diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2016-04-14 18:55:01 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2016-04-14 18:55:01 +0000 |
| commit | bde1393a7b0583bc123ac962ed2f729b80cd7498 (patch) | |
| tree | d9e8972ddece739bbdc248c5e33919ded2862cf7 /gcc/ada | |
| parent | 8f8a206e72c6183084a6792ae98593944dd06fbd (diff) | |
| download | gcc-bde1393a7b0583bc123ac962ed2f729b80cd7498.tar.gz | |
2016-04-14 Basile Starynkevitch <basile@starynkevitch.net>
{{merging with even more of GCC 6, using subversion 1.9
svn merge -r228401:229500 ^/trunk
}}
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@234985 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
408 files changed, 29977 insertions, 30816 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6703686c8e4..0065f944087 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,3328 @@ +2015-10-27 Tristan Gingold <gingold@adacore.com> + + * bindgen.adb (System_BB_CPU_Primitives_Multiprocessors_Used): + New variable. + (Gen_Adainit): Call Start_All_CPUs if the above + variable is set to true. + +2015-10-27 Emmanuel Briot <briot@adacore.com> + + * adaint.c, s-os_lib.adb, s-os_lib.ads (Copy_File_Attributes): New + subprogram. + +2015-10-27 Hristian Kirtchev <kirtchev@adacore.com> + + * namet.adb, namet.ads: Minor reformatting. + +2015-10-27 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Analyze_Allocator): Do not perform legality check + on allocators for limited objects in a qualified expression, + because expression has not been resolved. + * sem_res.adb (Resolve_Allocator): Perform check on legality of + limited objects after resolution. Add sem_ch3.adb to context. + +2015-10-27 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Refined_Global_In_Decl_Part): Add variable + States. + (Check_Refined_Global_Item): An object or state acts as a + constituent only when the corresponding encapsulating state + appears in pragma Global. + (Collect_Global_Item): Add a state with non-null visible refinement to + list States. + +2015-10-27 Gary Dismukes <dismukes@adacore.com> + + * sem_util.ads, par.adb, sem_ch6.adb: Minor reformatting and a few + typo corrections. + +2015-10-27 Pierre-Marie de Rodat <derodat@adacore.com> + + * namet.ads, namet.adb (Name_Equals): New function. + * namet.h (Name_Equals): New macro. + +2015-10-27 Arnaud Charlet <charlet@adacore.com> + + * exp_ch6.adb (Build_Procedure_Form): Use 'RESULT' for the extra + parameter, to avoid ambiguity when generating tmps using _xxx which + might end up reusing _result. + +2015-10-27 Javier Miranda <miranda@adacore.com> + + * sem_util.ads, sem_util.adb (Defining_Identifier): Adding a formal to + indicate the needed behavior in case of nodes with errors. + +2015-10-27 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Eval_Attribute): If the prefix of attribute + Enum_Rep is an object that is a generated loop variable for an + element iterator, no folding is possible. + * sem_res.adb (Resolve_Entity_Name): Do not check for a missing + initialization in the case of a constant that is an object + renaming. + * exp_attr.adb (Expand_N_Attribute_Reference, case Enum_Rep): + If the prefix is a constant that renames an expression there is + nothing to evaluate statically. + +2015-10-27 Vincent Celier <celier@adacore.com> + + * gnatlink.adb: Always delete the response file, even when the + invocation of gcc to link failed. + +2015-10-27 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): + Do not inherit the SPARK_Mode from the context if it has been + set already. + (Build_Subprogram_Declaration): Relocate relevant + pragmas from the subprogram body to the generated corresponding + spec. Do not copy aspect SPARK_Mode as this leads to circularity + in Copy_Separate_Tree. Inherit the attributes that describe + pragmas Ghost and SPARK_Mode. + (Move_Pragmas): New routine. + +2015-10-27 Hristian Kirtchev <kirtchev@adacore.com> + + * inline.adb (Is_Expression_Function): Removed. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): An internally + generated subprogram body that completes an expression function + inherits the SPARK_Mode from the spec. + * sem_res.adb (Resolve_Call): Update all calls to + Is_Expression_Function. + * sem_util.ads, sem_util.adb (Is_Expression_Function): Reimplemented. + (Is_Expression_Function_Or_Completion): New routine. + +2015-10-27 Hristian Kirtchev <kirtchev@adacore.com> + + * lib-xref-spark_specific.adb, a-dirval-mingw.adb, exp_ch6.adb, + sem_ch8.adb, s-os_lib.adb: Minor reformatting. + +2015-10-27 Yannick Moy <moy@adacore.com> + + * lib-xref-spark_specific.adb + (Enclosing_Subprogram_Or_Library_Package): detect library-level + subprograms and handle entries as subprograms, i.e. now both + library-level subprograms and entry bodies act as enclosing + scopes. + (Traverse_Declarations_Or_Statements): process entry bodies just + like subprogram bodies. + * lib-xref.ads (Enclosing_Subprogram_Or_Library_Package): comment + simplified while keeping its the meaning and minor typo fixed + ("of" -> "or"). + * spark_xrefs.ads (Xref Section): fix in description of the ALI + line for subprogram calls; such lines start with captial "F" + followed by a space. + +2015-10-27 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Find_Direct_Name): A parameter association is + a legal context for applying an implicit dereference. + (Analyze_Expanded_Name): Minor code cleanup. + +2015-10-27 Arnaud Charlet <charlet@adacore.com> + + * sinput.ads, spark_xrefs.ads, lib-xref.adb: Fix typos. + +2015-10-27 Pascal Obry <obry@adacore.com> + + * a-dirval-mingw.adb: Remove some characters from Invalid_Character set. + +2015-10-27 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Rewrite_Function_Call_For_C): Use a named + associaion for the added actual in the call because previous + actuals may also have been given by explicit associations. + * lib-xref.adb: Minor style fixes. + +2015-10-27 Arnaud Charlet <charlet@adacore.com> + + * gnat1drv.adb: Remove hard coded restrictions. + +2015-10-27 Pascal Obry <obry@adacore.com> + + * a-dirval-mingw.adb: Minor reformatting. + +2015-10-27 Javier Miranda <miranda@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Improve previous patch. + +2015-10-27 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch12.adb (Analyze_Formal_Package_Declaration): Code cleanup. Set + and restore the value of global flag Ignore_Pragma_SPARK_Mode. A + formal package declaration acts as a package instantation with + respect to SPARK_Mode legality. + +2015-10-27 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Check_Constituent_Usage): Use + logical operators rather than short circuit operators. Emit an + error when a state with visible refinement is not refined. + * snames.ads-tmpl: Add names for detecting + predefined potentially blocking subprograms. + +2015-10-27 Arnaud Charlet <charlet@adacore.com> + + * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Revert previous + change. + (Expand_Array_Aggregate): Rewrite previous change here + as done for other non GCC back-ends. + (Build_Record_Aggr_Code): Add special case. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Add_Item_To_Name_Buffer): Update the comment on usage. + Add an output string for loop parameters. + (Analyze_Global_Items): Loop parameters are now a + valid global item. The share the legality checks of constants. + (Analyze_Input_Output): Loop parameters are now a valid dependency item. + (Find_Role): Loop parameters share the role of constants. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Generalized_Indexing): In ASIS mode, + preserve the Generalized_ indexing link if the context is not + a spec expression that will be analyzed anew. + +2015-10-26 Javier Miranda <miranda@adacore.com> + + * exp_ch6.ads, exp_ch6.adb (Build_Procedure_Body_Form): Promote it to + library level (to invoke this routine from the semantic analyzer). + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): When generating + C code, invoke Build_Procedure_Body_Form to transform a function + that returns a constrained array type into a procedure with an + out parameter that carries the return value. + +2015-10-26 Arnaud Charlet <charlet@adacore.com> + + * a-reatim.ads: Add "Clock_Time with Synchronous" contract in package + Ada.Real_Time. + * a-taside.ads: Add "Tasking_State with Synchronous" contract in + package Ada.Task_Identification. + * sem_ch12.adb: minor typo in comment + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * contracts.adb (Analyze_Object_Contract): Set and restore + the SPARK_Mode for both constants and objects. Factor out the + semantic checks concerning Ghost objects. + * freeze.adb (Freeze_Array_Type): A Ghost array type cannot have a + concurrent component type. + (Freeze_Entity): A Ghost type cannot also be concurrent. + (Freeze_Record_Type): A Ghost record type cannot have a concurrent + component. + * sem_prag.adb (Analyze_Abstract_State): A Ghost abstract + state cannot also be synchronized. + (Check_Ghost_Synchronous): New routine. + * sem_util.adb (Yields_Synchronized_Object): Correct the case + of record components to account for the case where the type has + no component list. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * expander.adb (Expand): Expand a single protected declaration. + * exp_ch9.ads, exp_ch9.adb (Expand_N_Single_Protected_Declaration): New + routine. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Is_OK_Volatile_Context): A volatile object may appear + in an object declaration as long as it denotes the name. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch9.adb (Analyze_Single_Protected_Declaration): The anonymous + object no longer comes from source. + (Analyze_Single_Task_Declaration): The anonymous object no longer + comes from source. + * sem_prag.adb (Analyze_Pragma): The analysis of pragma SPARK_Mode + now recognizes the internal anonymous object created for a single + concurren type as a valid context. + (Find_Related_Context): The internal anonymous object created for a + single concurrent type is now a valid context. + (Find_Related_Declaration_Or_Body): The internal anonymous object + created for a single concurrent type is now a valid context. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Inherit_Rep_Item_Chain): Another another guard + to prevent circularities in the rep_item_chain of the full view + of a type extension in a child unit that extends a private type + from the parent. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * atree.ads, atree.adb (Ekind_In): New 10 and 11 parameter versions. + * contracts.ads, contracts.adb (Analyze_Initial_Declaration_Contract): + New routine. + * sem_ch6.adb (Analyze_Generic_Subprogram_Body): + Analyze the contract of the initial declaration. + (Analyze_Subprogram_Body_Helper): Analyze the contract of the + initial declaration. + * sem_ch7.adb (Analyze_Package_Body_Helper): Analyze the contract + of the initial declaration. + * sem_ch9.adb (Analyze_Entry_Body): Analyze the contract of + the initial declaration. + (Analyze_Protected_Body): Analyze + the contract of the initial declaration. + (Analyze_Task_Body): Analyze the contract of the initial declaration. + * sem_prag.adb (Add_Entity_To_Name_Buffer): Use "type" rather + than "unit" as it makes the error messages sound better. + (Add_Item_To_Name_Buffer): Update comment on usage. The routine + now supports discriminants and current instances of concurrent + types. + (Analyze_Depends_In_Decl_Part): Install the discriminants + of a task type. + (Analyze_Global_In_Decl_Part): Install the discriminants of a task type. + (Analyze_Global_Item): Add processing for current instances of + concurrent types and include discriminants as valid global items. + (Analyze_Input_Output): Discriminants and current instances of + concurrent types are now valid items. Update various error messages. + (Check_Usage): Current instances of protected and task types behaves + as formal parameters. + (Collect_Subprogram_Inputs_Outputs): There is + no longer need to manually analyze [Refined_]Global thanks to + freezing of initial declaration contracts. Add processing for + the current instance of a concurrent type. + (Find_Role): Add categorizations for discriminants, protected and task + types. + (Is_CCT_Instance): New routine. + (Match_Items): Update the comment on usage. Update internal comments. + * sem_prag.ads (Collect_Subprogram_Inputs_Outputs): Update the + comment on usage. + * sem_util.adb (Entity_Of): Ensure that the entity is an object + when traversing a potential renaming chain. + (Fix_Msg): Use "type" rather than "unit" as it makes the error messages + sound better. + * sem_util.ads (Fix_Msg): Update the comment on usage. + +2015-10-26 Arnaud Charlet <charlet@adacore.com> + + * par.adb (Par): Do not generate an error when generating + SCIL for predefined units or new children of system and co. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * einfo.adb: Access_Disp_Table applies to a private + extension. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Generalized_Indexing): In ASIS mode, when + restoring original node, remove Generalized_Indexing operation + so that it is recreated during re- analysis. + +2015-10-26 Javier Miranda <miranda@adacore.com> + + * exp_unst.adb: (Unnest_Subprogram): + Replace absolute references to 1 and 0 by their counterpart + relative references through Subps_First. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * par-ch3.adb (P_Declarative_Items): In case of misplaced + aspect specifications, ensure that flag Done is properly set to + continue parse. + * sem_prag.adb, sem_prag.ads: Remove Build_Generic_Class_Condition, + unused. + +2015-10-26 Emmanuel Briot <briot@adacore.com> + + * s-os_lib.adb (Argument_String_To_List): Remove backslashes in + argument value. + +2015-10-26 Javier Miranda <miranda@adacore.com> + + * exp_unst.ads, exp_unst.adb (Is_Uplevel_Referenced): Removed. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_util.adb, sem_aux.adb, exp_attr.adb, sem_eval.adb: Minor + reformatting. + * sem_util.adb, sem_ch5.adb: Minor reformatting. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.adb (Unnest_Subprogram): Add guard to prevent compiler + abort when handling a reference to a formal in an aspect of a + nested subprogram declaration as an uplevel reference. + +2015-10-26 Bob Duff <duff@adacore.com> + + * snames.ads-tmpl, aspects.adb, aspects.ads: Add the aspect and + pragma names and enter into relevant tables. + * sem_ch13.adb (Analyze_Aspect_Specifications): Analyze aspect + Predicate_Failure. + * sem_prag.adb (Predicate_Failure): Analyze pragma Predicate_Failure. + * exp_util.adb (Make_Predicate_Check): When building the Check + pragma, if Predicate_Failure has been specified, add the relevant + String argument to the pragma. + * par-prag.adb (Prag): Add Predicate_Failure to list of pragmas + handled during semantic analysis. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Assignment): If the left-hand side + is an indexed component with generalized indexing, discard + interpretation that yields a reference type, which is not + assignable. This prevent spurious ambiguities when the right-hand + side is an aggregate which does not provide a target type. + +2015-10-26 Bob Duff <duff@adacore.com> + + * exp_ch7.adb, exp_ch6.adb: Minor comment fix. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb (Move_Or_Merge_Aspects): Move all aspects related + to a single concurrent type declaration to the declaration + of the anonymous object if they qualify. + (Relocate_Aspect): Update comment on usage. + * aspects.ads Add new sectioon on aspect specifications on single + concurrent types. Add new table Aspect_On_Anonymous_Object_OK. + (Move_Or_Merge_Aspects): Udate the comment on usage. + * atree.adb (Elist36): New routine. + (Set_Elist36): New routine. + * atree.ads (Elist36): New routine along with pragma Inline. + (Set_Elist36): New routine along with pragma Inline. + * atree.h: Elist36 is now an alias for Field36. + * contracts.adb (Add_Contract_Item): Add processing + for protected units and extra processing for variables. + (Analyze_Object_Contract): Code cleanup. The processing of + Part_Of now depends on wherer the object is a constant or + a variable. Add processing for pragmas Depends and Global + when they apply to a single concurrent object. Verify that a + variable which is part of a single concurrent type has full + default initialization. Set/restore the SPARK_Mode of a single + concurrent object. + (Analyze_Protected_Contract): New routine. + * contracts.ads (Add_Contract_Item): Update the comment on usage. + (Analyze_Object_Contract): Update the comment on usage. + (Analyze_Protected_Contract): New routine. + (Analyze_Task_Contract): Update the comment on usage. + * einfo.adb Part_Of_Constituents now uses Elist10. + (Anonymous_Object): New routine. + (Contract): Code cleanup. + (Has_Option): Remove the assumption that the only simple + option is External. + (Is_Synchronized_State): New routine. + (Part_Of_Constituents): This attribute applies to + variables and uses Elist10. + (Set_Anonymous_Object): New routine. + (Set_Contract): Code cleanup. + (Set_Part_Of_Constituents): This attribute applies to variables and + uses Elist10. + (Set_SPARK_Aux_Pragma): Code cleanup. + (Set_SPARK_Aux_Pragma_Inherited): Code cleanup. + (Set_SPARK_Pragma): Code cleanup. This attribute applies to + variables. + (Set_SPARK_Pragma_Inherited): Code cleanup. This + attribute applies to variables. + (SPARK_Aux_Pragma): Code cleanup. + (SPARK_Aux_Pragma_Inherited): Code cleanup. + (SPARK_Pragma): Code cleanup. This attribute applies to variables. + (SPARK_Pragma_Inherited): Code cleanup. This attribute applies + to variables. + (Write_Field9_Name): Remove the output for Part_Of_Constituents. + (Write_Field10_Name): Add output for Part_Of_Constituents. + (Write_Field30_Name): Add output for Anonymous_Object. + (Write_Field34_Name): Output SPARK_Pragma + for protected types and variables. + * einfo.ads: New attributes Anonymous_Object and + Is_Synchronized_State along with usage in entities. Update + the documentation of attributes Contract Encapsulating_State + Part_Of_Constituents SPARK_Aux_Pragma SPARK_Aux_Pragma_Inherited + SPARK_Pragma SPARK_Pragma_Inherited (Anonymous_Object): New + routine along with pragma Inline. + (Is_Synchronized_State): New routine. + (Set_Anonymous_Object): New routine along with pragma Inline. + * freeze.adb (Freeze_Record_Type): Ensure that a non-synchronized + record does not have synchronized components. + * sem_ch3.adb (Analyze_Declarations): Code cleanup. Analyze the + contract of protected units. + * sem_ch9.adb Add with and use clauses for Sem_Prag. Code cleanup. + (Analyze_Single_Protected_Declaration): Reimplemented. + (Analyze_Single_Task_Declaration): Reimplemented. + * sem_ch13.adb (Analyze_Aspect_Specifications): Aspect Part_Of + can now apply to a single concurrent type declaration. Rely on + Insert_Pragma to place the pragma. Update the error message on + usage to reflect the new context. + (Insert_Pragma): When inserting + pragmas for a protected or task type, create a definition if + the type lacks one. + * sem_elab.adb (Check_A_Call): Code cleanup. Issue error message + related to elaboration issues for SPARK when SPARK_Mode is "on" + and the offending entity comes from source. + * sem_prag.adb (Analyze_Abstract_State): Add new flag + Synchronous_Seen. Update the analysis of simple options Externa, + Ghost and Synchronous. Update various error messages to reflect + the use of single concurrent types. + (Analyze_Depends_Global): Pragmas Depends and Global can now apply to + a single task type or a single concurrent object created for a task + type. + (Analyze_Depends_In_Decl_Part): Do not push a scope when the + context is a single concurrent object. (Analyze_Part_Of): + Moved out of Analyze_Pragma. The routine has a new profile + and comment on usage. + (Analyze_Part_Of_In_Decl_Part): New routine. + (Analyze_Part_Of_Option): Update the call to Analyze_Part_Of. + (Analyze_Pragma): Pragma Abstract_State can + now carry simple option Synchronous. Pragma Part_Of can now + apply to a single concurrent type declaration. The analysis + of pragma Part_Of is delayed when the context is a single + concurrent object. + (Analyze_Refined_Depends_In_Decl_Part): Use the anonymous object when + the context is a single concurren type. + (Analyze_Refined_Global_In_Decl_Part): Use the + anonymous object when the context is a single concurren type. + (Check_Ghost_Constituent): Removed. + (Check_Matching_Constituent): Renamed to Match_Constituent. + (Check_Matching_State): Renamed to Match_State. + (Collect_Constituent): Update the comment + on usage. Verify various legality rules related to ghost and + synchronized entities. + (Find_Related_Declaration_Or_Body): A single task declaration is no + longer a valid context for a pragma. + (Fix_Msg): Moved to Sem_Util. + (Process_Overloadable): Add processing for single task objects. + (Process_Visible_Part): Add processing for single concurrent + types. + (Relocate_Pragmas_To_Anonymous_Object): New routine. + * sem_prag.ads Add new table Pragma_On_Anonymous_Object_OK. + (Analyze_Part_Of_In_Decl_Part): New routine. + (Relocate_Pragmas_To_Anonymous_Object): New routine. + * sem_util.adb (Defining_Entity): Code cleanup. + (Fix_Msg): Moved from Sem_Prag and augmented to handle + mode replacements. + (Has_Full_Default_Initialization): New routine. + (Is_Descendant_Of_Suspension_Object): Moved out of + Is_Effectively_Volatile. + (Is_Single_Concurrent_Object): New routine. + (Is_Single_Concurrent_Type): New routine. + (Is_Single_Concurrent_Type_Declaration): New routine. + (Is_Synchronized_Object): New routine. + (Yields_Synchronized_Object): New routine. + * sem_util.ads (Fix_Msg): Moved form Sem_Prag. Update the + comment on usage. + (Has_Full_Default_Initialization): New routine. + (Is_Single_Concurrent_Object): New routine. + (Is_Single_Concurrent_Type): New routine. + (Is_Single_Concurrent_Type_Declaration): New routine. + (Is_Synchronized_Object): New routine. + (Yields_Synchronized_Object): New routine. + * snames.ads-tmpl: Add name Synchronous. + +2015-10-26 Jerome Lambourg <lambourg@adacore.com> + + * sysdep.c (__gnat_get_task_options): Refine the workaround for + the VX_USR_TASK_OPTION bug in VxWorks 7, as we cannot check the + value of VX_DEALLOC_TCB in RTP mode, the macro value not being + defined in the headers. + * g-arrspl.ads: Fix typo. + +2015-10-26 Jerome Lambourg <lambourg@adacore.com> + + * sysdep.c (__gnat_get_task_options): Workaround a VxWorks + bug where VX_DEALLOC_TCB task option is forbidden when calling + taskCreate but allowed in VX_USR_TASK_OPTIONS. + +2015-10-26 Javier Miranda <miranda@adacore.com> + + * exp_unst.ads, exp_unst.adb (Is_Uplevel_Referenced): New subprogram. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Constant_Indexing_OK): New predicate, subsidiary + of Try_Container_Indexing, that implements the name resolution + rules given in RM 4.1.6 (13-15). + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch3.adb, sem_util.adb: Minor reformatting. + +2015-10-26 Javier Miranda <miranda@adacore.com> + + * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Return False when + generating C code. + * sem_ch3.adb: Fix typos. + +2015-10-26 Bob Duff <duff@adacore.com> + + * sem_ch13.adb (Build_Predicate_Functions): Change the + structure of the predicate functions to reflect the requirements + of AI12-0071. + (Add_Condition): New procedure to do the "and-then-ing" in Add_Call + and Add_Predicates. + * einfo.ads (Static_Real_Or_String_Predicate): Change the + documentation to reflect the new structure. + * sem_eval.adb (Real_Or_String_Static_Predicate_Matches): + Change the walking of the predicate expression to reflect the + new structure. + * exp_util.adb: Minor comment fix. + +2015-10-26 Bob Duff <duff@adacore.com> + + * s-rident.ads (No_Dynamic_Sized_Objects): New restriction name. + * sem_util.ads, sem_util.adb (All_Composite_Constraints_Static): + New function to check that all relevant constraints are static. + * sem_aggr.adb (Resolve_Array_Aggregate): Call + All_Composite_Constraints_Static on the bounds of named array + aggregates. + * sem_ch3.adb (Analyze_Subtype_Declaration): Call + All_Composite_Constraints_Static if the type is composite and + the subtype is constrained. + +2015-10-26 Javier Miranda <miranda@adacore.com> + + * exp_ch6.adb (Expand_N_Subprogram_Declaration): Skip the frontend + transformation of functions that return a constrained array into + a procedure when they are unchecked_conversion instances. + +2015-10-26 Gary Dismukes <dismukes@adacore.com> + + * s-os_lib.ads: Minor reformatting/rewording. + +2015-10-26 Arnaud Charlet <charlet@adacore.com> + + * debug.adb: Introduce debug flag -gnatd.5. + +2015-10-26 Pascal Obry <obry@adacore.com> + + * s-os_lib.ads, s-os_lib.adb (Kill): New routine. This routine + makes visible support for killing processes in expect.c. + * expect.c (__gnat_kill): Removed from here. + * adaint.c (__gnat_kill): Added here to be usable in the compiler + (System.OS_Lib). + * make.adb (Sigint_Intercepted): Use the Kill routine from + System.OS_Lib. + +2015-10-26 Arnaud Charlet <charlet@adacore.com> + + * einfo.ads, einfo.adb, exp_unst.adb (Needs_Typedef, + Set_Needs_Typedef): Removed, no longer used. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb (First_Component): Update the assertion to allow + for concurrent types. + (First_Component_Or_Discriminant): Update the assertion to allow for + concurrent types. + * einfo.ads: Update the documentation of attributes First_Component + and First_Component_Or_Discriminant along with uses in entities. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Resolve_Actuals): An effectively + volatile object may act as an actual when the corresponding + formal is of a non-scalar effectively volatile type, not just + a non-scalar volatile type. + +2015-10-26 Bob Duff <duff@adacore.com> + + * sinfo.ads, sem_util.ads: Update comments. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Refined_Depends_Global_Post): When dealing with + protected entries or protected subprograms, use the enclosing protected + type to ensure that the protected type declaration is declared + in a package spec. Remove an obsolete attempt to ensure the + aggregate for of pragma Refined_State as this routine is never + called in that case. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_Iterator_Loop_Over_Container): For + an element iterator loop, the element is a constant if the + container object is a constant, even if the container type has + a Variable_Indexing aspect. + +2015-10-26 Bob Duff <duff@adacore.com> + + * s-fileio.adb (Fopen_Mode): Use "r+" for Out_File/Stream_IO, + so the file won't be truncated on 'fopen', as required by + AI95-00283-1. + +2015-10-26 Bob Duff <duff@adacore.com> + + * gnat1drv.adb, prj.adb, sem_ch6.adb, s-regpat.adb, + sem_prag.adb: Fix typos. + * einfo.ads, restrict.ads: Minor comment fixes. + * err_vars.ads, sem_util.adb, errout.ads: Code clean up. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Assignment): Do not check that the + Left-hand side is legal in an inlined body, check is done on + the original template. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * exp_util.ads, exp_util.adb (Find_Primitive_Operations): New + subprogram to retrieve by name the possibly overloaded set of + primitive operations of a type. + * sem_ch4.adb (Try_Container_Indexing): Use + Find_Primitive_Operations to handle overloaded indexing operations + of a derived type. + +2015-10-26 Arnaud Charlet <charlet@adacore.com> + + * osint-c.ads: Minor comment update. + +2015-10-26 Arnaud Charlet <charlet@adacore.com> + + * s-osinte-hpux.ads, s-osinte-aix.ads, s-osinte-solaris-posix.ads, + s-osinte-darwin.ads, s-osinte-android.ads, s-osinte-freebsd.ads, + s-taprop-posix.adb (Get_Page_Size): C function returns an int. Adjust + callers accordingly. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Is_OK_Object_Reference): New routine. + (Substitute_Valid_Check): Perform the 'Valid subsitution but do + not suggest the use of the attribute if the left hand operand + does not denote an object as it leads to illegal code. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_unst.adb: Minor reformatting. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb: Improve error msg. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_disp.adb (Check_Controlling_Type): Handle properly the + case of an incomplete type whose full view is tagged, when a + primitive operation of the type is declared between the two views. + +2015-10-26 Bob Duff <duff@adacore.com> + + * adaint.c (__gnat_locate_exec_on_path): If the PATH environment + variable is not set, do not return NULL, because we can still find + the executable if it includes a directory name. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_elab.adb (Elab_Warning): Under dynamic elaboration, when + elaboration warnings are enabled, emit proper warning header + when triggered by an access attribute. + +2015-10-26 Steve Baird <baird@adacore.com> + + * exp_ch11.adb: If CodePeer_Mode is true, generate simplified + SCIL for exception declarations. + * exp_ch11.adb (Expand_N_Exception_Declaration) If CodePeer_Mode + is True, initialize the Full_Name component of the exception + record to null instead of to the result of an unchecked + conversion. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.adb (Note_Uplevel_Ref) : Handle properly a reference + that denotes a function returning a constrained array, that has + been rewritten as a procedure. + * makeutl.ads: Minor edit. + +2015-10-26 Yannick Moy <moy@adacore.com> + + * lib-xref-spark_specific.adb (Traverse_Protected_Declaration): New + procedure for traversal. + (Add_SPARK_Xrefs): Remove debugging code. + (Traverse_Declaration_Or_Statement): Call the new traversal + procedure. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Pragma + Extensions_Visible can now appear on an abstract subprogram + declaration. + +2015-10-26 Yannick Moy <moy@adacore.com> + + * lib-xref-spark_specific.adb (Add_SPARK_Xrefs): Use character 'r' to + denote a reference to a constant which may have variable input, and + thus may be treated as a variable in GNATprove, instead of the + character 'c' used for constants. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Object_Access_Level): Only aliased formals of + functions have the accessibility level of the point of call; + aliased formals of procedures have the same level as unaliased + formals. + (New_Copy_Tree): Add guard on copying itypes. From code reading. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * inline.adb: Minor reformatting. + +2015-10-26 Yannick Moy <moy@adacore.com> + + * get_spark_xrefs.adb (get_SPARK_Xrefs): Remove obsolete + assertion. + * lib-xref-spark_specific.adb (Traverse_Declaration_Or_Statement): + New procedure to factor duplicated code and add + treatment of protected entries. + (Add_SPARK_Scope, Traverse_Declarations_Or_Statements): Call the new + procedure Traverse_Declaration_Or_Statement. Use same character used in + normal xrefs for SPARK xrefs, for a given entity used as scope. + * spark_xrefs.ads Document character used for entries. + * sem_prag.adb (Check_Loop_Pragma_Placement): Account for possible + introduction of declarations and statements by the expansion, between + two otherwise consecutive loop pragmas. + * sem_util.ads, sem_util.adb (Is_Suspension_Object): Lifted from nested + function. + (Is_Descendant_Of_Suspension_Object): nested function lifted. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_attr.adb (Eval_Attribute): Attribute 'Enum_Rep can be folded + when its prefix denotes a constant, an enumeration literal or + an enumeration type. Use the expression of the attribute in the + enumeration type form, otherwise use the prefix to fold. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb Add an entry for entry bodies in table + Has_Aspect_Specifications_Flag. + (Aspects_On_Body_Or_Stub_OK): Entry bodies now allow for certain + aspects. + * contracts.adb (Add_Contract_Items): Code cleanup. Add + processing for entry bodies, entry declarations and task units. + (Analyze_Subprogram_Body_Contract): Renamed + to Analyze_Entry_Or_Subprogram_Body_Contract. Do not + analyze the contract of an entry body unless annotating the + original tree. + (Analyze_Subprogram_Contract): Renamed to + Analyze_Entry_Or_Subprogram_Contract. Do not analyze the contract + of an entry declaration unless annotating the original tree. + (Analyze_Task_Contract): New routine. + * contracts.ads (Add_Contract_Item): Update the comment on usage. + (Analyze_Package_Body_Contract): Update comment on usage. + (Analyze_Package_Contract): Update the comment on usage. + (Analyze_Subprogram_Body_Contract): Renamed to + Analyze_Entry_Or_Subprogram_Body_Contract. + (Analyze_Subprogram_Body_Stub_Contract): Update the comment on usage. + (Analyze_Subprogram_Contract): Renamed to + Analyze_Entry_Or_Subprogram_Contract. + (Analyze_Task_Contract): New routine. + * einfo.adb (Contract): Restructure the assertion to include + entries and task units. + (SPARK_Pragma): This attribute now applies to operators. + (SPARK_Pragma_Inherited): This flag now applies to operators. + (Set_Contract): Restructure the assertion to include entries and task + units. + (Set_SPARK_Pragma): This attribute now applies to operators. + (Set_SPARK_Pragma_Inherited): This flag now applies to operators. + (Write_Field34_Name): Write out all Ekinds that have a contract. + (Write_Field40_Name): SPARK_Pragma now applies to operators. + * einfo.ads: Update the documentation of attribute Contract along + with usage in nodes. Update the documentation of attributes + SPARK_Pragma and SPARK_Pragma_Inherited. + * exp_ch6.adb (Freeze_Subprogram): Update the call to + Analyze_Subprogram_Contract. + * par-ch9.adb (P_Entry_Barrier): Do not parse keyword "is" as it + is not part of the entry barrier production. + (P_Entry_Body): Parse the optional aspect specifications. Diagnose + misplaced aspects. + * sem_attr.adb (Analyze_Attribute_Old_Result): Update the call + to Find_Related_Subprogram_Or_Body. + * sem_aux.adb (Unit_Declaration_Node) Add an entry for entry + declarations and bodies. + * sem_ch3.adb (Analyze_Declarations): Analyze the contracts of + entry declarations, entry bodies and task units. + * sem_ch6.adb (Analyze_Generic_Subprogram_Body): + Update the call to Analyze_Subprogram_Body_Contract. + (Analyze_Subprogram_Body_Helper): Update the call to + Analyze_Subprogram_Body_Contract. + * sem_ch9.adb (Analyze_Entry_Body): Analyze the aspect + specifications and the contract. + * sem_ch10.adb (Analyze_Compilation_Unit): Update the call to + Analyze_Subprogram_Contract. + * sem_ch12.adb (Save_References_In_Pragma): Update the call to + Find_Related_Subprogram_Or_Body. + * sem_ch13.adb (Analyze_Aspects_On_Body_Or_Stub): Use + Unique_Defining_Entity rather than rummaging around in nodes. + (Diagnose_Misplaced_Aspects): Update comment on usage. Update the + error messages to accomondate the increasing number of contexts. + * sem_prag.adb (Analyze_Contract_Cases_In_Decl_Part): + Update the call to Find_Related_Subprogram_Or_Body. + (Analyze_Depends_Global): Update the call to + Find_Related_Subprogram_Or_Body. Add processing for entry + declarations. + (Analyze_Depends_In_Decl_Part): Update the call + to Find_Related_Subprogram_Or_Body. Task units have no formal + parameters to install. (Analyze_Global_In_Decl_Part): Update + the call to Find_Related_Subprogram_Or_Body. Task units have no + formal parameters to install. + (Analyze_Global_Item): Use Fix_Msg to handle the increasing number of + contexts. + (Analyze_Pragma): Update the call to Find_Related_Subprogram_Or_Body. + Perform full analysis when various pragmas appear in an entry body. + (Analyze_Pre_Post_Condition): Update the call to + Find_Related_Subprogram_Or_Body. Perform full analysis when the pragma + appears in an entry body. + (Analyze_Pre_Post_Condition_In_Decl_Part): Update the call to + Find_Related_Subprogram_Or_Body. + (Analyze_Refined_Depends_Global_Post): Update + the call to Find_Related_Subprogram_Or_Body. Use + Fix_Msg to handle the increasing number of contexts. + (Analyze_Refined_Depends_In_Decl_Part): Update + the call to Find_Related_Subprogram_Or_Body. Use + Unique_Defining_Entity to obtain the entity of the + spec. Use Fix_Msg to handle the increasing number of contexts. + (Analyze_Refined_Global_In_Decl_Part): Update the call to + Find_Related_Subprogram_Or_Body. Use Unique_Defining_Entity to obtain + the entity of the spec. Use Fix_Msg to handle the increasing number of + contexts. + (Analyze_Test_Case_In_Decl_Part): Update the call to + Find_Related_Subprogram_Or_Body. + (Check_Dependency_Clause): Use Fix_Msg to handle the increasing number + of contexts. + (Check_Mode_Restriction_In_Enclosing_Context): Use + Fix_Msg to handle the increasing number of contexts. + (Collect_Subprogram_Inputs_Outputs): Use the refined + versions of the pragmas when the context is an entry body or + a task body. + (Find_Related_Subprogram_Or_Body): Renamed to + Find_Related_Declaration_Or_Body. Add processing for entries + and task units. + (Fix_Msg): New routine. + (Role_Error): Use Fix_Msg to handle the increasing number of contexts. + * sem_prag.ads (Find_Related_Subprogram_Or_Body): Renamed to + Find_Related_Declaration_Or_Body. Update the comment on usage. + * sem_util.adb (Is_Entry_Body): New routine. + (Is_Entry_Declaration): New routine. + * sem_util.ads (Is_Entry_Body): New routine. + (Is_Entry_Declaration): New routine. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * inline.adb (Has_Excluded_Declaration): A subtype declaration + with a predicate aspect generates a subprogram, and therefore + prevents the inlining of the enclosing subprogram. + * osint.ads: Fix typo. + + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_case.adb (Check_Choice_Set): Choose initial choice range + below low bound of type, to prevent spurious errors on case + statements whose expressions have an integer subtype with a + static predicate. + * sem_util.ads: Fix typo. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Expand_N_Case_Expression): In the scope of a + predicate function, delay the expansion of the expression only + if the target type has a specified Static_ Predicate aspect, + because the expression is processed later. A dynamic predicate + must be expanded in standard fashion. + +2015-10-26 Claire Dross <dross@adacore.com> + + * a-nudira.ads: Remove SPARK_Mode as it currently causes an error. + +2015-10-26 Arnaud Charlet <charlet@adacore.com> + + * sem_aggr.adb, sem_type.adb, sem_ch12.adb, sem_res.adb, sem_ch4.adb, + sem_ch8.adb, exp_aggr.adb, sem_eval.adb, s-fatgen.adb, a-tienio.adb: + Fix typos. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): The processing + for aspects Abstract_State, Ghost, Initial_Condition, Initializes + and Refined_State no longer have to take SPARK_Mode into account. + (Insert_After_SPARK_Mode): Removed. + (Insert_Pragma): Update profile and comment on usage. The routine can + now insert a pragma after the "header" of an instance. + * sem_prag.adb (Analyze_If_Available): New routine. + (Analyze_Pragma): Do not reset the Analyzed flag of various + SPARK pragmas as they use the Is_Analyzed_Pragma attribute to + avoid reanalysis. Various pragmas now trigger the analysis + of related pragmas that depend on or are dependent on the + current pragma. Remove the declaration order checks related + to pragmas Abstract_State, Initial_Condition and Initializes. + (Analyze_Pre_Post_Condition): Analyze pragmas SPARK_Mode and + Volatile_Function prior to analyzing the pre/postcondition. + (Check_Declaration_Order): Removed. + (Check_Distinct_Name): Ensure that a potentially duplicated pragma + Test_Case is not the pragma being analyzed. + (Is_Followed_By_Pragma): Removed. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb: Handle subprogram bodies without previous specs. + +2015-10-26 Claire Dross <dross@adacore.com> + + * a-nudira.ads: Specify appropriate SPARK_Mode so that the unit + can be used in SPARK code. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * contracts.adb (Analyze_Subprogram_Body_Contract): Do not analyze + pragmas Refined_Global and Refined_Depends because these pragmas + are now fully analyzed when encountered. + (Inherit_Pragma): Update the call to attribute Is_Inherited. + * sem_prag.adb (Analyze_Contract_Cases_In_Decl_Part): Add a guard + to prevent reanalysis. Mark the pragma as analyzed at the end of + the processing. + (Analyze_Depends_Global): New parameter profile + and comment on usage. Do not fully analyze the pragma, this is + now done at the outer level. + (Analyze_Depends_In_Decl_Part): Add a guard to prevent reanalysis. + Mark the pragma as analyzed at the end of the processing. + (Analyze_External_Property_In_Decl_Part): Add a guard to prevent + reanalysis. Mark the pragma as analyzed at the end of the processing. + (Analyze_Global_In_Decl_Part): Add a guard to prevent reanalysis. Mark + the pragma as analyzed at the end of the processing. + (Analyze_Initial_Condition_In_Decl_Part): Add a guard to prevent + reanalysis. Mark the pragma as analyzed at the end of the processing. + (Analyze_Initializes_In_Decl_Part): Add a guard to prevent reanalysis. + Mark the pragma as analyzed at the end of the processing. + (Analyze_Pragma): Reset the Analyzed flag on various pragmas that + require delayed full analysis. Contract_Cases is now analyzed + immediately when it applies to a subprogram body stub. Pragmas Depends, + Global, Refined_Depends and Refined_Global are now analyzed + in pairs when they appear in a subprogram body [stub]. + (Analyze_Pre_Post_Condition_In_Decl_Part): Add a guard to + prevent reanalysis. Mark the pragma as analyzed at the end of + the processing. + (Analyze_Refined_Depends_Global_Post): Update the comment on usage. + (Analyze_Refined_Depends_In_Decl_Part): Add a guard to prevent + reanalysis. Mark the pragma as analyzed at the end of the processing. + (Analyze_Refined_Global_In_Decl_Part): Add a guard to prevent + reanalysis. Mark the pragma as analyzed at the end of the processing. + (Analyze_Refined_State_In_Decl_Part): Add a guard to prevent + reanalysis. Mark the pragma as analyzed at the end of the processing. + (Analyze_Test_Case_In_Decl_Part): Add a guard to prevent reanalysis. + Mark the pragma as analyzed at the end of the processing. + (Is_Followed_By_Pragma): New routine. + * sinfo.adb (Is_Analyzed_Pragma): New routine. + (Is_Inherited): Renamed to Is_Inherited_Pragma. + (Set_Is_Analyzed_Pragma): New routine. + (Set_Is_Inherited): Renamed to Set_Is_Inherited_Pragma. + * sinfo.ads Rename attribute Is_Inherited to Is_Inherited_Pragma + and update occurrences in nodes. + (Is_Analyzed_Pragma): New routine along with pragma Inline. + (Is_Inherited): Renamed to Is_Inherited_Pragma along with pragma Inline. + (Set_Is_Analyzed_Pragma): New routine along with pragma Inline. + (Set_Is_Inherited): Renamed to Set_Is_Inherited_Pragma along + with pragma Inline. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * par-ch3.adb (P_Component_Items): When style checks are enabled, + apply them to component declarations in a record type declaration + or extension. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_util.adb (Is_Suspension_Object): Ensure that the scope of "Ada" + is Standard_Standard. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Is_OK_Volatile_Context): A subprogram call is an OK + context for a reference to an effectively volatile object. + (Resolve_Actuals): Add references to SPARK RM. + (Within_Procedure_Call): Removed. + (Within_Subprogram_Call): New routine. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Check_Aggregate_Accessibility): A reference to a + formal parameter in an aggregate does not need an accesibility + check only if the formal is aliased. + +2015-10-26 Claire Dross <dross@adacore.com> + + * sem_aux.ads (Number_Components): Can return 0 when called on + an empty record. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * contracts.adb (Analyze_Subprogram_Body_Contract): Use + Unique_Defining_Entity instead of Corresponding_Spec_Of. + * einfo.adb SPARK_Pragma and SPARK_Aux_Pragma are now Node40 and + Node41 respectively. + (SPARK_Aux_Pragma): Update the assertion and node querry. + (SPARK_Aux_Pragma_Inherited): Update the assertion and node query. + (SPARK_Pragma): Update the assertion and node query. + (SPARK_Pragma_Inherited): Update the assertion and node query. + (Set_SPARK_Aux_Pragma): Update the assertion and node setting. + (Set_SPARK_Aux_Pragma_Inherited): Update the assertion and node setting. + (Set_SPARK_Pragma): Update the assertion and node setting. + (Set_SPARK_Pragma_Inherited): Update the assertion and node setting. + (Write_Field32_Name): Remove the output for SPARK_Pragma. + (Write_Field33_Name): Remove the output for SPARK_Aux_Pragma. + (Write_Field40_Name): Add output for SPARK_Pragma. + (Write_Field41_Name): Add output for SPARK_Aux_Pragma. + * einfo.ads Rewrite the documentation on attributes + SPARK_Pragma, SPARK_Aux_Pragma, SPARK_Pragma_Inherited and + SPARK_Aux_Pragma_Inherited. Update their uses in nodes. + * exp_ch4.adb (Create_Anonymous_Master): Use + Unique_Defining_Entity instead of Corresponding_Spec_Of. + * exp_ch9.adb (Expand_Entry_Declaration): Mark the barrier + function as such. + (Expand_N_Task_Body): Mark the task body as such. + (Expand_N_Task_Type_Declaration): Mark the task body as such. + * exp_unst.adb (Visit_Node): Use Unique_Defining_Entity instead + of Corresponding_Spec_Of. + * sem_attr.adb (Analyze_Attribute_Old_Result): Use + Unique_Defining_Entity instead of Corresponding_Spec_Of. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Entry barrier + functions do not inherit the SPARK_Mode from the context. + (Build_Subprogram_Declaration): The matching spec is now marked + as a source construct to mimic the original stand alone body. + * sem_ch7.adb (Analyze_Package_Body_Helper): Code cleanup. + * sem_ch9.adb Add with and use clauses for Contracts. + (Analyze_Entry_Body): An entry body freezes the contract of + the nearest enclosing package body. The entry body now inherits + the SPARK_Mode from the context. + (Analyze_Entry_Declaration): A protected entry declaration now inherits + the SPARK_Mode from the context. + (Analyze_Protected_Body): A protected body freezes + the contract of the nearest enclosing package body. Set the + Etype of a protected body as this is neede for proper aspect + analysis. Protected bodies can now carry meaningful aspects and + those are now analyzed. + (Analyze_Protected_Type_Declaration): A protected type now inherits the + SPARK_Mode from the context. + (Analyze_Task_Body): A task body freezes the contract of the + nearest enclosing package body. Set the Etype of a task body + as this is needed for proper aspect analysis. A task body + now inherits the SPARK_Mode from the context. Task bodies + can now carry meaningful aspects and those are now analyzed. + (Analyze_Task_Type_Declaration): A task type declaration now + inherits the SPARK_Mode of from the context. + * sem_ch10.adb (Analyze_Protected_Body_Stub): Protected body + stubs can now carry meaningful aspects. + (Analyze_Task_Body_Stub): Task body stubs can now carry meaningful + aspects. + * sem_ch13.adb (Analyze_Aspect_Specifications): Aspects SPARK_Mode + Warnings now use routine Insert_Pragma as means of insertion into + the tree. + (Insert_After_SPARK_Mode): Clean up documentation. + (Insert_Pragma): Clean up documentation. The routine is now + capable of operating on synchronized units. + * sem_prag.adb (Add_Entity_To_Name_Buffer): New routine. + (Analyze_Contract_Cases_In_Decl_Part): Use + Unique_Defining_Entity instead of Corresponding_Spec_Of. + (Analyze_Depends_Global): Use Unique_Defining_Entity instead + of Corresponding_Spec_Of. + (Analyze_Depends_In_Decl_Part): Use Unique_Defining_Entity instead of + Corresponding_Spec_Of. + (Analyze_Global_In_Decl_Part): Use Unique_Defining_Entity instead of + Corresponding_Spec_Of. + (Analyze_Pragma): Use Unique_Defining_Entity instead of + Corresponding_Spec_Of. + Update the detection of an illegal pragma Ghost when it applies + to a task or protected unit. Reimplement the handling of + pragma SPARK_Mode. + (Analyze_Pre_Post_Condition_In_Decl_Part): Use Unique_Defining_Entity + instead of Corresponding_Spec_Of. + (Analyze_Test_Case_In_Decl_Part): Use Unique_Defining_Entity instead of + Corresponding_Spec_Of. + (Check_Library_Level_Entity): Update the comment on usage. + Reimplemented to offer a more specialized errror context. + (Check_Pragma_Conformance): Update profile and comment on usage. + Handle error message output on single protected or task units. + (Collect_Subprogram_Inputs_Outputs): Use Unique_Defining_Entity + instead of Corresponding_Spec_Of. + (Process_Body): New routine. + (Process_Overloadable): New routine. + (Process_Private_Part): New routine. + (Process_Statement_Part): New routine. + (Process_Visible_Part): New routine. + (Set_SPARK_Context): New routine. + (Set_SPARK_Flags): Removed. + * sem_util.adb (Corresponding_Spec_Of): Removed. + (Unique_Entity): Reimplemented to handle many more cases. + * sem_util.ads (Corresponding_Spec_Of): Removed. + (Unique_Defining_Entity): Update the comment on usage. + * sinfo.ads (Is_Entry_Barrier_Function): Update the assertion. + (Is_Task_Body_Procedure): New routine. + (Set_Is_Entry_Barrier_Function): Update the assertion. + (Set_Is_Task_Body_Procedure): New routine. + * sinfo.adb Update the documentation of attribute + Is_Entry_Barrier_Function along with use in nodes. Add new + attribute Is_Task_Body_Procedure along with use in nodes. + (Is_Task_Body_Procedure): New routine along with pragma Inline. + (Set_Is_Task_Body_Procedure): New routine along with pragma Inline. + +2015-10-26 Gary Dismukes <dismukes@adacore.com> + + * sem_ch13.adb: Minor reformatting. + +2015-10-26 Steve Baird <baird@adacore.com> + + * exp_disp.adb: Omit most dispatch table initialization code + if Generate_SCIL is true. + +2015-10-26 Arnaud Charlet <charlet@adacore.com> + + * sinfo.ads, exp_ch3.adb: Revert previous change. + (Build_Record_Init_Proc): Do not build an aggregate if + Modify_Tree_For_C. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Find_Corresponding_Spec): Reject a subprogram + body whose signature is type conformant with a previous expression + function. + +2015-10-26 Bob Duff <duff@adacore.com> + + * treepr.adb: Code clean up. + +2015-10-26 Eric Botcazou <ebotcazou@adacore.com> + + * freeze.adb (Check_Component_Storage_Order): Skip a record + component if it has Complex_Representation. + (Freeze_Record_Type): If the type has Complex_Representation, skip the + regular treatment of Scalar_Storage_Order attribute and instead issue + a warning if it is present. + +2015-10-26 Bob Duff <duff@adacore.com> + + * sem_ch13.adb (Check_Iterator_Functions): For a Default_Iterator + aspect, make sure an implicitly declared interpretation is + overridden by an explicit one. + * sem_util.ads: Update comment. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch7.adb, sem_ch6.adb (Analyze_Subprogram_Body_Helper): Only source + bodies should "freeze" the contract of the nearest enclosing + package body. + +2015-10-26 Joel Brobecker <brobecker@adacore.com brobecker> + + * adaint.c (__gnat_lwp_self): Replace current implementation re-using + the Linux one, which uses an __NR_gettid syscall rather than + pthread_self. + +2015-10-26 Arnaud Charlet <charlet@adacore.com> + + * sinfo.ads, exp_ch3.adb (Build_Array_Init_Proc, + Build_Record_Init_Proc): Do not inline init procs when + Modify_Tree_For_C is True. + +2015-10-26 Bob Duff <duff@adacore.com> + + * errout.ads: Minor comment fix. + * einfo.ads: Minor style fix. + +2015-10-26 Bob Duff <duff@adacore.com> + + * sem_ch3.adb (Derive_Interface_Subprogram): Fix + Is_Abstract_Subprogram, which might have been calculated + incorrectly, because we're passing Ultimate_Alias (Subp) (and + its dispatching type) to Derive_Subprogram, instead of the true + parent subprogram and type. + +2015-10-26 Bob Duff <duff@adacore.com> + + * sem_ch13.adb (Check_Iterator_Functions): When + printing the "default iterator must be unique" error message, + also print references to the places where the duplicates are + declared. This makes the message clearer. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Analyze_Formal_Package_Declaration): Do not set + Box_Present when the formal part is (others => <>) even though + it is equivalent to a formal part (<>), because ASIS tools depend + on the syntactic setting of this flag. + +2015-10-26 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch13.adb: Minor reformatting. + * einfo.ads: Minor typo. + +2015-10-26 Joel Brobecker <brobecker@adacore.com brobecker> + + * adaint.c (__gnat_open_new_temp): Use mkstemp on Android. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Analyze_Formal_Package_Declaration): Code clean up. + * sem_ch13.adb (Check_Inherited_Indexing): New inner procedure + of Check_Indexing_Functions, to verify that a derived type with an + Indexing aspect is not inheriting such an aspect from an ancestor. + (Check_Indexing_Functions): Call Check_Inherited_Indexing within + an instance. + +2015-10-26 Gary Dismukes <dismukes@adacore.com> + + * a-reatim.adb, contracts.adb, contracts.ads: Minor reformatting and + typo corrections. + +2015-10-26 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): Do not + recheck the consistency betwen the freeze point and the end of + declarations for the expression in an aspect specification, + because it was done already in the analysis of the generic. + Furthermore, the delayed analysis of an aspect of the instance + may produce spurious errors when the generic is a child unit + that references entities in the parent (which might not be in + scope at the freeze point of the instance). + +2015-10-26 Yannick Moy <moy@adacore.com> + + * sem_res.adb (Resolve_Call): Issue info message + instead of warning when call cannot be inlined in GNATprove mode. + +2015-10-26 Arnaud Charlet <charlet@adacore.com> + + * exp_ch6.adb (Build_Procedure_Form): Use _result as the + name of the extra parameter, cleaner than a random temp name. + * gnat1drv.adb (Gnat1drv): Code clean up. + +2015-10-24 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils2.c (build_binary_op): Tweak formatting. + (build_unary_op): Likewise. + +2015-10-23 Arnaud Charlet <charlet@adacore.com> + + * gnat_rm.texi, gnat_ugn.texi: Regenerate. + * doc/share/ada_pygments.py, doc/gnat_ugn/gnat_project_manager.rst, + doc/gnat_ugn/building_executable_programs_with_gnat.rst, + doc/gnat_ugn/gnat_and_program_execution.rst, + doc/gnat_rm/implementation_defined_attributes.rst, + doc/gnat_rm/standard_and_implementation_defined_restrictions.rst, + doc/gnat_rm/representation_clauses_and_pragmas.rst, + doc/gnat_rm/implementation_defined_pragmas.rst, + doc/gnat_rm/about_this_guide.rst, + doc/gnat_rm/implementation_of_ada_2012_features.rst, + doc/gnat_rm/implementation_of_specific_ada_features.rst, + doc/gnat_rm/implementation_defined_aspects.rst, + doc/gnat_rm/implementation_advice.rst: Update documentation. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * contracts.ads, contracts.adb: New unit. + * exp_ch6.adb Add with and use clauses for Contracts. + (Expand_Subprogram_Contract): Moved to Contracts. + * exp_ch6.ads (Expand_Subprogram_Contract): Moved to Contracts. + * sem_ch3.adb Add with and use clauses for Contracts. + (Analyze_Object_Contract): Moved to Contracts. + (Analyze_Declarations): Remove local variable Pack_Decl. Do not + capture global references in contracts. Check the hidden states + of a package body. + * sem_ch6.adb Add with and use clauses in Contracts. + (Analyze_Generic_Subprogram_Body): Do not capture global + references in contracts. + (Analyze_Subprogram_Body_Contract): + Moved to Contracts. + (Analyze_Subprogram_Body_Helper): Freeze the + contract of the nearest enclosing package body. Always analyze + the subprogram body contract. Do not expand the subprogram + body contract. + (Analyze_Subprogram_Contract): Moved to Contracts. + * sem_ch6.ads (Analyze_Subprogram_Body_Contract): Moved to Contracts. + (Analyze_Subprogram_Contract): Moved to Contracts. + * sem_ch7.adb Add with and use clauses for Contracts. + (Analyze_Package_Body_Contract): Moved to Contracts. + (Analyze_Package_Body_Helper): Freeze the contract of the + nearest enclosing package body. + (Analyze_Package_Contract): Moved to Contracts. + * sem_ch7.ads (Analyze_Package_Body_Contract): Moved to Contracts. + (Analyze_Package_Contract): Moved to Contracts. + * sem_ch10.adb Add with and use clauses for Contracts. + (Analyze_Compilation_Unit): Do not capture global references + in contracts. + (Analyze_Subprogram_Body_Stub_Contract): Moved to Contracts. + * sem_ch10.ads (Analyze_Subprogram_Body_Stub_Contract): Moved + to Contracts. + * sem_ch12.adb Add with and use clauses for Contracts. + (Analyze_Subprogram_Instantiation): Update the call to + Instantiate_Subprogram_Contract. + (Instantiate_Package_Body): + Do not copy the entity of the spec when creating an entity + for the body. Construct a brand new defining identifier for + the body and inherit the Comes_From_Source flag from the spec. + (Instantiate_Subprogram_Body): Remove Anon_Id to Act_Decl_Id + and update all occurrences. Construct a brand new defining + identifier for the body and inherit the Comes_From_Source + flag from the spec. + (Instantiate_Subprogram_Contract): Moved + to Contracts. + (Save_Global_References_In_Aspects): Moved to + the spec of Sem_Ch12. + (Save_Global_References_In_Contract): + Moved to Contracts. + * sem_ch12.ads (Save_Global_References_In_Aspects): Moved from + the body of Sem_Ch12. + (Save_Global_References_In_Contract): + Moved to Contracts. + * sem_prag.adb Add with and use clauses for Contracts. + (Add_Item): Removed. All references to this routine have been + replaced with calls to Append_New_Elmt. + (Analyze_Constituent): + Add special diagnostics for errors caused by freezing of + contracts. + (Analyze_Refined_State_In_Decl_Part): Add formal + parameter Freeze_Id. Add new global variable Freeze_Posted. + (Collect_Body_States): Removed. + (Report_Unused_States): Removed. + * sem_prag.ads (Analyze_Defined_State_In_Decl_Part): Add formal + parameter Freeze_Id and update comment on usage. + * sem_util.adb Remove with and use clauses for + Sem_Ch12. + (Add_Contract_Item): Moved to Contracts. + (Check_Unused_Body_States): New routine. + (Collect_Body_States): + New routine. + (Create_Generic_Contract): Moved to Contracts. + (Inherit_Subprogram_Contract): Moved to Contracts. + (Report_Unused_Body_States): New routine. + * sem_util.ads (Add_Contract_Item): Moved to Contracts. + (Check_Unused_Body_States): New routine. + (Collect_Body_States): New routine. + (Create_Generic_Contract): Moved to Contracts. + (Inherit_Subprogram_Contract): Moved to Contracts. + (Report_Unused_Body_States): New routine. + * sinfo.adb (Is_Expanded_Contract): New routine. + (Set_Is_Expanded_Contract): New routine. + * sinfo.ads New attribute Is_Expanded_Contract along with + placement in nodes. + (Is_Expanded_Contract): New routine along + with pragma Inline. + (Set_Is_Expanded_Contract): New routine + along with pragma Inline. + * gcc-interface/Make-lang.in: Add entry for contracts.o + +2015-10-23 Bob Duff <duff@adacore.com> + + * bindgen.adb, init.c, opt.ads, switch-b.adb: Implement new -Ea and + -Es switches. + * switch-b.ads: Minor comment fix. + * bindusg.adb: Document new -Ea and -Es switches. + * s-exctra.ads: Use -Es instead of -E. + +2015-10-23 Tristan Gingold <gingold@adacore.com> + + * gcc-interface/utils2.c (build_call_alloc_dealloc): Check no implicit + task and protected object restrictions. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch12.adb, exp_ch6.adb: Minor reformatting. + +2015-10-23 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.adb: Minor reformatting. + +2015-10-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Check_Formal_Packages): A formal package whose + actual part is (others => <>) os identical to a formal package + with an actual part written as (<>). + +2015-10-23 Arnaud Charlet <charlet@adacore.com> + + * a-reatim.adb ("/"): For Time_Span division convert the operands + to integers and then use integer division, which conforms to + the rounding required by Ada RM. + +2015-10-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Check_Missing_Return): Do not report a missing + return statement on a function body constructed to complete a + package body for a premature instantiation. + +2015-10-23 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Build_Procedure_Body_Form): Replace body of + original function with that of generated procedure, to simplify + processing and avoid scoping problems with local declarations. + (Rewrite_Function_Call_For_C): Handle properly the case of a + parameterless function. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * a-exextr.adb, sem_ch6.adb, sem_ch13.adb: Minor reformatting. + +2015-10-23 Arnaud Charlet <charlet@adacore.com> + + * s-taskin.ads: Minor code clean up. + (Ada_Task_Control_Block): Move fixed size field before variable sized + ones. + * einfo.ads: Minor editing. + +2015-10-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Check_Aggregate_Accessibility): Apply rule in RM + 6.5 (8.3) to verify that access discriminants in an aggregate + in a return statement have the proper accessibility, i.e. do + not lead to dangling references. + +2015-10-23 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Add missing + test on Address_Clause_Overlay_Warnings to the "constant overlays + variable" warning. For the reverse case, also issue a warning if + the modification is potentially made through the initialization + of the variable. + +2015-10-23 Jose Ruiz <ruiz@adacore.com> + + * a-exetim-posix.adb (Clock): Use the pthread_getcpuclockid + function to have access to CPU clocks for tasks other than the + calling task. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * debug.adb: Switch -gnatd.5 is no longer in use, remove the + associated documentation. + * exp_dbug.adb (Get_External_Name): Do not add a special prefix + for ignored Ghost entities or when switch -gnatd.5 is enabled. + * exp_dbug.ads Remove the documentation concerning the encoding + of ignored Ghost entities. + +2015-10-23 Bob Duff <duff@adacore.com> + + * a-exextr.adb (Notify_Exception): For Unhandled_Raise_In_Main, + mimic the output from Ada.Exceptions.Last_Chance_Handler; don't + print "Exception raised". + * s-stalib.ads, s-exctra.ads, s-exctra.adb: Add + Unhandled_Raise_In_Main to types Exception_Trace_Kind/Trace_Kind. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_attr.adb, freeze.adb, sem_attr.adb, exp_aggr.adb, + gnatname.adb: Minor reformatting. + +2015-10-23 Steve Baird <baird@adacore.com> + + * a-cbdlli.ads, a-cbhama.ads, a-cbhase.ads, a-cbmutr.ads, + a-cborma.ads, a-cborse.ads, a-cbprqu.ads, a-cbsyqu.ads, + a-cdlili.ads, a-cfdlli.ads, a-cfhama.ads, a-cfhase.ads, + a-cfinve.ads, a-cforma.ads, a-cforse.ads, a-cidlli.ads, + a-cihama.ads, a-cihase.ads, a-cimutr.ads, a-ciorma.ads, + a-ciormu.ads, a-ciorse.ads, a-coboho.ads, a-cobove.ads, + a-cofove.ads, a-cohama.ads, a-cohase.ads, a-coinho.ads, + a-coinho-shared.ads, a-coinve.ads, a-comutr.ads, a-conhel.ads, + a-convec.ads, a-coorma.ads, a-coormu.ads, a-coorse.ads, + a-cuprqu.ads, a-cusyqu.ads, a-rbtgbo.ads: Add spec Annotate + pragmas. + * a-cbdlli.adb, a-cbhama.adb, a-cbhase.adb, a-cbmutr.adb, + a-cborma.adb, a-cborse.adb, a-cbprqu.adb, a-cbsyqu.adb, + a-cdlili.adb, a-cfdlli.adb, a-cfhama.adb, a-cfhase.adb, + a-cfinve.adb, a-cforma.adb, a-cforse.adb, a-cidlli.adb, + a-cihama.adb, a-cihase.adb, a-cimutr.adb, a-ciorma.adb, + a-ciormu.adb, a-ciorse.adb, a-coboho.adb, a-cobove.adb, + a-cofove.adb, a-cohama.adb, a-cohase.adb, a-coinho.adb, + a-coinho-shared.adb, a-coinve.adb, a-comutr.adb, a-conhel.adb, + a-convec.adb, a-coorma.adb, a-coormu.adb, a-coorse.adb, + a-cuprqu.adb, a-cusyqu.adb, a-rbtgbo.adb: Remove body Annotate + pragmas. + +2015-10-23 Vincent Celier <celier@adacore.com> + + * gnatname.adb: When gnatname is invoked with a project file, + specified with switch -P, if gprname is available, gnatname will + invoke gprname, with the target if it is a cross gnatname. + +2015-10-23 Arnaud Charlet <charlet@adacore.com> + + * exp_ch4.adb: Fix typo. + * exp_ch6.adb: Update comment. + * exp_attr.adb (Expand_Min_Max_Attribute): Simplify expansion. + * exp_aggr.adb (Convert_To_Positional): Only convert to + positional when generating C in case of an object declaration. + (In_Object_Declaration): New. + (Late_Expansion): Adapt to trees generated by Modify_Tree_For_C. + * sinfo.ads: Update documentation. + +2015-10-23 Joel Brobecker <brobecker@adacore.com brobecker> + + * sigtramp.h (struct sigcontext, struct ucontext): Remove declarations, + and replace them by include of corresponding header file. + +2015-10-23 Bob Duff <duff@adacore.com> + + * a-convec.adb (Copy): Make sure C is initialized + on all paths, including when Checks is False. + +2015-10-23 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Remove + error as unreachable. + +2015-10-23 Arnaud Charlet <charlet@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Adjust. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_dbug.ads, exp_dbug.adb (Get_External_Name): The special prefix for + ignored Ghost entities is now ___ghost_. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * ghost.adb (Is_Subject_To_Ghost): Check the + original node when searching for pragma Ghost to catch cases + where a source construct has been rewritten into something else. + +2015-10-23 Ed Schonberg <schonberg@adacore.com> + + * einfo.ads, einfo.adb (Rewritten_For_C): New flag on functions + that return a constrained array type. When generating C these + functions are rewritten as procedures with an out parameter, + and calls to such functions are rewritten accordingly. + * exp_ch6.adb (Expand_N_Subprogram_Declaration): When + Modify_Tree_For_C is set and the function returns a constrained + array type, generate a procedure declaration with an additional + out parameter. Mark original function as Rewritten_For_C. + The new declaration is inserted in tree immediately after + current declaration. + (Expand_Subprogram_Body): If entity is marked Rewritten_For_C, + generate body of corresponding procedure using declarations + and statements for function body. Replace return statements + with assignments to the out parameter, followed by a simple + return statement. + (Rewrite_Function_Call_For_C): New procedure to replace a function + call that returns an array by a procedure call. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_util.adb (Denotes_Iterator): New routine. + (Is_Iterator): Code cleanup. Factor out the detection of a + predefined iterator. As a result this fixes a missing case + where a tagged type implements interface Reversible_Iterator. + +2015-10-23 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Eval_Attribute): Constant-fold 'Enabled if + not within a generic unit, even if expander is not active, so + that instances of container packages remain preelaborable in + -gnatc mode. + +2015-10-23 Tristan Gingold <gingold@adacore.com> + + * init.c (__gnat_sigtramp): New assembly function for arm64-darwin. + (__gnat_error_handler): Use trampoline for arm64. + +2015-10-23 Ed Schonberg <schonberg@adacore.com> + + * exp_ch3.adb (Expand_N_Object_Declaration): if the type of the + object is a class-wide limited interface type, the expression + is not restricted to the forms specified for limited types. + +2015-10-23 Vincent Celier <celier@adacore.com> + + * gnatname.adb: Code clean up. + * s-taasde.ads: Fix comment. + +2015-10-23 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Is_Iterator, Is_Reversible_iterator): Use + root type to determine whether the type is a descendant of the + corresponding interface type, so take into account multiple + levels of subtypes and derivations. + +2015-10-23 Olivier Hainque <hainque@adacore.com> + + * tracebak.c: Refine selection of GCC/GENERIC_UNWINDER for + tracebacks on x86 & x86_64. + (x86 & x86_64): If !SJLJ, always pick the + GCC_UNWINDER for x86_64 (not only on linux). + * sem_util.ads: Minor fix in comment. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Pragma Volatile_Function should + not apply to a function instantiation. + * sem_util.adb (Has_Effectively_Volatile_Profile): New routine. + (Is_Volatile_Function): An instance of Ada.Unchecked_Conversion + is a volatile function when its profile contains an effectively + volatile type. + * sem_util.ads (Has_Effectively_Volatile_Profile): New routine. + +2015-10-23 Arnaud Charlet <charlet@adacore.com> + + * exp_unst.adb (Unnest_Subprogram): Complete previous + change and update comments. + +2015-10-23 Ed Schonberg <schonberg@adacore.com> + + * sem_util.ads, sem_util.adb (Check_Function_With_Address_Parameter): + A subprogram that has an Address parameter and is declared in a Pure + package is not considered Pure, because the parameter may be used as a + pointer and the referenced data may change even if the address value + itself does not. + * freeze.adb (Freeze_Subprogram): use it. + * exp_ch6.adb (Expand_N_Subprogram_Body): Use it. + +2015-10-23 Olivier Hainque <hainque@adacore.com> + + * tracebak.c: Fallback to generic unwinder for gcc-sjlj on x86 & + x86_64 linux + * tracebak.c: Rework x86 & x86_64 sections to resort to the + generic unwinder if __USING_SJLJ_EXCEPTIONS__. + +2015-10-23 Javier Miranda <miranda@adacore.com> + + * sem_util.adb (Check_Function_Writable_Actuals): For function + calls restrict the check to elementary types, as requested by + RM 6.4.1(6.15/3) + +2015-10-23 Arnaud Charlet <charlet@adacore.com> + + * exp_unst.adb (Unnest_Subprogram): Suppress initialization on + Decl_ARECnT since we are taking care of all initializations in + the generated code. + +2015-10-23 Ed Schonberg <schonberg@adacore.com> + + * sem_dim.adb (Analyze_Dimension_Extension_Or_Record_Aggregate): + Handle properly a box-initialized aggregate component. + +2015-10-23 Yannick Moy <moy@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Reject Volatile_Function not placed + on a function. + +2015-10-23 Yannick Moy <moy@adacore.com> + + * a-extiin.ads, a-reatim.ads, a-interr.ads, a-exetim-mingw.ads, + a-exetim-default.ads, a-exetim.ads, a-taside.ads: Add "Global => null" + contract on subprograms. + * lib-xref-spark_specific.adb: collect scopes for stubs of + protected objects + +2015-10-23 Arnaud Charlet <charlet@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Enable + Back_Annotate_Rep_Info to get size information from gigi. + (Gnat1drv): Code clean ups. + * frontend.adb (Frontend): Ditto. + +2015-10-23 Arnaud Charlet <charlet@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Adjust settings. + * sem.adb (Semantics): Remove special case. + +2015-10-23 Gary Dismukes <dismukes@adacore.com> + + * bindgen.adb, restrict.adb: Minor spelling/grammar fixes. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Resolve_Entity_Name): Code cleanup. Check for possible + elaboration issues in SPARK when the name denotes a source variable. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Process_Transient_Objects): Reimplement to properly + handle restriction No_Exception_Propagation. + * exp_ch11.adb (Expand_At_End_Handler): Update the parameter + profile and all references to Block. + * exp_ch11.ads (Expand_At_End_Handler): Update the parameter + profile and comment on usage. + * exp_intr.adb (Expand_Unc_Deallocation): Reimplement to properly + handle restriction No_Exception_Propagation. + * gnat1drv.adb, restrict.adb: Update comment. + +2015-10-23 Bob Duff <duff@adacore.com> + + * exp_ch6.adb (Expand_N_Extended_Return_Statement): Do not call + SS_Release for a block statement enclosing the return statement in the + case where a build-in-place function return is returning + the result on the secondary stack. This is accomplished by + setting the Sec_Stack_Needed_For_Return flag on such blocks. + It was already being set for the function itself, and it was + already set correctly for blocks in the non-build-in-place case + (in Expand_Simple_Function_Return). + (Set_Enclosing_Sec_Stack_Return): New procedure to perform + the Set_Sec_Stack_Needed_For_Return calls. Called in the + build-in-place and non-build-in-place cases. + (Expand_Simple_Function_Return): Call + Set_Enclosing_Sec_Stack_Return instead of performing the loop + in line. + +2015-10-23 Bob Duff <duff@adacore.com> + + * scng.adb (Char_Literal_Case): If an apostrophe + follows a reserved word, treat it as a lone apostrophe, rather + than the start of a character literal. This was already done for + "all", but it needs to be done also for (e.g.) "Delta". + +2015-10-23 Bob Duff <duff@adacore.com> + + * exp_strm.adb (Build_Record_Or_Elementary_Input_Function): Use + Underlying_Type for B_Typ, in case the Typ is a subtype of a type with + unknown discriminants. + * g-awk.ads: Minor style fix in comment + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * debug.adb: Document the use of debug switch -gnatd.5. + * einfo.adb: Code reformatting. (Is_Ghost_Entity): Moved from ghost.adb. + * einfo.ads New synthesized attribute Is_Ghost_Enity along + with usage in nodes and pragma Inline. + (Is_Ghost_Entity: Moved from ghost.ads. + * exp_ch3.adb Code reformatting. + (Expand_Freeze_Array_Type): Capture, set and restore the Ghost mode. + (Expand_Freeze_Class_Wide_Type): Capture, set and restore the + Ghost mode. + (Expand_Freeze_Enumeration_Type): Capture, set and + restore the Ghost mode. + (Expand_Freeze_Record_Type): Capture, set and restore the Ghost mode. + * exp_ch6.adb (Expand_Subprogram_Contract): Do not expand the + contract of an ignored Ghost subprogram. + * exp_ch13.adb Add with and use clauses for Ghost. + (Expand_N_Freeze_Entity): Capture, set and restore the Ghost mode. + * exp_dbug.adb (Get_External_Name): Code reformatting. Add a + special prefix for ignored Ghost entities or when requested by + -gnatd.5 for any Ghost entity. + * exp_dbug.ads Document the use of prefix "_ghost_" for ignored + Ghost entities. + * exp_prag.adb (Expand_Pragma_Check): Capture, set and restore the + Ghost mode. + (Expand_Pragma_Loop_Variant): Use In_Assertion_Expr + to signal the original context. + * ghost.adb (Check_Ghost_Overriding): Code cleanup. + (Is_Ghost_Entity): Moved to einfo.adb. (Is_OK_Declaration): + Move the assertion expression check to the outer level. + (Is_OK_Ghost_Context): An assertion expression is a valid Ghost + context. + * ghost.ads (Is_Ghost_Entity): Moved to einfo.ads. + * sem_ch3.adb (Analyze_Object_Contract): A source Ghost object + cannot be imported or exported. Mark internally generated objects + as Ghost when applicable. + (Make_Class_Wide_Type): Inherit the ghostness of the root tagged type. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Mark + a stand alone subprogram body as Ghost when applicable. + (Analyze_Subprogram_Declaration): Mark internally generated + subprograms as Ghost when applicable. + * sem_ch7.adb: Code cleanup. + * sem_ch13.adb (Add_Invariants): Add various formal + parameters to break dependency on global variables. + (Build_Invariant_Procedure): Code cleanup. Capture, set and + restore the Ghost mode. + * sem_res.adb (Resolve_Actuals): The actual parameter of a source + Ghost subprogram whose formal is of mode IN OUT or OUT must be + a Ghost variable. + +2015-10-23 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch8.adb Code cleanup. + (Find_Expanded_Name): Replace + the call to In_Pragmas_Depends_Or_Global with a call to + In_Abstract_View_Pragma. + (In_Abstract_View_Pragma): New routine. + (In_Pragmas_Depends_Or_Global): Removed. + * sem_prag.adb (Analyze_Part_Of): Catch a case where indicator + Part_Of denotes the abstract view of a variable. + +2015-10-23 Arnaud Charlet <charlet@adacore.com> + + * sem_util.ads (Unique_Defining_Entity): Document the result + for tasks and entries. + * sem_util.adb (Unique_Entity): Return declaration entity for task and + entry bodies + +2015-10-22 Mikhail Maltsev <maltsevm@gmail.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity): Use gcc_checking_assert. + * gcc-interface/trans.c (assoc_to_constructor): Use flag_checking. + * gcc-interface/utils.c (relate_alias_sets): Likewise. + * gcc-interface/utils2.c (build_binary_op, build_unary_op): Use + gcc_checking_assert + +2015-10-21 Martin Sebor <msebor@redhat.com> + + PR driver/68043 + * gcc-interface/lang.opt: End each sentence that describes + an option with a period. + +2015-10-20 Yannick Moy <moy@adacore.com> + + * fmap.adb, a-cihama.adb, sem_ch5.adb, make.adb, inline.adb, + a-cfhase.adb, scng.adb, sem_ch12.adb, freeze.adb, tempdir.adb, + sem_util.adb, sem_res.adb, s-regexp.adb, a-clrefi.adb: Fix coding + style for marking start of processing of subprograms. + +2015-10-20 Yannick Moy <moy@adacore.com> + + * lib-xref-spark_specific.adb (Add_SPARK_File): Start traversal + by requesting info from stubs. (Traverse_All_Compilation_Units): + Remove unused procedure. + (Traverse_Declarations_Or_Statements): Handle protected and task units. + * lib-xref.ads (Traverse_All_Compilation_Units): Remove unused + procedure. + * restrict.adb (Check_Restriction): Do not ignore + restrictions in GNATprove_Mode. + +2015-10-20 Arnaud Charlet <charlet@adacore.com> + + * s-valllu.adb, sem_ch3.adb, layout.adb, a-crbtgo.adb, exp_ch9.adb, + make.adb, g-diopit.adb, s-valuns.adb, sem_ch9.adb, sem_ch10.adb, + sem_ch12.adb, a-tifiio.adb, g-dynhta.adb, uintp.adb, + sem_util.adb, sem_res.adb, s-htable.adb, exp_tss.adb, s-soflin.ads, + exp_ch6.adb, sem_ch6.adb, a-rbtgbo.adb, par-ch12.adb, sem_ch8.adb, + sem_eval.adb, mdll.adb, par-ch5.adb, s-poosiz.adb, sem_ch4.adb, + a-ngelfu.adb, s-taspri-solaris.ads, a-cforse.adb: Fix typos. + +2015-10-20 Arnaud Charlet <charlet@adacore.com> + + * sem_aggr.adb, mlib-prj.adb, prep.adb, eval_fat.adb, rtsfind.adb, + freeze.adb, sem_util.adb, sem_res.adb, sem_attr.adb, gnatlink.adb, + par-ch6.adb, exp_tss.adb, exp_ch4.adb, s-shasto.adb, exp_fixd.adb, + sem_ch6.adb, clean.adb, sem_ch8.adb, sem_eval.adb, sem_ch9.adb: Fix + typos. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch11.adb (Analyze_Handled_Statements): If the scope is a + postcondition subprogram, do not check for useless assignments + because there are no source references in such a body, and the + call will lose deferred references from the enclosing subprogram. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb: nalyze_Attribute_Definition_Clause, case + 'Address): If either object is controlled the overlay is + erroneous, but analysis must be completed so that back-end sees + address clause and completes code generation. Improve text + of warning. + +2015-10-20 Thomas Quinot <quinot@adacore.com> + + * exp_ch4.adb: Minor reformatting. + +2015-10-20 Bob Duff <duff@adacore.com> + + * s-mudido-affinity.adb (Create): Correct subranges of slices of CPU + arrays. + +2015-10-20 Arnaud Charlet <charlet@adacore.com> + + * sinfo.ads, g-pehage.adb, par-ch12.adb, + layout.adb, exp_util.adb, sem_aux.adb, make.adb, checks.adb, + sem_ch12.adb, sem_res.adb, sem_attr.adb, a-ngelfu.adb, sem_ch4.adb, + switch-b.adb, sem_ch6.adb, prj-dect.adb, gnatxref.adb, sem_ch13.adb, + lib-xref.adb: Fix typos. + +2015-10-20 Tristan Gingold <gingold@adacore.com> + + * exp_ch4.adb (Expand_Array_Comparison): Use + generic code if runtime routine is not available. + +2015-10-20 Yannick Moy <moy@adacore.com> + + * a-sytaco.ads (Ada.Synchronous_Task_Control): Package + now withs System.Task_Identification. The visible part + of the spec has SPARK_Mode. The private part has pragma + SPARK_Mode (Off). + (Set_True): Added Global and Depends aspects + (Set_False): Added Global and Depends aspects (Current_State): + Added Volatile_Function aspect and added external state + Ada.Task_Identification.Tasking_State as a Global input. + (Suspend_Until_True): Added Global and Depends aspects + * a-sytaco.adb (Ada.Synchronous_Task_Control): + Package body has SPARK_Mode => Off + * a-extiin.ads (Ada.Execution_Time.Interrupts): + Package now withs Ada.Real_Time and has SPARK_Mode. + (Clock): Added Volatile_Function aspect and added external state + Ada.Real_Time.Clock_Time as a Global input. + * a-reatim.ads (Ada.Real_Time): The visible part of the spec has + SPARK_Mode. The private part has pragma SPARK_Mode (Off). The package + declares external state Clock_Time with properties Async_Readers and + Async_Writers. + (Clock): Added Volatile_Function aspect and + added external state Clock_Time as a Global input. + * a-reatim.adb (Ada.Real_Time): Package body has SPARK_Mode => Off + * a-exetim-default.ads, a-exetim-mingw.ads (Ada.Execution_Time): + The visible part of the spec has SPARK_Mode. The private part + has pragma SPARK_Mode (Off). + (Clock): Added Volatile_Function + aspect and added external state Clock_Time as a Global input. + (Clock_For_Interrupts): Added Volatile_Function aspect and added + external state Ada.Real_Time.Clock_Time as a Global input. + * a-exetim-mingw.adb (Ada.Execution_Time): Package body has + SPARK_Mode => Off + * a-interr.ads (Ada.Interrupts): Package now + withs Ada.Task_Identification (Is_Reserved): Added + SPARK_Mode, Volatile_Function and external state + Ada.Task_Identification.Tasking_State as a Global input. + (Is_Attached): Added SPARK_Mode, Volatile_Function and external + state Ada.Task_Identification.Tasking_State as a Global input. + (Attach_Handler): Added SPARK_Mode => Off (Exchange_Handler): + Added SPARK_Mode => Off (Detach_Handler): Added SPARK_Mode + and external state Ada.Task_Identification.Tasking_State as a + Global In_Out. (Reference): Added SPARK_Mode => Off + * a-disedf.ads (Get_Deadline): Added SPARK_Mode, Volatile_Function + and external state Ada.Task_Identification.Tasking_State as a + Global input. + * a-taside.ads (Ada.Task_Identification): The visible part of + the spec has SPARK_Mode. The private part has pragma SPARK_Mode + (Off). The package declares external state Tasking_State with + properties Async_Readers and Async_Writers. + (Current_Task): Added + Volatile_Function aspect and added external state Tasking_State + as a Global input. + (Environment_Task): Added SPARK_Mode => Off + (Is_Terminated): Added Volatile_Function aspect and added external + state Tasking_State as a Global input. (Is_Callable): Added + Volatile_Function aspect and added external state Tasking_State as + a Global input. + (Activation_Is_Complete): Added Volatile_Function + aspect and added external state Tasking_State as a Global input. + * a-taside.adb (Ada.Task_Identification): Package body has + SPARK_Mode => Off. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * atree.ads, atree.adb: Enable List38 and List39 on entities. + * einfo.ads, einfo.adb (Class_Wide_Preconds) new attribute defined + on subprograms. Holds the list of class-wide precondition + functions inherited from ancestors. Each such function is an + instantiation of the generic function generated from an explicit + aspect specification for a class-wide precondition. A type is + an ancestor of itself, and therefore a root type has such an + instance on its own list. + (Class_Wide_Postconds): ditto for postconditions. + +2015-10-20 Vincent Celier <celier@adacore.com> + + * prj-attr.adb: Add packages Prove and GnatTest. + +2015-10-20 Steve Baird <baird@adacore.com> + + * a-conhel.adb: Add an Annotate pragma to help suppress CodePeer's + analysis of internals of container generic instances. This pragma + has no other effect. + * a-conhel.adb (Generic_Implementation) Add "pragma Annotate + (CodePeer, Skip_Analysis);". + +2015-10-20 Steve Baird <baird@adacore.com> + + * pprint.adb: Code clean up. + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-cfinve.ads, a-coboho.ads: Improve comments. + * a-coboho.adb (Size_In_Storage_Elements): Improve error message + in case of "Size is too big" exception. + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-contai.ads: Remove check names (moved to snames.ads-tmpl). + * snames.ads-tmpl: Add check names that were previously in + a-contai.ads, so they are now visible in configuration files. + * types.ads: Add checks corresponding to snames.ads-tmpl. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Loop_Statement): Attach generated loop + identifier to the tree, because it may be the root of a tree + traversal in Pop_Scope when freeze actions are pending. + +2015-10-20 Steve Baird <baird@adacore.com> + + * pprint.ads (Expression_Image) Add new generic formal flag + Hide_Parameter_Blocks. + * pprint.adb (Expression_Image) If new flag is set, then display + dereferences of parameter block components accordingly. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb: Code clean up. + +2015-10-20 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb (Expand_N_Extended_Return_Statement): Code cleanup. + (Make_Build_In_Place_Call_In_Object_Declaration): Update the + parameter profile. Code cleanup. Request debug info for the + object renaming declaration. + (Move_Activation_Chain): Add new formal parameter and update the + comment on usage. + * exp_ch6.ads (Make_Build_In_Place_Call_In_Object_Declaration): + Update the parameter profile and comment on usage. + * sem_util.ads, sem_util.adb (Remove_Overloaded_Entity): New routine, + currently unused. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_One_Aspect, case + Aspect_Disable_Controlled): If expander is not active, pre-analyze + expression anyway for ASIS and other tools use. + * sem_prag.adb (Build_Generic_Class_Condition): Handle properly + anonymous access types in parameter specifications. Make the + formal type a formal derived type of the controlling type of + the subprogram. + +2015-10-20 Tristan Gingold <gingold@adacore.com> + + * s-rident.ads: No_Task_At_Interrupt_Priority: New restriction. + * sem_prag.adb (Analyze_Pragma): Check the restriction. + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): + Check the restriction (for aspects). + +2015-10-20 Gary Dismukes <dismukes@adacore.com> + + * sem_prag.adb: Minor reformatting. + +2015-10-20 Tristan Gingold <gingold@adacore.com> + + * sem_util.adb (Is_Protected_Self_Reference): Remove reference to + UET_Address in comment. + * sem_attr.adb (Check_Unit_Name): Adjust comment. + (Analyze_Attribute): Remove handling of UET_Address. + * sem_attr.ads (Attribute_Impl_Def): Remove Attribute_UET_Address. + * snames.ads-tmpl Remove Name_UET_Address, Attribute_UET_Address. + * exp_attr.adb (Expand_N_Attribute_Reference): Remove + Attribute_UET_Address. + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-cbdlli.adb, a-cdlili.adb, a-chtgop.adb, a-cidlli.adb, + * a-cobove.adb, a-coinve.adb, a-convec.adb, a-crbtgo.adb ("="): Avoid + modifying the tampering counts unnecessarily. + (Adjust): Zero tampering counts unconditionally. + +2015-10-20 Jerome Lambourg <lambourg@adacore.com> + + * init.c: Fix build issue on arm-vx6 when building the RTP + run-time. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): If the expression + is an aggregate and compilation is in -gnatI mode (ignore rep + clauses) do not delay resolution of aggregate, to prevent freeze + actions out of order in the backend. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.ads, sem_prag.adb (Build_Generic_Class_Condition): + New procedure to construct a generic function for a class-wide + precondition, to implement AI12-0113 concerning the new semantics + of class-wide preconditions for overriding uperations. + +2015-10-20 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_util.adb (Find_Actual): The routine is + now capable of operating on entry calls. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb: Remove redundant check. + +2015-10-20 Jerome Lambourg <lambourg@adacore.com> + + * init.c (__gnat_vxsim_error_handler): Completely disable on + VxWorks-7 as the VSBs used to build gcc do not support vxsim + architecture. + +2015-10-20 Claire Dross <dross@adacore.com> + + * a-cfdlli.ads, a-cfinve.ads, a-cofove.ads (Generic_Sorting): Explicit + SPARK_Mode. + * a-cfhase.ads, a-cforse.ads (Generic_Keys): Explicit SPARK_Mode. + +2015-10-20 Tristan Gingold <gingold@adacore.com> + + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): + Check for No_Implicit_Protected_Object_Allocations. + * fe.h (Check_No_Implicit_Task_Alloc, + Check_No_Implicit_Protected_Alloc): Define and declare. + * restrict.ads, restrict.adb (Check_No_Implicit_Task_Alloc, + Check_No_Implicit_Protected_Alloc): New procedures to check the + restrictions. + * s-rident.ads (No_Implicit_Task_Allocations) + (No_Implicit_Protected_Object_Allocations): Declare new + restrictions. + +2015-10-20 Yannick Moy <moy@adacore.com> + + * sem_res.adb (Resolve_Selected_Component): Only set flag + when component is defined in a variant part. + * sem_util.adb, + * sem_util.ads (Is_Declared_Within_Variant): Promote local query + as publicy visible one for use in Resolve_Selected_Component. + +2015-10-20 Philippe Gil <gil@adacore.com> + + * g-debpoo.adb: allow instrumented System.Memory to use Debug_Pool + from foreign threads. + * g-debpoo.adb (Print_Traceback): NEW print traceback if available + added to support Stack_Trace_Depth = 0. + (Print_Address): NEW print System.Address without no secondary + stack use (Address_Image uses secondary stack) + +2015-10-20 Yannick Moy <moy@adacore.com> + + * exp_ch9.adb (Expand_Entry_Barrier): Default initialize local variable + Func. + +2015-10-20 Jerome Lambourg <lambourg@adacore.com> + + * init.c (__gnat_error_handler for vxworks): Force + SPE bit in the MSR when handling signals + +2015-10-20 Arnaud Charlet <charlet@adacore.com> + + * einfo.ads, sem_ch12.adb, sem_ch6.adb, table.ads, s-stposu.ads, + g-table.ads, g-dyntab.ads, makeutl.ads, a-crdlli.ads: Fix typos. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Loop_Statement): Element iterators + over multidimensional arrays create additional loops during + expansion. For such loops we create a label as a scope + name. Attach this label properly to tree, for use in GNATProve + over such element iterators. + * sem_attr.adb (Analyze_Attribute, case Loop_Entry): The loop to + which the attribute applies comes from source, not from expansion + of an element iterator or a quantified expression. + * exp_attr.adb (Expand_N_Attribute_Reference): Ditto. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Expand_Call): Check for a call to a function + declared in a Dimension I/O package, to handle the new Image + function. + +2015-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * inline.ads: Minor comment fixes. + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-comutr.ads (Tree_Node_Access): Add No_Strict_Aliasing, because + we're doing unchecked conversions with this pointer. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * exp_ch9.adb (Next_Protected_Operation): An expression function + used as a completion can be the next protected operation in a + protected body. + +2015-10-20 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Is_OK_Volatile_Context): Add a guard when checking a + possible call to an instance of Ada.Unchecked_Conversion to avoid + testing protected function calls. Allow references to protected objects + in prefixed protected calls. + (Is_Protected_Operation_Call): New routine. + +2015-10-20 Yannick Moy <moy@adacore.com> + + * exp_ch5.adb, exp_ch5.ads (Expand_Iterator_Loop_Over_Array): Make + query public. Remove code handling with iterator loop over array + of the 'in' form, which is not allowed in Ada. * exp_spark.adb + (Expand_SPARK): Expand loop statements that take the form of an + iterator over an array. + * sem_ch5.adb (Analyze_Loop_Statement): Do not analyze loop statements + that take the form of an iterator over an array, so that the rewritten + form gets analyzed instead. + * sem_util.adb, sem_util.ads (Is_Iterator_Over_Array): New query + to recognize iterators over arrays. + +2015-10-20 Arnaud Charlet <charlet@adacore.com> + + * s-excdeb.ads, s-excdeb.adb (Debug_Raise_Exception): Add + parameter Message. + * a-except.adb (Raise_Current_Excep): Update call to + Debug_Raise_Exception. + * a-except-2005.adb (Complete_Occurrence): Ditto. + * sem_ch12.adb: Whitespace fix. + +2015-10-20 Yannick Moy <moy@adacore.com> + + * sem_warn.adb (Is_OK_Fully_Initialized): Consider types with DIC as + fully default initialized. + * sem_ch6.adb: minor style fix in comment + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * s-diflio.ads, s-diflio.adb (Image): New function for dimensioned + quantities, to produce a string that includes the dimension + synbol for the quantity, or the vector of dimensions in standard + notation. + * sem_dim.adb (Expand_Put_Call_With_Symbol): Process new function + Image, to include dimension information in the generated string, + identical to the string produced by the Put procedure on a string + for a dimensioned quantity. + +2015-10-20 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Process_Declarations): A loop + parameter does not require finalization actions. + +2015-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch6.adb (Expand_Simple_Function_Return): Do not create an + actual subtype for a mutable record return type if the expression + is itself a function call. + +2015-10-20 Dmitriy Anisimkov <anisimko@adacore.com> + + * s-atocou.adb, s-atocou-builtin.adb: Fix implementation description + related to new type support. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Explicit_Dererence): Call Analyze_Dimension + to propagate dimension information from prefix. + * sem_dim.adb (Analyze_Dimension): Handle Explicit_Dereference. + * inline.ads: minor whitespace fix in comment + * sem_ch6.adb: minor gramar fix in comment + +2015-10-20 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch3.adb (Analyze_Object_Contract): + A protected type or a protected object is allowed to have a + discriminated part. + +2015-10-20 Bob Duff <duff@adacore.com> + + * sem_util.adb (Requires_Transient_Scope): + Return true for mutable records if the maximum size is very large. + +2015-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * a-except-2005.adb (To_Stderr): Import Put_Char_Stderr with + the same signature as in System.IO.Put. + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-cobove.adb (Set_Length): Restore previous logic, but with "Checks + and then" on the check. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * par-ch3.adb (P_Known_Discriminant_Part_Opt): Handle properly + a misplaced "constant" keyword in a discriminant specification. + +2015-10-20 Steve Baird <baird@adacore.com> + + * einfo.ads (Is_Param_Block_Component_Type): New function decl + for querying the flag. + (Set_Is_Param_Block_Component_Type): New procedure decl for setting + the flag. + * einfo.adb (Is_Param_Block_Component_Type): New function body. + (Set_Is_Param_Block_Component_Type): New procedure body. + (Write_Entity_Flags): Display the new flag. + * exp_ch9.adb (Build_Parameter_Block): Set flag on parameter + block component types. + (Expand_N_Entry_Declaration): Set flag on parameter block component + types. + +2015-10-20 Steve Baird <baird@adacore.com> + + * sem_elab.adb: Do not pass an N_Attribute_Reference node to + Sinfo.Set_No_Elaboration_Check. + * sem_elab.adb (Check_Elab_Call) Do not pass a non-call + node (specifically, an N_Attribute_Reference node) to + Sinfo.Set_No_Elaboration_Check. + +2015-10-20 Tristan Gingold <gingold@adacore.com> + + * adaint.c: File names are case sensitive on aarch64-ios. + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-cbdlli.ads, a-cbhase.ads, a-cbmutr.ads, a-cborse.ads, + * a-cdlili.ads, a-cidlli.ads, a-cihase.ads, a-cimutr.ads, + * a-ciorse.ads, a-cobove.ads, a-cohase.ads, a-coinve.ads, + * a-comutr.ads, a-convec.ads, a-coorse.ads: Use non-private with clause. + +2015-10-20 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_util.adb (Requires_Cleanup_Actions): A loop parameter does not + require finalization actions. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * par-ch3.adb (P_Declarative_Items): In case of misplaced + aspect specifications, ensure that flag Done is properly set to + continue parse. + +2015-10-20 Hristian Kirtchev <kirtchev@adacore.com> + + * rtsfind.ads Remove the entries for Ada.Synchronous_Task_Control + and Suspension_Object from tables RE_Id, RE_Unit_Table and RTU_Id. + * sem_util.adb (Is_Descendant_Of_Suspension_Object): Update + the comment on usage. Use routine Is_Suspension_Object to detect + whether a type matches Suspension_Object. + (Is_Suspension_Object): New routine. + * snames.ads-tmpl: Add predefined names for Suspension_Object + and Synchronous_Task_Control. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_smem.adb (Check_Shared_Var): Clean up code that handles + type declarations with discriminants, remove obsolete check. + +2015-10-20 Arnaud Charlet <charlet@adacore.com> + + * par_sco.adb: Minor style fixes. + +2015-10-20 Vincent Celier <celier@adacore.com> + + * debug.adb: Update documentation of -gnatdu. + +2015-10-20 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb Add aspect Volatile_Function to table + Canonical_Aspect. + * aspect.ads Add aspect Volatile_Function to tables + Aspect_Argument, Aspect_Delay, Aspect_Id, Aspect_Names + and Implementation_Defined_Aspect. Aspects Async_Readers, + Async_Writers, Effective_Reads and Effective_Writes are no + longer Boolean. + * einfo.adb (Get_Pragma): Add an entry for pragma + Volatile_Function. + * par-prag.adb (Prag): Pragma Volatile_Function does not need + special processing by the parser. + * rtsfind.ads Add an entry for Ada.Synchronous_Task_Control in + table RTU_Id. Add an entry for Suspension_Object in table RE_Id. + * sem_ch3.adb Fix SPARK RM references. + (Analyze_Object_Contract): Update the error guard. + * sem_ch5.adb Fix SPARK RM references. + * sem_ch6.adb (Analyze_Subprogram_Body_Contract): Ensure + that a non-volatile function does not contain an effectively + volatile parameter. + (Analyze_Subprogram_Contract): Ensure + that a non-volatile function does not contain an effectively + volatile parameter. + * sem_ch12.adb (Instantiate_Object): Remove the reference to + the SPARK RM from the error message. + * sem_ch13.adb (Analyze_Aspect_Specifications): Add + processing for aspects Async_Readers, Async_Writers, + Effective_Reads, Effective_Writes and Volatile_Function. + (Check_Aspect_At_Freeze_Point): Aspects Async_Readers, + Async_Writers, Effective_Reads, Effective_Writes and + Volatile_Function do not need special processing at the freeze + point. + * sem_prag.adb Add an entry for pragma Volatile_Function in + table Sig_Flags. + (Analyze_External_Property_In_Decl_Part): + Reimplemented as Async_Readers, Async_Writers, Effective_Reads + and Effective_Writes are no longer Boolean pragmas. + (Analyze_Global_Item): An external state or effectively + volatile object cannot appear as an item in pragma + [Refined_]Global. + (Analyze_Pragma): Change the implementation + of Async_Readers, Async_Writers, Effective_Reads and + Effective_Writes as these are no longer Boolean pragmas. + Use routine Check_Static_Boolean_Expression to verify the + optional Boolean expression of Async_Readers, Async_Writers, + Constant_After_Elaboration, Effective_Reads, Effective_Writes, + Extensions_Visible and Volatile_Function. Add processing for + pragma Volatile_Function. + (Check_Static_Boolean_Expression): New routine. + (Find_Related_Context): Update the comment on usage. + (Is_Enabled_Pragma): New routine. + * sem_prag.ads (Is_Enabled_Pragma): New routine. + * sem_res.adb Fix SPARK RM references. + (Is_OK_Volatile_Context): Add detection for return statements. + (Resolve_Actuals): Remove the check concerning an effectively volatile + OUT actual parameter as this is now done by the SPARK flow analyzer. + (Resolve_Entity_Name): Remove the check concerning an effectively + volatile OUT formal parameter as this is now done by the SPARK + flow analyzer. (Within_Volatile_Function): New routine. + * sem_util.adb (Add_Contract_Item): Add processing for pragma + Volatile_Function. + (Check_Nonvolatile_Function_Profile): New routine. + (Is_Descendant_Of_Suspension_Object): New routine. + (Is_Effectively_Volatile): Protected types and descendants of + Suspension_Object are now treated as effectively volatile. + (Is_Enabled): The optional Boolean expression of pragmas + Async_Readers, Async_Writers, Effective_Reads and Effective_Writes + now appears as the first argument. + (Is_Volatile_Function): New routine. + * sem_util.ads Add SPARK RM references. + (Add_Contract_Item): Update the comment on usage. + (Check_Nonvolatile_Function_Profile): New routine. + (Is_Effectively_Volatile): Update the comment on usage. + (Is_Volatile_Function): New routine. + * snames.ads-tmpl Add a predefined name and pragma id for + Volatile_Function. + +2015-10-20 Arnaud Charlet <charlet@adacore.com> + + * gnat_ugn.texi, gnat_rm.texi: Regenerate. + * doc/gnat_ugn/gnat_project_manager.rst, + doc/gnat_ugn/building_executable_programs_with_gnat.rst, + doc/gnat_ugn/the_gnat_compilation_model.rst, + doc/gnat_rm/standard_and_implementation_defined_restrictions.rst, + doc/gnat_rm/implementation_defined_pragmas.rst, + doc/gnat_rm/the_gnat_library.rst, + doc/gnat_rm/implementation_defined_characteristics.rst: Update doc. + +2015-10-20 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Makefile.in: Update targets. + +2015-10-20 Bob Duff <duff@adacore.com> + + * sem_ch13.adb (Analyze_One_Aspect): Avoid + analyzing the expression in a 'Disable_Controlled attribute when + Expander_Active is False, because otherwise, we get errors about + nonstatic expressions in pragma-Preelaborate generic packages. + * restrict.ads: minor whitespace cleanup in comment + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-conhel.adb: Remove "use SAC;", because otherwise the compiler + complains about use clauses in run-time units. Use "use type" + instead. + * a-btgbso.adb, a-btgbso.ads, a-cbdlli.adb, a-cbdlli.ads, + * a-cbhama.adb, a-cbhama.ads, a-cbhase.adb, a-cbhase.ads, + * a-cbmutr.adb, a-cbmutr.ads, a-cborma.adb, a-cborma.ads, + * a-cborse.adb, a-cborse.ads, a-cdlili.adb, a-cdlili.ads, + * a-chtgbk.adb, a-chtgbk.ads, a-chtgbo.adb, a-chtgbo.ads, + * a-chtgke.adb, a-chtgke.ads, a-chtgop.adb, a-chtgop.ads, + * a-cidlli.adb, a-cidlli.ads, a-cihama.adb, a-cihama.ads, + * a-cihase.adb, a-cihase.ads, a-cimutr.adb, a-cimutr.ads, + * a-ciorma.adb, a-ciorma.ads, a-ciormu.adb, a-ciormu.ads, + * a-ciorse.adb, a-ciorse.ads, a-cobove.adb, a-cobove.ads, + * a-cohama.adb, a-cohama.ads, a-cohase.adb, a-cohase.ads, + * a-cohata.ads, a-coinve.adb, a-comutr.adb, a-comutr.ads, + * a-convec.adb, a-coorma.adb, a-coorma.ads, a-coormu.adb, + * a-coormu.ads, a-coorse.adb, a-coorse.ads, a-crbltr.ads, + * a-crbtgk.adb, a-crbtgk.ads, a-crbtgo.adb, a-crbtgo.ads, + * a-rbtgbk.adb, a-rbtgbk.ads, a-rbtgbo.adb, a-rbtgbo.ads, + * a-rbtgso.adb, a-rbtgso.ads: Change all the predefined containers + to share the tampering machinery in Ada.Containers.Helpers. This + reduces the amount of duplicated code, and takes advantage of + efficiency improvements in Helpers. + Protect all run-time checks and supporting machinery with "if + Checks" or "if T_Check", so this code can be suppressed with + pragma Suppress or -gnatp. + Add Pseudo_Reference and Get_Element_Access to remaining + containers, so that the compiler can optimize "for ... of" loops. + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-contai.adb, a-coinve.ads, a-contai.ads, a-conhel.adb, a-conhel.ads, + Makefile.rtl, a-convec.ads: Move helper code from Ada.Containers to a + new package Ada.Containers.Helpers, because otherwise it's not + visible everywhere it needs to be (e.g. in the package + Ada.Containers.Red_Black_Trees, Generic_Tree_Types wants to have + a component of type Tamper_Counts). + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_type.adb (Intersect_Types): Specialize error message when + one operand is a limited view which is a priori incompatible + with all other named types. + * sem_prag.adb: minor fix in comment + * sem_ch13.adb: Code clean up. + +2015-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch12.adb (Need_Subprogram_Instance_Body): Also return true + for a subprogram nested in an inlined subprogram. + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-coinve.adb, a-contai.adb: Update comments. + * pprint.ads: Minor reformatting. + +2015-10-20 Tristan Gingold <gingold@adacore.com> + + * env.c, init.c: Handle arm64-darwin like arm-darwin. + * tracebak.c: Handle arm64-darwin. + +2015-10-20 Bob Duff <duff@adacore.com> + + * s-trasym.adb (Symbolic_Traceback): When giving the traceback + as hexadecimal code addresses, separate by blanks instead of LF. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Generate freeze + node for subprogram in Compile_Only mode. + +2015-10-20 Dmitriy Anisimkov <anisimko@adacore.com> + + * s-atocou.adb, s-atocou.ads, a-contai.adb, a-contai.ads, + s-atocou-x86.adb, s-atocou-builtin.adb: Task safe over container + iterations. + +2015-10-20 Philippe Gil <gil@adacore.com> + + * g-debpoo.ads (Dump): NEW print Debug_Pool statistics & main + contributors. + (Dump_Stdout): NEW print to stdout Debug_Pool statistics & + main contributors. + (Reset): NEW reset counters to 0. + (Get_Size): NEW return size allocated at parameter. + (High_Water_Mark): NEW. + (Current_Water_Mark): NEW. + (System_Memory_Debug_Pool): NEW tell Debug_Pools that + System.Memory uses it. + * g-debpoo.adb (Traceback_Htable_Elem): add Frees, Total_Frees + components. + (Find_Or_Create_Traceback): don't manage in System.Memory + Debug_Pool Deallocate Traceback's. + (Validity): add optional Handled table when System.Memory asked + for Allow_Unhandled_Memory. + (Allocate): handle Allocate reentrancy occuring when System.Memory + uses Debug_Pools. + (Deallocate): handle when Allow_Unhandled_Memory + is set deallocation of unhandled memory. Dont't check + Size_In_Storage_Elements if equal to Storage_Count'Last. update + Frees, Total_Frees new components. + +2015-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * fe.h: Minor tweak. + +2015-10-20 Vincent Celier <celier@adacore.com> + + * sem_cat.adb (Check_Categorization_Dependencies): Do nothing + when -gnatdu is specified. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (analyze_Subprogram_Renaming): The actual for a + formal abstract subprogram must have a controlling type. + * stand.ads: Minor whitespace cleanup. + +2015-10-20 Gary Dismukes <dismukes@adacore.com> + + * sem_ch13.adb: Minor reference change (RM => AARM). + +2015-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * make.adb (Check): Skip multilib switches reinstated by the + compiler only when counting the number of switches, since it is + what really matters in the regular operating mode. + +2015-10-20 Arnaud Charlet <charlet@adacore.com> + + * einfo.adb: Add extra assertion for small clause. + * cstand.adb: Minor style fix in comment. + * debug.adb: Minor reformatting. + * exp_util.adb: Fix minor typo. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Same_Instantiated_Function): New predicate in + Check_Formal_Package_Instance, used to verify that the formal + and the actual of an actual package match when both are functions + given as attribute references. + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-coinve.ads, a-coinve.adb: Do the same efficiency + improvements that were already done in the definite case + (Ada.Containers.Vectors, i.e. a-convec). This includes the + ability to suppress checks, the fast path for Append, inlining + as appropriate, and special-casing of "for ... of" loops. Reuse + the tampering machinery that is now in Ada.Containers. Simplify + many operations. + * a-convec.ads, a-convec.adb: Change the code to be more similar + to a-coinve. + * a-finali.ads, a-finali.adb: Expose the "null"-ness of the + operations. This may enable optimizations in the future, and + seems cleaner anyway. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Is_Operational_Item): Attributes related to + Ada 2012 iterators are operational items, and can be specified + on partial views. + +2015-10-20 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Check_Usage): Update the calls to Usage_Error. + (Usage_Error): Remove formal parameter Item. Emit a clearer message + concerning a missing dependency item and place it on the related pragma. + +2015-10-20 Bob Duff <duff@adacore.com> + + * debug.adb, expander.adb: Implement -gnatd.B switch, which + triggers a bug box when an abort_statement is seen. This is + useful for testing Comperr.Compiler_Abort. + * gnat1drv.adb: Trigger bug box on all exceptions other than + Unrecoverable_Error. + +2015-10-20 Thomas Quinot <quinot@adacore.com> + + * Makefile.rtl: add the following... + * g-binenv.ads, g-binenv.adb: New unit providing runtime access + to bind time captured values ("bind environment") + * init.c: declare new global variable __gl_bind_env_addr. + * bindgen.ads, bindgen.adb (Set_Bind_Env): record a bind + environment key=value pair. + (Gen_Bind_Env_String): helper to produce the bind environment data + called in the binder generated file. + (Gen_Output_File_Ada): Call the above (Gen_Adainit): Set + __gl_bind_env_addr accordingly. + * switch-b.adb: Support for command line switch -V (user interface + to set a build environment key=value pair) + * bindusg.adb: Document the above + +2015-10-20 Vincent Celier <celier@adacore.com> + + * sem_prag.adb (Analyse_Pragma: Pragma Pure): Do not set the + entity as Pure if Debug_Flag_U is set. + +2015-10-20 Bob Duff <duff@adacore.com> + + * output.adb (Write_Int): Work with negative numbers in order to avoid + negating Int'First and thereby causing overflow. + * sem_util.adb: Minor comment fix. + +2015-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * make.adb (Check): Skip multilib switches reinstated by the + compiler when doing the comparison with switches passed to + gnatmake. + +2015-10-20 Yannick Moy <moy@adacore.com> + + * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Return + False for procedures marked No_Return. + * sem_util.ads (Enclosing_Declaration): Improve comment. + * einfo.adb (Is_Completely_Hidden): Remove spurious assertion. + +2015-10-20 Thomas Quinot <quinot@adacore.com> + + * types.ads: Minor reformatting. + +2015-10-20 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb (Get_Pragma): Minor reformatting. Rename local constant + Is_CDG to Is_CLS. Add pragma Constant_After_Elaboration to the list of + classification pragmas. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Analyze_Declarations); At the of the visible part, + perform name resolution on the expressions in aspects of visible + entities. + * sem_ch13.ads, sem_ch13.adb (Resolve_Aspect_Expressions): Resolve + expressions in aspects independently of whether corresponding + entity is frozen. Used to complete name resolution of aspect + expressions for entities declared in the visible part of a + package or generic package declaration. + +2015-10-20 Vincent Celier <celier@adacore.com> + + * prj-attr.adb: Add package Codepeer and its attributes. + +2015-10-20 Thomas Quinot <quinot@adacore.com> + + * sem_ch3.adb, sem_ch13.adb: Minor reformatting. + +2015-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * gnatlink.adb (Gnatlink): Do not translate --RTS switch + for the linker and instead pass the switches that were + reinstated by the compiler. + +2015-10-20 Bob Duff <duff@adacore.com> + + * a-contai.ads, a-convec.ads: Move Count_Type_Last from + a-convec.ads to a-contai.ads, so other containers can refer to it. + +2015-10-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Check_Nonoverridable_Aspects): New procedure within + Analyze_Full_Type_ Declaration, used to apply legality rules in + 13,1,1 (18.3.3) concerning aspects that cannot be overridden in + a type extension. + (Check_Duplicate_Aspects): It is not legal to specify the + Implicit_Dereference aspect on a full view if partial view has + known discriminants. + * sem_ch13.adb (Analyze_Aspect_Implicit_Dereference): Verify that + the specification of the aspect on a derived type confirms the + value of the inherited one. + * sem_util.adb (Reference_Discriminant): Return empty if none + specified. + +2015-10-20 Thomas Quinot <quinot@adacore.com> + + * exp_ch5.adb, sem_ch3.adb: Minor reformatting. + +2015-10-20 Vincent Celier <celier@adacore.com> + + * a-strsup.adb (Super_Trim): Remove statements that put NUL + characters in unused portion of the Data string. + +2015-10-16 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb Add an entry for Constant_After_Elaboration in + table Canonical_Aspect. + * aspects.ads Add entries for Constant_After_Elaboration in + tables Aspect_Argument, Aspect_Delay, Aspect_Id, Aspect_Names + and Implementation_Defined_Aspect. + * par-prag.adb Pragma Constant_After_Elaboration does not require + special processing by the parser. + * sem_ch13.adb Add an entry for Constant_After_Elaboration + in table Sig_Flags. + (Analyze_Aspect_Specifications): + Add processing for aspect Constant_After_Elaboration. + (Check_Aspect_At_Freeze_Point): Aspect Constant_After_Elaboration + does not require special processing at freeze time. + * sem_prag.adb (Analyze_Pragma): Add processing for pragma + Constant_After_Elaboration. Use routine Find_Related_Context to + retrieve the context of pragma Part_Of. + (Duplication_Error): Update comment on usage. + (Find_Related_Context): New routine. + * sem_prag.ads Add an entry for Constant_After_Elaboration + in table Aspect_Specifying_Pragma. + (Analyze_Contract_Cases_In_Decl_Part): Update the comment on usage. + * sem_util.adb (Add_Contract_Item): Add processing for pragma + Constant_After_Elaboration. + * sem_util.ads (Add_Contract_Item): Update the comment on usage. + * snames.ads-tmpl Add new predefined name and aspect id for + Constant_After_Elaboration. + +2015-10-16 Vincent Celier <celier@adacore.com> + + * prj-pp.adb (Pretty_Print.Print): Correctly display extending + packages, instead of making them renamed packages. + +2015-10-16 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch12.adb (Analyze_Package_Instantiation): + Treat a missing SPARK_Mode annotation as having mode "Off". + (Analyze_Subprogram_Instantiation): Treat a missing SPARK_Mode + annotation as having mode "Off". + (Instantiate_Package_Body): Code + reformatting. Treat a missing SPARK_Mode annotation as having mode + "Off". + (Instantiate_Subprogram_Body): Code reformatting. Treat + a missing SPARK_Mode annotation as having mode "Off". + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb: Code clean up. + * sem_ch13.adb: Minor fix in comment. + +2015-10-16 Bob Duff <duff@adacore.com> + + * a-exexda.adb: Change format of Exception_Information to be + more like what we print for unhandled exceptions. + * a-exstat.adb: Parse new format. + * a-except-2005.adb, a-except.adb: Document new format. + +2015-10-16 Javier Miranda <miranda@adacore.com> + + * sem_ch5.adb (Analyze_Iterator_Specification): Associate a + transient scope with the renaming object declararation. + * exp_util.adb (Insert_Actions): if the enclosing interator + loop is marked as requiring the secondary stack then attach the + actions to the transient scope. + +2015-10-16 Bob Duff <duff@adacore.com> + + * exp_ch7.adb: Minor spelling fixes. + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Replace_Anonymous_Access_To_Protected_Subprogram): + If anonymous type is component type of array type declaration, + analyze its declaration in the current scope, not the enclosing + one. + +2015-10-16 Gary Dismukes <dismukes@adacore.com> + + * prj.adb, sem_util.adb, exp_ch6.adb: Minor reformatting. + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_Formal_Container_Element_Loop): Modify + expansion to allow element iteration over formal containers + whose elements are indefinite types. + +2015-10-16 Doug Rupp <rupp@adacore.com> + + * s-taprop-linux.adb (Monotonic_Clock): Call clock_gettime + instead of gettimeofday. + * s-osinte-android.ads, s-osinte-android.adb, s-osinte-linux.ads + (clock_gettime): New imported subprogram. + +2015-10-16 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): + Indefinite or limited library level objects are now returned on + the heap. + * exp_ch7.adb (Build_Finalization_Master): Add formal + parameter For_Lib_Level. Add context specific insertion for a + finalization master created for an access result type related + to a build-in-place function call used to initialize a library + level object. + * exp_ch7.ads (Build_Finalization_Master): Add formal parameter + For_Lib_Level. Update the comment on usage. + * sem_util.adb (Mark_Coextensions): Code cleanup. + +2015-10-16 Emmanuel Briot <briot@adacore.com> + + * prj.adb (For_Every_Project_Imported_Context): Fix handling + of aggregated projects with duplicate names. + * a-ngelfu.ads: Minor whitespace fix. + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Build_Predicate_Functions): The expression for + the predicate is side-effect free if it does not contain any + variable references. + +2015-10-16 Bob Duff <duff@adacore.com> + + * a-convec.adb ("="): Previous version depended + on "=" composing, but that doesn't quite work -- we want the "=" + operator passed in to the generic. So we need a loop after all. + +2015-10-16 Yannick Moy <moy@adacore.com> + + * sem_util.adb (Is_Object_Reference): Attribute 'Loop_Entry produces + an object. + * sem_ch6.adb: Minor fix in comment. + +2015-10-16 Bob Duff <duff@adacore.com> + + * a-contai.ads: Add two check names: Container_Checks and + Tampering_Check. Move the tampering check machinery from + Ada.Containers.Vectors to Ada.Containers. Later we can share it + with other containers. + Disable the tampering machinery in the presence of + Suppress(Tampering_Check). + Simplify the implementation of tampering checks. E.g. use RAII + to make incrementing/decrementing of the counts more concise. + * a-contai.adb: New package body, implementing the above. + * a-convec.ads, a-convec.adb: Use tampering check machinery + in Ada.Containers. + Disable all checking code when checks are suppressed. + Simplify many of the operations. Implement "&" in terms of Append, + rather than "by hand". + Remove: function "=" (L, R : Elements_Array) return Boolean is + abstract; so we can call the predefined "=" on Elements_Array. + For "=" on Vectors: Previously, we returned True immediately if + Left'Address = Right'Address. That seems like a non-optimization + ("if X = X" is unusual), so removed that. Simplify by using + slice comparison ("=" on Element_Array will automatically call + "=" on the components, even if user defined). + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Chek_Record_Representation_Clause): When + iterating over components, skip anonymous subtypes created for + constrained array components. + +2015-10-16 Eric Botcazou <ebotcazou@adacore.com> + + * a-tags.ads (Parent_Size): Remove obsolete pragma Export. + * s-finmas.ads (Header_Offset): Delete. + * s-finmas.adb (Header_Offset): Likewise. + (Finalize): Call Header_Size instead of Header_Offset. + * s-stposu.adb (Allocate_Any_Controlled): Likewise. + (Deallocate_Any_Controlled): Likewise. + +2015-10-16 Arnaud Charlet <charlet@adacore.com> + + * a-exetim.ads, a-exetim-mingw.ads, a-exetim-default.ads: Whitespace + cleanup. + * s-osprim-mingw.adb, einfo.ads, sem_util.adb, sem_util.ads, + sem_ch4.adb, sem_ch13.adb, s-trasym.adb, s-trasym.ads, + s-taprop-posix.adb: Minor reformatting. + +2015-10-16 Bob Duff <duff@adacore.com> + + * adadecode.h, adadecode.c (ada_demangle): Remove + ada_demangle, no longer used. + * a-except-2005.adb: Bring System.Traceback.Symbolic into the + closure. + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb, sem_util.ads (Get_Reference_Discriminant): Utility to + locate the access discriminant that supports implicit dereference on a + record type. + (Is_OK_Variable_For_Out_Parameter): Reject other illegal uses + of Implicit_Dereference on an access_to_constant when actual + parameter is a rewritten variable or function call. + +2015-10-16 Bob Duff <duff@adacore.com> + + * a-tags.adb, s-trasym.adb, s-trasym.ads: Make sure we don't get + elaboration circularities when polling is turned on. + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Replace_Anonymous_Access_To_Protected_Subprogram): + When creating a full declaration for a formal parameter, the + entity is labelled as an Itype, so set Associated_Node_For_Itype + accordingly. + * einfo.ads: Clarify use of Associated_Node_For_Itype. + +2015-10-16 Bob Duff <duff@adacore.com> + + * bindgen: Move pragmas Warnings earlier, otherwise + we can get warnings on with_clauses. + +2015-10-16 Arnaud Charlet <charlet@adacore.com> + + * s-osprim-mingw.adb, s-osprim-x32.adb, s-taprop-mingw.adb, + s-taprop-posix.adb (Monotonic_Clock): Removed, not used. + Remove remaining references to OS_Primitives.Monotonic_Clock. + Keep it only on windows which is a special case. + +2015-10-16 Javier Miranda <miranda@adacore.com> + + * a-textio.adb (Get_Line): Fix documentation. + * einfo.ads (Interface_Name): Fix documentation. + * exp_aggr.adb (Backend_Processing_Possible): Fix documentation. + * exp_ch4.adb (Expand_N_In): Fix documentation. + +2015-10-16 Eric Botcazou <ebotcazou@adacore.com> + + * inline.adb (Subp_Info): Remove Listed component. + (Add_Inlined_Subprogram): Take an entity instead of an index. + Do not set Listed component to True. + (New_Entry): Do not initialize Listed component to False. + (Analyze_Inlined_Bodies): Do not test Listed component + (Must_Inline): Add calls not in the main unit only + if they are in a subprogram that can be inlined outside its unit. + (Add_Inlined_Body): Move test around and add comment. + +2015-10-16 Arnaud Charlet <charlet@adacore.com> + + * sinfo.ads, einfo.ads: monir clean ups. + +2015-10-16 Arnaud Charlet <charlet@adacore.com> + + * usage.adb, debug.adb, a-except.adb, a-except.ads, a-except-2005.adb, + a-except-2005.ads, s-imgrea.adb: Minor code clean ups related to + jgnat/dotnet removal. + +2015-10-16 Arnaud Charlet <charlet@adacore.com> + + * s-osprim-vxworks.adb, s-osprim-darwin.adb, s-tadeca.adb, + s-osprim-unix.adb, s-osprim-solaris.adb, s-osprim-posix.adb, + s-osprim.ads (Monotonic_Clock): Removed, unused. + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Try_Object_Operation, Try_One_Interpretation): + Do not reset the Obj_Type of the prefix if an interpretation + involves an untagged type, to prevent a crash when analyzing an + illegal program in All_Errors mode. + +2015-10-16 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Expand_N_Expression_With_Actions): + Force the evaluation of the expression when its type is Boolean. + (Force_Boolean_Evaluation): New routine. + +2015-10-16 Bob Duff <duff@adacore.com> + + * sem_util.adb (Has_Discrim_Dep_Array): Remove + this function, and the call. No longer needed now that the back + end can handle such things. Should result in further speedups + in some cases. + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Build_Predicate_Functions): If expression for + predicate is side-effect free, indicate that the predicate + function is pure, to allow for optimization of redundant + predicate checks. + +2015-10-16 Arnaud Charlet <charlet@adacore.com> + + * checks.adb: Fix typo. + * s-osinte-linux.ads: Add header. + * projects.texi: Removed, no longer used. + * gcc-interface/Make-lang.in: Update dependencies + * s-multip.adb: Minor: fix header. + * sem_ch3.adb, exp_ch7.adb, g-dirope.ads, sinfo.ads, types.ads, + a-textio.adb, s-exctra.adb, ali.adb, back_end.ads, exp_intr.adb, + a-tigeli.adb, exp_ch3.adb, s-os_lib.ads: Remove further references to + .NET. + * gnatlink.adb, opt.ads, exp_aggr.adb, s-solita.adb: Minor comment + updates. + +2015-10-16 Gary Dismukes <dismukes@adacore.com> + + * exp_ch9.adb (Build_Simple_Entry_Call): Set_Is_Internal on + the temporary object used for a by-copy entry parameter, to + ensure that the object doesn't get its No_Initialization flag + reset later in Default_Initialize_Object. Also, generate the + assignment of the actual to the temporary in the additional case + of a scalar out parameter whose type has a Default_Value aspect. + * exp_ch3.adb: Fix minor typo in comment. + +2015-10-16 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_util.adb, sem_util.ads, sem_ch6.adb, sem_ch7.adb, sem_ch8.adb: + Minor reformatting. + * sem_ch12.adb (Analyze_Formal_Package_Declaration): Set the + SPARK_Mode from the context. + +2015-10-16 Bob Duff <duff@adacore.com> + + * sem_util.adb (Requires_Transient_Scope): + If Typ is a generic formal incomplete type, look at the actual + type. Otherwise, we don't notice that the actual type is tagged, + has a variant part, etc, causing a mismatch of calling conventions + between caller and callee. + +2015-10-16 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.ads: Move the declaration of enumeration + literal E_Abstract_State above E_Entry. Update the upper bound + of subtype Overloadable_Kind. + +2015-10-16 Gary Dismukes <dismukes@adacore.com> + + * exp_attr.adb: Minor editorial changes. + +2015-10-16 Arnaud Charlet <charlet@adacore.com> + + * exp_ch5.adb, sem_ch3.adb, frontend.adb, exp_ch7.adb, exp_ch7.ads, + sem_ch5.adb, sem_type.adb, exp_util.adb, exp_util.ads, comperr.adb, + exp_attr.adb, sinfo.ads, exp_ch9.adb, make.adb, usage.adb, + lib-writ.adb, sem_ch9.adb, bindgen.adb, debug.adb, einfo.adb, + einfo.ads, types.ads, checks.adb, sem_prag.adb, s-tasini.adb, + rtsfind.ads, freeze.adb, sem_util.adb, sem_util.ads, exp_dbug.adb, + gnatlink.adb, gnat1drv.adb, targparm.adb, targparm.ads, exp_ch4.adb, + exp_ch11.adb, repinfo.adb, s-soflin.adb, s-soflin.ads, exp_ch6.adb, + exp_ch13.adb, sem_mech.adb, sem_ch6.adb, par-prag.adb, exp_disp.adb, + sem_ch8.adb, exp_disp.ads, snames.adb-tmpl, exp_aggr.adb, sem_eval.adb, + exp_intr.adb, sem_ch13.adb, snames.ads-tmpl, sem_disp.adb, exp_ch3.adb: + Code clean up: remove special handling for .NET and JVM. + +2015-10-16 Arnaud Charlet <charlet@adacore.com> + + * sem_ch12.adb: Minor punctuation fix in comment + * s-rident.ads: Minor consistency fix in comment + * exp_attr.adb, g-spipat.ads: punctuation fixes in comments. + * restrict.ads: Style fix in comments. + * sem_prag.adb: Minor grammar fix in comment + +2015-10-16 Gary Dismukes <dismukes@adacore.com> + + * sem_ch12.adb: Minor reformatting/rewording. + +2015-10-16 Arnaud Charlet <charlet@adacore.com> + + * einfo.ads: Minor fix of duplicate words + * rident.ads: Minor style fix in comment + +2015-10-16 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch3.adb (Expand_N_Full_Type_Declaration): Do not capture, + set and restore the Ghost mode. + (Expand_N_Object_Declaration): Do not capture, set and restore the + Ghost mode. + (Freeze_Type): Redo the capture and restore of the Ghost mode. + (Restore_Globals): Removed. + * exp_ch5.adb (Expand_N_Assignment_Statement): Redo the capture + and restore of the Ghost mode. + (Restore_Globals): Removed. + * exp_ch6.adb (Expand_N_Procedure_Call_Statement): + Redo the capture and restore of the Ghost mode. + (Expand_N_Subprogram_Body): Redo the capture, set and restore + of the Ghost mode. + (Expand_N_Subprogram_Declaration): Do not + capture, set and restore the Ghost mode. + (Restore_Globals): Removed. + * exp_ch7.adb (Expand_N_Package_Body): Redo the capture, set + and restore of the Ghost mode. + (Expand_N_Package_Declaration): Do not capture, set and restore the + Ghost mode. + * exp_ch8.adb (Expand_N_Exception_Renaming_Declaration): + Redo the capture and restore of the Ghost mode. + (Expand_N_Object_Renaming_Declaration): Redo + the capture and restore of the Ghost mode. + (Expand_N_Package_Renaming_Declaration): + Redo the capture and restore of the Ghost mode. + (Expand_N_Subprogram_Renaming_Declaration): Redo the capture + and restore of the Ghost mode. + * exp_ch11.adb Remove with and use clauses for Ghost. + (Expand_N_Exception_Declaration): Do not capture, set and restore + the Ghost mode. + * exp_disp.adb (Make_DT): Redo the capture and restore of the + Ghost mode. + (Restore_Globals): Removed. + * exp_prag.adb (Expand_Pragma_Check): Do not capture, set + and restore the Ghost mode. + (Expand_Pragma_Contract_Cases): + Redo the capture and restore of the Ghost mode. Preserve the + original context of contract cases by setting / resetting the + In_Assertion_Expr counter. + (Expand_Pragma_Initial_Condition): + Redo the capture and restore of the Ghost mode. + (Expand_Pragma_Loop_Variant): Redo the capture and restore of + the Ghost mode. + (Restore_Globals): Removed. + * exp_util.adb (Make_Predicate_Call): Redo the capture and + restore of the Ghost mode. + (Restore_Globals): Removed. + * freeze.adb (Freeze_Entity): Redo the capture and restore of + the Ghost mode. + (Restore_Globals): Removed. + * ghost.adb (Check_Ghost_Context): Remove the RM reference from + the error message. + (Is_OK_Statement): Account for statements + that appear in assertion expressions. + (Is_Subject_To_Ghost): + Moved from spec. + * ghost.ads (Is_Subject_To_Ghost): Moved to body. + * rtsfind.ads (Load_RTU): Redo the capture and restore of the + Ghost mode. + * sem.adb Add with and use clauses for Ghost. + (Analyze): Redo + the capture and restore of the Ghost mode. Set the Ghost mode + when analyzing a declaration. + (Do_Analyze): Redo the capture + and restore of the Ghost mode. + * sem_ch3.adb (Analyze_Full_Type_Declaration): Do not capture, set + and restore the Ghost mode. + (Analyze_Incomplete_Type_Decl): + Do not capture, set and restore the Ghost mode. + (Analyze_Number_Declaration): Do not capture, set and restore the + Ghost mode. + (Analyze_Object_Declaration): Do not capture, set and + restore the Ghost mode. + (Analyze_Private_Extension_Declaration): + Do not capture, set and restore the Ghost mode. + (Analyze_Subtype_Declaration): Do not capture, set and restore + the Ghost mode. + (Restore_Globals): Removed. + * sem_ch5.adb (Analyze_Assignment): Redo the capture and restore + of the Ghost mode. + (Restore_Globals): Removed. + * sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): + Do not capture, set and restore the Ghost mode. + (Analyze_Procedure_Call): Redo the capture and restore of the + Ghost mode. + (Analyze_Subprogram_Body_Helper): Redo the capture + and restore of the Ghost mode. (Analyze_Subprogram_Declaration): + Do not capture, set and restore the Ghost mode. + (Restore_Globals): Removed. + * sem_ch7.adb (Analyze_Package_Body_Helper): Redo the capture and + restore of the Ghost mode. + (Analyze_Package_Declaration): + Do not capture, set and restore the Ghost mode. + (Analyze_Private_Type_Declaration): Do not capture, set and + restore the Ghost mode. + (Restore_Globals): Removed. + * sem_ch8.adb (Analyze_Exception_Renaming): Do not capture, + set and restore the Ghost mode. + (Analyze_Generic_Renaming): Do not capture, set and restore the Ghost + mode. + (Analyze_Object_Renaming): Do not capture, set and restore the + Ghost mode. + (Analyze_Package_Renaming): Do not capture, set and restore the Ghost + mode. + (Analyze_Subprogram_Renaming): Do not capture, set and restore the + Ghost mode. + (Restore_Globals): Removed. + * sem_ch11.adb (Analyze_Exception_Declaration): Do not capture, + set and restore the Ghost mode. + * sem_ch12.adb (Analyze_Generic_Package_Declaration): + Do not capture, set and restore the Ghost mode. + (Analyze_Generic_Subprogram_Declaration): Do not capture, set + and restore the Ghost mode. + * sem_ch13.adb (Build_Invariant_Procedure_Declaration): Redo + the capture and restore of the Ghost mode. + * sem_prag.adb (Analyze_Contract_Cases_In_Decl_Part): + Redo the capture and restore of the Ghost mode. + (Analyze_External_Property_In_Decl_Part): + Redo the capture and restore of the Ghost mode. + (Analyze_Initial_Condition_In_Decl_Part): Redo the + capture and restore of the Ghost mode. (Analyze_Pragma): + Do not capture, set and restore the Ghost mode for Assert. + Redo the capture and restore of the Ghost mode for Check. Do + not capture and restore the Ghost mode for Invariant. + (Analyze_Pre_Post_Condition_In_Decl_Part): Redo the capture and + restore of the Ghost mode. + * sem_res.adb (Resolve): Capture, set and restore the Ghost mode + when resolving a declaration. + * sem_util.adb (Build_Default_Init_Cond_Procedure_Body): + Redo the capture and restore of the Ghost mode. + (Build_Default_Init_Cond_Procedure_Declaration): Redo the capture + and restore of the Ghost mode. + +2015-10-16 Bob Duff <duff@adacore.com> + + * debug.adb: Document -gnatdQ switch. + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Analyze_Formal_Subprogram): Implement rule that + a formal abstract subprogram cannot have a null default: RM 12.6 + (4 1.2). + +2015-10-16 Bob Duff <duff@adacore.com> + + * sem_util.ads, sinput.ads, bcheck.adb: Minor comment fixes. + +2015-10-16 Javier Miranda <miranda@adacore.com> + + * inline.adb (Add_Inlined_Body): Ensure that + Analyze_Inlined_Bodies will be invoked after completing the + analysis of the current unit. + +2015-10-16 Arnaud Charlet <charlet@adacore.com> + + * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Fix error + message for bad last bit position. + * sem_ch3.adb, sem_util.adb, sem_util.ads: Minor reformatting. + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_N_Case_Statement): If expression is + compile-time known but does not obey a static predicate on + its type, replace the case statement with a raise statement, + as with other statically detected constraint violations. + +2015-10-16 Bob Duff <duff@adacore.com> + + * s-traceb.adb, s-traceb.ads, s-traceb-hpux.adb, s-traceb-mastop.adb: + Reinstate code. + * opt.ads: Minor typo. + +2015-10-16 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Gather_Components): When gathering components + of a nested variant, the record type used in legality checks is + the enclosing record type. + +2015-10-13 Jakub Jelinek <jakub@redhat.com> + + * gcc-interface/utils.c (DEF_FUNCTION_TYPE_9, DEF_FUNCTION_TYPE_10, + DEF_FUNCTION_TYPE_11): Define. + +2015-10-09 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/Make-lang.in: Make sure that GNAT1_OBJS and not just + GNAT1_ADA_OBJS are compiled only after generated files are created. + +2015-10-05 Richard Sandiford <richard.sandiford@arm.com> + + * gcc-interface/trans.c (convert_with_check): Use real_arithmetic + instead of REAL_ARITHMETIC. + +2015-10-05 Richard Sandiford <richard.sandiford@arm.com> + + * gcc-interface/trans.c (convert_with_check): Use real_less instead + of REAL_VALUES_LESS. + 2015-10-02 Doug Rupp <rupp@adacore.com> Olivier Hainque <hainque@adacore.com> @@ -270,7 +3595,7 @@ * gcc-interface/trans.c : Likewise. * gcc-interface/utils.c : Likewise. * gcc-interface/utils2.c : Likewise. - + 2015-06-08 John Marino <gnugcc@marino.st> * a-intnam-dragonfly.ads: New. @@ -4491,7 +7816,7 @@ 2015-01-07 Tristan Gingold <gingold@adacore.com> - PR ada/64349 + PR ada/64349 * env.c (__gnat_environ): Adjust for darwin9/darwin10. 2015-01-07 Javier Miranda <miranda@adacore.com> diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index ce59a64cfc2..68d8dc708cd 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -148,6 +148,7 @@ GNATRTL_NONTASKING_OBJS= \ a-colire$(objext) \ a-comlin$(objext) \ a-comutr$(objext) \ + a-conhel$(objext) \ a-contai$(objext) \ a-convec$(objext) \ a-coorma$(objext) \ @@ -380,6 +381,7 @@ GNATRTL_NONTASKING_OBJS= \ directio$(objext) \ g-arrspl$(objext) \ g-awk$(objext) \ + g-binenv$(objext) \ g-bubsor$(objext) \ g-busora$(objext) \ g-busorg$(objext) \ diff --git a/gcc/ada/a-btgbso.adb b/gcc/ada/a-btgbso.adb index 2aef270f64d..363b77e349a 100644 --- a/gcc/ada/a-btgbso.adb +++ b/gcc/ada/a-btgbso.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,10 @@ with System; use type System.Address; package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -53,12 +57,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ---------------- procedure Set_Difference (Target : in out Set_Type; Source : Set_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt, Src : Count_Type; TN : Nodes_Type renames Target.Nodes; @@ -68,10 +66,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is begin if Target'Address = Source'Address then - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); Tree_Operations.Clear_Tree (Target); return; @@ -81,10 +76,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); Tgt := Target.First; Src := Source.First; @@ -100,13 +92,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (TN (Tgt), SN (Src)) then Compare := -1; elsif Is_Less (SN (Src), TN (Tgt)) then @@ -114,21 +103,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -171,11 +145,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Count_Type; R_Node : Count_Type; @@ -184,12 +155,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -228,21 +193,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is R_Node := Tree_Operations.Next (Right, R_Node); end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end return; end Set_Difference; @@ -255,12 +205,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is (Target : in out Set_Type; Source : Set_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt : Count_Type; Src : Count_Type; @@ -271,10 +215,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); if Source.Length = 0 then Tree_Operations.Clear_Tree (Target); @@ -289,13 +230,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then Compare := -1; elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then @@ -303,21 +241,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -363,11 +286,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Count_Type; R_Node : Count_Type; @@ -376,12 +296,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -410,21 +324,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is R_Node := Tree_Operations.Next (Right, R_Node); end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end return; end Set_Intersection; @@ -450,42 +349,27 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Subset'Unrestricted_Access.Busy; - LL : Natural renames Subset'Unrestricted_Access.Lock; - - BR : Natural renames Of_Set'Unrestricted_Access.Busy; - LR : Natural renames Of_Set'Unrestricted_Access.Lock; + Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access); + Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access); Subset_Node : Count_Type; Set_Node : Count_Type; - - Result : Boolean; - begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - Subset_Node := Subset.First; Set_Node := Of_Set.First; loop if Set_Node = 0 then - Result := Subset_Node = 0; - exit; + return Subset_Node = 0; end if; if Subset_Node = 0 then - Result := True; - exit; + return True; end if; if Is_Less (Subset.Nodes (Subset_Node), Of_Set.Nodes (Set_Node)) then - Result := False; - exit; + return False; end if; if Is_Less (Of_Set.Nodes (Set_Node), @@ -497,23 +381,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is Subset_Node := Tree_Operations.Next (Subset, Subset_Node); end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end Set_Subset; @@ -531,62 +398,29 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Count_Type; R_Node : Count_Type; - - Result : Boolean; - begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop if L_Node = 0 or else R_Node = 0 then - Result := False; - exit; + return False; end if; if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then L_Node := Tree_Operations.Next (Left, L_Node); - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then R_Node := Tree_Operations.Next (Right, R_Node); - else - Result := True; - exit; + return True; end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end Set_Overlap; @@ -598,12 +432,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is (Target : in out Set_Type; Source : Set_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt : Count_Type; Src : Count_Type; @@ -642,13 +470,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then Compare := -1; elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then @@ -656,21 +481,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -722,11 +532,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Count_Type; R_Node : Count_Type; @@ -735,12 +542,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -795,21 +596,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is R_Node := Tree_Operations.Next (Right, R_Node); end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end return; end Set_Symmetric_Difference; @@ -850,13 +636,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- element tampering by a generic actual subprogram. declare - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BS := BS + 1; - LS := LS + 1; - -- Note that there's no way to decide a priori whether the target has -- enough capacity for the union with source. We cannot simply -- compare the sum of the existing lengths to the capacity of the @@ -864,15 +645,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is -- the union. Iterate (Source); - - BS := BS - 1; - LS := LS - 1; - exception - when others => - BS := BS - 1; - LS := LS - 1; - - raise; end; end Set_Union; @@ -892,19 +664,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is return Result : Set_Type (Left.Length + Right.Length) do declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - Assign (Target => Result, Source => Left); Insert_Right : declare @@ -934,21 +696,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is begin Iterate (Right); end Insert_Right; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end return; end Set_Union; diff --git a/gcc/ada/a-btgbso.ads b/gcc/ada/a-btgbso.ads index 06b58297eb0..0527a90c442 100644 --- a/gcc/ada/a-btgbso.ads +++ b/gcc/ada/a-btgbso.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,7 +37,7 @@ generic type Set_Type is new Tree_Operations.Tree_Types.Tree_Type with private; - use Tree_Operations.Tree_Types; + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; with procedure Assign (Target : in out Set_Type; Source : Set_Type); diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index c4e4945d702..c2799436053 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,9 @@ with System; use type System.Address; package body Ada.Containers.Bounded_Doubly_Linked_Lists is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------- -- Local Subprograms -- @@ -80,68 +82,39 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - - LN : Node_Array renames Left.Nodes; - RN : Node_Array renames Right.Nodes; - - LI : Count_Type; - RI : Count_Type; - - Result : Boolean; - begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Length /= Right.Length then return False; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - - LI := Left.First; - RI := Right.First; - Result := True; - for J in 1 .. Left.Length loop - if LN (LI).Element /= RN (RI).Element then - Result := False; - exit; - end if; - - LI := LN (LI).Next; - RI := RN (RI).Next; - end loop; + if Left.Length = 0 then + return True; + end if; - BL := BL - 1; - LL := LL - 1; + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - BR := BR - 1; - LR := LR - 1; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - return Result; + LN : Node_Array renames Left.Nodes; + RN : Node_Array renames Right.Nodes; - exception - when others => - BL := BL - 1; - LL := LL - 1; + LI : Count_Type := Left.First; + RI : Count_Type := Right.First; + begin + for J in 1 .. Left.Length loop + if LN (LI).Element /= RN (RI).Element then + return False; + end if; - BR := BR - 1; - LR := LR - 1; + LI := LN (LI).Next; + RI := RN (RI).Next; + end loop; + end; - raise; + return True; end "="; -------------- @@ -230,24 +203,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is end Append; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - - ------------ -- Assign -- ------------ @@ -260,7 +215,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error -- ??? with "Target capacity is less than Source length"; end if; @@ -286,8 +241,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is if Container.Length = 0 then pragma Assert (Container.First = 0); pragma Assert (Container.Last = 0); - pragma Assert (Container.Busy = 0); - pragma Assert (Container.Lock = 0); + pragma Assert (Container.TC = (Busy => 0, Lock => 0)); return; end if; @@ -296,10 +250,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); while Container.Length > 1 loop X := Container.First; @@ -332,30 +283,30 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - declare - N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; - begin - return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; - end if; + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Constant_Reference; -------------- @@ -382,7 +333,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is C := Source.Length; elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -404,12 +355,13 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is X : Count_Type; begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -431,10 +383,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for Index in 1 .. Count loop pragma Assert (Container.Length >= 2); @@ -484,10 +433,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for J in 1 .. Count loop X := Container.First; @@ -523,10 +469,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for J in 1 .. Count loop X := Container.Last; @@ -547,15 +490,14 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Element"); + pragma Assert (Vet (Position), "bad cursor in Element"); - return Position.Container.Nodes (Position.Node).Element; - end if; + return Position.Container.Nodes (Position.Node).Element; end Element; -------------- @@ -565,27 +507,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -606,7 +528,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Node := Container.First; else - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -618,39 +541,17 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Count_Type; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := 0; while Node /= 0 loop if Nodes (Node).Element = Item then - Result := Node; - exit; + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Nodes (Node).Next; end loop; - B := B - 1; - L := L - 1; - - if Result = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return No_Element; end; end Find; @@ -695,11 +596,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is function First_Element (Container : List) return Element_Type is begin - if Container.First = 0 then + if Checks and then Container.First = 0 then raise Constraint_Error with "list is empty"; - else - return Container.Nodes (Container.First).Element; end if; + + return Container.Nodes (Container.First).Element; end First_Element; ---------- @@ -826,42 +727,24 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is --------------- function Is_Sorted (Container : List) return Boolean is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Nodes : Node_Array renames Container.Nodes; - Node : Count_Type; - - Result : Boolean; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; + Lock : With_Lock (Container.TC'Unrestricted_Access); + Nodes : Node_Array renames Container.Nodes; + Node : Count_Type; + begin Node := Container.First; - Result := True; for J in 2 .. Container.Length loop if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then - Result := False; - exit; + return False; end if; Node := Nodes (Node).Next; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return True; end Is_Sorted; ----------- @@ -885,38 +768,30 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; end if; - if Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length + then raise Constraint_Error with "new length exceeds maximum"; end if; - if Target.Length + Source.Length > Target.Capacity then + if Checks and then Target.Length + Source.Length > Target.Capacity + then raise Capacity_Error with "new length exceeds target capacity"; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; - - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); LN : Node_Array renames Target.Nodes; RN : Node_Array renames Source.Nodes; @@ -924,12 +799,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is LI, LJ, RI, RJ : Count_Type; begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - LI := Target.First; RI := Source.First; while RI /= 0 loop @@ -955,22 +824,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is LI := LN (LI).Next; end if; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -1056,32 +909,15 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Front => 0, Back => 0); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - raise; end; pragma Assert (N (Container.First).Prev = 0); @@ -1090,6 +926,16 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is end Generic_Sorting; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1116,7 +962,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Before.Container /= null then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor designates wrong list"; end if; @@ -1129,14 +976,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Length > Container.Capacity - Count then + if Checks and then Container.Length > Container.Capacity - Count then raise Capacity_Error with "capacity exceeded"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); Allocate (Container, New_Item, New_Node); First_Node := New_Node; @@ -1258,32 +1102,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Count_Type := Container.First; begin - B := B + 1; - - begin - while Node /= 0 loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Container.Nodes (Node).Next; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= 0 loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Container.Nodes (Node).Next; + end loop; end Iterate; function Iterate (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1300,7 +1132,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Container => Container'Unrestricted_Access, Node => 0) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1309,8 +1141,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1323,12 +1153,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong list"; end if; @@ -1349,7 +1179,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1394,11 +1224,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is function Last_Element (Container : List) return Element_Type is begin - if Container.Last = 0 then + if Checks and then Container.Last = 0 then raise Constraint_Error with "list is empty"; - else - return Container.Nodes (Container.Last).Element; end if; + + return Container.Nodes (Container.Last).Element; end Last_Element; ------------ @@ -1426,14 +1256,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error with "Source length exceeds Target capacity"; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + TC_Check (Source.TC); -- Clear target, note that this checks busy bits of Target @@ -1533,12 +1360,14 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong list"; - else - return Next (Position); end if; + + return Next (Position); end Next; ------------- @@ -1590,14 +1419,30 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong list"; - else - return Previous (Position); end if; + + return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1607,7 +1452,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; @@ -1615,27 +1460,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Query_Element"); declare + Lock : With_Lock (Position.Container.TC'Unrestricted_Access); C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - + N : Node_Type renames C.Nodes (Position.Node); begin - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames C.Nodes (Position.Node); - begin - Process (N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Element); end; end Query_Element; @@ -1654,21 +1483,22 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Clear (Item); Count_Type'Base'Read (Stream, N); - if N < 0 then + if Checks and then N < 0 then raise Program_Error with "bad list length (corrupt stream)"; + end if; - elsif N = 0 then + if N = 0 then return; + end if; - elsif N > Item.Capacity then + if Checks and then N > Item.Capacity then raise Constraint_Error with "length exceeds capacity"; - - else - for Idx in 1 .. N loop - Allocate (Item, Stream, New_Node => X); - Insert_Internal (Item, Before => 0, New_Node => X); - end loop; end if; + + for Idx in 1 .. N loop + Allocate (Item, Stream, New_Node => X); + Insert_Internal (Item, Before => 0, New_Node => X); + end loop; end Read; procedure Read @@ -1704,30 +1534,30 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in function Reference"); + pragma Assert (Vet (Position), "bad cursor in function Reference"); - declare - N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - begin - return R : constant Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; - end if; + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Reference; --------------------- @@ -1740,22 +1570,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is New_Item : Element_Type) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; + TE_Check (Container.TC); - else - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - Container.Nodes (Position.Node).Element := New_Item; - end if; + Container.Nodes (Position.Node).Element := New_Item; end Replace_Element; ---------------------- @@ -1817,10 +1645,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); Container.First := J; Container.Last := I; @@ -1862,7 +1687,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Node := Container.Last; else - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -1874,39 +1700,17 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Count_Type; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := 0; while Node /= 0 loop if Container.Nodes (Node).Element = Item then - Result := Node; - exit; + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Container.Nodes (Node).Prev; end loop; - B := B - 1; - L := L - 1; - - if Result = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return No_Element; end; end Reverse_Find; @@ -1918,26 +1722,14 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Count_Type := Container.Last; begin - B := B + 1; - - begin - while Node /= 0 loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Container.Nodes (Node).Prev; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= 0 loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Container.Nodes (Node).Prev; + end loop; end Reverse_Iterate; ------------ @@ -1951,7 +1743,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is is begin if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; end if; @@ -1961,24 +1753,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is if Target'Address = Source'Address or else Source.Length = 0 then return; + end if; - elsif Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length then raise Constraint_Error with "new length exceeds maximum"; + end if; - elsif Target.Length + Source.Length > Target.Capacity then + if Checks and then Target.Length + Source.Length > Target.Capacity then raise Capacity_Error with "new length exceeds target capacity"; + end if; - elsif Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + TC_Check (Target.TC); + TC_Check (Source.TC); - else - Splice_Internal (Target, Before.Node, Source); - end if; + Splice_Internal (Target, Before.Node, Source); end Splice; procedure Splice @@ -1990,7 +1778,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Before.Container /= null then - if Before.Container /= Container'Unchecked_Access then + if Checks and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor designates wrong container"; end if; @@ -1998,11 +1786,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -2017,10 +1806,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Container.Length >= 2); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); if Before.Node = 0 then pragma Assert (Position.Node /= Container.Last); @@ -2100,7 +1886,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is end if; if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; end if; @@ -2108,30 +1894,23 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad Position cursor in Splice"); - if Target.Length >= Target.Capacity then + if Checks and then Target.Length >= Target.Capacity then raise Capacity_Error with "Target is full"; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); Splice_Internal (Target => Target, @@ -2275,19 +2054,19 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = 0 then + if Checks and then I.Node = 0 then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = 0 then + if Checks and then J.Node = 0 then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unchecked_Access then + if Checks and then I.Container /= Container'Unchecked_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unchecked_Access then + if Checks and then J.Container /= Container'Unchecked_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2295,10 +2074,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; - end if; + TE_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap"); pragma Assert (Vet (J), "bad J cursor in Swap"); @@ -2324,19 +2100,19 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = 0 then + if Checks and then I.Node = 0 then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = 0 then + if Checks and then J.Node = 0 then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2344,10 +2120,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap_Links"); pragma Assert (Vet (J), "bad J cursor in Swap_Links"); @@ -2388,11 +2161,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -2400,26 +2173,10 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Update_Element"); declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); + N : Node_Type renames Container.Nodes (Position.Node); begin - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - Process (N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Element); end; end Update_Element; diff --git a/gcc/ada/a-cbdlli.ads b/gcc/ada/a-cbdlli.ads index 603cb35b7a0..8489153917a 100644 --- a/gcc/ada/a-cbdlli.ads +++ b/gcc/ada/a-cbdlli.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +with Ada.Containers.Helpers; private with Ada.Streams; private with Ada.Finalization; @@ -43,6 +44,7 @@ generic return Boolean is <>; package Ada.Containers.Bounded_Doubly_Linked_Lists is + pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; @@ -248,6 +250,10 @@ private pragma Inline (Next); pragma Inline (Previous); + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + use Ada.Streams; use Ada.Finalization; @@ -265,8 +271,7 @@ private First : Count_Type := 0; Last : Count_Type := 0; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; end record; procedure Read @@ -301,15 +306,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is new Controlled with record - Container : List_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -353,6 +351,25 @@ 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. + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_List : constant List := (Capacity => 0, others => <>); No_Element : constant Cursor := Cursor'(null, 0); @@ -362,7 +379,8 @@ private record Container : List_Access; Node : Count_Type; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb index 3772c779305..86c57e737ad 100644 --- a/gcc/ada/a-cbhama.adb +++ b/gcc/ada/a-cbhama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,13 +33,17 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; with System; use type System.Address; package body Ada.Containers.Bounded_Hashed_Maps is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------- -- Local Subprograms -- @@ -120,24 +124,6 @@ package body Ada.Containers.Bounded_Hashed_Maps is end "="; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Map renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - - ------------ -- Assign -- ------------ @@ -168,7 +154,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error with "Target capacity is less than Source length"; end if; @@ -204,12 +190,13 @@ package body Ada.Containers.Bounded_Hashed_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -219,15 +206,14 @@ package body Ada.Containers.Bounded_Hashed_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => N.Element'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -240,25 +226,20 @@ package body Ada.Containers.Bounded_Hashed_Maps is Key_Ops.Find (Container'Unrestricted_Access.all, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; end if; declare - Cur : Cursor := Find (Container, Key); - pragma Unmodified (Cur); - N : Node_Type renames Container.Nodes (Node); - B : Natural renames Cur.Container.Busy; - L : Natural renames Cur.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -291,7 +272,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -325,7 +306,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is begin Key_Ops.Delete_Key_Sans_Free (Container, Key, X); - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "attempt to delete key not in map"; end if; @@ -334,20 +315,18 @@ package body Ada.Containers.Bounded_Hashed_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; - if Container.Busy > 0 then - raise Program_Error with - "Delete attempted to tamper with cursors (map is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -366,7 +345,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is Key_Ops.Find (Container'Unrestricted_Access.all, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "no element available because key not in map"; end if; @@ -376,7 +355,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; @@ -404,12 +383,12 @@ package body Ada.Containers.Bounded_Hashed_Maps is function Equivalent_Keys (Left, Right : Cursor) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; @@ -428,7 +407,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; @@ -445,7 +424,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; @@ -478,27 +457,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Map renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -536,6 +495,16 @@ package body Ada.Containers.Bounded_Hashed_Maps is return Object.Container.First; end First; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -571,10 +540,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "Include attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.TC); declare N : Node_Type renames Container.Nodes (Position.Node); @@ -648,7 +614,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is -- order to prevent divide-by-zero errors later, when we compute the -- buckets array index value for a key, given its hash value. - if Container.Buckets'Length = 0 then + if Checks and then Container.Buckets'Length = 0 then raise Capacity_Error with "No capacity for insertion"; end if; @@ -705,7 +671,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is -- order to prevent divide-by-zero errors later, when we compute the -- buckets array index value for a key, given its hash value. - if Container.Buckets'Length = 0 then + if Checks and then Container.Buckets'Length = 0 then raise Capacity_Error with "No capacity for insertion"; end if; @@ -726,7 +692,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert key already in map"; end if; @@ -763,35 +729,23 @@ package body Ada.Containers.Bounded_Hashed_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin return It : constant Iterator := (Limited_Controlled with Container => Container'Unrestricted_Access) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -801,7 +755,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; @@ -833,10 +787,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Target.Assign (Source); Source.Clear; @@ -885,7 +836,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -893,6 +844,21 @@ package body Ada.Containers.Bounded_Hashed_Maps is return Next (Position); end Next; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -903,7 +869,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is procedure (Key : Key_Type; Element : Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -913,26 +879,9 @@ package body Ada.Containers.Bounded_Hashed_Maps is declare M : Map renames Position.Container.all; N : Node_Type renames M.Nodes (Position.Node); - B : Natural renames M.Busy; - L : Natural renames M.Lock; - + Lock : With_Lock (M.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - declare - - begin - Process (N.Key, N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Key, N.Element); end; end Query_Element; @@ -1017,12 +966,13 @@ package body Ada.Containers.Bounded_Hashed_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -1032,16 +982,14 @@ package body Ada.Containers.Bounded_Hashed_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1053,22 +1001,20 @@ package body Ada.Containers.Bounded_Hashed_Maps is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; end if; declare N : Node_Type renames Container.Nodes (Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1085,19 +1031,15 @@ package body Ada.Containers.Bounded_Hashed_Maps is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "attempt to replace key not in map"; end if; - if Container.Lock > 0 then - raise Program_Error with - "Replace attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.TC); declare N : Node_Type renames Container.Nodes (Node); - begin N.Key := Key; N.Element := New_Item; @@ -1114,20 +1056,18 @@ package body Ada.Containers.Bounded_Hashed_Maps is New_Item : Element_Type) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Position.Container.Lock > 0 then - raise Program_Error with - "Replace_Element attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Position.Container.TC); pragma Assert (Vet (Position), "bad cursor in Replace_Element"); @@ -1143,7 +1083,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is Capacity : Count_Type) is begin - if Capacity > Container.Capacity then + if Checks and then Capacity > Container.Capacity then raise Capacity_Error with "requested capacity is too large"; end if; end Reserve_Capacity; @@ -1168,12 +1108,13 @@ package body Ada.Containers.Bounded_Hashed_Maps is Element : in out Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1182,24 +1123,9 @@ package body Ada.Containers.Bounded_Hashed_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (N.Key, N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Key, N.Element); end; end Update_Element; diff --git a/gcc/ada/a-cbhama.ads b/gcc/ada/a-cbhama.ads index a03bfe6ab07..0bab22e13b6 100644 --- a/gcc/ada/a-cbhama.ads +++ b/gcc/ada/a-cbhama.ads @@ -46,6 +46,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Bounded_Hashed_Maps is + pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; @@ -338,7 +339,7 @@ private type Map (Capacity : Count_Type; Modulus : Hash_Type) is new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Streams; use Ada.Finalization; @@ -380,15 +381,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is new Controlled with record - Container : Map_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -432,6 +426,25 @@ 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. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Map : constant Map := (Hash_Table_Type with Capacity => 0, Modulus => 0); @@ -441,7 +454,8 @@ private Map_Iterator_Interfaces.Forward_Iterator with record Container : Map_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index 5f87c295578..59b0bdb99de 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,13 +33,17 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; with System; use type System.Address; package body Ada.Containers.Bounded_Hashed_Sets is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------- -- Local Subprograms -- @@ -141,24 +145,6 @@ package body Ada.Containers.Bounded_Hashed_Sets is end "="; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Set renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - - ------------ -- Assign -- ------------ @@ -188,7 +174,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error with "Target capacity is less than Source length"; end if; @@ -224,11 +210,12 @@ package body Ada.Containers.Bounded_Hashed_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -237,16 +224,14 @@ package body Ada.Containers.Bounded_Hashed_Sets is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => N.Element'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -277,7 +262,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is C := Source.Length; elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -314,7 +299,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is begin Element_Keys.Delete_Key_Sans_Free (Container, Item, X); - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "attempt to delete element not in set"; end if; @@ -326,18 +311,16 @@ package body Ada.Containers.Bounded_Hashed_Sets is Position : in out Cursor) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -372,10 +355,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.TC); if Source.Length < Target.Length then Src_Node := HT_Ops.First (Source); @@ -460,7 +440,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -530,12 +510,12 @@ package body Ada.Containers.Bounded_Hashed_Sets is return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; @@ -570,7 +550,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Right : Element_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; @@ -589,7 +569,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; @@ -638,27 +618,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Set renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -693,6 +653,16 @@ package body Ada.Containers.Bounded_Hashed_Sets is return Object.Container.First; end First; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -727,10 +697,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Container.Nodes (Position.Node).Element := New_Item; end if; @@ -763,7 +730,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -816,7 +783,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is -- order to prevent divide-by-zero errors later, when we compute the -- buckets array index value for an element, given its hash value. - if Container.Buckets'Length = 0 then + if Checks and then Container.Buckets'Length = 0 then raise Capacity_Error with "No capacity for insertion"; end if; @@ -844,10 +811,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.TC); Tgt_Node := HT_Ops.First (Target); while Tgt_Node /= 0 loop @@ -982,30 +946,19 @@ package body Ada.Containers.Bounded_Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Iterate (Container); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; begin - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); return It : constant Iterator := Iterator'(Limited_Controlled with Container => Container'Unrestricted_Access); @@ -1030,10 +983,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Target.Assign (Source); Source.Clear; @@ -1083,7 +1033,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1118,6 +1068,21 @@ package body Ada.Containers.Bounded_Hashed_Sets is return False; end Overlap; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1127,7 +1092,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -1136,24 +1101,9 @@ package body Ada.Containers.Bounded_Hashed_Sets is declare S : Set renames Position.Container.all; - B : Natural renames S.Busy; - L : Natural renames S.Lock; - + Lock : With_Lock (S.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (S.Nodes (Position.Node).Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (S.Nodes (Position.Node).Element); end; end Query_Element; @@ -1231,15 +1181,12 @@ package body Ada.Containers.Bounded_Hashed_Sets is Node : constant Count_Type := Element_Keys.Find (Container, New_Item); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Container.Nodes (Node).Element := New_Item; end Replace; @@ -1250,12 +1197,13 @@ package body Ada.Containers.Bounded_Hashed_Sets is New_Item : Element_Type) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1274,7 +1222,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Capacity : Count_Type) is begin - if Capacity > Container.Capacity then + if Checks and then Capacity > Container.Capacity then raise Capacity_Error with "requested capacity is too large"; end if; end Reserve_Capacity; @@ -1342,10 +1290,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.TC); Iterate (Source); end Symmetric_Difference; @@ -1471,10 +1416,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.TC); -- ??? why is this code commented out ??? -- declare @@ -1623,23 +1565,6 @@ package body Ada.Containers.Bounded_Hashed_Sets is -- Local Subprograms -- ----------------------- - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - B : Natural renames Control.Container.Busy; - L : Natural renames Control.Container.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - function Equivalent_Key_Node (Key : Key_Type; Node : Node_Type) return Boolean; @@ -1670,25 +1595,20 @@ package body Ada.Containers.Bounded_Hashed_Sets is Key_Keys.Find (Container'Unrestricted_Access.all, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; declare - Cur : Cursor := Find (Container, Key); - pragma Unmodified (Cur); - N : Node_Type renames Container.Nodes (Node); - B : Natural renames Cur.Container.Busy; - L : Natural renames Cur.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -1718,7 +1638,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is begin Key_Keys.Delete_Key_Sans_Free (Container, Key, X); - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "attempt to delete key not in set"; end if; @@ -1737,7 +1657,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Key_Keys.Find (Container'Unrestricted_Access.all, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; @@ -1777,15 +1697,10 @@ package body Ada.Containers.Bounded_Hashed_Sets is procedure Finalize (Control : in out Reference_Control_Type) is begin if Control.Container /= null then - declare - B : Natural renames Control.Container.Busy; - L : Natural renames Control.Container.Lock; - begin - B := B - 1; - L := L - 1; - end; + Impl.Reference_Control_Type (Control).Finalize; - if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash + if Checks and then + Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash then HT_Ops.Delete_Node_At_Index (Control.Container.all, Control.Index, Control.Old_Pos.Node); @@ -1817,7 +1732,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -1847,11 +1762,12 @@ package body Ada.Containers.Bounded_Hashed_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -1862,21 +1778,18 @@ package body Ada.Containers.Bounded_Hashed_Sets is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - begin return R : constant Reference_Type := (Element => N.Element'Unrestricted_Access, Control => (Controlled with + Container.TC'Unrestricted_Access, Container'Unrestricted_Access, Index => Key_Keys.Index (Container, Key (Position)), Old_Pos => Position, Old_Hash => Hash (Key (Position)))) - do - B := B + 1; - L := L + 1; + do + Lock (Container.TC); end return; end; end Reference_Preserving_Key; @@ -1888,27 +1801,24 @@ package body Ada.Containers.Bounded_Hashed_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; declare P : constant Cursor := Find (Container, Key); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - begin return R : constant Reference_Type := (Element => Container.Nodes (Node).Element'Unrestricted_Access, Control => (Controlled with + Container.TC'Unrestricted_Access, Container'Unrestricted_Access, Index => Key_Keys.Index (Container, Key), Old_Pos => P, Old_Hash => Hash (Key))) do - B := B + 1; - L := L + 1; + Lock (Container.TC); end return; end; end Reference_Preserving_Key; @@ -1925,7 +1835,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -1947,12 +1857,13 @@ package body Ada.Containers.Bounded_Hashed_Sets is N : Nodes_Type renames Container.Nodes; begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1977,34 +1888,14 @@ package body Ada.Containers.Bounded_Hashed_Sets is declare E : Element_Type renames N (Position.Node).Element; K : constant Key_Type := Key (E); - - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - Eq : Boolean; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - -- Record bucket now, in case key is changed - Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); - - Process (E); - - Eq := Equivalent_Keys (K, Key (E)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + -- Record bucket now, in case key is changed + Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); - L := L - 1; - B := B - 1; + Process (E); - if Eq then + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -2022,7 +1913,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is while N (Prev).Next /= Position.Node loop Prev := N (Prev).Next; - if Prev = 0 then + if Checks and then Prev = 0 then raise Program_Error with "Position cursor is bad (node not found)"; end if; diff --git a/gcc/ada/a-cbhase.ads b/gcc/ada/a-cbhase.ads index c24fa8a1cf0..1023fc50464 100644 --- a/gcc/ada/a-cbhase.ads +++ b/gcc/ada/a-cbhase.ads @@ -34,6 +34,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; +with Ada.Containers.Helpers; private with Ada.Streams; private with Ada.Finalization; use Ada.Finalization; @@ -48,6 +49,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Bounded_Hashed_Sets is + pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; @@ -447,8 +449,10 @@ package Ada.Containers.Bounded_Hashed_Sets is type Set_Access is access all Set; for Set_Access'Storage_Size use 0; + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Index : Hash_Type; @@ -456,9 +460,6 @@ package Ada.Containers.Bounded_Hashed_Sets is Old_Hash : Hash_Type; end record; - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - overriding procedure Finalize (Control : in out Reference_Control_Type); pragma Inline (Finalize); @@ -496,7 +497,7 @@ private type Set (Capacity : Count_Type; Modulus : Hash_Type) is new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Streams; procedure Write @@ -537,15 +538,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is new Controlled with record - Container : Set_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -569,6 +563,25 @@ 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. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Set : constant Set := (Hash_Table_Type with Capacity => 0, Modulus => 0); @@ -578,7 +591,8 @@ private Set_Iterator_Interfaces.Forward_Iterator with record Container : Set_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb index 2a075428071..3fe986d1c9a 100644 --- a/gcc/ada/a-cbmutr.adb +++ b/gcc/ada/a-cbmutr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,11 +27,16 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Multiway_Trees is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + use Finalization; -------------------- -- Root_Iterator -- @@ -217,10 +222,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is function "=" (Left, Right : Tree) return Boolean is begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Count /= Right.Count then return False; end if; @@ -236,24 +237,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is Right_Subtree => Root_Node (Right)); end "="; - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Tree renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------------- -- Allocate_Node -- ------------------- @@ -343,7 +326,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is R, N : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; @@ -352,7 +335,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- search. For now we omit this check, pending a ruling from the ARG. -- ??? -- - -- if Is_Root (Position) then + -- if Checks and then Is_Root (Position) then -- raise Program_Error with "Position cursor designates root"; -- end if; @@ -383,11 +366,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is First, Last : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -395,15 +378,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Container.Count > Container.Capacity - Count then + if Checks and then Container.Count > Container.Capacity - Count then raise Capacity_Error with "requested count exceeds available storage"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container.Count = 0 then Initialize_Root (Container); @@ -443,7 +423,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Target.Capacity < Source.Count then + if Checks and then Target.Capacity < Source.Count then raise Capacity_Error -- ??? with "Target capacity is less than Source count"; end if; @@ -521,15 +501,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is N : Count_Type'Base; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Child = No_Element then + if Checks and then Child = No_Element then raise Constraint_Error with "Child cursor has no element"; end if; - if Parent.Container /= Child.Container then + if Checks and then Parent.Container /= Child.Container then raise Program_Error with "Parent and Child in different containers"; end if; @@ -545,7 +525,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Result := Result + 1; N := Parent.Container.Nodes (N).Parent; - if N < 0 then + if Checks and then N < 0 then raise Program_Error with "Parent is not ancestor of Child"; end if; end loop; @@ -562,10 +542,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Count : Count_Type; begin - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container_Count = 0 then return; @@ -596,17 +573,18 @@ package body Ada.Containers.Bounded_Multiway_Trees is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; @@ -615,17 +593,14 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- "Position cursor in Constant_Reference is bad"); declare - C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Container.Elements (Position.Node)'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -657,7 +632,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is C := Source.Count; elsif Capacity >= Source.Count then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -762,20 +737,22 @@ package body Ada.Containers.Bounded_Multiway_Trees is Target_Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in container"; end if; - if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then + if Checks and then + Before.Container.Nodes (Before.Node).Parent /= Parent.Node + then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; @@ -784,7 +761,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Is_Root (Source) then + if Checks and then Is_Root (Source) then raise Constraint_Error with "Source cursor designates root"; end if; @@ -1011,18 +988,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container.Count = 0 then pragma Assert (Is_Root (Parent)); @@ -1053,26 +1027,24 @@ package body Ada.Containers.Bounded_Multiway_Trees is X : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if not Is_Leaf (Position) then + if Checks and then not Is_Leaf (Position) then raise Constraint_Error with "Position cursor does not designate leaf"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -1095,22 +1067,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is Count : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -1163,11 +1133,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node = Root_Node (Position.Container.all) then + if Checks and then Position.Node = Root_Node (Position.Container.all) + then raise Program_Error with "Position cursor designates root"; end if; @@ -1222,11 +1193,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is Right_Position : Cursor) return Boolean is begin - if Left_Position = No_Element then + if Checks and then Left_Position = No_Element then raise Constraint_Error with "Left cursor has no element"; end if; - if Right_Position = No_Element then + if Checks and then Right_Position = No_Element then raise Constraint_Error with "Right cursor has no element"; end if; @@ -1290,25 +1261,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is -------------- procedure Finalize (Object : in out Root_Iterator) is - B : Natural renames Object.Container.Busy; begin - B := B - 1; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Tree renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; - end if; + Unbusy (Object.Container.TC); end Finalize; ---------- @@ -1361,7 +1315,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Node : Count_Type'Base; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1426,13 +1380,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is Result : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Commented-out pending ruling by ARG. ??? - -- if Position.Container /= Container'Unrestricted_Access then + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then -- raise Program_Error with "Position cursor not in container"; -- end if; @@ -1474,6 +1430,16 @@ package body Ada.Containers.Bounded_Multiway_Trees is return Find_In_Children (Container, Subtree, Item); end Find_In_Subtree; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Elements (Position.Node)'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1543,20 +1509,23 @@ package body Ada.Containers.Bounded_Multiway_Trees is Last : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then + if Checks and then + Before.Container.Nodes (Before.Node).Parent /= Parent.Node + then raise Constraint_Error with "Parent cursor not parent of Before"; end if; end if; @@ -1566,15 +1535,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Container.Count > Container.Capacity - Count then + if Checks and then Container.Count > Container.Capacity - Count then raise Capacity_Error with "requested count exceeds available storage"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container.Count = 0 then Initialize_Root (Container); @@ -1620,20 +1586,23 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- OK to reference, see below begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Container.Nodes (Before.Node).Parent /= Parent.Node then + if Checks and then + Before.Container.Nodes (Before.Node).Parent /= Parent.Node + then raise Constraint_Error with "Parent cursor not parent of Before"; end if; end if; @@ -1643,15 +1612,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Container.Count > Container.Capacity - Count then + if Checks and then Container.Count > Container.Capacity - Count then raise Capacity_Error with "requested count exceeds available storage"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container.Count = 0 then Initialize_Root (Container); @@ -1832,26 +1798,16 @@ package body Ada.Containers.Bounded_Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin if Container.Count = 0 then return; end if; - B := B + 1; - Iterate_Children (Container => Container, Subtree => Root_Node (Container), Process => Process); - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end Iterate; function Iterate (Container : Tree) @@ -1870,7 +1826,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Position : Cursor)) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1880,25 +1836,16 @@ package body Ada.Containers.Bounded_Multiway_Trees is end if; declare - B : Natural renames Parent.Container.Busy; C : Count_Type; NN : Tree_Node_Array renames Parent.Container.Nodes; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); begin - B := B + 1; - C := NN (Parent.Node).Children.First; while C > 0 loop Process (Cursor'(Parent.Container, Node => C)); C := NN (C).Next; end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end; end Iterate_Children; @@ -1931,14 +1878,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is return Tree_Iterator_Interfaces.Reversible_Iterator'Class is C : constant Tree_Access := Container'Unrestricted_Access; - B : Natural renames C.Busy; - begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= C then + if Checks and then Parent.Container /= C then raise Program_Error with "Parent cursor not in container"; end if; @@ -1947,7 +1892,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Container => C, Subtree => Parent.Node) do - B := B + 1; + Busy (C.TC); end return; end Iterate_Children; @@ -1959,25 +1904,22 @@ package body Ada.Containers.Bounded_Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + C : constant Tree_Access := Position.Container; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Implement Vet for multiway trees??? -- pragma Assert (Vet (Position), "bad subtree cursor"); - declare - B : Natural renames Position.Container.Busy; - begin - return It : constant Subtree_Iterator := - (Limited_Controlled with - Container => Position.Container, - Subtree => Position.Node) - do - B := B + 1; - end return; - end; + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => C, + Subtree => Position.Node) + do + Busy (C.TC); + end return; end Iterate_Subtree; procedure Iterate_Subtree @@ -1985,7 +1927,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Position : Cursor)) is begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; @@ -1996,23 +1938,13 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare T : Tree renames Position.Container.all; - B : Natural renames T.Busy; - + Busy : With_Busy (T.TC'Unrestricted_Access); begin - B := B + 1; - if Is_Root (Position) then Iterate_Children (T, Position.Node, Process); else Iterate_Subtree (T, Position.Node, Process); end if; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end; end Iterate_Subtree; @@ -2047,7 +1979,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Node : Count_Type'Base; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -2084,10 +2016,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors of Source (tree is busy)"; - end if; + TC_Check (Source.TC); Target.Assign (Source); Source.Clear; @@ -2106,7 +2035,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -2146,7 +2075,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -2254,11 +2183,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is First, Last : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -2266,15 +2195,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Container.Count > Container.Capacity - Count then + if Checks and then Container.Count > Container.Capacity - Count then raise Capacity_Error with "requested count exceeds available storage"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); if Container.Count = 0 then Initialize_Root (Container); @@ -2315,7 +2241,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong tree"; end if; @@ -2357,6 +2283,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is Position := Previous_Sibling (Position); end Previous_Sibling; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -2366,33 +2306,19 @@ package body Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Element : Element_Type)) is begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Process (Element => T.Elements (Position.Node)); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - raise; end; end Query_Element; @@ -2430,7 +2356,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is begin Count_Type'Read (Stream, Count); - if Count < 0 then + if Checks and then Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2480,7 +2406,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Count_Type'Read (Stream, Total_Count); - if Total_Count < 0 then + if Checks and then Total_Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2488,7 +2414,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Total_Count > Container.Capacity then + if Checks and then Total_Count > Container.Capacity then raise Capacity_Error -- ??? with "node count in stream exceeds container capacity"; end if; @@ -2499,7 +2425,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Read_Children (Root_Node (Container)); - if Read_Count /= Total_Count then + if Checks and then Read_Count /= Total_Count then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2539,17 +2465,18 @@ package body Ada.Containers.Bounded_Multiway_Trees is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; @@ -2558,19 +2485,16 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- "Position cursor in Constant_Reference is bad"); declare - C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Container.Elements (Position.Node)'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; - end Reference; -------------------- @@ -2623,22 +2547,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is New_Item : Element_Type) is begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); Container.Elements (Position.Node) := New_Item; end Replace_Element; @@ -2652,7 +2574,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Position : Cursor)) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -2663,24 +2585,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare NN : Tree_Node_Array renames Parent.Container.Nodes; - B : Natural renames Parent.Container.Busy; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); C : Count_Type; begin - B := B + 1; - C := NN (Parent.Node).Children.Last; while C > 0 loop Process (Cursor'(Parent.Container, Node => C)); C := NN (C).Prev; end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end; end Reverse_Iterate_Children; @@ -2716,32 +2629,36 @@ package body Ada.Containers.Bounded_Multiway_Trees is Source_Parent : Cursor) is begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Target'Unrestricted_Access then + if Checks and then Target_Parent.Container /= Target'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Target.Nodes (Before.Node).Parent /= Target_Parent.Node then + if Checks and then + Target.Nodes (Before.Node).Parent /= Target_Parent.Node + then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Source'Unrestricted_Access then + if Checks and then Source_Parent.Container /= Source'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in Source container"; end if; @@ -2756,12 +2673,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (Container => Target, + if Checks and then Is_Reachable (Container => Target, From => Target_Parent.Node, To => Source_Parent.Node) then @@ -2778,15 +2692,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); if Target.Count = 0 then Initialize_Root (Target); @@ -2807,32 +2714,39 @@ package body Ada.Containers.Bounded_Multiway_Trees is Source_Parent : Cursor) is begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Target_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Container.Nodes (Before.Node).Parent /= Target_Parent.Node then + if Checks and then + Container.Nodes (Before.Node).Parent /= Target_Parent.Node + then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Source_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in container"; end if; @@ -2843,12 +2757,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is pragma Assert (Container.Count > 0); - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (Container => Container, + if Checks and then Is_Reachable (Container => Container, From => Target_Parent.Node, To => Source_Parent.Node) then @@ -2944,7 +2855,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Target.Count > Target.Capacity - Source_Count then + if Checks and then Target.Count > Target.Capacity - Source_Count then raise Capacity_Error -- ??? with "Source count exceeds available storage on Target"; end if; @@ -3002,33 +2913,34 @@ package body Ada.Containers.Bounded_Multiway_Trees is Position : in out Cursor) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Target.Nodes (Before.Node).Parent /= Parent.Node then + if Checks and then Target.Nodes (Before.Node).Parent /= Parent.Node + then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor not in Source container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; @@ -3047,12 +2959,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is end if; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (Container => Target, + if Checks and then Is_Reachable (Container => Target, From => Parent.Node, To => Position.Node) then @@ -3067,15 +2976,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); if Target.Count = 0 then Initialize_Root (Target); @@ -3098,33 +3000,36 @@ package body Ada.Containers.Bounded_Multiway_Trees is Position : Cursor) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Container.Nodes (Before.Node).Parent /= Parent.Node then + if Checks and then Container.Nodes (Before.Node).Parent /= Parent.Node + then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then -- Should this be PE instead? Need ARG confirmation. ??? @@ -3145,12 +3050,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is end if; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (Container => Container, + if Checks and then Is_Reachable (Container => Container, From => Parent.Node, To => Position.Node) then @@ -3181,7 +3083,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- is a bit of a misnomer here in the case of a bounded tree, because -- the elements must be copied from the source to the target. - if Target.Count > Target.Capacity - Source_Count then + if Checks and then Target.Count > Target.Capacity - Source_Count then raise Capacity_Error -- ??? with "Source count exceeds available storage on Target"; end if; @@ -3276,15 +3178,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is I, J : Cursor) is begin - if I = No_Element then + if Checks and then I = No_Element then raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor not in container"; end if; - if Is_Root (I) then + if Checks and then Is_Root (I) then raise Program_Error with "I cursor designates root"; end if; @@ -3292,22 +3194,19 @@ package body Ada.Containers.Bounded_Multiway_Trees is return; end if; - if J = No_Element then + if Checks and then J = No_Element then raise Constraint_Error with "J cursor has no element"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor not in container"; end if; - if Is_Root (J) then + if Checks and then Is_Root (J) then raise Program_Error with "J cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); declare EE : Element_Array renames Container.Elements; @@ -3329,37 +3228,24 @@ package body Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Process (Element => T.Elements (Position.Node)); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - raise; end; end Update_Element; diff --git a/gcc/ada/a-cbmutr.ads b/gcc/ada/a-cbmutr.ads index 127b179d43c..66001976031 100644 --- a/gcc/ada/a-cbmutr.ads +++ b/gcc/ada/a-cbmutr.ads @@ -32,8 +32,9 @@ ------------------------------------------------------------------------------ with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; private with Ada.Streams; -private with Ada.Finalization; generic type Element_Type is private; @@ -41,6 +42,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Bounded_Multiway_Trees is + pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; @@ -270,8 +272,12 @@ package Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Position : Cursor)); private + + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + use Ada.Streams; - use Ada.Finalization; No_Node : constant Count_Type'Base := -1; -- Need to document all global declarations such as this ??? @@ -297,8 +303,7 @@ private Nodes : Tree_Node_Array (0 .. Capacity) := (others => <>); Elements : Element_Array (1 .. Capacity) := (others => <>); Free : Count_Type'Base := No_Node; - Busy : Integer := 0; - Lock : Integer := 0; + TC : aliased Tamper_Counts; Count : Count_Type := 0; end record; @@ -332,16 +337,8 @@ private Position : Cursor); for Cursor'Write use Write; - type Reference_Control_Type is - new Controlled with record - Container : Tree_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -383,6 +380,25 @@ 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. + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Tree : constant Tree := (Capacity => 0, others => <>); No_Element : constant Cursor := Cursor'(others => <>); diff --git a/gcc/ada/a-cborma.adb b/gcc/ada/a-cborma.adb index c45bf9a3b76..611e8953e16 100644 --- a/gcc/ada/a-cborma.adb +++ b/gcc/ada/a-cborma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,6 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); @@ -39,7 +41,9 @@ with System; use type System.Address; package body Ada.Containers.Bounded_Ordered_Maps is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------------- -- Node Access Subprograms -- @@ -108,11 +112,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; @@ -133,7 +137,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function "<" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; @@ -150,7 +154,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function "<" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; @@ -206,11 +210,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; @@ -231,7 +235,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function ">" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; @@ -247,7 +251,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function ">" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; @@ -263,24 +267,6 @@ package body Ada.Containers.Bounded_Ordered_Maps is end ">"; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Map renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - - ------------ -- Assign -- ------------ @@ -358,7 +344,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error with "Target capacity is less than Source length"; end if; @@ -409,12 +395,13 @@ package body Ada.Containers.Bounded_Ordered_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -424,16 +411,14 @@ package body Ada.Containers.Bounded_Ordered_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => N.Element'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -445,25 +430,20 @@ package body Ada.Containers.Bounded_Ordered_Maps is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; end if; declare - Cur : Cursor := Find (Container, Key); - pragma Unmodified (Cur); - N : Node_Type renames Container.Nodes (Node); - B : Natural renames Cur.Container.Busy; - L : Natural renames Cur.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => N.Element'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -491,7 +471,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -506,12 +486,13 @@ package body Ada.Containers.Bounded_Ordered_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; @@ -529,7 +510,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is X : constant Count_Type := Key_Ops.Find (Container, Key); begin - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "key not in map"; end if; @@ -571,7 +552,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; @@ -585,11 +566,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function Element (Container : Map; Key : Key_Type) return Element_Type is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; - else - return Container.Nodes (Node).Element; end if; + + return Container.Nodes (Node).Element; end Element; --------------------- @@ -628,27 +609,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Map renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -707,11 +668,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function First_Element (Container : Map) return Element_Type is begin - if Container.First = 0 then + if Checks and then Container.First = 0 then raise Constraint_Error with "map is empty"; - else - return Container.Nodes (Container.First).Element; end if; + + return Container.Nodes (Container.First).Element; end First_Element; --------------- @@ -720,11 +681,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function First_Key (Container : Map) return Key_Type is begin - if Container.First = 0 then + if Checks and then Container.First = 0 then raise Constraint_Error with "map is empty"; - else - return Container.Nodes (Container.First).Key; end if; + + return Container.Nodes (Container.First).Key; end First_Key; ----------- @@ -741,6 +702,16 @@ package body Ada.Containers.Bounded_Ordered_Maps is end if; end Floor; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -766,10 +737,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.TC); declare N : Node_Type renames Container.Nodes (Position.Node); @@ -852,7 +820,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "key already in map"; end if; end Insert; @@ -979,29 +947,17 @@ package body Ada.Containers.Bounded_Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1018,7 +974,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is Container => Container'Unrestricted_Access, Node => 0) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1027,8 +983,6 @@ package body Ada.Containers.Bounded_Ordered_Maps is Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- Iterator was defined to behave the same as for a complete iterator, -- and iterate over the entire sequence of items. However, those @@ -1040,12 +994,12 @@ package body Ada.Containers.Bounded_Ordered_Maps is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong map"; end if; @@ -1067,7 +1021,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1077,7 +1031,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; @@ -1129,11 +1083,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function Last_Element (Container : Map) return Element_Type is begin - if Container.Last = 0 then + if Checks and then Container.Last = 0 then raise Constraint_Error with "map is empty"; - else - return Container.Nodes (Container.Last).Element; end if; + + return Container.Nodes (Container.Last).Element; end Last_Element; -------------- @@ -1142,11 +1096,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is function Last_Key (Container : Map) return Key_Type is begin - if Container.Last = 0 then + if Checks and then Container.Last = 0 then raise Constraint_Error with "map is empty"; - else - return Container.Nodes (Container.Last).Key; end if; + + return Container.Nodes (Container.Last).Key; end Last_Key; ---------- @@ -1177,10 +1131,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Target.Assign (Source); Source.Clear; @@ -1228,7 +1179,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -1287,7 +1238,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong map"; end if; @@ -1295,6 +1246,21 @@ package body Ada.Containers.Bounded_Ordered_Maps is return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1305,7 +1271,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is Element : Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -1316,25 +1282,9 @@ package body Ada.Containers.Bounded_Ordered_Maps is declare M : Map renames Position.Container.all; N : Node_Type renames M.Nodes (Position.Node); - - B : Natural renames M.Busy; - L : Natural renames M.Lock; - + Lock : With_Lock (M.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (N.Key, N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Key, N.Element); end; end Query_Element; @@ -1404,12 +1354,13 @@ package body Ada.Containers.Bounded_Ordered_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -1419,15 +1370,14 @@ package body Ada.Containers.Bounded_Ordered_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1439,21 +1389,20 @@ package body Ada.Containers.Bounded_Ordered_Maps is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; end if; declare N : Node_Type renames Container.Nodes (Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1470,14 +1419,11 @@ package body Ada.Containers.Bounded_Ordered_Maps is Node : constant Count_Type := Key_Ops.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in map"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.TC); declare N : Node_Type renames Container.Nodes (Node); @@ -1498,20 +1444,18 @@ package body Ada.Containers.Bounded_Ordered_Maps is New_Item : Element_Type) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.TC); pragma Assert (Vet (Container, Position.Node), "Position cursor of Replace_Element is bad"); @@ -1542,22 +1486,12 @@ package body Ada.Containers.Bounded_Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (Container); end Reverse_Iterate; ----------- @@ -1619,12 +1553,13 @@ package body Ada.Containers.Bounded_Ordered_Maps is Element : in out Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1634,25 +1569,9 @@ package body Ada.Containers.Bounded_Ordered_Maps is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (N.Key, N.Element); - - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (N.Key, N.Element); end; end Update_Element; diff --git a/gcc/ada/a-cborma.ads b/gcc/ada/a-cborma.ads index df1a2a2076f..7aa6e6c4ef6 100644 --- a/gcc/ada/a-cborma.ads +++ b/gcc/ada/a-cborma.ads @@ -45,6 +45,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Bounded_Ordered_Maps is + pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; @@ -248,7 +249,7 @@ private new Tree_Types.Tree_Type (Capacity) with null record; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Streams; procedure Write @@ -283,15 +284,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is new Controlled with record - Container : Map_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -335,6 +329,25 @@ 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. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Map : constant Map := Map'(Tree_Type with Capacity => 0); No_Element : constant Cursor := Cursor'(null, 0); @@ -344,7 +357,8 @@ private record Container : Map_Access; Node : Count_Type; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb index af894ee11fb..85d65666cdc 100644 --- a/gcc/ada/a-cborse.adb +++ b/gcc/ada/a-cborse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,6 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); @@ -42,7 +44,9 @@ with System; use type System.Address; package body Ada.Containers.Bounded_Ordered_Sets is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ------------------------------ -- Access to Fields of Node -- @@ -141,11 +145,11 @@ package body Ada.Containers.Bounded_Ordered_Sets is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -165,7 +169,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function "<" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor equals No_Element"; end if; @@ -177,7 +181,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function "<" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -219,11 +223,11 @@ package body Ada.Containers.Bounded_Ordered_Sets is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -245,7 +249,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function ">" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = 0 then + if Checks and then Right.Node = 0 then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -257,7 +261,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function ">" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = 0 then + if Checks and then Left.Node = 0 then raise Constraint_Error with "Left cursor equals No_Element"; end if; @@ -268,24 +272,6 @@ package body Ada.Containers.Bounded_Ordered_Sets is end ">"; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Set renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - - ------------ -- Assign -- ------------ @@ -361,7 +347,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error with "Target capacity is less than Source length"; end if; @@ -409,11 +395,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -424,15 +411,14 @@ package body Ada.Containers.Bounded_Ordered_Sets is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => N.Element'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -461,7 +447,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is C := Source.Length; elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Capacity value too small"; end if; @@ -476,18 +462,16 @@ package body Ada.Containers.Bounded_Ordered_Sets is procedure Delete (Container : in out Set; Position : in out Cursor) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (Container, Position.Node), "bad cursor in Delete"); @@ -504,7 +488,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is begin Tree_Operations.Delete_Node_Sans_Free (Container, X); - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "attempt to delete element not in set"; end if; @@ -553,7 +537,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -620,27 +604,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Set renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -693,7 +657,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function First_Element (Container : Set) return Element_Type is begin - if Container.First = 0 then + if Checks and then Container.First = 0 then raise Constraint_Error with "set is empty"; end if; @@ -742,23 +706,6 @@ package body Ada.Containers.Bounded_Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - B : Natural renames Control.Container.Busy; - L : Natural renames Control.Container.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------- -- Ceiling -- ------------- @@ -782,25 +729,20 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; declare - Cur : Cursor := Find (Container, Key); - pragma Unmodified (Cur); - N : Node_Type renames Container.Nodes (Node); - B : Natural renames Cur.Container.Busy; - L : Natural renames Cur.Container.Lock; - + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => N.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -822,7 +764,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is X : constant Count_Type := Key_Keys.Find (Container, Key); begin - if X = 0 then + if Checks and then X = 0 then raise Constraint_Error with "attempt to delete key not in set"; end if; @@ -838,7 +780,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; @@ -874,15 +816,10 @@ package body Ada.Containers.Bounded_Ordered_Sets is procedure Finalize (Control : in out Reference_Control_Type) is begin if Control.Container /= null then - declare - B : Natural renames Control.Container.Busy; - L : Natural renames Control.Container.Lock; - begin - B := B - 1; - L := L - 1; - end; - - if not (Key (Control.Pos) = Control.Old_Key.all) then + Impl.Reference_Control_Type (Control).Finalize; + + if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) + then Delete (Control.Container.all, Key (Control.Pos)); raise Program_Error; end if; @@ -943,7 +880,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -975,11 +912,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -990,19 +928,17 @@ package body Ada.Containers.Bounded_Ordered_Sets is declare N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; begin return R : constant Reference_Type := (Element => N.Element'Access, Control => (Controlled with + Container.TC'Unrestricted_Access, Container => Container'Access, Pos => Position, Old_Key => new Key_Type'(Key (Position)))) do - B := B + 1; - L := L + 1; + Lock (Container.TC); end return; end; end Reference_Preserving_Key; @@ -1014,25 +950,23 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "key not in set"; end if; declare N : Node_Type renames Container.Nodes (Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; begin return R : constant Reference_Type := (Element => N.Element'Access, Control => (Controlled with + Container.TC'Unrestricted_Access, Container => Container'Access, Pos => Find (Container, Key), Old_Key => new Key_Type'(Key))) do - B := B + 1; - L := L + 1; + Lock (Container.TC); end return; end; end Reference_Preserving_Key; @@ -1049,7 +983,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node : constant Count_Type := Key_Keys.Find (Container, Key); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -1067,12 +1001,13 @@ package body Ada.Containers.Bounded_Ordered_Sets is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1087,30 +1022,10 @@ package body Ada.Containers.Bounded_Ordered_Sets is N : Node_Type renames Container.Nodes (Position.Node); E : Element_Type renames N.Element; K : constant Key_Type := Key (E); - - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - Eq : Boolean; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (E); - Eq := Equivalent_Keys (K, Key (E)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - - if Eq then + Process (E); + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -1134,6 +1049,16 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Write; end Generic_Keys; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1155,10 +1080,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Container.Nodes (Position.Node).Element := New_Item; end if; @@ -1196,7 +1118,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -1250,10 +1172,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- Start of processing for Insert_Sans_Hint begin - if Container.Busy > 0 then - raise Program_Error with - "attemot to tamper with cursors (set is busy)"; - end if; + TC_Check (Container.TC); Conditional_Insert_Sans_Hint (Container, @@ -1411,29 +1330,17 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Process_Node; S : Set renames Container'Unrestricted_Access.all; - B : Natural renames S.Busy; + Busy : With_Busy (S.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (S); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (S); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1450,15 +1357,13 @@ package body Ada.Containers.Bounded_Ordered_Sets is Container => Container'Unrestricted_Access, Node => 0) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; function Iterate (Container : Set; Start : Cursor) return Set_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1471,12 +1376,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong set"; end if; @@ -1498,7 +1403,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1540,7 +1445,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is function Last_Element (Container : Set) return Element_Type is begin - if Container.Last = 0 then + if Checks and then Container.Last = 0 then raise Constraint_Error with "set is empty"; end if; @@ -1575,10 +1480,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Target.Assign (Source); Source.Clear; @@ -1621,7 +1523,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1678,7 +1580,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong set"; end if; @@ -1686,6 +1588,21 @@ package body Ada.Containers.Bounded_Ordered_Sets is return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1695,7 +1612,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -1704,24 +1621,9 @@ package body Ada.Containers.Bounded_Ordered_Sets is declare S : Set renames Position.Container.all; - B : Natural renames S.Busy; - L : Natural renames S.Lock; - + Lock : With_Lock (S.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (S.Nodes (Position.Node).Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (S.Nodes (Position.Node).Element); end; end Query_Element; @@ -1781,15 +1683,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node : constant Count_Type := Element_Keys.Find (Container, New_Item); begin - if Node = 0 then + if Checks and then Node = 0 then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Container.Nodes (Node).Element := New_Item; end Replace; @@ -1841,12 +1740,6 @@ package body Ada.Containers.Bounded_Ordered_Sets is Inserted : Boolean; Compare : Boolean; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - -- Start of processing for Replace_Element begin @@ -1864,22 +1757,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- Determine whether Item is equivalent to element on the specified -- node. + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := (if Item < Node.Element then False elsif Node.Element < Item then False else True); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - raise; end; if Compare then @@ -1887,10 +1770,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- Item is equivalent to the node's element, so we will not have to -- move the node. - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Node.Element := Item; return; @@ -1908,25 +1788,15 @@ package body Ada.Containers.Bounded_Ordered_Sets is Hint := Element_Keys.Ceiling (Container, Item); if Hint /= 0 then -- Item <= Nodes (Hint).Element + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Item < Nodes (Hint).Element; - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - raise; end; -- Item is equivalent to Nodes (Hint).Element - if not Compare then + if Checks and then not Compare then -- Ceiling returns an element that is equivalent or greater than -- Item. If Item is "not less than" the element, then by @@ -1958,10 +1828,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- because it would only be placed in the exact same position. if Hint = Index then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.TC); Node.Element := Item; return; @@ -1993,12 +1860,13 @@ package body Ada.Containers.Bounded_Ordered_Sets is New_Item : Element_Type) is begin - if Position.Node = 0 then + if Checks and then Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -2033,22 +1901,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Process_Node; S : Set renames Container'Unrestricted_Access.all; - B : Natural renames S.Busy; + Busy : With_Busy (S.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (S); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (S); end Reverse_Iterate; ----------- diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads index 9b474a66353..f342ab81b9a 100644 --- a/gcc/ada/a-cborse.ads +++ b/gcc/ada/a-cborse.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +with Ada.Containers.Helpers; private with Ada.Containers.Red_Black_Trees; private with Ada.Streams; private with Ada.Finalization; @@ -44,6 +45,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Bounded_Ordered_Sets is + pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; @@ -284,17 +286,16 @@ package Ada.Containers.Bounded_Ordered_Sets is use Ada.Streams; + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Pos : Cursor; Old_Key : Key_Access; end record; - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - overriding procedure Finalize (Control : in out Reference_Control_Type); pragma Inline (Finalize); @@ -335,7 +336,7 @@ private type Set (Capacity : Count_Type) is new Tree_Types.Tree_Type (Capacity) with null record; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -377,15 +378,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is new Controlled with record - Container : Set_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -409,6 +403,25 @@ 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. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Set : constant Set := Set'(Tree_Type with Capacity => 0); No_Element : constant Cursor := Cursor'(null, 0); @@ -418,7 +431,8 @@ private record Container : Set_Access; Node : Count_Type; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cbprqu.adb b/gcc/ada/a-cbprqu.adb index 61b9e72a3db..8256d862115 100644 --- a/gcc/ada/a-cbprqu.adb +++ b/gcc/ada/a-cbprqu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,8 +29,6 @@ package body Ada.Containers.Bounded_Priority_Queues is - pragma Annotate (CodePeer, Skip_Analysis); - package body Implementation is ------------- diff --git a/gcc/ada/a-cbprqu.ads b/gcc/ada/a-cbprqu.ads index fb44d02c1dd..932e607a90a 100644 --- a/gcc/ada/a-cbprqu.ads +++ b/gcc/ada/a-cbprqu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, 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 -- @@ -52,6 +52,7 @@ generic Default_Ceiling : System.Any_Priority := System.Priority'Last; package Ada.Containers.Bounded_Priority_Queues is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; package Implementation is diff --git a/gcc/ada/a-cbsyqu.adb b/gcc/ada/a-cbsyqu.adb index e918a9aebfe..0f29d9f8115 100644 --- a/gcc/ada/a-cbsyqu.adb +++ b/gcc/ada/a-cbsyqu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,8 +29,6 @@ package body Ada.Containers.Bounded_Synchronized_Queues is - pragma Annotate (CodePeer, Skip_Analysis); - package body Implementation is ------------- diff --git a/gcc/ada/a-cbsyqu.ads b/gcc/ada/a-cbsyqu.ads index 908463906ce..e22e0823de3 100644 --- a/gcc/ada/a-cbsyqu.ads +++ b/gcc/ada/a-cbsyqu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, 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 -- @@ -42,6 +42,7 @@ generic Default_Ceiling : System.Any_Priority := System.Priority'Last; package Ada.Containers.Bounded_Synchronized_Queues is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; package Implementation is diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index e003cfc7c3d..011c3950730 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -33,7 +33,9 @@ with System; use type System.Address; package body Ada.Containers.Doubly_Linked_Lists is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------- -- Local Subprograms -- @@ -69,64 +71,36 @@ package body Ada.Containers.Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - - L : Node_Access; - R : Node_Access; - Result : Boolean; - begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Length /= Right.Length then return False; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - - L := Left.First; - R := Right.First; - Result := True; - for J in 1 .. Left.Length loop - if L.Element /= R.Element then - Result := False; - exit; - end if; - - L := L.Next; - R := R.Next; - end loop; - - BL := BL - 1; - LL := LL - 1; + if Left.Length = 0 then + return True; + end if; - BR := BR - 1; - LR := LR - 1; + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - return Result; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - exception - when others => - BL := BL - 1; - LL := LL - 1; + L : Node_Access := Left.First; + R : Node_Access := Right.First; + begin + for J in 1 .. Left.Length loop + if L.Element /= R.Element then + return False; + end if; - BR := BR - 1; - LR := LR - 1; + L := L.Next; + R := R.Next; + end loop; + end; - raise; + return True; end "="; ------------ @@ -137,11 +111,15 @@ package body Ada.Containers.Doubly_Linked_Lists is Src : Node_Access := Container.First; begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + if Src = null then pragma Assert (Container.Last = null); pragma Assert (Container.Length = 0); - pragma Assert (Container.Busy = 0); - pragma Assert (Container.Lock = 0); return; end if; @@ -152,8 +130,7 @@ package body Ada.Containers.Doubly_Linked_Lists is Container.First := null; Container.Last := null; Container.Length := 0; - Container.Busy := 0; - Container.Lock := 0; + Zero_Counts (Container.TC); Container.First := new Node_Type'(Src.Element, null, null); Container.Last := Container.First; @@ -171,20 +148,6 @@ package body Ada.Containers.Doubly_Linked_Lists is end loop; end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Append -- ------------ @@ -230,18 +193,14 @@ package body Ada.Containers.Doubly_Linked_Lists is if Container.Length = 0 then pragma Assert (Container.First = null); pragma Assert (Container.Last = null); - pragma Assert (Container.Busy = 0); - pragma Assert (Container.Lock = 0); + pragma Assert (Container.TC = (Busy => 0, Lock => 0)); return; end if; pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); while Container.Length > 1 loop X := Container.First; @@ -276,11 +235,12 @@ package body Ada.Containers.Doubly_Linked_Lists is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -288,16 +248,14 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); declare - C : List renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -337,12 +295,13 @@ package body Ada.Containers.Doubly_Linked_Lists is X : Node_Access; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -360,10 +319,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for Index in 1 .. Count loop X := Position.Node; @@ -412,10 +368,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for J in 1 .. Count loop X := Container.First; @@ -450,10 +403,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for J in 1 .. Count loop X := Container.Last; @@ -474,14 +424,14 @@ package body Ada.Containers.Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; - else - pragma Assert (Vet (Position), "bad cursor in Element"); - - return Position.Node.Element; end if; + + pragma Assert (Vet (Position), "bad cursor in Element"); + + return Position.Node.Element; end Element; -------------- @@ -491,27 +441,7 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -531,57 +461,30 @@ package body Ada.Containers.Doubly_Linked_Lists is Node := Container.First; else - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; - else - pragma Assert (Vet (Position), "bad cursor in Find"); end if; + + pragma Assert (Vet (Position), "bad cursor in Find"); end if; -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Node_Access; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - pragma Warnings (Off); - -- Deal with junk infinite loop warning from below loop - - Result := null; while Node /= null loop if Node.Element = Item then - Result := Node; - exit; - else - Node := Node.Next; + return Cursor'(Container'Unrestricted_Access, Node); end if; - end loop; - - pragma Warnings (On); - -- End of section dealing with junk infinite loop warning - B := B - 1; - L := L - 1; - - if Result = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; + Node := Node.Next; + end loop; - exception - when others => - B := B - 1; - L := L - 1; - raise; + return No_Element; end; end Find; @@ -626,11 +529,11 @@ package body Ada.Containers.Doubly_Linked_Lists is function First_Element (Container : List) return Element_Type is begin - if Container.First = null then + if Checks and then Container.First = null then raise Constraint_Error with "list is empty"; - else - return Container.First.Element; end if; + + return Container.First.Element; end First_Element; ---------- @@ -673,40 +576,23 @@ package body Ada.Containers.Doubly_Linked_Lists is --------------- function Is_Sorted (Container : List) return Boolean is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Node : Node_Access; - Result : Boolean; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; + Lock : With_Lock (Container.TC'Unrestricted_Access); + Node : Node_Access; + begin Node := Container.First; - Result := True; for Idx in 2 .. Container.Length loop if Node.Next.Element < Node.Element then - Result := False; - exit; + return False; end if; Node := Node.Next; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return True; end Is_Sorted; ----------- @@ -730,44 +616,29 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; end if; - if Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length + then raise Constraint_Error with "new length exceeds maximum"; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; - - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); LI, RI, RJ : Node_Access; begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - LI := Target.First; RI := Source.First; while RI /= null loop @@ -791,22 +662,6 @@ package body Ada.Containers.Doubly_Linked_Lists is LI := LI.Next; end if; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -889,32 +744,15 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Front => null, Back => null); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - raise; end; pragma Assert (Container.First.Prev = null); @@ -959,37 +797,36 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Before.Container /= null then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor designates wrong list"; - else - pragma Assert (Vet (Before), "bad cursor in Insert"); end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then Position := Before; return; + end if; - elsif Container.Length > Count_Type'Last - Count then + if Checks and then Container.Length > Count_Type'Last - Count then raise Constraint_Error with "new length exceeds maximum"; + end if; - elsif Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; + TC_Check (Container.TC); - else - New_Node := new Node_Type'(New_Item, null, null); - First_Node := New_Node; - Insert_Internal (Container, Before.Node, New_Node); + New_Node := new Node_Type'(New_Item, null, null); + First_Node := New_Node; + Insert_Internal (Container, Before.Node, New_Node); - for J in 2 .. Count loop - New_Node := new Node_Type'(New_Item, null, null); - Insert_Internal (Container, Before.Node, New_Node); - end loop; + for J in 2 .. Count loop + New_Node := new Node_Type'(New_Item, null, null); + Insert_Internal (Container, Before.Node, New_Node); + end loop; - Position := Cursor'(Container'Unchecked_Access, First_Node); - end if; + Position := Cursor'(Container'Unchecked_Access, First_Node); end Insert; procedure Insert @@ -1015,12 +852,13 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Before.Container /= null then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor designates wrong list"; - else - pragma Assert (Vet (Before), "bad cursor in Insert"); end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then @@ -1028,25 +866,22 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Length > Count_Type'Last - Count then + if Checks and then Container.Length > Count_Type'Last - Count then raise Constraint_Error with "new length exceeds maximum"; + end if; - elsif Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; + TC_Check (Container.TC); - else - New_Node := new Node_Type; - First_Node := New_Node; - Insert_Internal (Container, Before.Node, New_Node); + New_Node := new Node_Type; + First_Node := New_Node; + Insert_Internal (Container, Before.Node, New_Node); - for J in 2 .. Count loop - New_Node := new Node_Type; - Insert_Internal (Container, Before.Node, New_Node); - end loop; + for J in 2 .. Count loop + New_Node := new Node_Type; + Insert_Internal (Container, Before.Node, New_Node); + end loop; - Position := Cursor'(Container'Unchecked_Access, First_Node); - end if; + Position := Cursor'(Container'Unchecked_Access, First_Node); end Insert; --------------------- @@ -1114,31 +949,19 @@ package body Ada.Containers.Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Node_Access := Container.First; begin - B := B + 1; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Next; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Next; + end loop; end Iterate; function Iterate (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1155,15 +978,13 @@ package body Ada.Containers.Doubly_Linked_Lists is Container => Container'Unrestricted_Access, Node => null) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; function Iterate (Container : List; Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1176,34 +997,34 @@ package body Ada.Containers.Doubly_Linked_Lists is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; + end if; - elsif Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong list"; - - else - pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the - -- First and Last selector functions of the iterator object. When - -- the Node component is non-null (as is the case here), it means - -- that this is a partial iteration, over a subset of the complete - -- sequence of items. The iterator object was constructed with - -- a start expression, indicating the position from which the - -- iteration begins. Note that the start position has the same value - -- irrespective of whether this is a forward or reverse iteration. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - B := B + 1; - end return; end if; + + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this is a + -- partial iteration, over a subset of the complete sequence of items. + -- The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; end Iterate; ---------- @@ -1247,11 +1068,11 @@ package body Ada.Containers.Doubly_Linked_Lists is function Last_Element (Container : List) return Element_Type is begin - if Container.Last = null then + if Checks and then Container.Last = null then raise Constraint_Error with "list is empty"; - else - return Container.Last.Element; end if; + + return Container.Last.Element; end Last_Element; ------------ @@ -1274,23 +1095,20 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Target'Address = Source'Address then return; + end if; - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + TC_Check (Source.TC); - else - Clear (Target); + Clear (Target); - Target.First := Source.First; - Source.First := null; + Target.First := Source.First; + Source.First := null; - Target.Last := Source.Last; - Source.Last := null; + Target.Last := Source.Last; + Source.Last := null; - Target.Length := Source.Length; - Source.Length := 0; - end if; + Target.Length := Source.Length; + Source.Length := 0; end Move; ---------- @@ -1329,12 +1147,14 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong list"; - else - return Next (Position); end if; + + return Next (Position); end Next; ------------- @@ -1386,12 +1206,14 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong list"; - else - return Previous (Position); end if; + + return Previous (Position); end Previous; ---------------------- @@ -1401,15 +1223,10 @@ package body Ada.Containers.Doubly_Linked_Lists is function Pseudo_Reference (Container : aliased List'Class) return Reference_Control_Type is - C : constant List_Access := Container'Unrestricted_Access; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -1422,7 +1239,7 @@ package body Ada.Containers.Doubly_Linked_Lists is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; @@ -1430,25 +1247,9 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Query_Element"); declare - C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - + Lock : With_Lock (Position.Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element); end; end Query_Element; @@ -1537,30 +1338,28 @@ package body Ada.Containers.Doubly_Linked_Lists is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in function Reference"); + pragma Assert (Vet (Position), "bad cursor in function Reference"); - declare - C : List renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; - end if; + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Reference; --------------------- @@ -1573,22 +1372,20 @@ package body Ada.Containers.Doubly_Linked_Lists is New_Item : Element_Type) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; + TE_Check (Container.TC); - else - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - Position.Node.Element := New_Item; - end if; + Position.Node.Element := New_Item; end Replace_Element; ---------------------- @@ -1649,10 +1446,7 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); Container.First := J; Container.Last := I; @@ -1694,51 +1488,30 @@ package body Ada.Containers.Doubly_Linked_Lists is Node := Container.Last; else - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; - else - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; + + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Node_Access; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := null; while Node /= null loop if Node.Element = Item then - Result := Node; - exit; + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Prev; end loop; - B := B - 1; - L := L - 1; - - if Result = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return No_Element; end; end Reverse_Find; @@ -1750,26 +1523,14 @@ package body Ada.Containers.Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Node_Access := Container.Last; begin - B := B + 1; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Prev; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Prev; + end loop; end Reverse_Iterate; ------------ @@ -1783,31 +1544,26 @@ package body Ada.Containers.Doubly_Linked_Lists is is begin if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; - else - pragma Assert (Vet (Before), "bad cursor in Splice"); end if; + + pragma Assert (Vet (Before), "bad cursor in Splice"); end if; if Target'Address = Source'Address or else Source.Length = 0 then return; + end if; - elsif Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length then raise Constraint_Error with "new length exceeds maximum"; + end if; - elsif Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; + TC_Check (Target.TC); + TC_Check (Source.TC); - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - - else - Splice_Internal (Target, Before.Node, Source); - end if; + Splice_Internal (Target, Before.Node, Source); end Splice; procedure Splice @@ -1817,19 +1573,20 @@ package body Ada.Containers.Doubly_Linked_Lists is is begin if Before.Container /= null then - if Before.Container /= Container'Unchecked_Access then + if Checks and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor designates wrong container"; - else - pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -1844,10 +1601,7 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.Length >= 2); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); if Before.Node = null then pragma Assert (Position.Node /= Container.Last); @@ -1925,40 +1679,34 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; - else - pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - else - pragma Assert (Vet (Position), "bad Position cursor in Splice"); - - if Target.Length = Count_Type'Last then - raise Constraint_Error with "Target is full"; + pragma Assert (Vet (Position), "bad Position cursor in Splice"); - elsif Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; + if Checks and then Target.Length = Count_Type'Last then + raise Constraint_Error with "Target is full"; + end if; - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + TC_Check (Target.TC); + TC_Check (Source.TC); - else - Splice_Internal (Target, Before.Node, Source, Position.Node); - Position.Container := Target'Unchecked_Access; - end if; - end if; + Splice_Internal (Target, Before.Node, Source, Position.Node); + Position.Container := Target'Unchecked_Access; end Splice; --------------------- @@ -2114,19 +1862,19 @@ package body Ada.Containers.Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null then + if Checks and then I.Node = null then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = null then + if Checks and then J.Node = null then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unchecked_Access then + if Checks and then I.Container /= Container'Unchecked_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unchecked_Access then + if Checks and then J.Container /= Container'Unchecked_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2134,10 +1882,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; - end if; + TE_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap"); pragma Assert (Vet (J), "bad J cursor in Swap"); @@ -2163,19 +1908,19 @@ package body Ada.Containers.Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null then + if Checks and then I.Node = null then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = null then + if Checks and then J.Node = null then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2183,10 +1928,7 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap_Links"); pragma Assert (Vet (J), "bad J cursor in Swap_Links"); @@ -2227,37 +1969,22 @@ package body Ada.Containers.Doubly_Linked_Lists is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + pragma Assert (Vet (Position), "bad cursor in Update_Element"); - L := L - 1; - B := B - 1; - end; - end if; + declare + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + Process (Position.Node.Element); + end; end Update_Element; --------- diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index 35aaf9f6099..a1bc17cb020 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -43,6 +44,7 @@ generic return Boolean is <>; package Ada.Containers.Doubly_Linked_Lists is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -248,6 +250,10 @@ private pragma Inline (Next); pragma Inline (Previous); + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + type Node_Type; type Node_Access is access Node_Type; @@ -263,11 +269,10 @@ private type List is new Controlled with record - First : Node_Access; - Last : Node_Access; + First : Node_Access := null; + Last : Node_Access := null; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; end record; overriding procedure Adjust (Container : in out List); @@ -307,16 +312,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is - new Controlled with record - Container : List_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -374,13 +371,14 @@ private -- container, and increments the Lock. Finalization of this object will -- decrement the Lock. - type Element_Access is access all Element_Type; + type Element_Access is access all Element_Type with + Storage_Size => 0; function Get_Element_Access (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - Empty_List : constant List := (Controlled with null, null, 0, 0, 0); + Empty_List : constant List := (Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -389,7 +387,8 @@ private record Container : List_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb index 2e8676b4495..6fed4cce00d 100644 --- a/gcc/ada/a-cfdlli.adb +++ b/gcc/ada/a-cfdlli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,7 +30,6 @@ with System; use type System.Address; package body Ada.Containers.Formal_Doubly_Linked_Lists with SPARK_Mode => Off is - pragma Annotate (CodePeer, Skip_Analysis); ----------------------- -- Local Subprograms -- @@ -581,7 +580,7 @@ is -- Generic_Sorting -- --------------------- - package body Generic_Sorting is + package body Generic_Sorting with SPARK_Mode => Off is --------------- -- Is_Sorted -- diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads index f4a25861bff..36e1869ebd8 100644 --- a/gcc/ada/a-cfdlli.ads +++ b/gcc/ada/a-cfdlli.ads @@ -66,6 +66,7 @@ package Ada.Containers.Formal_Doubly_Linked_Lists with SPARK_Mode is pragma Annotate (GNATprove, External_Axiomatization); + pragma Annotate (CodePeer, Skip_Analysis); type List (Capacity : Count_Type) is private with Iterable => (First => First, @@ -299,7 +300,7 @@ is generic with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is + package Generic_Sorting with SPARK_Mode is function Is_Sorted (Container : List) return Boolean with Global => null; diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb index 11dbc6fe66d..7fd9b7f7bb4 100644 --- a/gcc/ada/a-cfhama.adb +++ b/gcc/ada/a-cfhama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -38,7 +38,6 @@ with System; use type System.Address; package body Ada.Containers.Formal_Hashed_Maps with SPARK_Mode => Off is - pragma Annotate (CodePeer, Skip_Analysis); ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/a-cfhama.ads index fd94b1b1101..8d6e96a3c58 100644 --- a/gcc/ada/a-cfhama.ads +++ b/gcc/ada/a-cfhama.ads @@ -70,6 +70,7 @@ package Ada.Containers.Formal_Hashed_Maps with SPARK_Mode is pragma Annotate (GNATprove, External_Axiomatization); + pragma Annotate (CodePeer, Skip_Analysis); type Map (Capacity : Count_Type; Modulus : Hash_Type) is private with Iterable => (First => First, diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb index 8d73a2c385c..cc900f356aa 100644 --- a/gcc/ada/a-cfhase.adb +++ b/gcc/ada/a-cfhase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -38,7 +38,6 @@ with System; use type System.Address; package body Ada.Containers.Formal_Hashed_Sets with SPARK_Mode => Off is - pragma Annotate (CodePeer, Skip_Analysis); ----------------------- -- Local Subprograms -- @@ -516,7 +515,7 @@ is end loop; end Find_Equivalent_Key; - -- Start of processing of Equivalent_Sets + -- Start of processing for Equivalent_Sets begin return Is_Equivalent (Left, Right); @@ -1387,7 +1386,7 @@ is end; end Vet; - package body Generic_Keys is + package body Generic_Keys with SPARK_Mode => Off is ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads index e0d210e5334..7ab161168ef 100644 --- a/gcc/ada/a-cfhase.ads +++ b/gcc/ada/a-cfhase.ads @@ -72,6 +72,7 @@ package Ada.Containers.Formal_Hashed_Sets with SPARK_Mode is pragma Annotate (GNATprove, External_Axiomatization); + pragma Annotate (CodePeer, Skip_Analysis); type Set (Capacity : Count_Type; Modulus : Hash_Type) is private with Iterable => (First => First, @@ -279,7 +280,7 @@ is with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - package Generic_Keys is + package Generic_Keys with SPARK_Mode is function Key (Container : Set; Position : Cursor) return Key_Type with Global => null; diff --git a/gcc/ada/a-cfinve.adb b/gcc/ada/a-cfinve.adb index f088b9ed118..b520d65f020 100644 --- a/gcc/ada/a-cfinve.adb +++ b/gcc/ada/a-cfinve.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2014-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -28,7 +28,6 @@ package body Ada.Containers.Formal_Indefinite_Vectors with SPARK_Mode => Off is - pragma Annotate (CodePeer, Skip_Analysis); function H (New_Item : Element_Type) return Holder renames To_Holder; function E (Container : Holder) return Element_Type renames Get; @@ -174,7 +173,7 @@ is -- Generic_Sorting -- --------------------- - package body Generic_Sorting is + package body Generic_Sorting with SPARK_Mode => Off is function "<" (X, Y : Holder) return Boolean is (E (X) < E (Y)); package Def_Sorting is new Def.Generic_Sorting ("<"); diff --git a/gcc/ada/a-cfinve.ads b/gcc/ada/a-cfinve.ads index 7559df6e4b5..e76ae8d8926 100644 --- a/gcc/ada/a-cfinve.ads +++ b/gcc/ada/a-cfinve.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2014-2015, 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 -- @@ -41,8 +41,12 @@ generic type Element_Type (<>) is private; Max_Size_In_Storage_Elements : Natural := Element_Type'Max_Size_In_Storage_Elements; - -- This has the same meaning as in Ada.Containers.Bounded_Holders, with the - -- same restrictions. + -- Maximum size of Vector elements in bytes. This has the same meaning as + -- in Ada.Containers.Bounded_Holders, with the same restrictions. Note that + -- setting this too small can lead to erroneous execution; see comments in + -- Ada.Containers.Bounded_Holders. If Element_Type is class-wide, it is the + -- responsibility of clients to calculate the maximum size of all types in + -- the class. with function "=" (Left, Right : Element_Type) return Boolean is <>; @@ -55,6 +59,7 @@ package Ada.Containers.Formal_Indefinite_Vectors with SPARK_Mode => On is pragma Annotate (GNATprove, External_Axiomatization); + pragma Annotate (CodePeer, Skip_Analysis); subtype Extended_Index is Index_Type'Base range Index_Type'First - 1 .. @@ -198,7 +203,7 @@ is generic with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is + package Generic_Sorting with SPARK_Mode is function Is_Sorted (Container : Vector) return Boolean with Global => null; diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb index bd088bd46df..4bf302ded63 100644 --- a/gcc/ada/a-cforma.adb +++ b/gcc/ada/a-cforma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,7 +37,6 @@ with System; use type System.Address; package body Ada.Containers.Formal_Ordered_Maps with SPARK_Mode => Off is - pragma Annotate (CodePeer, Skip_Analysis); ----------------------------- -- Node Access Subprograms -- diff --git a/gcc/ada/a-cforma.ads b/gcc/ada/a-cforma.ads index 58a768c9b1f..018a21bd6df 100644 --- a/gcc/ada/a-cforma.ads +++ b/gcc/ada/a-cforma.ads @@ -71,6 +71,7 @@ package Ada.Containers.Formal_Ordered_Maps with SPARK_Mode is pragma Annotate (GNATprove, External_Axiomatization); + pragma Annotate (CodePeer, Skip_Analysis); function Equivalent_Keys (Left, Right : Key_Type) return Boolean with Global => null; diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb index e1203215cc9..42a8503f8a8 100644 --- a/gcc/ada/a-cforse.adb +++ b/gcc/ada/a-cforse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,7 +41,6 @@ with System; use type System.Address; package body Ada.Containers.Formal_Ordered_Sets with SPARK_Mode => Off is - pragma Annotate (CodePeer, Skip_Analysis); ------------------------------ -- Access to Fields of Node -- @@ -584,7 +583,7 @@ is ------------------- function First_Element (Container : Set) return Element_Type is - Fst : constant Count_Type := First (Container).Node; + Fst : constant Count_Type := First (Container).Node; begin if Fst = 0 then raise Constraint_Error with "set is empty"; @@ -674,7 +673,7 @@ is -- Generic_Keys -- ------------------ - package body Generic_Keys is + package body Generic_Keys with SPARK_Mode => Off is ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads index a69aa4f3de4..f7f03ca4f5f 100644 --- a/gcc/ada/a-cforse.ads +++ b/gcc/ada/a-cforse.ads @@ -69,6 +69,7 @@ package Ada.Containers.Formal_Ordered_Sets with SPARK_Mode is pragma Annotate (GNATprove, External_Axiomatization); + pragma Annotate (CodePeer, Skip_Analysis); function Equivalent_Elements (Left, Right : Element_Type) return Boolean with @@ -288,7 +289,7 @@ is with function "<" (Left, Right : Key_Type) return Boolean is <>; - package Generic_Keys is + package Generic_Keys with SPARK_Mode is function Equivalent_Keys (Left, Right : Key_Type) return Boolean with Global => null; diff --git a/gcc/ada/a-chtgbk.adb b/gcc/ada/a-chtgbk.adb index 941da83a493..43d0c1aece2 100644 --- a/gcc/ada/a-chtgbk.adb +++ b/gcc/ada/a-chtgbk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,6 +29,10 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------------- -- Checked_Equivalent_Keys -- ----------------------------- @@ -38,28 +42,9 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is Key : Key_Type; Node : Count_Type) return Boolean is - Result : Boolean; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := Equivalent_Keys (Key, HT.Nodes (Node)); - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return Equivalent_Keys (Key, HT.Nodes (Node)); end Checked_Equivalent_Keys; ------------------- @@ -70,28 +55,9 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is (HT : aliased in out Hash_Table_Type'Class; Key : Key_Type) return Hash_Type is - Result : Hash_Type; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; end Checked_Index; -------------------------- @@ -115,10 +81,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Indx := Checked_Index (HT, Key); X := HT.Buckets (Indx); @@ -128,10 +91,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is end if; if Checked_Equivalent_Keys (HT, Key, X) then - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); HT.Buckets (Indx) := Next (HT.Nodes (X)); HT.Length := HT.Length - 1; return; @@ -146,10 +106,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is end if; if Checked_Equivalent_Keys (HT, Key, X) then - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X))); HT.Length := HT.Length - 1; return; @@ -204,16 +161,13 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Indx := Checked_Index (HT, Key); Node := HT.Buckets (Indx); if Node = 0 then - if HT.Length = HT.Capacity then + if Checks and then HT.Length = HT.Capacity then raise Capacity_Error with "no more capacity for insertion"; end if; @@ -239,7 +193,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is exit when Node = 0; end loop; - if HT.Length = HT.Capacity then + if Checks and then HT.Length = HT.Capacity then raise Capacity_Error with "no more capacity for insertion"; end if; @@ -285,24 +239,9 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- the computation of New_Index until after the tampering check. ??? declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length; - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; -- Replace_Element is allowed to change a node's key to Key @@ -311,10 +250,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- hash table as this one, a key is mapped to exactly one node.) if Checked_Equivalent_Keys (HT, Key, Node) then - if HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (container is locked)"; - end if; + TE_Check (HT.TC); -- The new Key value is mapped to this same Node, so Node -- stays in the same bucket. @@ -330,7 +266,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is N := New_Bucket; while N /= 0 loop - if Checked_Equivalent_Keys (HT, Key, N) then + if Checks and then Checked_Equivalent_Keys (HT, Key, N) then pragma Assert (N /= Node); raise Program_Error with "attempt to replace existing element"; @@ -350,10 +286,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- The node is already in the bucket implied by Key. In this case -- we merely change its value without moving it. - if HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (container is locked)"; - end if; + TE_Check (HT.TC); Assign (NN (Node), Key); return; @@ -361,10 +294,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is -- The node is a bucket different from the bucket implied by Key - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); -- Do the assignment first, before moving the node, so that if Assign -- propagates an exception, then the hash table will not have been diff --git a/gcc/ada/a-chtgbk.ads b/gcc/ada/a-chtgbk.ads index d6d207780f6..037a87ec499 100644 --- a/gcc/ada/a-chtgbk.ads +++ b/gcc/ada/a-chtgbk.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,7 +34,7 @@ generic with package HT_Types is new Generic_Bounded_Hash_Table_Types (<>); - use HT_Types; + use HT_Types, HT_Types.Implementation; with function Next (Node : Node_Type) return Count_Type; diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb index d114bc8bb04..f4f7c1c237e 100644 --- a/gcc/ada/a-chtgbo.adb +++ b/gcc/ada/a-chtgbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,10 @@ with System; use type System.Address; package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ------------------- -- Checked_Index -- ------------------- @@ -39,28 +43,9 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is (Hash_Table : aliased in out Hash_Table_Type'Class; Node : Count_Type) return Hash_Type is - Result : Hash_Type; - - B : Natural renames Hash_Table.Busy; - L : Natural renames Hash_Table.Lock; - + Lock : With_Lock (Hash_Table.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := Index (Hash_Table, Hash_Table.Nodes (Node)); - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return Index (Hash_Table, Hash_Table.Nodes (Node)); end Checked_Index; ----------- @@ -69,10 +54,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is procedure Clear (HT : in out Hash_Table_Type'Class) is begin - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); HT.Length := 0; -- HT.Busy := 0; @@ -96,7 +78,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is begin Prev := HT.Buckets (Indx); - if Prev = 0 then + if Checks and then Prev = 0 then raise Program_Error with "attempt to delete node from empty hash bucket"; end if; @@ -107,7 +89,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is return; end if; - if HT.Length = 1 then + if Checks and then HT.Length = 1 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -115,7 +97,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is loop Curr := Next (HT.Nodes (Prev)); - if Curr = 0 then + if Checks and then Curr = 0 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -139,7 +121,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is Curr : Count_Type; begin - if HT.Length = 0 then + if Checks and then HT.Length = 0 then raise Program_Error with "attempt to delete node from empty hashed container"; end if; @@ -147,7 +129,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is Indx := Checked_Index (HT, X); Prev := HT.Buckets (Indx); - if Prev = 0 then + if Checks and then Prev = 0 then raise Program_Error with "attempt to delete node from empty hash bucket"; end if; @@ -158,7 +140,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is return; end if; - if HT.Length = 1 then + if Checks and then HT.Length = 1 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -166,7 +148,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is loop Curr := Next (HT.Nodes (Prev)); - if Curr = 0 then + if Checks and then Curr = 0 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -363,13 +345,11 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is function Generic_Equal (L, R : Hash_Table_Type'Class) return Boolean is - BL : Natural renames L'Unrestricted_Access.Busy; - LL : Natural renames L'Unrestricted_Access.Lock; - - BR : Natural renames R'Unrestricted_Access.Busy; - LR : Natural renames R'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - Result : Boolean; + Lock_L : With_Lock (L.TC'Unrestricted_Access); + Lock_R : With_Lock (R.TC'Unrestricted_Access); L_Index : Hash_Type; L_Node : Count_Type; @@ -398,23 +378,13 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is L_Index := L_Index + 1; end loop; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - -- For each node of hash table L, search for an equivalent node in hash -- table R. N := L.Length; loop if not Find (HT => R, Key => L.Nodes (L_Node)) then - Result := False; - exit; + return False; end if; N := N - 1; @@ -426,8 +396,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is -- We have exhausted the nodes in this bucket if N = 0 then - Result := True; - exit; + return True; end if; -- Find the next bucket @@ -439,24 +408,6 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is end loop; end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end Generic_Equal; ----------------------- @@ -495,7 +446,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is Count_Type'Base'Read (Stream, N); - if N < 0 then + if Checks and then N < 0 then raise Program_Error with "stream appears to be corrupt"; end if; @@ -503,7 +454,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is return; end if; - if N > HT.Capacity then + if Checks and then N > HT.Capacity then raise Capacity_Error with "too many elements in stream"; end if; diff --git a/gcc/ada/a-chtgbo.ads b/gcc/ada/a-chtgbo.ads index 5019154205d..892bdaaf1df 100644 --- a/gcc/ada/a-chtgbo.ads +++ b/gcc/ada/a-chtgbo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -36,7 +36,7 @@ generic with package HT_Types is new Generic_Bounded_Hash_Table_Types (<>); - use HT_Types; + use HT_Types, HT_Types.Implementation; with function Hash_Node (Node : Node_Type) return Hash_Type; diff --git a/gcc/ada/a-chtgke.adb b/gcc/ada/a-chtgke.adb index df7821d74b9..cab0c09bc35 100644 --- a/gcc/ada/a-chtgke.adb +++ b/gcc/ada/a-chtgke.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,6 +29,10 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------------- -- Checked_Equivalent_Keys -- ----------------------------- @@ -38,28 +42,9 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is Key : Key_Type; Node : Node_Access) return Boolean is - Result : Boolean; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := Equivalent_Keys (Key, Node); - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return Equivalent_Keys (Key, Node); end Checked_Equivalent_Keys; ------------------- @@ -70,28 +55,9 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is (HT : aliased in out Hash_Table_Type; Key : Key_Type) return Hash_Type is - Result : Hash_Type; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := Hash (Key) mod HT.Buckets'Length; - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return Hash (Key) mod HT.Buckets'Length; end Checked_Index; -------------------------- @@ -115,10 +81,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Indx := Checked_Index (HT, Key); X := HT.Buckets (Indx); @@ -128,10 +91,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is end if; if Checked_Equivalent_Keys (HT, Key, X) then - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); HT.Buckets (Indx) := Next (X); HT.Length := HT.Length - 1; return; @@ -146,10 +106,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is end if; if Checked_Equivalent_Keys (HT, Key, X) then - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Set_Next (Node => Prev, Next => Next (X)); HT.Length := HT.Length - 1; return; @@ -202,16 +159,13 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Indx := Checked_Index (HT, Key); Node := HT.Buckets (Indx); if Node = null then - if HT.Length = Count_Type'Last then + if Checks and then HT.Length = Count_Type'Last then raise Constraint_Error; end if; @@ -235,7 +189,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is exit when Node = null; end loop; - if HT.Length = Count_Type'Last then + if Checks and then HT.Length = Count_Type'Last then raise Constraint_Error; end if; @@ -269,31 +223,13 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- element tampering by a generic actual subprogram. declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Old_Indx := Hash (Node) mod HT.Buckets'Length; - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; if Checked_Equivalent_Keys (HT, Key, Node) then - if HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (container is locked)"; - end if; + TE_Check (HT.TC); -- We can change a node's key to Key (that's what Assign is for), but -- only if Key is not already in the hash table. (In a unique-key @@ -312,7 +248,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is N := New_Bucket; while N /= null loop - if Checked_Equivalent_Keys (HT, Key, N) then + if Checks and then Checked_Equivalent_Keys (HT, Key, N) then pragma Assert (N /= Node); raise Program_Error with "attempt to replace existing element"; @@ -332,10 +268,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- The node is already in the bucket implied by Key. In this case -- we merely change its value without moving it. - if HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (container is locked)"; - end if; + TE_Check (HT.TC); Assign (Node, Key); return; @@ -343,10 +276,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -- The node is a bucket different from the bucket implied by Key - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); -- Do the assignment first, before moving the node, so that if Assign -- propagates an exception, then the hash table will not have been diff --git a/gcc/ada/a-chtgke.ads b/gcc/ada/a-chtgke.ads index 37256e2eb59..00b31384587 100644 --- a/gcc/ada/a-chtgke.ads +++ b/gcc/ada/a-chtgke.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,7 +34,7 @@ generic with package HT_Types is new Generic_Hash_Table_Types (<>); - use HT_Types; + use HT_Types, HT_Types.Implementation; with function Next (Node : Node_Access) return Node_Access; diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb index dda5f2cccf7..0d7f88fa3fb 100644 --- a/gcc/ada/a-chtgop.adb +++ b/gcc/ada/a-chtgop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,6 +34,10 @@ with System; use type System.Address; package body Ada.Containers.Hash_Tables.Generic_Operations is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + type Buckets_Allocation is access all Buckets_Type; -- Used for allocation and deallocation (see New_Buckets and Free_Buckets). -- This is necessary because Buckets_Access has an empty storage pool. @@ -130,28 +134,9 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Buckets : Buckets_Type; Node : Node_Access) return Hash_Type is - Result : Hash_Type; - - B : Natural renames Hash_Table.Busy; - L : Natural renames Hash_Table.Lock; - + Lock : With_Lock (Hash_Table.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := Index (Buckets, Node); - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return Index (Buckets, Node); end Checked_Index; function Checked_Index @@ -171,10 +156,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Node : Node_Access; begin - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); while HT.Length > 0 loop while HT.Buckets (Index) = null loop @@ -217,7 +199,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return; end if; - if HT.Length = 1 then + if Checks and then HT.Length = 1 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -225,7 +207,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is loop Curr := Next (Prev); - if Curr = null then + if Checks and then Curr = null then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -256,7 +238,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Curr : Node_Access; begin - if HT.Length = 0 then + if Checks and then HT.Length = 0 then raise Program_Error with "attempt to delete node from empty hashed container"; end if; @@ -264,7 +246,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Indx := Checked_Index (HT, X); Prev := HT.Buckets (Indx); - if Prev = null then + if Checks and then Prev = null then raise Program_Error with "attempt to delete node from empty hash bucket"; end if; @@ -275,7 +257,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return; end if; - if HT.Length = 1 then + if Checks and then HT.Length = 1 then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -283,7 +265,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is loop Curr := Next (Prev); - if Curr = null then + if Checks and then Curr = null then raise Program_Error with "attempt to delete node not in its proper hash bucket"; end if; @@ -375,24 +357,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is function Generic_Equal (L, R : Hash_Table_Type) return Boolean is - BL : Natural renames L'Unrestricted_Access.Busy; - LL : Natural renames L'Unrestricted_Access.Lock; - - BR : Natural renames R'Unrestricted_Access.Busy; - LR : Natural renames R'Unrestricted_Access.Lock; - - Result : Boolean; - - L_Index : Hash_Type; - L_Node : Node_Access; - - N : Count_Type; - begin - if L'Address = R'Address then - return True; - end if; - if L.Length /= R.Length then return False; end if; @@ -401,73 +366,57 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return True; end if; - -- Find the first node of hash table L - - L_Index := 0; - loop - L_Node := L.Buckets (L_Index); - exit when L_Node /= null; - L_Index := L_Index + 1; - end loop; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - -- For each node of hash table L, search for an equivalent node in hash - -- table R. + Lock_L : With_Lock (L.TC'Unrestricted_Access); + Lock_R : With_Lock (R.TC'Unrestricted_Access); - N := L.Length; - loop - if not Find (HT => R, Key => L_Node) then - Result := False; - exit; - end if; + L_Index : Hash_Type; + L_Node : Node_Access; - N := N - 1; + N : Count_Type; + begin + -- Find the first node of hash table L - L_Node := Next (L_Node); + L_Index := 0; + loop + L_Node := L.Buckets (L_Index); + exit when L_Node /= null; + L_Index := L_Index + 1; + end loop; - if L_Node = null then - -- We have exhausted the nodes in this bucket + -- For each node of hash table L, search for an equivalent node in + -- hash table R. - if N = 0 then - Result := True; - exit; + N := L.Length; + loop + if not Find (HT => R, Key => L_Node) then + return False; end if; - -- Find the next bucket - - loop - L_Index := L_Index + 1; - L_Node := L.Buckets (L_Index); - exit when L_Node /= null; - end loop; - end if; - end loop; - - BL := BL - 1; - LL := LL - 1; + N := N - 1; - BR := BR - 1; - LR := LR - 1; + L_Node := Next (L_Node); - return Result; + if L_Node = null then + -- We have exhausted the nodes in this bucket - exception - when others => - BL := BL - 1; - LL := LL - 1; + if N = 0 then + return True; + end if; - BR := BR - 1; - LR := LR - 1; + -- Find the next bucket - raise; + loop + L_Index := L_Index + 1; + L_Node := L.Buckets (L_Index); + exit when L_Node /= null; + end loop; + end if; + end loop; + end; end Generic_Equal; ----------------------- @@ -507,7 +456,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Count_Type'Base'Read (Stream, N); - if N < 0 then + if Checks and then N < 0 then raise Program_Error with "stream appears to be corrupt"; end if; @@ -600,10 +549,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Clear (Target); @@ -745,10 +691,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is end if; end if; - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (HT.TC); Rehash : declare Dst_Buckets : Buckets_Access := New_Buckets (Length => NN); diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads index 70e1535c86a..4a7fbd6c743 100644 --- a/gcc/ada/a-chtgop.ads +++ b/gcc/ada/a-chtgop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,7 +37,7 @@ generic with package HT_Types is new Generic_Hash_Table_Types (<>); - use HT_Types; + use HT_Types, HT_Types.Implementation; with function Hash_Node (Node : Node_Access) return Hash_Type; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index 6e296e80c2d..58c1e938ebf 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,7 +33,9 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Doubly_Linked_Lists is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); @@ -72,64 +74,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - - L : Node_Access; - R : Node_Access; - Result : Boolean; - begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Length /= Right.Length then return False; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - - L := Left.First; - R := Right.First; - Result := True; - for J in 1 .. Left.Length loop - if L.Element.all /= R.Element.all then - Result := False; - exit; - end if; - - L := L.Next; - R := R.Next; - end loop; - - BL := BL - 1; - LL := LL - 1; + if Left.Length = 0 then + return True; + end if; - BR := BR - 1; - LR := LR - 1; + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - return Result; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - exception - when others => - BL := BL - 1; - LL := LL - 1; + L : Node_Access := Left.First; + R : Node_Access := Right.First; + begin + for J in 1 .. Left.Length loop + if L.Element.all /= R.Element.all then + return False; + end if; - BR := BR - 1; - LR := LR - 1; + L := L.Next; + R := R.Next; + end loop; + end; - raise; + return True; end "="; ------------ @@ -141,11 +115,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Dst : Node_Access; begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + if Src = null then pragma Assert (Container.Last = null); pragma Assert (Container.Length = 0); - pragma Assert (Container.Busy = 0); - pragma Assert (Container.Lock = 0); return; end if; @@ -156,8 +134,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Container.First := null; Container.Last := null; Container.Length := 0; - Container.Busy := 0; - Container.Lock := 0; declare Element : Element_Access := new Element_Type'(Src.Element.all); @@ -193,20 +169,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end loop; end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Append -- ------------ @@ -254,18 +216,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Container.Length = 0 then pragma Assert (Container.First = null); pragma Assert (Container.Last = null); - pragma Assert (Container.Busy = 0); - pragma Assert (Container.Lock = 0); + pragma Assert (Container.TC = (Busy => 0, Lock => 0)); return; end if; pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); while Container.Length > 1 loop X := Container.First; @@ -298,32 +256,33 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; - elsif Position.Node.Element = null then + end if; + + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - declare - C : List renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; - end if; + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Constant_Reference; -------------- @@ -361,17 +320,18 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is X : Node_Access; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -389,10 +349,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); for Index in 1 .. Count loop X := Position.Node; @@ -435,27 +392,25 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Count >= Container.Length then Clear (Container); return; + end if; - elsif Count = 0 then + if Count = 0 then return; + end if; - elsif Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; + TC_Check (Container.TC); - else - for J in 1 .. Count loop - X := Container.First; - pragma Assert (X.Next.Prev = Container.First); + for J in 1 .. Count loop + X := Container.First; + pragma Assert (X.Next.Prev = Container.First); - Container.First := X.Next; - Container.First.Prev := null; + Container.First := X.Next; + Container.First.Prev := null; - Container.Length := Container.Length - 1; + Container.Length := Container.Length - 1; - Free (X); - end loop; - end if; + Free (X); + end loop; end Delete_First; ----------------- @@ -472,27 +427,25 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Count >= Container.Length then Clear (Container); return; + end if; - elsif Count = 0 then + if Count = 0 then return; + end if; - elsif Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; + TC_Check (Container.TC); - else - for J in 1 .. Count loop - X := Container.Last; - pragma Assert (X.Prev.Next = Container.Last); + for J in 1 .. Count loop + X := Container.Last; + pragma Assert (X.Prev.Next = Container.Last); - Container.Last := X.Prev; - Container.Last.Next := null; + Container.Last := X.Prev; + Container.Last.Next := null; - Container.Length := Container.Length - 1; + Container.Length := Container.Length - 1; - Free (X); - end loop; - end if; + Free (X); + end loop; end Delete_Last; ------------- @@ -501,19 +454,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Element"); + pragma Assert (Vet (Position), "bad cursor in Element"); - return Position.Node.Element.all; - end if; + return Position.Node.Element.all; end Element; -------------- @@ -523,27 +476,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : List renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.TC); end if; end Finalize; @@ -563,56 +496,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Node := Container.First; else - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; - - else - pragma Assert (Vet (Position), "bad cursor in Find"); end if; + + pragma Assert (Vet (Position), "bad cursor in Find"); end if; -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Node_Access; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := null; while Node /= null loop if Node.Element.all = Item then - Result := Node; - exit; + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Next; end loop; - B := B - 1; - L := L - 1; - - if Result = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Find; @@ -657,11 +568,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function First_Element (Container : List) return Element_Type is begin - if Container.First = null then + if Checks and then Container.First = null then raise Constraint_Error with "list is empty"; - else - return Container.First.Element.all; end if; + + return Container.First.Element.all; end First_Element; ---------- @@ -716,41 +627,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is --------------- function Is_Sorted (Container : List) return Boolean is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Node : Node_Access; - Result : Boolean; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; + Lock : With_Lock (Container.TC'Unrestricted_Access); + Node : Node_Access; + begin Node := Container.First; - Result := True; for J in 2 .. Container.Length loop if Node.Next.Element.all < Node.Element.all then - Result := False; - exit; + return False; end if; Node := Node.Next; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return True; end Is_Sorted; ----------- @@ -772,39 +665,28 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Source.Is_Empty then return; + end if; - elsif Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; + end if; - elsif Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length + then raise Constraint_Error with "new length exceeds maximum"; - - elsif Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; end if; - declare - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; + TC_Check (Target.TC); + TC_Check (Source.TC); - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; + declare + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); LI, RI, RJ : Node_Access; begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - LI := Target.First; RI := Source.First; while RI /= null loop @@ -830,22 +712,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is LI := LI.Next; end if; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -929,33 +795,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Front => null, Back => null); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; pragma Assert (Container.First.Prev = null); @@ -964,6 +812,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end Generic_Sorting; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -990,17 +848,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Before.Container /= null then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with - "attempt to tamper with cursors (list is busy)"; + "Before cursor designates wrong list"; + end if; - elsif Before.Node = null or else Before.Node.Element = null then + if Checks and then + (Before.Node = null or else Before.Node.Element = null) + then raise Program_Error with "Before cursor has no element"; - - else - pragma Assert (Vet (Before), "bad cursor in Insert"); end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then @@ -1008,14 +869,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - if Container.Length > Count_Type'Last - Count then + if Checks and then Container.Length > Count_Type'Last - Count then raise Constraint_Error with "new length exceeds maximum"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); declare -- The element allocator may need an accessibility check in the case @@ -1134,32 +992,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Node_Access := Container.First; begin - B := B + 1; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Next; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Next; + end loop; end Iterate; function Iterate (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1176,7 +1022,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Container => Container'Unrestricted_Access, Node => null) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1185,8 +1031,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1199,34 +1043,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; + end if; - elsif Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong list"; - - else - pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the - -- First and Last selector functions of the iterator object. When - -- the Node component is non-null (as is the case here), it means - -- that this is a partial iteration, over a subset of the complete - -- sequence of items. The iterator object was constructed with - -- a start expression, indicating the position from which the - -- iteration begins. Note that the start position has the same value - -- irrespective of whether this is a forward or reverse iteration. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - B := B + 1; - end return; end if; + + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the + -- First and Last selector functions of the iterator object. When + -- the Node component is non-null (as is the case here), it means + -- that this is a partial iteration, over a subset of the complete + -- sequence of items. The iterator object was constructed with + -- a start expression, indicating the position from which the + -- iteration begins. Note that the start position has the same value + -- irrespective of whether this is a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; end Iterate; ---------- @@ -1270,11 +1114,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Last_Element (Container : List) return Element_Type is begin - if Container.Last = null then + if Checks and then Container.Last = null then raise Constraint_Error with "list is empty"; - else - return Container.Last.Element.all; end if; + + return Container.Last.Element.all; end Last_Element; ------------ @@ -1294,23 +1138,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Target'Address = Source'Address then return; + end if; - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + TC_Check (Source.TC); - else - Clear (Target); + Clear (Target); - Target.First := Source.First; - Source.First := null; + Target.First := Source.First; + Source.First := null; - Target.Last := Source.Last; - Source.Last := null; + Target.Last := Source.Last; + Source.Last := null; - Target.Length := Source.Length; - Source.Length := 0; - end if; + Target.Length := Source.Length; + Source.Length := 0; end Move; ---------- @@ -1346,12 +1187,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong list"; - else - return Next (Position); end if; + + return Next (Position); end Next; ------------- @@ -1400,14 +1243,30 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong list"; - else - return Previous (Position); end if; + + return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1417,39 +1276,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element.all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + pragma Assert (Vet (Position), "bad cursor in Query_Element"); - L := L - 1; - B := B - 1; - end; - end if; + declare + Lock : With_Lock (Position.Container.TC'Unrestricted_Access); + begin + Process (Position.Node.Element.all); + end; end Query_Element; ---------- @@ -1538,33 +1381,33 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; + end if; - elsif Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in function Reference"); + pragma Assert (Vet (Position), "bad cursor in function Reference"); - declare - C : List renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; - end if; + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Reference; --------------------- @@ -1577,38 +1420,37 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is New_Item : Element_Type) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; + end if; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; + TE_Check (Container.TC); - elsif Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; + end if; - else - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - declare - -- The element allocator may need an accessibility check in the - -- case the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). - pragma Unsuppress (Accessibility_Check); + pragma Unsuppress (Accessibility_Check); - X : Element_Access := Position.Node.Element; + X : Element_Access := Position.Node.Element; - begin - Position.Node.Element := new Element_Type'(New_Item); - Free (X); - end; - end if; + begin + Position.Node.Element := new Element_Type'(New_Item); + Free (X); + end; end Replace_Element; ---------------------- @@ -1669,10 +1511,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); Container.First := J; Container.Last := I; @@ -1714,56 +1553,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Node := Container.Last; else - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; - - else - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; + + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Node_Access; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := null; while Node /= null loop if Node.Element.all = Item then - Result := Node; - exit; + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Prev; end loop; - B := B - 1; - L := L - 1; - - if Result = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Reverse_Find; @@ -1775,26 +1592,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); Node : Node_Access := Container.Last; begin - B := B + 1; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Prev; - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Prev; + end loop; end Reverse_Iterate; ------------ @@ -1808,36 +1613,33 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is is begin if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; + end if; - elsif Before.Node = null or else Before.Node.Element = null then + if Checks and then + (Before.Node = null or else Before.Node.Element = null) + then raise Program_Error with "Before cursor has no element"; - - else - pragma Assert (Vet (Before), "bad cursor in Splice"); end if; + + pragma Assert (Vet (Before), "bad cursor in Splice"); end if; if Target'Address = Source'Address or else Source.Length = 0 then return; + end if; - elsif Target.Length > Count_Type'Last - Source.Length then + if Checks and then Target.Length > Count_Type'Last - Source.Length then raise Constraint_Error with "new length exceeds maximum"; + end if; - elsif Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; + TC_Check (Target.TC); + TC_Check (Source.TC); - elsif Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - - else - Splice_Internal (Target, Before.Node, Source); - end if; + Splice_Internal (Target, Before.Node, Source); end Splice; procedure Splice @@ -1847,28 +1649,31 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is is begin if Before.Container /= null then - if Before.Container /= Container'Unchecked_Access then + if Checks and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor designates wrong container"; + end if; - elsif Before.Node = null or else Before.Node.Element = null then + if Checks and then + (Before.Node = null or else Before.Node.Element = null) + then raise Program_Error with "Before cursor has no element"; - - else - pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -1883,10 +1688,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Container.Length >= 2); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); if Before.Node = null then pragma Assert (Position.Node /= Container.Last); @@ -1964,13 +1766,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; if Before.Container /= null then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; end if; - if Before.Node = null - or else Before.Node.Element = null + if Checks and then + (Before.Node = null or else Before.Node.Element = null) then raise Program_Error with "Before cursor has no element"; @@ -1979,35 +1781,28 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; - if Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad Position cursor in Splice"); - if Target.Length = Count_Type'Last then + if Checks and then Target.Length = Count_Type'Last then raise Constraint_Error with "Target is full"; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); Splice_Internal (Target, Before.Node, Source, Position.Node); Position.Container := Target'Unchecked_Access; @@ -2165,19 +1960,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null then + if Checks and then I.Node = null then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = null then + if Checks and then J.Node = null then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unchecked_Access then + if Checks and then I.Container /= Container'Unchecked_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unchecked_Access then + if Checks and then J.Container /= Container'Unchecked_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2185,10 +1980,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (list is locked)"; - end if; + TE_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap"); pragma Assert (Vet (J), "bad J cursor in Swap"); @@ -2211,19 +2003,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null then + if Checks and then I.Node = null then raise Constraint_Error with "I cursor has no element"; end if; - if J.Node = null then + if Checks and then J.Node = null then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor designates wrong container"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor designates wrong container"; end if; @@ -2231,10 +2023,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is busy)"; - end if; + TC_Check (Container.TC); pragma Assert (Vet (I), "bad I cursor in Swap_Links"); pragma Assert (Vet (J), "bad J cursor in Swap_Links"); @@ -2278,16 +2067,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unchecked_Access then + if Checks and then Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -2295,24 +2084,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Update_Element"); declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element.all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element.all); end; end Update_Element; diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index 932fecbf326..44dc32d98ca 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -43,6 +44,7 @@ generic return Boolean is <>; package Ada.Containers.Indefinite_Doubly_Linked_Lists is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -240,10 +242,14 @@ private pragma Inline (Next); pragma Inline (Previous); + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + type Node_Type; type Node_Access is access Node_Type; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Node_Type is limited record @@ -257,11 +263,10 @@ private type List is new Controlled with record - First : Node_Access; - Last : Node_Access; + First : Node_Access := null; + Last : Node_Access := null; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; end record; overriding procedure Adjust (Container : in out List); @@ -301,16 +306,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is - new Controlled with record - Container : List_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -356,7 +353,23 @@ private for Reference_Type'Read use Read; - Empty_List : constant List := List'(Controlled with null, null, 0, 0, 0); + -- 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. + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_List : constant List := List'(Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -365,7 +378,8 @@ private record Container : List_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 98798a247a7..f81bfc8a7d7 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,13 +33,17 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Unchecked_Deallocation; with System; use type System.Address; package body Ada.Containers.Indefinite_Hashed_Maps is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers procedure Free_Key is new Ada.Unchecked_Deallocation (Key_Type, Key_Access); @@ -124,21 +128,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is HT_Ops.Adjust (Container.HT); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - M : Map renames Control.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -201,17 +190,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; @@ -223,15 +213,14 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare M : Map renames Position.Container.all; HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -244,24 +233,23 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "key has no element"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -292,7 +280,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -330,7 +318,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is begin Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete key not in map"; end if; @@ -339,20 +327,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; - if Container.HT.Busy > 0 then - raise Program_Error with - "Delete attempted to tamper with cursors (map is busy)"; - end if; + TC_Check (Container.HT.TC); pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -371,7 +357,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "no element available because key not in map"; end if; @@ -381,12 +367,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor of function Element is bad"; end if; @@ -414,22 +400,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Equivalent_Keys (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor of Equivalent_Keys is bad"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor of Equivalent_Keys is bad"; end if; @@ -445,12 +431,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor of Equivalent_Keys is bad"; end if; @@ -465,12 +451,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor of Equivalent_Keys is bad"; end if; @@ -503,28 +489,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.HT.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - M : Map renames Control.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.HT.TC); end if; end Finalize; @@ -631,6 +596,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Deallocate (X); end Free; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -669,10 +644,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.HT.Lock > 0 then - raise Program_Error with - "Include attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.HT.TC); K := Position.Node.Key; E := Position.Node.Element; @@ -774,7 +746,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert key already in map"; end if; @@ -812,33 +784,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); - -- Start of processing Iterate + -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (Container.HT); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container.HT); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; begin return It : constant Iterator := (Limited_Controlled with Container => Container'Unrestricted_Access) do - B := B + 1; + Busy (Container.HT.TC'Unrestricted_Access.all); end return; end Iterate; @@ -848,12 +809,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; - if Position.Node.Key = null then + if Checks and then Position.Node.Key = null then raise Program_Error with "Position cursor of function Key is bad"; end if; @@ -904,8 +865,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return No_Element; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Next is bad"; end if; @@ -930,7 +891,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -938,6 +899,21 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return Next (Position); end Next; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -948,13 +924,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Query_Element is bad"; @@ -965,31 +941,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare M : Map renames Position.Container.all; HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - - begin - Process (K, E); - - exception - when others => - L := L - 1; - B := B - 1; - - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Query_Element; @@ -1070,17 +1026,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; end if; @@ -1092,15 +1049,14 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare M : Map renames Position.Container.all; HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1113,24 +1069,23 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "key has no element"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1150,15 +1105,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is E : Element_Access; begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in map"; end if; - if Container.HT.Lock > 0 then - raise Program_Error with - "Replace attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.HT.TC); K := Node.Key; E := Node.Element; @@ -1195,27 +1147,25 @@ package body Ada.Containers.Indefinite_Hashed_Maps is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Replace_Element is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Position.Container.HT.Lock > 0 then - raise Program_Error with - "Replace_Element attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Position.Container.HT.TC); pragma Assert (Vet (Position), "bad cursor in Replace_Element"); @@ -1266,19 +1216,20 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Update_Element is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1287,30 +1238,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare HT : Hash_Table_Type renames Container.HT; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - - begin - Process (K, E); - - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Update_Element; diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index a224b3c5454..5ad65886c14 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -46,6 +46,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Hashed_Maps is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -312,7 +313,7 @@ private type Node_Access is access Node_Type; type Key_Access is access Key_Type; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Node_Type is limited record Key : Key_Access; @@ -331,7 +332,7 @@ private overriding procedure Finalize (Container : in out Map); - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -367,16 +368,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Map_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -422,7 +415,23 @@ private for Reference_Type'Read use Read; - Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0)); + -- 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. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Map : constant Map := (Controlled with others => <>); No_Element : constant Cursor := (Container => null, Node => null); @@ -430,7 +439,8 @@ private Map_Iterator_Interfaces.Forward_Iterator with record Container : Map_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 4cc0f461b40..ea7ee2211b4 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,13 +35,17 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Prime_Numbers; with System; use type System.Address; package body Ada.Containers.Indefinite_Hashed_Sets is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------- -- Local Subprograms -- @@ -155,20 +159,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is HT_Ops.Adjust (Container.HT); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -224,16 +214,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -241,15 +232,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare HT : Hash_Table_Type renames Position.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -280,7 +270,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -318,7 +308,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete element not in set"; end if; @@ -330,22 +320,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if Container.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Container.HT.TC); pragma Assert (Vet (Position), "Position cursor is bad"); @@ -376,10 +364,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); if Src_HT.Length < Target.HT.Length then declare @@ -495,7 +480,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise; end Iterate_Left; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Difference; ------------- @@ -504,11 +489,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of equals No_Element"; end if; - if Position.Node.Element = null then -- handle dangling reference + if Checks and then Position.Node.Element = null then + -- handle dangling reference raise Program_Error with "Position cursor is bad"; end if; @@ -532,22 +518,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Equivalent_Elements (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor of Equivalent_Elements is bad"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor of Equivalent_Elements is bad"; end if; @@ -579,12 +565,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor of Equivalent_Elements is bad"; end if; @@ -599,12 +585,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor of Equivalent_Elements is bad"; end if; @@ -652,27 +638,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.HT.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.HT.TC); end if; end Finalize; @@ -789,6 +755,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Deallocate (X); end Free; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -825,10 +801,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.HT.TC); X := Position.Node.Element; @@ -874,7 +847,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -950,10 +923,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); Tgt_Node := HT_Ops.First (Target.HT); while Tgt_Node /= null loop @@ -1048,7 +1018,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise; end Iterate_Left; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Intersection; -------------- @@ -1128,34 +1098,23 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Iterate (Container.HT); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Iterate (Container.HT); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; begin return It : constant Iterator := Iterator'(Limited_Controlled with Container => Container'Unrestricted_Access) do - B := B + 1; + Busy (Container.HT.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1192,7 +1151,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return No_Element; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "bad cursor in Next"; end if; @@ -1221,7 +1180,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1259,6 +1218,21 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return False; end Overlap; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1268,12 +1242,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "bad cursor in Query_Element"; end if; @@ -1282,25 +1256,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare HT : Hash_Table_Type renames Position.Container'Unrestricted_Access.all.HT; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element.all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element.all); end; end Query_Element; @@ -1363,15 +1321,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is pragma Warnings (Off, X); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.HT.TC); X := Node.Element; @@ -1399,15 +1354,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "bad cursor in Replace_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1448,26 +1404,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is is Tgt_HT : Hash_Table_Type renames Target.HT; Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - TB : Natural renames Tgt_HT.Busy; - TL : Natural renames Tgt_HT.Lock; - - SB : Natural renames Src_HT.Busy; - SL : Natural renames Src_HT.Lock; - begin if Target'Address = Source'Address then Clear (Target); return; end if; - if TB > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Tgt_HT.TC); declare N : constant Count_Type := Target.Length + Source.Length; @@ -1507,32 +1450,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is N := N + 1; end Process; - -- Start of processing for Iterate_Source_When_Empty_Target + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. - begin - TB := TB + 1; - TL := TL + 1; + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - SB := SB + 1; - SL := SL + 1; + -- Start of processing for Iterate_Source_When_Empty_Target + begin Iterate (Src_HT); - - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - exception - when others => - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - raise; end Iterate_Source_When_Empty_Target; else @@ -1608,32 +1535,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end if; end Process; - -- Start of processing for Iterate_Source + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. - begin - TB := TB + 1; - TL := TL + 1; + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - SB := SB + 1; - SL := SL + 1; + -- Start of processing for Iterate_Source + begin Iterate (Src_HT); - - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - exception - when others => - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - raise; end Iterate_Source; end if; end Symmetric_Difference; @@ -1767,7 +1678,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise; end Iterate_Right; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Symmetric_Difference; ------------ @@ -1841,10 +1752,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); declare N : constant Count_Type := Target.Length + Source.Length; @@ -1911,25 +1819,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -- Checked_Index instead of a simple invocation of generic formal -- Hash. - B : Integer renames Left_HT.Busy; - L : Integer renames Left_HT.Lock; + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); -- Start of processing for Iterate_Left begin - B := B + 1; - L := L + 1; - - Iterate (Left.HT); - - L := L - 1; - B := B - 1; - + Iterate (Left_HT); exception when others => - L := L - 1; - B := B - 1; - HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Left; @@ -1978,42 +1875,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -- Checked_Index instead of a simple invocation of generic formal -- Hash. - LB : Integer renames Left_HT.Busy; - LL : Integer renames Left_HT.Lock; - - RB : Integer renames Right_HT.Busy; - RL : Integer renames Right_HT.Lock; + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access); -- Start of processing for Iterate_Right begin - LB := LB + 1; - LL := LL + 1; - - RB := RB + 1; - RL := RL + 1; - Iterate (Right.HT); - - RL := RL - 1; - RB := RB - 1; - - LL := LL - 1; - LB := LB - 1; - exception when others => - RL := RL - 1; - RB := RB - 1; - - LL := LL - 1; - LB := LB - 1; - HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Right; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Union; --------- @@ -2141,24 +2016,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Hash => Hash, Equivalent_Keys => Equivalent_Key_Node); - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------------------ -- Constant_Reference -- ------------------------ @@ -2171,24 +2028,23 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "Key not in set"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -2218,7 +2074,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "key not in set"; end if; @@ -2237,7 +2093,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; end if; @@ -2276,16 +2132,10 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Finalize (Control : in out Reference_Control_Type) is begin if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; + Impl.Reference_Control_Type (Control).Finalize; - if Hash (Key (Control.Old_Pos)) /= Control.Old_Hash then + if Checks and then Hash (Key (Control.Old_Pos)) /= Control.Old_Hash + then HT_Ops.Delete_Node_At_Index (Control.Container.HT, Control.Index, Control.Old_Pos.Node); raise Program_Error; @@ -2316,12 +2166,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -2351,16 +2201,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -2370,20 +2221,18 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare HT : Hash_Table_Type renames Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; begin return R : constant Reference_Type := (Element => Position.Node.Element.all'Access, Control => (Controlled with + HT.TC'Unrestricted_Access, Container => Container'Access, Index => HT_Ops.Index (HT, Position.Node), Old_Pos => Position, Old_Hash => Hash (Key (Position)))) - do - B := B + 1; - L := L + 1; + do + Lock (HT.TC); end return; end; end Reference_Preserving_Key; @@ -2395,31 +2244,29 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "Key not in set"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare HT : Hash_Table_Type renames Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; P : constant Cursor := Find (Container, Key); begin return R : constant Reference_Type := (Element => Node.Element.all'Access, Control => (Controlled with + HT.TC'Unrestricted_Access, Container => Container'Access, Index => HT_Ops.Index (HT, P.Node), Old_Pos => P, Old_Hash => Hash (Key))) do - B := B + 1; - L := L + 1; + Lock (HT.TC); end return; end; end Reference_Preserving_Key; @@ -2436,7 +2283,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -2458,25 +2305,28 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Indx : Hash_Type; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null - or else Position.Node.Next = Position.Node + if Checks and then + (Position.Node.Element = null + or else Position.Node.Next = Position.Node) then raise Program_Error with "Position cursor is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if HT.Buckets = null - or else HT.Buckets'Length = 0 - or else HT.Length = 0 + if Checks and then + (HT.Buckets = null + or else HT.Buckets'Length = 0 + or else HT.Length = 0) then raise Program_Error with "Position cursor is bad (set is empty)"; end if; @@ -2491,33 +2341,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare E : Element_Type renames Position.Node.Element.all; K : constant Key_Type := Key (E); - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - - Eq : Boolean; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Indx := HT_Ops.Index (HT, Position.Node); - Process (E); - Eq := Equivalent_Keys (K, Key (E)); - - exception - when others => - L := L - 1; - B := B - 1; - - raise; - end; - - L := L - 1; - B := B - 1; + Indx := HT_Ops.Index (HT, Position.Node); + Process (E); - if Eq then + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -2533,7 +2362,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is while Prev.Next /= Position.Node loop Prev := Prev.Next; - if Prev = null then + if Checks and then Prev = null then raise Program_Error with "Position cursor is bad (node not found)"; end if; diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads index f9ae2ac6220..2eae9d22d2f 100644 --- a/gcc/ada/a-cihase.ads +++ b/gcc/ada/a-cihase.ads @@ -34,6 +34,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; +with Ada.Containers.Helpers; private with Ada.Streams; private with Ada.Finalization; @@ -48,6 +49,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Hashed_Sets is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -433,8 +435,10 @@ package Ada.Containers.Indefinite_Hashed_Sets is type Set_Access is access all Set; for Set_Access'Storage_Size use 0; + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Index : Hash_Type; @@ -442,9 +446,6 @@ package Ada.Containers.Indefinite_Hashed_Sets is Old_Hash : Hash_Type; end record; - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - overriding procedure Finalize (Control : in out Reference_Control_Type); pragma Inline (Finalize); @@ -477,7 +478,7 @@ private type Node_Type; type Node_Access is access Node_Type; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Node_Type is limited record Element : Element_Access; @@ -495,7 +496,7 @@ private overriding procedure Finalize (Container : in out Set); - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -531,16 +532,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Set_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -564,7 +557,23 @@ private for Constant_Reference_Type'Write use Write; - Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0)); + -- 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. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Set : constant Set := (Controlled with others => <>); No_Element : constant Cursor := (Container => null, Node => null); @@ -572,7 +581,8 @@ private Set_Iterator_Interfaces.Forward_Iterator with record Container : Set_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index e0b4b968257..756b512c990 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,7 +33,9 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Multiway_Trees is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers -------------------- -- Root_Iterator -- @@ -164,10 +166,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is function "=" (Left, Right : Tree) return Boolean is begin - if Left'Address = Right'Address then - return True; - end if; - return Equal_Children (Root_Node (Left), Root_Node (Right)); end "="; @@ -186,8 +184,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- are preserved in the event that the allocation fails. Container.Root.Children := Children_Type'(others => null); - Container.Busy := 0; - Container.Lock := 0; + Zero_Counts (Container.TC); Container.Count := 0; -- Copy_Children returns a count of the number of nodes that it @@ -206,20 +203,6 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Container.Count := Source_Count; end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Tree renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------------- -- Ancestor_Find -- ------------------- @@ -231,13 +214,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is R, N : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Commented-out pending ARG ruling. ??? - -- if Position.Container /= Container'Unrestricted_Access then + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then -- raise Program_Error with "Position cursor not in container"; -- end if; @@ -245,7 +230,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- not seem correct, as this value is just the limiting condition of the -- search. For now we omit this check pending a ruling from the ARG.??? - -- if Is_Root (Position) then + -- if Checks and then Is_Root (Position) then -- raise Program_Error with "Position cursor designates root"; -- end if; @@ -276,11 +261,11 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Element : Element_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -288,10 +273,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); declare -- The element allocator may need an accessibility check in the case @@ -406,15 +388,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is N : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Child = No_Element then + if Checks and then Child = No_Element then raise Constraint_Error with "Child cursor has no element"; end if; - if Parent.Container /= Child.Container then + if Checks and then Parent.Container /= Child.Container then raise Program_Error with "Parent and Child in different containers"; end if; @@ -424,7 +406,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Result := Result + 1; N := N.Parent; - if N = null then + if Checks and then N = null then raise Program_Error with "Parent is not ancestor of Child"; end if; end loop; @@ -441,10 +423,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Children_Count : Count_Type; begin - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); -- We first set the container count to 0, in order to preserve -- invariants in case the deallocation fails. (This works because @@ -478,21 +457,22 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -501,16 +481,14 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- "Position cursor in Constant_Reference is bad"); declare - C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -615,20 +593,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Target_Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; @@ -637,7 +615,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Is_Root (Source) then + if Checks and then Is_Root (Source) then raise Constraint_Error with "Source cursor designates root"; end if; @@ -760,18 +738,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); -- Deallocate_Children returns a count of the number of nodes -- that it deallocates, but it works by incrementing the @@ -797,26 +772,24 @@ package body Ada.Containers.Indefinite_Multiway_Trees is X : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if not Is_Leaf (Position) then + if Checks and then not Is_Leaf (Position) then raise Constraint_Error with "Position cursor does not designate leaf"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -846,22 +819,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Count : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -924,11 +895,12 @@ package body Ada.Containers.Indefinite_Multiway_Trees is function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node = Root_Node (Position.Container.all) then + if Checks and then Position.Node = Root_Node (Position.Container.all) + then raise Program_Error with "Position cursor designates root"; end if; @@ -976,11 +948,11 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Right_Position : Cursor) return Boolean is begin - if Left_Position = No_Element then + if Checks and then Left_Position = No_Element then raise Constraint_Error with "Left cursor has no element"; end if; - if Right_Position = No_Element then + if Checks and then Right_Position = No_Element then raise Constraint_Error with "Right cursor has no element"; end if; @@ -1020,25 +992,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -------------- procedure Finalize (Object : in out Root_Iterator) is - B : Natural renames Object.Container.Busy; - begin - B := B - 1; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is begin - if Control.Container /= null then - declare - C : Tree renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; - end if; + Unbusy (Object.Container.TC); end Finalize; ---------- @@ -1086,7 +1041,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Node : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1144,13 +1099,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Result : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Commented-out pending ruling from ARG. ??? - -- if Position.Container /= Container'Unrestricted_Access then + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then -- raise Program_Error with "Position cursor not in container"; -- end if; @@ -1180,6 +1137,16 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return Find_In_Children (Subtree, Item); end Find_In_Subtree; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1224,20 +1191,21 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Element : Element_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Parent cursor not parent of Before"; end if; end if; @@ -1247,10 +1215,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); declare -- The element allocator may need an accessibility check in the case @@ -1437,22 +1402,12 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - Iterate_Children (Container => Container'Unrestricted_Access, Subtree => Root_Node (Container), Process => Process); - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end Iterate; function Iterate (Container : Tree) @@ -1470,31 +1425,18 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Parent : Cursor; Process : not null access procedure (Position : Cursor)) is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - declare - B : Natural renames Parent.Container.Busy; - C : Tree_Node_Access; - - begin - B := B + 1; - - C := Parent.Node.Children.First; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Next; - end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + C := Parent.Node.Children.First; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Next; + end loop; end Iterate_Children; procedure Iterate_Children @@ -1524,14 +1466,12 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return Tree_Iterator_Interfaces.Reversible_Iterator'Class is C : constant Tree_Access := Container'Unrestricted_Access; - B : Natural renames C.Busy; - begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= C then + if Checks and then Parent.Container /= C then raise Program_Error with "Parent cursor not in container"; end if; @@ -1540,7 +1480,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Container => C, Subtree => Parent.Node) do - B := B + 1; + Busy (C.TC); end return; end Iterate_Children; @@ -1552,55 +1492,39 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + C : constant Tree_Access := Position.Container; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Implement Vet for multiway trees??? -- pragma Assert (Vet (Position), "bad subtree cursor"); - declare - B : Natural renames Position.Container.Busy; - begin - return It : constant Subtree_Iterator := - (Limited_Controlled with - Container => Position.Container, - Subtree => Position.Node) - do - B := B + 1; - end return; - end; + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => Position.Container, + Subtree => Position.Node) + do + Busy (C.TC); + end return; end Iterate_Subtree; procedure Iterate_Subtree (Position : Cursor; Process : not null access procedure (Position : Cursor)) is + Busy : With_Busy (Position.Container.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - declare - B : Natural renames Position.Container.Busy; - - begin - B := B + 1; - - if Is_Root (Position) then - Iterate_Children (Position.Container, Position.Node, Process); - else - Iterate_Subtree (Position.Container, Position.Node, Process); - end if; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + if Is_Root (Position) then + Iterate_Children (Position.Container, Position.Node, Process); + else + Iterate_Subtree (Position.Container, Position.Node, Process); + end if; end Iterate_Subtree; procedure Iterate_Subtree @@ -1634,7 +1558,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Node : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1668,10 +1592,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors of Source (tree is busy)"; - end if; + TC_Check (Source.TC); Target.Clear; -- checks busy bit @@ -1703,7 +1624,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -1734,7 +1655,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -1814,11 +1735,11 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Element : Element_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -1826,10 +1747,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); declare -- The element allocator may need an accessibility check in the case @@ -1889,7 +1807,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong tree"; end if; @@ -1919,6 +1837,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position := Previous_Sibling (Position); end Previous_Sibling; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1927,35 +1859,18 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - declare - T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - - begin - B := B + 1; - L := L + 1; - - Process (Position.Node.Element.all); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + Process (Position.Node.Element.all); end Query_Element; ---------- @@ -1994,7 +1909,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is begin Count_Type'Read (Stream, Count); - if Count < 0 then + if Checks and then Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2046,7 +1961,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Count_Type'Read (Stream, Total_Count); - if Total_Count < 0 then + if Checks and then Total_Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2058,7 +1973,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Read_Children (Root_Node (Container)); - if Read_Count /= Total_Count then + if Checks and then Read_Count /= Total_Count then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2098,21 +2013,22 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -2121,16 +2037,14 @@ package body Ada.Containers.Indefinite_Multiway_Trees is -- "Position cursor in Constant_Reference is bad"); declare - C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -2182,22 +2096,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is E, X : Element_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); declare -- The element allocator may need an accessibility check in the case @@ -2224,31 +2136,18 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Parent : Cursor; Process : not null access procedure (Position : Cursor)) is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - declare - B : Natural renames Parent.Container.Busy; - C : Tree_Node_Access; - - begin - B := B + 1; - - C := Parent.Node.Children.Last; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Prev; - end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + C := Parent.Node.Children.Last; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Prev; + end loop; end Reverse_Iterate_Children; ---------- @@ -2283,32 +2182,34 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Count : Count_Type; begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Target'Unrestricted_Access then + if Checks and then Target_Parent.Container /= Target'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Before.Node.Parent /= Target_Parent.Node then + if Checks and then Before.Node.Parent /= Target_Parent.Node then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Source'Unrestricted_Access then + if Checks and then Source_Parent.Container /= Source'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in Source container"; end if; @@ -2318,12 +2219,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (From => Target_Parent.Node, + if Checks and then Is_Reachable (From => Target_Parent.Node, To => Source_Parent.Node) then raise Constraint_Error @@ -2338,15 +2236,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- We cache the count of the nodes we have allocated, so that operation -- Node_Count can execute in O(1) time. But that means we must count the @@ -2374,32 +2265,37 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Source_Parent : Cursor) is begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Target_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Target_Parent.Node then + if Checks and then Before.Node.Parent /= Target_Parent.Node then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Source_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in container"; end if; @@ -2408,12 +2304,9 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (From => Target_Parent.Node, + if Checks and then Is_Reachable (From => Target_Parent.Node, To => Source_Parent.Node) then raise Constraint_Error @@ -2470,33 +2363,33 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Subtree_Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor not in Source container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; @@ -2511,12 +2404,11 @@ package body Ada.Containers.Indefinite_Multiway_Trees is end if; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (From => Parent.Node, To => Position.Node) then + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then raise Constraint_Error with "Position is ancestor of Parent"; end if; @@ -2528,15 +2420,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- This is an unfortunate feature of this API: we must count the nodes -- in the subtree that we remove from the source tree, which is an O(n) @@ -2570,33 +2455,35 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position : Cursor) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then -- Should this be PE instead? Need ARG confirmation. ??? @@ -2613,12 +2500,11 @@ package body Ada.Containers.Indefinite_Multiway_Trees is end if; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (From => Parent.Node, To => Position.Node) then + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then raise Constraint_Error with "Position is ancestor of Parent"; end if; @@ -2667,15 +2553,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is I, J : Cursor) is begin - if I = No_Element then + if Checks and then I = No_Element then raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor not in container"; end if; - if Is_Root (I) then + if Checks and then Is_Root (I) then raise Program_Error with "I cursor designates root"; end if; @@ -2683,22 +2569,19 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return; end if; - if J = No_Element then + if Checks and then J = No_Element then raise Constraint_Error with "J cursor has no element"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor not in container"; end if; - if Is_Root (J) then + if Checks and then Is_Root (J) then raise Program_Error with "J cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); declare EI : constant Element_Access := I.Node.Element; @@ -2718,40 +2601,23 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - declare - T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - - begin - B := B + 1; - L := L + 1; - - Process (Position.Node.Element.all); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; - end; + Process (Position.Node.Element.all); end Update_Element; ----------- diff --git a/gcc/ada/a-cimutr.ads b/gcc/ada/a-cimutr.ads index 48d2d5fabd4..7edb0d13ab0 100644 --- a/gcc/ada/a-cimutr.ads +++ b/gcc/ada/a-cimutr.ads @@ -32,6 +32,8 @@ ------------------------------------------------------------------------------ with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -41,6 +43,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Multiway_Trees is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -303,6 +306,10 @@ package Ada.Containers.Indefinite_Multiway_Trees is private + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + type Tree_Node_Type; type Tree_Node_Access is access all Tree_Node_Type; @@ -311,7 +318,7 @@ private Last : Tree_Node_Access; end record; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Tree_Node_Type is record Parent : Tree_Node_Access; @@ -337,8 +344,7 @@ private type Tree is new Controlled with record Root : aliased Tree_Node_Type; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; Count : Count_Type := 0; end record; @@ -380,16 +386,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Tree_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -435,6 +433,22 @@ 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. + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Tree : constant Tree := (Controlled with others => <>); No_Element : constant Cursor := (others => <>); diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index d06d8fedc1d..5d07151271d 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,6 +29,8 @@ with Ada.Unchecked_Deallocation; +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); @@ -38,9 +40,12 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Maps is - pragma Annotate (CodePeer, Skip_Analysis); pragma Suppress (All_Checks); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------------- -- Node Access Subprograms -- ----------------------------- @@ -132,19 +137,19 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor in ""<"" is bad"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor in ""<"" is bad"; end if; @@ -159,11 +164,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function "<" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor in ""<"" is bad"; end if; @@ -175,11 +180,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function "<" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor in ""<"" is bad"; end if; @@ -204,19 +209,19 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor in ""<"" is bad"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor in ""<"" is bad"; end if; @@ -231,11 +236,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function ">" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; - if Left.Node.Key = null then + if Checks and then Left.Node.Key = null then raise Program_Error with "Left cursor in ""<"" is bad"; end if; @@ -247,11 +252,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function ">" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; - if Right.Node.Key = null then + if Checks and then Right.Node.Key = null then raise Program_Error with "Right cursor in ""<"" is bad"; end if; @@ -272,20 +277,6 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Adjust (Container.Tree); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - T : Tree_Type renames Control.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -357,17 +348,18 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -375,16 +367,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is "Position cursor in Constant_Reference is bad"); declare - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -396,25 +386,23 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -473,18 +461,19 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Delete is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; @@ -502,7 +491,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is X : Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "key not in map"; end if; @@ -542,12 +531,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor of function Element is bad"; end if; @@ -562,7 +551,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; @@ -598,27 +587,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Tree.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - T : Tree_Type renames Control.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.Tree.TC); end if; end Finalize; @@ -673,11 +642,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function First_Element (Container : Map) return Element_Type is T : Tree_Type renames Container.Tree; begin - if T.First = null then + if Checks and then T.First = null then raise Constraint_Error with "map is empty"; - else - return T.First.Element.all; end if; + + return T.First.Element.all; end First_Element; --------------- @@ -687,11 +656,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function First_Key (Container : Map) return Key_Type is T : Tree_Type renames Container.Tree; begin - if T.First = null then + if Checks and then T.First = null then raise Constraint_Error with "map is empty"; - else - return T.First.Key.all; end if; + + return T.First.Key.all; end First_Key; ----------- @@ -754,6 +723,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Deallocate (X); end Free; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -782,10 +761,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); K := Position.Node.Key; E := Position.Node.Element; @@ -886,7 +862,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "key already in map"; end if; end Insert; @@ -959,30 +935,17 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (Container.Tree); - - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container.Tree); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -999,7 +962,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Container => Container'Unrestricted_Access, Node => null) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1008,8 +971,6 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1022,12 +983,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong map"; end if; @@ -1049,7 +1010,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1059,12 +1020,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; - if Position.Node.Key = null then + if Checks and then Position.Node.Key = null then raise Program_Error with "Position cursor of function Key is bad"; end if; @@ -1116,7 +1077,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is T : Tree_Type renames Container.Tree; begin - if T.Last = null then + if Checks and then T.Last = null then raise Constraint_Error with "map is empty"; end if; @@ -1131,7 +1092,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is T : Tree_Type renames Container.Tree; begin - if T.Last = null then + if Checks and then T.Last = null then raise Constraint_Error with "map is empty"; end if; @@ -1206,7 +1167,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -1262,7 +1223,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong map"; end if; @@ -1270,6 +1231,21 @@ package body Ada.Containers.Indefinite_Ordered_Maps is return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1280,13 +1256,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Query_Element is bad"; @@ -1297,28 +1273,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Query_Element; @@ -1394,17 +1353,18 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -1412,16 +1372,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is "Position cursor in function Reference is bad"); declare - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1433,25 +1391,23 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1471,14 +1427,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is E : Element_Access; begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); K := Node.Key; E := Node.Element; @@ -1515,27 +1468,25 @@ package body Ada.Containers.Indefinite_Ordered_Maps is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Replace_Element is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); pragma Assert (Vet (Container.Tree, Position.Node), "Position cursor of Replace_Element is bad"); @@ -1578,22 +1529,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (Container.Tree); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (Container.Tree); end Reverse_Iterate; ----------- @@ -1652,19 +1593,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Node.Key = null - or else Position.Node.Element = null + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) then raise Program_Error with "Position cursor of Update_Element is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1674,28 +1616,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Update_Element; diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads index 2882a084bd2..fa657552a1a 100644 --- a/gcc/ada/a-ciorma.ads +++ b/gcc/ada/a-ciorma.ads @@ -45,6 +45,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Ordered_Maps is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -236,7 +237,7 @@ private type Node_Access is access Node_Type; type Key_Access is access Key_Type; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Node_Type is limited record Parent : Node_Access; @@ -260,7 +261,7 @@ private overriding procedure Finalize (Container : in out Map) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -296,16 +297,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Map_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -351,13 +344,23 @@ private for Reference_Type'Write use Write; - Empty_Map : constant Map := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + -- 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. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Map : constant Map := (Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -366,7 +369,8 @@ private record Container : Map_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb index 38dd5ae6a40..4bf00c61cbd 100644 --- a/gcc/ada/a-ciormu.adb +++ b/gcc/ada/a-ciormu.adb @@ -42,7 +42,9 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Multisets is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------------- -- Node Access Subprograms -- @@ -636,10 +638,8 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -------------- procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Tree.Busy; - pragma Assert (B > 0); begin - B := B - 1; + Unbusy (Object.Container.Tree.TC); end Finalize; ----------- @@ -943,22 +943,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T, Key); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T, Key); end Iterate; --------- @@ -1012,22 +1002,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T, Key); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T, Key); end Reverse_Iterate; -------------------- @@ -1061,25 +1041,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is declare E : Element_Type renames Node.Element.all; K : constant Key_Type := Key (E); - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (E); if Equivalent_Keys (Left => K, Right => Key (E)) then return; @@ -1367,22 +1331,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T, Item); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T, Item); end Iterate; procedure Iterate @@ -1405,30 +1359,18 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'Class is S : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames S.Tree.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1441,7 +1383,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -- for a reverse iterator, Container.Last is the beginning. return It : constant Iterator := (Limited_Controlled with S, null) do - B := B + 1; + Busy (S.Tree.TC); end return; end Iterate; @@ -1449,8 +1391,6 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return Set_Iterator_Interfaces.Reversible_Iterator'Class is S : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames S.Tree.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1488,7 +1428,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return It : constant Iterator := (Limited_Controlled with S, Start.Node) do - B := B + 1; + Busy (S.Tree.TC); end return; end Iterate; @@ -1701,25 +1641,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element.all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element.all); end; end Query_Element; @@ -1792,10 +1716,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is then null; else - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); declare X : Element_Access := Node.Element; @@ -1914,22 +1835,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T, Item); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T, Item); end Reverse_Iterate; procedure Reverse_Iterate @@ -1952,22 +1863,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T); end Reverse_Iterate; ----------- diff --git a/gcc/ada/a-ciormu.ads b/gcc/ada/a-ciormu.ads index 7524cf7be3c..4eab5b1dd49 100644 --- a/gcc/ada/a-ciormu.ads +++ b/gcc/ada/a-ciormu.ads @@ -44,6 +44,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Ordered_Multisets is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -472,7 +473,7 @@ private overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -539,20 +540,15 @@ private for Constant_Reference_Type'Write use Write; - Empty_Set : constant Set := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + Empty_Set : constant Set := (Controlled with others => <>); type Iterator is new Limited_Controlled and Set_Iterator_Interfaces.Reversible_Iterator with record Container : Set_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 218ab8a325e..6ebc1432162 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,6 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); @@ -42,7 +44,9 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Sets is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------- -- Local Subprograms -- @@ -147,19 +151,19 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor is bad"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor is bad"; end if; @@ -174,11 +178,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function "<" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor is bad"; end if; @@ -190,11 +194,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function "<" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor is bad"; end if; @@ -237,19 +241,19 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor is bad"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor is bad"; end if; @@ -266,11 +270,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function ">" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Left.Node.Element = null then + if Checks and then Left.Node.Element = null then raise Program_Error with "Left cursor is bad"; end if; @@ -282,11 +286,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function ">" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; - if Right.Node.Element = null then + if Checks and then Right.Node.Element = null then raise Program_Error with "Right cursor is bad"; end if; @@ -307,20 +311,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Adjust (Container.Tree); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -377,16 +367,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -396,15 +387,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare Tree : Tree_Type renames Position.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -455,15 +445,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Delete (Container : in out Set; Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -478,12 +469,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Delete (Container : in out Set; Item : Element_Type) is X : Node_Access := Element_Keys.Find (Container.Tree, Item); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete element not in set"; - else - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); end if; + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); end Delete; ------------------ @@ -535,11 +526,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -615,27 +606,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Tree.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.Tree.TC); end if; end Finalize; @@ -692,11 +663,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function First_Element (Container : Set) return Element_Type is begin - if Container.Tree.First = null then + if Checks and then Container.Tree.First = null then raise Constraint_Error with "set is empty"; - else - return Container.Tree.First.Element.all; end if; + + return Container.Tree.First.Element.all; end First_Element; ----------- @@ -770,24 +741,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------- -- Ceiling -- ------------- @@ -810,25 +763,24 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "Key not in set"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -850,7 +802,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is X : Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete key not in set"; end if; @@ -865,11 +817,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Element (Container : Set; Key : Key_Type) return Element_Type is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; - else - return Node.Element.all; end if; + + return Node.Element.all; end Element; --------------------- @@ -905,16 +857,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Finalize (Control : in out Reference_Control_Type) is begin if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B - 1; - L := L - 1; - end; + Impl.Reference_Control_Type (Control).Finalize; - if not (Key (Control.Pos) = Control.Old_Key.all) then + if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) + then Delete (Control.Container.all, Key (Control.Pos)); raise Program_Error; end if; @@ -976,12 +922,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -1004,7 +950,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -1033,16 +979,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Node has no element"; end if; @@ -1052,19 +999,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare Tree : Tree_Type renames Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; begin return R : constant Reference_Type := (Element => Position.Node.Element.all'Unchecked_Access, Control => (Controlled with + Tree.TC'Unrestricted_Access, Container => Container'Access, Pos => Position, Old_Key => new Key_Type'(Key (Position)))) do - B := B + 1; - L := L + 1; + Lock (Tree.TC); end return; end; end Reference_Preserving_Key; @@ -1076,29 +1021,27 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "Key not in set"; end if; - if Node.Element = null then + if Checks and then Node.Element = null then raise Program_Error with "Node has no element"; end if; declare Tree : Tree_Type renames Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; begin return R : constant Reference_Type := (Element => Node.Element.all'Unchecked_Access, Control => (Controlled with + Tree.TC'Unrestricted_Access, Container => Container'Access, Pos => Find (Container, Key), Old_Key => new Key_Type'(Key))) do - B := B + 1; - L := L + 1; + Lock (Tree.TC); end return; end; end Reference_Preserving_Key; @@ -1116,15 +1059,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Tree : Tree_Type renames Container.Tree; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1134,30 +1078,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare E : Element_Type renames Position.Node.Element.all; K : constant Key_Type := Key (E); - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - - Eq : Boolean; - + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (E); - Eq := Equivalent_Keys (K, Key (E)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - - if Eq then + Process (E); + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -1186,6 +1110,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end Generic_Keys; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1199,7 +1133,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- Include -- ------------- - procedure Include (Container : in out Set; New_Item : Element_Type) is + procedure Include (Container : in out Set; New_Item : Element_Type) is Position : Cursor; Inserted : Boolean; @@ -1209,10 +1143,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.Tree.TC); declare -- The element allocator may need an accessibility check in the @@ -1258,7 +1189,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -1470,30 +1401,18 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end Process_Node; T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1510,7 +1429,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Container => Container'Unrestricted_Access, Node => null) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1519,8 +1438,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Start : Cursor) return Set_Iterator_Interfaces.Reversible_Iterator'class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1533,12 +1450,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong set"; end if; @@ -1560,7 +1477,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1603,11 +1520,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Last_Element (Container : Set) return Element_Type is begin - if Container.Tree.Last = null then + if Checks and then Container.Tree.Last = null then raise Constraint_Error with "set is empty"; - else - return Container.Tree.Last.Element.all; end if; + + return Container.Tree.Last.Element.all; end Last_Element; ---------- @@ -1654,7 +1571,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -1678,7 +1595,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1719,7 +1636,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -1744,7 +1661,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong set"; end if; @@ -1752,6 +1669,21 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1761,11 +1693,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; @@ -1774,25 +1706,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element.all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element.all); end; end Query_Element; @@ -1864,14 +1780,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is pragma Warnings (Off, X); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.Tree.TC); declare -- The element allocator may need an accessibility check in the case @@ -1941,12 +1854,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is X : Element_Access := Node.Element; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - -- Start of processing for Replace_Element begin @@ -1964,33 +1871,19 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- Determine whether Item is equivalent to element on the specified -- node. + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := (if Item < Node.Element.all then False elsif Node.Element.all < Item then False else True); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then -- Item is equivalent to the node's element, so we will not have to -- move the node. - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); declare -- The element allocator may need an accessibility check in the @@ -2019,26 +1912,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Hint := Element_Keys.Ceiling (Tree, Item); if Hint /= null then + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Item < Hint.Element.all; - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; -- Item >= Hint.Element - if not Compare then + if Checks and then not Compare then -- Ceiling returns an element that is equivalent or greater -- than Item. If Item is "not less than" the element, then @@ -2069,10 +1951,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- because it would only be placed in the exact same position. if Hint = Node then - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); declare -- The element allocator may need an accessibility check in the @@ -2118,15 +1997,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Node.Element = null then + if Checks and then Position.Node.Element = null then raise Program_Error with "Position cursor is bad"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -2160,22 +2040,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T); end Reverse_Iterate; ----------- diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index c885b80478e..2e1c018e188 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +with Ada.Containers.Helpers; private with Ada.Containers.Red_Black_Trees; private with Ada.Finalization; private with Ada.Streams; @@ -44,6 +45,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Ordered_Sets is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -298,17 +300,16 @@ package Ada.Containers.Indefinite_Ordered_Sets is type Key_Access is access all Key_Type; + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Pos : Cursor; Old_Key : Key_Access; end record; - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - overriding procedure Finalize (Control : in out Reference_Control_Type); pragma Inline (Finalize); @@ -338,7 +339,7 @@ private type Node_Type; type Node_Access is access Node_Type; - type Element_Access is access Element_Type; + type Element_Access is access all Element_Type; type Node_Type is limited record Parent : Node_Access; @@ -361,7 +362,7 @@ private overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -397,16 +398,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Set_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -430,13 +423,23 @@ private for Constant_Reference_Type'Write use Write; - Empty_Set : constant Set := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + -- 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. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Set : constant Set := (Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -445,7 +448,8 @@ private record Container : Set_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-clrefi.adb b/gcc/ada/a-clrefi.adb index 4708bf8f34c..5afde3b616c 100644 --- a/gcc/ada/a-clrefi.adb +++ b/gcc/ada/a-clrefi.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -217,7 +217,7 @@ package body Ada.Command_Line.Response_File is end loop; end Get_Line; - -- Start or Recurse + -- Start of processing for Recurse begin Last_Arg := 0; @@ -491,7 +491,7 @@ package body Ada.Command_Line.Response_File is raise; end Recurse; - -- Start of Arguments_From + -- Start of processing for Arguments_From begin -- The job is done by procedure Recurse diff --git a/gcc/ada/a-coboho.adb b/gcc/ada/a-coboho.adb index 4ea0fa047aa..75fc638759f 100644 --- a/gcc/ada/a-coboho.adb +++ b/gcc/ada/a-coboho.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -26,24 +26,32 @@ ------------------------------------------------------------------------------ with Unchecked_Conversion; -with Ada.Assertions; use Ada.Assertions; package body Ada.Containers.Bounded_Holders is - pragma Annotate (CodePeer, Skip_Analysis); - - function Size_In_Storage_Elements (Element : Element_Type) return Natural is - (Element'Size / System.Storage_Unit) - with Pre => - (Element'Size mod System.Storage_Unit = 0 or else - raise Assertion_Error with "Size must be a multiple of Storage_Unit") - and then - (Element'Size / System.Storage_Unit <= Max_Size_In_Storage_Elements - or else raise Assertion_Error with "Size is too big"); + function Size_In_Storage_Elements (Element : Element_Type) return Natural; -- This returns the size of Element in storage units. It raises an -- exception if the size is not a multiple of Storage_Unit, or if the size -- is too big. + ------------------------------ + -- Size_In_Storage_Elements -- + ------------------------------ + + function Size_In_Storage_Elements (Element : Element_Type) return Natural is + Max_Size : Natural renames Max_Size_In_Storage_Elements; + + begin + return S : constant Natural := Element'Size / System.Storage_Unit do + pragma Assert + (Element'Size mod System.Storage_Unit = 0, + "Size must be a multiple of Storage_Unit"); + + pragma Assert + (S <= Max_Size, "Size is too big:" & S'Img & " >" & Max_Size'Img); + end return; + end Size_In_Storage_Elements; + function Cast is new Unchecked_Conversion (System.Address, Element_Access); @@ -65,9 +73,9 @@ package body Ada.Containers.Bounded_Holders is return Cast (Container'Address).all; end Get; - --------------------- - -- Replace_Element -- - --------------------- + --------- + -- Set -- + --------- procedure Set (Container : in out Holder; New_Item : Element_Type) is Storage : Storage_Array diff --git a/gcc/ada/a-coboho.ads b/gcc/ada/a-coboho.ads index 7e6933e22de..67b27f25d6d 100644 --- a/gcc/ada/a-coboho.ads +++ b/gcc/ada/a-coboho.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2015, 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 -- @@ -38,6 +38,8 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Bounded_Holders is + pragma Annotate (CodePeer, Skip_Analysis); + -- This package is patterned after Ada.Containers.Indefinite_Holders. It is -- used to treat indefinite subtypes as definite, but without using heap -- allocation. For example, you might like to say: @@ -51,9 +53,14 @@ package Ada.Containers.Bounded_Holders is -- -- Each object of type Holder is allocated Max_Size_In_Storage_Elements -- bytes. If you try to create a holder from an object of type Element_Type - -- that is too big, an exception is raised. This applies to To_Holder and - -- Replace_Element. If you pass an Element_Type object that is smaller than - -- Max_Size_In_Storage_Elements, it works fine, but some space is wasted. + -- that is too big, an exception is raised (assuming assertions are + -- enabled). This applies to To_Holder and Set. If you pass an Element_Type + -- object that is smaller than Max_Size_In_Storage_Elements, it works fine, + -- but some space is wasted. + -- + -- NOTE: If assertions are disabled, and you try to use an Element that is + -- too big, execution is erroneous, and anything can happen, such as + -- overwriting arbitrary memory locations. -- -- Element_Type must not be an unconstrained array type. It can be a -- class-wide type or a type with non-defaulted discriminants. diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb index 80437de5e0a..59d6c27350a 100644 --- a/gcc/ada/a-cobove.adb +++ b/gcc/ada/a-cobove.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,7 +33,9 @@ with System; use type System.Address; package body Ada.Containers.Bounded_Vectors is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------- -- Local Subprograms -- @@ -89,7 +91,7 @@ package body Ada.Containers.Bounded_Vectors is -- we must check the sum of the combined lengths. Note that we cannot -- simply add the lengths, because of the possibility of overflow. - if LN > Count_Type'Last - RN then + if Checks and then LN > Count_Type'Last - RN then raise Constraint_Error with "new length is out of range"; end if; @@ -115,7 +117,9 @@ package body Ada.Containers.Bounded_Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (N) < No_Index + then raise Constraint_Error with "new length is out of range"; end if; @@ -127,7 +131,7 @@ package body Ada.Containers.Bounded_Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -139,7 +143,7 @@ package body Ada.Containers.Bounded_Vectors is J := Count_Type'Base (No_Index) + N; -- Last - if J > Count_Type'Base (Index_Type'Last) then + if Checks and then J > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "new length is out of range"; end if; @@ -156,7 +160,7 @@ package body Ada.Containers.Bounded_Vectors is J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - if J < Count_Type'Base (No_Index) then + if Checks and then J < Count_Type'Base (No_Index) then raise Constraint_Error with "new length is out of range"; end if; @@ -193,11 +197,11 @@ package body Ada.Containers.Bounded_Vectors is -- constraints: the new length cannot exceed Count_Type'Last, and the -- new Last index cannot exceed Index_Type'Last. - if LN = Count_Type'Last then + if Checks and then LN = Count_Type'Last then raise Constraint_Error with "new length is out of range"; end if; - if Left.Last >= Index_Type'Last then + if Checks and then Left.Last >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -221,11 +225,11 @@ package body Ada.Containers.Bounded_Vectors is -- the new length cannot exceed Count_Type'Last, and the new Last index -- cannot exceed Index_Type'Last. - if RN = Count_Type'Last then + if Checks and then RN = Count_Type'Last then raise Constraint_Error with "new length is out of range"; end if; - if Right.Last >= Index_Type'Last then + if Checks and then Right.Last >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -248,7 +252,7 @@ package body Ada.Containers.Bounded_Vectors is -- know that that condition is satisfied), and the new Last index cannot -- exceed Index_Type'Last. - if Index_Type'First >= Index_Type'Last then + if Checks and then Index_Type'First >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -263,78 +267,33 @@ package body Ada.Containers.Bounded_Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - - Result : Boolean; - begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Last /= Right.Last then return False; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - - Result := True; - for J in Count_Type range 1 .. Left.Length loop - if Left.Elements (J) /= Right.Elements (J) then - Result := False; - exit; - end if; - end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; + if Left.Length = 0 then + return True; + end if; - exception - when others => - BL := BL - 1; - LL := LL - 1; + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - BR := BR - 1; - LR := LR - 1; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + begin + for J in Count_Type range 1 .. Left.Length loop + if Left.Elements (J) /= Right.Elements (J) then + return False; + end if; + end loop; + end; - raise; + return True; end "="; ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - - ------------ -- Assign -- ------------ @@ -344,7 +303,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error -- ??? with "Target capacity is less than Source length"; end if; @@ -367,7 +326,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Container.Last >= Index_Type'Last then + if Checks and then Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -384,7 +343,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Container.Last >= Index_Type'Last then + if Checks and then Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -406,10 +365,7 @@ package body Ada.Containers.Bounded_Vectors is procedure Clear (Container : in out Vector) is begin - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); Container.Last := No_Index; end Clear; @@ -423,30 +379,30 @@ package body Ada.Containers.Bounded_Vectors is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Index > Position.Container.Last then + if Checks and then Position.Index > Position.Container.Last then raise Constraint_Error with "Position cursor is out of range"; end if; declare A : Elements_Array renames Container.Elements; - I : constant Count_Type := To_Array_Index (Position.Index); - B : Natural renames Position.Container.Busy; - L : Natural renames Position.Container.Lock; + J : constant Count_Type := To_Array_Index (Position.Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => A (I)'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => A (J)'Access, + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -456,20 +412,21 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type) return Constant_Reference_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; declare A : Elements_Array renames Container.Elements; - I : constant Count_Type := To_Array_Index (Index); + J : constant Count_Type := To_Array_Index (Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := - (Element => A (I)'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => A (J)'Access, + Control => (Controlled with TC)) do - R.Control.Container.Busy := R.Control.Container.Busy + 1; - R.Control.Container.Lock := R.Control.Container.Lock + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -503,7 +460,7 @@ package body Ada.Containers.Bounded_Vectors is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -549,7 +506,7 @@ package body Ada.Containers.Bounded_Vectors is -- in the base range that immediately precede and immediately follow the -- values in the Index_Type.) - if Index < Index_Type'First then + if Checks and then Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; @@ -561,7 +518,7 @@ package body Ada.Containers.Bounded_Vectors is -- algorithm, so that case is treated as a proper error.) if Index > Old_Last then - if Index > Old_Last + 1 then + if Checks and then Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; end if; @@ -581,10 +538,7 @@ package body Ada.Containers.Bounded_Vectors is -- the count on exit. Delete checks the count to determine whether it is -- being called while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- We first calculate what's available for deletion starting at -- Index. Here and elsewhere we use the wider of Index_Type'Base and @@ -641,15 +595,16 @@ package body Ada.Containers.Bounded_Vectors is pragma Warnings (Off, Position); begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Index > Container.Last then + if Checks and then Position.Index > Container.Last then raise Program_Error with "Position index is out of range"; end if; @@ -703,10 +658,7 @@ package body Ada.Containers.Bounded_Vectors is -- it is being called while the associated callback procedure is -- executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- There is no restriction on how large Count can be when deleting -- items. If it is equal or greater than the current length, then this @@ -739,7 +691,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type) return Element_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; else return Container.Elements (To_Array_Index (Index)); @@ -748,7 +700,7 @@ package body Ada.Containers.Bounded_Vectors is function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; else return Position.Container.Element (Position.Index); @@ -760,25 +712,8 @@ package body Ada.Containers.Bounded_Vectors is -------------- procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Busy; begin - B := B - 1; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; - end if; + Unbusy (Object.Container.TC); end Finalize; ---------- @@ -792,11 +727,12 @@ package body Ada.Containers.Bounded_Vectors is is begin if Position.Container /= null then - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Index > Container.Last then + if Checks and then Position.Index > Container.Last then raise Program_Error with "Position index is out of range"; end if; end if; @@ -805,38 +741,15 @@ package body Ada.Containers.Bounded_Vectors is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for J in Position.Index .. Container.Last loop if Container.Elements (To_Array_Index (J)) = Item then - Result := J; - exit; + return Cursor'(Container'Unrestricted_Access, J); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Find; @@ -849,37 +762,18 @@ package body Ada.Containers.Bounded_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; - - Result := No_Index; + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin for Indx in Index .. Container.Last loop if Container.Elements (To_Array_Index (Indx)) = Item then - Result := Indx; - exit; + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Index; end Find_Index; ----------- @@ -924,11 +818,11 @@ package body Ada.Containers.Bounded_Vectors is function First_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; - else - return Container.Elements (To_Array_Index (Index_Type'First)); end if; + + return Container.Elements (To_Array_Index (Index_Type'First)); end First_Element; ----------------- @@ -961,36 +855,16 @@ package body Ada.Containers.Bounded_Vectors is -- element tampering by a generic actual subprogram. declare + Lock : With_Lock (Container.TC'Unrestricted_Access); EA : Elements_Array renames Container.Elements; - - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Boolean; - begin - B := B + 1; - L := L + 1; - - Result := True; for J in 1 .. Container.Length - 1 loop if EA (J + 1) < EA (J) then - Result := False; - exit; + return False; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return True; end; end Is_Sorted; @@ -1014,7 +888,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; end if; @@ -1024,10 +898,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Source.TC); I := Target.Length; Target.Set_Length (I + Source.Length); @@ -1039,19 +910,9 @@ package body Ada.Containers.Bounded_Vectors is TA : Elements_Array renames Target.Elements; SA : Elements_Array renames Source.Elements; - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; - - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; - + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - J := Target.Length; while not Source.Is_Empty loop pragma Assert (Source.Length <= 1 @@ -1077,22 +938,6 @@ package body Ada.Containers.Bounded_Vectors is J := J - 1; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -1124,38 +969,31 @@ package body Ada.Containers.Bounded_Vectors is -- an artifact of our array-based implementation. Logically Sort -- requires a check for cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Container.Elements (1 .. Container.Length)); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; end Sort; end Generic_Sorting; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Elements + (To_Array_Index (Position.Index))'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1199,7 +1037,7 @@ package body Ada.Containers.Bounded_Vectors is -- in the base range that immediately precede and immediately follow the -- values in the Index_Type.) - if Before < Index_Type'First then + if Checks and then Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; @@ -1211,7 +1049,7 @@ package body Ada.Containers.Bounded_Vectors is -- deeper flaw in the caller's algorithm, so that case is treated as a -- proper error.) - if Before > Container.Last + if Checks and then Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with @@ -1231,7 +1069,7 @@ package body Ada.Containers.Bounded_Vectors is -- count. Note that we cannot simply add these values, because of the -- possibility of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -1340,7 +1178,7 @@ package body Ada.Containers.Bounded_Vectors is -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -1350,12 +1188,9 @@ package body Ada.Containers.Bounded_Vectors is -- exit. Insert checks the count to determine whether it is being called -- while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); - if New_Length > Container.Capacity then + if Checks and then New_Length > Container.Capacity then raise Capacity_Error with "New length is larger than capacity"; end if; @@ -1462,7 +1297,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1475,7 +1310,7 @@ package body Ada.Containers.Bounded_Vectors is if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1498,7 +1333,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1519,7 +1354,7 @@ package body Ada.Containers.Bounded_Vectors is if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1544,7 +1379,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1557,7 +1392,7 @@ package body Ada.Containers.Bounded_Vectors is if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1581,7 +1416,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1602,7 +1437,7 @@ package body Ada.Containers.Bounded_Vectors is if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1672,7 +1507,7 @@ package body Ada.Containers.Bounded_Vectors is -- in the base range that immediately precede and immediately follow the -- values in the Index_Type.) - if Before < Index_Type'First then + if Checks and then Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; @@ -1684,7 +1519,7 @@ package body Ada.Containers.Bounded_Vectors is -- deeper flaw in the caller's algorithm, so that case is treated as a -- proper error.) - if Before > Container.Last + if Checks and then Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with @@ -1704,7 +1539,7 @@ package body Ada.Containers.Bounded_Vectors is -- Note that we cannot simply add these values, because of the -- possibility of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -1813,7 +1648,7 @@ package body Ada.Containers.Bounded_Vectors is -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -1823,15 +1658,12 @@ package body Ada.Containers.Bounded_Vectors is -- exit. Insert checks the count to determine whether it is being called -- while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- An internal array has already been allocated, so we need to check -- whether there is enough unused storage for the new items. - if New_Length > Container.Capacity then + if Checks and then New_Length > Container.Capacity then raise Capacity_Error with "New length is larger than capacity"; end if; @@ -1870,7 +1702,7 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1891,7 +1723,7 @@ package body Ada.Containers.Bounded_Vectors is if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1924,22 +1756,11 @@ package body Ada.Containers.Bounded_Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Iterate; function Iterate @@ -1947,8 +1768,6 @@ package body Ada.Containers.Bounded_Vectors is return Vector_Iterator_Interfaces.Reversible_Iterator'Class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- The value of its Index component influences the behavior of the First -- and Last selector functions of the iterator object. When the Index @@ -1965,7 +1784,7 @@ package body Ada.Containers.Bounded_Vectors is Container => V, Index => No_Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -1975,8 +1794,6 @@ package body Ada.Containers.Bounded_Vectors is return Vector_Iterator_Interfaces.Reversible_Iterator'Class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1989,17 +1806,17 @@ package body Ada.Containers.Bounded_Vectors is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start.Container = null then + if Checks and then Start.Container = null then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= V then + if Checks and then Start.Container /= V then raise Program_Error with "Start cursor of Iterate designates wrong vector"; end if; - if Start.Index > V.Last then + if Checks and then Start.Index > V.Last then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; @@ -2018,7 +1835,7 @@ package body Ada.Containers.Bounded_Vectors is Container => V, Index => Start.Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -2063,11 +1880,11 @@ package body Ada.Containers.Bounded_Vectors is function Last_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; - else - return Container.Elements (Container.Length); end if; + + return Container.Elements (Container.Length); end Last_Element; ---------------- @@ -2126,20 +1943,13 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Target.Capacity < Source.Length then + if Checks and then Target.Capacity < Source.Length then raise Capacity_Error -- ??? with "Target capacity is less than Source length"; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Target is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Source is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- Clear Target now, in case element assignment fails @@ -2171,12 +1981,14 @@ package body Ada.Containers.Bounded_Vectors is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; - else - return Next (Position); end if; + + return Next (Position); end Next; procedure Next (Position : in out Cursor) is @@ -2241,14 +2053,30 @@ package body Ada.Containers.Bounded_Vectors is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + end if; + + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; - else - return Previous (Position); end if; + + return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -2258,29 +2086,14 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type; Process : not null access procedure (Element : Element_Type)) is + Lock : With_Lock (Container.TC'Unrestricted_Access); V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - L : Natural renames V.Lock; - begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - B := B + 1; - L := L + 1; - - begin - Process (V.Elements (To_Array_Index (Index))); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (V.Elements (To_Array_Index (Index))); end Query_Element; procedure Query_Element @@ -2288,11 +2101,11 @@ package body Ada.Containers.Bounded_Vectors is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - else - Query_Element (Position.Container.all, Position.Index, Process); end if; + + Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; ---------- @@ -2353,28 +2166,31 @@ package body Ada.Containers.Bounded_Vectors is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Index > Position.Container.Last then + if Checks and then Position.Index > Position.Container.Last then raise Constraint_Error with "Position cursor is out of range"; end if; declare A : Elements_Array renames Container.Elements; - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; J : constant Count_Type := To_Array_Index (Position.Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin - B := B + 1; - L := L + 1; - return (Element => A (J)'Access, - Control => (Controlled with Container'Unrestricted_Access)); + return R : constant Reference_Type := + (Element => A (J)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; end; end Reference; @@ -2383,20 +2199,22 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type) return Reference_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; declare A : Elements_Array renames Container.Elements; - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; J : constant Count_Type := To_Array_Index (Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin - B := B + 1; - L := L + 1; - return (Element => A (J)'Access, - Control => (Controlled with Container'Unrestricted_Access)); + return R : constant Reference_Type := + (Element => A (J)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; end; end Reference; @@ -2410,14 +2228,13 @@ package body Ada.Containers.Bounded_Vectors is New_Item : Element_Type) is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - else - Container.Elements (To_Array_Index (Index)) := New_Item; end if; + + TE_Check (Container.TC); + + Container.Elements (To_Array_Index (Index)) := New_Item; end Replace_Element; procedure Replace_Element @@ -2426,22 +2243,22 @@ package body Ada.Containers.Bounded_Vectors is New_Item : Element_Type) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + end if; - elsif Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; + end if; - elsif Position.Index > Container.Last then + if Checks and then Position.Index > Container.Last then raise Constraint_Error with "Position cursor is out of range"; + end if; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; + TE_Check (Container.TC); - else - Container.Elements (To_Array_Index (Position.Index)) := New_Item; - end if; + Container.Elements (To_Array_Index (Position.Index)) := New_Item; end Replace_Element; ---------------------- @@ -2453,7 +2270,7 @@ package body Ada.Containers.Bounded_Vectors is Capacity : Count_Type) is begin - if Capacity > Container.Capacity then + if Checks and then Capacity > Container.Capacity then raise Capacity_Error with "Capacity is out of range"; end if; end Reserve_Capacity; @@ -2483,10 +2300,7 @@ package body Ada.Containers.Bounded_Vectors is -- implementation. Logically Reverse_Elements requires a check for -- cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); Idx := 1; Jdx := Container.Length; @@ -2516,7 +2330,7 @@ package body Ada.Containers.Bounded_Vectors is Last : Index_Type'Base; begin - if Position.Container /= null + if Checks and then Position.Container /= null and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; @@ -2531,38 +2345,15 @@ package body Ada.Containers.Bounded_Vectors is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements (To_Array_Index (Indx)) = Item then - Result := Indx; - exit; + return Cursor'(Container'Unrestricted_Access, Indx); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Reverse_Find; @@ -2575,40 +2366,22 @@ package body Ada.Containers.Bounded_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); Last : constant Index_Type'Base := Index_Type'Min (Container.Last, Index); - Result : Index_Type'Base; - begin - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B := B + 1; - L := L + 1; - - Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements (To_Array_Index (Indx)) = Item then - Result := Indx; - exit; + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Index; end Reverse_Find_Index; --------------------- @@ -2619,23 +2392,11 @@ package body Ada.Containers.Bounded_Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Reverse_Iterate; ---------------- @@ -2655,7 +2416,7 @@ package body Ada.Containers.Bounded_Vectors is if Count >= 0 then Container.Delete_Last (Count); - elsif Container.Last >= Index_Type'Last then + elsif Checks and then Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else Container.Insert_Space (Container.Last + 1, -Count); @@ -2670,11 +2431,11 @@ package body Ada.Containers.Bounded_Vectors is E : Elements_Array renames Container.Elements; begin - if I > Container.Last then + if Checks and then I > Container.Last then raise Constraint_Error with "I index is out of range"; end if; - if J > Container.Last then + if Checks and then J > Container.Last then raise Constraint_Error with "J index is out of range"; end if; @@ -2682,10 +2443,7 @@ package body Ada.Containers.Bounded_Vectors is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; + TE_Check (Container.TC); declare EI_Copy : constant Element_Type := E (To_Array_Index (I)); @@ -2697,19 +2455,19 @@ package body Ada.Containers.Bounded_Vectors is procedure Swap (Container : in out Vector; I, J : Cursor) is begin - if I.Container = null then + if Checks and then I.Container = null then raise Constraint_Error with "I cursor has no element"; end if; - if J.Container = null then + if Checks and then J.Container = null then raise Constraint_Error with "J cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor denotes wrong container"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor denotes wrong container"; end if; @@ -2814,7 +2572,9 @@ package body Ada.Containers.Bounded_Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -2826,7 +2586,7 @@ package body Ada.Containers.Bounded_Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -2838,7 +2598,7 @@ package body Ada.Containers.Bounded_Vectors is Index := Count_Type'Base (No_Index) + Length; -- Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -2855,7 +2615,7 @@ package body Ada.Containers.Bounded_Vectors is Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -2903,7 +2663,9 @@ package body Ada.Containers.Bounded_Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -2915,7 +2677,7 @@ package body Ada.Containers.Bounded_Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -2927,7 +2689,7 @@ package body Ada.Containers.Bounded_Vectors is Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -2944,7 +2706,7 @@ package body Ada.Containers.Bounded_Vectors is Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -2970,28 +2732,13 @@ package body Ada.Containers.Bounded_Vectors is Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)) is - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - B := B + 1; - L := L + 1; - - begin - Process (Container.Elements (To_Array_Index (Index))); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Container.Elements (To_Array_Index (Index))); end Update_Element; procedure Update_Element @@ -3000,11 +2747,12 @@ package body Ada.Containers.Bounded_Vectors is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor denotes wrong container"; end if; diff --git a/gcc/ada/a-cobove.ads b/gcc/ada/a-cobove.ads index 3bd1843d7b3..c3157029344 100644 --- a/gcc/ada/a-cobove.ads +++ b/gcc/ada/a-cobove.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +with Ada.Containers.Helpers; private with Ada.Streams; private with Ada.Finalization; @@ -43,6 +44,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Bounded_Vectors is + pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; pragma Remote_Types; @@ -364,6 +366,10 @@ private pragma Inline (Next); pragma Inline (Previous); + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + use Ada.Streams; use Ada.Finalization; @@ -373,8 +379,7 @@ private type Vector (Capacity : Count_Type) is tagged record Elements : Elements_Array (1 .. Capacity) := (others => <>); Last : Extended_Index := No_Index; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; end record; procedure Write @@ -409,15 +414,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is new Controlled with record - Container : Vector_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -461,6 +459,25 @@ 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. + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Vector : constant Vector := (Capacity => 0, others => <>); No_Element : constant Cursor := Cursor'(null, Index_Type'First); @@ -470,7 +487,8 @@ private record Container : Vector_Access; Index : Index_Type'Base; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index ef37cc0226e..ac8208593b6 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,7 +33,6 @@ with System; use type System.Address; package body Ada.Containers.Formal_Vectors with SPARK_Mode => Off is - pragma Annotate (CodePeer, Skip_Analysis); Growth_Factor : constant := 2; -- When growing a container, multiply current capacity by this. Doubling @@ -355,7 +354,7 @@ is -- Generic_Sorting -- --------------------- - package body Generic_Sorting is + package body Generic_Sorting with SPARK_Mode => Off is --------------- -- Is_Sorted -- diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index 284f034e1ad..e8a3c946318 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -50,6 +50,7 @@ package Ada.Containers.Formal_Vectors with SPARK_Mode is pragma Annotate (GNATprove, External_Axiomatization); + pragma Annotate (CodePeer, Skip_Analysis); subtype Extended_Index is Index_Type'Base range Index_Type'First - 1 .. @@ -203,7 +204,7 @@ is generic with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is + package Generic_Sorting with SPARK_Mode is function Is_Sorted (Container : Vector) return Boolean with Global => null; diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 6fe9bfd576b..20a48b6d6c2 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -35,11 +35,15 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with System; use type System.Address; package body Ada.Containers.Hashed_Maps is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------- -- Local Subprograms -- @@ -123,20 +127,6 @@ package body Ada.Containers.Hashed_Maps is HT_Ops.Adjust (Container.HT); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -199,12 +189,13 @@ package body Ada.Containers.Hashed_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -215,15 +206,14 @@ package body Ada.Containers.Hashed_Maps is declare HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -236,20 +226,19 @@ package body Ada.Containers.Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -280,7 +269,7 @@ package body Ada.Containers.Hashed_Maps is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -316,7 +305,7 @@ package body Ada.Containers.Hashed_Maps is begin Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete key not in map"; end if; @@ -325,20 +314,18 @@ package body Ada.Containers.Hashed_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; - if Container.HT.Busy > 0 then - raise Program_Error with - "Delete attempted to tamper with cursors (map is busy)"; - end if; + TC_Check (Container.HT.TC); pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -357,7 +344,7 @@ package body Ada.Containers.Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "no element available because key not in map"; end if; @@ -367,7 +354,7 @@ package body Ada.Containers.Hashed_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; @@ -395,12 +382,12 @@ package body Ada.Containers.Hashed_Maps is function Equivalent_Keys (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; @@ -413,7 +400,7 @@ package body Ada.Containers.Hashed_Maps is function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Keys equals No_Element"; end if; @@ -425,7 +412,7 @@ package body Ada.Containers.Hashed_Maps is function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Keys equals No_Element"; end if; @@ -458,27 +445,7 @@ package body Ada.Containers.Hashed_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.HT.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.HT.TC); end if; end Finalize; @@ -600,10 +567,7 @@ package body Ada.Containers.Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.HT.Lock > 0 then - raise Program_Error with - "Include attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.HT.TC); Position.Node.Key := Key; Position.Node.Element := New_Item; @@ -712,7 +676,7 @@ package body Ada.Containers.Hashed_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert key already in map"; end if; @@ -749,33 +713,22 @@ package body Ada.Containers.Hashed_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (Container.HT); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container.HT); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; begin return It : constant Iterator := (Limited_Controlled with Container => Container'Unrestricted_Access) do - B := B + 1; + Busy (Container.HT.TC'Unrestricted_Access.all); end return; end Iterate; @@ -785,7 +738,7 @@ package body Ada.Containers.Hashed_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; @@ -860,7 +813,7 @@ package body Ada.Containers.Hashed_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -875,15 +828,11 @@ package body Ada.Containers.Hashed_Maps is function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type is - C : constant Map_Access := Container'Unrestricted_Access; - B : Natural renames C.HT.Busy; - L : Natural renames C.HT.Lock; + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -897,7 +846,7 @@ package body Ada.Containers.Hashed_Maps is procedure (Key : Key_Type; Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -907,28 +856,11 @@ package body Ada.Containers.Hashed_Maps is declare M : Map renames Position.Container.all; HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Query_Element; @@ -977,12 +909,13 @@ package body Ada.Containers.Hashed_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -993,15 +926,14 @@ package body Ada.Containers.Hashed_Maps is declare HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1014,20 +946,19 @@ package body Ada.Containers.Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1064,15 +995,12 @@ package body Ada.Containers.Hashed_Maps is Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in map"; end if; - if Container.HT.Lock > 0 then - raise Program_Error with - "Replace attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Container.HT.TC); Node.Key := Key; Node.Element := New_Item; @@ -1088,20 +1016,18 @@ package body Ada.Containers.Hashed_Maps is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Position.Container.HT.Lock > 0 then - raise Program_Error with - "Replace_Element attempted to tamper with elements (map is locked)"; - end if; + TE_Check (Position.Container.HT.TC); pragma Assert (Vet (Position), "bad cursor in Replace_Element"); @@ -1140,12 +1066,13 @@ package body Ada.Containers.Hashed_Maps is Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1154,27 +1081,11 @@ package body Ada.Containers.Hashed_Maps is declare HT : Hash_Table_Type renames Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Update_Element; diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 12c352962de..7443b545e86 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -46,6 +46,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Hashed_Maps is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -337,7 +338,7 @@ private overriding procedure Finalize (Container : in out Map); - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -373,16 +374,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is - new Controlled with record - Container : Map_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -440,13 +433,14 @@ private -- container, and increments the Lock. Finalization of this object will -- decrement the Lock. - type Element_Access is access all Element_Type; + type Element_Access is access all Element_Type with + Storage_Size => 0; function Get_Element_Access (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0)); + Empty_Map : constant Map := (Controlled with others => <>); No_Element : constant Cursor := (Container => null, Node => null); @@ -454,7 +448,8 @@ private Map_Iterator_Interfaces.Forward_Iterator with record Container : Map_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index 1ce5c4a50b9..5f31e58f38f 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -35,13 +35,17 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Prime_Numbers; with System; use type System.Address; package body Ada.Containers.Hashed_Sets is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------- -- Local Subprograms -- @@ -152,20 +156,6 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Adjust (Container.HT); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -212,11 +202,12 @@ package body Ada.Containers.Hashed_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -225,15 +216,14 @@ package body Ada.Containers.Hashed_Sets is declare HT : Hash_Table_Type renames Position.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -264,7 +254,7 @@ package body Ada.Containers.Hashed_Sets is elsif Capacity >= Source.Length then C := Capacity; - else + elsif Checks then raise Capacity_Error with "Requested capacity is less than Source length"; end if; @@ -297,7 +287,7 @@ package body Ada.Containers.Hashed_Sets is begin Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete element not in set"; end if; @@ -309,18 +299,16 @@ package body Ada.Containers.Hashed_Sets is Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if Container.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Container.HT.TC); pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -351,10 +339,7 @@ package body Ada.Containers.Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); if Src_HT.Length < Target.HT.Length then declare @@ -462,7 +447,7 @@ package body Ada.Containers.Hashed_Sets is raise; end Iterate_Left; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Difference; ------------- @@ -471,7 +456,7 @@ package body Ada.Containers.Hashed_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -496,12 +481,12 @@ package body Ada.Containers.Hashed_Sets is function Equivalent_Elements (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; @@ -529,7 +514,7 @@ package body Ada.Containers.Hashed_Sets is function Equivalent_Elements (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of Equivalent_Elements equals No_Element"; end if; @@ -542,7 +527,7 @@ package body Ada.Containers.Hashed_Sets is function Equivalent_Elements (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of Equivalent_Elements equals No_Element"; end if; @@ -587,30 +572,10 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Finalize (Container.HT); end Finalize; - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; - end if; - end Finalize; - procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.HT.Busy; - begin - B := B - 1; - end; + Unbusy (Object.Container.HT.TC); end if; end Finalize; @@ -766,10 +731,7 @@ package body Ada.Containers.Hashed_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.HT.TC); Position.Node.Element := New_Item; end if; @@ -802,7 +764,7 @@ package body Ada.Containers.Hashed_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -836,10 +798,7 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Reserve_Capacity (HT, 1); end if; - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (HT.TC); Local_Insert (HT, New_Item, Node, Inserted); @@ -871,10 +830,7 @@ package body Ada.Containers.Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); Tgt_Node := HT_Ops.First (Target.HT); while Tgt_Node /= null loop @@ -960,7 +916,7 @@ package body Ada.Containers.Hashed_Sets is raise; end Iterate_Left; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Intersection; -------------- @@ -1036,30 +992,19 @@ package body Ada.Containers.Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Iterate (Container.HT); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Iterate (Container.HT); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.HT.Busy; begin - B := B + 1; + Busy (Container.HT.TC'Unrestricted_Access.all); return It : constant Iterator := Iterator'(Limited_Controlled with Container => Container'Unrestricted_Access); @@ -1127,7 +1072,7 @@ package body Ada.Containers.Hashed_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1171,15 +1116,11 @@ package body Ada.Containers.Hashed_Sets is function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type is - C : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames C.HT.Busy; - L : Natural renames C.HT.Lock; - begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -1192,7 +1133,7 @@ package body Ada.Containers.Hashed_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -1201,25 +1142,9 @@ package body Ada.Containers.Hashed_Sets is declare HT : Hash_Table_Type renames Position.Container.HT; - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element); end; end Query_Element; @@ -1280,15 +1205,12 @@ package body Ada.Containers.Hashed_Sets is Element_Keys.Find (Container.HT, New_Item); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.HT.TC); Node.Element := New_Item; end Replace; @@ -1299,12 +1221,13 @@ package body Ada.Containers.Hashed_Sets is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1345,26 +1268,13 @@ package body Ada.Containers.Hashed_Sets is is Tgt_HT : Hash_Table_Type renames Target.HT; Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - TB : Natural renames Tgt_HT.Busy; - TL : Natural renames Tgt_HT.Lock; - - SB : Natural renames Src_HT.Busy; - SL : Natural renames Src_HT.Lock; - begin if Target'Address = Source'Address then Clear (Target); return; end if; - if TB > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Tgt_HT.TC); declare N : constant Count_Type := Target.Length + Source.Length; @@ -1378,8 +1288,7 @@ package body Ada.Containers.Hashed_Sets is Iterate_Source_When_Empty_Target : declare procedure Process (Src_Node : Node_Access); - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + procedure Iterate is new HT_Ops.Generic_Iteration (Process); ------------- -- Process -- @@ -1396,32 +1305,16 @@ package body Ada.Containers.Hashed_Sets is N := N + 1; end Process; - -- Start of processing for Iterate_Source_When_Empty_Target + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. - begin - TB := TB + 1; - TL := TL + 1; + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - SB := SB + 1; - SL := SL + 1; + -- Start of processing for Iterate_Source_When_Empty_Target + begin Iterate (Src_HT); - - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - exception - when others => - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - raise; end Iterate_Source_When_Empty_Target; else @@ -1479,32 +1372,16 @@ package body Ada.Containers.Hashed_Sets is end if; end Process; - -- Start of processing for Iterate_Source + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. - begin - TB := TB + 1; - TL := TL + 1; + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - SB := SB + 1; - SL := SL + 1; + -- Start of processing for Iterate_Source + begin Iterate (Src_HT); - - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - exception - when others => - SL := SL - 1; - SB := SB - 1; - - TL := TL - 1; - TB := TB - 1; - - raise; end Iterate_Source; end if; end Symmetric_Difference; @@ -1621,7 +1498,7 @@ package body Ada.Containers.Hashed_Sets is raise; end Iterate_Right; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Symmetric_Difference; ------------ @@ -1692,10 +1569,7 @@ package body Ada.Containers.Hashed_Sets is return; end if; - if Target.HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is busy)"; - end if; + TC_Check (Target.HT.TC); declare N : constant Count_Type := Target.Length + Source.Length; @@ -1757,25 +1631,14 @@ package body Ada.Containers.Hashed_Sets is -- Checked_Index instead of a simple invocation of generic formal -- Hash. - B : Integer renames Left_HT.Busy; - L : Integer renames Left_HT.Lock; + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); -- Start of processing for Iterate_Left begin - B := B + 1; - L := L + 1; - Iterate (Left_HT); - - L := L - 1; - B := B - 1; - exception when others => - L := L - 1; - B := B - 1; - HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Left; @@ -1816,42 +1679,20 @@ package body Ada.Containers.Hashed_Sets is -- Checked_Index instead of a simple invocation of generic formal -- Hash. - LB : Integer renames Left_HT.Busy; - LL : Integer renames Left_HT.Lock; - - RB : Integer renames Right_HT.Busy; - RL : Integer renames Right_HT.Lock; + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access); -- Start of processing for Iterate_Right begin - LB := LB + 1; - LL := LL + 1; - - RB := RB + 1; - RL := RL + 1; - Iterate (Right_HT); - - RL := RL - 1; - RB := RB - 1; - - LL := LL - 1; - LB := LB - 1; - exception when others => - RL := RL - 1; - RB := RB - 1; - - LL := LL - 1; - LB := LB - 1; - HT_Ops.Free_Hash_Table (Buckets); raise; end Iterate_Right; - return (Controlled with HT => (Buckets, Length, 0, 0)); + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); end Union; --------- @@ -1957,24 +1798,6 @@ package body Ada.Containers.Hashed_Sets is -- Local Subprograms -- ----------------------- - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - function Equivalent_Key_Node (Key : Key_Type; Node : Node_Access) return Boolean; @@ -2005,20 +1828,19 @@ package body Ada.Containers.Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "Key not in set"; end if; declare - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -2048,7 +1870,7 @@ package body Ada.Containers.Hashed_Sets is begin Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete key not in set"; end if; @@ -2067,7 +1889,7 @@ package body Ada.Containers.Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; end if; @@ -2107,16 +1929,10 @@ package body Ada.Containers.Hashed_Sets is procedure Finalize (Control : in out Reference_Control_Type) is begin if Control.Container /= null then - declare - HT : Hash_Table_Type renames Control.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - begin - B := B - 1; - L := L - 1; - end; + Impl.Reference_Control_Type (Control).Finalize; - if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash + if Checks and then + Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash then HT_Ops.Delete_Node_At_Index (Control.Container.HT, Control.Index, Control.Old_Pos.Node); @@ -2151,7 +1967,7 @@ package body Ada.Containers.Hashed_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -2182,11 +1998,12 @@ package body Ada.Containers.Hashed_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -2197,20 +2014,18 @@ package body Ada.Containers.Hashed_Sets is declare HT : Hash_Table_Type renames Position.Container.all.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; begin return R : constant Reference_Type := (Element => Position.Node.Element'Access, Control => (Controlled with + HT.TC'Unrestricted_Access, Container'Unrestricted_Access, Index => HT_Ops.Index (HT, Position.Node), Old_Pos => Position, Old_Hash => Hash (Key (Position)))) do - B := B + 1; - L := L + 1; + Lock (HT.TC); end return; end; end Reference_Preserving_Key; @@ -2222,27 +2037,25 @@ package body Ada.Containers.Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; end if; declare HT : Hash_Table_Type renames Container.HT; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; P : constant Cursor := Find (Container, Key); begin return R : constant Reference_Type := (Element => Node.Element'Access, Control => (Controlled with + HT.TC'Unrestricted_Access, Container'Unrestricted_Access, Index => HT_Ops.Index (HT, P.Node), Old_Pos => P, Old_Hash => Hash (Key))) do - B := B + 1; - L := L + 1; + Lock (HT.TC); end return; end; end Reference_Preserving_Key; @@ -2259,7 +2072,7 @@ package body Ada.Containers.Hashed_Sets is Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -2281,20 +2094,22 @@ package body Ada.Containers.Hashed_Sets is Indx : Hash_Type; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; - if HT.Buckets = null - or else HT.Buckets'Length = 0 - or else HT.Length = 0 - or else Position.Node.Next = Position.Node + if Checks and then + (HT.Buckets = null + or else HT.Buckets'Length = 0 + or else HT.Length = 0 + or else Position.Node.Next = Position.Node) then raise Program_Error with "Position cursor is bad (set is empty)"; end if; @@ -2309,31 +2124,12 @@ package body Ada.Containers.Hashed_Sets is declare E : Element_Type renames Position.Node.Element; K : constant Key_Type := Key (E); - - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - - Eq : Boolean; - + Lock : With_Lock (HT.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Indx := HT_Ops.Index (HT, Position.Node); - Process (E); - Eq := Equivalent_Keys (K, Key (E)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Indx := HT_Ops.Index (HT, Position.Node); + Process (E); - if Eq then + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -2349,7 +2145,7 @@ package body Ada.Containers.Hashed_Sets is while Prev.Next /= Position.Node loop Prev := Prev.Next; - if Prev = null then + if Checks and then Prev = null then raise Program_Error with "Position cursor is bad (node not found)"; end if; diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index 7e5671edfb4..681087a2913 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -34,6 +34,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; +with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -48,6 +49,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Hashed_Sets is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -451,8 +453,10 @@ package Ada.Containers.Hashed_Sets is -- in that case the check that buckets have not changed is performed -- at the time of the update, not when the reference is finalized. + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Index : Hash_Type; @@ -460,9 +464,6 @@ package Ada.Containers.Hashed_Sets is Old_Hash : Hash_Type; end record; - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - overriding procedure Finalize (Control : in out Reference_Control_Type); pragma Inline (Finalize); @@ -505,7 +506,7 @@ private overriding procedure Finalize (Container : in out Set); - use HT_Types; + use HT_Types, HT_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -529,10 +530,6 @@ private Node : Node_Access; end record; - type Reference_Control_Type is new Ada.Finalization.Controlled with record - Container : Set_Access; - end record; - procedure Write (Stream : not null access Root_Stream_Type'Class; Item : Cursor); @@ -545,11 +542,8 @@ private for Cursor'Read use Read; - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -585,21 +579,23 @@ private -- container, and increments the Lock. Finalization of this object will -- decrement the Lock. - type Element_Access is access all Element_Type; + type Element_Access is access all Element_Type with + Storage_Size => 0; function Get_Element_Access (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0)); + Empty_Set : constant Set := (Controlled with others => <>); No_Element : constant Cursor := (Container => null, Node => null); - type Iterator is new Limited_Controlled - and Set_Iterator_Interfaces.Forward_Iterator with + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with record Container : Set_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding function First (Object : Iterator) return Cursor; diff --git a/gcc/ada/a-cohata.ads b/gcc/ada/a-cohata.ads index 1a77970a0c7..c83e8c0081c 100644 --- a/gcc/ada/a-cohata.ads +++ b/gcc/ada/a-cohata.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,6 +30,8 @@ -- This package declares the hash-table type used to implement hashed -- containers. +with Ada.Containers.Helpers; + package Ada.Containers.Hash_Tables is pragma Pure; -- Declare Pure so this can be imported by Remote_Types packages @@ -40,6 +42,7 @@ package Ada.Containers.Hash_Tables is type Node_Access is access Node_Type; package Generic_Hash_Table_Types is + type Buckets_Type is array (Hash_Type range <>) of Node_Access; type Buckets_Access is access all Buckets_Type; @@ -47,16 +50,18 @@ package Ada.Containers.Hash_Tables is -- Storage_Size of zero so this package can be Pure type Hash_Table_Type is tagged record - Buckets : Buckets_Access; + Buckets : Buckets_Access := null; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Helpers.Tamper_Counts; end record; + + package Implementation is new Helpers.Generic_Implementation; end Generic_Hash_Table_Types; generic type Node_Type is private; package Generic_Bounded_Hash_Table_Types is + type Nodes_Type is array (Count_Type range <>) of Node_Type; type Buckets_Type is array (Hash_Type range <>) of Count_Type; @@ -65,12 +70,13 @@ package Ada.Containers.Hash_Tables is Modulus : Hash_Type) is tagged record Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Helpers.Tamper_Counts; Free : Count_Type'Base := -1; Nodes : Nodes_Type (1 .. Capacity) := (others => <>); Buckets : Buckets_Type (1 .. Modulus) := (others => 0); end record; + + package Implementation is new Helpers.Generic_Implementation; end Generic_Bounded_Hash_Table_Types; end Ada.Containers.Hash_Tables; diff --git a/gcc/ada/a-coinho-shared.adb b/gcc/ada/a-coinho-shared.adb index 9dd5b2f18cc..81732b9f551 100644 --- a/gcc/ada/a-coinho-shared.adb +++ b/gcc/ada/a-coinho-shared.adb @@ -36,8 +36,6 @@ with Ada.Unchecked_Deallocation; package body Ada.Containers.Indefinite_Holders is - pragma Annotate (CodePeer, Skip_Analysis); - procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); diff --git a/gcc/ada/a-coinho-shared.ads b/gcc/ada/a-coinho-shared.ads index 49b91fd6ae3..e5dfb543256 100644 --- a/gcc/ada/a-coinho-shared.ads +++ b/gcc/ada/a-coinho-shared.ads @@ -42,6 +42,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Holders is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate (Indefinite_Holders); pragma Remote_Types (Indefinite_Holders); diff --git a/gcc/ada/a-coinho.adb b/gcc/ada/a-coinho.adb index 0135ea55db4..e9f40aca207 100644 --- a/gcc/ada/a-coinho.adb +++ b/gcc/ada/a-coinho.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2012-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2012-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,8 +29,6 @@ with Ada.Unchecked_Deallocation; package body Ada.Containers.Indefinite_Holders is - pragma Annotate (CodePeer, Skip_Analysis); - procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); diff --git a/gcc/ada/a-coinho.ads b/gcc/ada/a-coinho.ads index 271d4ea0d63..7cfd193ca3c 100644 --- a/gcc/ada/a-coinho.ads +++ b/gcc/ada/a-coinho.ads @@ -37,6 +37,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Holders is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate (Indefinite_Holders); pragma Remote_Types (Indefinite_Holders); diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index bb7b2837c50..7843b5e1348 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,7 +34,9 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Vectors is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); @@ -42,451 +44,56 @@ package body Ada.Containers.Indefinite_Vectors is procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + procedure Append_Slow_Path + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type); + -- This is the slow path for Append. This is split out to minimize the size + -- of Append, because we have Inline (Append). + --------- -- "&" -- --------- - function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); - N : Count_Type'Base; -- length of result - J : Count_Type'Base; -- for computing intermediate values - Last : Index_Type'Base; -- Last index of result + -- We decide that the capacity of the result of "&" is the minimum needed + -- -- the sum of the lengths of the vector parameters. We could decide to + -- make it larger, but we have no basis for knowing how much larger, so we + -- just allocate the minimum amount of storage. + function "&" (Left, Right : Vector) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the vector parameters. We could decide to make it larger, but we - -- have no basis for knowing how much larger, so we just allocate the - -- minimum amount of storage. - - -- Here we handle the easy cases first, when one of the vector - -- parameters is empty. (We say "easy" because there's nothing to - -- compute, that can potentially overflow.) - - if LN = 0 then - if RN = 0 then - return Empty_Vector; - end if; - - declare - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - - Elements : Elements_Access := new Elements_Type (Right.Last); - - begin - -- Elements of an indefinite vector are allocated, so we cannot - -- use simple slice assignment to give a value to our result. - -- Hence we must walk the array of the Right vector, and copy - -- each source element individually. - - for I in Elements.EA'Range loop - begin - if RE (I) /= null then - Elements.EA (I) := new Element_Type'(RE (I).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Right.Last, 0, 0); - end; - end if; - - if RN = 0 then - declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - - Elements : Elements_Access := new Elements_Type (Left.Last); - - begin - -- Elements of an indefinite vector are allocated, so we cannot - -- use simple slice assignment to give a value to our result. - -- Hence we must walk the array of the Left vector, and copy - -- each source element individually. - - for I in Elements.EA'Range loop - begin - if LE (I) /= null then - Elements.EA (I) := new Element_Type'(LE (I).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Left.Last, 0, 0); - end; - end if; - - -- Neither of the vector parameters is empty, so we must compute the - -- length of the result vector and its last index. (This is the harder - -- case, because our computations must avoid overflow.) - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the combined lengths. Note that we cannot - -- simply add the lengths, because of the possibility of overflow. - - if LN > Count_Type'Last - RN then - raise Constraint_Error with "new length is out of range"; - end if; - - -- It is now safe compute the length of the new vector. - - N := LN + RN; - - -- The second constraint is that the new Last index value cannot - -- exceed Index_Type'Last. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (N); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Last > Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of length. - - J := Count_Type'Base (No_Index) + N; -- Last - - if J > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (J); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - - if J < Count_Type'Base (No_Index) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We have determined that the result length would not create a Last - -- index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + N); - end if; - - declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - - Elements : Elements_Access := new Elements_Type (Last); - - I : Index_Type'Base := No_Index; - - begin - -- Elements of an indefinite vector are allocated, so we cannot use - -- simple slice assignment to give a value to our result. Hence we - -- must walk the array of each vector parameter, and copy each source - -- element individually. - - for LI in LE'Range loop - I := I + 1; - - begin - if LE (LI) /= null then - Elements.EA (I) := new Element_Type'(LE (LI).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - for RI in RE'Range loop - I := I + 1; - - begin - if RE (RI) /= null then - Elements.EA (I) := new Element_Type'(RE (RI).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Last, 0, 0); - end; + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; - function "&" (Left : Vector; Right : Element_Type) return Vector is + function "&" (Left : Vector; Right : Element_Type) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- Here we handle the easy case first, when the vector parameter (Left) - -- is empty. - - if Left.Is_Empty then - declare - Elements : Elements_Access := new Elements_Type (Index_Type'First); - - begin - begin - Elements.EA (Index_Type'First) := new Element_Type'(Right); - exception - when others => - Free (Elements); - raise; - end; - - return (Controlled with Elements, Index_Type'First, 0, 0); - end; - end if; - - -- The vector parameter is not empty, so we must compute the length of - -- the result vector and its last index, but in such a way that overflow - -- is avoided. We must satisfy two constraints: the new length cannot - -- exceed Count_Type'Last, and the new Last index cannot exceed - -- Index_Type'Last. - - if Left.Length = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Left.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Left.Last + 1; - - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - - Elements : Elements_Access := new Elements_Type (Last); - - begin - for I in LE'Range loop - begin - if LE (I) /= null then - Elements.EA (I) := new Element_Type'(LE (I).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - begin - Elements.EA (Last) := new Element_Type'(Right); - - exception - when others => - for J in Index_Type'First .. Last - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - - return (Controlled with Elements, Last, 0, 0); - end; + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + 1); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; - function "&" (Left : Element_Type; Right : Vector) return Vector is + function "&" (Left : Element_Type; Right : Vector) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- Here we handle the easy case first, when the vector parameter (Right) - -- is empty. - - if Right.Is_Empty then - declare - Elements : Elements_Access := new Elements_Type (Index_Type'First); - - begin - begin - Elements.EA (Index_Type'First) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - return (Controlled with Elements, Index_Type'First, 0, 0); - end; - end if; - - -- The vector parameter is not empty, so we must compute the length of - -- the result vector and its last index, but in such a way that overflow - -- is avoided. We must satisfy two constraints: the new length cannot - -- exceed Count_Type'Last, and the new Last index cannot exceed - -- Index_Type'Last. - - if Right.Length = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Right.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Right.Last + 1; - - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - - Elements : Elements_Access := new Elements_Type (Last); - - I : Index_Type'Base := Index_Type'First; - - begin - begin - Elements.EA (I) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - for RI in RE'Range loop - I := I + 1; - - begin - if RE (RI) /= null then - Elements.EA (I) := new Element_Type'(RE (RI).all); - end if; - - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Last, 0, 0); - end; + return Result : Vector do + Reserve_Capacity (Result, 1 + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; function "&" (Left, Right : Element_Type) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- We must compute the length of the result vector and its last index, - -- but in such a way that overflow is avoided. We must satisfy two - -- constraints: the new length cannot exceed Count_Type'Last (here, we - -- know that that condition is satisfied), and the new Last index cannot - -- exceed Index_Type'Last. - - if Index_Type'First >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Index_Type'First + 1; - Elements : Elements_Access := new Elements_Type (Last); - - begin - begin - Elements.EA (Index_Type'First) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - begin - Elements.EA (Last) := new Element_Type'(Right); - exception - when others => - Free (Elements.EA (Index_Type'First)); - Free (Elements); - raise; - end; - - return (Controlled with Elements, Last, 0, 0); - end; + return Result : Vector do + Reserve_Capacity (Result, 1 + 1); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; --------- @@ -494,67 +101,38 @@ package body Ada.Containers.Indefinite_Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - - Result : Boolean; - begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Last /= Right.Last then return False; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - - Result := True; - for J in Index_Type'First .. Left.Last loop - if Left.Elements.EA (J) = null then - if Right.Elements.EA (J) /= null then - Result := False; - exit; - end if; - - elsif Right.Elements.EA (J) = null then - Result := False; - exit; - - elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then - Result := False; - exit; - end if; - end loop; - - BL := BL - 1; - LL := LL - 1; + if Left.Length = 0 then + return True; + end if; - BR := BR - 1; - LR := LR - 1; + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - return Result; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + begin + for J in Index_Type range Index_Type'First .. Left.Last loop + if Left.Elements.EA (J) = null then + if Right.Elements.EA (J) /= null then + return False; + end if; - exception - when others => - BL := BL - 1; - LL := LL - 1; + elsif Right.Elements.EA (J) = null then + return False; - BR := BR - 1; - LR := LR - 1; + elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then + return False; + end if; + end loop; + end; - raise; + return True; end "="; ------------ @@ -563,6 +141,12 @@ package body Ada.Containers.Indefinite_Vectors is procedure Adjust (Container : in out Vector) is begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + if Container.Last = No_Index then Container.Elements := null; return; @@ -576,8 +160,6 @@ package body Ada.Containers.Indefinite_Vectors is begin Container.Elements := null; Container.Last := No_Index; - Container.Busy := 0; - Container.Lock := 0; Container.Elements := new Elements_Type (L); @@ -591,20 +173,6 @@ package body Ada.Containers.Indefinite_Vectors is end; end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Append -- ------------ @@ -613,7 +181,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Is_Empty (New_Item) then return; - elsif Container.Last = Index_Type'Last then + elsif Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else Insert (Container, Container.Last + 1, New_Item); @@ -626,14 +194,56 @@ package body Ada.Containers.Indefinite_Vectors is Count : Count_Type := 1) is begin + -- In the general case, we pass the buck to Insert, but for efficiency, + -- we check for the usual case where Count = 1 and the vector has enough + -- room for at least one more element. + + if Count = 1 + and then Container.Elements /= null + and then Container.Last /= Container.Elements.Last + then + TC_Check (Container.TC); + + -- Increment Container.Last after assigning the New_Item, so we + -- leave the Container unmodified in case Finalize/Adjust raises + -- an exception. + + declare + New_Last : constant Index_Type := Container.Last + 1; + + -- The element allocator may need an accessibility check in the + -- case actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin + Container.Elements.EA (New_Last) := new Element_Type'(New_Item); + Container.Last := New_Last; + end; + + else + Append_Slow_Path (Container, New_Item, Count); + end if; + end Append; + + ---------------------- + -- Append_Slow_Path -- + ---------------------- + + procedure Append_Slow_Path + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + is + begin if Count = 0 then return; - elsif Container.Last = Index_Type'Last then + elsif Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else Insert (Container, Container.Last + 1, New_Item, Count); end if; - end Append; + end Append_Slow_Path; ------------ -- Assign -- @@ -668,21 +278,17 @@ package body Ada.Containers.Indefinite_Vectors is procedure Clear (Container : in out Vector) is begin - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; + TC_Check (Container.TC); - else - while Container.Last >= Index_Type'First loop - declare - X : Element_Access := Container.Elements.EA (Container.Last); - begin - Container.Elements.EA (Container.Last) := null; - Container.Last := Container.Last - 1; - Free (X); - end; - end loop; - end if; + while Container.Last >= Index_Type'First loop + declare + X : Element_Access := Container.Elements.EA (Container.Last); + begin + Container.Elements.EA (Container.Last) := null; + Container.Last := Container.Last - 1; + Free (X); + end; + end loop; end Clear; ------------------------ @@ -693,38 +299,32 @@ package body Ada.Containers.Indefinite_Vectors is (Container : aliased Vector; Position : Cursor) return Constant_Reference_Type is - E : Element_Access; - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - E := Container.Elements.EA (Position.Index); + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; - if E = null then - raise Constraint_Error with "element at Position is empty"; + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin + -- The following will raise Constraint_Error if Element is null + return R : constant Constant_Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => Container.Elements.EA (Position.Index), + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -733,30 +333,22 @@ package body Ada.Containers.Indefinite_Vectors is (Container : aliased Vector; Index : Index_Type) return Constant_Reference_Type is - E : Element_Access; - begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - E := Container.Elements.EA (Index); - - if E = null then - raise Constraint_Error with "element at Index is empty"; - end if; - declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin + -- The following will raise Constraint_Error if Element is null + return R : constant Constant_Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => Container.Elements.EA (Index), + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -790,9 +382,9 @@ package body Ada.Containers.Indefinite_Vectors is elsif Capacity >= Source.Length then C := Capacity; - else - raise Capacity_Error - with "Requested capacity is less than Source length"; + elsif Checks then + raise Capacity_Error with + "Requested capacity is less than Source length"; end if; return Target : Vector do @@ -833,7 +425,7 @@ package body Ada.Containers.Indefinite_Vectors is -- in the base range that immediately precede and immediately follow the -- values in the Index_Type.) - if Index < Index_Type'First then + if Checks and then Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; @@ -845,7 +437,7 @@ package body Ada.Containers.Indefinite_Vectors is -- algorithm, so that case is treated as a proper error.) if Index > Old_Last then - if Index > Old_Last + 1 then + if Checks and then Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; else return; @@ -874,10 +466,7 @@ package body Ada.Containers.Indefinite_Vectors is -- the count on exit. Delete checks the count to determine whether it is -- being called while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- We first calculate what's available for deletion starting at -- Index. Here and elsewhere we use the wider of Index_Type'Base and @@ -886,7 +475,6 @@ package body Ada.Containers.Indefinite_Vectors is if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else Count2 := Count_Type'Base (Old_Last - Index + 1); end if; @@ -938,7 +526,7 @@ package body Ada.Containers.Indefinite_Vectors is -- index value New_Last is the last index value of their new home, and -- index value J is the first index of their old home. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then New_Last := Old_Last - Index_Type'Base (Count); J := Index + Index_Type'Base (Count); else @@ -988,22 +576,21 @@ package body Ada.Containers.Indefinite_Vectors is Position : in out Cursor; Count : Count_Type := 1) is - pragma Warnings (Off, Position); - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; - elsif Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; - else - Delete (Container, Position.Index, Count); - Position := No_Element; + elsif Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; end if; + + Delete (Container, Position.Index, Count); + Position := No_Element; end Delete; ------------------ @@ -1062,10 +649,7 @@ package body Ada.Containers.Indefinite_Vectors is -- it is being called while the associated callback procedure is -- executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- Elements in an indefinite vector are allocated, so we must iterate -- over the loop and deallocate elements one-at-a-time. We work from @@ -1108,14 +692,14 @@ package body Ada.Containers.Indefinite_Vectors is Index : Index_Type) return Element_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; declare EA : constant Element_Access := Container.Elements.EA (Index); begin - if EA = null then + if Checks and then EA = null then raise Constraint_Error with "element is empty"; else return EA.all; @@ -1125,19 +709,21 @@ package body Ada.Containers.Indefinite_Vectors is function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; declare EA : constant Element_Access := Position.Container.Elements.EA (Position.Index); begin - if EA = null then + if Checks and then EA = null then raise Constraint_Error with "element is empty"; else return EA.all; @@ -1162,25 +748,11 @@ package body Ada.Containers.Indefinite_Vectors is end Finalize; procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Busy; + pragma Warnings (Off); + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); begin - B := B - 1; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; - end if; + Unbusy (Object.Container.TC); end Finalize; ---------- @@ -1193,7 +765,7 @@ package body Ada.Containers.Indefinite_Vectors is Position : Cursor := No_Element) return Cursor is begin - if Position.Container /= null then + if Checks and then Position.Container /= null then if Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; end if; @@ -1207,39 +779,15 @@ package body Ada.Containers.Indefinite_Vectors is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for J in Position.Index .. Container.Last loop - if Container.Elements.EA (J) /= null - and then Container.Elements.EA (J).all = Item - then - Result := J; - exit; + if Container.Elements.EA (J).all = Item then + return Cursor'(Container'Unrestricted_Access, J); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return No_Element; end; end Find; @@ -1252,39 +800,18 @@ package body Ada.Containers.Indefinite_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; - - Result := No_Index; + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin for Indx in Index .. Container.Last loop - if Container.Elements.EA (Indx) /= null - and then Container.Elements.EA (Indx).all = Item - then - Result := Indx; - exit; + if Container.Elements.EA (Indx).all = Item then + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Index; end Find_Index; ----------- @@ -1329,7 +856,7 @@ package body Ada.Containers.Indefinite_Vectors is function First_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; end if; @@ -1337,7 +864,7 @@ package body Ada.Containers.Indefinite_Vectors is EA : constant Element_Access := Container.Elements.EA (Index_Type'First); begin - if EA = null then + if Checks and then EA = null then raise Constraint_Error with "first element is empty"; else return EA.all; @@ -1397,36 +924,16 @@ package body Ada.Containers.Indefinite_Vectors is -- element tampering by a generic actual subprogram. declare + Lock : With_Lock (Container.TC'Unrestricted_Access); E : Elements_Array renames Container.Elements.EA; - - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Boolean; - begin - B := B + 1; - L := L + 1; - - Result := True; - for I in Index_Type'First .. Container.Last - 1 loop - if Is_Less (E (I + 1), E (I)) then - Result := False; - exit; + for J in Index_Type'First .. Container.Last - 1 loop + if Is_Less (E (J + 1), E (J)) then + return False; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return True; end; end Is_Sorted; @@ -1450,7 +957,7 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; end if; @@ -1460,10 +967,7 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Source.TC); I := Target.Last; -- original value (before Set_Length) Target.Set_Length (Length (Target) + Length (Source)); @@ -1475,19 +979,9 @@ package body Ada.Containers.Indefinite_Vectors is TA : Elements_Array renames Target.Elements.EA; SA : Elements_Array renames Source.Elements.EA; - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; - - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; - + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - J := Target.Last; -- new value (after Set_Length) while Source.Last >= Index_Type'First loop pragma Assert @@ -1531,22 +1025,6 @@ package body Ada.Containers.Indefinite_Vectors is J := J - 1; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -1579,38 +1057,30 @@ package body Ada.Containers.Indefinite_Vectors is -- an artifact of our array-based implementation. Logically Sort -- requires a check for cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; end Sort; end Generic_Sorting; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Elements.EA (Position.Index); + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1648,33 +1118,33 @@ package body Ada.Containers.Indefinite_Vectors is Dst : Elements_Access; -- new, expanded internal array begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Before > Container.Last - and then Before > Container.Last + 1 - then - raise Constraint_Error with - "Before index is out of range (too large)"; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) + + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; end if; -- We treat inserting 0 items into the container as a no-op, even when @@ -1687,10 +1157,10 @@ package body Ada.Containers.Indefinite_Vectors is -- There are two constraints we need to satisfy. The first constraint is -- that a container cannot have more than Count_Type'Last elements, so -- we must check the sum of the current length and the insertion count. - -- Note that we cannot simply add these values, because of the - -- possibility of overflow. + -- Note: we cannot simply add these values, because of the possibility + -- of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -1705,7 +1175,7 @@ package body Ada.Containers.Indefinite_Vectors is -- compare the new length to the maximum length. If the new length is -- acceptable, then we compute the new last index from that. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then -- We have to handle the case when there might be more values in the -- range of Index_Type than in the range of Count_Type. @@ -1740,9 +1210,7 @@ package body Ada.Containers.Indefinite_Vectors is -- worry about if No_Index were less than 0, but that case is -- handled above). - if Index_Type'Last - No_Index >= - Count_Type'Pos (Count_Type'Last) - then + if Index_Type'Last - No_Index >= Count_Type_Last then -- We have determined that range of Index_Type has at least as -- many values as in Count_Type, so Count_Type'Last is the -- maximum number of items that are allowed. @@ -1799,7 +1267,7 @@ package body Ada.Containers.Indefinite_Vectors is -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -1807,7 +1275,7 @@ package body Ada.Containers.Indefinite_Vectors is -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to -- compute its value from the New_Length. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then New_Last := No_Index + Index_Type'Base (New_Length); else New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); @@ -1863,10 +1331,7 @@ package body Ada.Containers.Indefinite_Vectors is -- exit. Insert checks the count to determine whether it is being called -- while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); if New_Length <= Container.Elements.EA'Length then @@ -1916,7 +1381,7 @@ package body Ada.Containers.Indefinite_Vectors is -- new home. We use the wider of Index_Type'Base and -- Count_Type'Base as the type for intermediate index values. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Index := Before + Index_Type'Base (Count); else Index := Index_Type'Base (Count_Type'Base (Before) + Count); @@ -2002,7 +1467,7 @@ package body Ada.Containers.Indefinite_Vectors is -- We have computed the length of the new internal array (and this is -- what "vector capacity" means), so use that to compute its last index. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Dst_Last := No_Index + Index_Type'Base (New_Capacity); else Dst_Last := @@ -2069,7 +1534,7 @@ package body Ada.Containers.Indefinite_Vectors is -- The new items are being inserted before some existing elements, -- so we must slide the existing elements up to their new home. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Index := Before + Index_Type'Base (Count); else Index := Index_Type'Base (Count_Type'Base (Before) + Count); @@ -2219,7 +1684,7 @@ package body Ada.Containers.Indefinite_Vectors is -- after copying the first slice of the source, and determining that -- this second slice of the source is empty. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then J := Before + Index_Type'Base (N); else J := Index_Type'Base (Count_Type'Base (Before) + N); @@ -2242,7 +1707,7 @@ package body Ada.Containers.Indefinite_Vectors is -- destination that receives this slice of the source. (For the -- reasons given above, this slice is guaranteed to be non-empty.) - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Dst_Index := J - Index_Type'Base (Src'Length); else Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length); @@ -2266,7 +1731,7 @@ package body Ada.Containers.Indefinite_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -2277,7 +1742,7 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -2300,9 +1765,8 @@ package body Ada.Containers.Indefinite_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null - and then Before.Container /= - Vector_Access'(Container'Unrestricted_Access) + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2318,7 +1782,7 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -2331,7 +1795,7 @@ package body Ada.Containers.Indefinite_Vectors is Insert (Container, Index, New_Item); - Position := Cursor'(Container'Unrestricted_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert; procedure Insert @@ -2343,7 +1807,7 @@ package body Ada.Containers.Indefinite_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -2354,7 +1818,7 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -2378,16 +1842,14 @@ package body Ada.Containers.Indefinite_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; if Count = 0 then - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then Position := No_Element; else Position := (Container'Unrestricted_Access, Before.Index); @@ -2397,7 +1859,7 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -2436,31 +1898,33 @@ package body Ada.Containers.Indefinite_Vectors is Dst : Elements_Access; -- new, expanded internal array begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Before > Container.Last and then Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) + + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; end if; -- We treat inserting 0 items into the container as a no-op, even when @@ -2472,11 +1936,11 @@ package body Ada.Containers.Indefinite_Vectors is -- There are two constraints we need to satisfy. The first constraint is -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion - -- count. Note that we cannot simply add these values, because of the - -- possibility of overflow. + -- we must check the sum of the current length and the insertion count. + -- Note: we cannot simply add these values, because of the possibility + -- of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -2491,7 +1955,7 @@ package body Ada.Containers.Indefinite_Vectors is -- compare the new length to the maximum length. If the new length is -- acceptable, then we compute the new last index from that. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then -- We have to handle the case when there might be more values in the -- range of Index_Type than in the range of Count_Type. @@ -2525,9 +1989,7 @@ package body Ada.Containers.Indefinite_Vectors is -- worry about if No_Index were less than 0, but that case is -- handled above). - if Index_Type'Last - No_Index >= - Count_Type'Pos (Count_Type'Last) - then + if Index_Type'Last - No_Index >= Count_Type_Last then -- We have determined that range of Index_Type has at least as -- many values as in Count_Type, so Count_Type'Last is the -- maximum number of items that are allowed. @@ -2584,7 +2046,7 @@ package body Ada.Containers.Indefinite_Vectors is -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -2592,7 +2054,7 @@ package body Ada.Containers.Indefinite_Vectors is -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to -- compute its value from the New_Length. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then New_Last := No_Index + Index_Type'Base (New_Length); else New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); @@ -2624,10 +2086,7 @@ package body Ada.Containers.Indefinite_Vectors is -- Insert checks the count to determine whether it is being called while -- the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); if New_Length <= Container.Elements.EA'Length then @@ -2646,7 +2105,7 @@ package body Ada.Containers.Indefinite_Vectors is -- their new home. We use the wider of Index_Type'Base and -- Count_Type'Base as the type for intermediate index values. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Index := Before + Index_Type'Base (Count); else Index := Index_Type'Base (Count_Type'Base (Before) + Count); @@ -2692,7 +2151,7 @@ package body Ada.Containers.Indefinite_Vectors is -- We have computed the length of the new internal array (and this is -- what "vector capacity" means), so use that to compute its last index. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Dst_Last := No_Index + Index_Type'Base (New_Capacity); else Dst_Last := @@ -2722,7 +2181,7 @@ package body Ada.Containers.Indefinite_Vectors is -- The new items are being inserted before some existing elements, -- so we must slide the existing elements up to their new home. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then Index := Before + Index_Type'Base (Count); else Index := Index_Type'Base (Count_Type'Base (Before) + Count); @@ -2750,7 +2209,7 @@ package body Ada.Containers.Indefinite_Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -2766,10 +2225,8 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then - if Container.Last = Index_Type'Last then + if Before.Container = null or else Before.Index > Container.Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -2782,7 +2239,7 @@ package body Ada.Containers.Indefinite_Vectors is Insert_Space (Container, Index, Count); - Position := Cursor'(Container'Unrestricted_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert_Space; -------------- @@ -2802,30 +2259,18 @@ package body Ada.Containers.Indefinite_Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Iterate; - function Iterate (Container : Vector) + function Iterate + (Container : Vector) return Vector_Iterator_Interfaces.Reversible_Iterator'Class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- The value of its Index component influences the behavior of the First -- and Last selector functions of the iterator object. When the Index @@ -2842,7 +2287,7 @@ package body Ada.Containers.Indefinite_Vectors is Container => V, Index => No_Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -2852,8 +2297,6 @@ package body Ada.Containers.Indefinite_Vectors is return Vector_Iterator_Interfaces.Reversible_Iterator'Class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -2866,19 +2309,21 @@ package body Ada.Containers.Indefinite_Vectors is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start.Container = null then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; + if Checks then + if Start.Container = null then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; - if Start.Container /= V then - raise Program_Error with - "Start cursor of Iterate designates wrong vector"; - end if; + if Start.Container /= V then + raise Program_Error with + "Start cursor of Iterate designates wrong vector"; + end if; - if Start.Index > V.Last then - raise Constraint_Error with - "Start position for iterator equals No_Element"; + if Start.Index > V.Last then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; end if; -- The value of its Index component influences the behavior of the First @@ -2895,7 +2340,7 @@ package body Ada.Containers.Indefinite_Vectors is Container => V, Index => Start.Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -2934,13 +2379,13 @@ package body Ada.Containers.Indefinite_Vectors is end if; end Last; - ----------------- + ------------------ -- Last_Element -- ------------------ function Last_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; end if; @@ -2948,7 +2393,7 @@ package body Ada.Containers.Indefinite_Vectors is EA : constant Element_Access := Container.Elements.EA (Container.Last); begin - if EA = null then + if Checks and then EA = null then raise Constraint_Error with "last element is empty"; else return EA.all; @@ -3012,10 +2457,7 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Source is busy)"; - end if; + TC_Check (Source.TC); Clear (Target); -- Checks busy-bit @@ -3049,7 +2491,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + elsif Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; else @@ -3090,17 +2532,6 @@ package body Ada.Containers.Indefinite_Vectors is -- Previous -- -------------- - procedure Previous (Position : in out Cursor) is - begin - if Position.Container = null then - return; - elsif Position.Index > Index_Type'First then - Position.Index := Position.Index - 1; - else - Position := No_Element; - end if; - end Previous; - function Previous (Position : Cursor) return Cursor is begin if Position.Container = null then @@ -3116,7 +2547,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + elsif Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; else @@ -3124,6 +2555,31 @@ package body Ada.Containers.Indefinite_Vectors is end if; end Previous; + procedure Previous (Position : in out Cursor) is + begin + if Position.Container = null then + return; + elsif Position.Index > Index_Type'First then + Position.Index := Position.Index - 1; + else + Position := No_Element; + end if; + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -3133,33 +2589,19 @@ package body Ada.Containers.Indefinite_Vectors is Index : Index_Type; Process : not null access procedure (Element : Element_Type)) is + Lock : With_Lock (Container.TC'Unrestricted_Access); V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - L : Natural renames V.Lock; begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - if V.Elements.EA (Index) = null then + if Checks and then V.Elements.EA (Index) = null then raise Constraint_Error with "element is null"; end if; - B := B + 1; - L := L + 1; - - begin - Process (V.Elements.EA (Index).all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (V.Elements.EA (Index).all); end Query_Element; procedure Query_Element @@ -3167,7 +2609,7 @@ package body Ada.Containers.Indefinite_Vectors is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; else Query_Element (Position.Container.all, Position.Index, Process); @@ -3241,38 +2683,32 @@ package body Ada.Containers.Indefinite_Vectors is (Container : aliased in out Vector; Position : Cursor) return Reference_Type is - E : Element_Access; - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - E := Container.Elements.EA (Position.Index); + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; - if E = null then - raise Constraint_Error with "element at Position is empty"; + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin + -- The following will raise Constraint_Error if Element is null + return R : constant Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Position.Container)) + (Element => Container.Elements.EA (Position.Index), + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -3281,30 +2717,22 @@ package body Ada.Containers.Indefinite_Vectors is (Container : aliased in out Vector; Index : Index_Type) return Reference_Type is - E : Element_Access; - begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - E := Container.Elements.EA (Index); - - if E = null then - raise Constraint_Error with "element at Index is empty"; - end if; - declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin + -- The following will raise Constraint_Error if Element is null + return R : constant Reference_Type := - (Element => E.all'Access, - Control => (Controlled with Container'Unrestricted_Access)) + (Element => Container.Elements.EA (Index), + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -3319,14 +2747,11 @@ package body Ada.Containers.Indefinite_Vectors is New_Item : Element_Type) is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; + TE_Check (Container.TC); declare X : Element_Access := Container.Elements.EA (Index); @@ -3349,22 +2774,21 @@ package body Ada.Containers.Indefinite_Vectors is New_Item : Element_Type) is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; - if Position.Index > Container.Last then - raise Constraint_Error with "Position cursor is out of range"; + if Position.Index > Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; + TE_Check (Container.TC); declare X : Element_Access := Container.Elements.EA (Position.Index); @@ -3442,10 +2866,7 @@ package body Ada.Containers.Indefinite_Vectors is -- so this is the best we can do with respect to minimizing -- storage). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare subtype Array_Index_Subtype is Index_Type'Base range @@ -3485,7 +2906,7 @@ package body Ada.Containers.Indefinite_Vectors is -- the Last index value of the new internal array, in a way that avoids -- any possibility of overflow. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then -- We perform a two-part test. First we determine whether the -- computed Last value lies in the base range of the type, and then @@ -3498,7 +2919,9 @@ package body Ada.Containers.Indefinite_Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index + then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3510,7 +2933,7 @@ package body Ada.Containers.Indefinite_Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3522,7 +2945,7 @@ package body Ada.Containers.Indefinite_Vectors is Index := Count_Type'Base (No_Index) + Capacity; -- Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3539,7 +2962,7 @@ package body Ada.Containers.Indefinite_Vectors is Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3578,10 +3001,7 @@ package body Ada.Containers.Indefinite_Vectors is -- internal array having a length that exactly matches the number -- of items in the container. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare subtype Array_Index_Subtype is Index_Type'Base range @@ -3634,10 +3054,7 @@ package body Ada.Containers.Indefinite_Vectors is -- number of active elements in the container.) We must check whether -- the container is busy before doing anything else. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- We now allocate a new internal array, having a length different from -- its current value. @@ -3689,10 +3106,7 @@ package body Ada.Containers.Indefinite_Vectors is -- implementation. Logically Reverse_Elements requires a check for -- cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare I : Index_Type; @@ -3729,55 +3143,32 @@ package body Ada.Containers.Indefinite_Vectors is Last : Index_Type'Base; begin - if Position.Container /= null + if Checks and then Position.Container /= null and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Container = null or else Position.Index > Container.Last then - Last := Container.Last; - else - Last := Position.Index; - end if; + Last := + (if Position.Container = null or else Position.Index > Container.Last + then Container.Last + else Position.Index); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) /= null and then Container.Elements.EA (Indx).all = Item then - Result := Indx; - exit; + return Cursor'(Container'Unrestricted_Access, Indx); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return No_Element; end; end Reverse_Find; @@ -3790,41 +3181,24 @@ package body Ada.Containers.Indefinite_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Last : constant Index_Type'Base := - (if Index > Container.Last then Container.Last else Index); - - Result : Index_Type'Base; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; + Lock : With_Lock (Container.TC'Unrestricted_Access); + + Last : constant Index_Type'Base := + Index_Type'Min (Container.Last, Index); - Result := No_Index; + begin for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) /= null and then Container.Elements.EA (Indx).all = Item then - Result := Indx; - exit; + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - raise; + return No_Index; end Reverse_Find_Index; --------------------- @@ -3835,33 +3209,18 @@ package body Ada.Containers.Indefinite_Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Reverse_Iterate; ---------------- -- Set_Length -- ---------------- - procedure Set_Length - (Container : in out Vector; - Length : Count_Type) - is + procedure Set_Length (Container : in out Vector; Length : Count_Type) is Count : constant Count_Type'Base := Container.Length - Length; begin @@ -3875,7 +3234,7 @@ package body Ada.Containers.Indefinite_Vectors is if Count >= 0 then Container.Delete_Last (Count); - elsif Container.Last >= Index_Type'Last then + elsif Checks and then Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else @@ -3887,27 +3246,23 @@ package body Ada.Containers.Indefinite_Vectors is -- Swap -- ---------- - procedure Swap - (Container : in out Vector; - I, J : Index_Type) - is + procedure Swap (Container : in out Vector; I, J : Index_Type) is begin - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; + if Checks then + if I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; end if; if I = J then return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; + TE_Check (Container.TC); declare EI : Element_Access renames Container.Elements.EA (I); @@ -3926,20 +3281,22 @@ package body Ada.Containers.Indefinite_Vectors is I, J : Cursor) is begin - if I.Container = null then - raise Constraint_Error with "I cursor has no element"; - end if; + if Checks then + if I.Container = null then + raise Constraint_Error with "I cursor has no element"; + end if; - if J.Container = null then - raise Constraint_Error with "J cursor has no element"; - end if; + if J.Container = null then + raise Constraint_Error with "J cursor has no element"; + end if; - if I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor denotes wrong container"; - end if; + if I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor denotes wrong container"; + end if; - if J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor denotes wrong container"; + if J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor denotes wrong container"; + end if; end if; Swap (Container, I.Index, J.Index); @@ -3997,7 +3354,7 @@ package body Ada.Containers.Indefinite_Vectors is -- index). We must therefore check whether the specified Length would -- create a Last index value greater than Index_Type'Last. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then -- We perform a two-part test. First we determine whether the -- computed Last value lies in the base range of the type, and then @@ -4010,7 +3367,9 @@ package body Ada.Containers.Indefinite_Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -4022,7 +3381,7 @@ package body Ada.Containers.Indefinite_Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -4034,7 +3393,7 @@ package body Ada.Containers.Indefinite_Vectors is Index := Count_Type'Base (No_Index) + Length; -- Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -4051,7 +3410,7 @@ package body Ada.Containers.Indefinite_Vectors is Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -4064,7 +3423,7 @@ package body Ada.Containers.Indefinite_Vectors is Elements := new Elements_Type (Last); - return Vector'(Controlled with Elements, Last, 0, 0); + return Vector'(Controlled with Elements, Last, TC => <>); end To_Vector; function To_Vector @@ -4087,7 +3446,7 @@ package body Ada.Containers.Indefinite_Vectors is -- index). We must therefore check whether the specified Length would -- create a Last index value greater than Index_Type'Last. - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + if Index_Type'Base'Last >= Count_Type_Last then -- We perform a two-part test. First we determine whether the -- computed Last value lies in the base range of the type, and then @@ -4100,7 +3459,9 @@ package body Ada.Containers.Indefinite_Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -4112,7 +3473,7 @@ package body Ada.Containers.Indefinite_Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -4124,7 +3485,7 @@ package body Ada.Containers.Indefinite_Vectors is Index := Count_Type'Base (No_Index) + Length; -- Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -4141,7 +3502,7 @@ package body Ada.Containers.Indefinite_Vectors is Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -4191,7 +3552,7 @@ package body Ada.Containers.Indefinite_Vectors is raise; end; - return (Controlled with Elements, Last, 0, 0); + return (Controlled with Elements, Last, TC => <>); end To_Vector; -------------------- @@ -4203,32 +3564,17 @@ package body Ada.Containers.Indefinite_Vectors is Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)) is - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - if Container.Elements.EA (Index) = null then + if Checks and then Container.Elements.EA (Index) = null then raise Constraint_Error with "element is null"; end if; - B := B + 1; - L := L + 1; - - begin - Process (Container.Elements.EA (Index).all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Container.Elements.EA (Index).all); end Update_Element; procedure Update_Element @@ -4237,15 +3583,15 @@ package body Ada.Containers.Indefinite_Vectors is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - - else - Update_Element (Container, Position.Index, Process); + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; end if; + + Update_Element (Container, Position.Index, Process); end Update_Element; ----------- diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index d2f7252e560..8be2121dee1 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -43,6 +44,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Vectors is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -343,6 +345,7 @@ package Ada.Containers.Indefinite_Vectors is private + pragma Inline (Append); pragma Inline (First_Index); pragma Inline (Last_Index); pragma Inline (Element); @@ -351,35 +354,38 @@ private pragma Inline (Query_Element); pragma Inline (Update_Element); pragma Inline (Replace_Element); + pragma Inline (Is_Empty); pragma Inline (Contains); pragma Inline (Next); pragma Inline (Previous); + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + type Element_Access is access Element_Type; type Elements_Array is array (Index_Type range <>) of Element_Access; function "=" (L, R : Elements_Array) return Boolean is abstract; - type Elements_Type (Last : Index_Type) is limited record + type Elements_Type (Last : Extended_Index) is limited record EA : Elements_Array (Index_Type'First .. Last); end record; - type Elements_Access is access Elements_Type; + type Elements_Access is access all Elements_Type; + + use Finalization; + use Streams; - type Vector is new Ada.Finalization.Controlled with record - Elements : Elements_Access; + type Vector is new Controlled with record + Elements : Elements_Access := null; Last : Extended_Index := No_Index; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; end record; overriding procedure Adjust (Container : in out Vector); - overriding procedure Finalize (Container : in out Vector); - use Ada.Finalization; - use Ada.Streams; - procedure Write (Stream : not null access Root_Stream_Type'Class; Container : Vector); @@ -412,16 +418,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is - new Controlled with record - Container : Vector_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -467,16 +465,33 @@ private for Reference_Type'Read use Read; - Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0); + -- 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. + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. No_Element : constant Cursor := Cursor'(null, Index_Type'First); + Empty_Vector : constant Vector := (Controlled with others => <>); + type Iterator is new Limited_Controlled and Vector_Iterator_Interfaces.Reversible_Iterator with record Container : Vector_Access; Index : Index_Type'Base; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb index 14d879e00ab..68d49aa4abd 100644 --- a/gcc/ada/a-comutr.adb +++ b/gcc/ada/a-comutr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,7 +34,9 @@ with System; use type System.Address; package body Ada.Containers.Multiway_Trees is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers -------------------- -- Root_Iterator -- @@ -166,10 +168,6 @@ package body Ada.Containers.Multiway_Trees is function "=" (Left, Right : Tree) return Boolean is begin - if Left'Address = Right'Address then - return True; - end if; - return Equal_Children (Root_Node (Left), Root_Node (Right)); end "="; @@ -188,8 +186,7 @@ package body Ada.Containers.Multiway_Trees is -- are preserved in the event that the allocation fails. Container.Root.Children := Children_Type'(others => null); - Container.Busy := 0; - Container.Lock := 0; + Zero_Counts (Container.TC); Container.Count := 0; -- Copy_Children returns a count of the number of nodes that it @@ -208,20 +205,6 @@ package body Ada.Containers.Multiway_Trees is Container.Count := Source_Count; end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Tree renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------------- -- Ancestor_Find -- ------------------- @@ -233,7 +216,7 @@ package body Ada.Containers.Multiway_Trees is R, N : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; @@ -247,7 +230,7 @@ package body Ada.Containers.Multiway_Trees is -- not seem correct, as this value is just the limiting condition of the -- search. For now we omit this check, pending a ruling from the ARG.??? - -- if Is_Root (Position) then + -- if Checks and then Is_Root (Position) then -- raise Program_Error with "Position cursor designates root"; -- end if; @@ -278,11 +261,11 @@ package body Ada.Containers.Multiway_Trees is Last : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -290,10 +273,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); First := new Tree_Node_Type'(Parent => Parent.Node, Element => New_Item, @@ -390,15 +370,15 @@ package body Ada.Containers.Multiway_Trees is N : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Child = No_Element then + if Checks and then Child = No_Element then raise Constraint_Error with "Child cursor has no element"; end if; - if Parent.Container /= Child.Container then + if Checks and then Parent.Container /= Child.Container then raise Program_Error with "Parent and Child in different containers"; end if; @@ -408,7 +388,7 @@ package body Ada.Containers.Multiway_Trees is Result := Result + 1; N := N.Parent; - if N = null then + if Checks and then N = null then raise Program_Error with "Parent is not ancestor of Child"; end if; end loop; @@ -424,10 +404,7 @@ package body Ada.Containers.Multiway_Trees is Container_Count, Children_Count : Count_Type; begin - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); -- We first set the container count to 0, in order to preserve -- invariants in case the deallocation fails. (This works because @@ -462,17 +439,18 @@ package body Ada.Containers.Multiway_Trees is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; @@ -482,15 +460,14 @@ package body Ada.Containers.Multiway_Trees is declare C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + C.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -594,20 +571,20 @@ package body Ada.Containers.Multiway_Trees is Target_Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; @@ -616,7 +593,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Is_Root (Source) then + if Checks and then Is_Root (Source) then raise Constraint_Error with "Source cursor designates root"; end if; @@ -720,18 +697,15 @@ package body Ada.Containers.Multiway_Trees is Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); -- Deallocate_Children returns a count of the number of nodes that it -- deallocates, but it works by incrementing the value that is passed @@ -757,26 +731,24 @@ package body Ada.Containers.Multiway_Trees is X : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if not Is_Leaf (Position) then + if Checks and then not Is_Leaf (Position) then raise Constraint_Error with "Position cursor does not designate leaf"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -806,22 +778,20 @@ package body Ada.Containers.Multiway_Trees is Count : Count_Type; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); X := Position.Node; Position := No_Element; @@ -884,11 +854,12 @@ package body Ada.Containers.Multiway_Trees is function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Node = Root_Node (Position.Container.all) then + if Checks and then Position.Node = Root_Node (Position.Container.all) + then raise Program_Error with "Position cursor designates root"; end if; @@ -936,11 +907,11 @@ package body Ada.Containers.Multiway_Trees is Right_Position : Cursor) return Boolean is begin - if Left_Position = No_Element then + if Checks and then Left_Position = No_Element then raise Constraint_Error with "Left cursor has no element"; end if; - if Right_Position = No_Element then + if Checks and then Right_Position = No_Element then raise Constraint_Error with "Right cursor has no element"; end if; @@ -980,25 +951,8 @@ package body Ada.Containers.Multiway_Trees is -------------- procedure Finalize (Object : in out Root_Iterator) is - B : Natural renames Object.Container.Busy; begin - B := B - 1; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Tree renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; - end if; + Unbusy (Object.Container.TC); end Finalize; ---------- @@ -1045,7 +999,7 @@ package body Ada.Containers.Multiway_Trees is Node : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1103,13 +1057,15 @@ package body Ada.Containers.Multiway_Trees is Result : Tree_Node_Access; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Commented out pending official ruling by ARG. ??? - -- if Position.Container /= Container'Unrestricted_Access then + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then -- raise Program_Error with "Position cursor not in container"; -- end if; @@ -1137,6 +1093,16 @@ package body Ada.Containers.Multiway_Trees is return Find_In_Children (Subtree, Item); end Find_In_Subtree; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1177,20 +1143,21 @@ package body Ada.Containers.Multiway_Trees is Last : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Parent cursor not parent of Before"; end if; end if; @@ -1200,10 +1167,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); First := new Tree_Node_Type'(Parent => Parent.Node, Element => New_Item, @@ -1248,20 +1212,21 @@ package body Ada.Containers.Multiway_Trees is Last : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Parent cursor not parent of Before"; end if; end if; @@ -1271,10 +1236,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); First := new Tree_Node_Type'(Parent => Parent.Node, Element => <>, @@ -1441,22 +1403,12 @@ package body Ada.Containers.Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - Iterate_Children (Container => Container'Unrestricted_Access, Subtree => Root_Node (Container), Process => Process); - - B := B - 1; - - exception - when others => - B := B - 1; - raise; end Iterate; function Iterate (Container : Tree) @@ -1474,31 +1426,18 @@ package body Ada.Containers.Multiway_Trees is (Parent : Cursor; Process : not null access procedure (Position : Cursor)) is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - declare - B : Natural renames Parent.Container.Busy; - C : Tree_Node_Access; - - begin - B := B + 1; - - C := Parent.Node.Children.First; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Next; - end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + C := Parent.Node.Children.First; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Next; + end loop; end Iterate_Children; procedure Iterate_Children @@ -1528,14 +1467,12 @@ package body Ada.Containers.Multiway_Trees is return Tree_Iterator_Interfaces.Reversible_Iterator'Class is C : constant Tree_Access := Container'Unrestricted_Access; - B : Natural renames C.Busy; - begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= C then + if Checks and then Parent.Container /= C then raise Program_Error with "Parent cursor not in container"; end if; @@ -1544,7 +1481,7 @@ package body Ada.Containers.Multiway_Trees is Container => C, Subtree => Parent.Node) do - B := B + 1; + Busy (C.TC); end return; end Iterate_Children; @@ -1556,55 +1493,39 @@ package body Ada.Containers.Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + C : constant Tree_Access := Position.Container; begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; -- Implement Vet for multiway trees??? -- pragma Assert (Vet (Position), "bad subtree cursor"); - declare - B : Natural renames Position.Container.Busy; - begin - return It : constant Subtree_Iterator := - (Limited_Controlled with - Container => Position.Container, - Subtree => Position.Node) - do - B := B + 1; - end return; - end; + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => C, + Subtree => Position.Node) + do + Busy (C.TC); + end return; end Iterate_Subtree; procedure Iterate_Subtree (Position : Cursor; Process : not null access procedure (Position : Cursor)) is + Busy : With_Busy (Position.Container.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - declare - B : Natural renames Position.Container.Busy; - - begin - B := B + 1; - - if Is_Root (Position) then - Iterate_Children (Position.Container, Position.Node, Process); - else - Iterate_Subtree (Position.Container, Position.Node, Process); - end if; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + if Is_Root (Position) then + Iterate_Children (Position.Container, Position.Node, Process); + else + Iterate_Subtree (Position.Container, Position.Node, Process); + end if; end Iterate_Subtree; procedure Iterate_Subtree @@ -1638,7 +1559,7 @@ package body Ada.Containers.Multiway_Trees is Node : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; @@ -1672,10 +1593,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors of Source (tree is busy)"; - end if; + TC_Check (Source.TC); Target.Clear; -- checks busy bit @@ -1707,7 +1625,7 @@ package body Ada.Containers.Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -1738,7 +1656,7 @@ package body Ada.Containers.Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong tree"; end if; @@ -1817,11 +1735,11 @@ package body Ada.Containers.Multiway_Trees is First, Last : Tree_Node_Access; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; @@ -1829,10 +1747,7 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); First := new Tree_Node_Type'(Parent => Parent.Node, Element => New_Item, @@ -1878,7 +1793,7 @@ package body Ada.Containers.Multiway_Trees is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong tree"; end if; @@ -1903,6 +1818,20 @@ package body Ada.Containers.Multiway_Trees is Position := Previous_Sibling (Position); end Previous_Sibling; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- @@ -1911,36 +1840,18 @@ package body Ada.Containers.Multiway_Trees is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - declare - T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - - begin - B := B + 1; - L := L + 1; - - Process (Position.Node.Element); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; - end; + Process (Position.Node.Element); end Query_Element; ---------- @@ -1979,7 +1890,7 @@ package body Ada.Containers.Multiway_Trees is begin Count_Type'Read (Stream, Count); - if Count < 0 then + if Checks and then Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2030,7 +1941,7 @@ package body Ada.Containers.Multiway_Trees is Count_Type'Read (Stream, Total_Count); - if Total_Count < 0 then + if Checks and then Total_Count < 0 then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2042,7 +1953,7 @@ package body Ada.Containers.Multiway_Trees is Read_Children (Root_Node (Container)); - if Read_Count /= Total_Count then + if Checks and then Read_Count /= Total_Count then raise Program_Error with "attempt to read from corrupt stream"; end if; @@ -2082,17 +1993,18 @@ package body Ada.Containers.Multiway_Trees is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; - if Position.Node = Root_Node (Container) then + if Checks and then Position.Node = Root_Node (Container) then raise Program_Error with "Position cursor designates root"; end if; @@ -2102,15 +2014,14 @@ package body Ada.Containers.Multiway_Trees is declare C : Tree renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + C.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -2160,22 +2071,20 @@ package body Ada.Containers.Multiway_Trees is New_Item : Element_Type) is begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); Position.Node.Element := New_Item; end Replace_Element; @@ -2188,31 +2097,18 @@ package body Ada.Containers.Multiway_Trees is (Parent : Cursor; Process : not null access procedure (Position : Cursor)) is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - declare - B : Natural renames Parent.Container.Busy; - C : Tree_Node_Access; - - begin - B := B + 1; - - C := Parent.Node.Children.Last; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Prev; - end loop; - - B := B - 1; - - exception - when others => - B := B - 1; - raise; - end; + C := Parent.Node.Children.Last; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Prev; + end loop; end Reverse_Iterate_Children; ---------- @@ -2262,32 +2158,34 @@ package body Ada.Containers.Multiway_Trees is Count : Count_Type; begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Target'Unrestricted_Access then + if Checks and then Target_Parent.Container /= Target'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Before.Node.Parent /= Target_Parent.Node then + if Checks and then Before.Node.Parent /= Target_Parent.Node then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Source'Unrestricted_Access then + if Checks and then Source_Parent.Container /= Source'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in Source container"; end if; @@ -2297,12 +2195,9 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (From => Target_Parent.Node, + if Checks and then Is_Reachable (From => Target_Parent.Node, To => Source_Parent.Node) then raise Constraint_Error @@ -2317,15 +2212,8 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- We cache the count of the nodes we have allocated, so that operation -- Node_Count can execute in O(1) time. But that means we must count the @@ -2353,32 +2241,37 @@ package body Ada.Containers.Multiway_Trees is Source_Parent : Cursor) is begin - if Target_Parent = No_Element then + if Checks and then Target_Parent = No_Element then raise Constraint_Error with "Target_Parent cursor has no element"; end if; - if Target_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Target_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Target_Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Target_Parent.Node then + if Checks and then Before.Node.Parent /= Target_Parent.Node then raise Constraint_Error with "Before cursor not child of Target_Parent"; end if; end if; - if Source_Parent = No_Element then + if Checks and then Source_Parent = No_Element then raise Constraint_Error with "Source_Parent cursor has no element"; end if; - if Source_Parent.Container /= Container'Unrestricted_Access then + if Checks and then + Source_Parent.Container /= Container'Unrestricted_Access + then raise Program_Error with "Source_Parent cursor not in container"; end if; @@ -2387,12 +2280,9 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (From => Target_Parent.Node, + if Checks and then Is_Reachable (From => Target_Parent.Node, To => Source_Parent.Node) then raise Constraint_Error @@ -2449,33 +2339,33 @@ package body Ada.Containers.Multiway_Trees is Subtree_Count : Count_Type; begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Target'Unrestricted_Access then + if Checks and then Parent.Container /= Target'Unrestricted_Access then raise Program_Error with "Parent cursor not in Target container"; end if; if Before /= No_Element then - if Before.Container /= Target'Unrestricted_Access then + if Checks and then Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor not in Target container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Source'Unrestricted_Access then + if Checks and then Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor not in Source container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; @@ -2490,12 +2380,11 @@ package body Ada.Containers.Multiway_Trees is end if; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; + TC_Check (Target.TC); - if Is_Reachable (From => Parent.Node, To => Position.Node) then + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then raise Constraint_Error with "Position is ancestor of Parent"; end if; @@ -2507,15 +2396,8 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if Target.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Target tree is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (Source tree is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); -- This is an unfortunate feature of this API: we must count the nodes -- in the subtree that we remove from the source tree, which is an O(n) @@ -2549,33 +2431,35 @@ package body Ada.Containers.Multiway_Trees is Position : Cursor) is begin - if Parent = No_Element then + if Checks and then Parent = No_Element then raise Constraint_Error with "Parent cursor has no element"; end if; - if Parent.Container /= Container'Unrestricted_Access then + if Checks and then Parent.Container /= Container'Unrestricted_Access then raise Program_Error with "Parent cursor not in container"; end if; if Before /= No_Element then - if Before.Container /= Container'Unrestricted_Access then + if Checks and then Before.Container /= Container'Unrestricted_Access + then raise Program_Error with "Before cursor not in container"; end if; - if Before.Node.Parent /= Parent.Node then + if Checks and then Before.Node.Parent /= Parent.Node then raise Constraint_Error with "Before cursor not child of Parent"; end if; end if; - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then -- Should this be PE instead? Need ARG confirmation. ??? @@ -2592,12 +2476,11 @@ package body Ada.Containers.Multiway_Trees is end if; end if; - if Container.Busy > 0 then - raise Program_Error - with "attempt to tamper with cursors (tree is busy)"; - end if; + TC_Check (Container.TC); - if Is_Reachable (From => Parent.Node, To => Position.Node) then + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then raise Constraint_Error with "Position is ancestor of Parent"; end if; @@ -2646,15 +2529,15 @@ package body Ada.Containers.Multiway_Trees is I, J : Cursor) is begin - if I = No_Element then + if Checks and then I = No_Element then raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access then + if Checks and then I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor not in container"; end if; - if Is_Root (I) then + if Checks and then Is_Root (I) then raise Program_Error with "I cursor designates root"; end if; @@ -2662,22 +2545,19 @@ package body Ada.Containers.Multiway_Trees is return; end if; - if J = No_Element then + if Checks and then J = No_Element then raise Constraint_Error with "J cursor has no element"; end if; - if J.Container /= Container'Unrestricted_Access then + if Checks and then J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor not in container"; end if; - if Is_Root (J) then + if Checks and then Is_Root (J) then raise Program_Error with "J cursor designates root"; end if; - if Container.Lock > 0 then - raise Program_Error - with "attempt to tamper with elements (tree is locked)"; - end if; + TE_Check (Container.TC); declare EI : constant Element_Type := I.Node.Element; @@ -2697,40 +2577,23 @@ package body Ada.Containers.Multiway_Trees is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); begin - if Position = No_Element then + if Checks and then Position = No_Element then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor not in container"; end if; - if Is_Root (Position) then + if Checks and then Is_Root (Position) then raise Program_Error with "Position cursor designates root"; end if; - declare - T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - - begin - B := B + 1; - L := L + 1; - - Process (Position.Node.Element); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; - end; + Process (Position.Node.Element); end Update_Element; ----------- diff --git a/gcc/ada/a-comutr.ads b/gcc/ada/a-comutr.ads index 3ea29452929..ef556969883 100644 --- a/gcc/ada/a-comutr.ads +++ b/gcc/ada/a-comutr.ads @@ -32,6 +32,8 @@ ------------------------------------------------------------------------------ with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -41,6 +43,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Multiway_Trees is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -333,9 +336,16 @@ private -- thus guaranteeing that (unchecked) conversions between access types -- designating each kind of node type is a meaningful conversion. + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + type Tree_Node_Type; type Tree_Node_Access is access all Tree_Node_Type; pragma Convention (C, Tree_Node_Access); + pragma No_Strict_Aliasing (Tree_Node_Access); + -- The above-mentioned Unchecked_Conversion is a violation of the normal + -- aliasing rules. type Children_Type is record First : Tree_Node_Access; @@ -386,8 +396,7 @@ private type Tree is new Controlled with record Root : aliased Root_Node_Type; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; Count : Count_Type := 0; end record; @@ -429,16 +438,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Tree_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -484,6 +485,25 @@ 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. + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Tree : constant Tree := (Controlled with others => <>); No_Element : constant Cursor := (others => <>); diff --git a/gcc/ada/a-conhel.adb b/gcc/ada/a-conhel.adb new file mode 100644 index 00000000000..f433250000a --- /dev/null +++ b/gcc/ada/a-conhel.adb @@ -0,0 +1,193 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H E L P E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2015, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Helpers is + + package body Generic_Implementation is + + use type SAC.Atomic_Unsigned; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + pragma Warnings (Off); + -- GNAT warns here if checks are turned off, but assertions on + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); + begin + if Control.T_Counts /= null then + Lock (Control.T_Counts.all); + end if; + end Adjust; + + ---------- + -- Busy -- + ---------- + + procedure Busy (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + SAC.Increment (T_Counts.Busy); + end if; + end Busy; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + pragma Warnings (Off); + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); + begin + if Control.T_Counts /= null then + Unlock (Control.T_Counts.all); + Control.T_Counts := null; + end if; + end Finalize; + + -- No need to protect against double Finalize here, because these types + -- are limited. + + procedure Finalize (Busy : in out With_Busy) is + pragma Warnings (Off); + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); + begin + Unbusy (Busy.T_Counts.all); + end Finalize; + + procedure Finalize (Lock : in out With_Lock) is + pragma Warnings (Off); + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); + begin + Unlock (Lock.T_Counts.all); + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Busy : in out With_Busy) is + pragma Warnings (Off); + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); + begin + Generic_Implementation.Busy (Busy.T_Counts.all); + end Initialize; + + procedure Initialize (Lock : in out With_Lock) is + pragma Warnings (Off); + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); + begin + Generic_Implementation.Lock (Lock.T_Counts.all); + end Initialize; + + ---------- + -- Lock -- + ---------- + + procedure Lock (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + SAC.Increment (T_Counts.Lock); + SAC.Increment (T_Counts.Busy); + end if; + end Lock; + + -------------- + -- TC_Check -- + -------------- + + procedure TC_Check (T_Counts : Tamper_Counts) is + begin + if T_Check and then T_Counts.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors"; + end if; + + -- The lock status (which monitors "element tampering") always + -- implies that the busy status (which monitors "cursor tampering") + -- is set too; this is a representation invariant. Thus if the busy + -- bit is not set, then the lock bit must not be set either. + + pragma Assert (T_Counts.Lock = 0); + end TC_Check; + + -------------- + -- TE_Check -- + -------------- + + procedure TE_Check (T_Counts : Tamper_Counts) is + begin + if T_Check and then T_Counts.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements"; + end if; + end TE_Check; + + ------------ + -- Unbusy -- + ------------ + + procedure Unbusy (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + SAC.Decrement (T_Counts.Busy); + end if; + end Unbusy; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + SAC.Decrement (T_Counts.Lock); + SAC.Decrement (T_Counts.Busy); + end if; + end Unlock; + + ----------------- + -- Zero_Counts -- + ----------------- + + procedure Zero_Counts (T_Counts : out Tamper_Counts) is + begin + if T_Check then + T_Counts := (others => <>); + end if; + end Zero_Counts; + + end Generic_Implementation; + +end Ada.Containers.Helpers; diff --git a/gcc/ada/a-conhel.ads b/gcc/ada/a-conhel.ads new file mode 100644 index 00000000000..74e51518fb0 --- /dev/null +++ b/gcc/ada/a-conhel.ads @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H E L P E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2015, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +------------------------------------------------------------------------------ + +with Ada.Finalization; +with System.Atomic_Counters; + +package Ada.Containers.Helpers is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + + -- Miscellaneous helpers shared among various containers + + package SAC renames System.Atomic_Counters; + + Count_Type_Last : constant := Count_Type'Last; + -- Count_Type'Last as a universal_integer, so we can compare Index_Type + -- values against this without type conversions that might overflow. + + type Tamper_Counts is record + Busy : aliased SAC.Atomic_Unsigned := 0; + Lock : aliased SAC.Atomic_Unsigned := 0; + end record; + + -- Busy is positive when tampering with cursors is prohibited. Busy and + -- Lock are both positive when tampering with elements is prohibited. + + type Tamper_Counts_Access is access all Tamper_Counts; + for Tamper_Counts_Access'Storage_Size use 0; + + generic + package Generic_Implementation is + + -- Generic package used in the implementation of containers. + -- ???????????????????Currently used by Vectors; not yet by all other + -- containers. + + -- This needs to be generic so that the 'Enabled attribute will return + -- the value that is relevant at the point where a container generic is + -- instantiated. For example: + -- + -- pragma Suppress (Container_Checks); + -- package My_Vectors is new Ada.Containers.Vectors (...); + -- + -- should suppress all container-related checks within the instance + -- My_Vectors. + + -- Shorthands for "checks enabled" and "tampering checks enabled". Note + -- that suppressing either Container_Checks or Tampering_Check disables + -- tampering checks. Note that this code needs to be in a generic + -- package, because we want to take account of check suppressions at the + -- instance. We use these flags, along with pragma Inline, to ensure + -- that the compiler can optimize away the checks, as well as the + -- tampering check machinery, when checks are suppressed. + + Checks : constant Boolean := Container_Checks'Enabled; + T_Check : constant Boolean := + Container_Checks'Enabled and Tampering_Check'Enabled; + + -- Reference_Control_Type is used as a component of reference types, to + -- prohibit tampering with elements so long as references exist. + + type Reference_Control_Type is + new Finalization.Controlled with record + T_Counts : Tamper_Counts_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + procedure Zero_Counts (T_Counts : out Tamper_Counts); + pragma Inline (Zero_Counts); + -- Set Busy and Lock to zero + + procedure Busy (T_Counts : in out Tamper_Counts); + pragma Inline (Busy); + -- Prohibit tampering with cursors + + procedure Unbusy (T_Counts : in out Tamper_Counts); + pragma Inline (Unbusy); + -- Allow tampering with cursors + + procedure Lock (T_Counts : in out Tamper_Counts); + pragma Inline (Lock); + -- Prohibit tampering with elements + + procedure Unlock (T_Counts : in out Tamper_Counts); + pragma Inline (Unlock); + -- Allow tampering with elements + + procedure TC_Check (T_Counts : Tamper_Counts); + pragma Inline (TC_Check); + -- Tampering-with-cursors check + + procedure TE_Check (T_Counts : Tamper_Counts); + pragma Inline (TE_Check); + -- Tampering-with-elements check + + ----------------- + -- RAII Types -- + ----------------- + + -- Initialize of With_Busy increments the Busy count, and Finalize + -- decrements it. Thus, to prohibit tampering with elements within a + -- given scope, declare an object of type With_Busy. The Busy count + -- will be correctly decremented in case of exception or abort. + + -- With_Lock is the same as With_Busy, except it increments/decrements + -- BOTH Busy and Lock, thus prohibiting tampering with cursors. + + type With_Busy (T_Counts : not null access Tamper_Counts) is + new Finalization.Limited_Controlled with null record + with Disable_Controlled => not T_Check; + overriding procedure Initialize (Busy : in out With_Busy); + overriding procedure Finalize (Busy : in out With_Busy); + + type With_Lock (T_Counts : not null access Tamper_Counts) is + new Finalization.Limited_Controlled with null record + with Disable_Controlled => not T_Check; + overriding procedure Initialize (Lock : in out With_Lock); + overriding procedure Finalize (Lock : in out With_Lock); + + -- Variables of type With_Busy and With_Lock are declared only for the + -- effects of Initialize and Finalize, so they are not referenced; + -- disable warnings about that. Note that all variables of these types + -- have names starting with "Busy" or "Lock". These pragmas need to be + -- present wherever these types are used. + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + + end Generic_Implementation; + +end Ada.Containers.Helpers; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index bf7c08b23ba..380a10b6a12 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -34,31 +34,13 @@ with System; use type System.Address; package body Ada.Containers.Vectors is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); - type Iterator is new Limited_Controlled and - Vector_Iterator_Interfaces.Reversible_Iterator with - record - Container : Vector_Access; - Index : Index_Type'Base; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - procedure Append_Slow_Path (Container : in out Vector; New_Item : Element_Type; @@ -70,273 +52,45 @@ package body Ada.Containers.Vectors is -- "&" -- --------- - function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); - N : Count_Type'Base; -- length of result - J : Count_Type'Base; -- for computing intermediate index values - Last : Index_Type'Base; -- Last index of result + -- We decide that the capacity of the result of "&" is the minimum needed + -- -- the sum of the lengths of the vector parameters. We could decide to + -- make it larger, but we have no basis for knowing how much larger, so we + -- just allocate the minimum amount of storage. + function "&" (Left, Right : Vector) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the vector parameters. We could decide to make it larger, but we - -- have no basis for knowing how much larger, so we just allocate the - -- minimum amount of storage. - - -- Here we handle the easy cases first, when one of the vector - -- parameters is empty. (We say "easy" because there's nothing to - -- compute, that can potentially overflow.) - - if LN = 0 then - if RN = 0 then - return Empty_Vector; - end if; - - declare - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - Elements : constant Elements_Access := - new Elements_Type'(Right.Last, RE); - begin - return (Controlled with Elements, Right.Last, others => <>); - end; - end if; - - if RN = 0 then - declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - Elements : constant Elements_Access := - new Elements_Type'(Left.Last, LE); - begin - return (Controlled with Elements, Left.Last, others => <>); - end; - - end if; - - -- Neither of the vector parameters is empty, so must compute the length - -- of the result vector and its last index. (This is the harder case, - -- because our computations must avoid overflow.) - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the combined lengths. Note that we cannot - -- simply add the lengths, because of the possibility of overflow. - - if LN > Count_Type'Last - RN then - raise Constraint_Error with "new length is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - N := LN + RN; - - -- The second constraint is that the new Last index value cannot - -- exceed Index_Type'Last. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. - - if Index_Type'Base'Last >= Count_Type_Last then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (N); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Last > Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of length. - - J := Count_Type'Base (No_Index) + N; -- Last - - if J > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (J); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - - if J < Count_Type'Base (No_Index) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We have determined that the result length would not create a Last - -- index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + N); - end if; - - declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - Elements : constant Elements_Access := - new Elements_Type'(Last, LE & RE); - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- Handle easy case first, when the vector parameter (Left) is empty - - if Left.Is_Empty then - declare - Elements : constant Elements_Access := - new Elements_Type' - (Last => Index_Type'First, - EA => (others => Right)); - - begin - return (Controlled with Elements, Index_Type'First, others => <>); - end; - end if; - - -- The vector parameter is not empty, so we must compute the length of - -- the result vector and its last index, but in such a way that overflow - -- is avoided. We must satisfy two constraints: the new length cannot - -- exceed Count_Type'Last, and the new Last index cannot exceed - -- Index_Type'Last. - - if Left.Length = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Left.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Left.Last + 1; - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - Elements : constant Elements_Access := - new Elements_Type'(Last => Last, EA => LE & Right); - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + 1); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; function "&" (Left : Element_Type; Right : Vector) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- Handle easy case first, when the vector parameter (Right) is empty - - if Right.Is_Empty then - declare - Elements : constant Elements_Access := - new Elements_Type' - (Last => Index_Type'First, - EA => (others => Left)); - begin - return (Controlled with Elements, Index_Type'First, others => <>); - end; - end if; - - -- The vector parameter is not empty, so we must compute the length of - -- the result vector and its last index, but in such a way that overflow - -- is avoided. We must satisfy two constraints: the new length cannot - -- exceed Count_Type'Last, and the new Last index cannot exceed - -- Index_Type'Last. - - if Right.Length = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Right.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Right.Last + 1; - - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - - Elements : constant Elements_Access := - new Elements_Type' - (Last => Last, - EA => Left & RE); - - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, 1 + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; function "&" (Left, Right : Element_Type) return Vector is begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- We must compute the length of the result vector and its last index, - -- but in such a way that overflow is avoided. We must satisfy two - -- constraints: the new length cannot exceed Count_Type'Last (here, we - -- know that that condition is satisfied), and the new Last index cannot - -- exceed Index_Type'Last. - - if Index_Type'First >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - declare - Last : constant Index_Type := Index_Type'First + 1; - - Elements : constant Elements_Access := - new Elements_Type' - (Last => Last, - EA => (Left, Right)); - - begin - return (Controlled with Elements, Last, others => <>); - end; + return Result : Vector do + Reserve_Capacity (Result, 1 + 1); + Append (Result, Left); + Append (Result, Right); + end return; end "&"; --------- @@ -344,57 +98,30 @@ package body Ada.Containers.Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - - Result : Boolean; - begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Last /= Right.Last then return False; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - - Result := True; - for J in Index_Type range Index_Type'First .. Left.Last loop - if Left.Elements.EA (J) /= Right.Elements.EA (J) then - Result := False; - exit; - end if; - end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; + if Left.Length = 0 then + return True; + end if; - exception - when others => - BL := BL - 1; - LL := LL - 1; + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - BR := BR - 1; - LR := LR - 1; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + begin + for J in Index_Type range Index_Type'First .. Left.Last loop + if Left.Elements.EA (J) /= Right.Elements.EA (J) then + return False; + end if; + end loop; + end; - raise; + return True; end "="; ------------ @@ -403,6 +130,12 @@ package body Ada.Containers.Vectors is procedure Adjust (Container : in out Vector) is begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + if Container.Last = No_Index then Container.Elements := null; return; @@ -415,8 +148,6 @@ package body Ada.Containers.Vectors is begin Container.Elements := null; - Container.Busy := 0; - Container.Lock := 0; -- Note: it may seem that the following assignment to Container.Last -- is useless, since we assign it to L below. However this code is @@ -429,20 +160,6 @@ package body Ada.Containers.Vectors is end; end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Append -- ------------ @@ -451,7 +168,7 @@ package body Ada.Containers.Vectors is begin if Is_Empty (New_Item) then return; - elsif Container.Last = Index_Type'Last then + elsif Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else Insert (Container, Container.Last + 1, New_Item); @@ -472,10 +189,7 @@ package body Ada.Containers.Vectors is and then Container.Elements /= null and then Container.Last /= Container.Elements.Last then - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- Increment Container.Last after assigning the New_Item, so we -- leave the Container unmodified in case Finalize/Adjust raises @@ -505,7 +219,7 @@ package body Ada.Containers.Vectors is begin if Count = 0 then return; - elsif Container.Last = Index_Type'Last then + elsif Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else Insert (Container, Container.Last + 1, New_Item, Count); @@ -545,12 +259,8 @@ package body Ada.Containers.Vectors is procedure Clear (Container : in out Vector) is begin - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - else - Container.Last := No_Index; - end if; + TC_Check (Container.TC); + Container.Last := No_Index; end Clear; ------------------------ @@ -562,29 +272,29 @@ package body Ada.Containers.Vectors is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; declare - C : Vector renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -594,23 +304,21 @@ package body Ada.Containers.Vectors is Index : Index_Type) return Constant_Reference_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; - else - declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Constant_Reference_Type := - (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; end if; + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Index)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Constant_Reference; -------------- @@ -636,15 +344,16 @@ package body Ada.Containers.Vectors is C : Count_Type; begin - if Capacity = 0 then - C := Source.Length; - - elsif Capacity >= Source.Length then + if Capacity >= Source.Length then C := Capacity; else - raise Capacity_Error with - "Requested capacity is less than Source length"; + C := Source.Length; + + if Checks and then Capacity /= 0 then + raise Capacity_Error with + "Requested capacity is less than Source length"; + end if; end if; return Target : Vector do @@ -685,7 +394,7 @@ package body Ada.Containers.Vectors is -- in the base range that immediately precede and immediately follow the -- values in the Index_Type.) - if Index < Index_Type'First then + if Checks and then Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; @@ -697,7 +406,7 @@ package body Ada.Containers.Vectors is -- algorithm, so that case is treated as a proper error.) if Index > Old_Last then - if Index > Old_Last + 1 then + if Checks and then Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; else return; @@ -717,10 +426,7 @@ package body Ada.Containers.Vectors is -- the count on exit. Delete checks the count to determine whether it is -- being called while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- We first calculate what's available for deletion starting at -- Index. Here and elsewhere we use the wider of Index_Type'Base and @@ -743,9 +449,9 @@ package body Ada.Containers.Vectors is return; end if; - -- There are some elements aren't being deleted (the requested count was - -- less than the available count), so we must slide them down to - -- Index. We first calculate the index values of the respective array + -- There are some elements that aren't being deleted (the requested + -- count was less than the available count), so we must slide them down + -- to Index. We first calculate the index values of the respective array -- slices, using the wider of Index_Type'Base and Count_Type'Base as the -- type for intermediate calculations. For the elements that slide down, -- index value New_Last is the last index value of their new home, and @@ -778,22 +484,21 @@ package body Ada.Containers.Vectors is Position : in out Cursor; Count : Count_Type := 1) is - pragma Warnings (Off, Position); - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - - elsif Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; - else - Delete (Container, Position.Index, Count); - Position := No_Element; + elsif Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; end if; + + Delete (Container, Position.Index, Count); + Position := No_Element; end Delete; ------------------ @@ -842,10 +547,7 @@ package body Ada.Containers.Vectors is -- it is being called while the associated callback procedure is -- executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- There is no restriction on how large Count can be when deleting -- items. If it is equal or greater than the current length, then this @@ -878,22 +580,24 @@ package body Ada.Containers.Vectors is Index : Index_Type) return Element_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; - else - return Container.Elements.EA (Index); end if; + + return Container.Elements.EA (Index); end Element; function Element (Position : Cursor) return Element_Type is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - elsif Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - else - return Position.Container.Elements.EA (Position.Index); + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + elsif Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; + + return Position.Container.Elements.EA (Position.Index); end Element; -------------- @@ -909,32 +613,15 @@ package body Ada.Containers.Vectors is Free (X); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); end Finalize; procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Busy; + pragma Warnings (Off); + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); begin - B := B - 1; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - C : Vector renames Control.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; - end if; + Unbusy (Object.Container.TC); end Finalize; ---------- @@ -947,7 +634,7 @@ package body Ada.Containers.Vectors is Position : Cursor := No_Element) return Cursor is begin - if Position.Container /= null then + if Checks and then Position.Container /= null then if Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; end if; @@ -961,38 +648,15 @@ package body Ada.Containers.Vectors is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for J in Position.Index .. Container.Last loop if Container.Elements.EA (J) = Item then - Result := J; - exit; + return Cursor'(Container'Unrestricted_Access, J); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Find; @@ -1005,37 +669,18 @@ package body Ada.Containers.Vectors is Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - - begin -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. - B := B + 1; - L := L + 1; - - Result := No_Index; + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin for Indx in Index .. Container.Last loop if Container.Elements.EA (Indx) = Item then - Result := Indx; - exit; + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Index; end Find_Index; ----------- @@ -1046,9 +691,9 @@ package body Ada.Containers.Vectors is begin if Is_Empty (Container) then return No_Element; - else - return (Container'Unrestricted_Access, Index_Type'First); end if; + + return (Container'Unrestricted_Access, Index_Type'First); end First; function First (Object : Iterator) return Cursor is @@ -1080,7 +725,7 @@ package body Ada.Containers.Vectors is function First_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; else return Container.Elements.EA (Index_Type'First); @@ -1117,36 +762,16 @@ package body Ada.Containers.Vectors is -- element tampering by a generic actual subprogram. declare - EA : Elements_Array renames Container.Elements.EA; - - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Boolean; - + Lock : With_Lock (Container.TC'Unrestricted_Access); + EA : Elements_Array renames Container.Elements.EA; begin - B := B + 1; - L := L + 1; - - Result := True; for J in Index_Type'First .. Container.Last - 1 loop if EA (J + 1) < EA (J) then - Result := False; - exit; + return False; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return True; end; end Is_Sorted; @@ -1171,7 +796,7 @@ package body Ada.Containers.Vectors is return; end if; - if Target'Address = Source'Address then + if Checks and then Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; end if; @@ -1181,10 +806,7 @@ package body Ada.Containers.Vectors is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Source.TC); Target.Set_Length (Length (Target) + Length (Source)); @@ -1195,19 +817,9 @@ package body Ada.Containers.Vectors is TA : Elements_Array renames Target.Elements.EA; SA : Elements_Array renames Source.Elements.EA; - TB : Natural renames Target.Busy; - TL : Natural renames Target.Lock; - - SB : Natural renames Source.Busy; - SL : Natural renames Source.Lock; - + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); begin - TB := TB + 1; - TL := TL + 1; - - SB := SB + 1; - SL := SL + 1; - J := Target.Last; while Source.Last >= Index_Type'First loop pragma Assert (Source.Last <= Index_Type'First @@ -1236,22 +848,6 @@ package body Ada.Containers.Vectors is J := J - 1; end loop; - - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - exception - when others => - TB := TB - 1; - TL := TL - 1; - - SB := SB - 1; - SL := SL - 1; - - raise; end; end Merge; @@ -1283,33 +879,15 @@ package body Ada.Containers.Vectors is -- an artifact of our array-based implementation. Logically Sort -- requires a check for cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - B := B + 1; - L := L + 1; - Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); - - B := B - 1; - L := L - 1; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end; end Sort; @@ -1358,31 +936,33 @@ package body Ada.Containers.Vectors is Dst : Elements_Access; -- new, expanded internal array begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) - if Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; end if; -- We treat inserting 0 items into the container as a no-op, even when @@ -1398,7 +978,7 @@ package body Ada.Containers.Vectors is -- Note: we cannot simply add these values, because of the possibility -- of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -1449,7 +1029,6 @@ package body Ada.Containers.Vectors is -- handled above). if Index_Type'Last - No_Index >= Count_Type_Last then - -- We have determined that range of Index_Type has at least as -- many values as in Count_Type, so Count_Type'Last is the -- maximum number of items that are allowed. @@ -1506,7 +1085,7 @@ package body Ada.Containers.Vectors is -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -1551,10 +1130,7 @@ package body Ada.Containers.Vectors is -- exit. Insert checks the count to determine whether it is being called -- while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- An internal array has already been allocated, so we must determine -- whether there is enough unused storage for the new items. @@ -1828,7 +1404,7 @@ package body Ada.Containers.Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1839,7 +1415,7 @@ package body Ada.Containers.Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1862,7 +1438,7 @@ package body Ada.Containers.Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1879,7 +1455,7 @@ package body Ada.Containers.Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -1904,7 +1480,7 @@ package body Ada.Containers.Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1915,7 +1491,7 @@ package body Ada.Containers.Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else @@ -1939,7 +1515,7 @@ package body Ada.Containers.Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -1956,7 +1532,7 @@ package body Ada.Containers.Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; end if; @@ -2019,31 +1595,33 @@ package body Ada.Containers.Vectors is Dst : Elements_Access; -- new, expanded internal array begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) - if Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; end if; -- We treat inserting 0 items into the container as a no-op, even when @@ -2059,7 +1637,7 @@ package body Ada.Containers.Vectors is -- Note: we cannot simply add these values, because of the possibility -- of overflow. - if Old_Length > Count_Type'Last - Count then + if Checks and then Old_Length > Count_Type'Last - Count then raise Constraint_Error with "Count is out of range"; end if; @@ -2075,7 +1653,6 @@ package body Ada.Containers.Vectors is -- acceptable, then we compute the new last index from that. if Index_Type'Base'Last >= Count_Type_Last then - -- We have to handle the case when there might be more values in the -- range of Index_Type than in the range of Count_Type. @@ -2110,7 +1687,6 @@ package body Ada.Containers.Vectors is -- handled above). if Index_Type'Last - No_Index >= Count_Type_Last then - -- We have determined that range of Index_Type has at least as -- many values as in Count_Type, so Count_Type'Last is the -- maximum number of items that are allowed. @@ -2167,7 +1743,7 @@ package body Ada.Containers.Vectors is -- an internal array with a last index value greater than -- Index_Type'Last, with no way to index those elements). - if New_Length > Max_Length then + if Checks and then New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; end if; @@ -2211,10 +1787,7 @@ package body Ada.Containers.Vectors is -- exit. Insert checks the count to determine whether it is being called -- while the associated callback procedure is executing. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- An internal array has already been allocated, so we must determine -- whether there is enough unused storage for the new items. @@ -2360,7 +1933,7 @@ package body Ada.Containers.Vectors is Index : Index_Type'Base; begin - if Before.Container /= null + if Checks and then Before.Container /= null and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; @@ -2377,7 +1950,7 @@ package body Ada.Containers.Vectors is end if; if Before.Container = null or else Before.Index > Container.Last then - if Container.Last = Index_Type'Last then + if Checks and then Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else @@ -2388,7 +1961,7 @@ package body Ada.Containers.Vectors is Index := Before.Index; end if; - Insert_Space (Container, Index, Count => Count); + Insert_Space (Container, Index, Count); Position := (Container'Unrestricted_Access, Index); end Insert_Space; @@ -2410,22 +1983,11 @@ package body Ada.Containers.Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - B : Natural renames Container'Unrestricted_Access.all.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Iterate; function Iterate @@ -2433,8 +1995,6 @@ package body Ada.Containers.Vectors is return Vector_Iterator_Interfaces.Reversible_Iterator'Class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- The value of its Index component influences the behavior of the First -- and Last selector functions of the iterator object. When the Index @@ -2451,18 +2011,16 @@ package body Ada.Containers.Vectors is Container => V, Index => No_Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; function Iterate (Container : Vector; Start : Cursor) - return Vector_Iterator_Interfaces.Reversible_Iterator'class + return Vector_Iterator_Interfaces.Reversible_Iterator'Class is V : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames V.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -2475,19 +2033,21 @@ package body Ada.Containers.Vectors is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start.Container = null then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; + if Checks then + if Start.Container = null then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; - if Start.Container /= V then - raise Program_Error with - "Start cursor of Iterate designates wrong vector"; - end if; + if Start.Container /= V then + raise Program_Error with + "Start cursor of Iterate designates wrong vector"; + end if; - if Start.Index > V.Last then - raise Constraint_Error with - "Start position for iterator equals No_Element"; + if Start.Index > V.Last then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; end if; -- The value of its Index component influences the behavior of the First @@ -2504,7 +2064,7 @@ package body Ada.Containers.Vectors is Container => V, Index => Start.Index) do - B := B + 1; + Busy (Container.TC'Unrestricted_Access.all); end return; end Iterate; @@ -2549,7 +2109,7 @@ package body Ada.Containers.Vectors is function Last_Element (Container : Vector) return Element_Type is begin - if Container.Last = No_Index then + if Checks and then Container.Last = No_Index then raise Constraint_Error with "Container is empty"; else return Container.Elements.EA (Container.Last); @@ -2612,15 +2172,8 @@ package body Ada.Containers.Vectors is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Target is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (Source is busy)"; - end if; + TC_Check (Target.TC); + TC_Check (Source.TC); declare Target_Elements : constant Elements_Access := Target.Elements; @@ -2652,7 +2205,7 @@ package body Ada.Containers.Vectors is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + elsif Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; else @@ -2708,7 +2261,7 @@ package body Ada.Containers.Vectors is begin if Position.Container = null then return No_Element; - elsif Position.Container /= Object.Container then + elsif Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; else @@ -2734,15 +2287,10 @@ package body Ada.Containers.Vectors is function Pseudo_Reference (Container : aliased Vector'Class) return Reference_Control_Type is - C : constant Vector_Access := Container'Unrestricted_Access; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -2755,29 +2303,15 @@ package body Ada.Containers.Vectors is Index : Index_Type; Process : not null access procedure (Element : Element_Type)) is + Lock : With_Lock (Container.TC'Unrestricted_Access); V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - L : Natural renames V.Lock; begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - B := B + 1; - L := L + 1; - - begin - Process (V.Elements.EA (Index)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (V.Elements.EA (Index)); end Query_Element; procedure Query_Element @@ -2785,7 +2319,7 @@ package body Ada.Containers.Vectors is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; else Query_Element (Position.Container.all, Position.Index, Process); @@ -2852,29 +2386,29 @@ package body Ada.Containers.Vectors is Position : Cursor) return Reference_Type is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; end if; declare - C : Vector renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -2884,24 +2418,21 @@ package body Ada.Containers.Vectors is Index : Index_Type) return Reference_Type is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; - - else - declare - C : Vector renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Reference_Type := - (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with Container'Unrestricted_Access)) - do - B := B + 1; - L := L + 1; - end return; - end; end if; + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Container.Elements.EA (Index)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; end Reference; --------------------- @@ -2914,14 +2445,12 @@ package body Ada.Containers.Vectors is New_Item : Element_Type) is begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; - elsif Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - else - Container.Elements.EA (Index) := New_Item; end if; + + TE_Check (Container.TC); + Container.Elements.EA (Index) := New_Item; end Replace_Element; procedure Replace_Element @@ -2930,23 +2459,20 @@ package body Ada.Containers.Vectors is New_Item : Element_Type) is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - - elsif Position.Index > Container.Last then - raise Constraint_Error with "Position cursor is out of range"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; - else - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; + elsif Position.Index > Container.Last then + raise Constraint_Error with "Position cursor is out of range"; end if; - - Container.Elements.EA (Position.Index) := New_Item; end if; + + TE_Check (Container.TC); + Container.Elements.EA (Position.Index) := New_Item; end Replace_Element; ---------------------- @@ -3008,10 +2534,7 @@ package body Ada.Containers.Vectors is -- so this is the best we can do with respect to minimizing -- storage). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare subtype Src_Index_Subtype is Index_Type'Base range @@ -3068,7 +2591,9 @@ package body Ada.Containers.Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index + then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3080,7 +2605,7 @@ package body Ada.Containers.Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3092,7 +2617,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (No_Index) + Capacity; -- Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3109,7 +2634,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Capacity is out of range"; end if; @@ -3148,10 +2673,7 @@ package body Ada.Containers.Vectors is -- new internal array having a length that exactly matches the -- number of items in the container. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare subtype Src_Index_Subtype is Index_Type'Base range @@ -3208,10 +2730,7 @@ package body Ada.Containers.Vectors is -- number of active elements in the container.) We must check whether -- the container is busy before doing anything else. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); -- We now allocate a new internal array, having a length different from -- its current value. @@ -3283,10 +2802,7 @@ package body Ada.Containers.Vectors is -- implementation. Logically Reverse_Elements requires a check for -- cursor tampering. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is busy)"; - end if; + TC_Check (Container.TC); declare K : Index_Type; @@ -3322,7 +2838,7 @@ package body Ada.Containers.Vectors is Last : Index_Type'Base; begin - if Position.Container /= null + if Checks and then Position.Container /= null and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; @@ -3337,38 +2853,15 @@ package body Ada.Containers.Vectors is -- element tampering by a generic actual subprogram. declare - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; - - Result : Index_Type'Base; - + Lock : With_Lock (Container.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then - Result := Indx; - exit; + return Cursor'(Container'Unrestricted_Access, Indx); end if; end loop; - B := B - 1; - L := L - 1; - - if Result = No_Index then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Result); - end if; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Element; end; end Reverse_Find; @@ -3381,40 +2874,22 @@ package body Ada.Containers.Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is - B : Natural renames Container'Unrestricted_Access.Busy; - L : Natural renames Container'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); Last : constant Index_Type'Base := Index_Type'Min (Container.Last, Index); - Result : Index_Type'Base; - begin - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B := B + 1; - L := L + 1; - - Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then - Result := Indx; - exit; + return Indx; end if; end loop; - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; + return No_Index; end Reverse_Find_Index; --------------------- @@ -3425,23 +2900,11 @@ package body Ada.Containers.Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - + Busy : With_Busy (Container.TC'Unrestricted_Access); begin - B := B + 1; - - begin - for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; end Reverse_Iterate; ---------------- @@ -3462,7 +2925,7 @@ package body Ada.Containers.Vectors is if Count >= 0 then Container.Delete_Last (Count); - elsif Container.Last >= Index_Type'Last then + elsif Checks and then Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; else @@ -3476,22 +2939,21 @@ package body Ada.Containers.Vectors is procedure Swap (Container : in out Vector; I, J : Index_Type) is begin - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; + if Checks then + if I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; end if; if I = J then return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; + TE_Check (Container.TC); declare EI_Copy : constant Element_Type := Container.Elements.EA (I); @@ -3503,21 +2965,22 @@ package body Ada.Containers.Vectors is procedure Swap (Container : in out Vector; I, J : Cursor) is begin - if I.Container = null then - raise Constraint_Error with "I cursor has no element"; + if Checks then + if I.Container = null then + raise Constraint_Error with "I cursor has no element"; - elsif J.Container = null then - raise Constraint_Error with "J cursor has no element"; + elsif J.Container = null then + raise Constraint_Error with "J cursor has no element"; - elsif I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor denotes wrong container"; + elsif I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor denotes wrong container"; - elsif J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor denotes wrong container"; - - else - Swap (Container, I.Index, J.Index); + elsif J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor denotes wrong container"; + end if; end if; + + Swap (Container, I.Index, J.Index); end Swap; --------------- @@ -3585,7 +3048,9 @@ package body Ada.Containers.Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -3597,7 +3062,7 @@ package body Ada.Containers.Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -3609,7 +3074,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (No_Index) + Length; -- Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -3626,7 +3091,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -3639,7 +3104,7 @@ package body Ada.Containers.Vectors is Elements := new Elements_Type (Last); - return Vector'(Controlled with Elements, Last, others => <>); + return Vector'(Controlled with Elements, Last, TC => <>); end To_Vector; function To_Vector @@ -3675,7 +3140,9 @@ package body Ada.Containers.Vectors is -- Which can rewrite as: -- No_Index <= Last - Length - if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then raise Constraint_Error with "Length is out of range"; end if; @@ -3687,7 +3154,7 @@ package body Ada.Containers.Vectors is -- Finally we test whether the value is within the range of the -- generic actual index subtype: - if Last > Index_Type'Last then + if Checks and then Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; @@ -3699,7 +3166,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last - if Index > Count_Type'Base (Index_Type'Last) then + if Checks and then Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; @@ -3716,7 +3183,7 @@ package body Ada.Containers.Vectors is Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - if Index < Count_Type'Base (No_Index) then + if Checks and then Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; @@ -3729,7 +3196,7 @@ package body Ada.Containers.Vectors is Elements := new Elements_Type'(Last, EA => (others => New_Item)); - return Vector'(Controlled with Elements, Last, others => <>); + return (Controlled with Elements, Last, TC => <>); end To_Vector; -------------------- @@ -3741,28 +3208,13 @@ package body Ada.Containers.Vectors is Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)) is - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - + Lock : With_Lock (Container.TC'Unchecked_Access); begin - if Index > Container.Last then + if Checks and then Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; - B := B + 1; - L := L + 1; - - begin - Process (Container.Elements.EA (Index)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Container.Elements.EA (Index)); end Update_Element; procedure Update_Element @@ -3771,13 +3223,15 @@ package body Ada.Containers.Vectors is Process : not null access procedure (Element : in out Element_Type)) is begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - else - Update_Element (Container, Position.Index, Process); + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; end if; + + Update_Element (Container, Position.Index, Process); end Update_Element; ----------- diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index fb801b8aaae..5e0de79c227 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; @@ -43,6 +44,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Vectors is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -366,6 +368,10 @@ private pragma Inline (Next); pragma Inline (Previous); + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + type Elements_Array is array (Index_Type range <>) of aliased Element_Type; function "=" (L, R : Elements_Array) return Boolean is abstract; @@ -375,14 +381,13 @@ private type Elements_Access is access all Elements_Type; - use Ada.Finalization; - use Ada.Streams; + use Finalization; + use Streams; type Vector is new Controlled with record Elements : Elements_Access := null; Last : Extended_Index := No_Index; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Tamper_Counts; end record; overriding procedure Adjust (Container : in out Vector); @@ -420,16 +425,8 @@ private for Cursor'Write use Write; - type Reference_Control_Type is - new Controlled with record - Container : Vector_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -477,7 +474,7 @@ private -- 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 + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for -- details. function Pseudo_Reference @@ -493,12 +490,29 @@ private (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - No_Element : constant Cursor := Cursor'(null, Index_Type'First); + No_Element : constant Cursor := Cursor'(null, Index_Type'First); Empty_Vector : constant Vector := (Controlled with others => <>); - Count_Type_Last : constant := Count_Type'Last; - -- Count_Type'Last as a universal_integer, so we can compare Index_Type - -- values against this without type conversions that might overflow. + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record + Container : Vector_Access; + Index : Index_Type'Base; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; end Ada.Containers.Vectors; diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index c217a4f6d68..6083b4cf45b 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -29,6 +29,8 @@ with Ada.Unchecked_Deallocation; +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); @@ -39,7 +41,9 @@ with System; use type System.Address; package body Ada.Containers.Ordered_Maps is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------------- -- Node Access Subprograms -- @@ -125,11 +129,11 @@ package body Ada.Containers.Ordered_Maps is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; @@ -144,7 +148,7 @@ package body Ada.Containers.Ordered_Maps is function "<" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; end if; @@ -156,7 +160,7 @@ package body Ada.Containers.Ordered_Maps is function "<" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; end if; @@ -181,11 +185,11 @@ package body Ada.Containers.Ordered_Maps is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; @@ -200,7 +204,7 @@ package body Ada.Containers.Ordered_Maps is function ">" (Left : Cursor; Right : Key_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor of "">"" equals No_Element"; end if; @@ -212,7 +216,7 @@ package body Ada.Containers.Ordered_Maps is function ">" (Left : Key_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor of "">"" equals No_Element"; end if; @@ -234,20 +238,6 @@ package body Ada.Containers.Ordered_Maps is Adjust (Container.Tree); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - T : Tree_Type renames Control.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -323,12 +313,13 @@ package body Ada.Containers.Ordered_Maps is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -338,15 +329,14 @@ package body Ada.Containers.Ordered_Maps is declare T : Tree_Type renames Position.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -358,21 +348,20 @@ package body Ada.Containers.Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; declare T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -421,12 +410,13 @@ package body Ada.Containers.Ordered_Maps is Tree : Tree_Type renames Container.Tree; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Delete equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Delete designates wrong map"; end if; @@ -444,7 +434,7 @@ package body Ada.Containers.Ordered_Maps is X : Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "key not in map"; end if; @@ -486,7 +476,7 @@ package body Ada.Containers.Ordered_Maps is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Element equals No_Element"; end if; @@ -501,7 +491,7 @@ package body Ada.Containers.Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; @@ -544,27 +534,7 @@ package body Ada.Containers.Ordered_Maps is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Tree.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - T : Tree_Type renames Control.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.Tree.TC); end if; end Finalize; @@ -622,11 +592,11 @@ package body Ada.Containers.Ordered_Maps is function First_Element (Container : Map) return Element_Type is T : Tree_Type renames Container.Tree; begin - if T.First = null then + if Checks and then T.First = null then raise Constraint_Error with "map is empty"; - else - return T.First.Element; end if; + + return T.First.Element; end First_Element; --------------- @@ -636,11 +606,11 @@ package body Ada.Containers.Ordered_Maps is function First_Key (Container : Map) return Key_Type is T : Tree_Type renames Container.Tree; begin - if T.First = null then + if Checks and then T.First = null then raise Constraint_Error with "map is empty"; - else - return T.First.Key; end if; + + return T.First.Key; end First_Key; ----------- @@ -712,10 +682,7 @@ package body Ada.Containers.Ordered_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); Position.Node.Key := Key; Position.Node.Element := New_Item; @@ -781,7 +748,7 @@ package body Ada.Containers.Ordered_Maps is begin Insert (Container, Key, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "key already in map"; end if; end Insert; @@ -902,29 +869,17 @@ package body Ada.Containers.Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (Container.Tree); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (Container.Tree); end Iterate; function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -941,15 +896,13 @@ package body Ada.Containers.Ordered_Maps is Container => Container'Unrestricted_Access, Node => null) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; function Iterate (Container : Map; Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -962,12 +915,12 @@ package body Ada.Containers.Ordered_Maps is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong map"; end if; @@ -989,7 +942,7 @@ package body Ada.Containers.Ordered_Maps is Container => Container'Unrestricted_Access, Node => Start.Node) do - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); end return; end Iterate; @@ -999,7 +952,7 @@ package body Ada.Containers.Ordered_Maps is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of function Key equals No_Element"; end if; @@ -1053,11 +1006,11 @@ package body Ada.Containers.Ordered_Maps is function Last_Element (Container : Map) return Element_Type is T : Tree_Type renames Container.Tree; begin - if T.Last = null then + if Checks and then T.Last = null then raise Constraint_Error with "map is empty"; - else - return T.Last.Element; end if; + + return T.Last.Element; end Last_Element; -------------- @@ -1067,11 +1020,11 @@ package body Ada.Containers.Ordered_Maps is function Last_Key (Container : Map) return Key_Type is T : Tree_Type renames Container.Tree; begin - if T.Last = null then + if Checks and then T.Last = null then raise Constraint_Error with "map is empty"; - else - return T.Last.Key; end if; + + return T.Last.Key; end Last_Key; ---------- @@ -1143,7 +1096,7 @@ package body Ada.Containers.Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong map"; end if; @@ -1200,7 +1153,7 @@ package body Ada.Containers.Ordered_Maps is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong map"; end if; @@ -1215,15 +1168,11 @@ package body Ada.Containers.Ordered_Maps is function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type is - C : constant Map_Access := Container'Unrestricted_Access; - B : Natural renames C.Tree.Busy; - L : Natural renames C.Tree.Lock; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -1237,7 +1186,7 @@ package body Ada.Containers.Ordered_Maps is Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Query_Element equals No_Element"; end if; @@ -1247,29 +1196,11 @@ package body Ada.Containers.Ordered_Maps is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Query_Element; @@ -1345,12 +1276,13 @@ package body Ada.Containers.Ordered_Maps is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong map"; end if; @@ -1360,15 +1292,14 @@ package body Ada.Containers.Ordered_Maps is declare T : Tree_Type renames Position.Container.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1380,21 +1311,20 @@ package body Ada.Containers.Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; declare T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; begin return R : constant Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Reference; @@ -1411,14 +1341,11 @@ package body Ada.Containers.Ordered_Maps is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in map"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); Node.Key := Key; Node.Element := New_Item; @@ -1434,20 +1361,18 @@ package body Ada.Containers.Ordered_Maps is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Replace_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Replace_Element designates wrong map"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (map is locked)"; - end if; + TE_Check (Container.Tree.TC); pragma Assert (Vet (Container.Tree, Position.Node), "Position cursor of Replace_Element is bad"); @@ -1478,22 +1403,12 @@ package body Ada.Containers.Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (Container.Tree); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (Container.Tree); end Reverse_Iterate; ----------- @@ -1555,12 +1470,13 @@ package body Ada.Containers.Ordered_Maps is Element : in out Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor of Update_Element equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor of Update_Element designates wrong map"; end if; @@ -1570,30 +1486,11 @@ package body Ada.Containers.Ordered_Maps is declare T : Tree_Type renames Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - - begin - Process (K, E); - - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (K, E); end; end Update_Element; diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads index 56a98fbc0e4..3034a2ec850 100644 --- a/gcc/ada/a-coorma.ads +++ b/gcc/ada/a-coorma.ads @@ -45,6 +45,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Ordered_Maps is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -261,7 +262,7 @@ private overriding procedure Finalize (Container : in out Map) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -297,16 +298,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Map_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -364,19 +357,14 @@ private -- container, and increments the Lock. Finalization of this object will -- decrement the Lock. - type Element_Access is access all Element_Type; + type Element_Access is access all Element_Type with + Storage_Size => 0; function Get_Element_Access (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - Empty_Map : constant Map := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + Empty_Map : constant Map := (Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -385,7 +373,8 @@ private record Container : Map_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb index c3e4fce66e4..75969d0596b 100644 --- a/gcc/ada/a-coormu.adb +++ b/gcc/ada/a-coormu.adb @@ -42,7 +42,9 @@ with System; use type System.Address; package body Ada.Containers.Ordered_Multisets is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------------- -- Node Access Subprograms -- @@ -577,10 +579,8 @@ package body Ada.Containers.Ordered_Multisets is -------------- procedure Finalize (Object : in out Iterator) is - B : Natural renames Object.Container.Tree.Busy; - pragma Assert (B > 0); begin - B := B - 1; + Unbusy (Object.Container.Tree.TC); end Finalize; ---------- @@ -887,22 +887,12 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T, Key); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T, Key); end Iterate; --------- @@ -947,22 +937,12 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T, Key); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T, Key); end Reverse_Iterate; -------------------- @@ -994,25 +974,9 @@ package body Ada.Containers.Ordered_Multisets is declare E : Element_Type renames Node.Element; K : constant Key_Type := Key (E); - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (E); if Equivalent_Keys (Left => K, Right => Key (E)) then return; @@ -1283,22 +1247,12 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T); end Iterate; procedure Iterate @@ -1322,30 +1276,18 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T, Item); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T, Item); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'Class is S : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames S.Tree.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1358,7 +1300,7 @@ package body Ada.Containers.Ordered_Multisets is -- for a reverse iterator, Container.Last is the beginning. return It : constant Iterator := (Limited_Controlled with S, null) do - B := B + 1; + Busy (S.Tree.TC); end return; end Iterate; @@ -1366,8 +1308,6 @@ package body Ada.Containers.Ordered_Multisets is return Set_Iterator_Interfaces.Reversible_Iterator'Class is S : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames S.Tree.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1405,7 +1345,7 @@ package body Ada.Containers.Ordered_Multisets is return It : constant Iterator := (Limited_Controlled with S, Start.Node) do - B := B + 1; + Busy (S.Tree.TC); end return; end Iterate; @@ -1609,25 +1549,9 @@ package body Ada.Containers.Ordered_Multisets is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element); end; end Query_Element; @@ -1700,10 +1624,7 @@ package body Ada.Containers.Ordered_Multisets is then null; else - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); Node.Element := Item; return; @@ -1796,22 +1717,12 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T); end Reverse_Iterate; procedure Reverse_Iterate @@ -1835,22 +1746,12 @@ package body Ada.Containers.Ordered_Multisets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T, Item); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T, Item); end Reverse_Iterate; ----------- diff --git a/gcc/ada/a-coormu.ads b/gcc/ada/a-coormu.ads index 51785820b50..5fd8a81edd2 100644 --- a/gcc/ada/a-coormu.ads +++ b/gcc/ada/a-coormu.ads @@ -43,6 +43,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Ordered_Multisets is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -476,7 +477,7 @@ private overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -543,20 +544,15 @@ private for Constant_Reference_Type'Write use Write; - Empty_Set : constant Set := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + Empty_Set : constant Set := (Controlled with others => <>); type Iterator is new Limited_Controlled and Set_Iterator_Interfaces.Reversible_Iterator with record Container : Set_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index fde98bf5f2d..78345c9ac81 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -29,6 +29,8 @@ with Ada.Unchecked_Deallocation; +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + with Ada.Containers.Red_Black_Trees.Generic_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); @@ -42,7 +44,9 @@ with System; use type System.Address; package body Ada.Containers.Ordered_Sets is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ------------------------------ -- Access to Fields of Node -- @@ -157,11 +161,11 @@ package body Ada.Containers.Ordered_Sets is function "<" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -176,7 +180,7 @@ package body Ada.Containers.Ordered_Sets is function "<" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; @@ -188,7 +192,7 @@ package body Ada.Containers.Ordered_Sets is function "<" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -213,11 +217,11 @@ package body Ada.Containers.Ordered_Sets is function ">" (Left, Right : Cursor) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -234,7 +238,7 @@ package body Ada.Containers.Ordered_Sets is function ">" (Left : Element_Type; Right : Cursor) return Boolean is begin - if Right.Node = null then + if Checks and then Right.Node = null then raise Constraint_Error with "Right cursor equals No_Element"; end if; @@ -246,7 +250,7 @@ package body Ada.Containers.Ordered_Sets is function ">" (Left : Cursor; Right : Element_Type) return Boolean is begin - if Left.Node = null then + if Checks and then Left.Node = null then raise Constraint_Error with "Left cursor equals No_Element"; end if; @@ -267,20 +271,6 @@ package body Ada.Containers.Ordered_Sets is Adjust (Container.Tree); end Adjust; - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------ -- Assign -- ------------ @@ -336,11 +326,12 @@ package body Ada.Containers.Ordered_Sets is Position : Cursor) return Constant_Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -351,15 +342,14 @@ package body Ada.Containers.Ordered_Sets is declare Tree : Tree_Type renames Position.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Position.Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -408,11 +398,12 @@ package body Ada.Containers.Ordered_Sets is procedure Delete (Container : in out Set; Position : in out Cursor) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -428,7 +419,7 @@ package body Ada.Containers.Ordered_Sets is X : Node_Access := Element_Keys.Find (Container.Tree, Item); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete element not in set"; end if; @@ -485,7 +476,7 @@ package body Ada.Containers.Ordered_Sets is function Element (Position : Cursor) return Element_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -553,27 +544,7 @@ package body Ada.Containers.Ordered_Sets is procedure Finalize (Object : in out Iterator) is begin if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Tree.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B - 1; - L := L - 1; - end; - - Control.Container := null; + Unbusy (Object.Container.Tree.TC); end if; end Finalize; @@ -627,7 +598,7 @@ package body Ada.Containers.Ordered_Sets is function First_Element (Container : Set) return Element_Type is begin - if Container.Tree.First = null then + if Checks and then Container.Tree.First = null then raise Constraint_Error with "set is empty"; end if; @@ -692,24 +663,6 @@ package body Ada.Containers.Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B + 1; - L := L + 1; - end; - end if; - end Adjust; - ------------- -- Ceiling -- ------------- @@ -732,21 +685,20 @@ package body Ada.Containers.Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; end if; declare Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; begin return R : constant Constant_Reference_Type := (Element => Node.Element'Access, - Control => (Controlled with Container'Unrestricted_Access)) + Control => (Controlled with TC)) do - B := B + 1; - L := L + 1; + Lock (TC.all); end return; end; end Constant_Reference; @@ -768,7 +720,7 @@ package body Ada.Containers.Ordered_Sets is X : Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if X = null then + if Checks and then X = null then raise Constraint_Error with "attempt to delete key not in set"; end if; @@ -784,7 +736,7 @@ package body Ada.Containers.Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "key not in set"; end if; @@ -820,16 +772,10 @@ package body Ada.Containers.Ordered_Sets is procedure Finalize (Control : in out Reference_Control_Type) is begin if Control.Container /= null then - declare - Tree : Tree_Type renames Control.Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin - B := B - 1; - L := L - 1; - end; - - if not (Key (Control.Pos) = Control.Old_Key.all) then + Impl.Reference_Control_Type (Control).Finalize; + + if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) + then Delete (Control.Container.all, Key (Control.Pos)); raise Program_Error; end if; @@ -891,7 +837,7 @@ package body Ada.Containers.Ordered_Sets is function Key (Position : Cursor) return Key_Type is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -923,11 +869,12 @@ package body Ada.Containers.Ordered_Sets is Position : Cursor) return Reference_Type is begin - if Position.Container = null then + if Checks and then Position.Container = null then raise Constraint_Error with "Position cursor has no element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong container"; end if; @@ -938,20 +885,17 @@ package body Ada.Containers.Ordered_Sets is declare Tree : Tree_Type renames Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin return R : constant Reference_Type := (Element => Position.Node.Element'Access, Control => (Controlled with + Tree.TC'Unrestricted_Access, Container => Container'Access, Pos => Position, Old_Key => new Key_Type'(Key (Position)))) do - B := B + 1; - L := L + 1; + Lock (Tree.TC); end return; end; end Reference_Preserving_Key; @@ -963,26 +907,23 @@ package body Ada.Containers.Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then - raise Constraint_Error with "key not in set"; + if Checks and then Node = null then + raise Constraint_Error with "Key not in set"; end if; declare Tree : Tree_Type renames Container.Tree; - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - begin return R : constant Reference_Type := (Element => Node.Element'Access, Control => (Controlled with + Tree.TC'Unrestricted_Access, Container => Container'Access, Pos => Find (Container, Key), Old_Key => new Key_Type'(Key))) do - B := B + 1; - L := L + 1; + Lock (Tree.TC); end return; end; end Reference_Preserving_Key; @@ -999,7 +940,7 @@ package body Ada.Containers.Ordered_Sets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace key not in set"; end if; @@ -1019,12 +960,13 @@ package body Ada.Containers.Ordered_Sets is Tree : Tree_Type renames Container.Tree; begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1035,30 +977,10 @@ package body Ada.Containers.Ordered_Sets is declare E : Element_Type renames Position.Node.Element; K : constant Key_Type := Key (E); - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - - Eq : Boolean; - + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (E); - Eq := Equivalent_Keys (K, Key (E)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - - if Eq then + Process (E); + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -1118,10 +1040,7 @@ package body Ada.Containers.Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.Tree.TC); Position.Node.Element := New_Item; end if; @@ -1159,7 +1078,7 @@ package body Ada.Containers.Ordered_Sets is begin Insert (Container, New_Item, Position, Inserted); - if not Inserted then + if Checks and then not Inserted then raise Constraint_Error with "attempt to insert element already in set"; end if; @@ -1362,29 +1281,17 @@ package body Ada.Containers.Ordered_Sets is end Process_Node; T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Iterate begin - B := B + 1; - - begin - Local_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Iterate (T); end Iterate; function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1396,7 +1303,7 @@ package body Ada.Containers.Ordered_Sets is -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); return It : constant Iterator := Iterator'(Limited_Controlled with @@ -1407,8 +1314,6 @@ package body Ada.Containers.Ordered_Sets is function Iterate (Container : Set; Start : Cursor) return Set_Iterator_Interfaces.Reversible_Iterator'Class is - B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; - begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1421,12 +1326,12 @@ package body Ada.Containers.Ordered_Sets is -- however, that it is not possible to use a partial iterator to specify -- an empty sequence of items. - if Start = No_Element then + if Checks and then Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; end if; - if Start.Container /= Container'Unrestricted_Access then + if Checks and then Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong set"; end if; @@ -1443,7 +1348,7 @@ package body Ada.Containers.Ordered_Sets is -- the start position has the same value irrespective of whether this is -- a forward or reverse iteration. - B := B + 1; + Busy (Container.Tree.TC'Unrestricted_Access.all); return It : constant Iterator := Iterator'(Limited_Controlled with @@ -1490,11 +1395,11 @@ package body Ada.Containers.Ordered_Sets is function Last_Element (Container : Set) return Element_Type is begin - if Container.Tree.Last = null then + if Checks and then Container.Tree.Last = null then raise Constraint_Error with "set is empty"; - else - return Container.Tree.Last.Element; end if; + + return Container.Tree.Last.Element; end Last_Element; ---------- @@ -1559,7 +1464,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong set"; end if; @@ -1618,7 +1523,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - if Position.Container /= Object.Container then + if Checks and then Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong set"; end if; @@ -1633,15 +1538,11 @@ package body Ada.Containers.Ordered_Sets is function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type is - C : constant Set_Access := Container'Unrestricted_Access; - B : Natural renames C.Tree.Busy; - L : Natural renames C.Tree.Lock; - begin - return R : constant Reference_Control_Type := - (Controlled with C) - do - B := B + 1; - L := L + 1; + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); end return; end Pseudo_Reference; @@ -1654,7 +1555,7 @@ package body Ada.Containers.Ordered_Sets is Process : not null access procedure (Element : Element_Type)) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; @@ -1663,25 +1564,9 @@ package body Ada.Containers.Ordered_Sets is declare T : Tree_Type renames Position.Container.Tree; - - B : Natural renames T.Busy; - L : Natural renames T.Lock; - + Lock : With_Lock (T.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - - begin - Process (Position.Node.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; + Process (Position.Node.Element); end; end Query_Element; @@ -1748,15 +1633,12 @@ package body Ada.Containers.Ordered_Sets is Element_Keys.Find (Container.Tree, New_Item); begin - if Node = null then + if Checks and then Node = null then raise Constraint_Error with "attempt to replace element not in set"; end if; - if Container.Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Container.Tree.TC); Node.Element := New_Item; end Replace; @@ -1805,12 +1687,6 @@ package body Ada.Containers.Ordered_Sets is Inserted : Boolean; Compare : Boolean; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - -- Start of processing for Replace_Element begin @@ -1828,33 +1704,19 @@ package body Ada.Containers.Ordered_Sets is -- Determine whether Item is equivalent to element on the specified -- node. + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := (if Item < Node.Element then False elsif Node.Element < Item then False else True); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then -- Item is equivalent to the node's element, so we will not have to -- move the node. - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); Node.Element := Item; return; @@ -1872,26 +1734,15 @@ package body Ada.Containers.Ordered_Sets is Hint := Element_Keys.Ceiling (Tree, Item); if Hint /= null then + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Item < Hint.Element; - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; -- Item >= Hint.Element - if not Compare then + if Checks and then not Compare then -- Ceiling returns an element that is equivalent or greater -- than Item. If Item is "not less than" the element, then @@ -1922,10 +1773,7 @@ package body Ada.Containers.Ordered_Sets is -- because it would only be placed in the exact same position. if Hint = Node then - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (set is locked)"; - end if; + TE_Check (Tree.TC); Node.Element := Item; return; @@ -1958,12 +1806,13 @@ package body Ada.Containers.Ordered_Sets is New_Item : Element_Type) is begin - if Position.Node = null then + if Checks and then Position.Node = null then raise Constraint_Error with "Position cursor equals No_Element"; end if; - if Position.Container /= Container'Unrestricted_Access then + if Checks and then Position.Container /= Container'Unrestricted_Access + then raise Program_Error with "Position cursor designates wrong set"; end if; @@ -1998,22 +1847,12 @@ package body Ada.Containers.Ordered_Sets is end Process_Node; T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - B : Natural renames T.Busy; + Busy : With_Busy (T.TC'Unrestricted_Access); -- Start of processing for Reverse_Iterate begin - B := B + 1; - - begin - Local_Reverse_Iterate (T); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; + Local_Reverse_Iterate (T); end Reverse_Iterate; ----------- diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index f574f3c92ca..1260fba05cc 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -33,6 +33,7 @@ with Ada.Iterator_Interfaces; +with Ada.Containers.Helpers; private with Ada.Containers.Red_Black_Trees; private with Ada.Finalization; private with Ada.Streams; @@ -44,6 +45,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Ordered_Sets is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; pragma Remote_Types; @@ -283,17 +285,16 @@ package Ada.Containers.Ordered_Sets is type Key_Access is access all Key_Type; + package Impl is new Helpers.Generic_Implementation; + type Reference_Control_Type is - new Ada.Finalization.Controlled with + new Impl.Reference_Control_Type with record Container : Set_Access; Pos : Cursor; Old_Key : Key_Access; end record; - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - overriding procedure Finalize (Control : in out Reference_Control_Type); pragma Inline (Finalize); @@ -344,7 +345,7 @@ private overriding procedure Finalize (Container : in out Set) renames Clear; use Red_Black_Trees; - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; use Ada.Streams; @@ -380,16 +381,8 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Set_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it type Constant_Reference_Type (Element : not null access constant Element_Type) is @@ -425,19 +418,14 @@ private -- container, and increments the Lock. Finalization of this object will -- decrement the Lock. - type Element_Access is access all Element_Type; + type Element_Access is access all Element_Type with + Storage_Size => 0; function Get_Element_Access (Position : Cursor) return not null Element_Access; -- Returns a pointer to the element designated by Position. - Empty_Set : constant Set := - (Controlled with Tree => (First => null, - Last => null, - Root => null, - Length => 0, - Busy => 0, - Lock => 0)); + Empty_Set : constant Set := (Controlled with others => <>); No_Element : constant Cursor := Cursor'(null, null); @@ -446,7 +434,8 @@ private record Container : Set_Access; Node : Node_Access; - end record; + end record + with Disable_Controlled => not T_Check; overriding procedure Finalize (Object : in out Iterator); diff --git a/gcc/ada/a-crbltr.ads b/gcc/ada/a-crbltr.ads index 2991d36ee06..73ed9ae6741 100644 --- a/gcc/ada/a-crbltr.ads +++ b/gcc/ada/a-crbltr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,6 +29,8 @@ -- This package declares the tree type used to implement ordered containers +with Ada.Containers.Helpers; + package Ada.Containers.Red_Black_Trees is pragma Pure; @@ -38,14 +40,16 @@ package Ada.Containers.Red_Black_Trees is type Node_Type (<>) is limited private; type Node_Access is access Node_Type; package Generic_Tree_Types is + type Tree_Type is tagged record - First : Node_Access; - Last : Node_Access; - Root : Node_Access; + First : Node_Access := null; + Last : Node_Access := null; + Root : Node_Access := null; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Helpers.Tamper_Counts; end record; + + package Implementation is new Helpers.Generic_Implementation; end Generic_Tree_Types; generic @@ -65,11 +69,12 @@ package Ada.Containers.Red_Black_Trees is Last : Count_Type := 0; Root : Count_Type := 0; Length : Count_Type := 0; - Busy : Natural := 0; - Lock : Natural := 0; + TC : aliased Helpers.Tamper_Counts; Free : Count_Type'Base := -1; Nodes : Nodes_Type (1 .. Capacity) := (others => <>); end record; + + package Implementation is new Helpers.Generic_Implementation; end Generic_Bounded_Tree_Types; end Ada.Containers.Red_Black_Trees; diff --git a/gcc/ada/a-crbtgk.adb b/gcc/ada/a-crbtgk.adb index ae8dd7c6c7a..10a9e92ba0d 100644 --- a/gcc/ada/a-crbtgk.adb +++ b/gcc/ada/a-crbtgk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,6 +29,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + package Ops renames Tree_Operations; ------------- @@ -38,8 +42,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- AKA Lower_Bound function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is - B : Natural renames Tree'Unrestricted_Access.Busy; - L : Natural renames Tree'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Tree.TC'Unrestricted_Access); Y : Node_Access; X : Node_Access; @@ -52,12 +58,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return null; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B := B + 1; - L := L + 1; - X := Tree.Root; while X /= null loop if Is_Greater_Key_Node (Key, X) then @@ -68,17 +68,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end if; end loop; - B := B - 1; - L := L - 1; - return Y; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end Ceiling; ---------- @@ -86,14 +76,14 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ---------- function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is - B : Natural renames Tree'Unrestricted_Access.Busy; - L : Natural renames Tree'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Tree.TC'Unrestricted_Access); Y : Node_Access; X : Node_Access; - Result : Node_Access; - begin -- If the container is empty, return a result immediately, so that we do -- not manipulate the tamper bits unnecessarily. @@ -102,12 +92,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return null; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B := B + 1; - L := L + 1; - X := Tree.Root; while X /= null loop if Is_Greater_Key_Node (Key, X) then @@ -118,27 +102,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end if; end loop; - if Y = null then - Result := null; - - elsif Is_Less_Key_Node (Key, Y) then - Result := null; - + if Y = null or else Is_Less_Key_Node (Key, Y) then + return null; else - Result := Y; + return Y; end if; - - B := B - 1; - L := L - 1; - - return Result; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end Find; ----------- @@ -146,8 +114,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ----------- function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is - B : Natural renames Tree'Unrestricted_Access.Busy; - L : Natural renames Tree'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Tree.TC'Unrestricted_Access); Y : Node_Access; X : Node_Access; @@ -160,12 +130,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return null; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B := B + 1; - L := L + 1; - X := Tree.Root; while X /= null loop if Is_Less_Key_Node (Key, X) then @@ -176,17 +140,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end if; end loop; - B := B - 1; - L := L - 1; - return Y; - - exception - when others => - B := B - 1; - L := L - 1; - - raise; end Floor; -------------------------------- @@ -202,12 +156,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is X : Node_Access; Y : Node_Access; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - Compare : Boolean; begin @@ -235,10 +183,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- either the smallest node greater than Key (Inserted is True), or the -- largest node less or equivalent to Key (Inserted is False). + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - X := Tree.Root; Y := null; Inserted := True; @@ -247,16 +194,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Inserted := Is_Less_Key_Node (Key, X); X := (if Inserted then Ops.Left (X) else Ops.Right (X)); end loop; - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Inserted then @@ -288,21 +225,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- Key is equivalent to or greater than Node. We must resolve which is -- the case, to determine whether the conditional insertion succeeds. + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Greater_Key_Node (Key, Node); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -334,12 +260,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Node : out Node_Access; Inserted : out Boolean) is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - B : Natural renames Tree.Busy; - L : Natural renames Tree.Lock; - Test : Node_Access; Compare : Boolean; @@ -366,21 +286,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- we must search. if Position = null then -- largest + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Greater_Key_Node (Key, Tree.Last); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -412,21 +321,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- then its neighbor must be anterior and so we insert before the -- hint. + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Less_Key_Node (Key, Position); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -439,21 +337,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return; end if; + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Greater_Key_Node (Key, Test); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -478,21 +365,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- less than the hint's next neighbor, then we're done; otherwise we -- must search. + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Greater_Key_Node (Key, Position); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -505,21 +381,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is return; end if; + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); begin - B := B + 1; - L := L + 1; - Compare := Is_Less_Key_Node (Key, Test); - - L := L - 1; - B := B - 1; - - exception - when others => - L := L - 1; - B := B - 1; - - raise; end; if Compare then @@ -557,14 +422,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Z : out Node_Access) is begin - if Tree.Length = Count_Type'Last then + if Checks and then Tree.Length = Count_Type'Last then raise Constraint_Error with "too many elements"; end if; - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Tree.TC); Z := New_Node; pragma Assert (Z /= null); diff --git a/gcc/ada/a-crbtgk.ads b/gcc/ada/a-crbtgk.ads index b2c21cdb0df..c93dfe7ba6a 100644 --- a/gcc/ada/a-crbtgk.ads +++ b/gcc/ada/a-crbtgk.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,7 +35,7 @@ with Ada.Containers.Red_Black_Trees.Generic_Operations; generic with package Tree_Operations is new Generic_Operations (<>); - use Tree_Operations.Tree_Types; + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; type Key_Type (<>) is limited private; diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb index a75f069acb7..03079618792 100644 --- a/gcc/ada/a-crbtgo.adb +++ b/gcc/ada/a-crbtgo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -38,6 +38,10 @@ with System; use type System.Address; package body Ada.Containers.Red_Black_Trees.Generic_Operations is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -153,7 +157,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is and then Color (X) = Black loop if X = Left (Parent (X)) then - W := Right (Parent (X)); + W := Right (Parent (X)); if Color (W) = Red then Set_Color (W, Black); @@ -197,7 +201,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is else pragma Assert (X = Right (Parent (X))); - W := Left (Parent (X)); + W := Left (Parent (X)); if Color (W) = Red then Set_Color (W, Black); @@ -258,10 +262,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is pragma Assert (Z /= null); begin - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Tree.TC); -- Why are these all commented out ??? @@ -511,12 +512,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Generic_Adjust (Tree : in out Tree_Type) is N : constant Count_Type := Tree.Length; Root : constant Node_Access := Tree.Root; - + use type Helpers.Tamper_Counts; begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Tree.TC); + if N = 0 then pragma Assert (Root = null); - pragma Assert (Tree.Busy = 0); - pragma Assert (Tree.Lock = 0); return; end if; @@ -538,17 +543,13 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Generic_Clear (Tree : in out Tree_Type) is Root : Node_Access := Tree.Root; begin - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Tree.TC); Tree := (First => null, Last => null, Root => null, Length => 0, - Busy => 0, - Lock => 0); + TC => <>); Delete_Tree (Root); end Generic_Clear; @@ -627,22 +628,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ------------------- function Generic_Equal (Left, Right : Tree_Type) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; - - L_Node : Node_Access; - R_Node : Node_Access; - - Result : Boolean; - begin - if Left'Address = Right'Address then - return True; - end if; - if Left.Length /= Right.Length then return False; end if; @@ -654,45 +640,24 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is return True; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - - L_Node := Left.First; - R_Node := Right.First; - Result := True; - while L_Node /= null loop - if not Is_Equal (L_Node, R_Node) then - Result := False; - exit; - end if; - - L_Node := Next (L_Node); - R_Node := Next (R_Node); - end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - exception - when others => - BL := BL - 1; - LL := LL - 1; + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + begin + while L_Node /= null loop + if not Is_Equal (L_Node, R_Node) then + return False; + end if; - BR := BR - 1; - LR := LR - 1; + L_Node := Next (L_Node); + R_Node := Next (R_Node); + end loop; + end; - raise; + return True; end Generic_Equal; ----------------------- @@ -732,10 +697,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is return; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Source.TC); Clear (Target); @@ -745,8 +707,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Last => null, Root => null, Length => 0, - Busy => 0, - Lock => 0); + TC => <>); end Generic_Move; ------------------ diff --git a/gcc/ada/a-crbtgo.ads b/gcc/ada/a-crbtgo.ads index f2787f608da..4c197417ae6 100644 --- a/gcc/ada/a-crbtgo.ads +++ b/gcc/ada/a-crbtgo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,7 +34,7 @@ with Ada.Streams; use Ada.Streams; generic with package Tree_Types is new Generic_Tree_Types (<>); - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; with function Parent (Node : Node_Access) return Node_Access is <>; with procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is <>; diff --git a/gcc/ada/a-crdlli.ads b/gcc/ada/a-crdlli.ads index c18005fc720..151d3f94a0b 100644 --- a/gcc/ada/a-crdlli.ads +++ b/gcc/ada/a-crdlli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -208,7 +208,7 @@ package Ada.Containers.Restricted_Doubly_Linked_Lists is Before : Cursor; Position : in out Cursor); -- If Before is associated with a list object different from Container, - -- then Program_Error is raised. If Position equals No_element, then + -- then Program_Error is raised. If Position equals No_Element, then -- Constraint_Error is raised; if it associated with a list object -- different from Container, then Program_Error is raised. Otherwise, the -- node designated by Position is relinked immediately prior to Before. If diff --git a/gcc/ada/a-cuprqu.adb b/gcc/ada/a-cuprqu.adb index dfb78687b4b..e6947862a20 100644 --- a/gcc/ada/a-cuprqu.adb +++ b/gcc/ada/a-cuprqu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,8 +31,6 @@ with Ada.Unchecked_Deallocation; package body Ada.Containers.Unbounded_Priority_Queues is - pragma Annotate (CodePeer, Skip_Analysis); - package body Implementation is ----------------------- diff --git a/gcc/ada/a-cuprqu.ads b/gcc/ada/a-cuprqu.ads index 4e11d6eef05..4cc000df60e 100644 --- a/gcc/ada/a-cuprqu.ads +++ b/gcc/ada/a-cuprqu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, 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 -- @@ -50,6 +50,7 @@ generic Default_Ceiling : System.Any_Priority := System.Priority'Last; package Ada.Containers.Unbounded_Priority_Queues is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; package Implementation is diff --git a/gcc/ada/a-cusyqu.adb b/gcc/ada/a-cusyqu.adb index 3a87306af15..4183dcba1fe 100644 --- a/gcc/ada/a-cusyqu.adb +++ b/gcc/ada/a-cusyqu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,8 +31,6 @@ with Ada.Unchecked_Deallocation; package body Ada.Containers.Unbounded_Synchronized_Queues is - pragma Annotate (CodePeer, Skip_Analysis); - package body Implementation is ----------------------- diff --git a/gcc/ada/a-cusyqu.ads b/gcc/ada/a-cusyqu.ads index c4f18020356..7efdbf4b2a3 100644 --- a/gcc/ada/a-cusyqu.ads +++ b/gcc/ada/a-cusyqu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, 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 -- @@ -42,6 +42,7 @@ generic Default_Ceiling : System.Any_Priority := System.Priority'Last; package Ada.Containers.Unbounded_Synchronized_Queues is + pragma Annotate (CodePeer, Skip_Analysis); pragma Preelaborate; package Implementation is diff --git a/gcc/ada/a-dirval-mingw.adb b/gcc/ada/a-dirval-mingw.adb index d7d77622db7..dad5c4ae8a4 100644 --- a/gcc/ada/a-dirval-mingw.adb +++ b/gcc/ada/a-dirval-mingw.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Windows Version) -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -40,8 +40,11 @@ package body Ada.Directories.Validity is (NUL .. US | '\' => True, '/' | ':' | '*' | '?' => True, '"' | '<' | '>' | '|' => True, - DEL .. NBSP => True, + DEL => True, others => False); + -- Note that a valid file-name or path-name is implementation defined. + -- To support UTF-8 file and directory names, we do not want to be too + -- restrictive here. --------------------------------- -- Is_Path_Name_Case_Sensitive -- @@ -74,8 +77,7 @@ package body Ada.Directories.Validity is if Name'Length >= 2 and then Name (Start + 1) = ':' and then - (Name (Start) in 'A' .. 'Z' or else - Name (Start) in 'a' .. 'z') + (Name (Start) in 'A' .. 'Z' or else Name (Start) in 'a' .. 'z') then Start := Start + 2; @@ -93,8 +95,8 @@ package body Ada.Directories.Validity is loop -- Look for the start of the next directory or file name - while Start <= Name'Last and then - (Name (Start) = '\' or Name (Start) = '/') + while Start <= Name'Last + and then (Name (Start) = '\' or Name (Start) = '/') loop Start := Start + 1; end loop; diff --git a/gcc/ada/a-disedf.ads b/gcc/ada/a-disedf.ads index f1a5f3c505b..4b28a6db333 100644 --- a/gcc/ada/a-disedf.ads +++ b/gcc/ada/a-disedf.ads @@ -45,6 +45,10 @@ package Ada.Dispatching.EDF is function Get_Deadline (T : Ada.Task_Identification.Task_Id := Ada.Task_Identification.Current_Task) - return Deadline; + return Deadline + with + SPARK_Mode, + Volatile_Function, + Global => Ada.Task_Identification.Tasking_State; end Ada.Dispatching.EDF; diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index d2034750167..a346494f6c4 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -44,6 +44,16 @@ with System.Soft_Links; use System.Soft_Links; with System.WCh_Con; use System.WCh_Con; with System.WCh_StW; use System.WCh_StW; +pragma Warnings (Off); +-- Suppress complaints about Symbolic not being referenced, and about it not +-- having pragma Preelaborate. +with System.Traceback.Symbolic; +-- Bring Symbolic into the closure. If it is the s-trasym-dwarf.adb version, +-- it will install symbolic tracebacks as the default decorator. Otherwise, +-- symbolic tracebacks are not supported, and we fall back to hexadecimal +-- addresses. +pragma Warnings (On); + package body Ada.Exceptions is pragma Suppress (All_Checks); @@ -142,8 +152,8 @@ package body Ada.Exceptions is -- -- The format of the string is as follows: -- - -- Exception_Name: <exception name> (as in Exception_Name) - -- Message: <message> (only if Exception_Message is empty) + -- raised <exception name> : <message> + -- (" : <message>" is present only if Exception_Message is not empty) -- PID=nnnn (only if nonzero) -- Call stack traceback locations: (only if at least one location) -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded) @@ -216,7 +226,7 @@ package body Ada.Exceptions is --------------------------------------- function Allocate_Occurrence return EOA; - -- Allocate an exception occurence (as well as the machine occurence) + -- Allocate an exception occurrence (as well as the machine occurrence) procedure Propagate_Exception (Excep : EOA); pragma No_Return (Propagate_Exception); @@ -694,15 +704,6 @@ package body Ada.Exceptions is -- The actual Call_Chain routine is separate, so that it can easily -- be dummied out when no exception traceback information is needed. - ------------------------------ - -- Current_Target_Exception -- - ------------------------------ - - function Current_Target_Exception return Exception_Occurrence is - begin - return Null_Occurrence; - end Current_Target_Exception; - ------------------- -- EId_To_String -- ------------------- @@ -921,7 +922,9 @@ package body Ada.Exceptions is Call_Chain (X); -- Notify the debugger - Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (X.Id)); + Debug_Raise_Exception + (E => SSL.Exception_Data_Ptr (X.Id), + Message => X.Msg (1 .. X.Msg_Length)); end Complete_Occurrence; --------------------------------------- @@ -1630,11 +1633,10 @@ package body Ada.Exceptions is --------------- procedure To_Stderr (C : Character) is - type int is new Integer; - procedure put_char_stderr (C : int); - pragma Import (C, put_char_stderr, "put_char_stderr"); + procedure Put_Char_Stderr (C : Character); + pragma Import (C, Put_Char_Stderr, "put_char_stderr"); begin - put_char_stderr (Character'Pos (C)); + Put_Char_Stderr (C); end To_Stderr; procedure To_Stderr (S : String) is diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads index 127306eeb76..cb2b2976e4a 100644 --- a/gcc/ada/a-except-2005.ads +++ b/gcc/ada/a-except-2005.ads @@ -177,18 +177,6 @@ private -- Private Subprograms -- ------------------------- - function Current_Target_Exception return Exception_Occurrence; - pragma Export - (Ada, Current_Target_Exception, - "__gnat_current_target_exception"); - -- This routine should return the current raised exception on targets which - -- have built-in exception handling such as the Java Virtual Machine. For - -- other targets this routine is simply ignored. Currently, only JGNAT - -- uses this. See 4jexcept.ads for details. The pragma Export allows this - -- routine to be accessed elsewhere in the run-time, even though it is in - -- the private part of this package (it is not allowed to be in the visible - -- part, since this is set by the reference manual). - function Exception_Name_Simple (X : Exception_Occurrence) return String; -- Like Exception_Name, but returns the simple non-qualified name of the -- exception. This is used to implement the Exception_Name function in diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 9d5aceea572..3b9caeadf8d 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -117,8 +117,8 @@ package body Ada.Exceptions is -- -- The format of the string is as follows: -- - -- Exception_Name: <exception name> (as in Exception_Name) - -- Message: <message> (only if Exception_Message is empty) + -- raised <exception name> : <message> + -- (" : <message>" is present only if Exception_Message is not empty) -- PID=nnnn (only if nonzero) -- Call stack traceback locations: (only if at least one location) -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded) @@ -727,15 +727,6 @@ package body Ada.Exceptions is -- The actual polling routine is separate, so that it can easily be -- replaced with a target dependent version. - ------------------------------ - -- Current_Target_Exception -- - ------------------------------ - - function Current_Target_Exception return Exception_Occurrence is - begin - return Null_Occurrence; - end Current_Target_Exception; - ------------------- -- EId_To_String -- ------------------- @@ -958,7 +949,7 @@ package body Ada.Exceptions is -- pragma Volatile is peculiar. begin - Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E)); + Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E), Message => ""); Process_Raise_Exception (E); end Raise_Current_Excep; diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads index bf3b74d763e..79ca6c8558b 100644 --- a/gcc/ada/a-except.ads +++ b/gcc/ada/a-except.ads @@ -154,18 +154,6 @@ private -- Private Subprograms -- ------------------------- - function Current_Target_Exception return Exception_Occurrence; - pragma Export - (Ada, Current_Target_Exception, - "__gnat_current_target_exception"); - -- This routine should return the current raised exception on targets - -- which have built-in exception handling such as the Java Virtual - -- Machine. For other targets this routine is simply ignored. Currently, - -- only JGNAT uses this. See 4jexcept.ads for details. The pragma Export - -- allows this routine to be accessed elsewhere in the run-time, even - -- though it is in the private part of this package (it is not allowed - -- to be in the visible part, since this is set by the reference manual). - function Exception_Name_Simple (X : Exception_Occurrence) return String; -- Like Exception_Name, but returns the simple non-qualified name of the -- exception. This is used to implement the Exception_Name function in diff --git a/gcc/ada/a-exetim-default.ads b/gcc/ada/a-exetim-default.ads index 3267baad606..5877fc535fe 100644 --- a/gcc/ada/a-exetim-default.ads +++ b/gcc/ada/a-exetim-default.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2015, 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 -- @@ -36,7 +36,9 @@ with Ada.Task_Identification; with Ada.Real_Time; -package Ada.Execution_Time is +package Ada.Execution_Time with + SPARK_Mode +is type CPU_Time is private; @@ -46,47 +48,69 @@ package Ada.Execution_Time is CPU_Tick : constant Ada.Real_Time.Time_Span; function Clock - (T : Ada.Task_Identification.Task_Id - := Ada.Task_Identification.Current_Task) - return CPU_Time; + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return CPU_Time + with + Volatile_Function, + Global => Ada.Real_Time.Clock_Time; function "+" (Left : CPU_Time; - Right : Ada.Real_Time.Time_Span) return CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time + with + Global => null; function "+" (Left : Ada.Real_Time.Time_Span; - Right : CPU_Time) return CPU_Time; + Right : CPU_Time) return CPU_Time + with + Global => null; function "-" (Left : CPU_Time; - Right : Ada.Real_Time.Time_Span) return CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time + with + Global => null; function "-" (Left : CPU_Time; - Right : CPU_Time) return Ada.Real_Time.Time_Span; - - function "<" (Left, Right : CPU_Time) return Boolean; - function "<=" (Left, Right : CPU_Time) return Boolean; - function ">" (Left, Right : CPU_Time) return Boolean; - function ">=" (Left, Right : CPU_Time) return Boolean; + Right : CPU_Time) return Ada.Real_Time.Time_Span + with + Global => null; + + function "<" (Left, Right : CPU_Time) return Boolean with + Global => null; + function "<=" (Left, Right : CPU_Time) return Boolean with + Global => null; + function ">" (Left, Right : CPU_Time) return Boolean with + Global => null; + function ">=" (Left, Right : CPU_Time) return Boolean with + Global => null; procedure Split (T : CPU_Time; SC : out Ada.Real_Time.Seconds_Count; - TS : out Ada.Real_Time.Time_Span); + TS : out Ada.Real_Time.Time_Span) + with + Global => null; function Time_Of (SC : Ada.Real_Time.Seconds_Count; TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero) - return CPU_Time; + return CPU_Time + with + Global => null; Interrupt_Clocks_Supported : constant Boolean := False; Separate_Interrupt_Clocks_Supported : constant Boolean := False; - function Clock_For_Interrupts return CPU_Time; + function Clock_For_Interrupts return CPU_Time with + Volatile_Function, + Global => Ada.Real_Time.Clock_Time; private + pragma SPARK_Mode (Off); type CPU_Time is new Ada.Real_Time.Time; diff --git a/gcc/ada/a-exetim-mingw.adb b/gcc/ada/a-exetim-mingw.adb index b6919f26875..44f4ac3b37c 100644 --- a/gcc/ada/a-exetim-mingw.adb +++ b/gcc/ada/a-exetim-mingw.adb @@ -39,7 +39,9 @@ with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; with System.Tasking; use System.Tasking; with System.Win32; use System.Win32; -package body Ada.Execution_Time is +package body Ada.Execution_Time with + SPARK_Mode => Off +is --------- -- "+" -- diff --git a/gcc/ada/a-exetim-mingw.ads b/gcc/ada/a-exetim-mingw.ads index 42b861bd3ce..8e1e764e50b 100644 --- a/gcc/ada/a-exetim-mingw.ads +++ b/gcc/ada/a-exetim-mingw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2015, 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 -- @@ -30,6 +30,7 @@ -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- ------------------------------------------------------------------------------ -- This is the Windows native version of this package @@ -37,7 +38,9 @@ with Ada.Task_Identification; with Ada.Real_Time; -package Ada.Execution_Time is +package Ada.Execution_Time with + SPARK_Mode +is type CPU_Time is private; @@ -48,45 +51,66 @@ package Ada.Execution_Time is function Clock (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) return CPU_Time; + Ada.Task_Identification.Current_Task) + return CPU_Time + with + Volatile_Function, + Global => Ada.Real_Time.Clock_Time; function "+" (Left : CPU_Time; - Right : Ada.Real_Time.Time_Span) return CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time + with + Global => null; function "+" (Left : Ada.Real_Time.Time_Span; - Right : CPU_Time) return CPU_Time; + Right : CPU_Time) return CPU_Time + with + Global => null; function "-" (Left : CPU_Time; - Right : Ada.Real_Time.Time_Span) return CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time + with + Global => null; function "-" (Left : CPU_Time; Right : CPU_Time) return Ada.Real_Time.Time_Span; - function "<" (Left, Right : CPU_Time) return Boolean; - function "<=" (Left, Right : CPU_Time) return Boolean; - function ">" (Left, Right : CPU_Time) return Boolean; - function ">=" (Left, Right : CPU_Time) return Boolean; + function "<" (Left, Right : CPU_Time) return Boolean with + Global => null; + function "<=" (Left, Right : CPU_Time) return Boolean with + Global => null; + function ">" (Left, Right : CPU_Time) return Boolean with + Global => null; + function ">=" (Left, Right : CPU_Time) return Boolean with + Global => null; procedure Split (T : CPU_Time; SC : out Ada.Real_Time.Seconds_Count; - TS : out Ada.Real_Time.Time_Span); + TS : out Ada.Real_Time.Time_Span) + with + Global => null; function Time_Of - (SC : Ada.Real_Time.Seconds_Count; - TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero) - return CPU_Time; + (SC : Ada.Real_Time.Seconds_Count; + TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero) + return CPU_Time + with + Global => null; Interrupt_Clocks_Supported : constant Boolean := False; Separate_Interrupt_Clocks_Supported : constant Boolean := False; - function Clock_For_Interrupts return CPU_Time; + function Clock_For_Interrupts return CPU_Time with + Volatile_Function, + Global => Ada.Real_Time.Clock_Time; private + pragma SPARK_Mode (Off); type CPU_Time is new Ada.Real_Time.Time; diff --git a/gcc/ada/a-exetim-posix.adb b/gcc/ada/a-exetim-posix.adb index 9dc709ac61f..9c7ad57166e 100644 --- a/gcc/ada/a-exetim-posix.adb +++ b/gcc/ada/a-exetim-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,8 +34,9 @@ with Ada.Task_Identification; use Ada.Task_Identification; with Ada.Unchecked_Conversion; -with System.OS_Constants; use System.OS_Constants; +with System.Tasking; with System.OS_Interface; use System.OS_Interface; +with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; with Interfaces.C; use Interfaces.C; @@ -97,14 +98,18 @@ package body Ada.Execution_Time is (T : Ada.Task_Identification.Task_Id := Ada.Task_Identification.Current_Task) return CPU_Time is - TS : aliased timespec; - Result : Interfaces.C.int; + TS : aliased timespec; + Clock_Id : aliased Interfaces.C.int; + Result : Interfaces.C.int; function To_CPU_Time is new Ada.Unchecked_Conversion (Duration, CPU_Time); -- Time is equal to Duration (although it is a private type) and -- CPU_Time is equal to Time. + function Convert_Ids is new + Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id); + function clock_gettime (clock_id : Interfaces.C.int; tp : access timespec) @@ -112,13 +117,26 @@ package body Ada.Execution_Time is pragma Import (C, clock_gettime, "clock_gettime"); -- Function from the POSIX.1b Realtime Extensions library + function pthread_getcpuclockid + (tid : Thread_Id; + clock_id : access Interfaces.C.int) + return int; + pragma Import (C, pthread_getcpuclockid, "pthread_getcpuclockid"); + -- Function from the Thread CPU-Time Clocks option + begin if T = Ada.Task_Identification.Null_Task_Id then raise Program_Error; + else + -- Get the CPU clock for the task passed as parameter + + Result := pthread_getcpuclockid + (Get_Thread_Id (Convert_Ids (T)), Clock_Id'Access); + pragma Assert (Result = 0); end if; Result := clock_gettime - (clock_id => CLOCK_THREAD_CPUTIME_ID, tp => TS'Unchecked_Access); + (clock_id => Clock_Id, tp => TS'Unchecked_Access); pragma Assert (Result = 0); return To_CPU_Time (To_Duration (TS)); diff --git a/gcc/ada/a-exetim.ads b/gcc/ada/a-exetim.ads index 1dc5f61f9c0..951c3ed09e9 100644 --- a/gcc/ada/a-exetim.ads +++ b/gcc/ada/a-exetim.ads @@ -24,7 +24,9 @@ with Ada.Task_Identification; with Ada.Real_Time; -package Ada.Execution_Time is +package Ada.Execution_Time with + SPARK_Mode +is pragma Preelaborate; pragma Unimplemented_Unit; @@ -38,46 +40,68 @@ package Ada.Execution_Time is function Clock (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) - return CPU_Time; + Ada.Task_Identification.Current_Task) + return CPU_Time + with + Volatile_Function, + Global => Ada.Real_Time.Clock_Time; function "+" (Left : CPU_Time; - Right : Ada.Real_Time.Time_Span) return CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time + with + Global => null; function "+" (Left : Ada.Real_Time.Time_Span; - Right : CPU_Time) return CPU_Time; + Right : CPU_Time) return CPU_Time + with + Global => null; function "-" (Left : CPU_Time; - Right : Ada.Real_Time.Time_Span) return CPU_Time; + Right : Ada.Real_Time.Time_Span) return CPU_Time + with + Global => null; function "-" (Left : CPU_Time; - Right : CPU_Time) return Ada.Real_Time.Time_Span; - - function "<" (Left, Right : CPU_Time) return Boolean; - function "<=" (Left, Right : CPU_Time) return Boolean; - function ">" (Left, Right : CPU_Time) return Boolean; - function ">=" (Left, Right : CPU_Time) return Boolean; + Right : CPU_Time) return Ada.Real_Time.Time_Span + with + Global => null; + + function "<" (Left, Right : CPU_Time) return Boolean with + Global => null; + function "<=" (Left, Right : CPU_Time) return Boolean with + Global => null; + function ">" (Left, Right : CPU_Time) return Boolean with + Global => null; + function ">=" (Left, Right : CPU_Time) return Boolean with + Global => null; procedure Split (T : CPU_Time; SC : out Ada.Real_Time.Seconds_Count; - TS : out Ada.Real_Time.Time_Span); + TS : out Ada.Real_Time.Time_Span) + with + Global => null; function Time_Of - (SC : Ada.Real_Time.Seconds_Count; - TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero) - return CPU_Time; + (SC : Ada.Real_Time.Seconds_Count; + TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero) + return CPU_Time + with + Global => null; Interrupt_Clocks_Supported : constant Boolean := False; Separate_Interrupt_Clocks_Supported : constant Boolean := False; - function Clock_For_Interrupts return CPU_Time; + function Clock_For_Interrupts return CPU_Time with + Volatile_Function, + Global => Ada.Real_Time.Clock_Time; private + pragma SPARK_Mode (Off); type CPU_Time is new Ada.Real_Time.Time; diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index c3d17189568..2a5ffbcf20e 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -248,11 +248,11 @@ package body Exception_Data is -- Append_Info_Basic_Exception_Information -- --------------------------------------------- - -- To ease the maximum length computation, we define and pull out a couple - -- of string constants: + -- To ease the maximum length computation, we define and pull out some + -- string constants: - BEI_Name_Header : constant String := "Exception name: "; - BEI_Msg_Header : constant String := "Message: "; + BEI_Name_Header : constant String := "raised "; + BEI_Msg_Header : constant String := " : "; BEI_PID_Header : constant String := "PID: "; procedure Append_Info_Basic_Exception_Information @@ -275,13 +275,13 @@ package body Exception_Data is if Name (Name'First) /= '_' then Append_Info_String (BEI_Name_Header, Info, Ptr); Append_Info_String (Name, Info, Ptr); - Append_Info_NL (Info, Ptr); if Exception_Message_Length (X) /= 0 then Append_Info_String (BEI_Msg_Header, Info, Ptr); Append_Info_Exception_Message (X, Info, Ptr); - Append_Info_NL (Info, Ptr); end if; + + Append_Info_NL (Info, Ptr); end if; -- Output PID line if nonzero @@ -498,7 +498,7 @@ package body Exception_Data is is begin return - BEI_Name_Header'Length + Exception_Name_Length (X) + 1 + BEI_Name_Header'Length + Exception_Name_Length (X) + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1 + BEI_PID_Header'Length + 15; end Basic_Exception_Info_Maxlength; diff --git a/gcc/ada/a-exextr.adb b/gcc/ada/a-exextr.adb index 94ec48338f9..2a6f82b83df 100644 --- a/gcc/ada/a-exextr.adb +++ b/gcc/ada/a-exextr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -85,7 +85,11 @@ package body Exception_Traces is if not Excep.Id.Not_Handled_By_Others and then (Exception_Trace = Every_Raise - or else (Exception_Trace = Unhandled_Raise and then Is_Unhandled)) + or else + (Is_Unhandled + and then + (Exception_Trace = Unhandled_Raise + or else Exception_Trace = Unhandled_Raise_In_Main))) then -- Exception trace messages need to be protected when several tasks -- can issue them at the same time. @@ -93,12 +97,15 @@ package body Exception_Traces is Lock_Task.all; To_Stderr (Nline); - if Is_Unhandled then - To_Stderr ("Unhandled "); + if Exception_Trace /= Unhandled_Raise_In_Main then + if Is_Unhandled then + To_Stderr ("Unhandled "); + end if; + + To_Stderr ("Exception raised"); + To_Stderr (Nline); end if; - To_Stderr ("Exception raised"); - To_Stderr (Nline); To_Stderr (Exception_Information (Excep.all)); Unlock_Task.all; end if; @@ -170,8 +177,8 @@ package body Exception_Traces is -- The bulk of exception traces output is centralized in Notify_Exception, -- for both the Handled and Unhandled cases. Extra task specific output is -- triggered in the task wrapper for unhandled occurrences in tasks. It is - -- not performed in this unit to avoid dragging dependencies against the - -- tasking units here. + -- not performed in this unit to avoid dependencies on the tasking units + -- here. -- We used to rely on the output performed by Unhanded_Exception_Terminate -- for the case of an unhandled occurrence in the environment thread, and @@ -191,12 +198,4 @@ package body Exception_Traces is -- Today's solution has the advantage of simplicity and better isolates -- the Exception_Traces machinery. - -- It currently outputs the information about unhandled exceptions twice - -- in the environment thread, once in the notification routine and once in - -- the termination routine. Avoiding the second output is possible but so - -- far has been considered undesirable. It would mean changing the order - -- of outputs between the two runs with or without exception traces, while - -- it seems preferable to only have additional outputs in the former - -- case. - end Exception_Traces; diff --git a/gcc/ada/a-exstat.adb b/gcc/ada/a-exstat.adb index b1c6db3a557..1ff9481eb14 100644 --- a/gcc/ada/a-exstat.adb +++ b/gcc/ada/a-exstat.adb @@ -142,117 +142,125 @@ package body Stream_Attributes is begin if S = "" then return Null_Occurrence; + end if; - else - To := S'First - 2; - Next_String; + To := S'First - 2; + Next_String; - if S (From .. From + 15) /= "Exception name: " then - Bad_EO; - end if; - - X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To))); + if S (From .. From + 6) /= "raised " then + Bad_EO; + end if; - Next_String; + declare + Name_Start : constant Positive := From + 7; + begin + From := Name_Start + 1; - if From <= To and then S (From) = 'M' then - if S (From .. From + 8) /= "Message: " then - Bad_EO; - end if; + while From < To and then S (From) /= ' ' loop + From := From + 1; + end loop; - X.Msg_Length := To - From - 8; - X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To); - Next_String; + X.Id := + Exception_Id (Internal_Exception (S (Name_Start .. From - 1))); + end; - else - X.Msg_Length := 0; + if From <= To then + if S (From .. From + 2) /= " : " then + Bad_EO; end if; - X.Pid := 0; - - if From <= To and then S (From) = 'P' then - if S (From .. From + 3) /= "PID:" then - Bad_EO; - end if; + X.Msg_Length := To - From - 2; + X.Msg (1 .. X.Msg_Length) := S (From + 3 .. To); - From := From + 5; -- skip past PID: space + else + X.Msg_Length := 0; + end if; - while From <= To loop - X.Pid := X.Pid * 10 + - (Character'Pos (S (From)) - Character'Pos ('0')); - From := From + 1; - end loop; + Next_String; + X.Pid := 0; - Next_String; + if From <= To and then S (From) = 'P' then + if S (From .. From + 3) /= "PID:" then + Bad_EO; end if; - X.Num_Tracebacks := 0; - - if From <= To then - if S (From .. To) /= "Call stack traceback locations:" then - Bad_EO; - end if; + From := From + 5; -- skip past PID: space - Next_String; - loop - exit when From > To; + while From <= To loop + X.Pid := X.Pid * 10 + + (Character'Pos (S (From)) - Character'Pos ('0')); + From := From + 1; + end loop; - declare - Ch : Character; - C : Integer_Address; - N : Integer_Address; - - begin - if S (From) /= '0' - or else S (From + 1) /= 'x' - then - Bad_EO; - else - From := From + 2; - end if; + Next_String; + end if; - C := 0; - while From <= To loop - Ch := S (From); + X.Num_Tracebacks := 0; - if Ch in '0' .. '9' then - N := - Character'Pos (S (From)) - Character'Pos ('0'); + if From <= To then + if S (From .. To) /= "Call stack traceback locations:" then + Bad_EO; + end if; - elsif Ch in 'a' .. 'f' then - N := - Character'Pos (S (From)) - Character'Pos ('a') + 10; + Next_String; + loop + exit when From > To; + + declare + Ch : Character; + C : Integer_Address; + N : Integer_Address; + + begin + if S (From) /= '0' + or else S (From + 1) /= 'x' + then + Bad_EO; + else + From := From + 2; + end if; - elsif Ch = ' ' then - From := From + 1; - exit; + C := 0; + while From <= To loop + Ch := S (From); - else - Bad_EO; - end if; + if Ch in '0' .. '9' then + N := + Character'Pos (S (From)) - Character'Pos ('0'); - C := C * 16 + N; + elsif Ch in 'a' .. 'f' then + N := + Character'Pos (S (From)) - Character'Pos ('a') + 10; + elsif Ch = ' ' then From := From + 1; - end loop; + exit; - if X.Num_Tracebacks = Max_Tracebacks then + else Bad_EO; end if; - X.Num_Tracebacks := X.Num_Tracebacks + 1; - X.Tracebacks (X.Num_Tracebacks) := - TBE.TB_Entry_For (To_Address (C)); - end; - end loop; - end if; + C := C * 16 + N; - -- If an exception was converted to a string, it must have - -- already been raised, so flag it accordingly and we are done. + From := From + 1; + end loop; - X.Exception_Raised := True; - return X; + if X.Num_Tracebacks = Max_Tracebacks then + Bad_EO; + end if; + + X.Num_Tracebacks := X.Num_Tracebacks + 1; + X.Tracebacks (X.Num_Tracebacks) := + TBE.TB_Entry_For (To_Address (C)); + end; + end loop; end if; + + -- If an exception was converted to a string, it must have + -- already been raised, so flag it accordingly and we are done. + + X.Exception_Raised := True; + return X; end String_To_EO; end Stream_Attributes; diff --git a/gcc/ada/a-extiin.ads b/gcc/ada/a-extiin.ads index 9677c580edd..e35c32df37d 100644 --- a/gcc/ada/a-extiin.ads +++ b/gcc/ada/a-extiin.ads @@ -14,13 +14,21 @@ ------------------------------------------------------------------------------ with Ada.Interrupts; +with Ada.Real_Time; -package Ada.Execution_Time.Interrupts is +package Ada.Execution_Time.Interrupts with + SPARK_Mode +is pragma Unimplemented_Unit; - function Clock (Interrupt : Ada.Interrupts.Interrupt_Id) return CPU_Time; + function Clock (Interrupt : Ada.Interrupts.Interrupt_ID) return CPU_Time + with + Volatile_Function, + Global => Ada.Real_Time.Clock_Time; - function Supported (Interrupt : Ada.Interrupts.Interrupt_Id) return Boolean; + function Supported (Interrupt : Ada.Interrupts.Interrupt_ID) return Boolean + with + Global => null; end Ada.Execution_Time.Interrupts; diff --git a/gcc/ada/a-finali.adb b/gcc/ada/a-finali.adb index dc2cdf78891..3d6e45bcf6d 100644 --- a/gcc/ada/a-finali.adb +++ b/gcc/ada/a-finali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,48 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body Ada.Finalization is +-- This package does not require a body. We provide a dummy file containing a +-- No_Body pragma so that previous versions of the body (which did exist) will +-- not interfere. - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Controlled) is - pragma Warnings (Off, Object); - begin - null; - end Adjust; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Controlled) is - pragma Warnings (Off, Object); - begin - null; - end Finalize; - - procedure Finalize (Object : in out Limited_Controlled) is - pragma Warnings (Off, Object); - begin - null; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Controlled) is - pragma Warnings (Off, Object); - begin - null; - end Initialize; - - procedure Initialize (Object : in out Limited_Controlled) is - pragma Warnings (Off, Object); - begin - null; - end Initialize; - -end Ada.Finalization; +pragma No_Body; diff --git a/gcc/ada/a-finali.ads b/gcc/ada/a-finali.ads index b65f6eabac7..a1f420efc91 100644 --- a/gcc/ada/a-finali.ads +++ b/gcc/ada/a-finali.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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 -- @@ -43,15 +43,15 @@ package Ada.Finalization is type Controlled is abstract tagged private; pragma Preelaborable_Initialization (Controlled); - procedure Initialize (Object : in out Controlled); - procedure Adjust (Object : in out Controlled); - procedure Finalize (Object : in out Controlled); + procedure Initialize (Object : in out Controlled) is null; + procedure Adjust (Object : in out Controlled) is null; + procedure Finalize (Object : in out Controlled) is null; type Limited_Controlled is abstract tagged limited private; pragma Preelaborable_Initialization (Limited_Controlled); - procedure Initialize (Object : in out Limited_Controlled); - procedure Finalize (Object : in out Limited_Controlled); + procedure Initialize (Object : in out Limited_Controlled) is null; + procedure Finalize (Object : in out Limited_Controlled) is null; private package SFR renames System.Finalization_Root; diff --git a/gcc/ada/a-interr.ads b/gcc/ada/a-interr.ads index fede3bd8542..0ce2ed66d95 100644 --- a/gcc/ada/a-interr.ads +++ b/gcc/ada/a-interr.ads @@ -34,6 +34,7 @@ ------------------------------------------------------------------------------ with System.Interrupts; +with Ada.Task_Identification; package Ada.Interrupts is @@ -41,25 +42,44 @@ package Ada.Interrupts is type Parameterless_Handler is access protected procedure; - function Is_Reserved (Interrupt : Interrupt_ID) return Boolean; + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean with + SPARK_Mode, + Volatile_Function, + Global => Ada.Task_Identification.Tasking_State; - function Is_Attached (Interrupt : Interrupt_ID) return Boolean; + function Is_Attached (Interrupt : Interrupt_ID) return Boolean with + SPARK_Mode, + Volatile_Function, + Global => Ada.Task_Identification.Tasking_State; function Current_Handler - (Interrupt : Interrupt_ID) return Parameterless_Handler; + (Interrupt : Interrupt_ID) return Parameterless_Handler + with + SPARK_Mode => Off, + Global => null; procedure Attach_Handler (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID); + Interrupt : Interrupt_ID) + with + SPARK_Mode => Off, + Global => null; procedure Exchange_Handler (Old_Handler : out Parameterless_Handler; New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID); + Interrupt : Interrupt_ID) + with + SPARK_Mode => Off, + Global => null; - procedure Detach_Handler (Interrupt : Interrupt_ID); + procedure Detach_Handler (Interrupt : Interrupt_ID) with + SPARK_Mode, + Global => (In_Out => Ada.Task_Identification.Tasking_State); - function Reference (Interrupt : Interrupt_ID) return System.Address; + function Reference (Interrupt : Interrupt_ID) return System.Address with + SPARK_Mode => Off, + Global => null; private pragma Inline (Is_Reserved); diff --git a/gcc/ada/a-ngelfu.adb b/gcc/ada/a-ngelfu.adb index f31f685e795..f17d92497ac 100644 --- a/gcc/ada/a-ngelfu.adb +++ b/gcc/ada/a-ngelfu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -127,7 +127,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is then Int_Part := Integer (Float_Type'Base'Truncation (A_Right)); Result := Left ** Int_Part; - Rest := A_Right - Float_Type'Base (Int_Part); + Rest := A_Right - Float_Type'Base (Int_Part); -- Compute with two leading bits of the mantissa using -- square roots. Bound to be better than logarithms, and @@ -148,7 +148,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is Rest := Rest - 0.25; end if; - Result := Result * + Result := Result * Float_Type'Base (Aux.Pow (Double (Left), Double (Rest))); if Right >= 0.0 then @@ -247,7 +247,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is elsif X < 1.0 + Sqrt_Epsilon then return Sqrt (2.0 * (X - 1.0)); - elsif X > 1.0 / Sqrt_Epsilon then + elsif X > 1.0 / Sqrt_Epsilon then return Log (X) + Log_Two; else @@ -540,7 +540,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is if Y < Sqrt_Epsilon then return 1.0; - elsif Y > Log_Inverse_Epsilon then + elsif Y > Log_Inverse_Epsilon then Z := Exp_Strict (Y - Lnv); return (Z + V2minus1 * Z); @@ -832,7 +832,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is if Y < Sqrt_Epsilon then return X; - elsif Y > Log_Inverse_Epsilon then + elsif Y > Log_Inverse_Epsilon then Z := Exp_Strict (Y - Lnv); Z := Z + V2minus1 * Z; diff --git a/gcc/ada/a-ngelfu.ads b/gcc/ada/a-ngelfu.ads index 8afb7332204..8b257b62b41 100644 --- a/gcc/ada/a-ngelfu.ads +++ b/gcc/ada/a-ngelfu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2012-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2012-2015, 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 -- @@ -61,8 +61,7 @@ package Ada.Numerics.Generic_Elementary_Functions is and then (if X >= Float_Type'Succ (0.0) then Sqrt'Result > 0.0); - function Log (X : Float_Type'Base) return Float_Type'Base - with + function Log (X : Float_Type'Base) return Float_Type'Base with Post => (if X = 1.0 then Log'Result = 0.0); function Log (X, Base : Float_Type'Base) return Float_Type'Base with diff --git a/gcc/ada/a-nudira.adb b/gcc/ada/a-nudira.adb index ca81ba51895..251f852579c 100644 --- a/gcc/ada/a-nudira.adb +++ b/gcc/ada/a-nudira.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-nudira.ads b/gcc/ada/a-nudira.ads index 385f33619f3..77501ec63ae 100644 --- a/gcc/ada/a-nudira.ads +++ b/gcc/ada/a-nudira.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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 -- diff --git a/gcc/ada/a-rbtgbk.adb b/gcc/ada/a-rbtgbk.adb index dba3e0bd095..abf7773522a 100644 --- a/gcc/ada/a-rbtgbk.adb +++ b/gcc/ada/a-rbtgbk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -349,12 +349,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is N : Nodes_Type renames Tree.Nodes; begin - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Tree.TC); - if Tree.Length >= Tree.Capacity then + if Checks and then Tree.Length >= Tree.Capacity then raise Capacity_Error with "not enough capacity to insert new item"; end if; diff --git a/gcc/ada/a-rbtgbk.ads b/gcc/ada/a-rbtgbk.ads index a96ef28cff3..1cf1cbc9cc4 100644 --- a/gcc/ada/a-rbtgbk.ads +++ b/gcc/ada/a-rbtgbk.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,7 +35,7 @@ with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; generic with package Tree_Operations is new Generic_Bounded_Operations (<>); - use Tree_Operations.Tree_Types; + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; type Key_Type (<>) is limited private; diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb index 100881bf013..acf2ccb01c0 100644 --- a/gcc/ada/a-rbtgbo.adb +++ b/gcc/ada/a-rbtgbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,7 +39,9 @@ with System; use type System.Address; package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is - pragma Annotate (CodePeer, Skip_Analysis); + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers ----------------------- -- Local Subprograms -- @@ -57,17 +59,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is procedure Clear_Tree (Tree : in out Tree_Type'Class) is begin - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; - - -- The lock status (which monitors "element tampering") always implies - -- that the busy status (which monitors "cursor tampering") is set too; - -- this is a representation invariant. Thus if the busy bit is not set, - -- then the lock bit must not be set either. - - pragma Assert (Tree.Lock = 0); + TC_Check (Tree.TC); Tree.First := 0; Tree.Last := 0; @@ -94,7 +86,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is X := Node; while X /= Tree.Root and then Color (N (X)) = Black loop if X = Left (N (Parent (N (X)))) then - W := Right (N (Parent (N (X)))); + W := Right (N (Parent (N (X)))); if Color (N (W)) = Red then Set_Color (N (W), Black); @@ -138,7 +130,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is else pragma Assert (X = Right (N (Parent (N (X))))); - W := Left (N (Parent (N (X)))); + W := Left (N (Parent (N (X)))); if Color (N (W)) = Red then Set_Color (N (W), Black); @@ -201,10 +193,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is N : Nodes_Type renames Tree.Nodes; begin - if Tree.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Tree.TC); -- If node is not present, return (exception will be raised in caller) @@ -612,17 +601,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is ------------------- function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Count_Type; R_Node : Count_Type; - Result : Boolean; - begin if Left'Address = Right'Address then return True; @@ -639,45 +626,18 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is return True; end if; - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; - Result := True; while L_Node /= 0 loop if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - Result := False; - exit; + return False; end if; L_Node := Next (Left, L_Node); R_Node := Next (Right, R_Node); end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; + return True; end Generic_Equal; ----------------------- @@ -725,7 +685,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is Clear_Tree (Tree); Count_Type'Base'Read (Stream, Len); - if Len < 0 then + if Checks and then Len < 0 then raise Program_Error with "bad container length (corrupt stream)"; end if; @@ -733,7 +693,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is return; end if; - if Len > Tree.Capacity then + if Checks and then Len > Tree.Capacity then raise Constraint_Error with "length exceeds capacity"; end if; diff --git a/gcc/ada/a-rbtgbo.ads b/gcc/ada/a-rbtgbo.ads index b6aae737fd3..4045182343a 100644 --- a/gcc/ada/a-rbtgbo.ads +++ b/gcc/ada/a-rbtgbo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,7 +34,7 @@ with Ada.Streams; use Ada.Streams; generic with package Tree_Types is new Generic_Bounded_Tree_Types (<>); - use Tree_Types; + use Tree_Types, Tree_Types.Implementation; with function Parent (Node : Node_Type) return Count_Type is <>; @@ -61,6 +61,7 @@ generic Color : Color_Type) is <>; package Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is + pragma Annotate (CodePeer, Skip_Analysis); pragma Pure; function Min (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type; diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb index 06a78e922c3..f6daa90ff1d 100644 --- a/gcc/ada/a-rbtgso.adb +++ b/gcc/ada/a-rbtgso.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,10 @@ with System; use type System.Address; package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + ----------------------- -- Local Subprograms -- ----------------------- @@ -44,8 +48,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ----------- procedure Clear (Tree : in out Tree_Type) is - pragma Assert (Tree.Busy = 0); - pragma Assert (Tree.Lock = 0); + use type Helpers.Tamper_Counts; + pragma Assert (Tree.TC = (Busy => 0, Lock => 0)); Root : Node_Access := Tree.Root; pragma Warnings (Off, Root); @@ -84,12 +88,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ---------------- procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt : Node_Access; Src : Node_Access; @@ -97,10 +95,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is begin if Target'Address = Source'Address then - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); Clear (Target); return; @@ -110,10 +105,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); Tgt := Target.First; Src := Source.First; @@ -129,13 +121,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (Tgt, Src) then Compare := -1; elsif Is_Less (Src, Tgt) then @@ -143,22 +132,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -199,11 +172,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); Tree : Tree_Type; @@ -214,12 +184,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -259,22 +223,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end if; end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - return Tree; exception when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - Delete_Tree (Tree.Root); raise; end; @@ -288,12 +240,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is (Target : in out Tree_Type; Source : Tree_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt : Node_Access; Src : Node_Access; @@ -304,10 +250,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + TC_Check (Target.TC); if Source.Length = 0 then Clear (Target); @@ -322,13 +265,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (Tgt, Src) then Compare := -1; elsif Is_Less (Src, Tgt) then @@ -336,22 +276,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -393,11 +317,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); Tree : Tree_Type; @@ -408,12 +329,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -443,22 +358,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end if; end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - return Tree; exception when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - Delete_Tree (Tree.Root); raise; end; @@ -485,40 +388,26 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Subset'Unrestricted_Access.Busy; - LL : Natural renames Subset'Unrestricted_Access.Lock; - - BR : Natural renames Of_Set'Unrestricted_Access.Busy; - LR : Natural renames Of_Set'Unrestricted_Access.Lock; + Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access); + Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access); Subset_Node : Node_Access; Set_Node : Node_Access; - Result : Boolean; - begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - Subset_Node := Subset.First; Set_Node := Of_Set.First; loop if Set_Node = null then - Result := Subset_Node = null; - exit; + return Subset_Node = null; end if; if Subset_Node = null then - Result := True; - exit; + return True; end if; if Is_Less (Subset_Node, Set_Node) then - Result := False; - exit; + return False; end if; if Is_Less (Set_Node, Subset_Node) then @@ -528,24 +417,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Subset_Node := Tree_Operations.Next (Subset_Node); end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end Is_Subset; @@ -563,32 +434,19 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); L_Node : Node_Access; R_Node : Node_Access; - - Result : Boolean; - begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop if L_Node = null or else R_Node = null then - Result := False; - exit; + return False; end if; if Is_Less (L_Node, R_Node) then @@ -598,28 +456,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is R_Node := Tree_Operations.Next (R_Node); else - Result := True; - exit; + return True; end if; end loop; - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - return Result; - - exception - when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - - raise; end; end Overlap; @@ -631,12 +470,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is (Target : in out Tree_Type; Source : Tree_Type) is - BT : Natural renames Target.Busy; - LT : Natural renames Target.Lock; - - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - Tgt : Node_Access; Src : Node_Access; @@ -675,13 +508,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BT := BT + 1; - LT := LT + 1; - - BS := BS + 1; - LS := LS + 1; - if Is_Less (Tgt, Src) then Compare := -1; elsif Is_Less (Src, Tgt) then @@ -689,22 +519,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is else Compare := 0; end if; - - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - exception - when others => - BT := BT - 1; - LT := LT - 1; - - BS := BS - 1; - LS := LS - 1; - - raise; end; if Compare < 0 then @@ -751,11 +565,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); Tree : Tree_Type; @@ -766,12 +577,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is pragma Warnings (Off, Dst_Node); begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - L_Node := Left.First; R_Node := Right.First; loop @@ -826,22 +631,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end if; end loop; - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - return Tree; exception when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - Delete_Tree (Tree.Root); raise; end; @@ -883,24 +676,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- element tampering by a generic actual subprogram. declare - BS : Natural renames Source'Unrestricted_Access.Busy; - LS : Natural renames Source'Unrestricted_Access.Lock; - + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); begin - BS := BS + 1; - LS := LS + 1; - Iterate (Source); - - BS := BS - 1; - LS := LS - 1; - - exception - when others => - BS := BS - 1; - LS := LS - 1; - - raise; end; end Union; @@ -919,11 +697,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end if; declare - BL : Natural renames Left'Unrestricted_Access.Busy; - LL : Natural renames Left'Unrestricted_Access.Lock; - - BR : Natural renames Right'Unrestricted_Access.Busy; - LR : Natural renames Right'Unrestricted_Access.Lock; + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); Tree : Tree_Type := Copy (Left); @@ -951,30 +726,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- Start of processing for Union begin - BL := BL + 1; - LL := LL + 1; - - BR := BR + 1; - LR := LR + 1; - Iterate (Right); - - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - return Tree; exception when others => - BL := BL - 1; - LL := LL - 1; - - BR := BR - 1; - LR := LR - 1; - Delete_Tree (Tree.Root); raise; end; diff --git a/gcc/ada/a-rbtgso.ads b/gcc/ada/a-rbtgso.ads index 26ff8fb849b..9ad296fe090 100644 --- a/gcc/ada/a-rbtgso.ads +++ b/gcc/ada/a-rbtgso.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,7 +35,7 @@ with Ada.Containers.Red_Black_Trees.Generic_Operations; generic with package Tree_Operations is new Generic_Operations (<>); - use Tree_Operations.Tree_Types; + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; with procedure Insert_With_Hint (Dst_Tree : in out Tree_Type; diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb index 1b4d4d8605c..57fcd00bf31 100644 --- a/gcc/ada/a-reatim.adb +++ b/gcc/ada/a-reatim.adb @@ -31,8 +31,11 @@ ------------------------------------------------------------------------------ with System.Tasking; +with Unchecked_Conversion; -package body Ada.Real_Time is +package body Ada.Real_Time with + SPARK_Mode => Off +is --------- -- "*" -- @@ -115,8 +118,20 @@ package body Ada.Real_Time is function "/" (Left, Right : Time_Span) return Integer is pragma Unsuppress (Overflow_Check); pragma Unsuppress (Division_Check); + + -- RM D.8 (27) specifies the effects of operators on Time_Span, and + -- rounding of the division operator in particular, to be the same as + -- effects on integer types. To get the correct rounding we first + -- convert Time_Span to its root type Duration, which is represented as + -- a 64-bit signed integer, and then use integer division. + + type Duration_Rep is range -(2 ** 63) .. +((2 ** 63 - 1)); + + function To_Integer is + new Unchecked_Conversion (Duration, Duration_Rep); begin - return Integer (Duration (Left) / Duration (Right)); + return Integer + (To_Integer (Duration (Left)) / To_Integer (Duration (Right))); end "/"; function "/" (Left : Time_Span; Right : Integer) return Time_Span is diff --git a/gcc/ada/a-reatim.ads b/gcc/ada/a-reatim.ads index 7abbeb843d2..8b341c0b58d 100644 --- a/gcc/ada/a-reatim.ads +++ b/gcc/ada/a-reatim.ads @@ -36,7 +36,12 @@ with System.Task_Primitives.Operations; pragma Elaborate_All (System.Task_Primitives.Operations); -package Ada.Real_Time is +package Ada.Real_Time with + SPARK_Mode, + Abstract_State => (Clock_Time with Synchronous, + External => (Async_Readers, + Async_Writers)) +is pragma Compile_Time_Error (Duration'Size /= 64, @@ -54,44 +59,73 @@ package Ada.Real_Time is Time_Span_Unit : constant Time_Span; Tick : constant Time_Span; - function Clock return Time; - - function "+" (Left : Time; Right : Time_Span) return Time; - function "+" (Left : Time_Span; Right : Time) return Time; - function "-" (Left : Time; Right : Time_Span) return Time; - function "-" (Left : Time; Right : Time) return Time_Span; - - function "<" (Left, Right : Time) return Boolean; - function "<=" (Left, Right : Time) return Boolean; - function ">" (Left, Right : Time) return Boolean; - function ">=" (Left, Right : Time) return Boolean; - - function "+" (Left, Right : Time_Span) return Time_Span; - function "-" (Left, Right : Time_Span) return Time_Span; - function "-" (Right : Time_Span) return Time_Span; - function "*" (Left : Time_Span; Right : Integer) return Time_Span; - function "*" (Left : Integer; Right : Time_Span) return Time_Span; - function "/" (Left, Right : Time_Span) return Integer; - function "/" (Left : Time_Span; Right : Integer) return Time_Span; - - function "abs" (Right : Time_Span) return Time_Span; - - function "<" (Left, Right : Time_Span) return Boolean; - function "<=" (Left, Right : Time_Span) return Boolean; - function ">" (Left, Right : Time_Span) return Boolean; - function ">=" (Left, Right : Time_Span) return Boolean; - - function To_Duration (TS : Time_Span) return Duration; - function To_Time_Span (D : Duration) return Time_Span; - - function Nanoseconds (NS : Integer) return Time_Span; - function Microseconds (US : Integer) return Time_Span; - function Milliseconds (MS : Integer) return Time_Span; - - function Seconds (S : Integer) return Time_Span; + function Clock return Time with + Volatile_Function, + Global => Clock_Time; + + function "+" (Left : Time; Right : Time_Span) return Time with + Global => null; + function "+" (Left : Time_Span; Right : Time) return Time with + Global => null; + function "-" (Left : Time; Right : Time_Span) return Time with + Global => null; + function "-" (Left : Time; Right : Time) return Time_Span with + Global => null; + + function "<" (Left, Right : Time) return Boolean with + Global => null; + function "<=" (Left, Right : Time) return Boolean with + Global => null; + function ">" (Left, Right : Time) return Boolean with + Global => null; + function ">=" (Left, Right : Time) return Boolean with + Global => null; + + function "+" (Left, Right : Time_Span) return Time_Span with + Global => null; + function "-" (Left, Right : Time_Span) return Time_Span with + Global => null; + function "-" (Right : Time_Span) return Time_Span with + Global => null; + function "*" (Left : Time_Span; Right : Integer) return Time_Span with + Global => null; + function "*" (Left : Integer; Right : Time_Span) return Time_Span with + Global => null; + function "/" (Left, Right : Time_Span) return Integer with + Global => null; + function "/" (Left : Time_Span; Right : Integer) return Time_Span with + Global => null; + + function "abs" (Right : Time_Span) return Time_Span with + Global => null; + + function "<" (Left, Right : Time_Span) return Boolean with + Global => null; + function "<=" (Left, Right : Time_Span) return Boolean with + Global => null; + function ">" (Left, Right : Time_Span) return Boolean with + Global => null; + function ">=" (Left, Right : Time_Span) return Boolean with + Global => null; + + function To_Duration (TS : Time_Span) return Duration with + Global => null; + function To_Time_Span (D : Duration) return Time_Span with + Global => null; + + function Nanoseconds (NS : Integer) return Time_Span with + Global => null; + function Microseconds (US : Integer) return Time_Span with + Global => null; + function Milliseconds (MS : Integer) return Time_Span with + Global => null; + + function Seconds (S : Integer) return Time_Span with + Global => null; pragma Ada_05 (Seconds); - function Minutes (M : Integer) return Time_Span; + function Minutes (M : Integer) return Time_Span with + Global => null; pragma Ada_05 (Minutes); type Seconds_Count is new Long_Long_Integer; @@ -103,10 +137,16 @@ package Ada.Real_Time is -- in the case of CodePeer with a target configuration file with a maximum -- integer size of 32, it allows analysis of this unit. - procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span); - function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time; + procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) + with + Global => null; + function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time + with + Global => null; private + pragma SPARK_Mode (Off); + -- Time and Time_Span are represented in 64-bit Duration value in -- nanoseconds. For example, 1 second and 1 nanosecond is represented -- as the stored integer 1_000_000_001. This is for the 64-bit Duration diff --git a/gcc/ada/a-strsup.adb b/gcc/ada/a-strsup.adb index 2ce40ac8cdb..50df7dd48b4 100644 --- a/gcc/ada/a-strsup.adb +++ b/gcc/ada/a-strsup.adb @@ -1744,7 +1744,6 @@ package body Ada.Strings.Superbounded is end loop; end if; - Source.Data := (others => ASCII.NUL); Source.Current_Length := Last - First + 1; Source.Data (1 .. Source.Current_Length) := Temp (First .. Last); end Super_Trim; @@ -1791,13 +1790,6 @@ package body Ada.Strings.Superbounded is Source.Current_Length := Last - First + 1; Source.Data (1 .. Source.Current_Length) := Source.Data (First .. Last); - - for J in Source.Current_Length + 1 .. - Source.Max_Length - loop - Source.Data (J) := ASCII.NUL; - end loop; - return; end if; end if; diff --git a/gcc/ada/a-sytaco.adb b/gcc/ada/a-sytaco.adb index 62bced2adec..ab7c9ad1629 100644 --- a/gcc/ada/a-sytaco.adb +++ b/gcc/ada/a-sytaco.adb @@ -34,7 +34,9 @@ with Ada.Exceptions; with System.Tasking; with System.Task_Primitives.Operations; -package body Ada.Synchronous_Task_Control is +package body Ada.Synchronous_Task_Control with + SPARK_Mode => Off +is ---------------- -- Initialize -- diff --git a/gcc/ada/a-sytaco.ads b/gcc/ada/a-sytaco.ads index a6bd84e1a2b..bf1ab8720c9 100644 --- a/gcc/ada/a-sytaco.ads +++ b/gcc/ada/a-sytaco.ads @@ -36,22 +36,37 @@ with System.Task_Primitives; with Ada.Finalization; +with Ada.Task_Identification; -package Ada.Synchronous_Task_Control is +package Ada.Synchronous_Task_Control with + SPARK_Mode +is pragma Preelaborate; -- In accordance with Ada 2005 AI-362 type Suspension_Object is limited private; - procedure Set_True (S : in out Suspension_Object); + procedure Set_True (S : in out Suspension_Object) with + Global => null, + Depends => (S => null, + null => S); - procedure Set_False (S : in out Suspension_Object); + procedure Set_False (S : in out Suspension_Object) with + Global => null, + Depends => (S => null, + null => S); - function Current_State (S : Suspension_Object) return Boolean; + function Current_State (S : Suspension_Object) return Boolean with + Volatile_Function, + Global => Ada.Task_Identification.Tasking_State; - procedure Suspend_Until_True (S : in out Suspension_Object); + procedure Suspend_Until_True (S : in out Suspension_Object) with + Global => null, + Depends => (S => null, + null => S); private + pragma SPARK_Mode (Off); procedure Initialize (S : in out Suspension_Object); -- Initialization for Suspension_Object diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index e60ef19f9bb..203d19ed676 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,7 +37,11 @@ with System.Storage_Elements; use System.Storage_Elements; with System.WCh_Con; use System.WCh_Con; with System.WCh_StW; use System.WCh_StW; -pragma Elaborate_All (System.HTable); +pragma Elaborate (System.HTable); +-- Elaborate needed instead of Elaborate_All to avoid elaboration cycles +-- when polling is turned on. This is safe because HTable doesn't do anything +-- at elaboration time; it just contains a generic package we want to +-- instantiate. package body Ada.Tags is diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 53a541b3b78..1d247aac51a 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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 -- @@ -526,9 +526,6 @@ private -- ancestor is the parent of the type represented by tag T. This function -- assumes that _size is always in slot one of the dispatch table. - pragma Export (Ada, Parent_Size, "ada__tags__parent_size"); - -- This procedure is used in s-finimp and is thus exported manually - procedure Register_Interface_Offset (This : System.Address; Interface_T : Tag; diff --git a/gcc/ada/a-taside.adb b/gcc/ada/a-taside.adb index ac4473e4c1a..b916c7609a1 100644 --- a/gcc/ada/a-taside.adb +++ b/gcc/ada/a-taside.adb @@ -45,7 +45,9 @@ with System.Tasking.Utilities; pragma Warnings (On); -package body Ada.Task_Identification is +package body Ada.Task_Identification with + SPARK_Mode => Off +is use System.Parameters; diff --git a/gcc/ada/a-taside.ads b/gcc/ada/a-taside.ads index d736b0317d0..ee39ec3e5a9 100644 --- a/gcc/ada/a-taside.ads +++ b/gcc/ada/a-taside.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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 -- @@ -36,7 +36,12 @@ with System; with System.Tasking; -package Ada.Task_Identification is +package Ada.Task_Identification with + SPARK_Mode, + Abstract_State => (Tasking_State with Synchronous, + External => (Async_Readers, + Async_Writers)) +is pragma Preelaborate; -- In accordance with Ada 2005 AI-362 @@ -45,30 +50,44 @@ package Ada.Task_Identification is Null_Task_Id : constant Task_Id; - function "=" (Left, Right : Task_Id) return Boolean; + function "=" (Left, Right : Task_Id) return Boolean with + Global => null; pragma Inline ("="); - function Image (T : Task_Id) return String; + function Image (T : Task_Id) return String with + Global => null; - function Current_Task return Task_Id; + function Current_Task return Task_Id with + Volatile_Function, + Global => Tasking_State; pragma Inline (Current_Task); - function Environment_Task return Task_Id; + function Environment_Task return Task_Id with + SPARK_Mode => Off, + Global => null; pragma Inline (Environment_Task); - procedure Abort_Task (T : Task_Id); + procedure Abort_Task (T : Task_Id) with + Global => null; pragma Inline (Abort_Task); -- Note: parameter is mode IN, not IN OUT, per AI-00101 - function Is_Terminated (T : Task_Id) return Boolean; + function Is_Terminated (T : Task_Id) return Boolean with + Volatile_Function, + Global => Tasking_State; pragma Inline (Is_Terminated); - function Is_Callable (T : Task_Id) return Boolean; + function Is_Callable (T : Task_Id) return Boolean with + Volatile_Function, + Global => Tasking_State; pragma Inline (Is_Callable); - function Activation_Is_Complete (T : Task_Id) return Boolean; + function Activation_Is_Complete (T : Task_Id) return Boolean with + Volatile_Function, + Global => Tasking_State; private + pragma SPARK_Mode (Off); type Task_Id is new System.Tasking.Task_Id; diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb index 2ebec616c6d..dc0b45358fe 100644 --- a/gcc/ada/a-textio.adb +++ b/gcc/ada/a-textio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -693,9 +693,7 @@ package body Ada.Text_IO is Item : out String; Last : out Natural) is separate; -- The implementation of Ada.Text_IO.Get_Line is split into a subunit so - -- that different implementations can be used on different systems. In - -- particular the standard implementation uses low level stuff that is - -- not appropriate for the JVM and .NET implementations. + -- that different implementations can be used on different systems. procedure Get_Line (Item : out String; diff --git a/gcc/ada/a-tienio.adb b/gcc/ada/a-tienio.adb index b4e1e893283..e98f410eee9 100644 --- a/gcc/ada/a-tienio.adb +++ b/gcc/ada/a-tienio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -97,7 +97,7 @@ package body Ada.Text_IO.Enumeration_IO is begin -- Ensure that Item is valid before attempting to retrieve the Image, to -- prevent the possibility of out-of-bounds addressing of index or image - -- tables. Units in the run-time library are normally compiled with + -- tables. Units in the run-time library are normally compiled with -- checks suppressed, which includes instantiated generics. if not Item'Valid then diff --git a/gcc/ada/a-tifiio.adb b/gcc/ada/a-tifiio.adb index ff4bb2c4e18..2fd8b5421f2 100644 --- a/gcc/ada/a-tifiio.adb +++ b/gcc/ada/a-tifiio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -231,7 +231,7 @@ package body Ada.Text_IO.Fixed_IO is -- The final expression for D is - -- D := Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1))); + -- D := Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1))); -- For Y and Z the following expressions can be derived: diff --git a/gcc/ada/a-tigeli.adb b/gcc/ada/a-tigeli.adb index c23cd347869..8273b050775 100644 --- a/gcc/ada/a-tigeli.adb +++ b/gcc/ada/a-tigeli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,7 +32,7 @@ -- The implementation of Ada.Text_IO.Get_Line is split into a subunit so that -- different implementations can be used on different systems. This is the -- standard implementation (it uses low level features not suitable for use --- in the JVM or .NET implementations). +-- on virtual machines). with System; use System; with System.Storage_Elements; use System.Storage_Elements; diff --git a/gcc/ada/adadecode.c b/gcc/ada/adadecode.c index d6935ca206b..8c9c7ab7a88 100644 --- a/gcc/ada/adadecode.c +++ b/gcc/ada/adadecode.c @@ -368,17 +368,6 @@ __gnat_decode (const char *coded_name, char *ada_name, int verbose) extern "C" { #endif -#ifdef IN_RTS -char * -ada_demangle (const char *coded_name) -{ - char ada_name[2048]; - - __gnat_decode (coded_name, ada_name, 0); - return xstrdup (ada_name); -} -#endif - void get_encoding (const char *coded_name, char *encoding) { diff --git a/gcc/ada/adadecode.h b/gcc/ada/adadecode.h index 73dda238a09..03848e74d83 100644 --- a/gcc/ada/adadecode.h +++ b/gcc/ada/adadecode.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 2001-2011, Free Software Foundation, Inc. * + * Copyright (C) 2001-2015, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -51,11 +51,6 @@ extern void __gnat_decode (const char *, char *, int); from the encoded form. The Ada encodings are described in exp_dbug.ads. */ extern void get_encoding (const char *, char *); -/* ada_demangle is added for COMPATIBILITY ONLY. It has the name of the - function used in the binutils and GDB. Always consider using __gnat_decode - instead of ada_demangle. Caller must free the pointer returned. */ -extern char *ada_demangle (const char *); - #ifdef __cplusplus } #endif diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 813d2c1f7d6..5fef49cc4c0 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -168,6 +168,7 @@ UINT CurrentCCSEncoding; #if defined (_WIN32) #include <process.h> +#include <signal.h> #include <dir.h> #include <windows.h> #include <accctrl.h> @@ -552,7 +553,8 @@ __gnat_get_file_names_case_sensitive (void) { /* By default, we suppose filesystems aren't case sensitive on Windows and Darwin (but they are on arm-darwin). */ -#if defined (WINNT) || (defined (__APPLE__) && !defined (__arm__)) +#if defined (WINNT) \ + || (defined (__APPLE__) && !(defined (__arm__) || defined (__arm64__))) file_names_case_sensitive_cache = 0; #else file_names_case_sensitive_cache = 1; @@ -982,8 +984,8 @@ __gnat_open_new_temp (char *path, int fmode) strcpy (path, "GNAT-XXXXXX"); #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \ - || defined (__linux__) || defined (__GLIBC__)) && !defined (__vxworks) \ - || defined (__DragonFly__) + || defined (__linux__) || defined (__GLIBC__) || defined (__ANDROID__) \ + || defined (__DragonFly__)) && !defined (__vxworks) return mkstemp (path); #elif defined (__Lynx__) mktemp (path); @@ -2786,16 +2788,19 @@ __gnat_locate_exec_on_path (char *exec_name) apath_val = (char *) alloca (EXPAND_BUFFER_SIZE); WS2SC (apath_val, wapath_val, EXPAND_BUFFER_SIZE); - return __gnat_locate_exec (exec_name, apath_val); #else char *path_val = getenv ("PATH"); - if (path_val == NULL) return NULL; + /* If PATH is not defined, proceed with __gnat_locate_exec anyway, so we can + find files that contain directory names. */ + + if (path_val == NULL) path_val = ""; apath_val = (char *) alloca (strlen (path_val) + 1); strcpy (apath_val, path_val); - return __gnat_locate_exec (exec_name, apath_val); #endif + + return __gnat_locate_exec (exec_name, apath_val); } /* Dummy functions for Osint import for non-VMS systems. @@ -2897,6 +2902,8 @@ char __gnat_environment_char = '$'; mode = 1 : In this mode, time stamps and read/write/execute attributes are copied. + mode = 2 : In this mode, only read/write/execute attributes are copied + Returns 0 if operation was successful and -1 in case of error. */ int @@ -2916,39 +2923,46 @@ __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED, char *to ATTRIBUTE_UNUSED, S2WSC (wfrom, from, GNAT_MAX_PATH_LEN + 2); S2WSC (wto, to, GNAT_MAX_PATH_LEN + 2); - /* retrieve from times */ + /* Do we need to copy the timestamp ? */ - hfrom = CreateFile - (wfrom, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + if (mode != 2) { + /* retrieve from times */ - if (hfrom == INVALID_HANDLE_VALUE) - return -1; + hfrom = CreateFile + (wfrom, GENERIC_READ, 0, NULL, OPEN_EXISTING, + FILE_ATTRIBUTE_NORMAL, NULL); - res = GetFileTime (hfrom, &fct, &flat, &flwt); + if (hfrom == INVALID_HANDLE_VALUE) + return -1; - CloseHandle (hfrom); + res = GetFileTime (hfrom, &fct, &flat, &flwt); - if (res == 0) - return -1; + CloseHandle (hfrom); - /* retrieve from times */ + if (res == 0) + return -1; - hto = CreateFile - (wto, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + /* retrieve from times */ - if (hto == INVALID_HANDLE_VALUE) - return -1; + hto = CreateFile + (wto, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, + FILE_ATTRIBUTE_NORMAL, NULL); - res = SetFileTime (hto, NULL, &flat, &flwt); + if (hto == INVALID_HANDLE_VALUE) + return -1; - CloseHandle (hto); + res = SetFileTime (hto, NULL, &flat, &flwt); - if (res == 0) - return -1; + CloseHandle (hto); + if (res == 0) + return -1; + } + + /* Do we need to copy the permissions ? */ /* Set file attributes in full mode. */ - if (mode == 1) + if (mode != 0) { DWORD attribs = GetFileAttributes (wfrom); @@ -2966,26 +2980,24 @@ __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED, char *to ATTRIBUTE_UNUSED, GNAT_STRUCT_STAT fbuf; struct utimbuf tbuf; - if (GNAT_STAT (from, &fbuf) == -1) - { - return -1; - } + if (GNAT_STAT (from, &fbuf) == -1) { + return -1; + } - tbuf.actime = fbuf.st_atime; - tbuf.modtime = fbuf.st_mtime; + /* Do we need to copy timestamp ? */ + if (mode != 2) { + tbuf.actime = fbuf.st_atime; + tbuf.modtime = fbuf.st_mtime; - if (utime (to, &tbuf) == -1) - { - return -1; - } + if (utime (to, &tbuf) == -1) { + return -1; + } + } - if (mode == 1) - { - if (chmod (to, fbuf.st_mode) == -1) - { + /* Do we need to copy file permissions ? */ + if (mode != 0 && (chmod (to, fbuf.st_mode) == -1)) { return -1; - } - } + } return 0; #endif @@ -3060,17 +3072,7 @@ __gnat_sals_init_using_constructors (void) #endif } -#if defined (__ANDROID__) - -#include <pthread.h> - -void * -__gnat_lwp_self (void) -{ - return (void *) pthread_self (); -} - -#elif defined (__linux__) +#if defined (__linux__) || defined (__ANDROID__) /* There is no function in the glibc to retrieve the LWP of the current thread. We need to do a system call in order to retrieve this information. */ @@ -3080,7 +3082,9 @@ __gnat_lwp_self (void) { return (void *) syscall (__NR_gettid); } +#endif +#if defined (__linux__) #include <sched.h> /* glibc versions earlier than 2.7 do not define the routines to handle @@ -3187,6 +3191,35 @@ __gnat_get_executable_load_address (void) #endif } +void +__gnat_kill (int pid, int sig, int close ATTRIBUTE_UNUSED) +{ +#if defined(_WIN32) + HANDLE h = OpenProcess (PROCESS_ALL_ACCESS, FALSE, pid); + if (h == NULL) + return; + if (sig == 9) + { + TerminateProcess (h, 0); + __gnat_win32_remove_handle (NULL, pid); + } + else if (sig == SIGINT) + GenerateConsoleCtrlEvent (CTRL_C_EVENT, pid); + else if (sig == SIGBREAK) + GenerateConsoleCtrlEvent (CTRL_BREAK_EVENT, pid); + /* ??? The last two alternatives don't really work. SIGBREAK requires setting + up process groups at start time which we don't do; treating SIGINT is just + not possible apparently. So we really only support signal 9. Fortunately + that's all we use in GNAT.Expect */ + + CloseHandle (h); +#elif defined (__vxworks) + /* Not implemented */ +#else + kill (pid, sig); +#endif +} + #ifdef __cplusplus } #endif diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 83bf2b99065..c777d39d569 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -385,7 +385,7 @@ package body ALI is Write_Str ("make sure you are using consistent versions " & -- Split the following line so that it can easily be transformed for - -- e.g. JVM/.NET back-ends where the compiler has a different name. + -- other back-ends where the compiler might have a different name. "of gcc/gnatbind"); diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index bf01f77a609..4398f922805 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -154,7 +154,8 @@ package body Aspects is pragma Assert (Has_Aspects (N)); pragma Assert (Nkind (N) in N_Body_Stub - or else Nkind_In (N, N_Package_Body, + or else Nkind_In (N, N_Entry_Body, + N_Package_Body, N_Protected_Body, N_Subprogram_Body, N_Task_Body)); @@ -337,8 +338,7 @@ package body Aspects is procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id) is procedure Relocate_Aspect (Asp : Node_Id); - -- Asp denotes an aspect specification of node From. Relocate the Asp to - -- the aspect specifications of node To (if any). + -- Move aspect specification Asp to the aspect specifications of node To --------------------- -- Relocate_Aspect -- @@ -359,8 +359,8 @@ package body Aspects is Set_Has_Aspects (To); end if; - -- Remove the aspect from node From's aspect specifications and - -- append it to node To. + -- Remove the aspect from its original owner and relocate it to node + -- To. Remove (Asp); Append (Asp, Asps); @@ -402,6 +402,23 @@ package body Aspects is Relocate_Aspect (Asp); end if; + -- When moving or merging aspects from a single concurrent type + -- declaration, relocate only those aspects that may apply to the + -- anonymous object created for the type. + + -- Note: It is better to use Is_Single_Concurrent_Type_Declaration + -- here, but Aspects and Sem_Util have incompatible licenses. + + elsif Nkind_In + (Original_Node (From), N_Single_Protected_Declaration, + N_Single_Task_Declaration) + then + Asp_Id := Get_Aspect_Id (Asp); + + if Aspect_On_Anonymous_Object_OK (Asp_Id) then + Relocate_Aspect (Asp); + end if; + -- Default case - relocate the aspect to its new owner else @@ -427,6 +444,7 @@ package body Aspects is Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean := (N_Abstract_Subprogram_Declaration => True, N_Component_Declaration => True, + N_Entry_Body => True, N_Entry_Declaration => True, N_Exception_Declaration => True, N_Exception_Renaming_Declaration => True, @@ -505,6 +523,7 @@ package body Aspects is Aspect_Attach_Handler => Aspect_Attach_Handler, Aspect_Bit_Order => Aspect_Bit_Order, Aspect_Component_Size => Aspect_Component_Size, + Aspect_Constant_After_Elaboration => Aspect_Constant_After_Elaboration, Aspect_Constant_Indexing => Aspect_Constant_Indexing, Aspect_Contract_Cases => Aspect_Contract_Cases, Aspect_Convention => Aspect_Convention, @@ -563,6 +582,7 @@ package body Aspects is Aspect_Pre => Aspect_Pre, Aspect_Precondition => Aspect_Pre, Aspect_Predicate => Aspect_Predicate, + Aspect_Predicate_Failure => Aspect_Predicate_Failure, Aspect_Preelaborate => Aspect_Preelaborate, Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization, Aspect_Priority => Aspect_Priority, @@ -609,6 +629,7 @@ package body Aspects is Aspect_Volatile => Aspect_Volatile, Aspect_Volatile_Components => Aspect_Volatile_Components, Aspect_Volatile_Full_Access => Aspect_Volatile_Full_Access, + Aspect_Volatile_Function => Aspect_Volatile_Function, Aspect_Warnings => Aspect_Warnings, Aspect_Write => Aspect_Write); diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index e2156224dee..5e042ada03e 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -78,9 +78,12 @@ package Aspects is Aspect_Address, Aspect_Alignment, Aspect_Annotate, -- GNAT + Aspect_Async_Readers, -- GNAT + Aspect_Async_Writers, -- GNAT Aspect_Attach_Handler, Aspect_Bit_Order, Aspect_Component_Size, + Aspect_Constant_After_Elaboration, -- GNAT Aspect_Constant_Indexing, Aspect_Contract_Cases, -- GNAT Aspect_Convention, @@ -95,6 +98,8 @@ package Aspects is Aspect_Dimension_System, -- GNAT Aspect_Dispatching_Domain, Aspect_Dynamic_Predicate, + Aspect_Effective_Reads, -- GNAT + Aspect_Effective_Writes, -- GNAT Aspect_Extensions_Visible, -- GNAT Aspect_External_Name, Aspect_External_Tag, @@ -120,6 +125,7 @@ package Aspects is Aspect_Pre, Aspect_Precondition, Aspect_Predicate, -- GNAT + Aspect_Predicate_Failure, Aspect_Priority, Aspect_Read, Aspect_Refined_Depends, -- GNAT @@ -144,6 +150,7 @@ package Aspects is Aspect_Unsuppress, Aspect_Value_Size, -- GNAT Aspect_Variable_Indexing, + Aspect_Volatile_Function, -- GNAT Aspect_Warnings, -- GNAT Aspect_Write, @@ -166,15 +173,11 @@ package Aspects is -- the aspect value is inherited from the parent, in which case, we do -- not allow False if we inherit a True value from the parent. - Aspect_Async_Readers, -- GNAT - Aspect_Async_Writers, -- GNAT Aspect_Asynchronous, Aspect_Atomic, Aspect_Atomic_Components, Aspect_Disable_Controlled, -- GNAT Aspect_Discard_Names, - Aspect_Effective_Reads, -- GNAT - Aspect_Effective_Writes, -- GNAT Aspect_Export, Aspect_Favor_Top_Level, -- GNAT Aspect_Independent, @@ -226,44 +229,46 @@ package Aspects is -- The following array identifies all implementation defined aspects Implementation_Defined_Aspect : constant array (Aspect_Id) of Boolean := - (Aspect_Abstract_State => True, - Aspect_Annotate => True, - Aspect_Async_Readers => True, - Aspect_Async_Writers => True, - Aspect_Contract_Cases => True, - Aspect_Depends => True, - Aspect_Dimension => True, - Aspect_Dimension_System => True, - Aspect_Effective_Reads => True, - Aspect_Effective_Writes => True, - Aspect_Extensions_Visible => True, - Aspect_Favor_Top_Level => True, - Aspect_Ghost => True, - Aspect_Global => True, - Aspect_Inline_Always => True, - Aspect_Invariant => True, - Aspect_Lock_Free => True, - Aspect_Object_Size => True, - Aspect_Persistent_BSS => True, - Aspect_Predicate => True, - Aspect_Pure_Function => True, - Aspect_Remote_Access_Type => True, - Aspect_Scalar_Storage_Order => True, - Aspect_Shared => True, - Aspect_Simple_Storage_Pool => True, - Aspect_Simple_Storage_Pool_Type => True, - Aspect_Suppress_Debug_Info => True, - Aspect_Suppress_Initialization => True, - Aspect_Thread_Local_Storage => True, - Aspect_Test_Case => True, - Aspect_Universal_Aliasing => True, - Aspect_Universal_Data => True, - Aspect_Unmodified => True, - Aspect_Unreferenced => True, - Aspect_Unreferenced_Objects => True, - Aspect_Value_Size => True, - Aspect_Warnings => True, - others => False); + (Aspect_Abstract_State => True, + Aspect_Annotate => True, + Aspect_Async_Readers => True, + Aspect_Async_Writers => True, + Aspect_Constant_After_Elaboration => True, + Aspect_Contract_Cases => True, + Aspect_Depends => True, + Aspect_Dimension => True, + Aspect_Dimension_System => True, + Aspect_Effective_Reads => True, + Aspect_Effective_Writes => True, + Aspect_Extensions_Visible => True, + Aspect_Favor_Top_Level => True, + Aspect_Ghost => True, + Aspect_Global => True, + Aspect_Inline_Always => True, + Aspect_Invariant => True, + Aspect_Lock_Free => True, + Aspect_Object_Size => True, + Aspect_Persistent_BSS => True, + Aspect_Predicate => True, + Aspect_Pure_Function => True, + Aspect_Remote_Access_Type => True, + Aspect_Scalar_Storage_Order => True, + Aspect_Shared => True, + Aspect_Simple_Storage_Pool => True, + Aspect_Simple_Storage_Pool_Type => True, + Aspect_Suppress_Debug_Info => True, + Aspect_Suppress_Initialization => True, + Aspect_Thread_Local_Storage => True, + Aspect_Test_Case => True, + Aspect_Universal_Aliasing => True, + Aspect_Universal_Data => True, + Aspect_Unmodified => True, + Aspect_Unreferenced => True, + Aspect_Unreferenced_Objects => True, + Aspect_Value_Size => True, + Aspect_Volatile_Function => True, + Aspect_Warnings => True, + others => False); -- The following array indicates aspects for which multiple occurrences of -- the same aspect attached to the same declaration are allowed. @@ -289,7 +294,7 @@ package Aspects is -- aspect is enabled. If it is False, the aspect is disabled. subtype Boolean_Aspects is - Aspect_Id range Aspect_Async_Readers .. Aspect_Id'Last; + Aspect_Id range Aspect_Asynchronous .. Aspect_Id'Last; subtype Pre_Post_Aspects is Aspect_Id range Aspect_Post .. Aspect_Precondition; @@ -305,82 +310,89 @@ package Aspects is -- The following array indicates what argument type is required Aspect_Argument : constant array (Aspect_Id) of Aspect_Expression := - (No_Aspect => Optional_Expression, - Aspect_Abstract_State => Expression, - Aspect_Address => Expression, - Aspect_Alignment => Expression, - Aspect_Annotate => Expression, - Aspect_Attach_Handler => Expression, - Aspect_Bit_Order => Expression, - Aspect_Component_Size => Expression, - Aspect_Constant_Indexing => Name, - Aspect_Contract_Cases => Expression, - Aspect_Convention => Name, - Aspect_CPU => Expression, - Aspect_Default_Component_Value => Expression, - Aspect_Default_Initial_Condition => Optional_Expression, - Aspect_Default_Iterator => Name, - Aspect_Default_Storage_Pool => Expression, - Aspect_Default_Value => Expression, - Aspect_Depends => Expression, - Aspect_Dimension => Expression, - Aspect_Dimension_System => Expression, - Aspect_Dispatching_Domain => Expression, - Aspect_Dynamic_Predicate => Expression, - Aspect_Extensions_Visible => Optional_Expression, - Aspect_External_Name => Expression, - Aspect_External_Tag => Expression, - Aspect_Ghost => Optional_Expression, - Aspect_Global => Expression, - Aspect_Implicit_Dereference => Name, - Aspect_Initial_Condition => Expression, - Aspect_Initializes => Expression, - Aspect_Input => Name, - Aspect_Interrupt_Priority => Expression, - Aspect_Invariant => Expression, - Aspect_Iterable => Expression, - Aspect_Iterator_Element => Name, - Aspect_Link_Name => Expression, - Aspect_Linker_Section => Expression, - Aspect_Machine_Radix => Expression, - Aspect_Object_Size => Expression, - Aspect_Obsolescent => Optional_Expression, - Aspect_Output => Name, - Aspect_Part_Of => Expression, - Aspect_Post => Expression, - Aspect_Postcondition => Expression, - Aspect_Pre => Expression, - Aspect_Precondition => Expression, - Aspect_Predicate => Expression, - Aspect_Priority => Expression, - Aspect_Read => Name, - Aspect_Refined_Depends => Expression, - Aspect_Refined_Global => Expression, - Aspect_Refined_Post => Expression, - Aspect_Refined_State => Expression, - Aspect_Relative_Deadline => Expression, - Aspect_Scalar_Storage_Order => Expression, - Aspect_Simple_Storage_Pool => Name, - Aspect_Size => Expression, - Aspect_Small => Expression, - Aspect_SPARK_Mode => Optional_Name, - Aspect_Static_Predicate => Expression, - Aspect_Storage_Pool => Name, - Aspect_Storage_Size => Expression, - Aspect_Stream_Size => Expression, - Aspect_Suppress => Name, - Aspect_Synchronization => Name, - Aspect_Test_Case => Expression, - Aspect_Type_Invariant => Expression, - Aspect_Unimplemented => Optional_Expression, - Aspect_Unsuppress => Name, - Aspect_Value_Size => Expression, - Aspect_Variable_Indexing => Name, - Aspect_Warnings => Name, - Aspect_Write => Name, - - Boolean_Aspects => Optional_Expression, - Library_Unit_Aspects => Optional_Expression); + (No_Aspect => Optional_Expression, + Aspect_Abstract_State => Expression, + Aspect_Address => Expression, + Aspect_Alignment => Expression, + Aspect_Annotate => Expression, + Aspect_Async_Readers => Optional_Expression, + Aspect_Async_Writers => Optional_Expression, + Aspect_Attach_Handler => Expression, + Aspect_Bit_Order => Expression, + Aspect_Component_Size => Expression, + Aspect_Constant_After_Elaboration => Optional_Expression, + Aspect_Constant_Indexing => Name, + Aspect_Contract_Cases => Expression, + Aspect_Convention => Name, + Aspect_CPU => Expression, + Aspect_Default_Component_Value => Expression, + Aspect_Default_Initial_Condition => Optional_Expression, + Aspect_Default_Iterator => Name, + Aspect_Default_Storage_Pool => Expression, + Aspect_Default_Value => Expression, + Aspect_Depends => Expression, + Aspect_Dimension => Expression, + Aspect_Dimension_System => Expression, + Aspect_Dispatching_Domain => Expression, + Aspect_Dynamic_Predicate => Expression, + Aspect_Effective_Reads => Optional_Expression, + Aspect_Effective_Writes => Optional_Expression, + Aspect_Extensions_Visible => Optional_Expression, + Aspect_External_Name => Expression, + Aspect_External_Tag => Expression, + Aspect_Ghost => Optional_Expression, + Aspect_Global => Expression, + Aspect_Implicit_Dereference => Name, + Aspect_Initial_Condition => Expression, + Aspect_Initializes => Expression, + Aspect_Input => Name, + Aspect_Interrupt_Priority => Expression, + Aspect_Invariant => Expression, + Aspect_Iterable => Expression, + Aspect_Iterator_Element => Name, + Aspect_Link_Name => Expression, + Aspect_Linker_Section => Expression, + Aspect_Machine_Radix => Expression, + Aspect_Object_Size => Expression, + Aspect_Obsolescent => Optional_Expression, + Aspect_Output => Name, + Aspect_Part_Of => Expression, + Aspect_Post => Expression, + Aspect_Postcondition => Expression, + Aspect_Pre => Expression, + Aspect_Precondition => Expression, + Aspect_Predicate => Expression, + Aspect_Predicate_Failure => Expression, + Aspect_Priority => Expression, + Aspect_Read => Name, + Aspect_Refined_Depends => Expression, + Aspect_Refined_Global => Expression, + Aspect_Refined_Post => Expression, + Aspect_Refined_State => Expression, + Aspect_Relative_Deadline => Expression, + Aspect_Scalar_Storage_Order => Expression, + Aspect_Simple_Storage_Pool => Name, + Aspect_Size => Expression, + Aspect_Small => Expression, + Aspect_SPARK_Mode => Optional_Name, + Aspect_Static_Predicate => Expression, + Aspect_Storage_Pool => Name, + Aspect_Storage_Size => Expression, + Aspect_Stream_Size => Expression, + Aspect_Suppress => Name, + Aspect_Synchronization => Name, + Aspect_Test_Case => Expression, + Aspect_Type_Invariant => Expression, + Aspect_Unimplemented => Optional_Expression, + Aspect_Unsuppress => Name, + Aspect_Value_Size => Expression, + Aspect_Variable_Indexing => Name, + Aspect_Volatile_Function => Optional_Expression, + Aspect_Warnings => Name, + Aspect_Write => Name, + + Boolean_Aspects => Optional_Expression, + Library_Unit_Aspects => Optional_Expression); ----------------------------------------- -- Table Linking Names and Aspect_Id's -- @@ -403,6 +415,7 @@ package Aspects is Aspect_Attach_Handler => Name_Attach_Handler, Aspect_Bit_Order => Name_Bit_Order, Aspect_Component_Size => Name_Component_Size, + Aspect_Constant_After_Elaboration => Name_Constant_After_Elaboration, Aspect_Constant_Indexing => Name_Constant_Indexing, Aspect_Contract_Cases => Name_Contract_Cases, Aspect_Convention => Name_Convention, @@ -461,6 +474,7 @@ package Aspects is Aspect_Pre => Name_Pre, Aspect_Precondition => Name_Precondition, Aspect_Predicate => Name_Predicate, + Aspect_Predicate_Failure => Name_Predicate_Failure, Aspect_Preelaborable_Initialization => Name_Preelaborable_Initialization, Aspect_Preelaborate => Name_Preelaborate, Aspect_Priority => Name_Priority, @@ -507,6 +521,7 @@ package Aspects is Aspect_Volatile => Name_Volatile, Aspect_Volatile_Components => Name_Volatile_Components, Aspect_Volatile_Full_Access => Name_Volatile_Full_Access, + Aspect_Volatile_Function => Name_Volatile_Function, Aspect_Warnings => Name_Warnings, Aspect_Write => Name_Write); @@ -575,7 +590,7 @@ package Aspects is -- constructs. To handle forward references in such aspects, the compiler -- delays the analysis of their respective pragmas by collecting them in -- N_Contract nodes. The pragmas are then analyzed at the end of the - -- declarative region which contains the related construct. For details, + -- declarative region containing the related construct. For details, -- see routines Analyze_xxx_In_Decl_Part. -- The following shows which aspects are delayed. There are three cases: @@ -664,6 +679,7 @@ package Aspects is Aspect_Pre => Always_Delay, Aspect_Precondition => Always_Delay, Aspect_Predicate => Always_Delay, + Aspect_Predicate_Failure => Always_Delay, Aspect_Preelaborable_Initialization => Always_Delay, Aspect_Preelaborate => Always_Delay, Aspect_Priority => Always_Delay, @@ -700,6 +716,7 @@ package Aspects is Aspect_Annotate => Never_Delay, Aspect_Async_Readers => Never_Delay, Aspect_Async_Writers => Never_Delay, + Aspect_Constant_After_Elaboration => Never_Delay, Aspect_Contract_Cases => Never_Delay, Aspect_Convention => Never_Delay, Aspect_Default_Initial_Condition => Never_Delay, @@ -726,6 +743,7 @@ package Aspects is Aspect_Synchronization => Never_Delay, Aspect_Test_Case => Never_Delay, Aspect_Unimplemented => Never_Delay, + Aspect_Volatile_Function => Never_Delay, Aspect_Warnings => Never_Delay, Aspect_Alignment => Rep_Aspect, @@ -780,7 +798,7 @@ package Aspects is -- package body P with SPARK_Mode is ...; -- The table should be synchronized with Pragma_On_Body_Or_Stub_OK in unit - -- Sem_Prag if the aspects below are implemented by a pragma. + -- Sem_Prag. Aspect_On_Body_Or_Stub_OK : constant array (Aspect_Id) of Boolean := (Aspect_Refined_Depends => True, @@ -790,6 +808,26 @@ package Aspects is Aspect_Warnings => True, others => False); + ------------------------------------------------------------------- + -- Handling of Aspects Specifications on Single Concurrent Types -- + ------------------------------------------------------------------- + + -- Certain aspects that appear on the following nodes + + -- N_Single_Protected_Declaration + -- N_Single_Task_Declaration + + -- are treated as if they apply to the anonymous object produced by the + -- analysis of a single concurrent type. The following table lists all + -- aspects that should apply to the anonymous object. The table should + -- be synchronized with Pragma_On_Anonymous_Object_OK in unit Sem_Prag. + + Aspect_On_Anonymous_Object_OK : constant array (Aspect_Id) of Boolean := + (Aspect_Depends => True, + Aspect_Global => True, + Aspect_Part_Of => True, + others => False); + --------------------------------------------------- -- Handling of Aspect Specifications in the Tree -- --------------------------------------------------- @@ -847,10 +885,14 @@ package Aspects is procedure Move_Or_Merge_Aspects (From : Node_Id; To : Node_Id); -- Relocate the aspect specifications of node From to node To. If To has - -- aspects, the aspects of From are added to the aspects of To. If From has - -- no aspects, the routine has no effect. When From denotes a subprogram - -- body stub that also acts as a spec, the only aspects relocated to node - -- To are those from table Aspect_On_Body_Or_Stub_OK and preconditions. + -- aspects, the aspects of From are appended to the aspects of To. If From + -- has no aspects, the routine has no effect. Special behavior: + -- * When node From denotes a subprogram body stub without a previous + -- declaration, the only aspects relocated to node To are those found + -- in table Aspect_On_Body_Or_Stub_OK. + -- * When node From denotes a single synchronized type declaration, the + -- only aspects relocated to node To are those found in table + -- Aspect_On_Anonymous_Object_OK. function Permits_Aspect_Specifications (N : Node_Id) return Boolean; -- Returns True if the node N is a declaration node that permits aspect diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 870d7ffa79e..b03da914165 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -828,6 +828,7 @@ package body Atree is end case; Set_Chars (New_Ent, Chars (E)); + -- Set_Comes_From_Source (New_Ent, Comes_From_Source (E)); return New_Ent; end Copy_Entity; @@ -1125,6 +1126,60 @@ package body Atree is end Ekind_In; function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind; + V7 : Entity_Kind; + V8 : Entity_Kind; + V9 : Entity_Kind; + V10 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6 or else + T = V7 or else + T = V8 or else + T = V9 or else + T = V10; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind; + V7 : Entity_Kind; + V8 : Entity_Kind; + V9 : Entity_Kind; + V10 : Entity_Kind; + V11 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6 or else + T = V7 or else + T = V8 or else + T = V9 or else + T = V10 or else + T = V11; + end Ekind_In; + + function Ekind_In (E : Entity_Id; V1 : Entity_Kind; V2 : Entity_Kind) return Boolean @@ -1224,6 +1279,42 @@ package body Atree is return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9); end Ekind_In; + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind; + V7 : Entity_Kind; + V8 : Entity_Kind; + V9 : Entity_Kind; + V10 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind; + V7 : Entity_Kind; + V8 : Entity_Kind; + V9 : Entity_Kind; + V10 : Entity_Kind; + V11 : Entity_Kind) return Boolean + is + begin + return + Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10, V11); + end Ekind_In; + ------------------------ -- Set_Reporting_Proc -- ------------------------ @@ -2905,6 +2996,16 @@ package body Atree is return List_Id (Nodes.Table (N + 4).Field7); end List25; + function List38 (N : Node_Id) return List_Id is + begin + return List_Id (Nodes.Table (N + 6).Field8); + end List38; + + function List39 (N : Node_Id) return List_Id is + begin + return List_Id (Nodes.Table (N + 6).Field9); + end List39; + function Elist1 (N : Node_Id) return Elist_Id is pragma Assert (N <= Nodes.Last); Value : constant Union_Id := Nodes.Table (N).Field1; @@ -3092,6 +3193,17 @@ package body Atree is end if; end Elist26; + function Elist36 (N : Node_Id) return Elist_Id is + pragma Assert (Nkind (N) in N_Entity); + Value : constant Union_Id := Nodes.Table (N + 6).Field6; + begin + if Value = 0 then + return No_Elist; + else + return Elist_Id (Value); + end if; + end Elist36; + function Name1 (N : Node_Id) return Name_Id is begin pragma Assert (N <= Nodes.Last); @@ -5758,6 +5870,18 @@ package body Atree is Nodes.Table (N + 4).Field7 := Union_Id (Val); end Set_List25; + procedure Set_List38 (N : Node_Id; Val : List_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field8 := Union_Id (Val); + end Set_List38; + + procedure Set_List39 (N : Node_Id; Val : List_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field9 := Union_Id (Val); + end Set_List39; + procedure Set_Elist1 (N : Node_Id; Val : Elist_Id) is begin Nodes.Table (N).Field1 := Union_Id (Val); @@ -5855,6 +5979,12 @@ package body Atree is Nodes.Table (N + 4).Field8 := Union_Id (Val); end Set_Elist26; + procedure Set_Elist36 (N : Node_Id; Val : Elist_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 6).Field6 := Union_Id (Val); + end Set_Elist36; + procedure Set_Name1 (N : Node_Id; Val : Name_Id) is begin pragma Assert (N <= Nodes.Last); diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 155cde3d947..56763c74d27 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -803,6 +803,33 @@ package Atree is V9 : Entity_Kind) return Boolean; function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind; + V7 : Entity_Kind; + V8 : Entity_Kind; + V9 : Entity_Kind; + V10 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind; + V7 : Entity_Kind; + V8 : Entity_Kind; + V9 : Entity_Kind; + V10 : Entity_Kind; + V11 : Entity_Kind) return Boolean; + + function Ekind_In (T : Entity_Kind; V1 : Entity_Kind; V2 : Entity_Kind) return Boolean; @@ -870,6 +897,33 @@ package Atree is V8 : Entity_Kind; V9 : Entity_Kind) return Boolean; + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind; + V7 : Entity_Kind; + V8 : Entity_Kind; + V9 : Entity_Kind; + V10 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind; + V7 : Entity_Kind; + V8 : Entity_Kind; + V9 : Entity_Kind; + V10 : Entity_Kind; + V11 : Entity_Kind) return Boolean; + pragma Inline (Ekind_In); -- Inline all above functions @@ -1355,6 +1409,12 @@ package Atree is function List25 (N : Node_Id) return List_Id; pragma Inline (List25); + function List38 (N : Node_Id) return List_Id; + pragma Inline (List38); + + function List39 (N : Node_Id) return List_Id; + pragma Inline (List39); + function Elist1 (N : Node_Id) return Elist_Id; pragma Inline (Elist1); @@ -1406,6 +1466,9 @@ package Atree is function Elist26 (N : Node_Id) return Elist_Id; pragma Inline (Elist26); + function Elist36 (N : Node_Id) return Elist_Id; + pragma Inline (Elist36); + function Name1 (N : Node_Id) return Name_Id; pragma Inline (Name1); @@ -2706,6 +2769,12 @@ package Atree is procedure Set_List25 (N : Node_Id; Val : List_Id); pragma Inline (Set_List25); + procedure Set_List38 (N : Node_Id; Val : List_Id); + pragma Inline (Set_List38); + + procedure Set_List39 (N : Node_Id; Val : List_Id); + pragma Inline (Set_List39); + procedure Set_Elist1 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist1); @@ -2757,6 +2826,9 @@ package Atree is procedure Set_Elist26 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist26); + procedure Set_Elist36 (N : Node_Id; Val : Elist_Id); + pragma Inline (Set_Elist36); + procedure Set_Name1 (N : Node_Id; Val : Name_Id); pragma Inline (Set_Name1); diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index e296b8adb69..f92961ee7ec 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -505,6 +505,8 @@ extern Node_Id Current_Error_Node; #define List10(N) Field10 (N) #define List14(N) Field14 (N) #define List25(N) Field25 (N) +#define List38(N) Field38 (N) +#define List39(N) Field39 (N) #define Elist1(N) Field1 (N) #define Elist2(N) Field2 (N) @@ -523,6 +525,7 @@ extern Node_Id Current_Error_Node; #define Elist24(N) Field24 (N) #define Elist25(N) Field25 (N) #define Elist26(N) Field26 (N) +#define Elist36(N) Field36 (N) #define Name1(N) Field1 (N) #define Name2(N) Field2 (N) diff --git a/gcc/ada/back_end.ads b/gcc/ada/back_end.ads index c58f0805f20..ee8ab456a66 100644 --- a/gcc/ada/back_end.ads +++ b/gcc/ada/back_end.ads @@ -82,8 +82,7 @@ package Back_End is -- -- This is a no-op with the gcc back-end (the object file is generated by -- the assembler afterwards), but is needed for back-ends that directly - -- generate the final object file (such as the .NET backend) so that the - -- object file's timestamp is correct when compared with the corresponding - -- ali file by gnatmake. + -- generate the final object file so that the object file's timestamp is + -- correct when compared with the corresponding ali file by gnatmake. end Back_End; diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb index 172e1300377..2cae8402475 100644 --- a/gcc/ada/bcheck.adb +++ b/gcc/ada/bcheck.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -639,9 +639,9 @@ package body Bcheck is -- Check_Consistent_Normalize_Scalars -- ---------------------------------------- - -- The rule is that if any unit is compiled with Normalized_Scalars, + -- The rule is that if any unit is compiled with Normalize_Scalars, -- then all other units in the partition must also be compiled with - -- Normalized_Scalars in effect. + -- Normalize_Scalars in effect. -- There is some issue as to whether this consistency check is desirable, -- it is certainly required at the moment by the RM. We should keep a watch diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 798db09dd40..098a1aeab14 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -35,6 +35,7 @@ with Osint; use Osint; with Osint.B; use Osint.B; with Output; use Output; with Rident; use Rident; +with Stringt; use Stringt; with Table; use Table; with Targparm; use Targparm; with Types; use Types; @@ -43,6 +44,7 @@ with System.OS_Lib; use System.OS_Lib; with System.WCh_Con; use System.WCh_Con; with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; +with GNAT.HTable; package body Bindgen is @@ -86,9 +88,18 @@ package body Bindgen is -- attach interrupt handlers at the end of the elaboration when partition -- elaboration policy is sequential. + System_BB_CPU_Primitives_Multiprocessors_Used : Boolean := False; + -- Flag indicating wether the unit System.BB.CPU_Primitives.Multiprocessors + -- is in the closure of the partiation. This is set by procedure + -- Resolve_Binder_Options, and it is used to call a procedure that starts + -- slave processors. + Lib_Final_Built : Boolean := False; -- Flag indicating whether the finalize_library rountine has been built + Bind_Env_String_Built : Boolean := False; + -- Flag indicating whether a bind environment string has been built + CodePeer_Wrapper_Name : constant String := "call_main_subprogram"; -- For CodePeer, introduce a wrapper subprogram which calls the -- user-defined main subprogram. @@ -124,6 +135,22 @@ package body Bindgen is Table_Increment => 200, Table_Name => "PSD_Pragma_Settings"); + ---------------------------- + -- Bind_Environment Table -- + ---------------------------- + + subtype Header_Num is Int range 0 .. 36; + + function Hash (Nam : Name_Id) return Header_Num; + + package Bind_Environment is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Name_Id, + No_Element => No_Name, + Key => Name_Id, + Hash => Hash, + Equal => "="); + ---------------------- -- Run-Time Globals -- ---------------------- @@ -145,6 +172,7 @@ package body Bindgen is -- Num_Interrupt_States : Integer; -- Unreserve_All_Interrupts : Integer; -- Exception_Tracebacks : Integer; + -- Exception_Tracebacks_Symbolic : Integer; -- Detect_Blocking : Integer; -- Default_Stack_Size : Integer; -- Leap_Seconds_Support : Integer; @@ -214,10 +242,13 @@ package body Bindgen is -- Unreserve_All_Interrupts is set to one if at least one unit in the -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise. - -- Exception_Tracebacks is set to one if the -E parameter was present - -- in the bind and to zero otherwise. Note that on some targets exception - -- tracebacks are provided by default, so a value of zero for this - -- parameter does not necessarily mean no trace backs are available. + -- Exception_Tracebacks is set to one if the -Ea or -E parameter was + -- present in the bind and to zero otherwise. Note that on some targets + -- exception tracebacks are provided by default, so a value of zero for + -- this parameter does not necessarily mean no trace backs are available. + + -- Exception_Tracebacks_Symbolic is set to one if the -Es parameter was + -- present in the bind and to zero otherwise. -- Detect_Blocking indicates whether pragma Detect_Blocking is active or -- not. A value of zero indicates that the pragma is not present, while a @@ -246,6 +277,9 @@ package body Bindgen is procedure Gen_Adafinal; -- Generate the Adafinal procedure + procedure Gen_Bind_Env_String; + -- Generate the bind environment buffer + procedure Gen_CodePeer_Wrapper; -- For CodePeer, generate wrapper which calls user-defined main subprogram @@ -352,13 +386,10 @@ package body Bindgen is -- characters of S. The caller must ensure that these characters do in fact -- exist in the Statement_Buffer. - type Qualification_Mode is (Dollar_Sign, Dot, Double_Underscores); - - procedure Set_Unit_Name (Mode : Qualification_Mode := Double_Underscores); + procedure Set_Unit_Name; -- Given a unit name in the Name_Buffer, copy it into Statement_Buffer, -- starting at the Last + 1 position and update Last past the value. - -- Depending on parameter Mode, a dot (.) can be qualified into double - -- underscores (__), a dollar sign ($) or left as is. + -- Each dot (.) will be qualified into double underscores (__). procedure Set_Unit_Number (U : Unit_Id); -- Sets unit number (first unit is 1, leading zeroes output to line up all @@ -372,6 +403,10 @@ package body Bindgen is -- First writes its argument (using Set_String (S)), then writes out the -- contents of statement buffer up to Last, and reset Last to 0 + procedure Write_Bind_Line (S : String); + -- Write S (an LF-terminated string) to the binder file (for use with + -- Set_Special_Output). + ------------------ -- Gen_Adafinal -- ------------------ @@ -380,10 +415,7 @@ package body Bindgen is begin WBI (" procedure " & Ada_Final_Name.all & " is"); - if VM_Target = No_VM - and Bind_Main_Program - and not CodePeer_Mode - then + if Bind_Main_Program and not CodePeer_Mode then WBI (" procedure s_stalib_adafinal;"); Set_String (" pragma Import (C, s_stalib_adafinal, "); Set_String ("""system__standard_library__adafinal"");"); @@ -406,10 +438,10 @@ package body Bindgen is WBI (" Runtime_Finalize;"); - -- On non-virtual machine targets, finalization is done differently - -- depending on whether this is the main program or a library. + -- By default (real targets), finalization is done differently depending + -- on whether this is the main program or a library. - if VM_Target = No_VM and then not CodePeer_Mode then + if not CodePeer_Mode then if Bind_Main_Program then WBI (" s_stalib_adafinal;"); elsif Lib_Final_Built then @@ -418,9 +450,9 @@ package body Bindgen is WBI (" null;"); end if; - -- Pragma Import C cannot be used on virtual machine targets, therefore - -- call the runtime finalization routine directly. Similarly in CodePeer - -- mode, where imported functions are ignored. + -- Pragma Import C cannot be used on virtual targets, therefore call the + -- runtime finalization routine directly in CodePeer mode, where + -- imported functions are ignored. else WBI (" System.Standard_Library.Adafinal;"); @@ -443,12 +475,11 @@ package body Bindgen is -- of __gnat_finalize_library_objects. This is declared at library -- level for compatibility with the type used in System.Soft_Links. -- The import of the soft link which performs library-level object - -- finalization is not needed for VM targets; regular Ada is used in + -- finalization does not work for CodePeer, so regular Ada is used in -- that case. For restricted run-time libraries (ZFP and Ravenscar) -- tasks are non-terminating, so we do not want finalization. if not Suppress_Standard_Library_On_Target - and then VM_Target = No_VM and then not CodePeer_Mode and then not Configurable_Run_Time_On_Target then @@ -511,6 +542,13 @@ package body Bindgen is WBI (" procedure Activate_All_Tasks_Sequential;"); WBI (" pragma Import (C, Activate_All_Tasks_Sequential," & " ""__gnat_activate_all_tasks"");"); + WBI (""); + end if; + + if System_BB_CPU_Primitives_Multiprocessors_Used then + WBI (" procedure Start_Slave_CPUs;"); + WBI (" pragma Import (C, Start_Slave_CPUs," & + " ""__gnat_start_slave_cpus"");"); end if; WBI (" begin"); @@ -586,10 +624,16 @@ package body Bindgen is WBI (" pragma Import (C, Unreserve_All_Interrupts, " & """__gl_unreserve_all_interrupts"");"); - if Exception_Tracebacks then + if Exception_Tracebacks or Exception_Tracebacks_Symbolic then WBI (" Exception_Tracebacks : Integer;"); WBI (" pragma Import (C, Exception_Tracebacks, " & """__gl_exception_tracebacks"");"); + + if Exception_Tracebacks_Symbolic then + WBI (" Exception_Tracebacks_Symbolic : Integer;"); + WBI (" pragma Import (C, Exception_Tracebacks_Symbolic, " & + """__gl_exception_tracebacks_symbolic"");"); + end if; end if; WBI (" Detect_Blocking : Integer;"); @@ -601,6 +645,9 @@ package body Bindgen is WBI (" Leap_Seconds_Support : Integer;"); WBI (" pragma Import (C, Leap_Seconds_Support, " & """__gl_leap_seconds_support"");"); + WBI (" Bind_Env_Addr : System.Address;"); + WBI (" pragma Import (C, Bind_Env_Addr, " & + """__gl_bind_env_addr"");"); -- Import entry point for elaboration time signal handler -- installation, and indication of if it's been called previously. @@ -638,12 +685,10 @@ package body Bindgen is " ""__gnat_activate_all_tasks"");"); end if; - -- The import of the soft link which performs library-level object - -- finalization is not needed for VM targets; regular Ada is used in - -- that case. For restricted run-time libraries (ZFP and Ravenscar) + -- For restricted run-time libraries (ZFP and Ravenscar) -- tasks are non-terminating, so we do not want finalization. - if VM_Target = No_VM and then not Configurable_Run_Time_On_Target then + if not Configurable_Run_Time_On_Target then WBI (""); WBI (" Finalize_Library_Objects : No_Param_Proc;"); WBI (" pragma Import (C, Finalize_Library_Objects, " & @@ -662,38 +707,6 @@ package body Bindgen is """__gnat_initialize_stack_limit"");"); end if; - -- Special processing when main program is CIL function/procedure - - if VM_Target = CLI_Target - and then Bind_Main_Program - and then not No_Main_Subprogram - then - WBI (""); - - -- Function case, use Set_Exit_Status to report the returned - -- status code, since that is the only mechanism available. - - if ALIs.Table (ALIs.First).Main_Program = Func then - WBI (" Result : Integer;"); - WBI (" procedure Set_Exit_Status (Code : Integer);"); - WBI (" pragma Import (C, Set_Exit_Status, " & - """__gnat_set_exit_status"");"); - WBI (""); - WBI (" function Ada_Main_Program return Integer;"); - - -- Procedure case - - else - WBI (" procedure Ada_Main_Program;"); - end if; - - Get_Name_String (Units.Table (First_Unit_Entry).Uname); - Name_Len := Name_Len - 2; - WBI (" pragma Import (CIL, Ada_Main_Program, """ - & Name_Buffer (1 .. Name_Len) & "." - & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);"); - end if; - -- When dispatching domains are used then we need to signal it -- before calling the main procedure. @@ -704,6 +717,8 @@ package body Bindgen is & """__gnat_freeze_dispatching_domains"");"); end if; + -- Start of processing for Adainit + WBI (" begin"); WBI (" if Is_Elaborated then"); WBI (" return;"); @@ -803,8 +818,12 @@ package body Bindgen is Set_Char (';'); Write_Statement_Buffer; - if Exception_Tracebacks then + if Exception_Tracebacks or Exception_Tracebacks_Symbolic then WBI (" Exception_Tracebacks := 1;"); + + if Exception_Tracebacks_Symbolic then + WBI (" Exception_Tracebacks_Symbolic := 1;"); + end if; end if; Set_String (" Detect_Blocking := "); @@ -834,20 +853,14 @@ package body Bindgen is Set_String (";"); Write_Statement_Buffer; - -- Generate call to Install_Handler + if Bind_Env_String_Built then + WBI (" Bind_Env_Addr := Bind_Env'Address;"); + end if; - -- In .NET, when binding with -z, we don't install the signal handler - -- to let the caller handle the last exception handler. + -- Generate call to Install_Handler WBI (""); - - if VM_Target /= CLI_Target - or else Bind_Main_Program - then - WBI (" Runtime_Initialize (1);"); - else - WBI (" Runtime_Initialize (0);"); - end if; + WBI (" Runtime_Initialize (1);"); end if; -- Generate call to set Initialize_Scalar values if active @@ -888,37 +901,22 @@ package body Bindgen is if CodePeer_Mode then null; - -- On virtual machine targets, or on non-virtual machine ones if this - -- is the main program case, attach finalize_library to the soft link. - -- Do it only when not using a restricted run time, in which case tasks - -- are non-terminating, so we do not want library-level finalization. + -- If this is the main program case, attach finalize_library to the soft + -- link. Do it only when not using a restricted run time, in which case + -- tasks are non-terminating, so we do not want library-level + -- finalization. - elsif (VM_Target /= No_VM or else Bind_Main_Program) + elsif Bind_Main_Program and then not Configurable_Run_Time_On_Target and then not Suppress_Standard_Library_On_Target then WBI (""); - if VM_Target = No_VM then - if Lib_Final_Built then - Set_String (" Finalize_Library_Objects := "); - Set_String ("finalize_library'access;"); - else - Set_String (" Finalize_Library_Objects := null;"); - end if; - - -- On VM targets use regular Ada to set the soft link - + if Lib_Final_Built then + Set_String (" Finalize_Library_Objects := "); + Set_String ("finalize_library'access;"); else - if Lib_Final_Built then - Set_String - (" System.Soft_Links.Finalize_Library_Objects"); - Set_String (" := finalize_library'access;"); - else - Set_String - (" System.Soft_Links.Finalize_Library_Objects"); - Set_String (" := null;"); - end if; + Set_String (" Finalize_Library_Objects := null;"); end if; Write_Statement_Buffer; @@ -959,28 +957,69 @@ package body Bindgen is end if; end if; - -- Case of main program is CIL function or procedure + if System_BB_CPU_Primitives_Multiprocessors_Used then + WBI (" Start_Slave_CPUs;"); + end if; - if VM_Target = CLI_Target - and then Bind_Main_Program - and then not No_Main_Subprogram - then - -- For function case, use Set_Exit_Status to set result + WBI (" end " & Ada_Init_Name.all & ";"); + WBI (""); + end Gen_Adainit; - if ALIs.Table (ALIs.First).Main_Program = Func then - WBI (" Result := Ada_Main_Program;"); - WBI (" Set_Exit_Status (Result);"); + ------------------------- + -- Gen_Bind_Env_String -- + ------------------------- - -- Procedure case + procedure Gen_Bind_Env_String is + KN, VN : Name_Id := No_Name; + Amp : Character; - else - WBI (" Ada_Main_Program;"); - end if; + procedure Write_Name_With_Len (Nam : Name_Id); + -- Write Nam as a string literal, prefixed with one + -- character encoding Nam's length. + + ------------------------- + -- Write_Name_With_Len -- + ------------------------- + + procedure Write_Name_With_Len (Nam : Name_Id) is + begin + Get_Name_String (Nam); + + Start_String; + Store_String_Char (Character'Val (Name_Len)); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + + Write_String_Table_Entry (End_String); + end Write_Name_With_Len; + + -- Start of processing for Gen_Bind_Env_String + + begin + Bind_Environment.Get_First (KN, VN); + if VN = No_Name then + return; end if; - WBI (" end " & Ada_Init_Name.all & ";"); - WBI (""); - end Gen_Adainit; + Set_Special_Output (Write_Bind_Line'Access); + + WBI (" Bind_Env : aliased constant String :="); + Amp := ' '; + while VN /= No_Name loop + Write_Str (" " & Amp & ' '); + Write_Name_With_Len (KN); + Write_Str (" & "); + Write_Name_With_Len (VN); + Write_Eol; + + Bind_Environment.Get_Next (KN, VN); + Amp := '&'; + end loop; + WBI (" & ASCII.NUL;"); + + Set_Special_Output (null); + + Bind_Env_String_Built := True; + end Gen_Bind_Env_String; -------------------------- -- Gen_CodePeer_Wrapper -- @@ -1188,37 +1227,24 @@ package body Bindgen is Set_String (" "); Get_Decoded_Name_String_With_Brackets (U.Uname); - if VM_Target = CLI_Target and then U.Unit_Kind /= 's' then - if Name_Buffer (Name_Len) = 's' then - Name_Buffer (Name_Len - 1 .. Name_Len + 12) := - "_pkg'elab_spec"; - else - Name_Buffer (Name_Len - 1 .. Name_Len + 12) := - "_pkg'elab_body"; - end if; - - Name_Len := Name_Len + 12; + if Name_Buffer (Name_Len) = 's' then + Name_Buffer (Name_Len - 1 .. Name_Len + 8) := + "'elab_spec"; + Name_Len := Name_Len + 8; - else - if Name_Buffer (Name_Len) = 's' then - Name_Buffer (Name_Len - 1 .. Name_Len + 8) := - "'elab_spec"; - Name_Len := Name_Len + 8; - - -- Special case in CodePeer mode for subprogram bodies - -- which correspond to CodePeer 'Elab_Subp_Body special - -- init procedure. + -- Special case in CodePeer mode for subprogram bodies + -- which correspond to CodePeer 'Elab_Subp_Body special + -- init procedure. - elsif U.Unit_Kind = 's' and CodePeer_Mode then - Name_Buffer (Name_Len - 1 .. Name_Len + 13) := - "'elab_subp_body"; - Name_Len := Name_Len + 13; + elsif U.Unit_Kind = 's' and CodePeer_Mode then + Name_Buffer (Name_Len - 1 .. Name_Len + 13) := + "'elab_subp_body"; + Name_Len := Name_Len + 13; - else - Name_Buffer (Name_Len - 1 .. Name_Len + 8) := - "'elab_body"; - Name_Len := Name_Len + 8; - end if; + else + Name_Buffer (Name_Len - 1 .. Name_Len + 8) := + "'elab_body"; + Name_Len := Name_Len + 8; end if; Set_Casing (U.Icasing); @@ -1294,51 +1320,10 @@ package body Bindgen is Set_String (" "); Set_String ("E"); Set_Unit_Number (Unum); - - case VM_Target is - when No_VM | JVM_Target => - Set_String (" : Short_Integer; pragma Import (Ada, "); - when CLI_Target => - Set_String (" : Short_Integer; pragma Import (CIL, "); - end case; - - Set_String ("E"); + Set_String (" : Short_Integer; pragma Import (Ada, E"); Set_Unit_Number (Unum); Set_String (", """); Get_Name_String (U.Uname); - - -- In the case of JGNAT we need to emit an Import name that - -- includes the class name (using '$' separators in the case - -- of a child unit name). - - if VM_Target /= No_VM then - for J in 1 .. Name_Len - 2 loop - if VM_Target = CLI_Target - or else Name_Buffer (J) /= '.' - then - Set_Char (Name_Buffer (J)); - else - Set_String ("$"); - end if; - end loop; - - if VM_Target /= CLI_Target or else U.Unit_Kind = 's' then - Set_String ("."); - else - Set_String ("_pkg."); - end if; - - -- If the unit name is very long, then split the - -- Import link name across lines using "&" (occurs - -- in some C2 tests). - - if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then - Set_String (""" &"); - Write_Statement_Buffer; - Set_String (" """); - end if; - end if; - Set_Unit_Name; Set_String ("_E"");"); Write_Statement_Buffer; @@ -1467,46 +1452,15 @@ package body Bindgen is Write_Statement_Buffer; -- Generate: - -- pragma Import (CIL, F<Count>, - -- "xx.yy_pkg.xx__yy__finalize_[body|spec]"); - -- -- for .NET targets - - -- pragma Import (Java, F<Count>, - -- "xx$yy.xx__yy__finalize_[body|spec]"); - -- -- for JVM targets - -- pragma Import (Ada, F<Count>, -- "xx__yy__finalize_[body|spec]"); - -- -- for default targets - - if VM_Target = CLI_Target then - Set_String (" pragma Import (CIL, F"); - elsif VM_Target = JVM_Target then - Set_String (" pragma Import (Java, F"); - else - Set_String (" pragma Import (Ada, F"); - end if; + Set_String (" pragma Import (Ada, F"); Set_Int (Count); Set_String (", """); -- Perform name construction - -- .NET xx.yy_pkg.xx__yy__finalize - - if VM_Target = CLI_Target then - Set_Unit_Name (Mode => Dot); - Set_String ("_pkg."); - - -- JVM xx$yy.xx__yy__finalize - - elsif VM_Target = JVM_Target then - Set_Unit_Name (Mode => Dollar_Sign); - Set_Char ('.'); - end if; - - -- Default xx__yy__finalize - Set_Unit_Name; Set_String ("__finalize_"); @@ -1586,31 +1540,17 @@ package body Bindgen is -- raised an exception. In that case import the actual exception -- and the routine necessary to raise it. - if VM_Target = No_VM then - WBI (" declare"); - WBI (" procedure Reraise_Library_Exception_If_Any;"); - - Set_String (" pragma Import (Ada, "); - Set_String ("Reraise_Library_Exception_If_Any, "); - Set_String ("""__gnat_reraise_library_exception_if_any"");"); - Write_Statement_Buffer; - - WBI (" begin"); - WBI (" Reraise_Library_Exception_If_Any;"); - WBI (" end;"); - - -- VM-specific code, use regular Ada to produce the desired behavior - - else - WBI (" if System.Soft_Links.Library_Exception_Set then"); + WBI (" declare"); + WBI (" procedure Reraise_Library_Exception_If_Any;"); - Set_String (" Ada.Exceptions.Reraise_Occurrence ("); - Set_String ("System.Soft_Links.Library_Exception);"); - Write_Statement_Buffer; - - WBI (" end if;"); - end if; + Set_String (" pragma Import (Ada, "); + Set_String ("Reraise_Library_Exception_If_Any, "); + Set_String ("""__gnat_reraise_library_exception_if_any"");"); + Write_Statement_Buffer; + WBI (" begin"); + WBI (" Reraise_Library_Exception_If_Any;"); + WBI (" end;"); WBI (" end finalize_library;"); WBI (""); end if; @@ -1980,18 +1920,16 @@ package body Bindgen is -- Add a "-Ldir" for each directory in the object path - if VM_Target /= CLI_Target then - for J in 1 .. Nb_Dir_In_Obj_Search_Path loop - declare - Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J); - begin - Name_Len := 0; - Add_Str_To_Name_Buffer ("-L"); - Add_Str_To_Name_Buffer (Dir.all); - Write_Linker_Option; - end; - end loop; - end if; + for J in 1 .. Nb_Dir_In_Obj_Search_Path loop + declare + Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J); + begin + Name_Len := 0; + Add_Str_To_Name_Buffer ("-L"); + Add_Str_To_Name_Buffer (Dir.all); + Write_Linker_Option; + end; + end loop; if not (Opt.No_Run_Time_Mode or Opt.No_Stdlib) then Name_Len := 0; @@ -2117,12 +2055,6 @@ package body Bindgen is Set_PSD_Pragma_Table; - -- For JGNAT the main program is already generated by the compiler - - if VM_Target = JVM_Target then - Bind_Main_Program := False; - end if; - -- Override time slice value if -T switch is set if Time_Slice_Set then @@ -2175,6 +2107,7 @@ package body Bindgen is -- of the Ada 2005 or Ada 2012 constructs are needed by the binder file. WBI ("pragma Ada_95;"); + WBI ("pragma Warnings (Off);"); -- If we are operating in Restrictions (No_Exception_Handlers) mode, -- then we need to make sure that the binder program is compiled with @@ -2219,57 +2152,50 @@ package body Bindgen is if not Suppress_Standard_Library_On_Target then if CodePeer_Mode then WBI ("with System.Standard_Library;"); - elsif VM_Target /= No_VM then - WBI ("with System.Soft_Links;"); - WBI ("with System.Standard_Library;"); end if; end if; WBI ("package " & Ada_Main & " is"); - WBI (" pragma Warnings (Off);"); -- Main program case if Bind_Main_Program then - if VM_Target = No_VM then + -- Generate argc/argv stuff unless suppressed + + if Command_Line_Args_On_Target + or not Configurable_Run_Time_On_Target + then + WBI (""); + WBI (" gnat_argc : Integer;"); + WBI (" gnat_argv : System.Address;"); + WBI (" gnat_envp : System.Address;"); - -- Generate argc/argv stuff unless suppressed + -- If the standard library is not suppressed, these variables + -- are in the run-time data area for easy run time access. - if Command_Line_Args_On_Target - or not Configurable_Run_Time_On_Target - then + if not Suppress_Standard_Library_On_Target then WBI (""); - WBI (" gnat_argc : Integer;"); - WBI (" gnat_argv : System.Address;"); - WBI (" gnat_envp : System.Address;"); - - -- If the standard library is not suppressed, these variables - -- are in the run-time data area for easy run time access. - - if not Suppress_Standard_Library_On_Target then - WBI (""); - WBI (" pragma Import (C, gnat_argc);"); - WBI (" pragma Import (C, gnat_argv);"); - WBI (" pragma Import (C, gnat_envp);"); - end if; + WBI (" pragma Import (C, gnat_argc);"); + WBI (" pragma Import (C, gnat_argv);"); + WBI (" pragma Import (C, gnat_envp);"); end if; + end if; - -- Define exit status. Again in normal mode, this is in the - -- run-time library, and is initialized there, but in the - -- configurable runtime case, the variable is declared and - -- initialized in this file. - - WBI (""); + -- Define exit status. Again in normal mode, this is in the + -- run-time library, and is initialized there, but in the + -- configurable runtime case, the variable is declared and + -- initialized in this file. - if Configurable_Run_Time_Mode then - if Exit_Status_Supported_On_Target then - WBI (" gnat_exit_status : Integer := 0;"); - end if; + WBI (""); - else - WBI (" gnat_exit_status : Integer;"); - WBI (" pragma Import (C, gnat_exit_status);"); + if Configurable_Run_Time_Mode then + if Exit_Status_Supported_On_Target then + WBI (" gnat_exit_status : Integer := 0;"); end if; + + else + WBI (" gnat_exit_status : Integer;"); + WBI (" pragma Import (C, gnat_exit_status);"); end if; -- Generate the GNAT_Version and Ada_Main_Program_Name info only for @@ -2289,12 +2215,8 @@ package body Bindgen is Set_String (" Ada_Main_Program_Name : constant String := """); Get_Name_String (Units.Table (First_Unit_Entry).Uname); - if VM_Target = No_VM then - Set_Main_Program_Name; - Set_String (""" & ASCII.NUL;"); - else - Set_String (Name_Buffer (1 .. Name_Len - 2) & """;"); - end if; + Set_Main_Program_Name; + Set_String (""" & ASCII.NUL;"); Write_Statement_Buffer; @@ -2326,7 +2248,7 @@ package body Bindgen is end if; end if; - if Bind_Main_Program and then VM_Target = No_VM then + if Bind_Main_Program then WBI (""); @@ -2384,6 +2306,7 @@ package body Bindgen is -- of the Ada 2005/2012 constructs are needed by the binder file. WBI ("pragma Ada_95;"); + WBI ("pragma Warnings (Off);"); -- Output Source_File_Name pragmas which look like @@ -2445,7 +2368,6 @@ package body Bindgen is WBI (""); WBI ("package body " & Ada_Main & " is"); - WBI (" pragma Warnings (Off);"); WBI (""); -- Generate externals for elaboration entities @@ -2481,13 +2403,18 @@ package body Bindgen is WBI (""); end if; - -- The B.1 (39) implementation advice says that the adainit/adafinal - -- routines should be idempotent. Generate a flag to ensure that. - -- This is not needed if we are suppressing the standard library - -- since it would never be referenced. - if not Suppress_Standard_Library_On_Target then + + -- The B.1(39) implementation advice says that the adainit + -- and adafinal routines should be idempotent. Generate a flag to + -- ensure that. This is not needed if we are suppressing the + -- standard library since it would never be referenced. + WBI (" Is_Elaborated : Boolean := False;"); + + -- Generate bind environment string + + Gen_Bind_Env_String; end if; WBI (""); @@ -2505,7 +2432,7 @@ package body Bindgen is Gen_Adainit; - if Bind_Main_Program and then VM_Target = No_VM then + if Bind_Main_Program then Gen_Main; end if; @@ -2706,17 +2633,11 @@ package body Bindgen is Nlen : Natural; begin - -- The main program generated by JGNAT expects a package called - -- ada_<main procedure>. - if VM_Target /= No_VM then - Get_Name_String (Units.Table (First_Unit_Entry).Uname); - return "ada_" & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2)); - end if; - -- For CodePeer, we want reproducible names (independent of other -- mains that may or may not be present) that don't collide -- when analyzing multiple mains and which are easily recognizable -- as "ada_main" names. + if CodePeer_Mode then Get_Name_String (Units.Table (First_Unit_Entry).Uname); return "ada_main_for_" & @@ -2864,6 +2785,15 @@ package body Bindgen is return False; end Has_Finalizer; + ---------- + -- Hash -- + ---------- + + function Hash (Nam : Name_Id) return Header_Num is + begin + return Int (Nam - Names_Low_Bound) rem Header_Num'Last; + end Hash; + ---------------------- -- Lt_Linker_Option -- ---------------------- @@ -2911,8 +2841,8 @@ package body Bindgen is procedure Check_Package (Var : in out Boolean; Name : String); -- Set Var to true iff the current identifier in Namet is Name. Do - -- nothing if it doesn't match. This procedure is just an helper to - -- avoid to explicitely deal with length. + -- nothing if it doesn't match. This procedure is just a helper to + -- avoid explicitly dealing with length. ------------------- -- Check_Package -- @@ -2959,9 +2889,34 @@ package body Bindgen is -- Ditto for the use of restrictions Check_Package (System_Restrictions_Used, "system.restrictions%s"); + + -- Ditto for use of an SMP bareboard runtime + + Check_Package (System_BB_CPU_Primitives_Multiprocessors_Used, + "system.bb.cpu_primitives.multiprocessors%s"); + end loop; end Resolve_Binder_Options; + ------------------ + -- Set_Bind_Env -- + ------------------ + + procedure Set_Bind_Env (Key, Value : String) is + begin + -- The lengths of Key and Value are stored as single bytes + + if Key'Length > 255 then + Osint.Fail ("bind environment key """ & Key & """ too long"); + end if; + + if Value'Length > 255 then + Osint.Fail ("bind environment value """ & Value & """ too long"); + end if; + + Bind_Environment.Set (Name_Find_Str (Key), Name_Find_Str (Value)); + end Set_Bind_Env; + ----------------- -- Set_Boolean -- ----------------- @@ -3122,17 +3077,11 @@ package body Bindgen is -- Set_Unit_Name -- ------------------- - procedure Set_Unit_Name (Mode : Qualification_Mode := Double_Underscores) is + procedure Set_Unit_Name is begin for J in 1 .. Name_Len - 2 loop if Name_Buffer (J) = '.' then - if Mode = Double_Underscores then - Set_String ("__"); - elsif Mode = Dot then - Set_Char ('.'); - else - Set_Char ('$'); - end if; + Set_String ("__"); else Set_Char (Name_Buffer (J)); end if; @@ -3159,6 +3108,17 @@ package body Bindgen is Set_Int (Unum); end Set_Unit_Number; + --------------------- + -- Write_Bind_Line -- + --------------------- + + procedure Write_Bind_Line (S : String) is + begin + -- Need to strip trailing LF from S + + WBI (S (S'First .. S'Last - 1)); + end Write_Bind_Line; + ---------------------------- -- Write_Statement_Buffer -- ---------------------------- diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads index 71596284963..2f4cc78c483 100644 --- a/gcc/ada/bindgen.ads +++ b/gcc/ada/bindgen.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,4 +37,8 @@ package Bindgen is procedure Gen_Output_File (Filename : String); -- Filename is the full path name of the binder output file + procedure Set_Bind_Env (Key, Value : String); + -- Add (Key, Value) pair to bind environment. These associations + -- are made available at run time using System.Bind_Environment. + end Bindgen; diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index b1029487dfa..f1a61777bfb 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -4,9 +4,9 @@ -- -- -- B I N D U S G -- -- -- --- B o d y -- +-- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -108,7 +108,10 @@ package body Bindusg is -- Line for -E switch - Write_Line (" -E Store tracebacks in exception occurrences"); + Write_Line (" -Ea Store tracebacks in exception occurrences"); + Write_Line (" -Es Store tracebacks in exception occurrences,"); + Write_Line (" and enable symbolic tracebacks"); + Write_Line (" -E Same as -Ea"); -- The -f switch is voluntarily omitted, because it is obsolete @@ -228,6 +231,10 @@ package body Bindusg is Write_Line (" -v Verbose mode. Error messages, " & "header, summary output to stdout"); + -- Line for -V switch + + Write_Line (" -Vkey=val Record bind-time variable key " & + "with value val"); -- Line for -w switch Write_Line (" -wx Warning mode. (x=s/e for " & diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index b2e779c99e6..f992aa2097a 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1037,17 +1037,12 @@ package body Checks is -- operation on signed integers on which the expander can promote -- later the operands to type Integer (see Expand_N_Type_Conversion). - -- Special case CLI target, where arithmetic overflow checks can be - -- performed for integer and long_integer - if Backend_Overflow_Checks_On_Target or else not Do_Overflow_Check (N) or else not Expander_Active or else (Present (Parent (N)) and then Nkind (Parent (N)) = N_Type_Conversion and then Integer_Promotion_Possible (Parent (N))) - or else - (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size) then return; end if; @@ -3236,7 +3231,7 @@ package body Checks is Rewrite (R_Cno, Make_Null_Statement (Loc)); end if; - -- The range check raises Constrant_Error explicitly + -- The range check raises Constraint_Error explicitly else Install_Static_Check (R_Cno, Loc); @@ -5903,11 +5898,6 @@ package body Checks is elsif Nkind_In (Expr, N_Integer_Literal, N_Character_Literal) then return True; - -- Real literals are assumed to be valid in VM targets - - elsif VM_Target /= No_VM and then Nkind (Expr) = N_Real_Literal then - return True; - -- If we have a type conversion or a qualification of a known valid -- value, then the result will always be valid. @@ -9182,7 +9172,7 @@ package body Checks is (Compile_Time_Constraint_Error (Wnode, "too few elements for}??", T_Typ)); - elsif L_Length < R_Length then + elsif L_Length < R_Length then Add_Check (Compile_Time_Constraint_Error (Wnode, "too many elements for}??", T_Typ)); diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index e410c3ba88a..805f65393a8 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -686,7 +686,7 @@ package body Clean is Delete_File := False; if (Project.Library_Kind = Static - and then Name (1 .. Last) = Archive_Name) + and then Name (1 .. Last) = Archive_Name) or else ((Project.Library_Kind = Dynamic or else diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index cabc028417b..f32db3267b8 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -40,7 +40,6 @@ with Sinfo; use Sinfo; with Sinput; use Sinput; with Sprint; use Sprint; with Sdefault; use Sdefault; -with Targparm; use Targparm; with Treepr; use Treepr; with Types; use Types; @@ -116,35 +115,19 @@ package body Comperr is Abort_In_Progress := True; -- Generate a "standard" error message instead of a bug box in case - -- of .NET compiler, since we do not support all constructs of the - -- language. Of course ideally, we should detect this before bombing on - -- e.g. an assertion error, but in practice most of these bombs are due - -- to a legitimate case of a construct not being supported (in a sense - -- they all are, since for sure we are not supporting something if we - -- bomb). By giving this message, we provide a more reasonable practical - -- interface, since giving scary bug boxes on unsupported features is - -- definitely not helpful. - - -- Similarly if we are generating SCIL, an error message is sufficient - -- instead of generating a bug box. + -- of CodePeer rather than generating a bug box, friendlier. -- Note that the call to Error_Msg_N below sets Serious_Errors_Detected -- to 1, so we use the regular mechanism below in order to display a -- "compilation abandoned" message and exit, so we still know we have -- this case (and -gnatdk can still be used to get the bug box). - if (VM_Target = CLI_Target or else CodePeer_Mode) + if CodePeer_Mode and then Serious_Errors_Detected = 0 and then not Debug_Flag_K and then Sloc (Current_Error_Node) > No_Location then - if VM_Target = CLI_Target then - Error_Msg_N - ("unsupported construct in this context", - Current_Error_Node); - else - Error_Msg_N ("cannot generate 'S'C'I'L", Current_Error_Node); - end if; + Error_Msg_N ("cannot generate 'S'C'I'L", Current_Error_Node); end if; -- If we are in CodePeer mode, we must also delete SCIL files diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb new file mode 100644 index 00000000000..2ab91f98fec --- /dev/null +++ b/gcc/ada/contracts.adb @@ -0,0 +1,2708 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C O N T R A C T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2015, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Prag; use Exp_Prag; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Disp; use Sem_Disp; +with Sem_Prag; use Sem_Prag; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stringt; use Stringt; +with Tbuild; use Tbuild; + +package body Contracts is + + procedure Expand_Subprogram_Contract (Body_Id : Entity_Id); + -- Expand the contracts of a subprogram body and its correspoding spec (if + -- any). This routine processes all [refined] pre- and postconditions as + -- well as Contract_Cases, invariants and predicates. Body_Id denotes the + -- entity of the subprogram body. + + ----------------------- + -- Add_Contract_Item -- + ----------------------- + + procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id) is + Items : Node_Id := Contract (Id); + + procedure Add_Classification; + -- Prepend Prag to the list of classifications + + procedure Add_Contract_Test_Case; + -- Prepend Prag to the list of contract and test cases + + procedure Add_Pre_Post_Condition; + -- Prepend Prag to the list of pre- and postconditions + + ------------------------ + -- Add_Classification -- + ------------------------ + + procedure Add_Classification is + begin + Set_Next_Pragma (Prag, Classifications (Items)); + Set_Classifications (Items, Prag); + end Add_Classification; + + ---------------------------- + -- Add_Contract_Test_Case -- + ---------------------------- + + procedure Add_Contract_Test_Case is + begin + Set_Next_Pragma (Prag, Contract_Test_Cases (Items)); + Set_Contract_Test_Cases (Items, Prag); + end Add_Contract_Test_Case; + + ---------------------------- + -- Add_Pre_Post_Condition -- + ---------------------------- + + procedure Add_Pre_Post_Condition is + begin + Set_Next_Pragma (Prag, Pre_Post_Conditions (Items)); + Set_Pre_Post_Conditions (Items, Prag); + end Add_Pre_Post_Condition; + + -- Local variables + + Prag_Nam : Name_Id; + + -- Start of processing for Add_Contract_Item + + begin + -- A contract must contain only pragmas + + pragma Assert (Nkind (Prag) = N_Pragma); + Prag_Nam := Pragma_Name (Prag); + + -- Create a new contract when adding the first item + + if No (Items) then + Items := Make_Contract (Sloc (Id)); + Set_Contract (Id, Items); + end if; + + -- Constants, the applicable pragmas are: + -- Part_Of + + if Ekind (Id) = E_Constant then + if Prag_Nam = Name_Part_Of then + Add_Classification; + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + + -- Entry bodies, the applicable pragmas are: + -- Refined_Depends + -- Refined_Global + -- Refined_Post + + elsif Is_Entry_Body (Id) then + if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then + Add_Classification; + + elsif Prag_Nam = Name_Refined_Post then + Add_Pre_Post_Condition; + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + + -- Entry or subprogram declarations, the applicable pragmas are: + -- Contract_Cases + -- Depends + -- Extensions_Visible + -- Global + -- Postcondition + -- Precondition + -- Test_Case + -- Volatile_Function + + elsif Is_Entry_Declaration (Id) + or else Ekind_In (Id, E_Function, + E_Generic_Function, + E_Generic_Procedure, + E_Procedure) + then + if Nam_In (Prag_Nam, Name_Postcondition, Name_Precondition) then + Add_Pre_Post_Condition; + + elsif Nam_In (Prag_Nam, Name_Contract_Cases, Name_Test_Case) then + Add_Contract_Test_Case; + + elsif Nam_In (Prag_Nam, Name_Depends, + Name_Extensions_Visible, + Name_Global) + then + Add_Classification; + + elsif Prag_Nam = Name_Volatile_Function + and then Ekind_In (Id, E_Function, E_Generic_Function) + then + Add_Classification; + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + + -- Packages or instantiations, the applicable pragmas are: + -- Abstract_States + -- Initial_Condition + -- Initializes + -- Part_Of (instantiation only) + + elsif Ekind_In (Id, E_Generic_Package, E_Package) then + if Nam_In (Prag_Nam, Name_Abstract_State, + Name_Initial_Condition, + Name_Initializes) + then + Add_Classification; + + -- Indicator Part_Of must be associated with a package instantiation + + elsif Prag_Nam = Name_Part_Of and then Is_Generic_Instance (Id) then + Add_Classification; + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + + -- Package bodies, the applicable pragmas are: + -- Refined_States + + elsif Ekind (Id) = E_Package_Body then + if Prag_Nam = Name_Refined_State then + Add_Classification; + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + + -- Protected units, the applicable pragmas are: + -- Part_Of + + elsif Ekind (Id) = E_Protected_Type then + if Prag_Nam = Name_Part_Of then + Add_Classification; + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + + -- Subprogram bodies, the applicable pragmas are: + -- Postcondition + -- Precondition + -- Refined_Depends + -- Refined_Global + -- Refined_Post + + elsif Ekind (Id) = E_Subprogram_Body then + if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then + Add_Classification; + + elsif Nam_In (Prag_Nam, Name_Postcondition, + Name_Precondition, + Name_Refined_Post) + then + Add_Pre_Post_Condition; + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + + -- Task bodies, the applicable pragmas are: + -- Refined_Depends + -- Refined_Global + + elsif Ekind (Id) = E_Task_Body then + if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then + Add_Classification; + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + + -- Task units, the applicable pragmas are: + -- Depends + -- Global + -- Part_Of + + elsif Ekind (Id) = E_Task_Type then + if Nam_In (Prag_Nam, Name_Depends, Name_Global, Name_Part_Of) then + Add_Classification; + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + + -- Variables, the applicable pragmas are: + -- Async_Readers + -- Async_Writers + -- Constant_After_Elaboration + -- Depends + -- Effective_Reads + -- Effective_Writes + -- Global + -- Part_Of + + elsif Ekind (Id) = E_Variable then + if Nam_In (Prag_Nam, Name_Async_Readers, + Name_Async_Writers, + Name_Constant_After_Elaboration, + Name_Depends, + Name_Effective_Reads, + Name_Effective_Writes, + Name_Global, + Name_Part_Of) + then + Add_Classification; + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + end if; + end Add_Contract_Item; + + --------------------------------------------- + -- Analyze_Enclosing_Package_Body_Contract -- + --------------------------------------------- + + procedure Analyze_Enclosing_Package_Body_Contract (Body_Decl : Node_Id) is + Par : Node_Id; + + begin + -- Climb the parent chain looking for an enclosing body. Do not use the + -- scope stack, as a body uses the entity of its corresponding spec. + + Par := Parent (Body_Decl); + while Present (Par) loop + if Nkind (Par) = N_Package_Body then + Analyze_Package_Body_Contract + (Body_Id => Defining_Entity (Par), + Freeze_Id => Defining_Entity (Body_Decl)); + + return; + end if; + + Par := Parent (Par); + end loop; + end Analyze_Enclosing_Package_Body_Contract; + + ----------------------------------------------- + -- Analyze_Entry_Or_Subprogram_Body_Contract -- + ----------------------------------------------- + + procedure Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id : Entity_Id) is + Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id); + Items : constant Node_Id := Contract (Body_Id); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Body_Decl); + Mode : SPARK_Mode_Type; + + begin + -- When a subprogram body declaration is illegal, its defining entity is + -- left unanalyzed. There is nothing left to do in this case because the + -- body lacks a contract, or even a proper Ekind. + + if Ekind (Body_Id) = E_Void then + return; + + -- Do not analyze the contract of an entry body unless annotating the + -- original tree. It is preferable to analyze the contract after the + -- entry body has been transformed into a subprogram body to properly + -- handle references to unpacked formals. + + elsif Ekind_In (Body_Id, E_Entry, E_Entry_Family) + and then not ASIS_Mode + and then not GNATprove_Mode + then + return; + + -- Do not analyze a contract multiple times + + elsif Present (Items) then + if Analyzed (Items) then + return; + else + Set_Analyzed (Items); + end if; + end if; + + -- Due to the timing of contract analysis, delayed pragmas may be + -- subject to the wrong SPARK_Mode, usually that of the enclosing + -- context. To remedy this, restore the original SPARK_Mode of the + -- related subprogram body. + + Save_SPARK_Mode_And_Set (Body_Id, Mode); + + -- Ensure that the contract cases or postconditions mention 'Result or + -- define a post-state. + + Check_Result_And_Post_State (Body_Id); + + -- A stand-alone nonvolatile function body cannot have an effectively + -- volatile formal parameter or return type (SPARK RM 7.1.3(9)). This + -- check is relevant only when SPARK_Mode is on, as it is not a standard + -- legality rule. The check is performed here because Volatile_Function + -- is processed after the analysis of the related subprogram body. + + if SPARK_Mode = On + and then Ekind_In (Body_Id, E_Function, E_Generic_Function) + and then not Is_Volatile_Function (Body_Id) + then + Check_Nonvolatile_Function_Profile (Body_Id); + end if; + + -- Restore the SPARK_Mode of the enclosing context after all delayed + -- pragmas have been analyzed. + + Restore_SPARK_Mode (Mode); + + -- Capture all global references in a generic subprogram body now that + -- the contract has been analyzed. + + if Is_Generic_Declaration_Or_Body (Body_Decl) then + Save_Global_References_In_Contract + (Templ => Original_Node (Body_Decl), + Gen_Id => Spec_Id); + end if; + + -- Deal with preconditions, [refined] postconditions, Contract_Cases, + -- invariants and predicates associated with body and its spec. Do not + -- expand the contract of subprogram body stubs. + + if Nkind (Body_Decl) = N_Subprogram_Body then + Expand_Subprogram_Contract (Body_Id); + end if; + end Analyze_Entry_Or_Subprogram_Body_Contract; + + ------------------------------------------ + -- Analyze_Entry_Or_Subprogram_Contract -- + ------------------------------------------ + + procedure Analyze_Entry_Or_Subprogram_Contract (Subp_Id : Entity_Id) is + Items : constant Node_Id := Contract (Subp_Id); + Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); + Depends : Node_Id := Empty; + Global : Node_Id := Empty; + Mode : SPARK_Mode_Type; + Prag : Node_Id; + Prag_Nam : Name_Id; + + begin + -- Do not analyze a contract multiple times + + if Present (Items) then + if Analyzed (Items) then + return; + else + Set_Analyzed (Items); + end if; + end if; + + -- Due to the timing of contract analysis, delayed pragmas may be + -- subject to the wrong SPARK_Mode, usually that of the enclosing + -- context. To remedy this, restore the original SPARK_Mode of the + -- related subprogram body. + + Save_SPARK_Mode_And_Set (Subp_Id, Mode); + + -- All subprograms carry a contract, but for some it is not significant + -- and should not be processed. + + if not Has_Significant_Contract (Subp_Id) then + null; + + elsif Present (Items) then + + -- Do not analyze the pre/postconditions of an entry declaration + -- unless annotating the original tree for ASIS or GNATprove. + + -- ??? References to formals are causing problems during contract + -- expansion as the references resolve to the entry formals, not + -- the subprogram body emulating the entry body. This will have to + -- be addressed. + + if Ekind_In (Subp_Id, E_Entry, E_Entry_Family) + and then not ASIS_Mode + and then not GNATprove_Mode + then + null; + + -- Otherwise analyze the pre/postconditions + + else + Prag := Pre_Post_Conditions (Items); + while Present (Prag) loop + Analyze_Pre_Post_Condition_In_Decl_Part (Prag); + Prag := Next_Pragma (Prag); + end loop; + end if; + + -- Analyze contract-cases and test-cases + + Prag := Contract_Test_Cases (Items); + while Present (Prag) loop + Prag_Nam := Pragma_Name (Prag); + + if Prag_Nam = Name_Contract_Cases then + Analyze_Contract_Cases_In_Decl_Part (Prag); + else + pragma Assert (Prag_Nam = Name_Test_Case); + Analyze_Test_Case_In_Decl_Part (Prag); + end if; + + Prag := Next_Pragma (Prag); + end loop; + + -- Analyze classification pragmas + + Prag := Classifications (Items); + while Present (Prag) loop + Prag_Nam := Pragma_Name (Prag); + + if Prag_Nam = Name_Depends then + Depends := Prag; + + elsif Prag_Nam = Name_Global then + Global := Prag; + end if; + + Prag := Next_Pragma (Prag); + end loop; + + -- Analyze Global first, as Depends may mention items classified in + -- the global categorization. + + if Present (Global) then + Analyze_Global_In_Decl_Part (Global); + end if; + + -- Depends must be analyzed after Global in order to see the modes of + -- all global items. + + if Present (Depends) then + Analyze_Depends_In_Decl_Part (Depends); + end if; + + -- Ensure that the contract cases or postconditions mention 'Result + -- or define a post-state. + + Check_Result_And_Post_State (Subp_Id); + end if; + + -- A nonvolatile function cannot have an effectively volatile formal + -- parameter or return type (SPARK RM 7.1.3(9)). This check is relevant + -- only when SPARK_Mode is on, as it is not a standard legality rule. + -- The check is performed here because pragma Volatile_Function is + -- processed after the analysis of the related subprogram declaration. + + if SPARK_Mode = On + and then Ekind_In (Subp_Id, E_Function, E_Generic_Function) + and then not Is_Volatile_Function (Subp_Id) + then + Check_Nonvolatile_Function_Profile (Subp_Id); + end if; + + -- Restore the SPARK_Mode of the enclosing context after all delayed + -- pragmas have been analyzed. + + Restore_SPARK_Mode (Mode); + + -- Capture all global references in a generic subprogram now that the + -- contract has been analyzed. + + if Is_Generic_Declaration_Or_Body (Subp_Decl) then + Save_Global_References_In_Contract + (Templ => Original_Node (Subp_Decl), + Gen_Id => Subp_Id); + end if; + end Analyze_Entry_Or_Subprogram_Contract; + + ------------------------------------------ + -- Analyze_Initial_Declaration_Contract -- + ------------------------------------------ + + procedure Analyze_Initial_Declaration_Contract (Body_Decl : Node_Id) is + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Body_Decl); + + begin + -- Note that stubs are excluded because the compiler always analyzes the + -- proper body when a stub is encountered. + + if Nkind (Body_Decl) = N_Entry_Body then + Analyze_Entry_Or_Subprogram_Contract (Spec_Id); + + elsif Nkind (Body_Decl) = N_Package_Body then + Analyze_Package_Contract (Spec_Id); + + elsif Nkind (Body_Decl) = N_Protected_Body then + Analyze_Protected_Contract (Spec_Id); + + elsif Nkind (Body_Decl) = N_Subprogram_Body then + if Present (Corresponding_Spec (Body_Decl)) then + Analyze_Entry_Or_Subprogram_Contract (Spec_Id); + end if; + + elsif Nkind (Body_Decl) = N_Task_Body then + Analyze_Task_Contract (Spec_Id); + + else + raise Program_Error; + end if; + end Analyze_Initial_Declaration_Contract; + + ----------------------------- + -- Analyze_Object_Contract -- + ----------------------------- + + procedure Analyze_Object_Contract (Obj_Id : Entity_Id) is + Obj_Typ : constant Entity_Id := Etype (Obj_Id); + AR_Val : Boolean := False; + AW_Val : Boolean := False; + Encap_Id : Entity_Id; + ER_Val : Boolean := False; + EW_Val : Boolean := False; + Items : Node_Id; + Mode : SPARK_Mode_Type; + Prag : Node_Id; + Restore_Mode : Boolean := False; + Seen : Boolean := False; + + begin + -- The loop parameter in an element iterator over a formal container + -- is declared with an object declaration, but no contracts apply. + + if Ekind (Obj_Id) = E_Loop_Parameter then + return; + end if; + + -- Do not analyze a contract multiple times + + Items := Contract (Obj_Id); + + if Present (Items) then + if Analyzed (Items) then + return; + else + Set_Analyzed (Items); + end if; + end if; + + -- The anonymous object created for a single concurrent type inherits + -- the SPARK_Mode from the type. Due to the timing of contract analysis, + -- delayed pragmas may be subject to the wrong SPARK_Mode, usually that + -- of the enclosing context. To remedy this, restore the original mode + -- of the related anonymous object. + + if Is_Single_Concurrent_Object (Obj_Id) + and then Present (SPARK_Pragma (Obj_Id)) + then + Restore_Mode := True; + Save_SPARK_Mode_And_Set (Obj_Id, Mode); + end if; + + -- Constant-related checks + + if Ekind (Obj_Id) = E_Constant then + + -- Analyze indicator Part_Of + + Prag := Get_Pragma (Obj_Id, Pragma_Part_Of); + + -- Check whether the lack of indicator Part_Of agrees with the + -- placement of the constant with respect to the state space. + + if No (Prag) then + Check_Missing_Part_Of (Obj_Id); + end if; + + -- A constant cannot be effectively volatile (SPARK RM 7.1.3(4)). + -- This check is relevant only when SPARK_Mode is on, as it is not + -- a standard Ada legality rule. Internally-generated constants that + -- map generic formals to actuals in instantiations are allowed to + -- be volatile. + + if SPARK_Mode = On + and then Comes_From_Source (Obj_Id) + and then Is_Effectively_Volatile (Obj_Id) + and then No (Corresponding_Generic_Association (Parent (Obj_Id))) + then + Error_Msg_N ("constant cannot be volatile", Obj_Id); + end if; + + -- Variable-related checks + + else pragma Assert (Ekind (Obj_Id) = E_Variable); + + -- Analyze all external properties + + Prag := Get_Pragma (Obj_Id, Pragma_Async_Readers); + + if Present (Prag) then + Analyze_External_Property_In_Decl_Part (Prag, AR_Val); + Seen := True; + end if; + + Prag := Get_Pragma (Obj_Id, Pragma_Async_Writers); + + if Present (Prag) then + Analyze_External_Property_In_Decl_Part (Prag, AW_Val); + Seen := True; + end if; + + Prag := Get_Pragma (Obj_Id, Pragma_Effective_Reads); + + if Present (Prag) then + Analyze_External_Property_In_Decl_Part (Prag, ER_Val); + Seen := True; + end if; + + Prag := Get_Pragma (Obj_Id, Pragma_Effective_Writes); + + if Present (Prag) then + Analyze_External_Property_In_Decl_Part (Prag, EW_Val); + Seen := True; + end if; + + -- Verify the mutual interaction of the various external properties + + if Seen then + Check_External_Properties (Obj_Id, AR_Val, AW_Val, ER_Val, EW_Val); + end if; + + -- The anonymous object created for a single concurrent type carries + -- pragmas Depends and Globat of the type. + + if Is_Single_Concurrent_Object (Obj_Id) then + + -- Analyze Global first, as Depends may mention items classified + -- in the global categorization. + + Prag := Get_Pragma (Obj_Id, Pragma_Global); + + if Present (Prag) then + Analyze_Global_In_Decl_Part (Prag); + end if; + + -- Depends must be analyzed after Global in order to see the modes + -- of all global items. + + Prag := Get_Pragma (Obj_Id, Pragma_Depends); + + if Present (Prag) then + Analyze_Depends_In_Decl_Part (Prag); + end if; + end if; + + Prag := Get_Pragma (Obj_Id, Pragma_Part_Of); + + -- Analyze indicator Part_Of + + if Present (Prag) then + Analyze_Part_Of_In_Decl_Part (Prag); + + -- Otherwise check whether the lack of indicator Part_Of agrees with + -- the placement of the variable with respect to the state space. + + else + Check_Missing_Part_Of (Obj_Id); + end if; + + -- The following checks are relevant only when SPARK_Mode is on, as + -- they are not standard Ada legality rules. Internally generated + -- temporaries are ignored. + + if SPARK_Mode = On and then Comes_From_Source (Obj_Id) then + if Is_Effectively_Volatile (Obj_Id) then + + -- The declaration of an effectively volatile object must + -- appear at the library level (SPARK RM 7.1.3(3), C.6(6)). + + if not Is_Library_Level_Entity (Obj_Id) then + Error_Msg_N + ("volatile variable & must be declared at library level", + Obj_Id); + + -- An object of a discriminated type cannot be effectively + -- volatile except for protected objects (SPARK RM 7.1.3(5)). + + elsif Has_Discriminants (Obj_Typ) + and then not Is_Protected_Type (Obj_Typ) + then + Error_Msg_N + ("discriminated object & cannot be volatile", Obj_Id); + + -- An object of a tagged type cannot be effectively volatile + -- (SPARK RM C.6(5)). + + elsif Is_Tagged_Type (Obj_Typ) then + Error_Msg_N ("tagged object & cannot be volatile", Obj_Id); + end if; + + -- The object is not effectively volatile + + else + -- A non-effectively volatile object cannot have effectively + -- volatile components (SPARK RM 7.1.3(6)). + + if not Is_Effectively_Volatile (Obj_Id) + and then Has_Volatile_Component (Obj_Typ) + then + Error_Msg_N + ("non-volatile object & cannot have volatile components", + Obj_Id); + end if; + end if; + + -- A variable whose Part_Of pragma specifies a single concurrent + -- type as encapsulator must be (SPARK RM 9.4): + -- * Of a type that defines full default initialization, or + -- * Declared with a default value, or + -- * Imported + + Encap_Id := Encapsulating_State (Obj_Id); + + if Present (Encap_Id) + and then Is_Single_Concurrent_Object (Encap_Id) + and then not Has_Full_Default_Initialization (Etype (Obj_Id)) + and then not Has_Initial_Value (Obj_Id) + and then not Is_Imported (Obj_Id) + then + Error_Msg_N ("& requires full default initialization", Obj_Id); + + Error_Msg_Name_1 := Chars (Encap_Id); + Error_Msg_N + (Fix_Msg (Encap_Id, "\object acts as constituent of single " + & "protected type %"), Obj_Id); + end if; + end if; + end if; + + -- Common checks + + if Comes_From_Source (Obj_Id) and then Is_Ghost_Entity (Obj_Id) then + + -- A Ghost object cannot be of a type that yields a synchronized + -- object (SPARK RM 6.9(19)). + + if Yields_Synchronized_Object (Obj_Typ) then + Error_Msg_N ("ghost object & cannot be synchronized", Obj_Id); + + -- A Ghost object cannot be effectively volatile (SPARK RM 6.9(8) and + -- SPARK RM 6.9(19)). + + elsif Is_Effectively_Volatile (Obj_Id) then + Error_Msg_N ("ghost object & cannot be volatile", Obj_Id); + + -- A Ghost object cannot be imported or exported (SPARK RM 6.9(8)). + -- One exception to this is the object that represents the dispatch + -- table of a Ghost tagged type, as the symbol needs to be exported. + + elsif Is_Exported (Obj_Id) then + Error_Msg_N ("ghost object & cannot be exported", Obj_Id); + + elsif Is_Imported (Obj_Id) then + Error_Msg_N ("ghost object & cannot be imported", Obj_Id); + end if; + end if; + + -- Restore the SPARK_Mode of the enclosing context after all delayed + -- pragmas have been analyzed. + + if Restore_Mode then + Restore_SPARK_Mode (Mode); + end if; + end Analyze_Object_Contract; + + ----------------------------------- + -- Analyze_Package_Body_Contract -- + ----------------------------------- + + procedure Analyze_Package_Body_Contract + (Body_Id : Entity_Id; + Freeze_Id : Entity_Id := Empty) + is + Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id); + Items : constant Node_Id := Contract (Body_Id); + Spec_Id : constant Entity_Id := Spec_Entity (Body_Id); + Mode : SPARK_Mode_Type; + Ref_State : Node_Id; + + begin + -- Do not analyze a contract multiple times + + if Present (Items) then + if Analyzed (Items) then + return; + else + Set_Analyzed (Items); + end if; + end if; + + -- Due to the timing of contract analysis, delayed pragmas may be + -- subject to the wrong SPARK_Mode, usually that of the enclosing + -- context. To remedy this, restore the original SPARK_Mode of the + -- related package body. + + Save_SPARK_Mode_And_Set (Body_Id, Mode); + + Ref_State := Get_Pragma (Body_Id, Pragma_Refined_State); + + -- The analysis of pragma Refined_State detects whether the spec has + -- abstract states available for refinement. + + if Present (Ref_State) then + Analyze_Refined_State_In_Decl_Part (Ref_State, Freeze_Id); + + -- State refinement is required when the package declaration defines at + -- least one abstract state. Null states are not considered. Refinement + -- is not enforced when SPARK checks are turned off. + + elsif SPARK_Mode /= Off + and then Requires_State_Refinement (Spec_Id, Body_Id) + then + Error_Msg_N ("package & requires state refinement", Spec_Id); + end if; + + -- Restore the SPARK_Mode of the enclosing context after all delayed + -- pragmas have been analyzed. + + Restore_SPARK_Mode (Mode); + + -- Capture all global references in a generic package body now that the + -- contract has been analyzed. + + if Is_Generic_Declaration_Or_Body (Body_Decl) then + Save_Global_References_In_Contract + (Templ => Original_Node (Body_Decl), + Gen_Id => Spec_Id); + end if; + end Analyze_Package_Body_Contract; + + ------------------------------ + -- Analyze_Package_Contract -- + ------------------------------ + + procedure Analyze_Package_Contract (Pack_Id : Entity_Id) is + Items : constant Node_Id := Contract (Pack_Id); + Pack_Decl : constant Node_Id := Unit_Declaration_Node (Pack_Id); + Init : Node_Id := Empty; + Init_Cond : Node_Id := Empty; + Mode : SPARK_Mode_Type; + Prag : Node_Id; + Prag_Nam : Name_Id; + + begin + -- Do not analyze a contract multiple times + + if Present (Items) then + if Analyzed (Items) then + return; + else + Set_Analyzed (Items); + end if; + end if; + + -- Due to the timing of contract analysis, delayed pragmas may be + -- subject to the wrong SPARK_Mode, usually that of the enclosing + -- context. To remedy this, restore the original SPARK_Mode of the + -- related package. + + Save_SPARK_Mode_And_Set (Pack_Id, Mode); + + if Present (Items) then + + -- Locate and store pragmas Initial_Condition and Initializes, since + -- their order of analysis matters. + + Prag := Classifications (Items); + while Present (Prag) loop + Prag_Nam := Pragma_Name (Prag); + + if Prag_Nam = Name_Initial_Condition then + Init_Cond := Prag; + + elsif Prag_Nam = Name_Initializes then + Init := Prag; + end if; + + Prag := Next_Pragma (Prag); + end loop; + + -- Analyze the initialization-related pragmas. Initializes must come + -- before Initial_Condition due to item dependencies. + + if Present (Init) then + Analyze_Initializes_In_Decl_Part (Init); + end if; + + if Present (Init_Cond) then + Analyze_Initial_Condition_In_Decl_Part (Init_Cond); + end if; + end if; + + -- Check whether the lack of indicator Part_Of agrees with the placement + -- of the package instantiation with respect to the state space. + + if Is_Generic_Instance (Pack_Id) then + Prag := Get_Pragma (Pack_Id, Pragma_Part_Of); + + if No (Prag) then + Check_Missing_Part_Of (Pack_Id); + end if; + end if; + + -- Restore the SPARK_Mode of the enclosing context after all delayed + -- pragmas have been analyzed. + + Restore_SPARK_Mode (Mode); + + -- Capture all global references in a generic package now that the + -- contract has been analyzed. + + if Is_Generic_Declaration_Or_Body (Pack_Decl) then + Save_Global_References_In_Contract + (Templ => Original_Node (Pack_Decl), + Gen_Id => Pack_Id); + end if; + end Analyze_Package_Contract; + + -------------------------------- + -- Analyze_Protected_Contract -- + -------------------------------- + + procedure Analyze_Protected_Contract (Prot_Id : Entity_Id) is + Items : constant Node_Id := Contract (Prot_Id); + Mode : SPARK_Mode_Type; + + begin + -- Do not analyze a contract multiple times + + if Present (Items) then + if Analyzed (Items) then + return; + else + Set_Analyzed (Items); + end if; + end if; + + -- Due to the timing of contract analysis, delayed pragmas may be + -- subject to the wrong SPARK_Mode, usually that of the enclosing + -- context. To remedy this, restore the original SPARK_Mode of the + -- related protected unit. + + Save_SPARK_Mode_And_Set (Prot_Id, Mode); + + -- A protected type must define full default initialization + -- (SPARK RM 9.4). This check is relevant only when SPARK_Mode is on as + -- it is not a standard Ada legality rule. + + if SPARK_Mode = On + and then not Has_Full_Default_Initialization (Prot_Id) + then + Error_Msg_N + ("protected type & must define full default initialization", + Prot_Id); + end if; + + -- Restore the SPARK_Mode of the enclosing context after all delayed + -- pragmas have been analyzed. + + Restore_SPARK_Mode (Mode); + end Analyze_Protected_Contract; + + ------------------------------------------- + -- Analyze_Subprogram_Body_Stub_Contract -- + ------------------------------------------- + + procedure Analyze_Subprogram_Body_Stub_Contract (Stub_Id : Entity_Id) is + Stub_Decl : constant Node_Id := Parent (Parent (Stub_Id)); + Spec_Id : constant Entity_Id := Corresponding_Spec_Of_Stub (Stub_Decl); + + begin + -- A subprogram body stub may act as its own spec or as the completion + -- of a previous declaration. Depending on the context, the contract of + -- the stub may contain two sets of pragmas. + + -- The stub is a completion, the applicable pragmas are: + -- Refined_Depends + -- Refined_Global + + if Present (Spec_Id) then + Analyze_Entry_Or_Subprogram_Body_Contract (Stub_Id); + + -- The stub acts as its own spec, the applicable pragmas are: + -- Contract_Cases + -- Depends + -- Global + -- Postcondition + -- Precondition + -- Test_Case + + else + Analyze_Entry_Or_Subprogram_Contract (Stub_Id); + end if; + end Analyze_Subprogram_Body_Stub_Contract; + + --------------------------- + -- Analyze_Task_Contract -- + --------------------------- + + procedure Analyze_Task_Contract (Task_Id : Entity_Id) is + Items : constant Node_Id := Contract (Task_Id); + Mode : SPARK_Mode_Type; + Prag : Node_Id; + + begin + -- Do not analyze a contract multiple times + + if Present (Items) then + if Analyzed (Items) then + return; + else + Set_Analyzed (Items); + end if; + end if; + + -- Due to the timing of contract analysis, delayed pragmas may be + -- subject to the wrong SPARK_Mode, usually that of the enclosing + -- context. To remedy this, restore the original SPARK_Mode of the + -- related task unit. + + Save_SPARK_Mode_And_Set (Task_Id, Mode); + + -- Analyze Global first, as Depends may mention items classified in the + -- global categorization. + + Prag := Get_Pragma (Task_Id, Pragma_Global); + + if Present (Prag) then + Analyze_Global_In_Decl_Part (Prag); + end if; + + -- Depends must be analyzed after Global in order to see the modes of + -- all global items. + + Prag := Get_Pragma (Task_Id, Pragma_Depends); + + if Present (Prag) then + Analyze_Depends_In_Decl_Part (Prag); + end if; + + -- Restore the SPARK_Mode of the enclosing context after all delayed + -- pragmas have been analyzed. + + Restore_SPARK_Mode (Mode); + end Analyze_Task_Contract; + + ----------------------------- + -- Create_Generic_Contract -- + ----------------------------- + + procedure Create_Generic_Contract (Unit : Node_Id) is + Templ : constant Node_Id := Original_Node (Unit); + Templ_Id : constant Entity_Id := Defining_Entity (Templ); + + procedure Add_Generic_Contract_Pragma (Prag : Node_Id); + -- Add a single contract-related source pragma Prag to the contract of + -- generic template Templ_Id. + + --------------------------------- + -- Add_Generic_Contract_Pragma -- + --------------------------------- + + procedure Add_Generic_Contract_Pragma (Prag : Node_Id) is + Prag_Templ : Node_Id; + + begin + -- Mark the pragma to prevent the premature capture of global + -- references when capturing global references of the context + -- (see Save_References_In_Pragma). + + Set_Is_Generic_Contract_Pragma (Prag); + + -- Pragmas that apply to a generic subprogram declaration are not + -- part of the semantic structure of the generic template: + + -- generic + -- procedure Example (Formal : Integer); + -- pragma Precondition (Formal > 0); + + -- Create a generic template for such pragmas and link the template + -- of the pragma with the generic template. + + if Nkind (Templ) = N_Generic_Subprogram_Declaration then + Rewrite + (Prag, Copy_Generic_Node (Prag, Empty, Instantiating => False)); + Prag_Templ := Original_Node (Prag); + + Set_Is_Generic_Contract_Pragma (Prag_Templ); + Add_Contract_Item (Prag_Templ, Templ_Id); + + -- Otherwise link the pragma with the generic template + + else + Add_Contract_Item (Prag, Templ_Id); + end if; + end Add_Generic_Contract_Pragma; + + -- Local variables + + Context : constant Node_Id := Parent (Unit); + Decl : Node_Id := Empty; + + -- Start of processing for Create_Generic_Contract + + begin + -- A generic package declaration carries contract-related source pragmas + -- in its visible declarations. + + if Nkind (Templ) = N_Generic_Package_Declaration then + Set_Ekind (Templ_Id, E_Generic_Package); + + if Present (Visible_Declarations (Specification (Templ))) then + Decl := First (Visible_Declarations (Specification (Templ))); + end if; + + -- A generic package body carries contract-related source pragmas in its + -- declarations. + + elsif Nkind (Templ) = N_Package_Body then + Set_Ekind (Templ_Id, E_Package_Body); + + if Present (Declarations (Templ)) then + Decl := First (Declarations (Templ)); + end if; + + -- Generic subprogram declaration + + elsif Nkind (Templ) = N_Generic_Subprogram_Declaration then + if Nkind (Specification (Templ)) = N_Function_Specification then + Set_Ekind (Templ_Id, E_Generic_Function); + else + Set_Ekind (Templ_Id, E_Generic_Procedure); + end if; + + -- When the generic subprogram acts as a compilation unit, inspect + -- the Pragmas_After list for contract-related source pragmas. + + if Nkind (Context) = N_Compilation_Unit then + if Present (Aux_Decls_Node (Context)) + and then Present (Pragmas_After (Aux_Decls_Node (Context))) + then + Decl := First (Pragmas_After (Aux_Decls_Node (Context))); + end if; + + -- Otherwise inspect the successive declarations for contract-related + -- source pragmas. + + else + Decl := Next (Unit); + end if; + + -- A generic subprogram body carries contract-related source pragmas in + -- its declarations. + + elsif Nkind (Templ) = N_Subprogram_Body then + Set_Ekind (Templ_Id, E_Subprogram_Body); + + if Present (Declarations (Templ)) then + Decl := First (Declarations (Templ)); + end if; + end if; + + -- Inspect the relevant declarations looking for contract-related source + -- pragmas and add them to the contract of the generic unit. + + while Present (Decl) loop + if Comes_From_Source (Decl) then + if Nkind (Decl) = N_Pragma then + + -- The source pragma is a contract annotation + + if Is_Contract_Annotation (Decl) then + Add_Generic_Contract_Pragma (Decl); + end if; + + -- The region where a contract-related source pragma may appear + -- ends with the first source non-pragma declaration or statement. + + else + exit; + end if; + end if; + + Next (Decl); + end loop; + end Create_Generic_Contract; + + -------------------------------- + -- Expand_Subprogram_Contract -- + -------------------------------- + + procedure Expand_Subprogram_Contract (Body_Id : Entity_Id) is + Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id); + Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl); + + procedure Add_Invariant_And_Predicate_Checks + (Subp_Id : Entity_Id; + Stmts : in out List_Id; + Result : out Node_Id); + -- Process the result of function Subp_Id (if applicable) and all its + -- formals. Add invariant and predicate checks where applicable. The + -- routine appends all the checks to list Stmts. If Subp_Id denotes a + -- function, Result contains the entity of parameter _Result, to be + -- used in the creation of procedure _Postconditions. + + procedure Append_Enabled_Item (Item : Node_Id; List : in out List_Id); + -- Append a node to a list. If there is no list, create a new one. When + -- the item denotes a pragma, it is added to the list only when it is + -- enabled. + + procedure Build_Postconditions_Procedure + (Subp_Id : Entity_Id; + Stmts : List_Id; + Result : Entity_Id); + -- Create the body of procedure _Postconditions which handles various + -- assertion actions on exit from subprogram Subp_Id. Stmts is the list + -- of statements to be checked on exit. Parameter Result is the entity + -- of parameter _Result when Subp_Id denotes a function. + + function Build_Pragma_Check_Equivalent + (Prag : Node_Id; + Subp_Id : Entity_Id := Empty; + Inher_Id : Entity_Id := Empty) return Node_Id; + -- Transform a [refined] pre- or postcondition denoted by Prag into an + -- equivalent pragma Check. When the pre- or postcondition is inherited, + -- the routine corrects the references of all formals of Inher_Id to + -- point to the formals of Subp_Id. + + procedure Process_Contract_Cases (Stmts : in out List_Id); + -- Process pragma Contract_Cases. This routine prepends items to the + -- body declarations and appends items to list Stmts. + + procedure Process_Postconditions (Stmts : in out List_Id); + -- Collect all [inherited] spec and body postconditions and accumulate + -- their pragma Check equivalents in list Stmts. + + procedure Process_Preconditions; + -- Collect all [inherited] spec and body preconditions and prepend their + -- pragma Check equivalents to the declarations of the body. + + ---------------------------------------- + -- Add_Invariant_And_Predicate_Checks -- + ---------------------------------------- + + procedure Add_Invariant_And_Predicate_Checks + (Subp_Id : Entity_Id; + Stmts : in out List_Id; + Result : out Node_Id) + is + procedure Add_Invariant_Access_Checks (Id : Entity_Id); + -- Id denotes the return value of a function or a formal parameter. + -- Add an invariant check if the type of Id is access to a type with + -- invariants. The routine appends the generated code to Stmts. + + function Invariant_Checks_OK (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ can benefit from invariant checks. To + -- qualify, the type must have a non-null invariant procedure and + -- subprogram Subp_Id must appear visible from the point of view of + -- the type. + + --------------------------------- + -- Add_Invariant_Access_Checks -- + --------------------------------- + + procedure Add_Invariant_Access_Checks (Id : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Body_Decl); + Ref : Node_Id; + Typ : Entity_Id; + + begin + Typ := Etype (Id); + + if Is_Access_Type (Typ) and then not Is_Access_Constant (Typ) then + Typ := Designated_Type (Typ); + + if Invariant_Checks_OK (Typ) then + Ref := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Id, Loc)); + Set_Etype (Ref, Typ); + + -- Generate: + -- if <Id> /= null then + -- <invariant_call (<Ref>)> + -- end if; + + Append_Enabled_Item + (Item => + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Id, Loc), + Right_Opnd => Make_Null (Loc)), + Then_Statements => New_List ( + Make_Invariant_Call (Ref))), + List => Stmts); + end if; + end if; + end Add_Invariant_Access_Checks; + + ------------------------- + -- Invariant_Checks_OK -- + ------------------------- + + function Invariant_Checks_OK (Typ : Entity_Id) return Boolean is + function Has_Null_Body (Proc_Id : Entity_Id) return Boolean; + -- Determine whether the body of procedure Proc_Id contains a sole + -- null statement, possibly followed by an optional return. + + function Has_Public_Visibility_Of_Subprogram return Boolean; + -- Determine whether type Typ has public visibility of subprogram + -- Subp_Id. + + ------------------- + -- Has_Null_Body -- + ------------------- + + function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is + Body_Id : Entity_Id; + Decl : Node_Id; + Spec : Node_Id; + Stmt1 : Node_Id; + Stmt2 : Node_Id; + + begin + Spec := Parent (Proc_Id); + Decl := Parent (Spec); + + -- Retrieve the entity of the invariant procedure body + + if Nkind (Spec) = N_Procedure_Specification + and then Nkind (Decl) = N_Subprogram_Declaration + then + Body_Id := Corresponding_Body (Decl); + + -- The body acts as a spec + + else + Body_Id := Proc_Id; + end if; + + -- The body will be generated later + + if No (Body_Id) then + return False; + end if; + + Spec := Parent (Body_Id); + Decl := Parent (Spec); + + pragma Assert + (Nkind (Spec) = N_Procedure_Specification + and then Nkind (Decl) = N_Subprogram_Body); + + Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); + + -- Look for a null statement followed by an optional return + -- statement. + + if Nkind (Stmt1) = N_Null_Statement then + Stmt2 := Next (Stmt1); + + if Present (Stmt2) then + return Nkind (Stmt2) = N_Simple_Return_Statement; + else + return True; + end if; + end if; + + return False; + end Has_Null_Body; + + ----------------------------------------- + -- Has_Public_Visibility_Of_Subprogram -- + ----------------------------------------- + + function Has_Public_Visibility_Of_Subprogram return Boolean is + Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); + + begin + -- An Initialization procedure must be considered visible even + -- though it is internally generated. + + if Is_Init_Proc (Defining_Entity (Subp_Decl)) then + return True; + + elsif Ekind (Scope (Typ)) /= E_Package then + return False; + + -- Internally generated code is never publicly visible except + -- for a subprogram that is the implementation of an expression + -- function. In that case the visibility is determined by the + -- last check. + + elsif not Comes_From_Source (Subp_Decl) + and then + (Nkind (Original_Node (Subp_Decl)) /= N_Expression_Function + or else not + Comes_From_Source (Defining_Entity (Subp_Decl))) + then + return False; + + -- Determine whether the subprogram is declared in the visible + -- declarations of the package containing the type. + + else + return List_Containing (Subp_Decl) = + Visible_Declarations + (Specification (Unit_Declaration_Node (Scope (Typ)))); + end if; + end Has_Public_Visibility_Of_Subprogram; + + -- Start of processing for Invariant_Checks_OK + + begin + return + Has_Invariants (Typ) + and then Present (Invariant_Procedure (Typ)) + and then not Has_Null_Body (Invariant_Procedure (Typ)) + and then Has_Public_Visibility_Of_Subprogram; + end Invariant_Checks_OK; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (Body_Decl); + -- Source location of subprogram body contract + + Formal : Entity_Id; + Typ : Entity_Id; + + -- Start of processing for Add_Invariant_And_Predicate_Checks + + begin + Result := Empty; + + -- Process the result of a function + + if Ekind (Subp_Id) = E_Function then + Typ := Etype (Subp_Id); + + -- Generate _Result which is used in procedure _Postconditions to + -- verify the return value. + + Result := Make_Defining_Identifier (Loc, Name_uResult); + Set_Etype (Result, Typ); + + -- Add an invariant check when the return type has invariants and + -- the related function is visible to the outside. + + if Invariant_Checks_OK (Typ) then + Append_Enabled_Item + (Item => + Make_Invariant_Call (New_Occurrence_Of (Result, Loc)), + List => Stmts); + end if; + + -- Add an invariant check when the return type is an access to a + -- type with invariants. + + Add_Invariant_Access_Checks (Result); + end if; + + -- Add invariant and predicates for all formals that qualify + + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + Typ := Etype (Formal); + + if Ekind (Formal) /= E_In_Parameter + or else Is_Access_Type (Typ) + then + if Invariant_Checks_OK (Typ) then + Append_Enabled_Item + (Item => + Make_Invariant_Call (New_Occurrence_Of (Formal, Loc)), + List => Stmts); + end if; + + Add_Invariant_Access_Checks (Formal); + + -- Note: we used to add predicate checks for OUT and IN OUT + -- formals here, but that was misguided, since such checks are + -- performed on the caller side, based on the predicate of the + -- actual, rather than the predicate of the formal. + + end if; + + Next_Formal (Formal); + end loop; + end Add_Invariant_And_Predicate_Checks; + + ------------------------- + -- Append_Enabled_Item -- + ------------------------- + + procedure Append_Enabled_Item (Item : Node_Id; List : in out List_Id) is + begin + -- Do not chain ignored or disabled pragmas + + if Nkind (Item) = N_Pragma + and then (Is_Ignored (Item) or else Is_Disabled (Item)) + then + null; + + -- Otherwise, add the item + + else + if No (List) then + List := New_List; + end if; + + -- If the pragma is a conjunct in a composite postcondition, it + -- has been processed in reverse order. In the postcondition body + -- it must appear before the others. + + if Nkind (Item) = N_Pragma + and then From_Aspect_Specification (Item) + and then Split_PPC (Item) + then + Prepend (Item, List); + else + Append (Item, List); + end if; + end if; + end Append_Enabled_Item; + + ------------------------------------ + -- Build_Postconditions_Procedure -- + ------------------------------------ + + procedure Build_Postconditions_Procedure + (Subp_Id : Entity_Id; + Stmts : List_Id; + Result : Entity_Id) + is + procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id); + -- Insert node Stmt before the first source declaration of the + -- related subprogram's body. If no such declaration exists, Stmt + -- becomes the last declaration. + + -------------------------------------------- + -- Insert_Before_First_Source_Declaration -- + -------------------------------------------- + + procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id) is + Decls : constant List_Id := Declarations (Body_Decl); + Decl : Node_Id; + + begin + -- Inspect the declarations of the related subprogram body looking + -- for the first source declaration. + + if Present (Decls) then + Decl := First (Decls); + while Present (Decl) loop + if Comes_From_Source (Decl) then + Insert_Before (Decl, Stmt); + return; + end if; + + Next (Decl); + end loop; + + -- If we get there, then the subprogram body lacks any source + -- declarations. The body of _Postconditions now acts as the + -- last declaration. + + Append (Stmt, Decls); + + -- Ensure that the body has a declaration list + + else + Set_Declarations (Body_Decl, New_List (Stmt)); + end if; + end Insert_Before_First_Source_Declaration; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (Body_Decl); + Params : List_Id := No_List; + Proc_Bod : Node_Id; + Proc_Id : Entity_Id; + + -- Start of processing for Build_Postconditions_Procedure + + begin + -- Nothing to do if there are no actions to check on exit + + if No (Stmts) then + return; + end if; + + Proc_Id := Make_Defining_Identifier (Loc, Name_uPostconditions); + Set_Debug_Info_Needed (Proc_Id); + Set_Postconditions_Proc (Subp_Id, Proc_Id); + + -- The related subprogram is a function: create the specification of + -- parameter _Result. + + if Present (Result) then + Params := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Result, + Parameter_Type => + New_Occurrence_Of (Etype (Result), Loc))); + end if; + + -- Insert _Postconditions before the first source declaration of the + -- body. This ensures that the body will not cause any premature + -- freezing, as it may mention types: + + -- procedure Proc (Obj : Array_Typ) is + -- procedure _postconditions is + -- begin + -- ... Obj ... + -- end _postconditions; + + -- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1)); + -- begin + + -- In the example above, Obj is of type T but the incorrect placement + -- of _Postconditions will cause a crash in gigi due to an out-of- + -- order reference. The body of _Postconditions must be placed after + -- the declaration of Temp to preserve correct visibility. + + -- Set an explicit End_Label to override the sloc of the implicit + -- RETURN statement, and prevent it from inheriting the sloc of one + -- the postconditions: this would cause confusing debug info to be + -- produced, interfering with coverage-analysis tools. + + Proc_Bod := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => Params), + + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts, + End_Label => Make_Identifier (Loc, Chars (Proc_Id)))); + + Insert_Before_First_Source_Declaration (Proc_Bod); + Analyze (Proc_Bod); + end Build_Postconditions_Procedure; + + ----------------------------------- + -- Build_Pragma_Check_Equivalent -- + ----------------------------------- + + function Build_Pragma_Check_Equivalent + (Prag : Node_Id; + Subp_Id : Entity_Id := Empty; + Inher_Id : Entity_Id := Empty) return Node_Id + is + function Suppress_Reference (N : Node_Id) return Traverse_Result; + -- Detect whether node N references a formal parameter subject to + -- pragma Unreferenced. If this is the case, set Comes_From_Source + -- to False to suppress the generation of a reference when analyzing + -- N later on. + + ------------------------ + -- Suppress_Reference -- + ------------------------ + + function Suppress_Reference (N : Node_Id) return Traverse_Result is + Formal : Entity_Id; + + begin + if Is_Entity_Name (N) and then Present (Entity (N)) then + Formal := Entity (N); + + -- The formal parameter is subject to pragma Unreferenced. + -- Prevent the generation of a reference by resetting the + -- Comes_From_Source flag. + + if Is_Formal (Formal) + and then Has_Pragma_Unreferenced (Formal) + then + Set_Comes_From_Source (N, False); + end if; + end if; + + return OK; + end Suppress_Reference; + + procedure Suppress_References is + new Traverse_Proc (Suppress_Reference); + + -- Local variables + + Loc : constant Source_Ptr := Sloc (Prag); + Prag_Nam : constant Name_Id := Pragma_Name (Prag); + Check_Prag : Node_Id; + Formals_Map : Elist_Id; + Inher_Formal : Entity_Id; + Msg_Arg : Node_Id; + Nam : Name_Id; + Subp_Formal : Entity_Id; + + -- Start of processing for Build_Pragma_Check_Equivalent + + begin + Formals_Map := No_Elist; + + -- When the pre- or postcondition is inherited, map the formals of + -- the inherited subprogram to those of the current subprogram. + + if Present (Inher_Id) then + pragma Assert (Present (Subp_Id)); + + Formals_Map := New_Elmt_List; + + -- Create a relation <inherited formal> => <subprogram formal> + + Inher_Formal := First_Formal (Inher_Id); + Subp_Formal := First_Formal (Subp_Id); + while Present (Inher_Formal) and then Present (Subp_Formal) loop + Append_Elmt (Inher_Formal, Formals_Map); + Append_Elmt (Subp_Formal, Formals_Map); + + Next_Formal (Inher_Formal); + Next_Formal (Subp_Formal); + end loop; + end if; + + -- Copy the original pragma while performing substitutions (if + -- applicable). + + Check_Prag := + New_Copy_Tree + (Source => Prag, + Map => Formals_Map, + New_Scope => Current_Scope); + + -- Mark the pragma as being internally generated and reset the + -- Analyzed flag. + + Set_Analyzed (Check_Prag, False); + Set_Comes_From_Source (Check_Prag, False); + + -- The tree of the original pragma may contain references to the + -- formal parameters of the related subprogram. At the same time + -- the corresponding body may mark the formals as unreferenced: + + -- procedure Proc (Formal : ...) + -- with Pre => Formal ...; + + -- procedure Proc (Formal : ...) is + -- pragma Unreferenced (Formal); + -- ... + + -- This creates problems because all pragma Check equivalents are + -- analyzed at the end of the body declarations. Since all source + -- references have already been accounted for, reset any references + -- to such formals in the generated pragma Check equivalent. + + Suppress_References (Check_Prag); + + if Present (Corresponding_Aspect (Prag)) then + Nam := Chars (Identifier (Corresponding_Aspect (Prag))); + else + Nam := Prag_Nam; + end if; + + -- Convert the copy into pragma Check by correcting the name and + -- adding a check_kind argument. + + Set_Pragma_Identifier + (Check_Prag, Make_Identifier (Loc, Name_Check)); + + Prepend_To (Pragma_Argument_Associations (Check_Prag), + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Nam))); + + -- Update the error message when the pragma is inherited + + if Present (Inher_Id) then + Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag)); + + if Chars (Msg_Arg) = Name_Message then + String_To_Name_Buffer (Strval (Expression (Msg_Arg))); + + -- Insert "inherited" to improve the error message + + if Name_Buffer (1 .. 8) = "failed p" then + Insert_Str_In_Name_Buffer ("inherited ", 8); + Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer); + end if; + end if; + end if; + + return Check_Prag; + end Build_Pragma_Check_Equivalent; + + ---------------------------- + -- Process_Contract_Cases -- + ---------------------------- + + procedure Process_Contract_Cases (Stmts : in out List_Id) is + procedure Process_Contract_Cases_For (Subp_Id : Entity_Id); + -- Process pragma Contract_Cases for subprogram Subp_Id + + -------------------------------- + -- Process_Contract_Cases_For -- + -------------------------------- + + procedure Process_Contract_Cases_For (Subp_Id : Entity_Id) is + Items : constant Node_Id := Contract (Subp_Id); + Prag : Node_Id; + + begin + if Present (Items) then + Prag := Contract_Test_Cases (Items); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Contract_Cases then + Expand_Pragma_Contract_Cases + (CCs => Prag, + Subp_Id => Subp_Id, + Decls => Declarations (Body_Decl), + Stmts => Stmts); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + end Process_Contract_Cases_For; + + -- Start of processing for Process_Contract_Cases + + begin + Process_Contract_Cases_For (Body_Id); + + if Present (Spec_Id) then + Process_Contract_Cases_For (Spec_Id); + end if; + end Process_Contract_Cases; + + ---------------------------- + -- Process_Postconditions -- + ---------------------------- + + procedure Process_Postconditions (Stmts : in out List_Id) is + procedure Process_Body_Postconditions (Post_Nam : Name_Id); + -- Collect all [refined] postconditions of a specific kind denoted + -- by Post_Nam that belong to the body, and generate pragma Check + -- equivalents in list Stmts. + + procedure Process_Spec_Postconditions; + -- Collect all [inherited] postconditions of the spec, and generate + -- pragma Check equivalents in list Stmts. + + --------------------------------- + -- Process_Body_Postconditions -- + --------------------------------- + + procedure Process_Body_Postconditions (Post_Nam : Name_Id) is + Items : constant Node_Id := Contract (Body_Id); + Unit_Decl : constant Node_Id := Parent (Body_Decl); + Decl : Node_Id; + Prag : Node_Id; + + begin + -- Process the contract + + if Present (Items) then + Prag := Pre_Post_Conditions (Items); + while Present (Prag) loop + if Pragma_Name (Prag) = Post_Nam then + Append_Enabled_Item + (Item => Build_Pragma_Check_Equivalent (Prag), + List => Stmts); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + + -- The subprogram body being processed is actually the proper body + -- of a stub with a corresponding spec. The subprogram stub may + -- carry a postcondition pragma, in which case it must be taken + -- into account. The pragma appears after the stub. + + if Present (Spec_Id) and then Nkind (Unit_Decl) = N_Subunit then + Decl := Next (Corresponding_Stub (Unit_Decl)); + while Present (Decl) loop + + -- Note that non-matching pragmas are skipped + + if Nkind (Decl) = N_Pragma then + if Pragma_Name (Decl) = Post_Nam then + Append_Enabled_Item + (Item => Build_Pragma_Check_Equivalent (Decl), + List => Stmts); + end if; + + -- Skip internally generated code + + elsif not Comes_From_Source (Decl) then + null; + + -- Postcondition pragmas are usually grouped together. There + -- is no need to inspect the whole declarative list. + + else + exit; + end if; + + Next (Decl); + end loop; + end if; + end Process_Body_Postconditions; + + --------------------------------- + -- Process_Spec_Postconditions -- + --------------------------------- + + procedure Process_Spec_Postconditions is + Subps : constant Subprogram_List := + Inherited_Subprograms (Spec_Id); + Items : Node_Id; + Prag : Node_Id; + Subp_Id : Entity_Id; + + begin + -- Process the contract + + Items := Contract (Spec_Id); + + if Present (Items) then + Prag := Pre_Post_Conditions (Items); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Postcondition then + Append_Enabled_Item + (Item => Build_Pragma_Check_Equivalent (Prag), + List => Stmts); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + + -- Process the contracts of all inherited subprograms, looking for + -- class-wide postconditions. + + for Index in Subps'Range loop + Subp_Id := Subps (Index); + Items := Contract (Subp_Id); + + if Present (Items) then + Prag := Pre_Post_Conditions (Items); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Postcondition + and then Class_Present (Prag) + then + Append_Enabled_Item + (Item => + Build_Pragma_Check_Equivalent + (Prag => Prag, + Subp_Id => Spec_Id, + Inher_Id => Subp_Id), + List => Stmts); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + end loop; + end Process_Spec_Postconditions; + + -- Start of processing for Process_Postconditions + + begin + -- The processing of postconditions is done in reverse order (body + -- first) to ensure the following arrangement: + + -- <refined postconditions from body> + -- <postconditions from body> + -- <postconditions from spec> + -- <inherited postconditions> + + Process_Body_Postconditions (Name_Refined_Post); + Process_Body_Postconditions (Name_Postcondition); + + if Present (Spec_Id) then + Process_Spec_Postconditions; + end if; + end Process_Postconditions; + + --------------------------- + -- Process_Preconditions -- + --------------------------- + + procedure Process_Preconditions is + Class_Pre : Node_Id := Empty; + -- The sole [inherited] class-wide precondition pragma that applies + -- to the subprogram. + + Insert_Node : Node_Id := Empty; + -- The insertion node after which all pragma Check equivalents are + -- inserted. + + procedure Merge_Preconditions (From : Node_Id; Into : Node_Id); + -- Merge two class-wide preconditions by "or else"-ing them. The + -- changes are accumulated in parameter Into. Update the error + -- message of Into. + + procedure Prepend_To_Decls (Item : Node_Id); + -- Prepend a single item to the declarations of the subprogram body + + procedure Prepend_To_Decls_Or_Save (Prag : Node_Id); + -- Save a class-wide precondition into Class_Pre, or prepend a normal + -- precondition to the declarations of the body and analyze it. + + procedure Process_Inherited_Preconditions; + -- Collect all inherited class-wide preconditions and merge them into + -- one big precondition to be evaluated as pragma Check. + + procedure Process_Preconditions_For (Subp_Id : Entity_Id); + -- Collect all preconditions of subprogram Subp_Id and prepend their + -- pragma Check equivalents to the declarations of the body. + + ------------------------- + -- Merge_Preconditions -- + ------------------------- + + procedure Merge_Preconditions (From : Node_Id; Into : Node_Id) is + function Expression_Arg (Prag : Node_Id) return Node_Id; + -- Return the boolean expression argument of a precondition while + -- updating its parentheses count for the subsequent merge. + + function Message_Arg (Prag : Node_Id) return Node_Id; + -- Return the message argument of a precondition + + -------------------- + -- Expression_Arg -- + -------------------- + + function Expression_Arg (Prag : Node_Id) return Node_Id is + Args : constant List_Id := Pragma_Argument_Associations (Prag); + Arg : constant Node_Id := Get_Pragma_Arg (Next (First (Args))); + + begin + if Paren_Count (Arg) = 0 then + Set_Paren_Count (Arg, 1); + end if; + + return Arg; + end Expression_Arg; + + ----------------- + -- Message_Arg -- + ----------------- + + function Message_Arg (Prag : Node_Id) return Node_Id is + Args : constant List_Id := Pragma_Argument_Associations (Prag); + begin + return Get_Pragma_Arg (Last (Args)); + end Message_Arg; + + -- Local variables + + From_Expr : constant Node_Id := Expression_Arg (From); + From_Msg : constant Node_Id := Message_Arg (From); + Into_Expr : constant Node_Id := Expression_Arg (Into); + Into_Msg : constant Node_Id := Message_Arg (Into); + Loc : constant Source_Ptr := Sloc (Into); + + -- Start of processing for Merge_Preconditions + + begin + -- Merge the two preconditions by "or else"-ing them + + Rewrite (Into_Expr, + Make_Or_Else (Loc, + Right_Opnd => Relocate_Node (Into_Expr), + Left_Opnd => From_Expr)); + + -- Merge the two error messages to produce a single message of the + -- form: + + -- failed precondition from ... + -- also failed inherited precondition from ... + + if not Exception_Locations_Suppressed then + Start_String (Strval (Into_Msg)); + Store_String_Char (ASCII.LF); + Store_String_Chars (" also "); + Store_String_Chars (Strval (From_Msg)); + + Set_Strval (Into_Msg, End_String); + end if; + end Merge_Preconditions; + + ---------------------- + -- Prepend_To_Decls -- + ---------------------- + + procedure Prepend_To_Decls (Item : Node_Id) is + Decls : List_Id := Declarations (Body_Decl); + + begin + -- Ensure that the body has a declarative list + + if No (Decls) then + Decls := New_List; + Set_Declarations (Body_Decl, Decls); + end if; + + Prepend_To (Decls, Item); + end Prepend_To_Decls; + + ------------------------------ + -- Prepend_To_Decls_Or_Save -- + ------------------------------ + + procedure Prepend_To_Decls_Or_Save (Prag : Node_Id) is + Check_Prag : Node_Id; + + begin + Check_Prag := Build_Pragma_Check_Equivalent (Prag); + + -- Save the sole class-wide precondition (if any) for the next + -- step, where it will be merged with inherited preconditions. + + if Class_Present (Prag) then + pragma Assert (No (Class_Pre)); + Class_Pre := Check_Prag; + + -- Accumulate the corresponding Check pragmas at the top of the + -- declarations. Prepending the items ensures that they will be + -- evaluated in their original order. + + else + if Present (Insert_Node) then + Insert_After (Insert_Node, Check_Prag); + else + Prepend_To_Decls (Check_Prag); + end if; + + Analyze (Check_Prag); + end if; + end Prepend_To_Decls_Or_Save; + + ------------------------------------- + -- Process_Inherited_Preconditions -- + ------------------------------------- + + procedure Process_Inherited_Preconditions is + Subps : constant Subprogram_List := + Inherited_Subprograms (Spec_Id); + Check_Prag : Node_Id; + Items : Node_Id; + Prag : Node_Id; + Subp_Id : Entity_Id; + + begin + -- Process the contracts of all inherited subprograms, looking for + -- class-wide preconditions. + + for Index in Subps'Range loop + Subp_Id := Subps (Index); + Items := Contract (Subp_Id); + + if Present (Items) then + Prag := Pre_Post_Conditions (Items); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Precondition + and then Class_Present (Prag) + then + Check_Prag := + Build_Pragma_Check_Equivalent + (Prag => Prag, + Subp_Id => Spec_Id, + Inher_Id => Subp_Id); + + -- The spec of an inherited subprogram already yielded + -- a class-wide precondition. Merge the existing + -- precondition with the current one using "or else". + + if Present (Class_Pre) then + Merge_Preconditions (Check_Prag, Class_Pre); + else + Class_Pre := Check_Prag; + end if; + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + end loop; + + -- Add the merged class-wide preconditions + + if Present (Class_Pre) then + Prepend_To_Decls (Class_Pre); + Analyze (Class_Pre); + end if; + end Process_Inherited_Preconditions; + + ------------------------------- + -- Process_Preconditions_For -- + ------------------------------- + + procedure Process_Preconditions_For (Subp_Id : Entity_Id) is + Items : constant Node_Id := Contract (Subp_Id); + Decl : Node_Id; + Prag : Node_Id; + Subp_Decl : Node_Id; + + begin + -- Process the contract + + if Present (Items) then + Prag := Pre_Post_Conditions (Items); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Precondition then + Prepend_To_Decls_Or_Save (Prag); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + + -- The subprogram declaration being processed is actually a body + -- stub. The stub may carry a precondition pragma, in which case + -- it must be taken into account. The pragma appears after the + -- stub. + + Subp_Decl := Unit_Declaration_Node (Subp_Id); + + if Nkind (Subp_Decl) = N_Subprogram_Body_Stub then + + -- Inspect the declarations following the body stub + + Decl := Next (Subp_Decl); + while Present (Decl) loop + + -- Note that non-matching pragmas are skipped + + if Nkind (Decl) = N_Pragma then + if Pragma_Name (Decl) = Name_Precondition then + Prepend_To_Decls_Or_Save (Decl); + end if; + + -- Skip internally generated code + + elsif not Comes_From_Source (Decl) then + null; + + -- Preconditions are usually grouped together. There is no + -- need to inspect the whole declarative list. + + else + exit; + end if; + + Next (Decl); + end loop; + end if; + end Process_Preconditions_For; + + -- Local variables + + Decls : constant List_Id := Declarations (Body_Decl); + Decl : Node_Id; + + -- Start of processing for Process_Preconditions + + begin + -- Find the last internally generated declaration, starting from the + -- top of the body declarations. This ensures that discriminals and + -- subtypes are properly visible to the pragma Check equivalents. + + if Present (Decls) then + Decl := First (Decls); + while Present (Decl) loop + exit when Comes_From_Source (Decl); + Insert_Node := Decl; + Next (Decl); + end loop; + end if; + + -- The processing of preconditions is done in reverse order (body + -- first), because each pragma Check equivalent is inserted at the + -- top of the declarations. This ensures that the final order is + -- consistent with following diagram: + + -- <inherited preconditions> + -- <preconditions from spec> + -- <preconditions from body> + + Process_Preconditions_For (Body_Id); + + if Present (Spec_Id) then + Process_Preconditions_For (Spec_Id); + Process_Inherited_Preconditions; + end if; + end Process_Preconditions; + + -- Local variables + + Restore_Scope : Boolean := False; + Result : Entity_Id; + Stmts : List_Id := No_List; + Subp_Id : Entity_Id; + + -- Start of processing for Expand_Subprogram_Contract + + begin + -- Obtain the entity of the initial declaration + + if Present (Spec_Id) then + Subp_Id := Spec_Id; + else + Subp_Id := Body_Id; + end if; + + -- Do not perform expansion activity when it is not needed + + if not Expander_Active then + return; + + -- ASIS requires an unaltered tree + + elsif ASIS_Mode then + return; + + -- GNATprove does not need the executable semantics of a contract + + elsif GNATprove_Mode then + return; + + -- The contract of a generic subprogram or one declared in a generic + -- context is not expanded, as the corresponding instance will provide + -- the executable semantics of the contract. + + elsif Is_Generic_Subprogram (Subp_Id) or else Inside_A_Generic then + return; + + -- All subprograms carry a contract, but for some it is not significant + -- and should not be processed. This is a small optimization. + + elsif not Has_Significant_Contract (Subp_Id) then + return; + + -- The contract of an ignored Ghost subprogram does not need expansion, + -- because the subprogram and all calls to it will be removed. + + elsif Is_Ignored_Ghost_Entity (Subp_Id) then + return; + end if; + + -- Do not re-expand the same contract. This scenario occurs when a + -- construct is rewritten into something else during its analysis + -- (expression functions for instance). + + if Has_Expanded_Contract (Subp_Id) then + return; + + -- Otherwise mark the subprogram + + else + Set_Has_Expanded_Contract (Subp_Id); + end if; + + -- Ensure that the formal parameters are visible when expanding all + -- contract items. + + if not In_Open_Scopes (Subp_Id) then + Restore_Scope := True; + Push_Scope (Subp_Id); + + if Is_Generic_Subprogram (Subp_Id) then + Install_Generic_Formals (Subp_Id); + else + Install_Formals (Subp_Id); + end if; + end if; + + -- The expansion of a subprogram contract involves the creation of Check + -- pragmas to verify the contract assertions of the spec and body in a + -- particular order. The order is as follows: + + -- function Example (...) return ... is + -- procedure _Postconditions (...) is + -- begin + -- <refined postconditions from body> + -- <postconditions from body> + -- <postconditions from spec> + -- <inherited postconditions> + -- <contract case consequences> + -- <invariant check of function result> + -- <invariant and predicate checks of parameters> + -- end _Postconditions; + + -- <inherited preconditions> + -- <preconditions from spec> + -- <preconditions from body> + -- <contract case conditions> + + -- <source declarations> + -- begin + -- <source statements> + + -- _Preconditions (Result); + -- return Result; + -- end Example; + + -- Routine _Postconditions holds all contract assertions that must be + -- verified on exit from the related subprogram. + + -- Step 1: Handle all preconditions. This action must come before the + -- processing of pragma Contract_Cases because the pragma prepends items + -- to the body declarations. + + Process_Preconditions; + + -- Step 2: Handle all postconditions. This action must come before the + -- processing of pragma Contract_Cases because the pragma appends items + -- to list Stmts. + + Process_Postconditions (Stmts); + + -- Step 3: Handle pragma Contract_Cases. This action must come before + -- the processing of invariants and predicates because those append + -- items to list Stmts. + + Process_Contract_Cases (Stmts); + + -- Step 4: Apply invariant and predicate checks on a function result and + -- all formals. The resulting checks are accumulated in list Stmts. + + Add_Invariant_And_Predicate_Checks (Subp_Id, Stmts, Result); + + -- Step 5: Construct procedure _Postconditions + + Build_Postconditions_Procedure (Subp_Id, Stmts, Result); + + if Restore_Scope then + End_Scope; + end if; + end Expand_Subprogram_Contract; + + --------------------------------- + -- Inherit_Subprogram_Contract -- + --------------------------------- + + procedure Inherit_Subprogram_Contract + (Subp : Entity_Id; + From_Subp : Entity_Id) + is + procedure Inherit_Pragma (Prag_Id : Pragma_Id); + -- Propagate a pragma denoted by Prag_Id from From_Subp's contract to + -- Subp's contract. + + -------------------- + -- Inherit_Pragma -- + -------------------- + + procedure Inherit_Pragma (Prag_Id : Pragma_Id) is + Prag : constant Node_Id := Get_Pragma (From_Subp, Prag_Id); + New_Prag : Node_Id; + + begin + -- A pragma cannot be part of more than one First_Pragma/Next_Pragma + -- chains, therefore the node must be replicated. The new pragma is + -- flagged as inherited for distinction purposes. + + if Present (Prag) then + New_Prag := New_Copy_Tree (Prag); + Set_Is_Inherited_Pragma (New_Prag); + + Add_Contract_Item (New_Prag, Subp); + end if; + end Inherit_Pragma; + + -- Start of processing for Inherit_Subprogram_Contract + + begin + -- Inheritance is carried out only when both entities are subprograms + -- with contracts. + + if Is_Subprogram_Or_Generic_Subprogram (Subp) + and then Is_Subprogram_Or_Generic_Subprogram (From_Subp) + and then Present (Contract (From_Subp)) + then + Inherit_Pragma (Pragma_Extensions_Visible); + end if; + end Inherit_Subprogram_Contract; + + ------------------------------------- + -- Instantiate_Subprogram_Contract -- + ------------------------------------- + + procedure Instantiate_Subprogram_Contract (Templ : Node_Id; L : List_Id) is + procedure Instantiate_Pragmas (First_Prag : Node_Id); + -- Instantiate all contract-related source pragmas found in the list, + -- starting with pragma First_Prag. Each instantiated pragma is added + -- to list L. + + ------------------------- + -- Instantiate_Pragmas -- + ------------------------- + + procedure Instantiate_Pragmas (First_Prag : Node_Id) is + Inst_Prag : Node_Id; + Prag : Node_Id; + + begin + Prag := First_Prag; + while Present (Prag) loop + if Is_Generic_Contract_Pragma (Prag) then + Inst_Prag := + Copy_Generic_Node (Prag, Empty, Instantiating => True); + + Set_Analyzed (Inst_Prag, False); + Append_To (L, Inst_Prag); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end Instantiate_Pragmas; + + -- Local variables + + Items : constant Node_Id := Contract (Defining_Entity (Templ)); + + -- Start of processing for Instantiate_Subprogram_Contract + + begin + if Present (Items) then + Instantiate_Pragmas (Pre_Post_Conditions (Items)); + Instantiate_Pragmas (Contract_Test_Cases (Items)); + Instantiate_Pragmas (Classifications (Items)); + end if; + end Instantiate_Subprogram_Contract; + + ---------------------------------------- + -- Save_Global_References_In_Contract -- + ---------------------------------------- + + procedure Save_Global_References_In_Contract + (Templ : Node_Id; + Gen_Id : Entity_Id) + is + procedure Save_Global_References_In_List (First_Prag : Node_Id); + -- Save all global references in contract-related source pragmas found + -- in the list, starting with pragma First_Prag. + + ------------------------------------ + -- Save_Global_References_In_List -- + ------------------------------------ + + procedure Save_Global_References_In_List (First_Prag : Node_Id) is + Prag : Node_Id; + + begin + Prag := First_Prag; + while Present (Prag) loop + if Is_Generic_Contract_Pragma (Prag) then + Save_Global_References (Prag); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end Save_Global_References_In_List; + + -- Local variables + + Items : constant Node_Id := Contract (Defining_Entity (Templ)); + + -- Start of processing for Save_Global_References_In_Contract + + begin + -- The entity of the analyzed generic copy must be on the scope stack + -- to ensure proper detection of global references. + + Push_Scope (Gen_Id); + + if Permits_Aspect_Specifications (Templ) + and then Has_Aspects (Templ) + then + Save_Global_References_In_Aspects (Templ); + end if; + + if Present (Items) then + Save_Global_References_In_List (Pre_Post_Conditions (Items)); + Save_Global_References_In_List (Contract_Test_Cases (Items)); + Save_Global_References_In_List (Classifications (Items)); + end if; + + Pop_Scope; + end Save_Global_References_In_Contract; + +end Contracts; diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads new file mode 100644 index 00000000000..21c609d5b2a --- /dev/null +++ b/gcc/ada/contracts.ads @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C O N T R A C T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2015, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines that perform analysis and expansion of +-- various contracts. + +with Types; use Types; + +package Contracts is + + procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id); + -- Add pragma Prag to the contract of a constant, entry, entry family, + -- [generic] package, package body, protected unit, [generic] subprogram, + -- subprogram body, variable or task unit denoted by Id. The following are + -- valid pragmas: + -- Abstract_State + -- Async_Readers + -- Async_Writers + -- Constant_After_Elaboration + -- Contract_Cases + -- Depends + -- Effective_Reads + -- Effective_Writes + -- Extensions_Visible + -- Global + -- Initial_Condition + -- Initializes + -- Part_Of + -- Postcondition + -- Precondition + -- Refined_Depends + -- Refined_Global + -- Refined_Post + -- Refined_States + -- Test_Case + -- Volatile_Function + + procedure Analyze_Enclosing_Package_Body_Contract (Body_Decl : Node_Id); + -- Analyze the contract of the nearest package body (if any) which encloses + -- package or subprogram body Body_Decl. + + procedure Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id : Entity_Id); + -- Analyze all delayed pragmas chained on the contract of entry or + -- subprogram body Body_Id as if they appeared at the end of a declarative + -- region. Pragmas in question are: + -- Contract_Cases (stand alone subprogram body) + -- Depends (stand alone subprogram body) + -- Global (stand alone subprogram body) + -- Postcondition (stand alone subprogram body) + -- Precondition (stand alone subprogram body) + -- Refined_Depends + -- Refined_Global + -- Refined_Post + -- Test_Case (stand alone subprogram body) + + procedure Analyze_Entry_Or_Subprogram_Contract (Subp_Id : Entity_Id); + -- Analyze all delayed pragmas chained on the contract of entry or + -- subprogram Subp_Id as if they appeared at the end of a declarative + -- region. The pragmas in question are: + -- Contract_Cases + -- Depends + -- Global + -- Postcondition + -- Precondition + -- Test_Case + + procedure Analyze_Initial_Declaration_Contract (Body_Decl : Node_Id); + -- Analyze the contract of the initial declaration of entry body, package + -- body, protected body, subprogram body or task body Body_Decl. + + procedure Analyze_Object_Contract (Obj_Id : Entity_Id); + -- Analyze all delayed pragmas chained on the contract of object Obj_Id as + -- if they appeared at the end of the declarative region. The pragmas to be + -- considered are: + -- Async_Readers + -- Async_Writers + -- Depends (single concurrent object) + -- Effective_Reads + -- Effective_Writes + -- Global (single concurrent object) + -- Part_Of + + procedure Analyze_Package_Body_Contract + (Body_Id : Entity_Id; + Freeze_Id : Entity_Id := Empty); + -- Analyze all delayed pragmas chained on the contract of package body + -- Body_Id as if they appeared at the end of a declarative region. The + -- pragmas that are considered are: + -- Refined_State + -- + -- Freeze_Id is the entity of a [generic] package body or a [generic] + -- subprogram body which "freezes" the contract of Body_Id. + + procedure Analyze_Package_Contract (Pack_Id : Entity_Id); + -- Analyze all delayed pragmas chained on the contract of package Pack_Id + -- as if they appeared at the end of a declarative region. The pragmas + -- that are considered are: + -- Initial_Condition + -- Initializes + -- Part_Of + + procedure Analyze_Protected_Contract (Prot_Id : Entity_Id); + -- Analyze all delayed pragmas chained on the contract of protected unit + -- Prot_Id if they appeared at the end of a declarative region. Currently + -- there are no such pragmas. + + procedure Analyze_Subprogram_Body_Stub_Contract (Stub_Id : Entity_Id); + -- Analyze all delayed pragmas chained on the contract of subprogram body + -- stub Stub_Id as if they appeared at the end of a declarative region. The + -- pragmas in question are: + -- Contract_Cases + -- Depends + -- Global + -- Postcondition + -- Precondition + -- Refined_Depends + -- Refined_Global + -- Refined_Post + -- Test_Case + + procedure Analyze_Task_Contract (Task_Id : Entity_Id); + -- Analyze all delayed pragmas chained on the contract of task unit Task_Id + -- as if they appeared at the end of a declarative region. The pragmas in + -- question are: + -- Depends + -- Global + + procedure Create_Generic_Contract (Unit : Node_Id); + -- Create a contract node for a generic package, generic subprogram, or a + -- generic body denoted by Unit by collecting all source contract-related + -- pragmas in the contract of the unit. + + procedure Inherit_Subprogram_Contract + (Subp : Entity_Id; + From_Subp : Entity_Id); + -- Inherit relevant contract items from source subprogram From_Subp. Subp + -- denotes the destination subprogram. The inherited items are: + -- Extensions_Visible + -- ??? it would be nice if this routine handles Pre'Class and Post'Class + + procedure Instantiate_Subprogram_Contract (Templ : Node_Id; L : List_Id); + -- Instantiate all source pragmas found in the contract of the generic + -- subprogram declaration template denoted by Templ. The instantiated + -- pragmas are added to list L. + + procedure Save_Global_References_In_Contract + (Templ : Node_Id; + Gen_Id : Entity_Id); + -- Save all global references found within the aspect specifications and + -- the contract-related source pragmas assocated with generic template + -- Templ. Gen_Id denotes the entity of the analyzed generic copy. + +end Contracts; diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index da30887b36d..3d627c8c13f 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1425,8 +1425,8 @@ package body CStand is Dhi := Intval (Type_High_Bound (Standard_Integer_32)); Delta_Val := UR_From_Components (UI_From_Int (20), Uint_3, 10); - -- In standard 64-bit mode, the size is 64-bits and the delta and - -- small values are set to nanoseconds (1.0*(10.0**(-9)) + -- In 64-bit mode, the size is 64-bits and the delta and + -- small values are set to nanoseconds (1.0*(10.0**(-9)). else Dlo := Intval (Type_Low_Bound (Standard_Integer_64)); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 87e0de74dc6..b38b82b102c 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -73,14 +73,14 @@ package body Debug is -- dG Generate all warnings including those normally suppressed -- dH Hold (kill) call to gigi -- dI Inhibit internal name numbering in gnatG listing - -- dJ Output debugging trace info for JGNAT (Java VM version of GNAT) + -- dJ -- dK Kill all error messages -- dL Output trace information on elaboration checking -- dM Assume all variables are modified (no current values) -- dN No file name information in exception messages -- dO Output immediate error messages -- dP Do not check for controlled objects in preelaborable packages - -- dQ + -- dQ Use old secondary stack method -- dR Bypass check for correct version of s-rpc -- dS Never convert numbers to machine numbers in Sem_Eval -- dT Convert to machine numbers only for constant declarations @@ -105,8 +105,8 @@ package body Debug is -- d.l Use Ada 95 semantics for limited function returns -- d.m For -gnatl, print full source only for main unit -- d.n Print source file names - -- d.o Generate .NET listing of CIL code - -- d.p Enable the .NET CIL verifier + -- d.o + -- d.p -- d.q -- d.r Enable OK_To_Reorder_Components in non-variant records -- d.s Disable expansion of slice move, use memmove @@ -119,7 +119,7 @@ package body Debug is -- d.z Restore previous support for frontend handling of Inline_Always -- d.A Read/write Aspect_Specifications hash table to tree - -- d.B + -- d.B Generate a bug box on abort_statement -- d.C Generate concatenation call, do not generate inline code -- d.D Disable errors on use of overriding keyword in Ada 95 mode -- d.E Turn selected errors into warnings @@ -159,7 +159,7 @@ package body Debug is -- d.2 Allow statements in declarative part -- d.3 Output debugging information from Exp_Unst -- d.4 - -- d.5 + -- d.5 Do not generate imported subprogram definitions in C code -- d.6 -- d.7 -- d.8 @@ -316,14 +316,15 @@ package body Debug is -- dt Print full tree. The generated tree is output (see also df,dy) -- du Uncheck categorization pragmas. This debug switch causes the - -- categorization pragmas (Pure, Preelaborate etc) to be ignored - -- so that normal checks are not made (this is particularly useful - -- for adding temporary debugging code to units that have pragmas - -- that are inconsistent with the debugging code added. + -- elaboration control pragmas (Pure, Preelaborate, etc.) and the + -- categorization pragmas (Shared_Passive, Remote_Types, etc.) to be + -- ignored, so that normal checks are not made (this is particularly + -- useful for adding temporary debugging code to units that have + -- pragmas that are inconsistent with the debugging code added). -- dv Output trace of overload resolution. Outputs messages for -- overload attempts that involve cascaded errors, or where - -- an interepretation is incompatible with the context. + -- an interpretation is incompatible with the context. -- dw Write semantic scope stack messages. Each time a scope is created -- or removed, a message is output (see the Sem_Ch8.Push_Scope and @@ -399,11 +400,6 @@ package body Debug is -- is used in the fixed bugs run to minimize system and version -- dependency in filed -gnatD or -gnatG output. - -- dJ Generate debugging trace output for the JGNAT back end. This - -- consists of symbolic Java Byte Code sequences for all generated - -- classes plus additional information to indicate local variables - -- and methods. - -- dK Kill all error messages. This debug flag suppresses the output -- of all error messages. It is used in regression tests where the -- error messages are target dependent and irrelevant. @@ -430,6 +426,11 @@ package body Debug is -- in preelaborable packages, but this restriction is a huge pain, -- especially in the predefined library units. + -- dQ Use old method for determining what goes on the secondary stack. + -- This disables some newer optimizations. The intent is to use this + -- temporarily to measure before/after efficiency. ???Remove this + -- when we are done (see Sem_Util.Requires_Transient_Scope). + -- dR Bypass the check for a proper version of s-rpc being present -- to use the -gnatz? switch. This allows debugging of the use -- of stubs generation without needing to have GLADE (or some @@ -555,13 +556,6 @@ package body Debug is -- compiler has a bug -- these are the files that need to be included -- in a bug report. - -- d.o Generate listing showing the IL instructions generated by the .NET - -- compiler for each subprogram. - - -- d.p Enable the .NET CIL verifier. During development the verifier is - -- disabled by default and this flag is used to enable it. In the - -- future we will reverse this functionality. - -- d.r Forces the flag OK_To_Reorder_Components to be set in all record -- base types that have no discriminants. @@ -592,16 +586,23 @@ package body Debug is -- d.z Restore previous front-end support for Inline_Always. In default -- mode, for targets that use the GCC back end (i.e. currently all - -- targets except AAMP, .NET, JVM, and GNATprove), Inline_Always is - -- handled by the back end. Use of this switch restores the previous - -- handling of Inline_Always by the front end on such targets. For the - -- targets that do not use the GCC back end, this switch is ignored. + -- targets except AAMP and GNATprove), Inline_Always is handled by the + -- back end. Use of this switch restores the previous handling of + -- Inline_Always by the front end on such targets. For the targets + -- that do not use the GCC back end, this switch is ignored. -- d.A There seems to be a problem with ASIS if we activate the circuit -- for reading and writing the aspect specification hash table, so -- for now, this is controlled by the debug flag d.A. The hash table -- is only written and read if this flag is set. + -- d.B Generate a bug box when we see an abort_statement, even though + -- there is no bug. Useful for testing Comperr.Compiler_Abort: write + -- some code containing an abort_statement, and compile it with + -- -gnatd.B. There is nothing special about abort_statements; it just + -- provides a way to control where the bug box is generated. See "when + -- N_Abort_Statement" in package body Expander. + -- d.C Generate call to System.Concat_n.Str_Concat_n routines in cases -- where we would normally generate inline concatenation code. @@ -694,8 +695,8 @@ package body Debug is -- d.X A previous version of GNAT allowed indexing aspects to be redefined -- on derived container types, while the default iterator was - -- inherited from the aprent type. This non-standard extension is - -- preserved temporarily for use by the modelling project under debug + -- inherited from the parent type. This nonstandard extension is + -- preserved temporarily for use by the modeling project under debug -- flag d.X. -- d.Z Normally we always enable expansion in configurable run-time mode @@ -761,6 +762,10 @@ package body Debug is -- d.3 Output debugging information from Exp_Unst, including the name of -- any unreachable subprograms that get deleted. + -- d.5 By default a subprogram imported generates a subprogram profile. + -- This debug flag disables this generation when generating C code, + -- assuming a proper #include will be used instead. + ------------------------------------------ -- Documentation for Binder Debug Flags -- ------------------------------------------ diff --git a/gcc/ada/doc/gnat_rm/about_this_guide.rst b/gcc/ada/doc/gnat_rm/about_this_guide.rst index 09eacebe0e4..11450c421b8 100644 --- a/gcc/ada/doc/gnat_rm/about_this_guide.rst +++ b/gcc/ada/doc/gnat_rm/about_this_guide.rst @@ -29,6 +29,7 @@ different compilers on different platforms. However, since Ada is designed to be used in a wide variety of applications, it also contains a number of system dependent features to be used in interfacing to the external world. + .. index:: Implementation-dependent features .. index:: Portability diff --git a/gcc/ada/doc/gnat_rm/implementation_advice.rst b/gcc/ada/doc/gnat_rm/implementation_advice.rst index 2ccb4e40172..c505e31b97c 100644 --- a/gcc/ada/doc/gnat_rm/implementation_advice.rst +++ b/gcc/ada/doc/gnat_rm/implementation_advice.rst @@ -294,8 +294,8 @@ RM 13.1 (21-24): Representation Clauses qualified as follows: An implementation need not support representation items containing - non-static expressions, except that an implementation should support a - representation item for a given entity if each non-static expression in + nonstatic expressions, except that an implementation should support a + representation item for a given entity if each nonstatic expression in the representation item is a name that statically denotes a constant declared before the entity." @@ -318,7 +318,7 @@ For example: constraints on the subtype and its composite subcomponents (if any) are all static constraints." -Followed. Size Clauses are not permitted on non-static components, as +Followed. Size Clauses are not permitted on nonstatic components, as described above. diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst index 5599a81413a..b0c5ef68b96 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst @@ -98,6 +98,12 @@ Aspect Async_Writers This boolean aspect is equivalent to pragma `Async_Writers`. +Aspect Constant_After_Elaboration +================================= +.. index:: Constant_After_Elaboration + +This aspect is equivalent to pragma `Constant_After_Elaboration`. + Aspect Contract_Cases ===================== .. index:: Contract_Cases @@ -112,6 +118,12 @@ Aspect Depends This aspect is equivalent to pragma `Depends`. +Aspect Default_Initial_Condition +================================ +.. index:: Default_Initial_Condition + +This aspect is equivalent to pragma `Default_Initial_Condition`. + Aspect Dimension ================ .. index:: Dimension @@ -223,12 +235,24 @@ Aspect Effective_Writes This aspect is equivalent to pragma `Effective_Writes`. +Aspect Extensions_Visible +========================= +.. index:: Extensions_Visible + +This aspect is equivalent to pragma `Extensions_Visible`. + Aspect Favor_Top_Level ====================== .. index:: Favor_Top_Level This boolean aspect is equivalent to pragma `Favor_Top_Level`. +Aspect Ghost +============= +.. index:: Ghost + +This aspect is equivalent to pragma `Ghost`. + Aspect Global ============= .. index:: Global @@ -527,6 +551,12 @@ Aspect Volatile_Full_Access This boolean aspect is equivalent to pragma `Volatile_Full_Access`. +Aspect Volatile_Function +=========================== +.. index:: Volatile_Function + +This boolean aspect is equivalent to pragma `Volatile_Function`. + Aspect Warnings =============== .. index:: Warnings diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index cb43587ecd9..601ca78e6ae 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -44,7 +44,7 @@ Attribute Address_Size prefix) is a static constant giving the number of bits in an `Address`. It is the same value as System.Address'Size, but has the advantage of being static, while a direct -reference to System.Address'Size is non-static because Address +reference to System.Address'Size is nonstatic because Address is a private type. Attribute Asm_Input @@ -233,7 +233,7 @@ Attribute Descriptor_Size .. index:: Descriptor_Size -Non-static attribute `Descriptor_Size` returns the size in bits of the +Nonstatic attribute `Descriptor_Size` returns the size in bits of the descriptor allocated for a type. The result is non-zero only for unconstrained array types and the returned value is of type universal integer. In GNAT, an array descriptor contains bounds information and is located immediately before @@ -760,7 +760,7 @@ Attribute Passed_By_Reference a value of type `Boolean` value that is `True` if the type is normally passed by reference and `False` if the type is normally passed by copy in calls. For scalar types, the result is always `False` -and is static. For non-scalar types, the result is non-static. +and is static. For non-scalar types, the result is nonstatic. Attribute Pool_Address ====================== @@ -1145,7 +1145,7 @@ a static expression, then the result of the attribute is a static expression. This means that such an expression can be used in contexts (e.g., preelaborable packages) which require a static expression and where the function call could not be used -(since the function call is always non-static, even if its +(since the function call is always nonstatic, even if its argument is static). The argument must be in the range -(2**(m-1) .. 2**m-1, where m is the memory size (typically 32 or 64). Negative values are intepreted in a @@ -1203,17 +1203,6 @@ Attribute TypeCode This internal attribute is used for the generation of remote subprogram stubs in the context of the Distributed Systems Annex. -Attribute UET_Address -===================== -.. index:: UET_Address - -The `UET_Address` attribute can only be used for a prefix which -denotes a library package. It yields the address of the unit exception -table when zero cost exception handling is used. This attribute is -intended only for use within the GNAT implementation. See the unit -`Ada.Exceptions` in files :file:`a-except.ads` and :file:`a-except.adb` -for details on how this attribute is used in the implementation. - Attribute Unconstrained_Array ============================= .. index:: Unconstrained_Array diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst index f26dd912998..68c5039b41c 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst @@ -22,48 +22,48 @@ and other operating systems is an important consideration. The numbers in each entry below correspond to the paragraph numbers in the Ada Reference Manual. -* +* "Whether or not each recommendation given in Implementation Advice is followed. See 1.1.2(37)." See :ref:`Implementation_Advice`. -* +* "Capacity limitations of the implementation. See 1.1.3(3)." The complexity of programs that can be processed is limited only by the total amount of available virtual memory, and disk space for the generated object files. -* +* "Variations from the standard that are impractical to avoid given the implementation's execution environment. See 1.1.3(6)." There are no variations from the standard. -* +* "Which code_statements cause external interactions. See 1.1.3(10)." Any `code_statement` can potentially cause external interactions. -* +* "The coded representation for the text of an Ada program. See 2.1(4)." See separate section on source representation. -* +* "The control functions allowed in comments. See 2.1(14)." See separate section on source representation. -* +* "The representation for an end of line. See 2.2(2)." See separate section on source representation. -* +* "Maximum supported line length and lexical element length. See 2.2(15)." @@ -74,19 +74,19 @@ sets the maximum to 79) or *-gnatyMnn* which allows the maximum line length to be specified to be any value up to 32767. The maximum length of a lexical element is the same as the maximum line length. -* +* "Implementation defined pragmas. See 2.8(14)." See :ref:`Implementation_Defined_Pragmas`. -* +* "Effect of pragma `Optimize`. See 2.8(27)." Pragma `Optimize`, if given with a `Time` or `Space` parameter, checks that the optimization flag is set, and aborts if it is not. -* +* "The sequence of characters of the value returned by ``S'Image`` when some of the graphic characters of ``S'Wide_Image`` are not defined in `Character`. See @@ -96,7 +96,7 @@ The sequence of characters is as defined by the wide character encoding method used for the source. See section on source representation for further details. -* +* "The predefined integer types declared in `Standard`. See 3.5.4(25)." @@ -106,31 +106,31 @@ Type Representation *Short_Short_Integer* 8 bit signed *Short_Integer* (Short) 16 bit signed *Integer* 32 bit signed -*Long_Integer* 64 bit signed (on most 64 bit targets, +*Long_Integer* 64 bit signed (on most 64 bit targets, depending on the C definition of long). 32 bit signed (all other targets) *Long_Long_Integer* 64 bit signed ====================== ======================================= -* +* "Any nonstandard integer types and the operators defined for them. See 3.5.4(26)." There are no nonstandard integer types. -* +* "Any nonstandard real types and the operators defined for them. See 3.5.6(8)." There are no nonstandard real types. -* +* "What combinations of requested decimal precision and range are supported for floating point types. See 3.5.7(7)." The precision and range is as defined by the IEEE standard. -* +* "The predefined floating point types declared in `Standard`. See 3.5.7(16)." @@ -143,12 +143,12 @@ Type Representation *Long_Long_Float* 64 bit IEEE long (80 bit IEEE long on x86 processors) ====================== ==================================================== -* +* "The small of an ordinary fixed point type. See 3.5.9(8)." `Fine_Delta` is 2**(-63) -* +* "What combinations of small, range, and digits are supported for fixed point types. See 3.5.9(10)." @@ -160,37 +160,37 @@ Text_IO is accurate to only 53 bits, rather than the full mantissa. This is because floating-point conversions are used to convert fixed point. -* +* "The result of `Tags.Expanded_Name` for types declared within an unnamed `block_statement`. See 3.9(10)." Block numbers of the form `B`nnn``, where `nnn` is a decimal integer are allocated. -* +* "Implementation-defined attributes. See 4.1.4(12)." See :ref:`Implementation_Defined_Attributes`. -* +* "Any implementation-defined time types. See 9.6(6)." There are no implementation-defined time types. -* +* "The time base associated with relative delays." See 9.6(20). The time base used is that provided by the C library function `gettimeofday`. -* +* "The time base of the type `Calendar.Time`. See 9.6(23)." The time base used is that provided by the C library function `gettimeofday`. -* +* "The time zone used for package `Calendar` operations. See 9.6(24)." @@ -198,13 +198,13 @@ The time zone used by package `Calendar` is the current system time zone setting for local time, as accessed by the C library function `localtime`. -* +* "Any limit on `delay_until_statements` of `select_statements`. See 9.6(29)." There are no such limits. -* +* "Whether or not two non-overlapping parts of a composite object are independently addressable, in the case where packing, record layout, or `Component_Size` is specified for the object. See @@ -213,13 +213,13 @@ There are no such limits. Separate components are independently addressable if they do not share overlapping storage units. -* +* "The representation for a compilation. See 10.1(2)." A compilation is represented by a sequence of files presented to the compiler in a single invocation of the *gcc* command. -* +* "Any restrictions on compilations that contain multiple compilation_units. See 10.1(4)." @@ -227,13 +227,13 @@ No single file can contain more than one compilation unit, but any sequence of files can be presented to the compiler as a single compilation. -* +* "The mechanisms for creating an environment and for adding and replacing compilation units. See 10.1.4(3)." See separate section on compilation model. -* +* "The manner of explicitly assigning library units to a partition. See 10.2(2)." @@ -256,7 +256,7 @@ be included automatically). For full details on the use of these options, refer to the `GNAT Make Program gnatmake` in the :title:`GNAT User's Guide`. -* +* "The implementation-defined means, if any, of specifying which compilation units are needed by a given compilation unit. See 10.2(2)." @@ -266,14 +266,14 @@ the Ada Reference Manual section 10.2(2-6). There are no implementation-defined pragmas or other implementation-defined means for specifying needed units. -* +* "The manner of designating the main subprogram of a partition. See 10.2(7)." The main program is designated by providing the name of the corresponding :file:`ALI` file as the input parameter to the binder. -* +* "The order of elaboration of `library_items`. See 10.2(18)." @@ -286,7 +286,7 @@ clauses of a unit to determine the probably best choice, and third by elaborating in alphabetical order of unit names where a choice still remains. -* +* "Parameter passing and function return for the main subprogram. See 10.2(21)." @@ -295,7 +295,7 @@ returning an integer type. In the latter case, the returned integer value is the return code of the program (overriding any value that may have been set by a call to `Ada.Command_Line.Set_Exit_Status`). -* +* "The mechanisms for building and running partitions. See 10.2(24)." @@ -305,13 +305,13 @@ of the PCS) provides a completely flexible method for building and running programs consisting of multiple partitions. See the separate GLADE manual for details. -* +* "The details of program execution, including program termination. See 10.2(25)." See separate section on compilation model. -* +* "The semantics of any non-active partitions supported by the implementation. See 10.2(28)." @@ -319,21 +319,21 @@ Passive partitions are supported on targets where shared memory is provided by the operating system. See the GLADE reference manual for further details. -* +* "The information returned by `Exception_Message`. See 11.4.1(10)." Exception message returns the null string unless a specific message has been passed by the program. -* +* "The result of `Exceptions.Exception_Name` for types declared within an unnamed `block_statement`. See 11.4.1(12)." Blocks have implementation defined names of the form `B`nnn`` where `nnn` is an integer. -* +* "The information returned by `Exception_Information`. See 11.4.1(13)." @@ -350,9 +350,9 @@ where * `nnnn` is the fully qualified name of the exception in all upper case letters. This line is always present. - + * `mmmm` is the message (this line present only if message is non-null) - + * `ppp` is the Process Id value as a decimal integer (this line is present only if the Process Id is nonzero). Currently we are not making use of this field. @@ -366,35 +366,28 @@ where The line terminator sequence at the end of each line, including the last line is a single `LF` character (`16#0A#`). -* +* "Implementation-defined check names. See 11.5(27)." -The implementation defined check name Alignment_Check controls checking of -address clause values for proper alignment (that is, the address supplied -must be consistent with the alignment of the type). - -The implementation defined check name Predicate_Check controls whether -predicate checks are generated. - -The implementation defined check name Validity_Check controls whether -validity checks are generated. - -In addition, a user program can add implementation-defined check names -by means of the pragma Check_Name. +The implementation defined check names include Alignment_Check, +Atomic_Synchronization, Duplicated_Tag_Check, Container_Checks, +Tampering_Check, Predicate_Check, and Validity_Check. In addition, a user +program can add implementation-defined check names by means of the pragma +Check_Name. See the description of pragma `Suppress` for full details. -* +* "The interpretation of each aspect of representation. See 13.1(20)." See separate section on data representations. -* +* "Any restrictions placed upon representation items. See 13.1(20)." See separate section on data representations. -* +* "The meaning of `Size` for indefinite subtypes. See 13.3(48)." @@ -402,27 +395,27 @@ Size for an indefinite subtype is the maximum possible size, except that for the case of a subprogram parameter, the size of the parameter object is the actual size. -* +* "The default external representation for a type tag. See 13.3(75)." The default external representation for a type tag is the fully expanded name of the type in upper case letters. -* +* "What determines whether a compilation unit is the same in two different partitions. See 13.3(76)." A compilation unit is the same in two different partitions if and only if it derives from the same source file. -* +* "Implementation-defined components. See 13.5.1(15)." The only implementation defined component is the tag for a tagged type, which contains a pointer to the dispatching table. -* +* "If `Word_Size` = `Storage_Unit`, the default bit ordering. See 13.5.3(5)." @@ -430,7 +423,7 @@ which contains a pointer to the dispatching table. implementation, so no non-default bit ordering is supported. The default bit ordering corresponds to the natural endianness of the target architecture. -* +* "The contents of the visible part of package `System` and its language-defined children. See 13.7(2)." @@ -443,14 +436,14 @@ System. Max_Priority : constant Positive := Priority'Last; Max_Interrupt_Priority : constant Positive := Interrupt_Priority'Last; -* +* "The contents of the visible part of package `System.Machine_Code`, and the meaning of `code_statements`. See 13.8(7)." See the definition and documentation in file :file:`s-maccod.ads`. -* +* "The effect of unchecked conversion. See 13.9(11)." Unchecked conversion between types of the same size @@ -467,7 +460,7 @@ unconstrained array are not permitted. If the target alignment is greater than the source alignment, then a copy of the result is made with appropriate alignment -* +* "The semantics of operations on invalid representations. See 13.9.2(10-11)." @@ -492,7 +485,7 @@ result in erroneous behavior. For example executing: As indicated, an exception is raised on the array assignment, but not on the simple assignment of the invalid negative value from Y to Z. -* +* "The manner of choosing a storage pool for an access type when `Storage_Pool` is not specified for the type. See 13.11(17)." @@ -505,7 +498,7 @@ library units `System.Pool_Global`, `System.Pool_Size` and :file:`s-pooglo.ads` and :file:`s-pooloc.ads` for full details on the default pools used. -* +* "Whether or not the implementation provides user-accessible names for the standard pool type(s). See 13.11(17)." @@ -513,14 +506,14 @@ See documentation in the sources of the run time mentioned in the previous paragraph. All these pools are accessible by means of `with`'ing these units. -* +* "The meaning of `Storage_Size`. See 13.11(18)." `Storage_Size` is measured in storage units, and refers to the total space available for an access type collection, or to the primary stack space for a task. -* +* "Implementation-defined aspects of storage pools. See 13.11(22)." @@ -528,13 +521,13 @@ See documentation in the sources of the run time mentioned in the paragraph about standard storage pools above for details on GNAT-defined aspects of storage pools. -* +* "The set of restrictions allowed in a pragma `Restrictions`. See 13.12(7)." See :ref:`Standard_and_Implementation_Defined_Restrictions`. -* +* "The consequences of violating limitations on `Restrictions` pragmas. See 13.12(9)." @@ -542,7 +535,7 @@ Restrictions that can be checked at compile time result in illegalities if violated. Currently there are no other consequences of violating restrictions. -* +* "The representation used by the `Read` and `Write` attributes of elementary types in terms of stream elements. See 13.13.2(9)." @@ -551,13 +544,13 @@ The representation is the in-memory representation of the base type of the type, using the number of bits corresponding to the ``type'Size`` value, and the natural ordering of the machine. -* +* "The names and characteristics of the numeric subtypes declared in the visible part of package `Standard`. See A.1(3)." See items describing the integer and floating-point types supported. -* +* "The string returned by `Character_Set_Version`. See A.3.5(3)." @@ -565,14 +558,14 @@ See items describing the integer and floating-point types supported. the string "Unicode 4.0", referring to version 4.0 of the Unicode specification. -* +* "The accuracy actually achieved by the elementary functions. See A.5.1(1)." The elementary functions correspond to the functions available in the C library. Only fast math mode is implemented. -* +* "The sign of a zero result from some of the operators or functions in `Numerics.Generic_Elementary_Functions`, when `Float_Type'Signed_Zeros` is `True`. See A.5.1(46)." @@ -580,19 +573,19 @@ library. Only fast math mode is implemented. The sign of zeroes follows the requirements of the IEEE 754 standard on floating-point. -* +* "The value of `Numerics.Float_Random.Max_Image_Width`. See A.5.2(27)." Maximum image width is 6864, see library file :file:`s-rannum.ads`. -* +* "The value of `Numerics.Discrete_Random.Max_Image_Width`. See A.5.2(27)." Maximum image width is 6864, see library file :file:`s-rannum.ads`. -* +* "The algorithms for random number generation. See A.5.2(32)." @@ -600,7 +593,7 @@ The algorithm is the Mersenne Twister, as documented in the source file :file:`s-rannum.adb`. This version of the algorithm has a period of 2**19937-1. -* +* "The string representation of a random number generator's state. See A.5.2(38)." @@ -608,7 +601,7 @@ The value returned by the Image function is the concatenation of the fixed-width decimal representations of the 624 32-bit integers of the state vector. -* +* "The minimum time interval between calls to the time-dependent Reset procedure that are guaranteed to initiate different random number sequences. See A.5.2(45)." @@ -616,7 +609,7 @@ of the state vector. The minimum period between reset calls to guarantee distinct series of random numbers is one microsecond. -* +* "The values of the `Model_Mantissa`, `Model_Emin`, `Model_Epsilon`, `Model`, `Safe_First`, and `Safe_Last` attributes, if the Numerics @@ -625,14 +618,14 @@ random numbers is one microsecond. Run the compiler with *-gnatS* to produce a listing of package `Standard`, has the values of all numeric attributes. -* +* "Any implementation-defined characteristics of the input-output packages. See A.7(14)." There are no special implementation defined characteristics for these packages. -* +* "The value of `Buffer_Size` in `Storage_IO`. See A.9(10)." @@ -640,14 +633,14 @@ All type representations are contiguous, and the `Buffer_Size` is the value of ``type'Size`` rounded up to the next storage unit boundary. -* +* "External files for standard input, standard output, and standard error See A.10(5)." These files are mapped onto the files provided by the C streams libraries. See source file :file:`i-cstrea.ads` for further details. -* +* "The accuracy of the value produced by `Put`. See A.10.9(36)." @@ -655,26 +648,26 @@ If more digits are requested in the output than are represented by the precision of the value, zeroes are output in the corresponding least significant digit positions. -* +* "The meaning of `Argument_Count`, `Argument`, and `Command_Name`. See A.15(1)." These are mapped onto the `argv` and `argc` parameters of the main program in the natural manner. -* +* "The interpretation of the `Form` parameter in procedure `Create_Directory`. See A.16(56)." The `Form` parameter is not used. -* +* "The interpretation of the `Form` parameter in procedure `Create_Path`. See A.16(60)." The `Form` parameter is not used. -* +* "The interpretation of the `Form` parameter in procedure `Copy_File`. See A.16(68)." @@ -693,7 +686,7 @@ The only possible values for preserve= are: ================== =================================================================== Value Meaning ================== =================================================================== -*no_attributes* Do not try to preserve any file attributes. This is the +*no_attributes* Do not try to preserve any file attributes. This is the default if no preserve= is found in Form. *all_attributes* Try to preserve all file attributes (timestamps, access rights). *timestamps* Preserve the timestamp of the copied file, but not the other @@ -705,11 +698,11 @@ The only possible values for mode= are: ============== =============================================================================== Value Meaning ============== =============================================================================== -*copy* Only do the copy if the destination file does not already exist. +*copy* Only do the copy if the destination file does not already exist. If it already exists, Copy_File fails. *overwrite* Copy the file in all cases. Overwrite an already existing destination file. -*append* Append the original file to the destination file. If the destination file - does not exist, the destination file is a copy of the source file. +*append* Append the original file to the destination file. If the destination file + does not exist, the destination file is a copy of the source file. When mode=append, the field preserve=, if it exists, is not taken into account. ============== =============================================================================== @@ -727,7 +720,7 @@ Examples of incorrect Forms:: Form => "preserve=junk" Form => "mode=internal, preserve=timestamps" -* +* "The interpretation of the `Pattern` parameter, when not the null string, in the `Start_Search` and `Search` procedures. See A.16(104) and A.16(112)." @@ -738,7 +731,7 @@ according to the syntax of regular expressions as defined in the See :ref:`GNAT.Regexp_(g-regexp.ads)`. -* +* "Implementation-defined convention names. See B.1(11)." The following convention names are supported @@ -784,12 +777,12 @@ Convention Name Interpretation implementations, these names are accepted silently. ======================= ============================================================================== -* +* "The meaning of link names. See B.1(36)." Link names are the actual names used by the linker. -* +* "The manner of choosing link names when neither the link name nor the address of an imported or exported entity is specified. See B.1(36)." @@ -798,7 +791,7 @@ The default linker name is that which would be assigned by the relevant external language, interpreting the Ada name as being in all lower case letters. -* +* "The effect of pragma `Linker_Options`. See B.1(37)." The string passed to `Linker_Options` is presented uninterpreted as @@ -815,20 +808,20 @@ list of options passed to the linker is in reverse order of the elaboration order. For example, linker options for a body always appear before the options from the corresponding package spec. -* +* "The contents of the visible part of package `Interfaces` and its language-defined descendants. See B.2(1)." See files with prefix :file:`i-` in the distributed library. -* +* "Implementation-defined children of package `Interfaces`. The contents of the visible part of package `Interfaces`. See B.2(11)." See files with prefix :file:`i-` in the distributed library. -* +* "The types `Floating`, `Long_Floating`, `Binary`, `Long_Binary`, `Decimal_ Element`, and `COBOL_Character`; and the initialization of the variables @@ -848,18 +841,18 @@ COBOL Ada For initialization, see the file :file:`i-cobol.ads` in the distributed library. -* +* "Support for access to machine instructions. See C.1(1)." See documentation in file :file:`s-maccod.ads` in the distributed library. -* +* "Implementation-defined aspects of access to machine operations. See C.1(9)." See documentation in file :file:`s-maccod.ads` in the distributed library. -* +* "Implementation-defined aspects of interrupts. See C.3(2)." Interrupts are mapped to signals or conditions as appropriate. See @@ -867,14 +860,14 @@ definition of unit `Ada.Interrupt_Names` in source file :file:`a-intnam.ads` for details on the interrupts supported on a particular target. -* +* "Implementation-defined aspects of pre-elaboration. See C.4(13)." GNAT does not permit a partition to be restarted without reloading, except under control of the debugger. -* +* "The semantics of pragma `Discard_Names`. See C.5(7)." Pragma `Discard_Names` causes names of enumeration literals to @@ -882,7 +875,7 @@ be suppressed. In the presence of this pragma, the Image attribute provides the image of the Pos of the literal, and Value accepts Pos values. -* +* "The result of the `Task_Identification.Image` attribute. See C.7.1(7)." @@ -910,14 +903,14 @@ No_Implicit_Heap_Allocation is in effect, the image reduces to the numeric suffix, that is to say the hexadecimal representation of the virtual address of the control block of the task. -* +* "The value of `Current_Task` when in a protected entry or interrupt handler. See C.7.1(17)." Protected entries or interrupt handlers can be executed by any convenient thread, so the value of `Current_Task` is undefined. -* +* "The effect of calling `Current_Task` from an entry body or interrupt handler. See C.7.1(19)." @@ -925,13 +918,13 @@ The effect of calling `Current_Task` from an entry body or interrupt handler is to return the identification of the task currently executing the code. -* +* "Implementation-defined aspects of `Task_Attributes`. See C.7.2(19)." There are no implementation-defined aspects of `Task_Attributes`. -* +* "Values of all `Metrics`. See D(2)." The metrics information for GNAT depends on the performance of the @@ -943,25 +936,25 @@ information on the performance of the underlying operating system, on the exact target in use, this information can be used to determine the required metrics. -* +* "The declarations of `Any_Priority` and `Priority`. See D.1(11)." See declarations in file :file:`system.ads`. -* +* "Implementation-defined execution resources. See D.1(15)." There are no implementation-defined execution resources. -* +* "Whether, on a multiprocessor, a task that is waiting for access to a protected object keeps its processor busy. See D.2.1(3)." On a multi-processor, a task that is waiting for access to a protected object does not keep its processor busy. -* +* "The affect of implementation defined execution resources on task dispatching. See D.2.1(9)." @@ -969,26 +962,26 @@ Tasks map to threads in the threads package used by GNAT. Where possible and appropriate, these threads correspond to native threads of the underlying operating system. -* +* "Implementation-defined `policy_identifiers` allowed in a pragma `Task_Dispatching_Policy`. See D.2.2(3)." There are no implementation-defined policy-identifiers allowed in this pragma. -* +* "Implementation-defined aspects of priority inversion. See D.2.2(16)." Execution of a task cannot be preempted by the implementation processing of delay expirations for lower priority tasks. -* +* "Implementation-defined task dispatching. See D.2.2(18)." The policy is the same as that of the underlying threads implementation. -* +* "Implementation-defined `policy_identifiers` allowed in a pragma `Locking_Policy`. See D.3(4)." @@ -1002,26 +995,26 @@ requesting the lock. On targets that support the read/write lock allowing multiple propected object functions to enter concurrently. -* +* "Default ceiling priorities. See D.3(10)." The ceiling priority of protected objects of the type `System.Interrupt_Priority'Last` as described in the Ada Reference Manual D.3(10), -* +* "The ceiling of any protected object used internally by the implementation. See D.3(16)." The ceiling priority of internal protected objects is `System.Priority'Last`. -* +* "Implementation-defined queuing policies. See D.4(1)." There are no implementation-defined queuing policies. -* +* "On a multiprocessor, any conditions that cause the completion of an aborted construct to be delayed later than what is specified for a single processor. See D.6(3)." @@ -1029,59 +1022,59 @@ There are no implementation-defined queuing policies. The semantics for abort on a multi-processor is the same as on a single processor, there are no further delays. -* +* "Any operations that implicitly require heap storage allocation. See D.7(8)." The only operation that implicitly requires heap storage allocation is task creation. -* +* "What happens when a task terminates in the presence of pragma `No_Task_Termination`. See D.7(15)." Execution is erroneous in that case. -* +* "Implementation-defined aspects of pragma `Restrictions`. See D.7(20)." There are no such implementation-defined aspects. -* +* "Implementation-defined aspects of package `Real_Time`. See D.8(17)." There are no implementation defined aspects of package `Real_Time`. -* +* "Implementation-defined aspects of `delay_statements`. See D.9(8)." Any difference greater than one microsecond will cause the task to be delayed (see D.9(7)). -* +* "The upper bound on the duration of interrupt blocking caused by the implementation. See D.12(5)." The upper bound is determined by the underlying operating system. In no cases is it more than 10 milliseconds. -* +* "The means for creating and executing distributed programs. See E(5)." The GLADE package provides a utility GNATDIST for creating and executing distributed programs. See the GLADE reference manual for further details. -* +* "Any events that can result in a partition becoming inaccessible. See E.1(7)." See the GLADE reference manual for full details on such events. -* +* "The scheduling policies, treatment of priorities, and management of shared resources between partitions in certain cases. See E.1(11)." @@ -1089,7 +1082,7 @@ See the GLADE reference manual for full details on such events. See the GLADE reference manual for full details on these aspects of multi-partition execution. -* +* "Events that cause the version of a compilation unit to change. See E.3(5)." @@ -1099,27 +1092,27 @@ to change. No other actions cause the version number to change. All changes are significant except those which affect only layout, capitalization or comments. -* +* "Whether the execution of the remote subprogram is immediately aborted as a result of cancellation. See E.4(13)." See the GLADE reference manual for details on the effect of abort in a distributed application. -* +* "Implementation-defined aspects of the PCS. See E.5(25)." See the GLADE reference manual for a full description of all implementation defined aspects of the PCS. -* +* "Implementation-defined interfaces in the PCS. See E.5(26)." See the GLADE reference manual for a full description of all implementation defined interfaces. -* +* "The values of named numbers in the package `Decimal`. See F.2(7)." @@ -1133,26 +1126,26 @@ Named Number Value *Max_Decimal_Digits* 18 ==================== ========== -* +* "The value of `Max_Picture_Length` in the package `Text_IO.Editing`. See F.3.3(16)." 64 -* +* "The value of `Max_Picture_Length` in the package `Wide_Text_IO.Editing`. See F.3.4(5)." 64 -* +* "The accuracy actually achieved by the complex elementary functions and by other complex arithmetic operations. See G.1(1)." Standard library functions are used for the complex arithmetic operations. Only fast math mode is currently supported. -* +* "The sign of a zero result (or a component thereof) from any operator or function in `Numerics.Generic_Complex_Types`, when `Real'Signed_Zeros` is True. See G.1.1(53)." @@ -1160,7 +1153,7 @@ operations. Only fast math mode is currently supported. The signs of zero values are as recommended by the relevant implementation advice. -* +* "The sign of a zero result (or a component thereof) from any operator or function in `Numerics.Generic_Complex_Elementary_Functions`, when @@ -1169,14 +1162,14 @@ implementation advice. The signs of zero values are as recommended by the relevant implementation advice. -* +* "Whether the strict mode or the relaxed mode is the default. See G.2(2)." The strict mode is the default. There is no separate relaxed mode. GNAT provides a highly efficient implementation of strict mode. -* +* "The result interval in certain cases of fixed-to-float conversion. See G.2.1(10)." @@ -1184,7 +1177,7 @@ For cases where the result interval is implementation dependent, the accuracy is that provided by performing all operations in 64-bit IEEE floating-point format. -* +* "The result of a floating point arithmetic operation in overflow situations, when the `Machine_Overflows` attribute of the result type is `False`. See G.2.1(13)." @@ -1197,14 +1190,14 @@ must be used for achieving IEEE conforming behavior (although at the cost of a significant performance penalty), so infinite and NaN values are properly generated. -* +* "The result interval for division (or exponentiation by a negative exponent), when the floating point hardware implements division as multiplication by a reciprocal. See G.2.1(16)." Not relevant, division is IEEE exact. -* +* "The definition of close result set, which determines the accuracy of certain fixed point multiplications and divisions. See G.2.3(5)." @@ -1214,7 +1207,7 @@ floating-point arithmetic. The input operands are converted to floating-point, the operation is done in floating-point, and the result is converted to the target type. -* +* "Conditions on a `universal_real` operand of a fixed point multiplication or division for which the result shall be in the perfect result set. See G.2.3(22)." @@ -1223,7 +1216,7 @@ The result is only defined to be in the perfect result set if the result can be computed by a single scaling operation involving a scale factor representable in 64-bits. -* +* "The result of a fixed point arithmetic operation in overflow situations, when the `Machine_Overflows` attribute of the result type is `False`. See G.2.3(27)." @@ -1231,14 +1224,14 @@ representable in 64-bits. Not relevant, `Machine_Overflows` is `True` for fixed-point types. -* +* "The result of an elementary function reference in overflow situations, when the `Machine_Overflows` attribute of the result type is `False`. See G.2.4(4)." IEEE infinite and Nan values are produced as appropriate. -* +* "The value of the angle threshold, within which certain elementary functions, complex arithmetic operations, and complex elementary functions yield results conforming to a maximum relative @@ -1246,13 +1239,13 @@ IEEE infinite and Nan values are produced as appropriate. Information on this subject is not yet available. -* +* "The accuracy of certain elementary functions for parameters beyond the angle threshold. See G.2.4(10)." Information on this subject is not yet available. -* +* "The result of a complex arithmetic operation or complex elementary function reference in overflow situations, when the `Machine_Overflows` attribute of the corresponding real type is @@ -1260,27 +1253,27 @@ Information on this subject is not yet available. IEEE infinite and Nan values are produced as appropriate. -* +* "The accuracy of certain complex arithmetic operations and certain complex elementary functions for parameters (or components thereof) beyond the angle threshold. See G.2.6(8)." Information on those subjects is not yet available. -* +* "Information regarding bounded errors and erroneous execution. See H.2(1)." Information on this subject is not yet available. -* +* "Implementation-defined aspects of pragma `Inspection_Point`. See H.3.2(8)." Pragma `Inspection_Point` ensures that the variable is live and can be examined by the debugger at the inspection point. -* +* "Implementation-defined aspects of pragma `Restrictions`. See H.4(25)." @@ -1288,7 +1281,7 @@ There are no implementation-defined aspects of pragma `Restrictions`. The use of pragma `Restrictions [No_Exceptions]` has no effect on the generated code. Checks must suppressed by use of pragma `Suppress`. -* +* "Any restrictions on pragma `Restrictions`. See H.4(27)." diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 058db243575..7bde3f38f29 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -803,24 +803,6 @@ compatibility with the standard `Assertion_Policy` pragma. The check policy setting `DISABLE` causes the second argument of a corresponding `Check` pragma to be completely ignored and not analyzed. -Pragma CIL_Constructor -====================== - -Syntax: - - -:: - - pragma CIL_Constructor ([Entity =>] function_LOCAL_NAME); - - -This pragma is used to assert that the specified Ada function should be -mapped to the .NET constructor for some Ada tagged record type. - -See section 4.1 of the -`GNAT User's Guide: Supplement for the .NET Platform.` -for related information. - Pragma Comment ============== @@ -1075,6 +1057,12 @@ If the alignment for a record or array type is not specified (using pragma `Pack`, pragma `Component_Alignment`, or a record rep clause), the GNAT uses the default alignment as described previously. +Pragma Constant_After_Elaboration +================================= + +For the description of this pragma, see SPARK 2014 Reference Manual, +section 3.3.1. + Pragma Contract_Cases ===================== .. index:: Contract cases @@ -1328,6 +1316,12 @@ This pragma is standard in Ada 2012, but is available in all earlier versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. +Pragma Default_Initial_Condition +================================ + +For the description of this pragma, see SPARK 2014 Reference Manual, +section 7.3.3. + Pragma Debug ============ @@ -1980,6 +1974,12 @@ of GNAT specific extensions are recognized as follows: is constrained. +Pragma Extensions_Visible +========================= + +For the description of this pragma, see SPARK 2014 Reference Manual, +section 6.1.7. + Pragma External =============== @@ -2176,6 +2176,12 @@ be `IEEE_Float` to specify the use of IEEE format, as follows: * No other value of digits is permitted. +Pragma Ghost +============ + +For the description of this pragma, see SPARK 2014 Reference Manual, +section 6.9. + Pragma Global ============= @@ -2864,42 +2870,6 @@ invariant pragma for the same entity. For further details on the use of this pragma, see the Ada 2012 documentation of the Type_Invariant aspect. -Pragma Java_Constructor -======================= - -Syntax: - - -:: - - pragma Java_Constructor ([Entity =>] function_LOCAL_NAME); - - -This pragma is used to assert that the specified Ada function should be -mapped to the Java constructor for some Ada tagged record type. - -See section 7.3.2 of the -`GNAT User's Guide: Supplement for the JVM Platform.` -for related information. - -Pragma Java_Interface -===================== - -Syntax: - - -:: - - pragma Java_Interface ([Entity =>] abstract_tagged_type_LOCAL_NAME); - - -This pragma is used to assert that the specified Ada abstract tagged type -is to be mapped to a Java interface name. - -See sections 7.1 and 7.2 of the -`GNAT User's Guide: Supplement for the JVM Platform.` -for related information. - Pragma Keep_Names ================= @@ -5430,7 +5400,7 @@ Pragma Source_File_Name_Project =============================== This pragma has the same syntax and semantics as pragma Source_File_Name. -It is only allowed as a stand alone configuration pragma. +It is only allowed as a stand-alone configuration pragma. It cannot appear after a :ref:`Pragma_Source_File_Name`, and most importantly, once pragma Source_File_Name_Project appears, no further Source_File_Name pragmas are allowed. @@ -5770,6 +5740,13 @@ names that are implementation defined (as permitted by the RM): for a duplicated tag value when a tagged type is declared. * + `Container_Checks` Can be used to suppress all checks within Ada.Containers + and instances of its children, including Tampering_Check. + +* + `Tampering_Check` Can be used to suppress tampering check in the containers. + +* `Predicate_Check` can be used to control whether predicate checks are active. It is applicable only to predicates for which the policy is `Check`. Unlike `Assertion_Policy`, which determines if a given @@ -6479,8 +6456,8 @@ configuration pragma will ensure this test is not suppressed: This pragma is standard in Ada 2005. It is available in all earlier versions of Ada as an implementation-defined pragma. -Note that in addition to the checks defined in the Ada RM, GNAT recogizes -a number of implementation-defined check names. See description of pragma +Note that in addition to the checks defined in the Ada RM, GNAT recogizes a +number of implementation-defined check names. See the description of pragma `Suppress` for full details. Pragma Use_VADS_Size @@ -6615,6 +6592,12 @@ the same object. It is not permissible to specify `Volatile_Full_Access` for a composite (record or array) type or object that has at least one `Aliased` component. +Pragma Volatile_Function +======================== + +For the description of this pragma, see SPARK 2014 Reference Manual, +section 7.1.2. + Pragma Warning_As_Error ======================= diff --git a/gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst b/gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst index d46c52c6d1c..303b425c459 100644 --- a/gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst +++ b/gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst @@ -422,7 +422,7 @@ Supported Aspect Source * *AI-0220 Needed components for aggregates (0000-00-00)* This AI addresses a wording problem in the RM that appears to permit some - complex cases of aggregates with non-static discriminants. GNAT has always + complex cases of aggregates with nonstatic discriminants. GNAT has always implemented the intended semantics. RM References: 4.03.01 (17) diff --git a/gcc/ada/doc/gnat_rm/implementation_of_specific_ada_features.rst b/gcc/ada/doc/gnat_rm/implementation_of_specific_ada_features.rst index 5788929bedc..4ba0926065b 100644 --- a/gcc/ada/doc/gnat_rm/implementation_of_specific_ada_features.rst +++ b/gcc/ada/doc/gnat_rm/implementation_of_specific_ada_features.rst @@ -17,17 +17,17 @@ Machine Code Insertions Package `Machine_Code` provides machine code support as described in the Ada Reference Manual in two separate forms: -* +* Machine code statements, consisting of qualified expressions that fit the requirements of RM section 13.8. -* +* An intrinsic callable procedure, providing an alternative mechanism of including machine instructions in a subprogram. The two features are similar, and both are closely related to the mechanism provided by the asm instruction in the GNU C compiler. Full understanding and use of the facilities in this package requires understanding the asm -instruction, see the section on Extended Asm in +instruction, see the section on Extended Asm in :title:`Using_the_GNU_Compiler_Collection_(GCC)`. Calls to the function `Asm` and the procedure `Asm` have identical @@ -40,7 +40,7 @@ Consider this C `asm` instruction: :: asm ("fsinx %1 %0" : "=f" (result) : "f" (angle)); - + The equivalent can be written for GNAT as: @@ -49,7 +49,7 @@ The equivalent can be written for GNAT as: Asm ("fsinx %1 %0", My_Float'Asm_Output ("=f", result), My_Float'Asm_Input ("f", angle)); - + The first argument to `Asm` is the assembler template, and is identical to what is used in GNU C. This string must be a static @@ -62,7 +62,7 @@ The `Asm_Output` attribute denotes a function that takes two parameters. The first is a string, the second is the name of a variable of the type designated by the attribute prefix. The first (string) argument is required to be a static expression and designates the -constraint (see the section on Constraints in +constraint (see the section on Constraints in :title:`Using_the_GNU_Compiler_Collection_(GCC)`) for the parameter; e.g., what kind of register is required. The second argument is the variable to be written or updated with the @@ -129,7 +129,7 @@ appear as aggregates of the form: Asm_Insn'(Asm (...)); Asm_Insn'(Asm_Volatile (...)); - + In accordance with RM rules, such code statements are allowed only within subprograms whose entire body consists of such statements. It is not permissible to intermix such statements with other Ada statements. @@ -165,7 +165,7 @@ normal rules for use of positional and named arguments: INPUT_OPERAND_ATTRIBUTE ::= SUBTYPE_MARK'Asm_Input (static_string_EXPRESSION, EXPRESSION) - + The identifiers `No_Input_Operands` and `No_Output_Operands` are declared in the package `Machine_Code` and must be referenced according to normal visibility rules. In particular if there is no @@ -215,27 +215,28 @@ kernel. For example, in the case of VxWorks, one Ada task = one VxWorks task. In addition Ada task priorities map onto the underlying thread priorities. Mapping Ada tasks onto the underlying kernel threads has several advantages: -* +* The underlying scheduler is used to schedule the Ada tasks. This makes Ada tasks as efficient as kernel threads from a scheduling standpoint. -* +* Interaction with code written in C containing threads is eased since at the lowest level Ada tasks and C threads map onto the same underlying kernel concept. -* +* When an Ada task is blocked during I/O the remaining Ada tasks are able to proceed. -* +* On multiprocessor systems Ada tasks can execute in parallel. Some threads libraries offer a mechanism to fork a new process, with the child process duplicating the threads from the parent. GNAT does not support this functionality when the parent contains more than one task. + .. index:: Forking a new process .. _Ensuring_Compliance_with_the_Real-Time_Annex: @@ -291,14 +292,14 @@ GNAT Implementation of Shared Passive Packages .. index:: Shared passive packages -GNAT fully implements the pragma `Shared_Passive` for -.. index:: pragma `Shared_Passive` - +GNAT fully implements the :index:`pragma <pragma Shared_Passive>` +`Shared_Passive` for the purpose of designating shared passive packages. This allows the use of passive partitions in the context described in the Ada Reference Manual; i.e., for communication between separate partitions of a distributed application using the features in Annex E. + .. index:: Annex E .. index:: Distribution Systems Annex @@ -348,7 +349,7 @@ will have the names: /stemp/x.y /stemp/x.z - + These files are created when a value is initially written to the object, and the files are retained until manually deleted. This provides the persistence @@ -411,7 +412,7 @@ For the declarations: type One_Dim is array (1..10) of integer; ar0 : constant One_Dim := (1, 2, 3, 4, 5, 6, 7, 8, 9, 0); - + GNAT generates no executable code: the constant ar0 is placed in static memory. The same is true for constant aggregates with named associations: @@ -421,7 +422,7 @@ The same is true for constant aggregates with named associations: Cr1 : constant One_Dim := (4 => 16, 2 => 4, 3 => 9, 1 => 1, 5 .. 10 => 0); Cr3 : constant One_Dim := (others => 7777); - + The same is true for multidimensional constant arrays such as: @@ -429,7 +430,7 @@ The same is true for multidimensional constant arrays such as: type two_dim is array (1..3, 1..3) of integer; Unit : constant two_dim := ( (1,0,0), (0,1,0), (0,0,1)); - + The same is true for arrays of one-dimensional arrays: the following are static: @@ -441,7 +442,7 @@ static: type ar_ar is array (1..3) of ar1b; None : constant ar1b := (others => false); -- fully static None2 : constant ar_ar := (1..3 => None); -- fully static - + However, for multidimensional aggregates with named associations, GNAT will generate assignments and loops, even if all associations are static. The @@ -453,7 +454,7 @@ individual component assignments for the second dimension: Zero1: constant two_dim := (1..3 => (1..3 => 0)); Zero2: constant two_dim := (others => (others => 0)); - + .. _Constant_aggregates_with_unconstrained_nominal_types: @@ -470,7 +471,7 @@ aggregate statically as well. No code is generated for the following: type One_Unc is array (natural range <>) of integer; Cr_Unc : constant One_Unc := (12,24,36); - + .. _Aggregates_with_static_bounds: @@ -487,7 +488,7 @@ object. The declarations Cr_Var1 : One_Dim := (2, 5, 7, 11, 0, 0, 0, 0, 0, 0); Cr_Var2 : One_Dim := (others > -1); - + generate the equivalent of @@ -502,11 +503,11 @@ generate the equivalent of for I in Cr_Var2'range loop Cr_Var2 (I) := -1; end loop; - -.. _Aggregates_with_non-static_bounds: -Aggregates with non-static bounds +.. _Aggregates_with_nonstatic_bounds: + +Aggregates with nonstatic bounds --------------------------------- If the bounds of the aggregate are not statically compatible with the bounds @@ -529,7 +530,7 @@ component assignments. For example, consider the simple case: .. code-block:: ada A := (A(2), A(1)); - + This cannot be converted into: @@ -538,16 +539,16 @@ This cannot be converted into: A(1) := A(2); A(2) := A(1); - + So the aggregate has to be built first in a separate location, and then copied into the target. GNAT recognizes simple cases where this intermediate step is not required, and the assignments can be performed in place, directly into the target. The following sufficient criteria are applied: -* +* The bounds of the aggregate are static, and the associations are static. -* +* The components of the aggregate are static constants, names of simple variables that are not renamings, or expressions not involving indexed components whose operands obey these rules. @@ -575,7 +576,7 @@ constraint: end T; Word : Rec; - + Such an object is said to be *unconstrained*. The discriminant of the object @@ -648,17 +649,15 @@ Strict Conformance to the Ada Reference Manual The dynamic semantics defined by the Ada Reference Manual impose a set of run-time checks to be generated. By default, the GNAT compiler will insert many run-time checks into the compiled code, including most of those required by the -Ada Reference Manual. However, there are three checks that are not enabled -in the default mode for efficiency reasons: arithmetic overflow checking for -integer operations (including division by zero), checks for access before -elaboration on subprogram calls, and stack overflow checking (most operating -systems do not perform this check by default). - -Strict conformance to the Ada Reference Manual can be achieved by adding -three compiler options for overflow checking for integer operations -(*-gnato*), dynamic checks for access-before-elaboration on subprogram -calls and generic instantiations (*-gnatE*), and stack overflow -checking (*-fstack-check*). +Ada Reference Manual. However, there are two checks that are not enabled in +the default mode for efficiency reasons: checks for access before elaboration +on subprogram calls, and stack overflow checking (most operating systems do not +perform this check by default). + +Strict conformance to the Ada Reference Manual can be achieved by adding two +compiler options for dynamic checks for access-before-elaboration on subprogram +calls and generic instantiations (*-gnatE*), and stack overflow checking +(*-fstack-check*). Note that the result of a floating point arithmetic operation in overflow and invalid situations, when the `Machine_Overflows` attribute of the result @@ -668,4 +667,3 @@ machines that are not fully compliant with this standard, such as Alpha, the *-mieee* compiler flag must be used for achieving IEEE confirming behavior (although at the cost of a significant performance penalty), so infinite and NaN values are properly generated. - diff --git a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst index 8d28d24fe60..ca2744327cf 100644 --- a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst @@ -1477,7 +1477,7 @@ as found in RM 13.1(22): a constant declared before the entity." In practice this is applicable only to address clauses, since this is the -only case in which a non-static expression is permitted by the syntax. As +only case in which a nonstatic expression is permitted by the syntax. As the AARM notes in sections 13.1 (22.a-22.h): 22.a Reason: This is to avoid the following sort of thing: @@ -1509,7 +1509,7 @@ the AARM notes in sections 13.1 (22.a-22.h): might be known at compile time anyway in many cases. -GNAT does indeed permit many additional cases of non-static expressions. In +GNAT does indeed permit many additional cases of nonstatic expressions. In particular, if the type involved is elementary there are no restrictions (since in this case, holding a temporary copy of the initialization value, if one is present, is inexpensive). In addition, if there is no implicit or @@ -1524,7 +1524,7 @@ only the case where all three of these conditions hold: Note that access values are always implicitly initialized. * - The address value is non-static. Here GNAT is more permissive than the + The address value is nonstatic. Here GNAT is more permissive than the RM, and allows the address value to be the address of a previously declared stand-alone variable, as long as it does not itself have an address clause. @@ -1537,9 +1537,9 @@ only the case where all three of these conditions hold: However, the prefix of the address clause cannot be an array component, or a component of a discriminated record. -As noted above in section 22.h, address values are typically non-static. In +As noted above in section 22.h, address values are typically nonstatic. In particular the To_Address function, even if applied to a literal value, is -a non-static function call. To avoid this minor annoyance, GNAT provides +a nonstatic function call. To avoid this minor annoyance, GNAT provides the implementation defined attribute 'To_Address. The following two expressions have identical values: diff --git a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst index c5cabb98af4..c820cb7877d 100644 --- a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst +++ b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst @@ -137,12 +137,19 @@ No_Anonymous_Allocators [RM H.4] This restriction ensures at compile time that there are no occurrences of an allocator of anonymous access type. +No_Asynchronous_Control +----------------------- +.. index:: No_Asynchronous_Control + +[RM J.13] This restriction ensures at compile time that there are no semantic +dependences on the predefined package Asynchronous_Task_Control. + No_Calendar ----------- .. index:: No_Calendar -[GNAT] This restriction ensures at compile time that there is no implicit or -explicit dependence on the package `Ada.Calendar`. +[GNAT] This restriction ensures at compile time that there are no semantic +dependences on package Calendar. No_Coextensions --------------- @@ -170,14 +177,14 @@ No_Delay .. index:: No_Delay [RM H.4] This restriction ensures at compile time that there are no -delay statements and no dependences on package Calendar. +delay statements and no semantic dependences on package Calendar. No_Dependence ------------- .. index:: No_Dependence -[RM 13.12.1] This restriction checks at compile time that there are no -dependence on a library unit. +[RM 13.12.1] This restriction ensures at compile time that there are no +dependences on a library unit. No_Direct_Boolean_Operators --------------------------- @@ -452,6 +459,19 @@ intermediate temporary, and without generating a loop to initialize individual components. Otherwise, a loop is created for arrays larger than about 5000 scalar components. +No_Implicit_Protected_Object_Allocations +---------------------------------------- +.. index: No_Implicit_Protected_Object_Allocations + +[GNAT] No constructs are allowed to cause implicit heap allocation of a +protected object. + +No_Implicit_Task_Allocations +---------------------------- +.. index: No_Implicit_Task_Allocations + +[GNAT] No constructs are allowed to cause implicit heap allocation of a task. + No_Initialize_Scalars --------------------- .. index:: No_Initialize_Scalars @@ -659,6 +679,15 @@ No_Task_Allocators [RM D.7] There are no allocators for task types or types containing task subcomponents. +No_Task_At_Interrupt_Priority +----------------------------- +.. index:: No_Task_At_Interrupt_Priority + +[GNAT] This restriction ensures at compile time that there is no +Interrupt_Priority aspect or pragma for a task or a task type. As +a consequence, the tasks are always created with a priority below +that an interrupt priority. + No_Task_Attributes_Package -------------------------- .. index:: No_Task_Attributes_Package @@ -709,6 +738,20 @@ No_Unchecked_Access [RM H.4] This restriction ensures at compile time that there are no occurrences of the Unchecked_Access attribute. +No_Unchecked_Conversion +----------------------- +.. index:: No_Unchecked_Conversion + +[RM J.13] This restriction ensures at compile time that there are no semantic +dependences on the predefined generic function Unchecked_Conversion. + +No_Unchecked_Deallocation +------------------------- +.. index:: No_Unchecked_Deallocation + +[RM J.13] This restriction ensures at compile time that there are no semantic +dependences on the predefined generic procedure Unchecked_Deallocation. + No_Use_Of_Entity ---------------- .. index:: No_Use_Of_Entity @@ -982,7 +1025,7 @@ restriction is in force: * No object renaming * No use clause * Aggregates must be qualified -* Non-static choice in array aggregates not allowed +* Nonstatic choice in array aggregates not allowed * The only view conversions which are allowed as in-out parameters are conversions of a tagged type to an ancestor type * No mixing of positional and named association in aggregate, no multi choice * AND, OR and XOR for arrays only allowed when operands have same static bounds @@ -1003,7 +1046,7 @@ restriction is in force: * Untagged record cannot be null * No class-wide operations * Initialization expressions must respect SPARK restrictions -* Non-static ranges not allowed except in iteration schemes +* Nonstatic ranges not allowed except in iteration schemes * String subtypes must have lower bound of 1 * Subtype of Boolean cannot have constraint * At most one tagged type or extension per package diff --git a/gcc/ada/doc/gnat_rm/the_gnat_library.rst b/gcc/ada/doc/gnat_rm/the_gnat_library.rst index a5f0aa210e6..6220bc28003 100644 --- a/gcc/ada/doc/gnat_rm/the_gnat_library.rst +++ b/gcc/ada/doc/gnat_rm/the_gnat_library.rst @@ -641,6 +641,19 @@ Provides AWK-like parsing functions, with an easy interface for parsing one or more files containing formatted data. The file is viewed as a database where each record is a line and a field is a data element in this line. +.. _`GNAT.Bind_Environment_(g-binenv.ads)`: + +`GNAT.Bind_Environment` (:file:`g-binenv.ads`) +============================================== + +.. index:: GNAT.Bind_Environment (g-binenv.ads) + +.. index:: Bind environment + +Provides access to key=value associations captured at bind time. +These associations can be specified using the `-V` binder command +line switch. + .. _`GNAT.Bounded_Buffers_(g-boubuf.ads)`: `GNAT.Bounded_Buffers` (:file:`g-boubuf.ads`) 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 4c6e137ddcd..9351465c538 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 @@ -2953,7 +2953,7 @@ of the pragma in the :title:`GNAT_Reference_manual`). .. index:: -gnatw.e (gcc) :samp:`-gnatw.e` - *Activate every optional warning* + *Activate every optional warning.* .. index:: Warnings, activate every optional warning @@ -3016,7 +3016,7 @@ of the pragma in the :title:`GNAT_Reference_manual`). .. index:: -gnatw.g (gcc) :samp:`-gnatw.g` - *Warnings used for GNAT sources* + *Warnings used for GNAT sources.* This switch sets the warning categories that are used by the standard GNAT style. Currently this is equivalent to @@ -3143,16 +3143,18 @@ of the pragma in the :title:`GNAT_Reference_manual`). Second, the restriction does flag uses of package `ASCII`. +.. index:: -gnatwJ (gcc) + :samp:`-gnatwJ` *Suppress warnings on obsolescent features (Annex J).* - .. index:: -gnatwJ (gcc) This switch disables warnings on use of obsolescent features. +.. index:: -gnatwk (gcc) + :samp:`-gnatwk` *Activate warnings on variables that could be constants.* - .. index:: -gnatwk (gcc) This switch activates warnings for variables that are initialized but never modified, and then could be declared constants. The default is that @@ -3724,7 +3726,7 @@ of the pragma in the :title:`GNAT_Reference_manual`). .. index:: Warnings Off control :samp:`-gnatw.w` - *Activate warnings on Warnings Off pragmas* + *Activate warnings on Warnings Off pragmas.* This switch activates warnings for use of `pragma Warnings (Off, entity)` where either the pragma is entirely useless (because it suppresses no @@ -3739,7 +3741,7 @@ of the pragma in the :title:`GNAT_Reference_manual`). .. index:: -gnatw.W (gcc) :samp:`-gnatw.W` - *Suppress warnings on unnecessary Warnings Off pragmas* + *Suppress warnings on unnecessary Warnings Off pragmas.* This switch suppresses warnings for use of `pragma Warnings (Off, ...)`. @@ -3820,7 +3822,7 @@ of the pragma in the :title:`GNAT_Reference_manual`). .. index:: Package spec needing body :samp:`-gnatw.y` - *Activate information messages for why package spec needs body* + *Activate information messages for why package spec needs body.* There are a number of cases in which a package spec needs a body. For example, the use of pragma Elaborate_Body, or the declaration @@ -3835,7 +3837,7 @@ of the pragma in the :title:`GNAT_Reference_manual`). .. index:: No information messages for why package spec needs body :samp:`-gnatw.Y` - *Disable information messages for why package spec needs body* + *Disable information messages for why package spec needs body.* This switch suppresses the output of information messages showing why a package specification needs a body. @@ -4188,7 +4190,7 @@ to the default checks required by Ada as described above. .. index:: -gnatVi (gcc) :samp:`-gnatVi` - *Validity checks for `in* mode parameters` + *Validity checks for `in` mode parameters.* Arguments for parameters of mode `in` are validity checked in function and procedure calls at the point of call. @@ -4197,7 +4199,7 @@ to the default checks required by Ada as described above. .. index:: -gnatVm (gcc) :samp:`-gnatVm` - *Validity checks for `in out* mode parameters.` + *Validity checks for `in out` mode parameters.* Arguments for parameters of mode `in out` are validity checked in procedure calls at the point of call. The `'m'` here stands for @@ -4220,9 +4222,10 @@ to the default checks required by Ada as described above. is used, it cancels any other *-gnatV* previously issued. +.. index:: -gnatVo (gcc) + :samp:`-gnatVo` *Validity checks for operator and attribute operands.* - .. index:: -gnatVo (gcc) Arguments for predefined operators and attributes are validity checked. This includes all operators in package `Standard`, @@ -4796,7 +4799,7 @@ checks to be performed. The following checks are defined: .. index:: -gnatyy (gcc) :samp:`-gnatyy` - *Set all standard style check options* + *Set all standard style check options.* This is equivalent to `gnaty3aAbcefhiklmnprst`, that is all checking options enabled with the exception of *-gnatyB*, *-gnatyd*, @@ -4807,7 +4810,7 @@ checks to be performed. The following checks are defined: .. index:: -gnaty- (gcc) :samp:`-gnaty-` - *Remove style check options* + *Remove style check options.* This causes any subsequent options in the string to act as canceling the corresponding style check option. To cancel maximum nesting level control, @@ -4821,7 +4824,7 @@ checks to be performed. The following checks are defined: .. index:: -gnaty+ (gcc) :samp:`-gnaty+` - *Enable style check options* + *Enable style check options.* This causes any subsequent options in the string to enable the corresponding style check option. That is, it cancels the effect of a previous -, @@ -4911,13 +4914,12 @@ following *gcc* switches refine this default behavior. the condition being checked is true, which can result in erroneous execution if that assumption is wrong. - The checks subject to suppression include all the checks defined by - the Ada standard, the additional implementation defined checks - `Alignment_Check`, - `Duplicated_Tag_Check`, `Predicate_Check`, and - `Validity_Check`, as well as any checks introduced using - `pragma Check_Name`. Note that `Atomic_Synchronization` - is not automatically suppressed by use of this option. + The checks subject to suppression include all the checks defined by the Ada + standard, the additional implementation defined checks `Alignment_Check`, + `Duplicated_Tag_Check`, `Predicate_Check`, Container_Checks, Tampering_Check, + and `Validity_Check`, as well as any checks introduced using `pragma + Check_Name`. Note that `Atomic_Synchronization` is not automatically + suppressed by use of this option. If the code depends on certain checks being active, you can use pragma `Unsuppress` either as a configuration pragma or as @@ -5146,7 +5148,7 @@ indicate Ada 83 compatibility mode. .. index:: ACVC, Ada 83 tests .. index:: Ada 83 mode -:samp:`-gnat83 (Ada 83 Compatibility Mode)` +:samp:`-gnat83` (Ada 83 Compatibility Mode) Although GNAT is primarily an Ada 95 / Ada 2005 compiler, this switch specifies that the program is to be compiled in Ada 83 mode. With *-gnat83*, GNAT rejects most post-Ada 83 extensions and applies Ada 83 @@ -5160,9 +5162,8 @@ indicate Ada 83 compatibility mode. using only Ada 83 features. With few exceptions (most notably the need to use `<>` on - .. index:: Generic formal parameters - - unconstrained generic formal parameters, the use of the new Ada 95 / Ada 2005 + unconstrained :index:`generic formal parameters <Generic formal parameters>`, + the use of the new Ada 95 / Ada 2005 reserved words, and the use of packages with optional bodies), it is not necessary to specify the *-gnat83* switch when compiling Ada 83 programs, because, with rare @@ -6059,10 +6060,12 @@ be presented in subsequent sections. Output complete list of elaboration-order dependencies. -.. index:: -E (gnatbind) +.. index:: -Ea (gnatbind) -:samp:`-E` +:samp:`-Ea` Store tracebacks in exception occurrences when the target supports it. + The "a" is for "address"; tracebacks will contain hexadecimal addresses, + unless symbolic tracebacks are enabled. See also the packages `GNAT.Traceback` and `GNAT.Traceback.Symbolic` for more information. @@ -6070,6 +6073,19 @@ be presented in subsequent sections. *gcc* option. +.. index:: -Es (gnatbind) + +:samp:`-Es` + Store tracebacks in exception occurrences when the target supports it. + The "s" is for "symbolic"; symbolic tracebacks are enabled. + + +.. index:: -E (gnatbind) + +:samp:`-E` + Currently the same as `-Ea`. + + .. index:: -F (gnatbind) :samp:`-F` @@ -6085,7 +6101,7 @@ be presented in subsequent sections. .. index:: -h (gnatbind) :samp:`-h` - Output usage (help) information + Output usage (help) information. .. index:: -H32 (gnatbind) @@ -6195,7 +6211,7 @@ be presented in subsequent sections. .. index:: -p (gnatbind) :samp:`-p` - Pessimistic (worst-case) elaboration order + Pessimistic (worst-case) elaboration order. .. index:: -P (gnatbind) @@ -6230,7 +6246,7 @@ be presented in subsequent sections. objects with pragma Initialize_Scalars. The `xxx` string specified with the switch is one of: - * ``in`` for an invalid value*. + * ``in`` for an invalid value. If zero is invalid for the discrete type in question, then the scalar value is set to all zero bits. @@ -6290,7 +6306,7 @@ be presented in subsequent sections. .. index:: -t (gnatbind) :samp:`-t` - Tolerate time stamp and other consistency errors + Tolerate time stamp and other consistency errors. .. index:: -T (gnatbind) @@ -6326,10 +6342,18 @@ be presented in subsequent sections. :file:`stdout`. + .. index:: -V (gnatbind) + +:samp:`-V{key}={value}` + Store the given association of `key` to `value` in the bind environment. + Values stored this way can be retrieved at run time using + `GNAT.Bind_Environment`. + + .. index:: -w (gnatbind) :samp:`-w{x}` - Warning mode; `x` = s/e for suppress/treat as error + Warning mode; `x` = s/e for suppress/treat as error. .. index:: -Wx (gnatbind) diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index 9e332d9d076..6f33d0b4ce3 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -1101,6 +1101,15 @@ information. Here is an example: end STB; +.. rubric:: Automatic Symbolic Tracebacks + +Symbolic tracebacks may also be enabled by using the -Es switch to gnatbind (as +in `gprbuild -g ... -bargs -Es`). +This will cause the Exception_Information to contain a symbolic traceback, +which will also be printed if an unhandled exception terminates the +program. + + .. index:: Code Coverage .. index:: Profiling @@ -3211,8 +3220,11 @@ This retains compatibility with previous versions of GNAT which suppressed overflow checks by default and always used the base type for computation of intermediate results. -The switch *-gnato* (with no digits following) is equivalent to -.. index:: -gnato (gcc) +.. Sphinx allows no emphasis within :index: role. As a workaround we + point the index to "switch" and use emphasis for "-gnato". + +The :index:`switch <-gnato (gcc)>` *-gnato* (with no digits following) +is equivalent to :: @@ -4184,7 +4196,3 @@ execution of this erroneous program: The allocation root #1 of the first example has been split in 2 roots #1 and #3, thanks to the more precise associated backtrace. - - - - diff --git a/gcc/ada/doc/gnat_ugn/gnat_project_manager.rst b/gcc/ada/doc/gnat_ugn/gnat_project_manager.rst index 79569b0ff12..1fdb1f54060 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_project_manager.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_project_manager.rst @@ -175,7 +175,7 @@ the directory :file:`obj/`. proc.adb common/obj/ proc.ali, proc.o pack.ali, pack.o - + Our project is to be called *Build*. The name of the file is the name of the project (case-insensitive) with the @@ -187,10 +187,10 @@ file is enough for it. We will thus create a new file, that for now should contain the following code: .. code-block:: gpr - + project Build is end Build; - + .. _Source_Files_and_Directories: @@ -263,7 +263,7 @@ There are several ways of defining source directories: for Source_Dirs use ("./**"); for Ignore_Source_Sub_Dirs use (".svn"); - + When applied to the simple example, and because we generally prefer to have the project file at the toplevel directory rather than mixed with the sources, @@ -276,7 +276,7 @@ we will create the following file project Build is for Source_Dirs use ("common"); -- <<<< end Build; - + Once source directories have been specified, one may need to indicate source files of interest. By default, all source files present in the source @@ -426,7 +426,7 @@ For our example, we can specify the object dir in this way: for Source_Dirs use ("common"); for Object_Dir use "obj"; -- <<<< end Build; - + As mentioned earlier, there is a single object directory per project. As a result, if you have an existing system where the object files are spread across several directories, you can either move all of them into the same directory if @@ -459,7 +459,7 @@ the project file is now for Object_Dir use "obj"; for Exec_Dir use "."; -- <<<< end Build; - + .. _Main_Subprograms: @@ -497,7 +497,7 @@ corresponding executables. for Exec_Dir use "."; for Main use ("proc.adb"); -- <<<< end Build; - + If this attribute is defined in the project, then spawning the builder with a command such as @@ -505,7 +505,7 @@ with a command such as .. code-block:: sh gprbuild -Pbuild - + automatically builds all the executables corresponding to the files listed in the *Main* attribute. It is possible to specify one @@ -564,7 +564,7 @@ packages would be involved in the build process. for Object_Dir use "obj"; for Exec_Dir use "."; for Main use ("proc.adb"); - + package Builder is --<<< for gprbuild end Builder; @@ -630,7 +630,7 @@ Several attributes can be used to specify the switches: for Switches ("proc.adb") use ("-O0"); end Compiler; - + `Switches` may take a pattern as an index, such as in: @@ -642,7 +642,7 @@ Several attributes can be used to specify the switches: for Switches ("pkg*") use ("-O0"); end Compiler; - + Sources :file:`pkg.adb` and :file:`pkg-child.adb` would be compiled with -O0, not -O2. @@ -679,7 +679,7 @@ Here is the command we would use from the command line: .. code-block:: sh gprbuild -Pbuild - + This will automatically build the executables specified through the *Main* attribute: for each, it will compile or recompile the sources for which the object file does not exist or is not up-to-date; it @@ -693,7 +693,7 @@ set the attribute *Languages* to `"(Ada, C)"`, and re-run .. code-block:: sh gprbuild -Pbuild - + Gprbuild knows how to recompile the C files and will recompile them only if one of their dependencies has changed. No direct indication on how to build the various elements is given in the @@ -752,7 +752,7 @@ on Windows), we could configure our project file to build "proc1" for Executable ("proc.adb") use "proc1"; end Builder end Build; - + .. index:: Executable_Suffix (GNAT Project Manager) Attribute **Executable_Suffix**, when specified, may change the suffix @@ -790,7 +790,7 @@ project using similar sources and a main program in C: for Switches ("main.c") use C_Switches & ("-g"); end Compiler; end C_Main; - + This project has many similarities with the previous one. As expected, its `Main` attribute now refers to a C source. The attribute *Exec_Dir* is now omitted, thus the resulting @@ -810,7 +810,7 @@ replaced by a reference to the `Default_Switches` attribute: .. code-block:: gpr for Switches ("c_main.c") use Compiler'Default_Switches ("C") & ("-g"); - + Note the tick (*'*) used to refer to attributes defined in a package. Here is the output of the GPRbuild command using this project: @@ -825,7 +825,7 @@ Here is the output of the GPRbuild command using this project: gprbind main.bexch ... gcc main.o -o main - + The default switches for Ada sources, the default switches for C sources (in the compilation of :file:`lib.c`), and the specific switches for :file:`main.c` have all been taken into @@ -986,7 +986,7 @@ The following attributes can be defined in package `Naming`: for Spec ("MyPack.MyChild") use "mypack.mychild.spec"; for Spec ("top") use "foo.a" at 1; for Spec ("foo") use "foo.a" at 2; - + .. index:: Body (GNAT Project Manager) @@ -1018,7 +1018,7 @@ For example, the following package models the Apex file naming rules: for Spec_Suffix ("Ada") use ".1.ada"; for Body_Suffix ("Ada") use ".2.ada"; end Naming; - + .. _Installation: @@ -1048,7 +1048,9 @@ The following attributes can be defined in package `Install`: An array attribute to declare a set of files not part of the sources to be installed. The array discriminant is the directory where the file is to be installed. If a relative directory then Prefix (see - below) is prepended. + below) is prepended. Note also that if the same file name occurs + multiple time in the attribute list, the last one will be the one + installed. .. index:: Prefix (GNAT Project Manager) @@ -1155,7 +1157,7 @@ project: project Build is ... -- as before end Build; - + .. index:: Externally_Built (GNAT Project Manager) @@ -1296,7 +1298,7 @@ its variables cannot be referred to. project D is for Exec_Dir use A'Exec_Dir; -- not ok end D; - + .. _Sharing_Between_Projects: @@ -1341,7 +1343,7 @@ There are two main approaches to avoiding this duplication: for Switches ("Ada") use Logging.Binder'Switches ("Ada"); end Binder; end Build; - + The solution used for `Compiler` gets the same value for all attributes of the package, but you cannot modify anything from the package (adding extra switches or some exceptions). The second @@ -1383,7 +1385,7 @@ There are two main approaches to avoiding this duplication: project Build is package Compiler renames Shared.Compiler; end Build; - + As for the first example, we could have chosen to set the attributes one by one rather than to rename a package. The reason we explicitly indicate that `Shared` has no sources is so that it can be created @@ -1482,7 +1484,7 @@ order of priority): .. code-block:: sh gprbuild -Pbuild.gpr -Xmode=release - + **Environment variables**: When the external value does not come from the command line, it can come from @@ -1507,7 +1509,7 @@ either :file:`obj/debug` or :file:`obj/release` by changing our project to for Object_Dir use "obj/" & external ("mode", "debug"); ... -- as before end Build; - + The second parameter to `external` is optional, and is the default value to use if "mode" is not set from the command line or the environment. @@ -1539,7 +1541,7 @@ sections in the project. The following example shows how this can be done: end case; end Compiler; end Build; - + The project has suddenly grown in size, but has become much more flexible. `Mode_Type` defines the only valid values for the `mode` variable. If any other value is read from the environment, an error is reported and the @@ -1636,7 +1638,7 @@ Here is the new version of :file:`logging.gpr` that makes it a library: for Object_Dir use "obj"; for Library_Dir use "lib"; -- different from object_dir end Logging; - + Once the above two attributes are defined, the library project is valid and is enough for building a library with default characteristics. Other library-related attributes can be used to change the defaults: @@ -1696,7 +1698,7 @@ Other library-related attributes can be used to change the defaults: for Library_Kind use "dynamic"; for Library_Version use "liblogging.so." & Version; end Logging; - + After the compilation, the directory :file:`lib` will contain both a :file:`libdummy.so.1` library and a symbolic link to it called @@ -1781,7 +1783,7 @@ the following two commands need to be used: gprbuild -Plogging.gpr gprbuild -Pbuild.gpr - + All :file:`ALI` files will also be copied from the object directory to the library directory. To build executables, *gprbuild* will use the library rather than the individual object files. @@ -1801,7 +1803,7 @@ of the library sources are not available. Such library projects need to use the for Library_Name use "l2"; for Externally_Built use "true"; -- <<<< end Extern_Lib; - + In the case of externally built libraries, the `Object_Dir` attribute does not need to be specified because it will never be used. @@ -2089,7 +2091,7 @@ the project `Build` from previous examples: project Work extends "../bld/build.gpr" is end Work; - + The project after **extends** is the one being extended. As usual, it can be specified using an absolute path, or a path relative to any of the directories in the project path (see :ref:`Project_Dependencies`). This project does not @@ -2100,7 +2102,7 @@ attributes will be used that is to say the current directory (where project .. code-block:: sh gprbuild -Pwork - + If no sources have been placed in the current directory, this command won't do anything, since this project does not change the sources it inherited from `Build`, therefore all the object files @@ -2154,7 +2156,7 @@ line. -- New spec of Pkg does not need a completion for Excluded_Source_Files use ("pack.adb"); end Work; - + All packages that are not declared in the extending project are inherited from the project being extended, with their attributes, with the exception of @@ -2182,7 +2184,7 @@ For example, consider the following hierarchy of projects. a.gpr contains package A1 b.gpr, imports a.gpr and contains B1, which depends on A1 c.gpr, imports b.gpr and contains C1, which depends on B1 - + If we want to locally extend the packages `A1` and `C1`, we need to create several extending projects: @@ -2191,7 +2193,7 @@ create several extending projects: a_ext.gpr which extends a.gpr, and overrides A1 b_ext.gpr which extends b.gpr and imports a_ext.gpr c_ext.gpr which extends c.gpr, imports b_ext.gpr and overrides C1 - + .. code-block:: gpr project A_Ext extends "a.gpr" is @@ -2252,7 +2254,7 @@ Thus, in our example we could create the following projects instead: project C_Ext extends all "c.gpr" is for Source_Files use ("c1.adb"); end C_Ext; - + When building project :file:`c_ext.gpr`, the entire modified project space is considered for recompilation, including the sources of :file:`b.gpr` that are @@ -2289,7 +2291,7 @@ However, if you build your project through *gprbuild*, using a syntax similar to :: gprbuild -PA.gpr - + this will only rebuild the main programs of project A, not those of the imported projects B and C. Therefore you have to spawn several *gprbuild* commands, one per project, to build all executables. @@ -2341,7 +2343,7 @@ Using only *gprbuild*, you could do gprbuild -PA.gpr gprbuild -PB.gpr - + to build both. But again, *gprbuild* has to do some duplicate work for those files that are shared between the two, and cannot truly build things in parallel efficiently. @@ -2401,7 +2403,7 @@ reference external variables in |with| declarations, as in project MyProject is ... end MyProject; - + For various reasons, this is not allowed. But using aggregate projects provide an elegant solution. For instance, you could use a project file like: @@ -2416,7 +2418,7 @@ an elegant solution. For instance, you could use a project file like: project MyProject is ... end MyProject; - + .. _Performance_improvements_in_builder: @@ -2527,7 +2529,7 @@ The following three attributes can be used only in an aggregate project: for Project_Files use ("/.gpr"); -- all projects recursively - + .. index:: Project_Path (GNAT Project Manager) @@ -2601,7 +2603,7 @@ The following three attributes can be used only in an aggregate project: .. code-block:: gpr for Project_Path use ("/usr/local/gpr", "gpr/"); - + .. index:: External (GNAT Project Manager) **External**: @@ -2665,7 +2667,7 @@ are valid: .. code-block:: gpr for Switches (others) use ("-v", "-k", "-j8"); - + These switches are only read from the main aggregate project (the one passed on the command line), and ignored in all other aggregate projects or projects. @@ -2740,7 +2742,7 @@ are valid: use ("-O0", "-g"); end Compiler; end C; - + then the following switches are used: @@ -2816,13 +2818,13 @@ and C: for Library_Name use ("agg"); for Library_Dir use ("lagg"); end Agg; - + Then, when you build with: .. code-block:: sh gprbuild agg.gpr - + This will build all units from projects A, B and C and will create a static library named :file:`libagg.a` in the :file:`lagg` directory. An aggregate library project has the same set of @@ -2929,7 +2931,7 @@ are always case-insensitive ("Name" is the same as "name"). simple_name ::= identifier name ::= simple_name { . simple_name } - + **Strings** are used for values of attributes or as indexes for these attributes. They are in general case sensitive, except when noted otherwise (in particular, strings representing file names will be case @@ -2939,7 +2941,7 @@ represent the same file). **Reserved words** are the same as for standard Ada 95, and cannot be used for identifiers. In particular, the following words are currently used in project files, but others could be added later on. In bold are the -extra reserved words in project files: +extra reserved words in project files: ``all``, ``at``, ``case``, ``end``, ``for``, ``is``, ``limited``, ``null``, ``others``, ``package``, ``renames``, ``type``, ``use``, ``when``, ``with``, **extends**, **external**, **project**. @@ -2980,7 +2982,7 @@ in the cycle is a **limited with**. with "other_project.gpr"; project My_Project extends "extended.gpr" is end My_Project; - + These dependencies form a **directed graph**, potentially cyclic when using **limited with**. The subgraph reflecting the **extends** relations is a tree. @@ -3010,7 +3012,7 @@ in the child project. project <project_>name is {declarative_item} end <project_>simple_name; - + .. _Qualified_Projects: @@ -3021,7 +3023,7 @@ Before the reserved `project`, there may be one or two **qualifiers**, that is identifiers or reserved words, to qualify the project. The current list of qualifiers is: -**abstract**: +**abstract**: Qualifies a project with no sources. Such a project must either have no declaration of attributes `Source_Dirs`, `Source_Files`, `Languages` or `Source_List_File`, or one of @@ -3029,11 +3031,11 @@ The current list of qualifiers is: as empty. If it extends another project, the project it extends must also be a qualified abstract project. -**standard**: +**standard**: A standard project is a non library project with sources. This is the default (implicit) qualifier. -**aggregate**: +**aggregate**: A project whose sources are aggregated from other project files. **aggregate library**: @@ -3071,7 +3073,7 @@ declaration. Others can appear within a project or within a package. | empty_declaration empty_declaration ::= *null* ; - + An empty declaration is allowed anywhere a declaration is allowed. It has no effect. @@ -3177,9 +3179,9 @@ The following packages are currently supported in project files used to automatically find all source files in the source directories, or given a file name to find out its language for proper processing. See :ref:`Naming_Schemes`. - + .. only: PRO or GPL - + *Pretty_Printer* This package specifies the options used when calling the formatting tool *gnatpp* via the *gnat* driver. Its attributes @@ -3208,7 +3210,7 @@ In its simplest form, a package may be empty: package Builder is end Builder; end Simple; - + A package may contain **attribute declarations**, **variable declarations** and **case constructions**, as will be described below. @@ -3306,7 +3308,7 @@ following Ada declarations show the existing operators: function "&" (X : String; Y : String) return String; function "&" (X : String_List; Y : String) return String_List; function "&" (X : String_List; Y : String_List) return String_List; - + Here are some specific examples: @@ -3316,7 +3318,7 @@ Here are some specific examples: List2 := List & (File_Name & ".orig"); -- Two strings Big_List := List & Lists2; -- Three strings Illegal := "gnat.adc" & List2; -- Illegal, must start with list - + .. _External_Values: @@ -3333,7 +3335,7 @@ one that returns a string list. The syntax of a single string external value is:: external_value ::= *external* ( string_literal [, string_literal] ) - + The first string_literal is the string to be used on the command line or in the environment to specify the external value. The second string_literal, @@ -3363,7 +3365,7 @@ attributes in various scenarios. Thus such variables are often called The syntax for a string list external value is:: external_value ::= *external_as_list* ( string_literal , string_literal ) - + The first string_literal is the string to be used on the command line or in the environment to specify the external value. The second string_literal is @@ -3382,7 +3384,7 @@ last separator and the end are components of the string list. :: *external_as_list* ("SWITCHES", ",") - + If the external value is "-O2,-g", the result is ("-O2", "-g"). @@ -3412,7 +3414,7 @@ level, not inside a package. typed_string_declaration ::= *type* *<typed_string_>*_simple_name *is* ( string_literal {, string_literal} ); - + The string literals in the list are case sensitive and must all be different. They may include any graphic characters allowed in Ada, including spaces. Here is an example of a string type declaration: @@ -3420,7 +3422,7 @@ Here is an example of a string type declaration: .. code-block:: ada type OS is ("NT", "nt", "Unix", "GNU/Linux", "other OS"); - + Variables of a string type are called **typed variables**; all other variables are called **untyped variables**. Typed variables are particularly useful in `case` constructions, to support conditional @@ -3465,9 +3467,9 @@ A variable may be declared at the project file level, or within a package. typed_variable_declaration ::= *<typed_variable_>*simple_name : *<typed_string_>*name := string_expression; - + variable_declaration ::= *<variable_>*simple_name := expression; - + Here are some examples of variable declarations: .. code-block:: gpr @@ -3482,7 +3484,7 @@ Here are some examples of variable declarations: List_With_One_Element := ("-gnaty"); List_With_Two_Elements := List_With_One_Element & "-gnatg"; Long_List := ("main.ada", "pack1_.ada", "pack1.ada", "pack2_.ada"); - + A **variable reference** may take several forms: * The simple variable name, for a variable in the current package (if any) @@ -3543,7 +3545,7 @@ variables that have already been declared before the case construction. | empty_declaration} discrete_choice_list ::= string_literal {| string_literal} | *others* - + Here is a typical example, with a typed string variable: .. code-block:: gpr @@ -3565,7 +3567,7 @@ Here is a typical example, with a typed string variable: end case; end Compiler; end MyProj; - + .. _Attributes: @@ -3589,7 +3591,7 @@ others have values that are string lists. attribute_designator ::= *<simple_attribute_>*simple_name | *<indexed_attribute_>*simple_name ( string_literal ) - + There are two categories of attributes: **simple attributes** and **indexed attributes**. Each simple attribute has a default value: the empty string (for string @@ -3624,7 +3626,7 @@ Here are some examples of attribute declarations: -- The package name must always be specified, even if it is the current -- package. for Default_Switches use Default.Builder'Default_Switches; - + Attributes references may appear anywhere in expressions, and are used to retrieve the value previously assigned to the attribute. If an attribute has not been set in a given package or project, its value defaults to the @@ -3638,7 +3640,7 @@ empty string or the empty list, with some exceptions. | *<project_>*simple_name | package_identifier | *<project_>*simple_name . package_identifier - + Examples are:: <project>'Object_Dir @@ -3646,7 +3648,7 @@ Examples are:: Imported_Project'Source_Dirs Imported_Project.Naming'Casing Builder'Default_Switches ("Ada") - + The exceptions to the empty defaults are: * Object_Dir: default is "." @@ -3981,12 +3983,20 @@ Project Level Attributes Value is the name of the target platform. Taken into account only in the main project. + Note that when the target is specified on the command line (usually with + a switch --target=), the value of attribute reference 'Target is the one + specified on the command line. + * **Runtime**: single, indexed, case-insensitive index Index is a language name. Indicates the runtime directory that is to be used when using the compiler of the language. Taken into account only in the main project. + Note that when the runtime is specified for a language on the command line + (usually with a switch --RTS), the value of attribute reference 'Runtime + for this language is the one specified on the command line. + * **Configuration - Libraries** * **Library_Builder**: single @@ -4596,7 +4606,9 @@ Package Install Attributes An array attribute to declare a set of files not part of the sources to be installed. The array discriminant is the directory where the file is to be installed. If a relative directory then Prefix (see - below) is prepended. + below) is prepended. Note also that if the same file name occurs + multiple time in the attribute list, the last one will be the one + installed. * **Prefix**: single @@ -4873,5 +4885,3 @@ Package Synchronize Attributes Index is a source file name. Value is the list of switches to be used when invoking `gnatsync` for the source. - - diff --git a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst index 30eb860789e..80634d0eec7 100644 --- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst +++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst @@ -4465,7 +4465,7 @@ If you want to generate a single Ada file and not the transitive closure, you can use instead the *-fdump-ada-spec-slim* switch. You can optionally specify a parent unit, of which all generated units will -be children, using `-fada-spec-parent=``unit`. +be children, using `-fada-spec-parent=<unit>`. Note that we recommend when possible to use the *g++* driver to generate bindings, even for most C headers, since this will in general diff --git a/gcc/ada/doc/share/ada_pygments.py b/gcc/ada/doc/share/ada_pygments.py index 27462a3226d..c23005dd290 100644 --- a/gcc/ada/doc/share/ada_pygments.py +++ b/gcc/ada/doc/share/ada_pygments.py @@ -62,7 +62,7 @@ def get_lexer_tokens(tag_highlighting=False, project_support=False): r'Version|Value_Size|Value|Valid_Scalars|VADS_Size|Valid|Val|' r'Update|Unrestricted_Access|Universal_Literal_String|' r'Unconstrained_Array|Unchecked_Access|Unbiased_Rounding|' - r'UET_Address|Truncation|Type_Class|To_Address|Tick|Terminated|' + r'Truncation|Type_Class|To_Address|Tick|Terminated|' r'Target_Name|Tag|System_Allocator_Alignment|Succ|Stub_Type|' r'Stream_Size|Storage_Unit|Storage_Size|Storage_Pool|Small|Size|' r'Simple_Storage_Pool|Signed_Zeros|Scaling|Scale|' diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index eb57b6996d8..8769631e4c2 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -86,7 +86,6 @@ package body Einfo is -- Class_Wide_Type Node9 -- Current_Value Node9 - -- Part_Of_Constituents Elist9 -- Renaming_Map Uint9 -- Direct_Primitive_Operations Elist10 @@ -94,6 +93,7 @@ package body Einfo is -- Float_Rep Uint10 (but returns Float_Rep_Kind) -- Handler_Records List10 -- Normalized_Position_Max Uint10 + -- Part_Of_Constituents Elist10 -- Component_Bit_Offset Uint11 -- Full_View Node11 @@ -246,6 +246,7 @@ package body Einfo is -- BIP_Initialization_Call Node29 -- Subprograms_For_Type Node29 + -- Anonymous_Object Node30 -- Corresponding_Equality Node30 -- Last_Aggregate_Assignment Node30 -- Static_Initialization Node30 @@ -255,11 +256,9 @@ package body Einfo is -- Activation_Record_Component Node31 -- Encapsulating_State Node32 - -- SPARK_Pragma Node32 -- No_Tagged_Streams_Pragma Node32 -- Linker_Section_Pragma Node33 - -- SPARK_Aux_Pragma Node33 -- Contract Node34 @@ -267,10 +266,13 @@ package body Einfo is -- Anonymous_Master Node36 - -- (unused) Node38 - -- (unused) Node39 - -- (unused) Node40 - -- (unused) Node41 + -- Class_Wide_Preconds List38 + + -- Class_Wide_Postconds List39 + + -- SPARK_Pragma Node40 + + -- SPARK_Aux_Pragma Node41 --------------------------------------------- -- Usage of Flags in Defining Entity Nodes -- @@ -516,7 +518,7 @@ package body Einfo is -- Has_Pragma_Unreferenced_Objects Flag212 -- Requires_Overriding Flag213 -- Has_RACW Flag214 - -- Has_Uplevel_Reference Flag215 + -- Is_Param_Block_Component_Type Flag215 -- Universal_Aliasing Flag216 -- Suppress_Value_Tracking_On_Call Flag217 -- Is_Primitive Flag218 @@ -594,9 +596,9 @@ package body Einfo is -- Is_Uplevel_Referenced_Entity Flag283 -- Is_Unimplemented Flag284 -- Is_Volatile_Full_Access Flag285 - -- Needs_Typedef Flag286 + -- (unused) Flag286 + -- Rewritten_For_C Flag287 - -- (unused) Flag287 -- (unused) Flag288 -- (unused) Flag289 -- (unused) Flag300 @@ -660,13 +662,7 @@ package body Einfo is Opt := First (Expressions (Decl)); while Present (Opt) loop - - -- Currently the only simple option allowed is External - - if Nkind (Opt) = N_Identifier - and then Chars (Opt) = Name_External - and then Chars (Opt) = Option_Nam - then + if Nkind (Opt) = N_Identifier and then Chars (Opt) = Option_Nam then return True; end if; @@ -709,6 +705,7 @@ package body Einfo is function Access_Disp_Table (Id : E) return L is begin pragma Assert (Ekind_In (Id, E_Record_Type, + E_Record_Type_With_Private, E_Record_Subtype)); return Elist16 (Implementation_Base_Type (Id)); end Access_Disp_Table; @@ -765,6 +762,12 @@ package body Einfo is return Node36 (Id); end Anonymous_Master; + function Anonymous_Object (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Protected_Type, E_Task_Type)); + return Node30 (Id); + end Anonymous_Object; + function Associated_Entity (Id : E) return E is begin return Node37 (Id); @@ -842,6 +845,18 @@ package body Einfo is return Flag31 (Id); end Checks_May_Be_Suppressed; + function Class_Wide_Postconds (Id : E) return S is + begin + pragma Assert (Is_Subprogram (Id)); + return List39 (Id); + end Class_Wide_Postconds; + + function Class_Wide_Preconds (Id : E) return S is + begin + pragma Assert (Is_Subprogram (Id)); + return List38 (Id); + end Class_Wide_Preconds; + function Class_Wide_Type (Id : E) return E is begin pragma Assert (Is_Type (Id)); @@ -1192,16 +1207,27 @@ package body Einfo is function Contract (Id : E) return N is begin pragma Assert - (Ekind_In (Id, E_Constant, - E_Entry, + (Ekind_In (Id, E_Protected_Type, -- concurrent variants + E_Task_Body, + E_Task_Type) + or else + Ekind_In (Id, E_Constant, -- object variants + E_Variable) + or else + Ekind_In (Id, E_Entry, -- overloadable variants E_Entry_Family, - E_Generic_Package, + E_Function, + E_Generic_Function, + E_Generic_Procedure, + E_Operator, + E_Procedure, + E_Subprogram_Body) + or else + Ekind_In (Id, E_Generic_Package, -- package variants E_Package, - E_Package_Body, - E_Subprogram_Body, - E_Variable, - E_Void) - or else Is_Subprogram_Or_Generic_Subprogram (Id)); + E_Package_Body) + or else + Ekind (Id) = E_Void); -- special purpose return Node34 (Id); end Contract; @@ -1764,6 +1790,7 @@ package body Einfo is function Has_Small_Clause (Id : E) return B is begin + pragma Assert (Is_Ordinary_Fixed_Point_Type (Id)); return Flag67 (Id); end Has_Small_Clause; @@ -1847,11 +1874,6 @@ package body Einfo is return Flag72 (Id); end Has_Unknown_Discriminants; - function Has_Uplevel_Reference (Id : E) return B is - begin - return Flag215 (Id); - end Has_Uplevel_Reference; - function Has_Visible_Refinement (Id : E) return B is begin pragma Assert (Ekind (Id) = E_Abstract_State); @@ -2322,6 +2344,12 @@ package body Einfo is return Flag138 (Id); end Is_Packed_Array_Impl_Type; + function Is_Param_Block_Component_Type (Id : E) return B is + begin + pragma Assert (Is_Access_Type (Id)); + return Flag215 (Base_Type (Id)); + end Is_Param_Block_Component_Type; + function Is_Potentially_Use_Visible (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -2663,12 +2691,6 @@ package body Einfo is return Flag22 (Id); end Needs_No_Actuals; - function Needs_Typedef (Id : E) return B is - begin - pragma Assert (Is_Type (Id)); - return Flag286 (Id); - end Needs_Typedef; - function Never_Set_In_Source (Id : E) return B is begin return Flag115 (Id); @@ -2829,8 +2851,8 @@ package body Einfo is function Part_Of_Constituents (Id : E) return L is begin - pragma Assert (Ekind (Id) = E_Abstract_State); - return Elist9 (Id); + pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); + return Elist10 (Id); end Part_Of_Constituents; function Partial_View_Has_Unknown_Discr (Id : E) return B is @@ -3026,6 +3048,12 @@ package body Einfo is return Flag93 (Base_Type (Id)); end Reverse_Storage_Order; + function Rewritten_For_C (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Function); + return Flag287 (Id); + end Rewritten_For_C; + function RM_Size (Id : E) return U is begin pragma Assert (Is_Type (Id)); @@ -3089,16 +3117,22 @@ package body Einfo is function SPARK_Aux_Pragma (Id : E) return N is begin pragma Assert - (Ekind_In (Id, E_Generic_Package, -- package variants + (Ekind_In (Id, E_Protected_Type, -- concurrent variants + E_Task_Type) + or else + Ekind_In (Id, E_Generic_Package, -- package variants E_Package, E_Package_Body)); - return Node33 (Id); + return Node41 (Id); end SPARK_Aux_Pragma; function SPARK_Aux_Pragma_Inherited (Id : E) return B is begin pragma Assert - (Ekind_In (Id, E_Generic_Package, -- package variants + (Ekind_In (Id, E_Protected_Type, -- concurrent variants + E_Task_Type) + or else + Ekind_In (Id, E_Generic_Package, -- package variants E_Package, E_Package_Body)); return Flag266 (Id); @@ -3107,30 +3141,50 @@ package body Einfo is function SPARK_Pragma (Id : E) return N is begin pragma Assert - (Ekind_In (Id, E_Function, -- subprogram variants + (Ekind_In (Id, E_Protected_Body, -- concurrent variants + E_Protected_Type, + E_Task_Body, + E_Task_Type) + or else + Ekind_In (Id, E_Entry, -- overloadable variants + E_Entry_Family, + E_Function, E_Generic_Function, E_Generic_Procedure, + E_Operator, E_Procedure, E_Subprogram_Body) or else Ekind_In (Id, E_Generic_Package, -- package variants E_Package, - E_Package_Body)); - return Node32 (Id); + E_Package_Body) + or else + Ekind (Id) = E_Variable); -- variable + return Node40 (Id); end SPARK_Pragma; function SPARK_Pragma_Inherited (Id : E) return B is begin pragma Assert - (Ekind_In (Id, E_Function, -- subprogram variants + (Ekind_In (Id, E_Protected_Body, -- concurrent variants + E_Protected_Type, + E_Task_Body, + E_Task_Type) + or else + Ekind_In (Id, E_Entry, -- overloadable variants + E_Entry_Family, + E_Function, E_Generic_Function, E_Generic_Procedure, + E_Operator, E_Procedure, E_Subprogram_Body) or else Ekind_In (Id, E_Generic_Package, -- package variants E_Package, - E_Package_Body)); + E_Package_Body) + or else + Ekind (Id) = E_Variable); -- variable return Flag265 (Id); end SPARK_Pragma_Inherited; @@ -3383,8 +3437,7 @@ package body Einfo is function Is_Concurrent_Body (Id : E) return B is begin - return Ekind (Id) in - Concurrent_Body_Kind; + return Ekind (Id) in Concurrent_Body_Kind; end Is_Concurrent_Body; function Is_Concurrent_Record_Type (Id : E) return B is @@ -3399,8 +3452,7 @@ package body Einfo is function Is_Decimal_Fixed_Point_Type (Id : E) return B is begin - return Ekind (Id) in - Decimal_Fixed_Point_Kind; + return Ekind (Id) in Decimal_Fixed_Point_Kind; end Is_Decimal_Fixed_Point_Type; function Is_Digits_Type (Id : E) return B is @@ -3430,14 +3482,12 @@ package body Einfo is function Is_Enumeration_Type (Id : E) return B is begin - return Ekind (Id) in - Enumeration_Kind; + return Ekind (Id) in Enumeration_Kind; end Is_Enumeration_Type; function Is_Fixed_Point_Type (Id : E) return B is begin - return Ekind (Id) in - Fixed_Point_Kind; + return Ekind (Id) in Fixed_Point_Kind; end Is_Fixed_Point_Type; function Is_Floating_Point_Type (Id : E) return B is @@ -3465,16 +3515,19 @@ package body Einfo is return Ekind (Id) in Generic_Unit_Kind; end Is_Generic_Unit; + function Is_Ghost_Entity (Id : Entity_Id) return Boolean is + begin + return Is_Checked_Ghost_Entity (Id) or else Is_Ignored_Ghost_Entity (Id); + end Is_Ghost_Entity; + function Is_Incomplete_Or_Private_Type (Id : E) return B is begin - return Ekind (Id) in - Incomplete_Or_Private_Kind; + return Ekind (Id) in Incomplete_Or_Private_Kind; end Is_Incomplete_Or_Private_Type; function Is_Incomplete_Type (Id : E) return B is begin - return Ekind (Id) in - Incomplete_Kind; + return Ekind (Id) in Incomplete_Kind; end Is_Incomplete_Type; function Is_Integer_Type (Id : E) return B is @@ -3484,8 +3537,7 @@ package body Einfo is function Is_Modular_Integer_Type (Id : E) return B is begin - return Ekind (Id) in - Modular_Integer_Kind; + return Ekind (Id) in Modular_Integer_Kind; end Is_Modular_Integer_Type; function Is_Named_Number (Id : E) return B is @@ -3505,8 +3557,7 @@ package body Einfo is function Is_Ordinary_Fixed_Point_Type (Id : E) return B is begin - return Ekind (Id) in - Ordinary_Fixed_Point_Kind; + return Ekind (Id) in Ordinary_Fixed_Point_Kind; end Is_Ordinary_Fixed_Point_Type; function Is_Overloadable (Id : E) return B is @@ -3605,6 +3656,12 @@ package body Einfo is Set_Node36 (Id, V); end Set_Anonymous_Master; + procedure Set_Anonymous_Object (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Protected_Type, E_Task_Type)); + Set_Node30 (Id, V); + end Set_Anonymous_Object; + procedure Set_Associated_Entity (Id : E; V : E) is begin Set_Node37 (Id, V); @@ -3730,6 +3787,18 @@ package body Einfo is Set_Flag31 (Id, V); end Set_Checks_May_Be_Suppressed; + procedure Set_Class_Wide_Preconds (Id : E; V : S) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_List38 (Id, V); + end Set_Class_Wide_Preconds; + + procedure Set_Class_Wide_Postconds (Id : E; V : S) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_List39 (Id, V); + end Set_Class_Wide_Postconds; + procedure Set_Class_Wide_Type (Id : E; V : E) is begin pragma Assert (Is_Type (Id)); @@ -3784,16 +3853,27 @@ package body Einfo is procedure Set_Contract (Id : E; V : N) is begin pragma Assert - (Ekind_In (Id, E_Constant, - E_Entry, + (Ekind_In (Id, E_Protected_Type, -- concurrent variants + E_Task_Body, + E_Task_Type) + or else + Ekind_In (Id, E_Constant, -- object variants + E_Variable) + or else + Ekind_In (Id, E_Entry, -- overloadable variants E_Entry_Family, - E_Generic_Package, + E_Function, + E_Generic_Function, + E_Generic_Procedure, + E_Operator, + E_Procedure, + E_Subprogram_Body) + or else + Ekind_In (Id, E_Generic_Package, -- package variants E_Package, - E_Package_Body, - E_Subprogram_Body, - E_Variable, - E_Void) - or else Is_Subprogram_Or_Generic_Subprogram (Id)); + E_Package_Body) + or else + Ekind (Id) = E_Void); -- special purpose Set_Node34 (Id, V); end Set_Contract; @@ -4669,6 +4749,7 @@ package body Einfo is procedure Set_Has_Small_Clause (Id : E; V : B := True) is begin + pragma Assert (Is_Ordinary_Fixed_Point_Type (Id)); Set_Flag67 (Id, V); end Set_Has_Small_Clause; @@ -4756,11 +4837,6 @@ package body Einfo is Set_Flag72 (Id, V); end Set_Has_Unknown_Discriminants; - procedure Set_Has_Uplevel_Reference (Id : E; V : B := True) is - begin - Set_Flag215 (Id, V); - end Set_Has_Uplevel_Reference; - procedure Set_Has_Visible_Refinement (Id : E; V : B := True) is begin pragma Assert (Ekind (Id) = E_Abstract_State); @@ -5290,6 +5366,12 @@ package body Einfo is Set_Flag138 (Id, V); end Set_Is_Packed_Array_Impl_Type; + procedure Set_Is_Param_Block_Component_Type (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Void, E_General_Access_Type)); + Set_Flag215 (Id, V); + end Set_Is_Param_Block_Component_Type; + procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -5643,12 +5725,6 @@ package body Einfo is Set_Flag22 (Id, V); end Set_Needs_No_Actuals; - procedure Set_Needs_Typedef (Id : E; V : B := True) is - begin - pragma Assert (Is_Type (Id)); - Set_Flag286 (Id, V); - end Set_Needs_Typedef; - procedure Set_Never_Set_In_Source (Id : E; V : B := True) is begin Set_Flag115 (Id, V); @@ -5811,8 +5887,8 @@ package body Einfo is procedure Set_Part_Of_Constituents (Id : E; V : L) is begin - pragma Assert (Ekind (Id) = E_Abstract_State); - Set_Elist9 (Id, V); + pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); + Set_Elist10 (Id, V); end Set_Part_Of_Constituents; procedure Set_Partial_View_Has_Unknown_Discr (Id : E; V : B := True) is @@ -6019,6 +6095,12 @@ package body Einfo is Set_Flag93 (Id, V); end Set_Reverse_Storage_Order; + procedure Set_Rewritten_For_C (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Function); + Set_Flag287 (Id, V); + end Set_Rewritten_For_C; + procedure Set_RM_Size (Id : E; V : U) is begin pragma Assert (Is_Type (Id)); @@ -6083,52 +6165,74 @@ package body Einfo is procedure Set_SPARK_Aux_Pragma (Id : E; V : N) is begin pragma Assert - (Ekind_In (Id, E_Generic_Package, -- package variants + (Ekind_In (Id, E_Protected_Type, -- concurrent variants + E_Task_Type) + or else + Ekind_In (Id, E_Generic_Package, -- package variants E_Package, E_Package_Body)); - - Set_Node33 (Id, V); + Set_Node41 (Id, V); end Set_SPARK_Aux_Pragma; procedure Set_SPARK_Aux_Pragma_Inherited (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Generic_Package, -- package variants + (Ekind_In (Id, E_Protected_Type, -- concurrent variants + E_Task_Type) + or else + Ekind_In (Id, E_Generic_Package, -- package variants E_Package, E_Package_Body)); - Set_Flag266 (Id, V); end Set_SPARK_Aux_Pragma_Inherited; procedure Set_SPARK_Pragma (Id : E; V : N) is begin pragma Assert - (Ekind_In (Id, E_Function, -- subprogram variants + (Ekind_In (Id, E_Protected_Body, -- concurrent variants + E_Protected_Type, + E_Task_Body, + E_Task_Type) + or else + Ekind_In (Id, E_Entry, -- overloadable variants + E_Entry_Family, + E_Function, E_Generic_Function, E_Generic_Procedure, + E_Operator, E_Procedure, E_Subprogram_Body) or else Ekind_In (Id, E_Generic_Package, -- package variants E_Package, - E_Package_Body)); - - Set_Node32 (Id, V); + E_Package_Body) + or else + Ekind (Id) = E_Variable); -- variable + Set_Node40 (Id, V); end Set_SPARK_Pragma; procedure Set_SPARK_Pragma_Inherited (Id : E; V : B := True) is begin pragma Assert - (Ekind_In (Id, E_Function, -- subprogram variants + (Ekind_In (Id, E_Protected_Body, -- concurrent variants + E_Protected_Type, + E_Task_Body, + E_Task_Type) + or else + Ekind_In (Id, E_Entry, -- overloadable variants + E_Entry_Family, + E_Function, E_Generic_Function, E_Generic_Procedure, + E_Operator, E_Procedure, E_Subprogram_Body) or else Ekind_In (Id, E_Generic_Package, -- package variants E_Package, - E_Package_Body)); - + E_Package_Body) + or else + Ekind (Id) = E_Variable); -- variable Set_Flag265 (Id, V); end Set_SPARK_Pragma_Inherited; @@ -6830,7 +6934,9 @@ package body Einfo is begin pragma Assert - (Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id)); + (Is_Concurrent_Type (Id) + or else Is_Incomplete_Or_Private_Type (Id) + or else Is_Record_Type (Id)); Comp_Id := First_Entity (Id); while Present (Comp_Id) loop @@ -6850,8 +6956,9 @@ package body Einfo is begin pragma Assert - (Is_Record_Type (Id) + (Is_Concurrent_Type (Id) or else Is_Incomplete_Or_Private_Type (Id) + or else Is_Record_Type (Id) or else Has_Discriminants (Id)); Comp_Id := First_Entity (Id); @@ -6991,30 +7098,41 @@ package body Einfo is ---------------- function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id is - Is_CDG : constant Boolean := - Id = Pragma_Abstract_State or else - Id = Pragma_Async_Readers or else - Id = Pragma_Async_Writers or else - Id = Pragma_Depends or else - Id = Pragma_Effective_Reads or else - Id = Pragma_Effective_Writes or else - Id = Pragma_Extensions_Visible or else - Id = Pragma_Global or else - Id = Pragma_Initial_Condition or else - Id = Pragma_Initializes or else - Id = Pragma_Part_Of or else - Id = Pragma_Refined_Depends or else - Id = Pragma_Refined_Global or else - Id = Pragma_Refined_State; + + -- Classification pragmas + + Is_CLS : constant Boolean := + Id = Pragma_Abstract_State or else + Id = Pragma_Async_Readers or else + Id = Pragma_Async_Writers or else + Id = Pragma_Constant_After_Elaboration or else + Id = Pragma_Depends or else + Id = Pragma_Effective_Reads or else + Id = Pragma_Effective_Writes or else + Id = Pragma_Extensions_Visible or else + Id = Pragma_Global or else + Id = Pragma_Initial_Condition or else + Id = Pragma_Initializes or else + Id = Pragma_Part_Of or else + Id = Pragma_Refined_Depends or else + Id = Pragma_Refined_Global or else + Id = Pragma_Refined_State or else + Id = Pragma_Volatile_Function; + + -- Contract / test case pragmas + Is_CTC : constant Boolean := - Id = Pragma_Contract_Cases or else + Id = Pragma_Contract_Cases or else Id = Pragma_Test_Case; + + -- Pre / postcondition pragmas + Is_PPC : constant Boolean := - Id = Pragma_Precondition or else - Id = Pragma_Postcondition or else + Id = Pragma_Precondition or else + Id = Pragma_Postcondition or else Id = Pragma_Refined_Post; - In_Contract : constant Boolean := Is_CDG or Is_CTC or Is_PPC; + In_Contract : constant Boolean := Is_CLS or Is_CTC or Is_PPC; Item : Node_Id; Items : Node_Id; @@ -7029,7 +7147,7 @@ package body Einfo is if No (Items) then return Empty; - elsif Is_CDG then + elsif Is_CLS then Item := Classifications (Items); elsif Is_CTC then @@ -7646,6 +7764,17 @@ package body Einfo is end if; end Is_Synchronized_Interface; + --------------------------- + -- Is_Synchronized_State -- + --------------------------- + + function Is_Synchronized_State (Id : E) return B is + begin + return + Ekind (Id) = E_Abstract_State + and then Has_Option (Id, Name_Synchronous); + end Is_Synchronized_State; + ----------------------- -- Is_Task_Interface -- ----------------------- @@ -8770,7 +8899,6 @@ package body Einfo is W ("Has_Thunks", Flag228 (Id)); W ("Has_Unchecked_Union", Flag123 (Id)); W ("Has_Unknown_Discriminants", Flag72 (Id)); - W ("Has_Uplevel_Reference", Flag215 (Id)); W ("Has_Visible_Refinement", Flag263 (Id)); W ("Has_Volatile_Components", Flag87 (Id)); W ("Has_Xref_Entry", Flag182 (Id)); @@ -8850,6 +8978,7 @@ package body Einfo is W ("Is_Package_Body_Entity", Flag160 (Id)); W ("Is_Packed", Flag51 (Id)); W ("Is_Packed_Array_Impl_Type", Flag138 (Id)); + W ("Is_Param_Block_Component_Type", Flag215 (Id)); W ("Is_Potentially_Use_Visible", Flag9 (Id)); W ("Is_Predicate_Function", Flag255 (Id)); W ("Is_Predicate_Function_M", Flag256 (Id)); @@ -8900,7 +9029,6 @@ package body Einfo is W ("Must_Have_Preelab_Init", Flag208 (Id)); W ("Needs_Debug_Info", Flag147 (Id)); W ("Needs_No_Actuals", Flag22 (Id)); - W ("Needs_Typedef", Flag286 (Id)); W ("Never_Set_In_Source", Flag115 (Id)); W ("No_Dynamic_Predicate_On_actual", Flag276 (Id)); W ("No_Pool_Assigned", Flag131 (Id)); @@ -8926,6 +9054,7 @@ package body Einfo is W ("Returns_Limited_View", Flag134 (Id)); W ("Reverse_Bit_Order", Flag164 (Id)); W ("Reverse_Storage_Order", Flag93 (Id)); + W ("Rewritten_For_C", Flag287 (Id)); W ("Sec_Stack_Needed_For_Return", Flag167 (Id)); W ("Size_Depends_On_Discriminant", Flag177 (Id)); W ("Size_Known_At_Compile_Time", Flag92 (Id)); @@ -9151,9 +9280,6 @@ package body Einfo is when Object_Kind => Write_Str ("Current_Value"); - when E_Abstract_State => - Write_Str ("Part_Of_Constituents"); - when E_Function | E_Generic_Function | E_Generic_Package | @@ -9199,6 +9325,10 @@ package body Einfo is E_Discriminant => Write_Str ("Normalized_Position_Max"); + when E_Abstract_State | + E_Variable => + Write_Str ("Part_Of_Constituents"); + when others => Write_Str ("Field10??"); end case; @@ -10036,6 +10166,10 @@ package body Einfo is procedure Write_Field30_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Protected_Type | + E_Task_Type => + Write_Str ("Anonymous_Object"); + when E_Function => Write_Str ("Corresponding_Equality"); @@ -10090,16 +10224,6 @@ package body Einfo is E_Variable => Write_Str ("Encapsulating_State"); - when E_Function | - E_Generic_Function | - E_Generic_Package | - E_Generic_Procedure | - E_Package | - E_Package_Body | - E_Procedure | - E_Subprogram_Body => - Write_Str ("SPARK_Pragma"); - when Type_Kind => Write_Str ("No_Tagged_Streams_Pragma"); @@ -10115,11 +10239,6 @@ package body Einfo is procedure Write_Field33_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Generic_Package | - E_Package | - E_Package_Body => - Write_Str ("SPARK_Aux_Pragma"); - when E_Constant | E_Variable | Subprogram_Kind | @@ -10141,14 +10260,20 @@ package body Einfo is when E_Constant | E_Entry | E_Entry_Family | + E_Function | + E_Generic_Function | E_Generic_Package | + E_Generic_Procedure | + E_Operator | E_Package | E_Package_Body | + E_Procedure | + E_Protected_Type | E_Subprogram_Body | + E_Task_Body | + E_Task_Type | E_Variable | - E_Void | - Generic_Subprogram_Kind | - Subprogram_Kind => + E_Void => Write_Str ("Contract"); when others => @@ -10208,6 +10333,10 @@ package body Einfo is procedure Write_Field38_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Function | + E_Procedure => + Write_Str ("Class-wide preconditions"); + when others => Write_Str ("Field38??"); end case; @@ -10220,6 +10349,10 @@ package body Einfo is procedure Write_Field39_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Function | + E_Procedure => + Write_Str ("Class-wide postcondition"); + when others => Write_Str ("Field39??"); end case; @@ -10232,6 +10365,24 @@ package body Einfo is procedure Write_Field40_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Entry | + E_Entry_Family | + E_Function | + E_Generic_Function | + E_Generic_Package | + E_Generic_Procedure | + E_Operator | + E_Package | + E_Package_Body | + E_Procedure | + E_Protected_Body | + E_Protected_Type | + E_Subprogram_Body | + E_Task_Body | + E_Task_Type | + E_Variable => + Write_Str ("SPARK_Pragma"); + when others => Write_Str ("Field40??"); end case; @@ -10244,6 +10395,13 @@ package body Einfo is procedure Write_Field41_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Generic_Package | + E_Package | + E_Package_Body | + E_Protected_Type | + E_Task_Type => + Write_Str ("SPARK_Aux_Pragma"); + when others => Write_Str ("Field41??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 6ca5e5e0140..8b91ee4ad8f 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -120,7 +120,7 @@ package Einfo is -- For functions that are not inlined, there is no restriction on the body, -- and XEINFO generates a direct reference in the C header file which allows --- the C code in the backend to directly call the corresponding Ada body. +-- the C code in the backend to directly call the corresponding Ada body. ---------------------------------- -- Handling of Type'Size Values -- @@ -444,6 +444,10 @@ package Einfo is -- finalization master that services most anonymous access-to-controlled -- allocations that occur within the unit. +-- Anonymous_Object (Node30) +-- Present in protected and task type entities. Contains the entity of +-- the anonymous object created for a single protected or task type. + -- Associated_Entity (Node37) -- Defined in all entities. This field is similar to Associated_Node, but -- applied to entities. The attribute links an entity from the generic @@ -462,10 +466,15 @@ package Einfo is -- copying trees, to determine whether or not to copy an Itype, and -- also for accessibility checks on anonymous access types. This -- node is typically an object declaration, component declaration, --- type or subtype declaration. For an access discriminant in a type --- declaration, the associated_node_for_itype is the discriminant --- specification. For an access parameter it is the enclosing subprogram --- declaration. +-- type or subtype declaration. + +-- For an access discriminant in a type declaration, the associated_ +-- node_for_itype is the corresponding discriminant specification. + +-- For an access parameter it is the enclosing subprogram declaration. + +-- For an access_to_protected_subprogram parameter it is the declaration +-- of the corresponding formal parameter. -- -- Itypes have no explicit declaration, and therefore are not attached to -- the tree: their Parent field is always empty. The Associated_Node_For_ @@ -602,6 +611,17 @@ package Einfo is -- tables must be consulted to determine if there actually is an active -- Suppress or Unsuppress pragma that applies to the entity. +-- Class_Wide_Preconds (List38) +-- Defined on subprograms. Holds the list of class-wide precondition +-- functions inherited from ancestors. Each such function is an +-- instantiation of the generic function generated from an explicit +-- aspect specification for a class-wide precondition. A type is an +-- ancestor of itself, and therefore a root type has such an instance +-- on its own list. + +-- Class_Wide_Postconds (List39) +-- Ditto for class-wide postconditions. + -- Class_Wide_Type (Node9) -- Defined in all type entities. For a tagged type or subtype, returns -- the corresponding implicitly declared class-wide type. For a @@ -688,6 +708,12 @@ package Einfo is -- bodies. Set if the entity contains any ignored Ghost code in the form -- of declaration, procedure call, assignment statement or pragma. +-- Contract (Node34) +-- Defined in constant, entry, entry family, operator, [generic] package, +-- package body, protected type, [generic] subprogram, subprogram body, +-- variable and task type entities. Points to the contract of the entity, +-- holding various assertion items and data classifiers. + -- Corresponding_Concurrent_Type (Node18) -- Defined in record types that are constructed by the expander to -- represent task and protected types (Is_Concurrent_Record_Type flag @@ -1052,9 +1078,9 @@ package Einfo is -- need to set the flag. -- Encapsulating_State (Node32) --- Defined in abstract states, constants and variables. Contains the --- entity of an ancestor state whose refinement utilizes this item as --- a constituent. +-- Defined in abstract state, constant and variable entities. Contains +-- the entity of an ancestor state or a single concurrent type whose +-- refinement utilizes this item as a constituent. -- Enclosing_Scope (Node18) -- Defined in labels. Denotes the innermost enclosing construct that @@ -1107,12 +1133,6 @@ package Einfo is -- accept statement for a member of the family, and in the prefix of -- 'COUNT when it applies to a family member. --- Contract (Node34) --- Defined in constant, entry, entry family, [generic] package, package --- body, [generic] subprogram, subprogram body, and variable entities. --- Points to the contract of the entity, holding various assertion items --- and data classifiers. - -- Entry_Parameters_Type (Node15) -- Defined in entries. Points to the access-to-record type that is -- constructed by the expander to hold a reference to the parameter @@ -1270,14 +1290,15 @@ package Einfo is -- objects. -- First_Component (synthesized) --- Applies to record types. Returns the first component by following the --- chain of declared entities for the record until a component is found --- (one with an Ekind of E_Component). The discriminants are skipped. If --- the record is null, then Empty is returned. +-- Applies to incomplete, private, protected, record and task types. +-- Returns the first component by following the chain of declared +-- entities for the type a component is found (one with an Ekind of +-- E_Component). The discriminants are skipped. If the record is null, +-- then Empty is returned. -- First_Component_Or_Discriminant (synthesized) --- Similar to First_Component, but discriminants are not skipped, so will --- find the first discriminant if discriminants are present. +-- Similar to First_Component, but discriminants are not skipped, so will +-- find the first discriminant if discriminants are present. -- First_Entity (Node17) -- Defined in all entities which act as scopes to which a list of @@ -1503,16 +1524,16 @@ package Einfo is -- Defined in enumeration types. Set if the type as a representation -- clause whose entries are successive integers. --- Has_Controlling_Result (Flag98) --- Defined in E_Function entities. Set if the function is a primitive --- function of a tagged type which can dispatch on result. - -- Has_Controlled_Component (Flag43) [base type only] -- Defined in all type and subtype entities. Set only for composite type -- entities which contain a component that either is a controlled type, -- or itself contains controlled component (i.e. either Is_Controlled or -- Has_Controlled_Component is set for at least one component). +-- Has_Controlling_Result (Flag98) +-- Defined in E_Function entities. Set if the function is a primitive +-- function of a tagged type which can dispatch on result. + -- Has_Convention_Pragma (Flag119) -- Defined in all entities. Set for an entity for which a valid pragma -- Convention, Import, or Export has been given. Used to prevent more @@ -1525,7 +1546,7 @@ package Einfo is -- node will be present on the rep item chain for the entity. For a -- derived type that inherits a default from its ancestor, the default -- value is set, but it may be overridden by an aspect declaration on --- type type derivation. +-- type derivation. -- Has_Default_Init_Cond (Flag3) [base type only] -- Defined in all type entities. Set if pragma Default_Initial_Condition @@ -1550,7 +1571,7 @@ package Einfo is -- delayed and is one of the characteristics that may be inherited by -- types derived from this type if not overridden. If this flag is set, -- then types derived from this type have May_Inherit_Delayed_Rep_Aspects --- set, signalling that Freeze.Inhert_Delayed_Rep_Aspects must be called +-- set, signalling that Freeze.Inherit_Delayed_Rep_Aspects must be called -- at the freeze point of the derived type. -- Has_Discriminants (Flag5) @@ -1613,7 +1634,7 @@ package Einfo is -- generic entities before the corresponding generic body has been seen. -- If a package has a forward instantiation, we cannot inline subprograms -- appearing in the same package because the placement requirements of --- the instance will conflict with the linear elaboration of front-end +-- the instance will conflict with the linear elaboration of front-end -- inlining. -- Has_Fully_Qualified_Name (Flag173) @@ -1820,19 +1841,19 @@ package Einfo is -- valid pragma Pack was given for the type. Note that this flag is not -- inherited by derived type. See also the Is_Packed flag. +-- Has_Pragma_Preelab_Init (Flag221) +-- Defined in type and subtype entities. If set indicates that a valid +-- pragma Preelaborable_Initialization applies to the type. + -- Has_Pragma_Pure (Flag203) -- Defined in all entities. If set, indicates that a valid pragma Pure -- was given for the entity. In some cases, we need to test whether -- Is_Pure was explicitly set using this pragma. --- Has_Pragma_Preelab_Init (Flag221) --- Defined in type and subtype entities. If set indicates that a valid --- pragma Preelaborable_Initialization applies to the type. - -- Has_Pragma_Pure_Function (Flag179) -- Defined in all entities. If set, indicates that a valid pragma --- Pure_Function was given for the entity. In some cases, we need to --- know that Is_Pure was explicitly set using this pragma. We also set +-- Pure_Function was given for the entity. In some cases, we need to test +-- whether Is_Pure was explicitly set using this pragma. We also set -- this flag for some internal entities that we know should be treated -- as pure for optimization purposes. @@ -2026,18 +2047,9 @@ package Einfo is -- their subtypes have unknown discriminants and can have declared ones -- as well. Private types declared with unknown discriminants may have a -- full view that has explicit discriminants, and both flag will be set --- on the partial view, to insure that discriminants are properly +-- on the partial view, to ensure that discriminants are properly -- inherited in certain contexts. --- Has_Uplevel_Reference (Flag215) --- Defined in all entities. Indicates that the entity is locally defined --- within a subprogram P, and there is a reference to the entity within --- a subprogram nested within P (at any depth). Set only for the VM case --- (where it is set for variables, constants, and loop parameters). Note --- that this is similar in usage to Is_Uplevel_Referenced_Entity (which --- is used when we are unnesting subprograms), but the usages are a bit --- different and it is cleaner to leave the old VM usage unchanged. - -- Has_Visible_Refinement (Flag263) -- Defined in E_Abstract_State entities. Set when a state has at least -- one refinement constituent and analysis is in the region between @@ -2131,25 +2143,14 @@ package Einfo is -- Interface_Name (Node21) -- Defined in constants, variables, exceptions, functions, procedures, --- packages, components (JGNAT only), discriminants (JGNAT only), and --- access to subprograms (JGNAT only). Set to Empty unless an export, --- import, or interface name pragma has explicitly specified an external --- name, in which case it references an N_String_Literal node for the --- specified external name. Note that if this field is Empty, and --- Is_Imported or Is_Exported is set, then the default interface name --- is the name of the entity, cased in a manner that is appropriate to --- the system in use. Note that Interface_Name is ignored if an address --- clause is present (since it is meaningless in this case). --- --- An additional special case usage of this field is in JGNAT for --- E_Component and E_Discriminant. JGNAT allows these entities to be --- imported by specifying pragma Import within a component's containing --- record definition. This supports interfacing to object fields defined --- within Java classes, and such pragmas are generated by the jvm2ada --- binding generator tool whenever it processes classes with public --- object fields. A pragma Import for a component can define the --- External_Name of the imported Java field (which is generally needed, --- because Java names are case sensitive). +-- and packages. Set to Empty unless an export, import, or interface name +-- pragma has explicitly specified an external name, in which case it +-- references an N_String_Literal node for the specified external name. +-- Note that if this field is Empty, and Is_Imported or Is_Exported is +-- set, then the default interface name is the name of the entity, cased +-- in a manner that is appropriate to the system in use. Note that +-- Interface_Name is ignored if an address clause is present (since it +-- is meaningless in this case). -- Interfaces (Elist25) -- Defined in record types and subtypes. List of abstract interfaces @@ -2213,6 +2214,13 @@ package Einfo is -- carry the keyword aliased, and on record components that have the -- keyword. For Ada 2012, also applies to formal parameters. +-- Is_Array_Type (synthesized) +-- Applies to all entities, true for array types and subtypes + +-- Is_Asynchronous (Flag81) +-- Defined in all type entities and in procedure entities. Set +-- if a pragma Asynchronous applies to the entity. + -- Is_Atomic (Flag85) -- Defined in all type entities, and also in constants, components, and -- variables. Set if a pragma Atomic or Shared applies to the entity. @@ -2227,13 +2235,6 @@ package Einfo is -- usage. In the case of private and incomplete types, the predicate -- applies to both the partial view and the full view. --- Is_Array_Type (synthesized) --- Applies to all entities, true for array types and subtypes - --- Is_Asynchronous (Flag81) --- Defined in all type entities and in procedure entities. Set --- if a pragma Asynchronous applies to the entity. - -- Is_Base_Type (synthesized) -- Applies to type and subtype entities. True if entity is a base type @@ -2270,14 +2271,14 @@ package Einfo is -- Defined in all entities. Set only for defining entities of program -- units that are child units (but False for subunits). --- Is_Class_Wide_Type (synthesized) --- Applies to all entities, true for class wide types and subtypes - -- Is_Class_Wide_Equivalent_Type (Flag35) -- Defined in record types and subtypes. Set to True, if the type acts -- as a class-wide equivalent type, i.e. the Equivalent_Type field of -- some class-wide subtype entity references this record type. +-- Is_Class_Wide_Type (synthesized) +-- Applies to all entities, true for class wide types and subtypes + -- Is_Compilation_Unit (Flag149) -- Defined in all entities. Set if the entity is a package or subprogram -- entity for a compilation unit other than a subunit (since we treat @@ -2285,8 +2286,7 @@ package Einfo is -- parent, we do not consider them to be separate units for this flag). -- Is_Completely_Hidden (Flag103) --- Defined in all entities. This flag can be set only for E_Discriminant --- entities. This flag can be set only for girder discriminants of +-- Defined on discriminants. Only set on girder discriminants of -- untagged types. When set, the entity is a girder discriminant of a -- derived untagged type which is not directly visible in the derived -- type because the derived type or one of its ancestors have renamed the @@ -2365,13 +2365,13 @@ package Einfo is -- Defined in all entities. True if the entity is type System.Address, -- or (recursively) a subtype or derived type of System.Address. --- Is_Discrete_Type (synthesized) --- Applies to all entities, true for all discrete types and subtypes - -- Is_Discrete_Or_Fixed_Point_Type (synthesized) -- Applies to all entities, true for all discrete types and subtypes -- and all fixed-point types and subtypes. +-- Is_Discrete_Type (synthesized) +-- Applies to all entities, true for all discrete types and subtypes + -- Is_Discrim_SO_Function (Flag176) -- Defined in all entities. Set only in E_Function entities that Layout -- creates to compute discriminant-dependent dynamic size/offset values. @@ -2409,9 +2409,6 @@ package Einfo is -- of pragma Eliminate. Also used to mark subprogram entities whose -- declaration and body are within unreachable code that is removed. --- Is_Enumeration_Type (synthesized) --- Defined in all entities, true for enumeration types and subtypes - -- Is_Entry (synthesized) -- Applies to all entities, True only for entry and entry family -- entities and False for all other entity kinds. @@ -2421,11 +2418,14 @@ package Einfo is -- be in, in-out or out parameters). This flag is used to speed up the -- test for the need to replace references in Exp_Ch2. +-- Is_Enumeration_Type (synthesized) +-- Defined in all entities, true for enumeration types and subtypes + -- Is_Exported (Flag99) -- Defined in all entities. Set if the entity is exported. For now we -- only allow the export of constants, exceptions, functions, procedures -- and variables, but that may well change later on. Exceptions can only --- be exported in the Java VM implementation of GNAT. +-- be exported in the Java VM implementation of GNAT, which is retired. -- Is_External_State (synthesized) -- Applies to all entities, true for abstract states that are subject to @@ -2445,7 +2445,7 @@ package Einfo is -- Is_Fixed_Point_Type (synthesized) -- Applies to all entities, true for decimal and ordinary fixed --- point types and subtypes +-- point types and subtypes. -- Is_Floating_Point_Type (synthesized) -- Applies to all entities, true for float types and subtypes @@ -2507,6 +2507,13 @@ package Einfo is -- package, generic function, generic procedure), and False for all -- other entities. +-- Is_Ghost_Entity (synthesized) +-- Applies to all entities. Yields True for abstract states, [generic] +-- packages, [generic] subprograms, components, discriminants, formal +-- parameters, objects, package bodies, subprogram bodies, and [sub]types +-- subject to pragma Ghost or those that inherit the Ghost propery from +-- an enclosing construct. + -- Is_Hidden (Flag57) -- Defined in all entities. Set for all entities declared in the -- private part or body of a package. Also marks generic formals of a @@ -2549,7 +2556,7 @@ package Einfo is -- Defined in all entities. Set if the entity is imported. For now we -- only allow the import of exceptions, functions, procedures, packages. -- and variables. Exceptions, packages and types can only be imported in --- the Java VM implementation. +-- the Java VM implementation, which is retired. -- Is_Incomplete_Or_Private_Type (synthesized) -- Applies to all entities, true for private and incomplete types @@ -2641,8 +2648,8 @@ package Einfo is -- to intrinsic, which causes intrinsic code to be generated. -- Is_Invariant_Procedure (Flag257) --- Defined in functions an procedures. Set for a generated invariant --- procedure to identify it easily in the +-- Defined in functions and procedures. Set for a generated invariant +-- procedure to identify it easily. -- Is_Itype (Flag91) -- Defined in all entities. Set to indicate that a type is an Itype, @@ -2805,14 +2812,14 @@ package Einfo is -- Applies to all entities, true for ordinary fixed point types and -- subtypes. --- Is_Package_Or_Generic_Package (synthesized) --- Applies to all entities. True for packages and generic packages. --- False for all other entities. - -- Is_Package_Body_Entity (Flag160) -- Defined in all entities. Set for entities defined at the top level -- of a package body. Used to control externally generated names. +-- Is_Package_Or_Generic_Package (synthesized) +-- Applies to all entities. True for packages and generic packages. +-- False for all other entities. + -- Is_Packed (Flag51) [implementation base type only] -- Defined in all type entities. This flag is set only for record and -- array types which have a packed representation. There are three @@ -2863,6 +2870,11 @@ package Einfo is -- set in an entity, then the Original_Array_Type field of this entity -- points to the array type for which this is the Packed_Array_Impl_Type. +-- Is_Param_Block_Component_Type (Flag215) [base type only] +-- Defined in access types. Set to indicate that a type is the type of a +-- component of the parameter block record type generated by the compiler +-- for an entry or a select statement. Read by CodePeer. + -- Is_Potentially_Use_Visible (Flag9) -- Defined in all entities. Set if entity is potentially use visible, -- i.e. it is defined in a package that appears in a currently active @@ -2922,7 +2934,7 @@ package Einfo is -- Is_Private_Type (synthesized) -- Applies to all entities, true for private types and subtypes, --- as well as for record with private types as subtypes +-- as well as for record with private types as subtypes. -- Is_Processed_Transient (Flag252) -- Defined in variables, loop parameters, and constants, including the @@ -2939,6 +2951,10 @@ package Einfo is -- Defined in types that are interfaces. True if interface is declared -- protected, or is derived from protected interfaces. +-- Is_Protected_Record_Type (synthesized) +-- Applies to all entities, true if Is_Concurrent_Record_Type is true and +-- Corresponding_Concurrent_Type is a protected type. + -- Is_Protected_Type (synthesized) -- Applies to all entities, true for protected types and subtypes @@ -2949,10 +2965,6 @@ package Einfo is -- example in the case of a variable name, then the backend will generate -- an appropriate external name for use by the linker. --- Is_Protected_Record_Type (synthesized) --- Applies to all entities, true if Is_Concurrent_Record_Type is true and --- Corresponding_Concurrent_Type is a protected type. - -- Is_Pure (Flag44) -- Defined in all entities. Set in all entities of a unit to which a -- pragma Pure is applied except for non-intrinsic imported subprograms, @@ -2981,7 +2993,7 @@ package Einfo is -- Is_Record_Type (synthesized) -- Applies to all entities, true for record types and subtypes, --- includes class-wide types and subtypes (which are also records) +-- includes class-wide types and subtypes (which are also records). -- Is_Remote_Call_Interface (Flag62) -- Defined in all entities. Set in E_Package and E_Generic_Package @@ -3035,9 +3047,7 @@ package Einfo is -- static bounds, a record all of whose component types are static types, -- or an array, all of whose bounds are of a static type, and also have -- a component type that is a static type). See Set_Uplevel_Type for more --- information on how this flag is used. Note that if Is_Static_Type is --- True, then it is never the case that the Has_Uplevel_Reference flag is --- set for the same type. +-- information on how this flag is used. -- Is_Statically_Allocated (Flag28) -- Defined in all entities. This can only be set for exception, @@ -3074,6 +3084,10 @@ package Einfo is -- synchronized, task, or protected, or is derived from a synchronized -- interface. +-- Is_Synchronized_State (synthesized) +-- Applies to all entities, true for abstract states that are subject to +-- option Synchronous. + -- Is_Tag (Flag78) -- Defined in E_Component and E_Constant entities. For regular tagged -- type this flag is set on the tag component (whose name is Name_uTag). @@ -3081,7 +3095,7 @@ package Einfo is -- vtable (i.e. the one to be extended by derivation). -- Is_Tagged_Type (Flag55) --- Defined in all entities. Set for an entity that is a tagged type. +-- Defined in all entities, set for an entity that is a tagged type -- Is_Task_Interface (synthesized) -- Defined in types that are interfaces. True if interface is declared as @@ -3162,10 +3176,6 @@ package Einfo is -- the cases where the reference is implicit (e.g. the type of an array -- used for computing the location of an element in an array. This is -- used internally in Exp_Unst, see this package for further details. --- Note that this is similar to the Has_Uplevel_Reference flag which --- is used in the VM case but we prefer to keep the two cases entirely --- separated, so that the VM usage is not disturbed by work on the --- Unnesting_Subprograms mode. -- Is_Valued_Procedure (Flag127) -- Defined in procedure entities. Set if an Import_Valued_Procedure @@ -3375,14 +3385,6 @@ package Einfo is -- interpreted as an indexing of the result of the call. It is also -- used to resolve various cases of entry calls. --- Needs_Typedef (Flag286) --- Defined for all types and subtypes. Set if it is essential to generate --- a typedef when we are generating C code from Cprint. Normally we --- generate typedef's only for source entities, and not for internally --- generated types, but there are cases, notably the AREC types generated --- in Exp_Unst when we are unnesting subprograms where we must generate --- typedef's for non-source types. - -- Never_Set_In_Source (Flag115) -- Defined in all entities, but can be set only for variables and -- parameters. This flag is set if the object is never assigned a value @@ -3477,7 +3479,7 @@ package Einfo is -- Next_Inlined_Subprogram (Node12) -- Defined in subprograms. Used to chain inlined subprograms used in -- the current compilation, in the order in which they must be compiled --- by the backend to insure that all inlinings are performed. +-- by the backend to ensure that all inlinings are performed. -- Next_Literal (synthesized) -- Applies to enumeration literals, returns the next literal, or @@ -3516,7 +3518,7 @@ package Einfo is -- access type, or if an explicit pragma No_Strict_Aliasing applies. -- No_Tagged_Streams_Pragma (Node32) --- Present in all subtype and type entities. Set for tagged types and +-- Present in all subtype and type entities. Set for tagged types and -- subtypes (i.e. entities with Is_Tagged_Type set True) if a valid -- pragma/aspect applies to the type. @@ -3674,16 +3676,17 @@ package Einfo is -- Parameter_Mode (synthesized) -- Applies to formal parameter entities. This is a synonym for Ekind, -- used when obtaining the formal kind of a formal parameter (the result --- is one of E_[In/Out/In_Out]_Parameter) +-- is one of E_[In/Out/In_Out]_Parameter). -- Parent_Subtype (Node19) [base type only] -- Defined in E_Record_Type. Set only for derived tagged types, in which -- case it points to the subtype of the parent type. This is the type -- that is used as the Etype of the _parent field. --- Part_Of_Constituents (Elist9) --- Present in abstract state entities. Contains all constituents that are --- subject to indicator Part_Of (both aspect and option variants). +-- Part_Of_Constituents (Elist10) +-- Present in abstract state and variable entities. Contains all +-- constituents that are subject to indicator Part_Of (both aspect and +-- option variants). -- Partial_View_Has_Unknown_Discr (Flag280) -- Present in all types. Set to Indicate that the partial view of a type @@ -3771,16 +3774,16 @@ package Einfo is -- in the shadow entity, it points to the proper location in which to -- restore the private view saved in the shadow. +-- Protected_Body_Subprogram (Node11) +-- Defined in protected operations. References the entity for the +-- subprogram which implements the body of the operation. + -- Protected_Formal (Node22) -- Defined in formal parameters (in, in out and out parameters). Used -- only for formals of protected operations. References corresponding -- formal parameter in the unprotected version of the operation that -- is created during expansion. --- Protected_Body_Subprogram (Node11) --- Defined in protected operations. References the entity for the --- subprogram which implements the body of the operation. - -- Protection_Object (Node23) -- Applies to protected entries, entry families and subprograms. Denotes -- the entity which is used to rename the _object component of protected @@ -3898,16 +3901,9 @@ package Einfo is -- Requires_Overriding (Flag213) -- Defined in all subprograms and entries. Set for subprograms that -- require overriding as defined by RM-2005-3.9.3(6/2). Note that this --- is True only for implicitly declare subprograms; it is not set on the +-- is True only for implicitly declared subprograms; it is not set on the -- parent type's subprogram. See also Is_Abstract_Subprogram. --- Return_Present (Flag54) --- Defined in function and generic function entities. Set if the --- function contains a return statement (used for error checking). --- This flag can also be set in procedure and generic procedure --- entities (for convenience in setting it), but is only tested --- for the function case. - -- Return_Applies_To (Node8) -- Defined in E_Return_Statement. Points to the entity representing -- the construct to which the return statement applies, as defined in @@ -3915,6 +3911,13 @@ package Einfo is -- extended_return_statement applies to the extended_return_statement, -- even though it causes the whole function to return. +-- Return_Present (Flag54) +-- Defined in function and generic function entities. Set if the +-- function contains a return statement (used for error checking). +-- This flag can also be set in procedure and generic procedure +-- entities (for convenience in setting it), but is only tested +-- for the function case. + -- Returns_By_Ref (Flag90) -- Defined in function entities. Set if the function returns the result -- by reference, either because its return type is a by-reference-type @@ -3942,6 +3945,12 @@ package Einfo is -- the Bit_Order aspect must be set to the same value (either explicitly -- or as the target default value). +-- Rewritten_For_C (Flag287) +-- Defined on functions that return a constrained array type, when +-- Modify_Tree_For_C is set. Indicates that a procedure with an extra +-- out parameter has been created for it, and calls must be rewritten as +-- calls to the new procedure. + -- RM_Size (Uint13) -- Defined in all type and subtype entities. Contains the value of -- type'Size as defined in the RM. See also the Esize field and @@ -3996,7 +4005,7 @@ package Einfo is -- Indicates the number of scopes that statically enclose the declaration -- of the unit or type. Library units have a depth of zero. Note that -- record types can act as scopes but do NOT have this field set (see --- Scope_Depth above) +-- Scope_Depth above). -- Scope_Depth_Set (synthesized) -- Applies to a special predicate function that returns a Boolean value @@ -4063,35 +4072,37 @@ package Einfo is -- Small of the type, either as given in a representation clause, or -- as computed (as a power of two) by the compiler. --- SPARK_Aux_Pragma (Node33) --- Present in package spec and body entities. For a package spec entity --- it relates to the SPARK mode setting for the private part. This field --- points to the N_Pragma node that applies to the private part. This is --- either set with a local SPARK_Mode pragma in the private part or it is --- inherited from the SPARK mode that applies to the rest of the spec. --- For a package body, it similarly applies to the SPARK mode setting for --- the elaboration sequence after the BEGIN. In the case where the pragma --- is inherited, the SPARK_Aux_Pragma_Inherited flag is set in the --- package spec or body entity. +-- SPARK_Aux_Pragma (Node41) +-- Present in concurrent type, [generic] package spec and package body +-- entities. For concurrent types and package specs it refers to the +-- SPARK mode setting for the private part. This field points to the +-- N_Pragma node that either appears in the private part or is inherited +-- from the enclosing context. For package bodies, it refers to the SPARK +-- mode of the elaboration sequence after the BEGIN. The fields points to +-- the N_Pragma node that either appears in the statement sequence or is +-- inherited from the enclosing context. In all cases, if the pragma is +-- inherited, then the SPARK_Aux_Pragma_Inherited flag is set. -- SPARK_Aux_Pragma_Inherited (Flag266) --- Present in the entities of subprogram specs and bodies as well as --- in package specs and bodies. Set if the SPARK_Aux_Pragma field --- points to a pragma that is inherited, rather than a local one. - --- SPARK_Pragma (Node32) --- Present in the entities of subprogram specs and bodies as well as in --- package specs and bodies. Points to the N_Pragma node that applies to --- the spec or body. This is either set by a local SPARK_Mode pragma or --- is inherited from the context (from an outer scope for the spec case --- or from the spec for the body case). In the case where it is inherited --- the flag SPARK_Pragma_Inherited is set. Empty if no SPARK_Mode pragma --- is applicable. +-- Present in concurrent type, [generic] package spec and package body +-- entities. Set if the SPARK_Aux_Pragma field points to a pragma that is +-- inherited, rather than a local one. + +-- SPARK_Pragma (Node40) +-- Present in concurrent type, entry, operator, [generic] package, +-- package body, [generic] subprogram, subprogram body and variable +-- entities. Points to the N_Pragma node that applies to the initial +-- declaration or body. This is either set by a local SPARK_Mode pragma +-- or is inherited from the context (from an outer scope for the spec +-- case or from the spec for the body case). In the case where it is +-- inherited the flag SPARK_Pragma_Inherited is set. Empty if no +-- SPARK_Mode pragma is applicable. -- SPARK_Pragma_Inherited (Flag265) --- Present in the entities of subprogram specs and bodies as well as in --- package specs and bodies. Set if the SPARK_Pragma field points to a --- pragma that is inherited, rather than a local one. +-- Present in concurrent type, entry, operator, [generic] package, +-- package body, [generic] subprogram, subprogram body and variable +-- entities. Set if the SPARK_Pragma attribute points to a pragma that is +-- inherited, rather than a local one. -- Spec_Entity (Node19) -- Defined in package body entities. Points to corresponding package @@ -4120,6 +4131,21 @@ package Einfo is -- are fully analyzed and typed with the base type of the subtype. Note -- that all entries are static and have values within the subtype range. +-- Static_Elaboration_Desired (Flag77) +-- Defined in library-level packages. Set by the pragma of the same +-- name, to indicate that static initialization must be attempted for +-- all types declared in the package, and that a warning must be emitted +-- for those types to which static initialization is not available. + +-- Static_Initialization (Node30) +-- Defined in initialization procedures for types whose objects can be +-- initialized statically. The value of this attribute is a positional +-- aggregate whose components are compile-time static values. Used +-- when available in object declarations to eliminate the call to the +-- initialization procedure, and to minimize elaboration code. Note: +-- This attribute uses the same field as Overridden_Operation, which is +-- irrelevant in init_procs. + -- Static_Real_Or_String_Predicate (Node25) -- Defined in real types/subtypes with static predicates (with the two -- flags Has_Predicates and Has_Static_Predicate set). Set if the type @@ -4132,7 +4158,7 @@ package Einfo is -- as Predicate_Function (typ). Also, in the case where a predicate is -- inherited, the expression is of the form: -- --- expression AND THEN xxxPredicate (typ2 (ent)) +-- xxxPredicate (typ2 (ent)) AND THEN expression -- -- where typ2 is the type from which the predicate is inherited, ent is -- the entity for the current predicate function, and xxxPredicate is the @@ -4149,21 +4175,6 @@ package Einfo is -- or the declaration of a "hook" object. -- In which case is it a flag, or a hook object??? --- Static_Elaboration_Desired (Flag77) --- Defined in library-level packages. Set by the pragma of the same --- name, to indicate that static initialization must be attempted for --- all types declared in the package, and that a warning must be emitted --- for those types to which static initialization is not available. - --- Static_Initialization (Node30) --- Defined in initialization procedures for types whose objects can be --- initialized statically. The value of this attribute is a positional --- aggregate whose components are compile-time static values. Used --- when available in object declarations to eliminate the call to the --- initialization procedure, and to minimize elaboration code. Note: --- This attribute uses the same field as Overridden_Operation, which is --- irrelevant in init_procs. - -- Storage_Size_Variable (Node26) [implementation base type only] -- Defined in access types and task type entities. This flag is set -- if a valid and effective pragma Storage_Size applies to the base @@ -4516,7 +4527,7 @@ package Einfo is -- The classification of program entities which follows is a refinement of -- the list given in RM 3.1(1). E.g., separate entities denote subtypes of -- different type classes. Ada 95 entities include class wide types, --- protected types, subprogram types, generalized access types, generic +-- protected types, subprogram types, generalized access types, generic -- formal derived types and generic formal packages. -- The order chosen for these kinds allows us to classify related entities @@ -4678,8 +4689,8 @@ package Einfo is -- type (whether or not it is a general access type). E_Access_Attribute_Type, - -- An access type created for an access attribute (such as 'Access, - -- 'Unrestricted_Access and Unchecked_Access) + -- An access type created for an access attribute (one of 'Access, + -- 'Unrestricted_Access, or Unchecked_Access). E_Allocator_Type, -- A special internal type used to label allocators and references to @@ -4834,15 +4845,15 @@ package Einfo is -- A procedure, created by a procedure declaration or a procedure -- body that acts as its own declaration. - E_Entry, - -- An entry, created by an entry declaration in a task or protected - -- object. - E_Abstract_State, -- A state abstraction. Used to designate entities introduced by aspect -- or pragma Abstract_State. The entity carries the various properties -- of the state. + E_Entry, + -- An entry, created by an entry declaration in a task or protected + -- object. + -------------------- -- Other Entities -- -------------------- @@ -4908,7 +4919,7 @@ package Einfo is E_Protected_Body, -- A protected body. This entity serves almost no function, since all - -- semantic analysis uses the protected entity (E_Protected_Type) + -- semantic analysis uses the protected entity (E_Protected_Type). E_Task_Body, -- A task body. This entity serves almost no function, since all @@ -5162,8 +5173,8 @@ package Einfo is -- E_Function -- E_Operator -- E_Procedure - -- E_Entry - E_Abstract_State; + -- E_Abstract_State + E_Entry; subtype Private_Kind is Entity_Kind range E_Record_Type_With_Private .. @@ -5311,7 +5322,6 @@ package Einfo is -- Has_Qualified_Name (Flag161) -- Has_Stream_Size_Clause (Flag184) -- Has_Unknown_Discriminants (Flag72) - -- Has_Uplevel_Reference (Flag215) -- Has_Xref_Entry (Flag182) -- In_Private_Part (Flag45) -- Is_Ada_2005_Only (Flag185) @@ -5322,7 +5332,6 @@ package Einfo is -- Is_Checked_Ghost_Entity (Flag277) -- Is_Child_Unit (Flag73) -- Is_Compilation_Unit (Flag149) - -- Is_Completely_Hidden (Flag103) -- Is_Descendent_Of_Address (Flag223) -- Is_Discrim_SO_Function (Flag176) -- Is_Discriminant_Check_Function (Flag264) @@ -5392,6 +5401,7 @@ package Einfo is -- Declaration_Node (synth) -- Has_Foreign_Convention (synth) -- Is_Dynamic_Scope (synth) + -- Is_Ghost_Entity (synth) -- Is_Standard_Character_Type (synth) -- Is_Standard_String_Type (synth) -- Underlying_Type (synth) @@ -5477,7 +5487,6 @@ package Einfo is -- May_Inherit_Delayed_Rep_Aspects (Flag262) -- Must_Be_On_Byte_Boundary (Flag183) -- Must_Have_Preelab_Init (Flag208) - -- Needs_Typedef (Flag286) -- Optimize_Alignment_Space (Flag241) -- Optimize_Alignment_Time (Flag242) -- Partial_View_Has_Unknown_Discr (Flag280) @@ -5507,7 +5516,7 @@ package Einfo is -- E_Abstract_State -- Refinement_Constituents (Elist8) - -- Part_Of_Constituents (Elist9) + -- Part_Of_Constituents (Elist10) -- Body_References (Elist16) -- Non_Limited_View (Node19) -- Encapsulating_State (Node32) @@ -5518,6 +5527,7 @@ package Einfo is -- Has_Null_Refinement (synth) -- Is_External_State (synth) -- Is_Null_State (synth) + -- Is_Synchronized_State (synth) -- E_Access_Protected_Subprogram_Type -- Equivalent_Type (Node18) @@ -5529,7 +5539,6 @@ package Einfo is -- E_Access_Subprogram_Type -- Equivalent_Type (Node18) (remote types only) -- Directly_Designated_Type (Node20) - -- Interface_Name (Node21) (JGNAT usage only) -- Needs_No_Actuals (Flag22) -- Original_Access_Type (Node28) -- Can_Use_Internal_Rep (Flag229) @@ -5549,6 +5558,7 @@ package Einfo is -- Is_Pure_Unit_Access_Type (Flag189) -- No_Pool_Assigned (Flag131) (base type only) -- No_Strict_Aliasing (Flag136) (base type only) + -- Is_Param_Block_Component_Type (Flag215) (base type only) -- (plus type attributes) -- E_Access_Attribute_Type @@ -5635,7 +5645,6 @@ package Einfo is -- Prival (Node17) -- Renamed_Object (Node18) (always Empty) -- Discriminant_Checking_Func (Node20) - -- Interface_Name (Node21) (JGNAT usage only) -- Original_Record_Component (Node22) -- DT_Offset_To_Top_Func (Node25) -- Related_Type (Node27) @@ -5728,9 +5737,9 @@ package Einfo is -- Renamed_Object (Node18) (always Empty) -- Corresponding_Discriminant (Node19) -- Discriminant_Default_Value (Node20) - -- Interface_Name (Node21) (JGNAT usage only) -- Original_Record_Component (Node22) -- CR_Discriminant (Node23) + -- Is_Completely_Hidden (Flag103) -- Is_Return_Object (Flag209) -- Next_Component_Or_Discriminant (synth) -- Next_Discriminant (synth) @@ -5751,12 +5760,14 @@ package Einfo is -- PPC_Wrapper (Node25) -- Extra_Formals (Node28) -- Contract (Node34) + -- SPARK_Pragma (Node40) (protected kind) -- Needs_No_Actuals (Flag22) -- Uses_Sec_Stack (Flag95) -- Default_Expressions_Processed (Flag108) -- Entry_Accepted (Flag152) -- Sec_Stack_Needed_For_Return (Flag167) -- Has_Expanded_Contract (Flag240) + -- SPARK_Pragma_Inherited (Flag265) (protected kind) -- Address_Clause (synth) -- Entry_Index_Type (synth) -- First_Formal (synth) @@ -5859,11 +5870,13 @@ package Einfo is -- Subprograms_For_Type (Node29) -- Corresponding_Equality (Node30) (implicit /= only) -- Thunk_Entity (Node31) (thunk case only) - -- SPARK_Pragma (Node32) -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) -- Anonymous_Master (Node36) (non-generic case only) + -- Class_Wide_Preconds (List38) + -- Class_Wide_Postconds (List39) + -- SPARK_Pragma (Node40) -- Body_Needed_For_SAL (Flag40) -- Contains_Ignored_Ghost_Code (Flag279) -- Default_Expressions_Processed (Flag108) @@ -5907,6 +5920,7 @@ package Einfo is -- Return_Present (Flag54) -- Returns_By_Ref (Flag90) -- Returns_Limited_View (Flag134) (non-generic case only) + -- Rewritten_For_C (Flag287) -- Sec_Stack_Needed_For_Return (Flag167) -- SPARK_Pragma_Inherited (Flag265) -- Uses_Sec_Stack (Flag95) @@ -6030,13 +6044,15 @@ package Einfo is -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Import_Pragma (Node35) + -- SPARK_Pragma (Node40) + -- Default_Expressions_Processed (Flag108) -- Has_Invariants (Flag232) -- Has_Nested_Subprogram (Flag282) - -- Is_Machine_Code_Subprogram (Flag137) - -- Is_Pure (Flag44) -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Machine_Code_Subprogram (Flag137) -- Is_Primitive (Flag218) - -- Default_Expressions_Processed (Flag108) + -- Is_Pure (Flag44) + -- SPARK_Pragma_Inherited (Flag265) -- Aren't there more flags and fields? seems like this list should be -- more similar to the E_Function list, which is much longer ??? @@ -6078,10 +6094,10 @@ package Einfo is -- Package_Instantiation (Node26) -- Current_Use_Clause (Node27) -- Finalizer (Node28) (non-generic case only) - -- SPARK_Pragma (Node32) - -- SPARK_Aux_Pragma (Node33) -- Contract (Node34) -- Anonymous_Master (Node36) (non-generic case only) + -- SPARK_Pragma (Node40) + -- SPARK_Aux_Pragma (Node41) -- Delay_Subprogram_Descriptors (Flag50) -- Body_Needed_For_SAL (Flag40) -- Contains_Ignored_Ghost_Code (Flag279) @@ -6115,10 +6131,10 @@ package Einfo is -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) -- Finalizer (Node28) (non-generic case only) - -- SPARK_Pragma (Node32) - -- SPARK_Aux_Pragma (Node33) -- Contract (Node34) -- Anonymous_Master (Node36) + -- SPARK_Pragma (Node40) + -- SPARK_Aux_Pragma (Node41) -- Contains_Ignored_Ghost_Code (Flag279) -- Delay_Subprogram_Descriptors (Flag50) -- SPARK_Aux_Pragma_Inherited (Flag266) @@ -6166,11 +6182,13 @@ package Einfo is -- Extra_Formals (Node28) -- Static_Initialization (Node30) (init_proc only) -- Thunk_Entity (Node31) (thunk case only) - -- SPARK_Pragma (Node32) -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) -- Anonymous_Master (Node36) (non-generic case only) + -- Class_Wide_Preconds (List38) + -- Class_Wide_Postconds (List39) + -- SPARK_Pragma (Node40) -- Body_Needed_For_SAL (Flag40) -- Contains_Ignored_Ghost_Code (Flag279) -- Delay_Cleanups (Flag114) @@ -6223,6 +6241,8 @@ package Einfo is -- Number_Formals (synth) -- E_Protected_Body + -- SPARK_Pragma (Node40) + -- SPARK_Pragma_Inherited (Flag265) -- (any others??? First/Last Entity, Scope_Depth???) -- E_Protected_Object @@ -6237,14 +6257,23 @@ package Einfo is -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) -- Scope_Depth_Value (Uint22) - -- Scope_Depth (synth) -- Stored_Constraint (Elist23) - -- Has_Interrupt_Handler (synth) + -- Anonymous_Object (Node30) + -- Contract (Node34) + -- SPARK_Pragma (Node40) + -- SPARK_Aux_Pragma (Node41) -- Sec_Stack_Needed_For_Return (Flag167) ??? + -- SPARK_Aux_Pragma_Inherited (Flag266) + -- SPARK_Pragma_Inherited (Flag265) -- Uses_Lock_Free (Flag188) -- Uses_Sec_Stack (Flag95) ??? + -- First_Component (synth) + -- First_Component_Or_Discriminant (synth) -- Has_Entries (synth) + -- Has_Interrupt_Handler (synth) -- Number_Entries (synth) + -- Scope_Depth (synth) + -- (plus type attributes) -- E_Record_Type -- E_Record_Subtype @@ -6341,9 +6370,9 @@ package Einfo is -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) -- Extra_Formals (Node28) - -- SPARK_Pragma (Node32) -- Contract (Node34) -- Anonymous_Master (Node36) + -- SPARK_Pragma (Node40) -- Contains_Ignored_Ghost_Code (Flag279) -- SPARK_Pragma_Inherited (Flag265) -- Scope_Depth (synth) @@ -6359,6 +6388,9 @@ package Einfo is -- (plus type attributes) -- E_Task_Body + -- Contract (Node34) + -- SPARK_Pragma (Node40) + -- SPARK_Pragma_Inherited (Flag265) -- (any others??? First/Last Entity, Scope_Depth???) -- E_Task_Type @@ -6370,23 +6402,32 @@ package Einfo is -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) -- Scope_Depth_Value (Uint22) - -- Scope_Depth (synth) -- Stored_Constraint (Elist23) -- Task_Body_Procedure (Node25) -- Storage_Size_Variable (Node26) (base type only) -- Relative_Deadline_Variable (Node28) (base type only) + -- Anonymous_Object (Node30) + -- Contract (Node34) + -- SPARK_Pragma (Node40) + -- SPARK_Aux_Pragma (Node41) -- Delay_Cleanups (Flag114) -- Has_Master_Entity (Flag21) -- Has_Storage_Size_Clause (Flag23) (base type only) - -- Uses_Sec_Stack (Flag95) ??? -- Sec_Stack_Needed_For_Return (Flag167) ??? + -- SPARK_Aux_Pragma_Inherited (Flag266) + -- SPARK_Pragma_Inherited (Flag265) + -- Uses_Sec_Stack (Flag95) ??? + -- First_Component (synth) + -- First_Component_Or_Discriminant (synth) -- Has_Entries (synth) -- Number_Entries (synth) + -- Scope_Depth (synth) -- (plus type attributes) -- E_Variable -- Hiding_Loop_Variable (Node8) -- Current_Value (Node9) + -- Part_Of_Constituents (Elist10) -- Esize (Uint12) -- Extra_Accessibility (Node13) -- Alignment (Uint14) @@ -6410,6 +6451,7 @@ package Einfo is -- Encapsulating_State (Node32) -- Linker_Section_Pragma (Node33) -- Contract (Node34) + -- SPARK_Pragma (Node40) -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) -- Has_Biased_Representation (Flag139) @@ -6431,6 +6473,7 @@ package Einfo is -- OK_To_Rename (Flag247) -- Optimize_Alignment_Space (Flag241) -- Optimize_Alignment_Time (Flag242) + -- SPARK_Pragma_Inherited (Flag265) -- Suppress_Initialization (Flag105) -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) @@ -6461,7 +6504,7 @@ package Einfo is -- types, and a field in the type entities contains a value of the -- following type indicating which alignment choice applies. For full -- details of the meaning of these alignment types, see description - -- of the Component_Alignment pragma + -- of the Component_Alignment pragma. type Component_Alignment_Kind is ( Calign_Default, -- default alignment @@ -6485,9 +6528,9 @@ package Einfo is -- attributes are procedural, and require some small amount of -- computation. Of course, from the point of view of a user of this -- package, the distinction is not visible (even the field information - -- provided below should be disregarded, as it is subject to change - -- without notice). A number of attributes appear as lists: lists of - -- formals, lists of actuals, of discriminants, etc. For these, pairs + -- provided below should be disregarded, as it is subject to change + -- without notice). A number of attributes appear as lists: lists of + -- formals, lists of actuals, of discriminants, etc. For these, pairs -- of functions are defined, which take the form: -- function First_Thing (E : Enclosing_Construct) return Thing; @@ -6681,6 +6724,7 @@ package Einfo is function Alias (Id : E) return E; function Alignment (Id : E) return U; function Anonymous_Master (Id : E) return E; + function Anonymous_Object (Id : E) return E; function Associated_Entity (Id : E) return E; function Associated_Formal_Package (Id : E) return E; function Associated_Node_For_Itype (Id : E) return N; @@ -6695,6 +6739,8 @@ package Einfo is function Can_Never_Be_Null (Id : E) return B; function Can_Use_Internal_Rep (Id : E) return B; function Checks_May_Be_Suppressed (Id : E) return B; + function Class_Wide_Postconds (Id : E) return S; + function Class_Wide_Preconds (Id : E) return S; function Class_Wide_Type (Id : E) return E; function Cloned_Subtype (Id : E) return E; function Component_Alignment (Id : E) return C; @@ -6868,7 +6914,6 @@ package Einfo is function Has_Thunks (Id : E) return B; function Has_Unchecked_Union (Id : E) return B; function Has_Unknown_Discriminants (Id : E) return B; - function Has_Uplevel_Reference (Id : E) return B; function Has_Visible_Refinement (Id : E) return B; function Has_Volatile_Components (Id : E) return B; function Has_Xref_Entry (Id : E) return B; @@ -6953,6 +6998,7 @@ package Einfo is function Is_Packed (Id : E) return B; function Is_Packed_Array_Impl_Type (Id : E) return B; function Is_Potentially_Use_Visible (Id : E) return B; + function Is_Param_Block_Component_Type (Id : E) return B; function Is_Predicate_Function (Id : E) return B; function Is_Predicate_Function_M (Id : E) return B; function Is_Preelaborated (Id : E) return B; @@ -7012,7 +7058,6 @@ package Einfo is function Must_Have_Preelab_Init (Id : E) return B; function Needs_Debug_Info (Id : E) return B; function Needs_No_Actuals (Id : E) return B; - function Needs_Typedef (Id : E) return B; function Never_Set_In_Source (Id : E) return B; function Next_Inlined_Subprogram (Id : E) return E; function No_Dynamic_Predicate_On_Actual (Id : E) return B; @@ -7073,6 +7118,7 @@ package Einfo is function Returns_Limited_View (Id : E) return B; function Reverse_Bit_Order (Id : E) return B; function Reverse_Storage_Order (Id : E) return B; + function Rewritten_For_C (Id : E) return B; function RM_Size (Id : E) return U; function Scalar_Range (Id : E) return N; function Scale_Value (Id : E) return U; @@ -7133,7 +7179,8 @@ package Einfo is -- whether an Ekind value belongs to a specified kind, for example the -- function Is_Elementary_Type tests if its argument is in Elementary_Kind. -- In some cases, the test is of an entity attribute (e.g. in the case of - -- Is_Generic_Type where the Ekind does not provide the needed information) + -- Is_Generic_Type where the Ekind does not provide the needed + -- information). function Is_Access_Type (Id : E) return B; function Is_Access_Protected_Subprogram_Type (Id : E) return B; @@ -7160,9 +7207,10 @@ package Einfo is function Is_Formal_Subprogram (Id : E) return B; function Is_Generic_Actual_Subprogram (Id : E) return B; function Is_Generic_Actual_Type (Id : E) return B; - function Is_Generic_Unit (Id : E) return B; - function Is_Generic_Type (Id : E) return B; function Is_Generic_Subprogram (Id : E) return B; + function Is_Generic_Type (Id : E) return B; + function Is_Generic_Unit (Id : E) return B; + function Is_Ghost_Entity (Id : E) return B; function Is_Incomplete_Or_Private_Type (Id : E) return B; function Is_Incomplete_Type (Id : E) return B; function Is_Integer_Type (Id : E) return B; @@ -7228,6 +7276,7 @@ package Einfo is function Is_Standard_String_Type (Id : E) return B; function Is_String_Type (Id : E) return B; function Is_Synchronized_Interface (Id : E) return B; + function Is_Synchronized_State (Id : E) return B; function Is_Task_Interface (Id : E) return B; function Is_Task_Record_Type (Id : E) return B; function Is_Wrapper_Package (Id : E) return B; @@ -7339,6 +7388,7 @@ package Einfo is procedure Set_Alias (Id : E; V : E); procedure Set_Alignment (Id : E; V : U); procedure Set_Anonymous_Master (Id : E; V : E); + procedure Set_Anonymous_Object (Id : E; V : E); procedure Set_Associated_Entity (Id : E; V : E); procedure Set_Associated_Formal_Package (Id : E; V : E); procedure Set_Associated_Node_For_Itype (Id : E; V : N); @@ -7353,6 +7403,8 @@ package Einfo is procedure Set_Can_Never_Be_Null (Id : E; V : B := True); procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True); procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True); + procedure Set_Class_Wide_Postconds (Id : E; V : S); + procedure Set_Class_Wide_Preconds (Id : E; V : S); procedure Set_Class_Wide_Type (Id : E; V : E); procedure Set_Cloned_Subtype (Id : E; V : E); procedure Set_Component_Alignment (Id : E; V : C); @@ -7524,7 +7576,6 @@ package Einfo is procedure Set_Has_Thunks (Id : E; V : B := True); procedure Set_Has_Unchecked_Union (Id : E; V : B := True); procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True); - procedure Set_Has_Uplevel_Reference (Id : E; V : B := True); procedure Set_Has_Visible_Refinement (Id : E; V : B := True); procedure Set_Has_Volatile_Components (Id : E; V : B := True); procedure Set_Has_Xref_Entry (Id : E; V : B := True); @@ -7613,6 +7664,7 @@ package Einfo is procedure Set_Is_Package_Body_Entity (Id : E; V : B := True); procedure Set_Is_Packed (Id : E; V : B := True); procedure Set_Is_Packed_Array_Impl_Type (Id : E; V : B := True); + procedure Set_Is_Param_Block_Component_Type (Id : E; V : B := True); procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True); procedure Set_Is_Predicate_Function (Id : E; V : B := True); procedure Set_Is_Predicate_Function_M (Id : E; V : B := True); @@ -7673,7 +7725,6 @@ package Einfo is procedure Set_Must_Have_Preelab_Init (Id : E; V : B := True); procedure Set_Needs_Debug_Info (Id : E; V : B := True); procedure Set_Needs_No_Actuals (Id : E; V : B := True); - procedure Set_Needs_Typedef (Id : E; V : B := True); procedure Set_Never_Set_In_Source (Id : E; V : B := True); procedure Set_Next_Inlined_Subprogram (Id : E; V : E); procedure Set_No_Dynamic_Predicate_On_Actual (Id : E; V : B := True); @@ -7734,6 +7785,7 @@ package Einfo is procedure Set_Returns_Limited_View (Id : E; V : B := True); procedure Set_Reverse_Bit_Order (Id : E; V : B := True); procedure Set_Reverse_Storage_Order (Id : E; V : B := True); + procedure Set_Rewritten_For_C (Id : E; V : B := True); procedure Set_RM_Size (Id : E; V : U); procedure Set_Scalar_Range (Id : E; V : N); procedure Set_Scale_Value (Id : E; V : U); @@ -8053,7 +8105,7 @@ package Einfo is procedure Write_Entity_Flags (Id : Entity_Id; Prefix : String); -- Writes a series of entries giving a line for each flag that is - -- set to True. Each line is prefixed by the given string + -- set to True. Each line is prefixed by the given string. procedure Write_Entity_Info (Id : Entity_Id; Prefix : String); -- A debugging procedure to write out information about an entity @@ -8116,6 +8168,7 @@ package Einfo is pragma Inline (Alias); pragma Inline (Alignment); pragma Inline (Anonymous_Master); + pragma Inline (Anonymous_Object); pragma Inline (Associated_Entity); pragma Inline (Associated_Formal_Package); pragma Inline (Associated_Node_For_Itype); @@ -8130,6 +8183,8 @@ package Einfo is pragma Inline (Can_Never_Be_Null); pragma Inline (Can_Use_Internal_Rep); pragma Inline (Checks_May_Be_Suppressed); + pragma Inline (Class_Wide_Preconds); + pragma Inline (Class_Wide_Postconds); pragma Inline (Class_Wide_Type); pragma Inline (Cloned_Subtype); pragma Inline (Component_Bit_Offset); @@ -8299,7 +8354,6 @@ package Einfo is pragma Inline (Has_Thunks); pragma Inline (Has_Unchecked_Union); pragma Inline (Has_Unknown_Discriminants); - pragma Inline (Has_Uplevel_Reference); pragma Inline (Has_Visible_Refinement); pragma Inline (Has_Volatile_Components); pragma Inline (Has_Xref_Entry); @@ -8379,6 +8433,7 @@ package Einfo is pragma Inline (Is_Generic_Subprogram); pragma Inline (Is_Generic_Type); pragma Inline (Is_Generic_Unit); + pragma Inline (Is_Ghost_Entity); pragma Inline (Is_Hidden); pragma Inline (Is_Hidden_Non_Overridden_Subpgm); pragma Inline (Is_Hidden_Open_Scope); @@ -8420,6 +8475,7 @@ package Einfo is pragma Inline (Is_Package_Body_Entity); pragma Inline (Is_Packed); pragma Inline (Is_Packed_Array_Impl_Type); + pragma Inline (Is_Param_Block_Component_Type); pragma Inline (Is_Potentially_Use_Visible); pragma Inline (Is_Predicate_Function); pragma Inline (Is_Predicate_Function_M); @@ -8488,7 +8544,6 @@ package Einfo is pragma Inline (Must_Have_Preelab_Init); pragma Inline (Needs_Debug_Info); pragma Inline (Needs_No_Actuals); - pragma Inline (Needs_Typedef); pragma Inline (Never_Set_In_Source); pragma Inline (Next_Index); pragma Inline (Next_Inlined_Subprogram); @@ -8552,6 +8607,7 @@ package Einfo is pragma Inline (Returns_Limited_View); pragma Inline (Reverse_Bit_Order); pragma Inline (Reverse_Storage_Order); + pragma Inline (Rewritten_For_C); pragma Inline (RM_Size); pragma Inline (Scalar_Range); pragma Inline (Scale_Value); @@ -8620,6 +8676,7 @@ package Einfo is pragma Inline (Set_Alias); pragma Inline (Set_Alignment); pragma Inline (Set_Anonymous_Master); + pragma Inline (Set_Anonymous_Object); pragma Inline (Set_Associated_Entity); pragma Inline (Set_Associated_Formal_Package); pragma Inline (Set_Associated_Node_For_Itype); @@ -8634,6 +8691,8 @@ package Einfo is pragma Inline (Set_Can_Never_Be_Null); pragma Inline (Set_Can_Use_Internal_Rep); pragma Inline (Set_Checks_May_Be_Suppressed); + pragma Inline (Set_Class_Wide_Postconds); + pragma Inline (Set_Class_Wide_Preconds); pragma Inline (Set_Class_Wide_Type); pragma Inline (Set_Cloned_Subtype); pragma Inline (Set_Component_Bit_Offset); @@ -8888,6 +8947,7 @@ package Einfo is pragma Inline (Set_Is_Package_Body_Entity); pragma Inline (Set_Is_Packed); pragma Inline (Set_Is_Packed_Array_Impl_Type); + pragma Inline (Set_Is_Param_Block_Component_Type); pragma Inline (Set_Is_Potentially_Use_Visible); pragma Inline (Set_Is_Predicate_Function); pragma Inline (Set_Is_Predicate_Function_M); @@ -8948,7 +9008,6 @@ package Einfo is pragma Inline (Set_Must_Have_Preelab_Init); pragma Inline (Set_Needs_Debug_Info); pragma Inline (Set_Needs_No_Actuals); - pragma Inline (Set_Needs_Typedef); pragma Inline (Set_Never_Set_In_Source); pragma Inline (Set_Next_Inlined_Subprogram); pragma Inline (Set_No_Dynamic_Predicate_On_Actual); @@ -9009,6 +9068,7 @@ package Einfo is pragma Inline (Set_Returns_Limited_View); pragma Inline (Set_Reverse_Bit_Order); pragma Inline (Set_Reverse_Storage_Order); + pragma Inline (Set_Rewritten_For_C); pragma Inline (Set_RM_Size); pragma Inline (Set_Scalar_Range); pragma Inline (Set_Scale_Value); diff --git a/gcc/ada/env.c b/gcc/ada/env.c index 1bf9ef06076..84698766797 100644 --- a/gcc/ada/env.c +++ b/gcc/ada/env.c @@ -50,7 +50,7 @@ #include <stdlib.h> #endif -#if defined (__APPLE__) && !defined (__arm__) +#if defined (__APPLE__) && !(defined (__arm__) || defined (__arm64__)) /* On Darwin, _NSGetEnviron must be used for shared libraries; but it is not available on iOS. */ #include <crt_externs.h> @@ -211,7 +211,7 @@ __gnat_environ (void) #elif defined (__sun__) extern char **_environ; return _environ; -#elif defined (__APPLE__) && !defined (__arm__) +#elif defined (__APPLE__) && !(defined (__arm__) || defined (__arm64__)) return *_NSGetEnviron (); #elif ! (defined (__vxworks)) extern char **environ; diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads index c9beb0ccc30..0c2fb6f7c92 100644 --- a/gcc/ada/err_vars.ads +++ b/gcc/ada/err_vars.ads @@ -54,7 +54,7 @@ package Err_Vars is -- variables are not reset by calls to the error message routines, so the -- caller is responsible for resetting the default behavior after use. - Error_Msg_Qual_Level : Int := 0; + Error_Msg_Qual_Level : Nat := 0; -- Number of levels of qualification required for type name (see the -- description of the } insertion character. Note that this value does -- not get reset by any Error_Msg call, so the caller is responsible diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 35e5a97fd36..4540c9380ae 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -111,9 +111,6 @@ package Errout is -- This normal suppression action may be overridden in cases 2-5 (but not -- in case 1 or 7 by setting All_Errors mode, or by setting the special -- unconditional message insertion character (!) as described below. - -- This normal suppression action may be overridden in cases 2-5 (but - -- not in case 1) by setting All_Errors mode, or by setting the special - -- unconditional message insertion character (!) as described below. --------------------------------------------------------- -- Error Message Text and Message Insertion Characters -- @@ -477,7 +474,7 @@ package Errout is Error_Msg_Node_2 : Node_Id renames Err_Vars.Error_Msg_Node_2; -- Node_Id values for & insertion characters in message - Error_Msg_Qual_Level : Int renames Err_Vars.Error_Msg_Qual_Level; + Error_Msg_Qual_Level : Nat renames Err_Vars.Error_Msg_Qual_Level; -- Number of levels of qualification required for type name (see the -- description of the } insertion character). Note that this value does -- not get reset by any Error_Msg call, so the caller is responsible diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb index 7217048c54e..5b56ddd5ea2 100644 --- a/gcc/ada/eval_fat.adb +++ b/gcc/ada/eval_fat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 6cdd290bd9e..dbc0d7afdf3 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -88,6 +88,9 @@ package body Exp_Aggr is -- N is an aggregate (record or array). Checks the presence of default -- initialization (<>) in any component (Ada 2005: AI-287). + function In_Object_Declaration (N : Node_Id) return Boolean; + -- Return True if N is part of an object declaration, False otherwise + function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean; -- Returns true if N is an aggregate used to initialize the components -- of a statically allocated dispatch table. @@ -536,8 +539,6 @@ package body Exp_Aggr is -- 10. No controlled actions need to be generated for components - -- 11. For a VM back end, the array should have no aliased components - function Backend_Processing_Possible (N : Node_Id) return Boolean is Typ : constant Entity_Id := Etype (N); -- Typ is the correct constrained array subtype of the aggregate @@ -650,7 +651,8 @@ package body Exp_Aggr is -- component associations that actually need tag adjustment, similar -- to the test in Component_Not_OK_For_Backend for record aggregates -- with tagged components, but not clear whether it's worthwhile ???; - -- in the case of the JVM, object tags are handled implicitly) + -- in the case of virtual machines (no Tagged_Type_Expansion), object + -- tags are handled implicitly). if Is_Tagged_Type (Component_Type (Typ)) and then Tagged_Type_Expansion @@ -664,16 +666,6 @@ package body Exp_Aggr is return False; end if; - -- Checks 11: Array aggregates with aliased components are currently - -- not well supported by the VM backend; disable temporarily this - -- backend processing until it is definitely supported. - - if VM_Target /= No_VM - and then Has_Aliased_Components (Base_Type (Typ)) - then - return False; - end if; - -- Backend processing is possible Set_Size_Known_At_Compile_Time (Etype (N), True); @@ -2485,7 +2477,7 @@ package body Exp_Aggr is then Ancestor_Is_Expression := True; - -- Set up finalization data for enclosing record, because + -- Set up finalization data for enclosing record, because -- controlled subcomponents of the ancestor part will be -- attached to it. @@ -2534,8 +2526,8 @@ package body Exp_Aggr is Set_No_Ctrl_Actions (First (Assign)); -- Assign the tag now to make sure that the dispatching call in - -- the subsequent deep_adjust works properly (unless VM_Target, - -- where tags are implicit). + -- the subsequent deep_adjust works properly (unless + -- Tagged_Type_Expansion where tags are implicit). if Tagged_Type_Expansion then Instr := @@ -2932,13 +2924,33 @@ package body Exp_Aggr is end if; end if; - Instr := - Make_OK_Assignment_Statement (Loc, - Name => Comp_Expr, - Expression => Expr_Q); + if Generate_C_Code + and then Nkind (Expr_Q) = N_Aggregate + and then Is_Array_Type (Etype (Expr_Q)) + and then Present (First_Index (Etype (Expr_Q))) + then + declare + Expr_Q_Type : constant Node_Id := Etype (Expr_Q); + begin + Append_List_To (L, + Build_Array_Aggr_Code + (N => Expr_Q, + Ctype => Component_Type (Expr_Q_Type), + Index => First_Index (Expr_Q_Type), + Into => Comp_Expr, + Scalar_Comp => Is_Scalar_Type + (Component_Type (Expr_Q_Type)))); + end; + + else + Instr := + Make_OK_Assignment_Statement (Loc, + Name => Comp_Expr, + Expression => Expr_Q); - Set_No_Ctrl_Actions (Instr); - Append_To (L, Instr); + Set_No_Ctrl_Actions (Instr); + Append_To (L, Instr); + end if; -- Adjust the tag if tagged (because of possible view -- conversions), unless compiling for a VM where tags are @@ -3567,7 +3579,7 @@ package body Exp_Aggr is end if; if Nkind (N) = N_Aggregate - and then Present (Component_Associations (N)) + and then Present (Component_Associations (N)) then Expr := First (Component_Associations (N)); while Present (Expr) loop @@ -3666,12 +3678,6 @@ package body Exp_Aggr is -- present we can proceed since the bounds can be obtained from the -- aggregate. - -- Note: This case is required in VM platforms since their backends - -- normalize array indexes in the range 0 .. N-1. Hence, if we do - -- not flat an array whose bounds cannot be obtained from the type - -- of the index the backend has no way to properly generate the code. - -- See ACATS c460010 for an example. - if Hiv < Lov or else (not Compile_Time_Known_Value (Blo) and then Others_Present) then @@ -3914,6 +3920,14 @@ package body Exp_Aggr is -- Start of processing for Convert_To_Positional begin + -- Only convert to positional when generating C in case of an + -- object declaration, this is the only case where aggregates are + -- supported in C. + + if Modify_Tree_For_C and then not In_Object_Declaration (N) then + return; + end if; + -- Ada 2005 (AI-287): Do not convert in case of default initialized -- components because in this case will need to call the corresponding -- IP procedure. @@ -3942,7 +3956,7 @@ package body Exp_Aggr is -- If the size is known, or all the components are static, try to -- build a fully positional aggregate. - -- The size of the type may not be known for an aggregate with + -- The size of the type may not be known for an aggregate with -- discriminated array components, but if the components are static -- it is still possible to verify statically that the length is -- compatible with the upper bound of the type, and therefore it is @@ -3986,7 +4000,7 @@ package body Exp_Aggr is else Error_Msg_N - ("non-static object requires elaboration code??", N); + ("non-static object requires elaboration code??", N); exit; end if; @@ -5475,9 +5489,9 @@ package body Exp_Aggr is -- then we could go into an infinite recursion. if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK) - and then VM_Target = No_VM and then not AAMP_On_Target - and then not Generate_SCIL + and then not CodePeer_Mode + and then not Generate_C_Code and then not Possible_Bit_Aligned_Component (Target) and then not Is_Possibly_Unaligned_Slice (Target) and then Aggr_Assignment_OK_For_Backend (N) @@ -5851,7 +5865,8 @@ package body Exp_Aggr is -- These are cases where the source expression may have a tag that -- could differ from the component tag (e.g., can occur for type -- conversions and formal parameters). (Tag adjustment not needed - -- if VM_Target because object tags are implicit in the machine.) + -- if Tagged_Type_Expansion because object tags are implicit in + -- the machine.) if Is_Tagged_Type (Etype (Expr_Q)) and then (Nkind (Expr_Q) = N_Type_Conversion @@ -6055,6 +6070,12 @@ package body Exp_Aggr is elsif Type_May_Have_Bit_Aligned_Components (Typ) then Convert_To_Assignments (N, Typ); + -- When generating C, only generate an aggregate when declaring objects + -- since C does not support aggregates in e.g. assignment statements. + + elsif Modify_Tree_For_C and then not In_Object_Declaration (N) then + Convert_To_Assignments (N, Typ); + -- In all other cases, build a proper aggregate to be handled by gigi else @@ -6425,6 +6446,24 @@ package body Exp_Aggr is end if; end Is_Delayed_Aggregate; + --------------------------- + -- In_Object_Declaration -- + --------------------------- + + function In_Object_Declaration (N : Node_Id) return Boolean is + P : Node_Id := Parent (N); + begin + while Present (P) loop + if Nkind (P) = N_Object_Declaration then + return True; + end if; + + P := Parent (P); + end loop; + + return False; + end In_Object_Declaration; + ---------------------------------------- -- Is_Static_Dispatch_Table_Aggregate -- ---------------------------------------- @@ -6482,10 +6521,7 @@ package body Exp_Aggr is Aggr_Code : List_Id; begin - if Is_Record_Type (Etype (N)) then - Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target); - - else pragma Assert (Is_Array_Type (Etype (N))); + if Is_Array_Type (Etype (N)) then Aggr_Code := Build_Array_Aggr_Code (N => N, @@ -6494,6 +6530,11 @@ package body Exp_Aggr is Into => Target, Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)), Indexes => No_List); + + -- Directly or indirectly (e.g. access protected procedure) a record + + else + Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target); end if; -- Save the last assignment statement associated with the aggregate diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index c985a426817..cb64c39230e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1012,13 +1012,15 @@ package body Exp_Attr is Loop_Stmt := Label_Construct (Parent (Loop_Id)); -- Climb the parent chain to find the nearest enclosing loop. Skip all - -- internally generated loops for quantified expressions. + -- internally generated loops for quantified expressions and for + -- element iterators over multidimensional arrays: pragma applies to + -- source loop. else Loop_Stmt := N; while Present (Loop_Stmt) loop if Nkind (Loop_Stmt) = N_Loop_Statement - and then Present (Identifier (Loop_Stmt)) + and then Comes_From_Source (Loop_Stmt) then exit; end if; @@ -1456,57 +1458,39 @@ package body Exp_Attr is Duplicate_Subexpr_No_Checks (Left), Duplicate_Subexpr_No_Checks (Right)))); - -- Otherwise we generate declarations to capture the values. We - -- can't put these declarations inside the if expression, since - -- we could end up with an N_Expression_With_Actions which has - -- declarations in the actions, forbidden for Modify_Tree_For_C. + -- Otherwise we generate declarations to capture the values. -- The translation is - -- T1 : styp; -- inserted high up in tree - -- T2 : styp; -- inserted high up in tree - -- do - -- T1 := styp!(Left); - -- T2 := styp!(Right); + -- T1 : constant typ := Left; + -- T2 : constant typ := Right; -- in - -- (if T1 >=|<= T2 then typ!(T1) else typ!(T2)) + -- (if T1 >=|<= T2 then T1 else T2) -- end; - -- We insert the T1,T2 declarations with Insert_Declaration which - -- inserts these declarations high up in the tree unconditionally. - -- This is safe since no code is associated with the declarations. - -- Here styp is a standard type whose Esize matches the size of - -- our type. We do this because the actual type may be a result of - -- some local declaration which would not be visible at the point - -- where we insert the declarations of T1 and T2. - else declare - T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left); - T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Left); - Styp : constant Entity_Id := Matching_Standard_Type (Typ); + T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left); + T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Right); begin - Insert_Declaration (N, - Make_Object_Declaration (Loc, - Defining_Identifier => T1, - Object_Definition => New_Occurrence_Of (Styp, Loc))); - - Insert_Declaration (N, - Make_Object_Declaration (Loc, - Defining_Identifier => T2, - Object_Definition => New_Occurrence_Of (Styp, Loc))); - Rewrite (N, Make_Expression_With_Actions (Loc, - Actions => New_List ( - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (T1, Loc), - Expression => Unchecked_Convert_To (Styp, Left)), - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (T2, Loc), - Expression => Unchecked_Convert_To (Styp, Right))), + Actions => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => T1, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Etype (Left), Loc), + Expression => Relocate_Node (Left)), + + Make_Object_Declaration (Loc, + Defining_Identifier => T2, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Etype (Right), Loc), + Expression => Relocate_Node (Right))), Expression => Make_If_Expression (Loc, @@ -1514,10 +1498,8 @@ package body Exp_Attr is Make_Compare (New_Occurrence_Of (T1, Loc), New_Occurrence_Of (T2, Loc)), - Unchecked_Convert_To (Typ, - New_Occurrence_Of (T1, Loc)), - Unchecked_Convert_To (Typ, - New_Occurrence_Of (T2, Loc)))))); + New_Occurrence_Of (T1, Loc), + New_Occurrence_Of (T2, Loc))))); end; end if; @@ -2223,14 +2205,7 @@ package body Exp_Attr is Prefix => Pref, Attribute_Name => Name_Tag); - if VM_Target = No_VM then - New_Node := Build_Get_Alignment (Loc, New_Node); - else - New_Node := - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Get_Alignment), Loc), - Parameter_Associations => New_List (New_Node)); - end if; + New_Node := Build_Get_Alignment (Loc, New_Node); -- Case where the context is a specific integer type with which -- the original attribute was compatible. The function has a @@ -2901,17 +2876,8 @@ package body Exp_Attr is begin if Nkind (Nod) = N_Selected_Component then Make_Elab_String (Prefix (Nod)); - - case VM_Target is - when JVM_Target => - Store_String_Char ('$'); - when CLI_Target => - Store_String_Char ('.'); - when No_VM => - Store_String_Char ('_'); - Store_String_Char ('_'); - end case; - + Store_String_Char ('_'); + Store_String_Char ('_'); Get_Name_String (Chars (Selector_Name (Nod))); else @@ -2930,14 +2896,8 @@ package body Exp_Attr is Start_String; Make_Elab_String (Pref); - - if VM_Target = No_VM then - Store_String_Chars ("___elab"); - Lang := Make_Identifier (Loc, Name_C); - else - Store_String_Chars ("._elab"); - Lang := Make_Identifier (Loc, Name_Ada); - end if; + Store_String_Chars ("___elab"); + Lang := Make_Identifier (Loc, Name_C); if Id = Attribute_Elab_Body then Store_String_Char ('b'); @@ -3035,13 +2995,14 @@ package body Exp_Attr is Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref)))); -- If this is a renaming of a literal, recover the representation - -- of the original. + -- of the original. If it renames an expression there is nothing + -- to fold. elsif Ekind (Entity (Pref)) = E_Constant and then Present (Renamed_Object (Entity (Pref))) - and then - Ekind (Entity (Renamed_Object (Entity (Pref)))) - = E_Enumeration_Literal + and then Is_Entity_Name (Renamed_Object (Entity (Pref))) + and then Ekind (Entity (Renamed_Object (Entity (Pref)))) = + E_Enumeration_Literal then Rewrite (N, Make_Integer_Literal (Loc, @@ -4189,11 +4150,7 @@ package body Exp_Attr is -- are not part of the actual type. Transform the attribute reference -- into a runtime expression to add the size of the hidden header. - -- Do not perform this expansion on .NET/JVM targets because the - -- two pointers are already present in the type. - - if VM_Target = No_VM - and then Needs_Finalization (Ptyp) + if Needs_Finalization (Ptyp) and then not Header_Size_Added (Attr) then Set_Header_Size_Added (Attr); @@ -5031,8 +4988,8 @@ package body Exp_Attr is -- both cases the type of the first formal of their expanded -- subprogram is Address) - if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) - = RTE (RE_Address) + if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) = + RTE (RE_Address) then declare New_Itype : Entity_Id; @@ -5809,7 +5766,7 @@ package body Exp_Attr is -- c) If the prefix is a task type, the size is obtained from the -- size variable created for each task type - -- d) If no storage_size was specified for the type , there is no + -- d) If no Storage_Size was specified for the type, there is no -- size variable, and the value is a system-specific default. else @@ -5850,7 +5807,7 @@ package body Exp_Attr is elsif Present (Storage_Size_Variable (Ptyp)) then - -- Static storage size pragma given for type: retrieve value + -- Static Storage_Size pragma given for type: retrieve value -- from its allocated storage variable. Rewrite (N, @@ -6176,49 +6133,6 @@ package body Exp_Attr is Expand_Fpt_Attribute_R (N); end if; - ----------------- - -- UET_Address -- - ----------------- - - when Attribute_UET_Address => UET_Address : declare - Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); - - begin - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Ent, - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc))); - - -- Construct name __gnat_xxx__SDP, where xxx is the unit name - -- in normal external form. - - Get_External_Unit_Name_String (Get_Unit_Name (Pref)); - Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); - Name_Len := Name_Len + 7; - Name_Buffer (1 .. 7) := "__gnat_"; - Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP"; - Name_Len := Name_Len + 5; - - Set_Is_Imported (Ent); - Set_Interface_Name (Ent, - Make_String_Literal (Loc, - Strval => String_From_Name_Buffer)); - - -- Set entity as internal to ensure proper Sprint output of its - -- implicit importation. - - Set_Is_Internal (Ent); - - Rewrite (N, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ent, Loc), - Attribute_Name => Name_Address)); - - Analyze_And_Resolve (N, Typ); - end UET_Address; - ------------ -- Update -- ------------ @@ -7554,9 +7468,6 @@ package body Exp_Attr is -- that appear in GNAT's library, but will generate calls via rtsfind -- to library routines for user code. - -- ??? For now, disable this code for JVM, since this generates a - -- VerifyError exception at run time on e.g. c330001. - -- This is disabled for AAMP, to avoid creating dependences on files not -- supported in the AAMP library (such as s-fileio.adb). @@ -7567,8 +7478,7 @@ package body Exp_Attr is -- instead. That is why we include the test Is_Available when dealing -- with these cases. - if VM_Target /= JVM_Target - and then not AAMP_On_Target + if not AAMP_On_Target and then not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) then @@ -8044,8 +7954,7 @@ package body Exp_Attr is function Is_GCC_Target return Boolean is begin - return VM_Target = No_VM and then not CodePeer_Mode - and then not AAMP_On_Target; + return not CodePeer_Mode and then not AAMP_On_Target; end Is_GCC_Target; -- Start of processing for Exp_Attr diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 47c373081b3..814dfdd80fd 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -31,7 +31,6 @@ with Errout; use Errout; with Exp_Ch7; use Exp_Ch7; with Exp_Intr; use Exp_Intr; with Exp_Util; use Exp_Util; -with Ghost; use Ghost; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -100,7 +99,7 @@ package body Exp_Ch11 is -- and the code generator (e.g. gigi) must still handle proper generation -- of cleanup calls for the non-exceptional case. - procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is + procedure Expand_At_End_Handler (HSS : Node_Id; Blk_Id : Entity_Id) is Clean : constant Entity_Id := Entity (At_End_Proc (HSS)); Ohandle : Node_Id; Stmnts : List_Id; @@ -139,8 +138,8 @@ package body Exp_Ch11 is return; end if; - if Present (Block) then - Push_Scope (Block); + if Present (Blk_Id) then + Push_Scope (Blk_Id); end if; Ohandle := @@ -176,7 +175,7 @@ package body Exp_Ch11 is Analyze_List (Stmnts, Suppress => All_Checks); Expand_Exception_Handlers (HSS); - if Present (Block) then + if Present (Blk_Id) then Pop_Scope; end if; end Expand_At_End_Handler; @@ -1095,33 +1094,14 @@ package body Exp_Ch11 is end; end if; - -- The processing at this point is rather different for the JVM - -- case, so we completely separate the processing. + -- For the normal case, we have to worry about the state of + -- abort deferral. Generally, we defer abort during runtime + -- handling of exceptions. When control is passed to the + -- handler, then in the normal case we undefer aborts. In + -- any case this entire handling is relevant only if aborts + -- are allowed. - -- For the VM case, we unconditionally call Update_Exception, - -- passing a call to the intrinsic Current_Target_Exception - -- (see JVM/.NET versions of Ada.Exceptions for details). - - if VM_Target /= No_VM then - declare - Arg : constant Node_Id := - Make_Function_Call (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Current_Target_Exception), Loc)); - begin - Prepend_Call_To_Handler - (RE_Update_Exception, New_List (Arg)); - end; - - -- For the normal case, we have to worry about the state of - -- abort deferral. Generally, we defer abort during runtime - -- handling of exceptions. When control is passed to the - -- handler, then in the normal case we undefer aborts. In - -- any case this entire handling is relevant only if aborts - -- are allowed. - - elsif Abort_Allowed + if Abort_Allowed and then Exception_Mechanism /= Back_End_Exceptions then -- There are some special cases in which we do not do the @@ -1190,9 +1170,8 @@ package body Exp_Ch11 is -- end if; procedure Expand_N_Exception_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - Id : constant Entity_Id := Defining_Identifier (N); - Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Identifier (N); + Loc : constant Source_Ptr := Sloc (N); Ex_Id : Entity_Id; Flag_Id : Entity_Id; L : List_Id; @@ -1271,20 +1250,6 @@ package body Exp_Ch11 is -- Start of processing for Expand_N_Exception_Declaration begin - -- There is no expansion needed when compiling for the JVM since the - -- JVM has a built-in exception mechanism. See cil/gnatlib/a-except.ads - -- for details. - - if VM_Target /= No_VM then - return; - end if; - - -- The exception declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - -- Definition of the external name: nam : constant String := "A.B.NAME"; Ex_Id := @@ -1323,10 +1288,18 @@ package body Exp_Ch11 is -- Full_Name component: Standard.A_Char!(Nam'Address) - Append_To (L, Unchecked_Convert_To (Standard_A_Char, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ex_Id, Loc), - Attribute_Name => Name_Address))); + -- The unchecked conversion causes capacity issues for CodePeer in some + -- cases and is never useful, so we set the Full_Name component to null + -- instead for CodePeer. + + if CodePeer_Mode then + Append_To (L, Make_Null (Loc)); + else + Append_To (L, Unchecked_Convert_To (Standard_A_Char, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ex_Id, Loc), + Attribute_Name => Name_Address))); + end if; -- HTable_Ptr component: null @@ -1391,11 +1364,6 @@ package body Exp_Ch11 is Insert_List_After_And_Analyze (N, L); end if; end if; - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Expand_N_Exception_Declaration; --------------------------------------------- @@ -1739,13 +1707,12 @@ package body Exp_Ch11 is else -- Bypass expansion to a run-time call when back-end exception - -- handling is active, unless the target is a VM, CodePeer or - -- GNATprove. In CodePeer, raising an exception is treated as an - -- error, while in GNATprove all code with exceptions falls outside - -- the subset of code which can be formally analyzed. + -- handling is active, unless the target is CodePeer or GNATprove. + -- In CodePeer, raising an exception is treated as an error, while in + -- GNATprove all code with exceptions falls outside the subset of + -- code which can be formally analyzed. - if VM_Target = No_VM - and then not CodePeer_Mode + if not CodePeer_Mode and then Exception_Mechanism = Back_End_Exceptions then return; diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads index ab93d5d5bc6..cdd53de626e 100644 --- a/gcc/ada/exp_ch11.ads +++ b/gcc/ada/exp_ch11.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -40,12 +40,11 @@ package Exp_Ch11 is -- See runtime routine Ada.Exceptions for full details on the format and -- content of these tables. - procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id); - -- Given a handled statement sequence, HSS, for which the At_End_Proc - -- field is set, and which currently has no exception handlers, this - -- procedure expands the special exception handler required. - -- This procedure also create a new scope for the given Block, if - -- Block is not Empty. + procedure Expand_At_End_Handler (HSS : Node_Id; Blk_Id : Entity_Id); + -- Given handled statement sequence HSS for which the At_End_Proc field + -- is set, and which currently has no exception handlers, this procedure + -- expands the special exception handler required. This procedure also + -- create a new scope for the given block, if Blk_Id is not Empty. procedure Expand_Exception_Handlers (HSS : Node_Id); -- This procedure expands exception handlers, and is called as part diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 65fa3238a49..11e75f37b8b 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -32,6 +32,7 @@ with Exp_Imgv; use Exp_Imgv; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; +with Ghost; use Ghost; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -47,7 +48,6 @@ with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Validsw; use Validsw; @@ -291,12 +291,6 @@ package body Exp_Ch13 is if Restriction_Active (No_Finalization) then return; - - -- Do not create a specialized Deallocate since .NET/JVM compilers do - -- not support pools and address arithmetic. - - elsif VM_Target /= No_VM then - return; end if; -- Use the base type to perform the check for finalization master @@ -368,14 +362,21 @@ package body Exp_Ch13 is ---------------------------- procedure Expand_N_Freeze_Entity (N : Node_Id) is - E : constant Entity_Id := Entity (N); + E : constant Entity_Id := Entity (N); + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + + Decl : Node_Id; + Delete : Boolean := False; E_Scope : Entity_Id; In_Other_Scope : Boolean; In_Outer_Scope : Boolean; - Decl : Node_Id; - Delete : Boolean := False; begin + -- Ensure that all freezing activities are properly flagged as Ghost + + Set_Ghost_Mode_From_Entity (E); + -- If there are delayed aspect specifications, we insert them just -- before the freeze node. They are already analyzed so we don't need -- to reanalyze them (they were analyzed before the type was frozen), @@ -443,13 +444,14 @@ package body Exp_Ch13 is -- statement, insert them back into the tree now. Explode_Initialization_Compound_Statement (E); - + Ghost_Mode := Save_Ghost_Mode; return; -- Only other items requiring any front end action are types and -- subprograms. elsif not Is_Type (E) and then not Is_Subprogram (E) then + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -461,6 +463,7 @@ package body Exp_Ch13 is if No (E_Scope) then Check_Error_Detected; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -678,6 +681,7 @@ package body Exp_Ch13 is -- whether we are inside a (possibly nested) call to this procedure. Inside_Freezing_Actions := Inside_Freezing_Actions - 1; + Ghost_Mode := Save_Ghost_Mode; end Expand_N_Freeze_Entity; ------------------------------------------- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 885e63a4ae9..6fb3a598351 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -671,14 +671,9 @@ package body Exp_Ch3 is -- Nothing to generate in the following cases: -- 1. Initialization is suppressed for the type - -- 2. The type is a value type, in the CIL sense. - -- 3. The type has CIL/JVM convention. - -- 4. An initialization already exists for the base type + -- 2. An initialization already exists for the base type if Initialization_Suppressed (A_Type) - or else Is_Value_Type (Comp_Type) - or else Convention (A_Type) = Convention_CIL - or else Convention (A_Type) = Convention_Java or else Present (Base_Init_Proc (A_Type)) then return; @@ -1480,13 +1475,8 @@ package body Exp_Ch3 is -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars -- is active (in which case we make the call anyway, since in the -- actual compiled client it may be non null). - -- Also nothing to do for value types. - if (Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars) - or else Is_Value_Type (Typ) - or else - (Is_Array_Type (Typ) and then Is_Value_Type (Component_Type (Typ))) - then + if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then return Empty_List; end if; @@ -1861,8 +1851,8 @@ package body Exp_Ch3 is Set_No_Ctrl_Actions (First (Res)); -- Adjust the tag if tagged (because of possible view conversions). - -- Suppress the tag adjustment when VM_Target because VM tags are - -- represented implicitly in objects. + -- Suppress the tag adjustment when not Tagged_Type_Expansion because + -- tags are represented implicitly in objects. if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then Append_To (Res, @@ -2174,8 +2164,8 @@ package body Exp_Ch3 is begin -- Offset_To_Top_Functions are built only for derivations of types -- with discriminants that cover interface types. - -- Nothing is needed either in case of virtual machines, since - -- interfaces are handled directly by the VM. + -- Nothing is needed either in case of virtual targets, since + -- interfaces are handled directly by the target. if not Is_Tagged_Type (Rec_Type) or else Etype (Rec_Type) = Rec_Type @@ -2439,10 +2429,10 @@ package body Exp_Ch3 is -- _Init._Tag := Typ'Tag; - -- Suppress the tag assignment when VM_Target because VM tags are - -- represented implicitly in objects. It is also suppressed in case - -- of CPP_Class types because in this case the tag is initialized in - -- the C++ side. + -- Suppress the tag assignment when not Tagged_Type_Expansion because + -- tags are represented implicitly in objects. It is also suppressed + -- in case of CPP_Class types because in this case the tag is + -- initialized in the C++ side. if Is_Tagged_Type (Rec_Type) and then Tagged_Type_Expansion @@ -2694,11 +2684,7 @@ package body Exp_Ch3 is -- list by Insert_Actions. and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement - and then VM_Target = No_VM then - -- Even though the init proc may be null at this time it might get - -- some stuff added to it later by the VM backend. - Set_Is_Null_Init_Proc (Proc_Id); end if; end Build_Init_Procedure; @@ -3525,14 +3511,8 @@ package body Exp_Ch3 is -- Start of processing for Build_Record_Init_Proc begin - -- Check for value type, which means no initialization required - Rec_Type := Defining_Identifier (N); - if Is_Value_Type (Rec_Type) then - return; - end if; - -- This may be full declaration of a private type, in which case -- the visible entity is a record, and the private entity has been -- exchanged with it in the private part of the current package. @@ -3632,6 +3612,14 @@ package body Exp_Ch3 is Set_Debug_Info_Off (Proc_Id); end if; + -- Do not build an aggregate if Modify_Tree_For_C, this isn't + -- needed and may generate early references to non frozen types + -- since we expand aggregate much more systematically. + + if Modify_Tree_For_C then + return; + end if; + declare Agg : constant Node_Id := Build_Equivalent_Record_Aggregate (Rec_Type); @@ -4593,130 +4581,1137 @@ package body Exp_Ch3 is end if; end Check_Stream_Attributes; - ----------------------------- - -- Expand_Record_Extension -- - ----------------------------- + ---------------------- + -- Clean_Task_Names -- + ---------------------- - -- Add a field _parent at the beginning of the record extension. This is - -- used to implement inheritance. Here are some examples of expansion: + procedure Clean_Task_Names + (Typ : Entity_Id; + Proc_Id : Entity_Id) + is + begin + if Has_Task (Typ) + and then not Restriction_Active (No_Implicit_Heap_Allocations) + and then not Global_Discard_Names + and then Tagged_Type_Expansion + then + Set_Uses_Sec_Stack (Proc_Id); + end if; + end Clean_Task_Names; - -- 1. no discriminants - -- type T2 is new T1 with null record; - -- gives - -- type T2 is new T1 with record - -- _Parent : T1; - -- end record; + ------------------------------ + -- Expand_Freeze_Array_Type -- + ------------------------------ - -- 2. renamed discriminants - -- type T2 (B, C : Int) is new T1 (A => B) with record - -- _Parent : T1 (A => B); - -- D : Int; - -- end; + procedure Expand_Freeze_Array_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Base : constant Entity_Id := Base_Type (Typ); + Comp_Typ : constant Entity_Id := Component_Type (Typ); - -- 3. inherited discriminants - -- type T2 is new T1 with record -- discriminant A inherited - -- _Parent : T1 (A); - -- D : Int; - -- end; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; - procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is - Indic : constant Node_Id := Subtype_Indication (Def); - Loc : constant Source_Ptr := Sloc (Def); - Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); - Par_Subtype : Entity_Id; - Comp_List : Node_Id; - Comp_Decl : Node_Id; - Parent_N : Node_Id; - D : Entity_Id; - List_Constr : constant List_Id := New_List; + Ins_Node : Node_Id; begin - -- Expand_Record_Extension is called directly from the semantics, so - -- we must check to see whether expansion is active before proceeding, - -- because this affects the visibility of selected components in bodies - -- of instances. + -- Ensure that all freezing activities are properly flagged as Ghost - if not Expander_Active then + Set_Ghost_Mode_From_Entity (Typ); + + if not Is_Bit_Packed_Array (Typ) then + + -- If the component contains tasks, so does the array type. This may + -- not be indicated in the array type because the component may have + -- been a private type at the point of definition. Same if component + -- type is controlled or contains protected objects. + + Set_Has_Task (Base, Has_Task (Comp_Typ)); + Set_Has_Protected (Base, Has_Protected (Comp_Typ)); + Set_Has_Controlled_Component + (Base, Has_Controlled_Component + (Comp_Typ) + or else + Is_Controlled (Comp_Typ)); + + if No (Init_Proc (Base)) then + + -- If this is an anonymous array created for a declaration with + -- an initial value, its init_proc will never be called. The + -- initial value itself may have been expanded into assignments, + -- in which case the object declaration is carries the + -- No_Initialization flag. + + if Is_Itype (Base) + and then Nkind (Associated_Node_For_Itype (Base)) = + N_Object_Declaration + and then + (Present (Expression (Associated_Node_For_Itype (Base))) + or else No_Initialization (Associated_Node_For_Itype (Base))) + then + null; + + -- We do not need an init proc for string or wide [wide] string, + -- since the only time these need initialization in normalize or + -- initialize scalars mode, and these types are treated specially + -- and do not need initialization procedures. + + elsif Is_Standard_String_Type (Base) then + null; + + -- Otherwise we have to build an init proc for the subtype + + else + Build_Array_Init_Proc (Base, N); + end if; + end if; + + if Typ = Base then + if Has_Controlled_Component (Base) then + Build_Controlling_Procs (Base); + + if not Is_Limited_Type (Comp_Typ) + and then Number_Dimensions (Typ) = 1 + then + Build_Slice_Assignment (Typ); + end if; + end if; + + -- Create a finalization master to service the anonymous access + -- components of the array. + + if Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Designated_Type (Comp_Typ)) + then + -- The finalization master is inserted before the declaration + -- of the array type. The only exception to this is when the + -- array type is an itype, in which case the master appears + -- before the related context. + + if Is_Itype (Typ) then + Ins_Node := Associated_Node_For_Itype (Typ); + else + Ins_Node := Parent (Typ); + end if; + + Build_Finalization_Master + (Typ => Comp_Typ, + For_Anonymous => True, + Context_Scope => Scope (Typ), + Insertion_Node => Ins_Node); + end if; + end if; + + -- For packed case, default initialization, except if the component type + -- is itself a packed structure with an initialization procedure, or + -- initialize/normalize scalars active, and we have a base type, or the + -- type is public, because in that case a client might specify + -- Normalize_Scalars and there better be a public Init_Proc for it. + + elsif (Present (Init_Proc (Component_Type (Base))) + and then No (Base_Init_Proc (Base))) + or else (Init_Or_Norm_Scalars and then Base = Typ) + or else Is_Public (Typ) + then + Build_Array_Init_Proc (Base, N); + end if; + + if Has_Invariants (Component_Type (Base)) + and then Typ = Base + and then In_Open_Scopes (Scope (Component_Type (Base))) + then + -- Generate component invariant checking procedure. This is only + -- relevant if the array type is within the scope of the component + -- type. Otherwise an array object can only be built using the public + -- subprograms for the component type, and calls to those will have + -- invariant checks. The invariant procedure is only generated for + -- a base type, not a subtype. + + Insert_Component_Invariant_Checks + (N, Base, Build_Array_Invariant_Proc (Base, N)); + end if; + + Ghost_Mode := Save_Ghost_Mode; + end Expand_Freeze_Array_Type; + + ----------------------------------- + -- Expand_Freeze_Class_Wide_Type -- + ----------------------------------- + + procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is + function Is_C_Derivation (Typ : Entity_Id) return Boolean; + -- Given a type, determine whether it is derived from a C or C++ root + + --------------------- + -- Is_C_Derivation -- + --------------------- + + function Is_C_Derivation (Typ : Entity_Id) return Boolean is + T : Entity_Id; + + begin + T := Typ; + loop + if Is_CPP_Class (T) + or else Convention (T) = Convention_C + or else Convention (T) = Convention_CPP + then + return True; + end if; + + exit when T = Etype (T); + + T := Etype (T); + end loop; + + return False; + end Is_C_Derivation; + + -- Local variables + + Typ : constant Entity_Id := Entity (N); + Root : constant Entity_Id := Root_Type (Typ); + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + + -- Start of processing for Expand_Freeze_Class_Wide_Type + + begin + -- Certain run-time configurations and targets do not provide support + -- for controlled types. + + if Restriction_Active (No_Finalization) then + return; + + -- Do not create TSS routine Finalize_Address when dispatching calls are + -- disabled since the core of the routine is a dispatching call. + + elsif Restriction_Active (No_Dispatching_Calls) then + return; + + -- Do not create TSS routine Finalize_Address for concurrent class-wide + -- types. Ignore C, C++, CIL and Java types since it is assumed that the + -- non-Ada side will handle their destruction. + + elsif Is_Concurrent_Type (Root) + or else Is_C_Derivation (Root) + or else Convention (Typ) = Convention_CPP + then + return; + + -- Do not create TSS routine Finalize_Address when compiling in CodePeer + -- mode since the routine contains an Unchecked_Conversion. + + elsif CodePeer_Mode then return; end if; - -- This may be a derivation of an untagged private type whose full - -- view is tagged, in which case the Derived_Type_Definition has no - -- extension part. Build an empty one now. + -- Ensure that all freezing activities are properly flagged as Ghost - if No (Rec_Ext_Part) then - Rec_Ext_Part := - Make_Record_Definition (Loc, - End_Label => Empty, - Component_List => Empty, - Null_Present => True); + Set_Ghost_Mode_From_Entity (Typ); - Set_Record_Extension_Part (Def, Rec_Ext_Part); - Mark_Rewrite_Insertion (Rec_Ext_Part); + -- Create the body of TSS primitive Finalize_Address. This automatically + -- sets the TSS entry for the class-wide type. + + Make_Finalize_Address_Body (Typ); + Ghost_Mode := Save_Ghost_Mode; + end Expand_Freeze_Class_Wide_Type; + + ------------------------------------ + -- Expand_Freeze_Enumeration_Type -- + ------------------------------------ + + procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Loc : constant Source_Ptr := Sloc (Typ); + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + + Arr : Entity_Id; + Ent : Entity_Id; + Fent : Entity_Id; + Is_Contiguous : Boolean; + Ityp : Entity_Id; + Last_Repval : Uint; + Lst : List_Id; + Num : Nat; + Pos_Expr : Node_Id; + + Func : Entity_Id; + pragma Warnings (Off, Func); + + begin + -- Ensure that all freezing activities are properly flagged as Ghost + + Set_Ghost_Mode_From_Entity (Typ); + + -- Various optimizations possible if given representation is contiguous + + Is_Contiguous := True; + + Ent := First_Literal (Typ); + Last_Repval := Enumeration_Rep (Ent); + + Next_Literal (Ent); + while Present (Ent) loop + if Enumeration_Rep (Ent) - Last_Repval /= 1 then + Is_Contiguous := False; + exit; + else + Last_Repval := Enumeration_Rep (Ent); + end if; + + Next_Literal (Ent); + end loop; + + if Is_Contiguous then + Set_Has_Contiguous_Rep (Typ); + Ent := First_Literal (Typ); + Num := 1; + Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent))); + + else + -- Build list of literal references + + Lst := New_List; + Num := 0; + + Ent := First_Literal (Typ); + while Present (Ent) loop + Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent))); + Num := Num + 1; + Next_Literal (Ent); + end loop; end if; - Comp_List := Component_List (Rec_Ext_Part); + -- Now build an array declaration - Parent_N := Make_Defining_Identifier (Loc, Name_uParent); + -- typA : array (Natural range 0 .. num - 1) of ctype := + -- (v, v, v, v, v, ....) - -- If the derived type inherits its discriminants the type of the - -- _parent field must be constrained by the inherited discriminants + -- where ctype is the corresponding integer type. If the representation + -- is contiguous, we only keep the first literal, which provides the + -- offset for Pos_To_Rep computations. - if Has_Discriminants (T) - and then Nkind (Indic) /= N_Subtype_Indication - and then not Is_Constrained (Entity (Indic)) - then - D := First_Discriminant (T); - while Present (D) loop - Append_To (List_Constr, New_Occurrence_Of (D, Loc)); - Next_Discriminant (D); + Arr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), 'A')); + + Append_Freeze_Action (Typ, + Make_Object_Declaration (Loc, + Defining_Identifier => Arr, + Constant_Present => True, + + Object_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 0), + High_Bound => + Make_Integer_Literal (Loc, Num - 1))))), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (Typ, Loc))), + + Expression => + Make_Aggregate (Loc, + Expressions => Lst))); + + Set_Enum_Pos_To_Rep (Typ, Arr); + + -- Now we build the function that converts representation values to + -- position values. This function has the form: + + -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is + -- begin + -- case ityp!(A) is + -- when enum-lit'Enum_Rep => return posval; + -- when enum-lit'Enum_Rep => return posval; + -- ... + -- when others => + -- [raise Constraint_Error when F "invalid data"] + -- return -1; + -- end case; + -- end; + + -- Note: the F parameter determines whether the others case (no valid + -- representation) raises Constraint_Error or returns a unique value + -- of minus one. The latter case is used, e.g. in 'Valid code. + + -- Note: the reason we use Enum_Rep values in the case here is to avoid + -- the code generator making inappropriate assumptions about the range + -- of the values in the case where the value is invalid. ityp is a + -- signed or unsigned integer type of appropriate width. + + -- Note: if exceptions are not supported, then we suppress the raise + -- and return -1 unconditionally (this is an erroneous program in any + -- case and there is no obligation to raise Constraint_Error here). We + -- also do this if pragma Restrictions (No_Exceptions) is active. + + -- Is this right??? What about No_Exception_Propagation??? + + -- Representations are signed + + if Enumeration_Rep (First_Literal (Typ)) < 0 then + + -- The underlying type is signed. Reset the Is_Unsigned_Type + -- explicitly, because it might have been inherited from + -- parent type. + + Set_Is_Unsigned_Type (Typ, False); + + if Esize (Typ) <= Standard_Integer_Size then + Ityp := Standard_Integer; + else + Ityp := Universal_Integer; + end if; + + -- Representations are unsigned + + else + if Esize (Typ) <= Standard_Integer_Size then + Ityp := RTE (RE_Unsigned); + else + Ityp := RTE (RE_Long_Long_Unsigned); + end if; + end if; + + -- The body of the function is a case statement. First collect case + -- alternatives, or optimize the contiguous case. + + Lst := New_List; + + -- If representation is contiguous, Pos is computed by subtracting + -- the representation of the first literal. + + if Is_Contiguous then + Ent := First_Literal (Typ); + + if Enumeration_Rep (Ent) = Last_Repval then + + -- Another special case: for a single literal, Pos is zero + + Pos_Expr := Make_Integer_Literal (Loc, Uint_0); + + else + Pos_Expr := + Convert_To (Standard_Integer, + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (Ityp, Make_Identifier (Loc, Name_uA)), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => Enumeration_Rep (First_Literal (Typ))))); + end if; + + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), + Low_Bound => + Make_Integer_Literal (Loc, + Intval => Enumeration_Rep (Ent)), + High_Bound => + Make_Integer_Literal (Loc, Intval => Last_Repval))), + + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Pos_Expr)))); + + else + Ent := First_Literal (Typ); + while Present (Ent) loop + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), + Intval => Enumeration_Rep (Ent))), + + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, + Intval => Enumeration_Pos (Ent)))))); + + Next_Literal (Ent); end loop; + end if; - Par_Subtype := - Process_Subtype ( - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => List_Constr)), - Def); + -- In normal mode, add the others clause with the test - -- Otherwise the original subtype_indication is just what is needed + if not No_Exception_Handlers_Set then + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Raise_Constraint_Error (Loc, + Condition => Make_Identifier (Loc, Name_uF), + Reason => CE_Invalid_Data), + Make_Simple_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, -1))))); + + -- If either of the restrictions No_Exceptions_Handlers/Propagation is + -- active then return -1 (we cannot usefully raise Constraint_Error in + -- this case). See description above for further details. else - Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, -1))))); end if; - Set_Parent_Subtype (T, Par_Subtype); + -- Now we can build the function body - Comp_Decl := - Make_Component_Declaration (Loc, - Defining_Identifier => Parent_N, - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc))); + Fent := + Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); - if Null_Present (Rec_Ext_Part) then - Set_Component_List (Rec_Ext_Part, - Make_Component_List (Loc, - Component_Items => New_List (Comp_Decl), - Variant_Part => Empty, - Null_Present => False)); - Set_Null_Present (Rec_Ext_Part, False); + Func := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Fent, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uA), + Parameter_Type => New_Occurrence_Of (Typ, Loc)), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), - elsif Null_Present (Comp_List) - or else Is_Empty_List (Component_Items (Comp_List)) + Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Case_Statement (Loc, + Expression => + Unchecked_Convert_To + (Ityp, Make_Identifier (Loc, Name_uA)), + Alternatives => Lst)))); + + Set_TSS (Typ, Fent); + + -- Set Pure flag (it will be reset if the current context is not Pure). + -- We also pretend there was a pragma Pure_Function so that for purposes + -- of optimization and constant-folding, we will consider the function + -- Pure even if we are not in a Pure context). + + Set_Is_Pure (Fent); + Set_Has_Pragma_Pure_Function (Fent); + + -- Unless we are in -gnatD mode, where we are debugging generated code, + -- this is an internal entity for which we don't need debug info. + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Fent); + end if; + + Ghost_Mode := Save_Ghost_Mode; + + exception + when RE_Not_Available => + Ghost_Mode := Save_Ghost_Mode; + return; + end Expand_Freeze_Enumeration_Type; + + ------------------------------- + -- Expand_Freeze_Record_Type -- + ------------------------------- + + procedure Expand_Freeze_Record_Type (N : Node_Id) is + Typ : constant Node_Id := Entity (N); + Typ_Decl : constant Node_Id := Parent (Typ); + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + + Comp : Entity_Id; + Comp_Typ : Entity_Id; + Has_AACC : Boolean; + Predef_List : List_Id; + + Renamed_Eq : Node_Id := Empty; + -- Defining unit name for the predefined equality function in the case + -- where the type has a primitive operation that is a renaming of + -- predefined equality (but only if there is also an overriding + -- user-defined equality function). Used to pass this entity from + -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. + + Wrapper_Decl_List : List_Id := No_List; + Wrapper_Body_List : List_Id := No_List; + + -- Start of processing for Expand_Freeze_Record_Type + + begin + -- Ensure that all freezing activities are properly flagged as Ghost + + Set_Ghost_Mode_From_Entity (Typ); + + -- Build discriminant checking functions if not a derived type (for + -- derived types that are not tagged types, always use the discriminant + -- checking functions of the parent type). However, for untagged types + -- the derivation may have taken place before the parent was frozen, so + -- we copy explicitly the discriminant checking functions from the + -- parent into the components of the derived type. + + if not Is_Derived_Type (Typ) + or else Has_New_Non_Standard_Rep (Typ) + or else Is_Tagged_Type (Typ) then - Set_Component_Items (Comp_List, New_List (Comp_Decl)); - Set_Null_Present (Comp_List, False); + Build_Discr_Checking_Funcs (Typ_Decl); - else - Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); + elsif Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + + -- If we have a derived Unchecked_Union, we do not inherit the + -- discriminant checking functions from the parent type since the + -- discriminants are non existent. + + and then not Is_Unchecked_Union (Typ) + and then Has_Discriminants (Typ) + then + declare + Old_Comp : Entity_Id; + + begin + Old_Comp := + First_Component (Base_Type (Underlying_Type (Etype (Typ)))); + Comp := First_Component (Typ); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Chars (Comp) = Chars (Old_Comp) + then + Set_Discriminant_Checking_Func (Comp, + Discriminant_Checking_Func (Old_Comp)); + end if; + + Next_Component (Old_Comp); + Next_Component (Comp); + end loop; + end; end if; - Analyze (Comp_Decl); - end Expand_Record_Extension; + if Is_Derived_Type (Typ) + and then Is_Limited_Type (Typ) + and then Is_Tagged_Type (Typ) + then + Check_Stream_Attributes (Typ); + end if; + + -- Update task, protected, and controlled component flags, because some + -- of the component types may have been private at the point of the + -- record declaration. Detect anonymous access-to-controlled components. + + Has_AACC := False; + + Comp := First_Component (Typ); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + if Has_Task (Comp_Typ) then + Set_Has_Task (Typ); + end if; + + if Has_Protected (Comp_Typ) then + Set_Has_Protected (Typ); + end if; + + -- Do not set Has_Controlled_Component on a class-wide equivalent + -- type. See Make_CW_Equivalent_Type. + + if not Is_Class_Wide_Equivalent_Type (Typ) + and then + (Has_Controlled_Component (Comp_Typ) + or else (Chars (Comp) /= Name_uParent + and then (Is_Controlled_Active (Comp_Typ)))) + then + Set_Has_Controlled_Component (Typ); + end if; + + -- Non-self-referential anonymous access-to-controlled component + + if Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Designated_Type (Comp_Typ)) + and then Designated_Type (Comp_Typ) /= Typ + then + Has_AACC := True; + end if; + + Next_Component (Comp); + end loop; + + -- Handle constructors of untagged CPP_Class types + + if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then + Set_CPP_Constructors (Typ); + end if; + + -- Creation of the Dispatch Table. Note that a Dispatch Table is built + -- for regular tagged types as well as for Ada types deriving from a C++ + -- Class, but not for tagged types directly corresponding to C++ classes + -- In the later case we assume that it is created in the C++ side and we + -- just use it. + + if Is_Tagged_Type (Typ) then + + -- Add the _Tag component + + if Underlying_Type (Etype (Typ)) = Typ then + Expand_Tagged_Root (Typ); + end if; + + if Is_CPP_Class (Typ) then + Set_All_DT_Position (Typ); + + -- Create the tag entities with a minimum decoration + + if Tagged_Type_Expansion then + Append_Freeze_Actions (Typ, Make_Tags (Typ)); + end if; + + Set_CPP_Constructors (Typ); + + else + if not Building_Static_DT (Typ) then + + -- Usually inherited primitives are not delayed but the first + -- Ada extension of a CPP_Class is an exception since the + -- address of the inherited subprogram has to be inserted in + -- the new Ada Dispatch Table and this is a freezing action. + + -- Similarly, if this is an inherited operation whose parent is + -- not frozen yet, it is not in the DT of the parent, and we + -- generate an explicit freeze node for the inherited operation + -- so it is properly inserted in the DT of the current type. + + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Subp := Node (Elmt); + + if Present (Alias (Subp)) then + if Is_CPP_Class (Etype (Typ)) then + Set_Has_Delayed_Freeze (Subp); + + elsif Has_Delayed_Freeze (Alias (Subp)) + and then not Is_Frozen (Alias (Subp)) + then + Set_Is_Frozen (Subp, False); + Set_Has_Delayed_Freeze (Subp); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + -- Unfreeze momentarily the type to add the predefined primitives + -- operations. The reason we unfreeze is so that these predefined + -- operations will indeed end up as primitive operations (which + -- must be before the freeze point). + + Set_Is_Frozen (Typ, False); + + -- Do not add the spec of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Typ)) + and then Convention (Typ) = Convention_CPP + then + null; + + -- Do not add the spec of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls. + + elsif not Restriction_Active (No_Dispatching_Calls) then + Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq); + Insert_List_Before_And_Analyze (N, Predef_List); + end if; + + -- Ada 2005 (AI-391): For a nonabstract null extension, create + -- wrapper functions for each nonoverridden inherited function + -- with a controlling result of the type. The wrapper for such + -- a function returns an extension aggregate that invokes the + -- parent function. + + if Ada_Version >= Ada_2005 + and then not Is_Abstract_Type (Typ) + and then Is_Null_Extension (Typ) + then + Make_Controlling_Function_Wrappers + (Typ, Wrapper_Decl_List, Wrapper_Body_List); + Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); + end if; + + -- Ada 2005 (AI-251): For a nonabstract type extension, build + -- null procedure declarations for each set of homographic null + -- procedures that are inherited from interface types but not + -- overridden. This is done to ensure that the dispatch table + -- entry associated with such null primitives are properly filled. + + if Ada_Version >= Ada_2005 + and then Etype (Typ) /= Typ + and then not Is_Abstract_Type (Typ) + and then Has_Interfaces (Typ) + then + Insert_Actions (N, Make_Null_Procedure_Specs (Typ)); + end if; + + Set_Is_Frozen (Typ); + + if not Is_Derived_Type (Typ) + or else Is_Tagged_Type (Etype (Typ)) + then + Set_All_DT_Position (Typ); + + -- If this is a type derived from an untagged private type whose + -- full view is tagged, the type is marked tagged for layout + -- reasons, but it has no dispatch table. + + elsif Is_Derived_Type (Typ) + and then Is_Private_Type (Etype (Typ)) + and then not Is_Tagged_Type (Etype (Typ)) + then + return; + end if; + + -- Create and decorate the tags. Suppress their creation when + -- not Tagged_Type_Expansion because the dispatching mechanism is + -- handled internally by the virtual target. + + if Tagged_Type_Expansion then + Append_Freeze_Actions (Typ, Make_Tags (Typ)); + + -- Generate dispatch table of locally defined tagged type. + -- Dispatch tables of library level tagged types are built + -- later (see Analyze_Declarations). + + if not Building_Static_DT (Typ) then + Append_Freeze_Actions (Typ, Make_DT (Typ)); + end if; + end if; + + -- If the type has unknown discriminants, propagate dispatching + -- information to its underlying record view, which does not get + -- its own dispatch table. + + if Is_Derived_Type (Typ) + and then Has_Unknown_Discriminants (Typ) + and then Present (Underlying_Record_View (Typ)) + then + declare + Rep : constant Entity_Id := Underlying_Record_View (Typ); + begin + Set_Access_Disp_Table + (Rep, Access_Disp_Table (Typ)); + Set_Dispatch_Table_Wrappers + (Rep, Dispatch_Table_Wrappers (Typ)); + Set_Direct_Primitive_Operations + (Rep, Direct_Primitive_Operations (Typ)); + end; + end if; + + -- Make sure that the primitives Initialize, Adjust and Finalize + -- are Frozen before other TSS subprograms. We don't want them + -- Frozen inside. + + if Is_Controlled (Typ) then + if not Is_Limited_Type (Typ) then + Append_Freeze_Actions (Typ, + Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ)); + end if; + + Append_Freeze_Actions (Typ, + Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ)); + + Append_Freeze_Actions (Typ, + Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ)); + end if; + + -- Freeze rest of primitive operations. There is no need to handle + -- the predefined primitives if we are compiling under restriction + -- No_Dispatching_Calls. + + if not Restriction_Active (No_Dispatching_Calls) then + Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ)); + end if; + end if; + + -- In the untagged case, ever since Ada 83 an equality function must + -- be provided for variant records that are not unchecked unions. + -- In Ada 2012 the equality function composes, and thus must be built + -- explicitly just as for tagged records. + + elsif Has_Discriminants (Typ) + and then not Is_Limited_Type (Typ) + then + declare + Comps : constant Node_Id := + Component_List (Type_Definition (Typ_Decl)); + begin + if Present (Comps) + and then Present (Variant_Part (Comps)) + then + Build_Variant_Record_Equality (Typ); + end if; + end; + + -- Otherwise create primitive equality operation (AI05-0123) + + -- This is done unconditionally to ensure that tools can be linked + -- properly with user programs compiled with older language versions. + -- In addition, this is needed because "=" composes for bounded strings + -- in all language versions (see Exp_Ch4.Expand_Composite_Equality). + + elsif Comes_From_Source (Typ) + and then Convention (Typ) = Convention_Ada + and then not Is_Limited_Type (Typ) + then + Build_Untagged_Equality (Typ); + end if; + + -- Before building the record initialization procedure, if we are + -- dealing with a concurrent record value type, then we must go through + -- the discriminants, exchanging discriminals between the concurrent + -- type and the concurrent record value type. See the section "Handling + -- of Discriminants" in the Einfo spec for details. + + if Is_Concurrent_Record_Type (Typ) + and then Has_Discriminants (Typ) + then + declare + Ctyp : constant Entity_Id := + Corresponding_Concurrent_Type (Typ); + Conc_Discr : Entity_Id; + Rec_Discr : Entity_Id; + Temp : Entity_Id; + + begin + Conc_Discr := First_Discriminant (Ctyp); + Rec_Discr := First_Discriminant (Typ); + while Present (Conc_Discr) loop + Temp := Discriminal (Conc_Discr); + Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); + Set_Discriminal (Rec_Discr, Temp); + + Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); + Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); + + Next_Discriminant (Conc_Discr); + Next_Discriminant (Rec_Discr); + end loop; + end; + end if; + + if Has_Controlled_Component (Typ) then + Build_Controlling_Procs (Typ); + end if; + + Adjust_Discriminants (Typ); + + -- Do not need init for interfaces on virtual targets since they're + -- abstract. + + if Tagged_Type_Expansion or else not Is_Interface (Typ) then + Build_Record_Init_Proc (Typ_Decl, Typ); + end if; + + -- For tagged type that are not interfaces, build bodies of primitive + -- operations. Note: do this after building the record initialization + -- procedure, since the primitive operations may need the initialization + -- routine. There is no need to add predefined primitives of interfaces + -- because all their predefined primitives are abstract. + + if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then + + -- Do not add the body of predefined primitives in case of CPP tagged + -- type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Typ)) + and then Convention (Typ) = Convention_CPP + then + null; + + -- Do not add the body of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls or if we are + -- compiling a CPP tagged type. + + elsif not Restriction_Active (No_Dispatching_Calls) then + + -- Create the body of TSS primitive Finalize_Address. This must + -- be done before the bodies of all predefined primitives are + -- created. If Typ is limited, Stream_Input and Stream_Read may + -- produce build-in-place allocations and for those the expander + -- needs Finalize_Address. + + Make_Finalize_Address_Body (Typ); + Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq); + Append_Freeze_Actions (Typ, Predef_List); + end if; + + -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden + -- inherited functions, then add their bodies to the freeze actions. + + if Present (Wrapper_Body_List) then + Append_Freeze_Actions (Typ, Wrapper_Body_List); + end if; + + -- Create extra formals for the primitive operations of the type. + -- This must be done before analyzing the body of the initialization + -- procedure, because a self-referential type might call one of these + -- primitives in the body of the init_proc itself. + + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Subp := Node (Elmt); + if not Has_Foreign_Convention (Subp) + and then not Is_Predefined_Dispatching_Operation (Subp) + then + Create_Extra_Formals (Subp); + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + -- Create a heterogeneous finalization master to service the anonymous + -- access-to-controlled components of the record type. + + if Has_AACC then + declare + Encl_Scope : constant Entity_Id := Scope (Typ); + Ins_Node : constant Node_Id := Parent (Typ); + Loc : constant Source_Ptr := Sloc (Typ); + Fin_Mas_Id : Entity_Id; + + Attributes_Set : Boolean := False; + Master_Built : Boolean := False; + -- Two flags which control the creation and initialization of a + -- common heterogeneous master. + + begin + Comp := First_Component (Typ); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + -- A non-self-referential anonymous access-to-controlled + -- component. + + if Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Designated_Type (Comp_Typ)) + and then Designated_Type (Comp_Typ) /= Typ + then + -- Build a homogeneous master for the first anonymous + -- access-to-controlled component. This master may be + -- converted into a heterogeneous collection if more + -- components are to follow. + + if not Master_Built then + Master_Built := True; + + -- All anonymous access-to-controlled types allocate + -- on the global pool. Note that the finalization + -- master and the associated storage pool must be set + -- on the root type (both are "root type only"). + + Set_Associated_Storage_Pool + (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); + + Build_Finalization_Master + (Typ => Root_Type (Comp_Typ), + For_Anonymous => True, + Context_Scope => Encl_Scope, + Insertion_Node => Ins_Node); + + Fin_Mas_Id := Finalization_Master (Comp_Typ); + + -- Subsequent anonymous access-to-controlled components + -- reuse the available master. + + else + -- All anonymous access-to-controlled types allocate + -- on the global pool. Note that both the finalization + -- master and the associated storage pool must be set + -- on the root type (both are "root type only"). + + Set_Associated_Storage_Pool + (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); + + -- Shared the master among multiple components + + Set_Finalization_Master + (Root_Type (Comp_Typ), Fin_Mas_Id); + + -- Convert the master into a heterogeneous collection. + -- Generate: + -- Set_Is_Heterogeneous (<Fin_Mas_Id>); + + if not Attributes_Set then + Attributes_Set := True; + + Insert_Action (Ins_Node, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Set_Is_Heterogeneous), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Fin_Mas_Id, Loc)))); + end if; + end if; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + + -- Check whether individual components have a defined invariant, and add + -- the corresponding component invariant checks. + + -- Do not create an invariant procedure for some internally generated + -- subtypes, in particular those created for objects of a class-wide + -- type. Such types may have components to which invariant apply, but + -- the corresponding checks will be applied when an object of the parent + -- type is constructed. + + -- Such objects will show up in a class-wide postcondition, and the + -- invariant will be checked, if necessary, upon return from the + -- enclosing subprogram. + + if not Is_Class_Wide_Equivalent_Type (Typ) then + Insert_Component_Invariant_Checks + (N, Typ, Build_Record_Invariant_Proc (Typ, N)); + end if; + + Ghost_Mode := Save_Ghost_Mode; + end Expand_Freeze_Record_Type; ------------------------------------ -- Expand_N_Full_Type_Declaration -- @@ -4761,24 +5756,6 @@ package body Exp_Ch3 is elsif Is_Limited_Class_Wide_Type (Desig_Typ) and then Tasking_Allowed - - -- Do not create a class-wide master for types whose convention is - -- Java since these types cannot embed Ada tasks anyway. Note that - -- the following test cannot catch the following case: - - -- package java.lang.Object is - -- type Typ is tagged limited private; - -- type Ref is access all Typ'Class; - -- private - -- type Typ is tagged limited ...; - -- pragma Convention (Typ, Java) - -- end; - - -- Because the convention appears after we have done the - -- processing for type Ref. - - and then Convention (Desig_Typ) /= Convention_Java - and then Convention (Desig_Typ) /= Convention_CIL then Build_Class_Wide_Master (Ptr_Typ); end if; @@ -4786,21 +5763,14 @@ package body Exp_Ch3 is -- Local declarations - Def_Id : constant Entity_Id := Defining_Identifier (N); - B_Id : constant Entity_Id := Base_Type (Def_Id); - GM : constant Ghost_Mode_Type := Ghost_Mode; + Def_Id : constant Entity_Id := Defining_Identifier (N); + B_Id : constant Entity_Id := Base_Type (Def_Id); FN : Node_Id; Par_Id : Entity_Id; -- Start of processing for Expand_N_Full_Type_Declaration begin - -- The type declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - if Is_Access_Type (Def_Id) then Build_Master (Def_Id); @@ -4924,11 +5894,6 @@ package body Exp_Ch3 is end if; end; end if; - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Expand_N_Full_Type_Declaration; --------------------------------- @@ -4936,13 +5901,12 @@ package body Exp_Ch3 is --------------------------------- procedure Expand_N_Object_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Def_Id : constant Entity_Id := Defining_Identifier (N); - Expr : constant Node_Id := Expression (N); - GM : constant Ghost_Mode_Type := Ghost_Mode; - Obj_Def : constant Node_Id := Object_Definition (N); - Typ : constant Entity_Id := Etype (Def_Id); - Base_Typ : constant Entity_Id := Base_Type (Typ); + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); + Expr : constant Node_Id := Expression (N); + Obj_Def : constant Node_Id := Object_Definition (N); + Typ : constant Entity_Id := Etype (Def_Id); + Base_Typ : constant Entity_Id := Base_Type (Typ); Expr_Q : Node_Id; function Build_Equivalent_Aggregate return Boolean; @@ -4954,9 +5918,6 @@ package body Exp_Ch3 is -- Generate all default initialization actions for object Def_Id. Any -- new code is inserted after node After. - procedure Restore_Globals; - -- Restore the values of all saved global variables - function Rewrite_As_Renaming return Boolean; -- Indicate whether to rewrite a declaration with initialization into an -- object renaming declaration (see below). @@ -5163,12 +6124,11 @@ package body Exp_Ch3 is -- Step 2: Initialize the components of the object -- Do not initialize the components if their initialization is - -- prohibited or the type represents a value type in a .NET VM. + -- prohibited. if Has_Non_Null_Base_Init_Proc (Typ) and then not No_Initialization (N) and then not Initialization_Suppressed (Typ) - and then not Is_Value_Type (Typ) then -- Do not initialize the components if No_Default_Initialization -- applies as the actual restriction check will occur later @@ -5209,7 +6169,7 @@ package body Exp_Ch3 is -- Provide a default value if the object needs simple initialization -- and does not already have an initial value. A generated temporary - -- do not require initialization because it will be assigned later. + -- does not require initialization because it will be assigned later. elsif Needs_Simple_Initialization (Typ, Initialize_Scalars @@ -5387,15 +6347,6 @@ package body Exp_Ch3 is end if; end Default_Initialize_Object; - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - ------------------------- -- Rewrite_As_Renaming -- ------------------------- @@ -5439,12 +6390,6 @@ package body Exp_Ch3 is return; end if; - -- The object declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - -- First we do special processing for objects of a tagged type where -- this is the point at which the type is frozen. The creation of the -- dispatch table and the initialization procedure have to be deferred @@ -5613,7 +6558,6 @@ package body Exp_Ch3 is and then Is_Build_In_Place_Function_Call (Expr_Q) then Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q); - Restore_Globals; -- The previous call expands the expression initializing the -- built-in-place object into further code that will be analyzed @@ -5858,7 +6802,6 @@ package body Exp_Ch3 is end; end if; - Restore_Globals; return; -- Common case of explicit object initialization @@ -5931,10 +6874,10 @@ package body Exp_Ch3 is -- be re-initialized separately in order to avoid the propagation -- of a wrong tag coming from a view conversion unless the type -- is class wide (in this case the tag comes from the init value). - -- Suppress the tag assignment when VM_Target because VM tags are - -- represented implicitly in objects. Ditto for types that are - -- CPP_CLASS, and for initializations that are aggregates, because - -- they have to have the right tag. + -- Suppress the tag assignment when not Tagged_Type_Expansion + -- because tags are represented implicitly in objects. Ditto for + -- types that are CPP_CLASS, and for initializations that are + -- aggregates, because they have to have the right tag. -- The re-assignment of the tag has to be done even if the object -- is a constant. The assignment must be analyzed after the @@ -5974,7 +6917,6 @@ package body Exp_Ch3 is -- to avoid its management in the backend Set_Expression (N, Empty); - Restore_Globals; return; -- Handle initialization of limited tagged types @@ -5982,6 +6924,7 @@ package body Exp_Ch3 is elsif Is_Tagged_Type (Typ) and then Is_Class_Wide_Type (Typ) and then Is_Limited_Record (Typ) + and then not Is_Limited_Interface (Typ) then -- Given that the type is limited we cannot perform a copy. If -- Expr_Q is the reference to a variable we mark the variable @@ -6196,13 +7139,10 @@ package body Exp_Ch3 is end; end if; - Restore_Globals; - -- Exception on library entity not available exception when RE_Not_Available => - Restore_Globals; return; end Expand_N_Object_Declaration; @@ -6280,6 +7220,131 @@ package body Exp_Ch3 is end loop; end Expand_Previous_Access_Type; + ----------------------------- + -- Expand_Record_Extension -- + ----------------------------- + + -- Add a field _parent at the beginning of the record extension. This is + -- used to implement inheritance. Here are some examples of expansion: + + -- 1. no discriminants + -- type T2 is new T1 with null record; + -- gives + -- type T2 is new T1 with record + -- _Parent : T1; + -- end record; + + -- 2. renamed discriminants + -- type T2 (B, C : Int) is new T1 (A => B) with record + -- _Parent : T1 (A => B); + -- D : Int; + -- end; + + -- 3. inherited discriminants + -- type T2 is new T1 with record -- discriminant A inherited + -- _Parent : T1 (A); + -- D : Int; + -- end; + + procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is + Indic : constant Node_Id := Subtype_Indication (Def); + Loc : constant Source_Ptr := Sloc (Def); + Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); + Par_Subtype : Entity_Id; + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Parent_N : Node_Id; + D : Entity_Id; + List_Constr : constant List_Id := New_List; + + begin + -- Expand_Record_Extension is called directly from the semantics, so + -- we must check to see whether expansion is active before proceeding, + -- because this affects the visibility of selected components in bodies + -- of instances. + + if not Expander_Active then + return; + end if; + + -- This may be a derivation of an untagged private type whose full + -- view is tagged, in which case the Derived_Type_Definition has no + -- extension part. Build an empty one now. + + if No (Rec_Ext_Part) then + Rec_Ext_Part := + Make_Record_Definition (Loc, + End_Label => Empty, + Component_List => Empty, + Null_Present => True); + + Set_Record_Extension_Part (Def, Rec_Ext_Part); + Mark_Rewrite_Insertion (Rec_Ext_Part); + end if; + + Comp_List := Component_List (Rec_Ext_Part); + + Parent_N := Make_Defining_Identifier (Loc, Name_uParent); + + -- If the derived type inherits its discriminants the type of the + -- _parent field must be constrained by the inherited discriminants + + if Has_Discriminants (T) + and then Nkind (Indic) /= N_Subtype_Indication + and then not Is_Constrained (Entity (Indic)) + then + D := First_Discriminant (T); + while Present (D) loop + Append_To (List_Constr, New_Occurrence_Of (D, Loc)); + Next_Discriminant (D); + end loop; + + Par_Subtype := + Process_Subtype ( + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => List_Constr)), + Def); + + -- Otherwise the original subtype_indication is just what is needed + + else + Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); + end if; + + Set_Parent_Subtype (T, Par_Subtype); + + Comp_Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Parent_N, + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc))); + + if Null_Present (Rec_Ext_Part) then + Set_Component_List (Rec_Ext_Part, + Make_Component_List (Loc, + Component_Items => New_List (Comp_Decl), + Variant_Part => Empty, + Null_Present => False)); + Set_Null_Present (Rec_Ext_Part, False); + + elsif Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Set_Component_Items (Comp_List, New_List (Comp_Decl)); + Set_Null_Present (Comp_List, False); + + else + Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); + end if; + + Analyze (Comp_Decl); + end Expand_Record_Extension; + ------------------------ -- Expand_Tagged_Root -- ------------------------ @@ -6338,1146 +7403,6 @@ package body Exp_Ch3 is return; end Expand_Tagged_Root; - ---------------------- - -- Clean_Task_Names -- - ---------------------- - - procedure Clean_Task_Names - (Typ : Entity_Id; - Proc_Id : Entity_Id) - is - begin - if Has_Task (Typ) - and then not Restriction_Active (No_Implicit_Heap_Allocations) - and then not Global_Discard_Names - and then Tagged_Type_Expansion - then - Set_Uses_Sec_Stack (Proc_Id); - end if; - end Clean_Task_Names; - - ------------------------------ - -- Expand_Freeze_Array_Type -- - ------------------------------ - - procedure Expand_Freeze_Array_Type (N : Node_Id) is - Typ : constant Entity_Id := Entity (N); - Base : constant Entity_Id := Base_Type (Typ); - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Ins_Node : Node_Id; - - begin - if not Is_Bit_Packed_Array (Typ) then - - -- If the component contains tasks, so does the array type. This may - -- not be indicated in the array type because the component may have - -- been a private type at the point of definition. Same if component - -- type is controlled or contains protected objects. - - Set_Has_Task (Base, Has_Task (Comp_Typ)); - Set_Has_Protected (Base, Has_Protected (Comp_Typ)); - Set_Has_Controlled_Component - (Base, Has_Controlled_Component - (Comp_Typ) - or else - Is_Controlled (Comp_Typ)); - - if No (Init_Proc (Base)) then - - -- If this is an anonymous array created for a declaration with - -- an initial value, its init_proc will never be called. The - -- initial value itself may have been expanded into assignments, - -- in which case the object declaration is carries the - -- No_Initialization flag. - - if Is_Itype (Base) - and then Nkind (Associated_Node_For_Itype (Base)) = - N_Object_Declaration - and then - (Present (Expression (Associated_Node_For_Itype (Base))) - or else No_Initialization (Associated_Node_For_Itype (Base))) - then - null; - - -- We do not need an init proc for string or wide [wide] string, - -- since the only time these need initialization in normalize or - -- initialize scalars mode, and these types are treated specially - -- and do not need initialization procedures. - - elsif Is_Standard_String_Type (Base) then - null; - - -- Otherwise we have to build an init proc for the subtype - - else - Build_Array_Init_Proc (Base, N); - end if; - end if; - - if Typ = Base then - if Has_Controlled_Component (Base) then - Build_Controlling_Procs (Base); - - if not Is_Limited_Type (Comp_Typ) - and then Number_Dimensions (Typ) = 1 - then - Build_Slice_Assignment (Typ); - end if; - end if; - - -- Create a finalization master to service the anonymous access - -- components of the array. - - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) - then - -- The finalization master is inserted before the declaration - -- of the array type. The only exception to this is when the - -- array type is an itype, in which case the master appears - -- before the related context. - - if Is_Itype (Typ) then - Ins_Node := Associated_Node_For_Itype (Typ); - else - Ins_Node := Parent (Typ); - end if; - - Build_Finalization_Master - (Typ => Comp_Typ, - For_Anonymous => True, - Context_Scope => Scope (Typ), - Insertion_Node => Ins_Node); - end if; - end if; - - -- For packed case, default initialization, except if the component type - -- is itself a packed structure with an initialization procedure, or - -- initialize/normalize scalars active, and we have a base type, or the - -- type is public, because in that case a client might specify - -- Normalize_Scalars and there better be a public Init_Proc for it. - - elsif (Present (Init_Proc (Component_Type (Base))) - and then No (Base_Init_Proc (Base))) - or else (Init_Or_Norm_Scalars and then Base = Typ) - or else Is_Public (Typ) - then - Build_Array_Init_Proc (Base, N); - end if; - - if Has_Invariants (Component_Type (Base)) - and then Typ = Base - and then In_Open_Scopes (Scope (Component_Type (Base))) - then - -- Generate component invariant checking procedure. This is only - -- relevant if the array type is within the scope of the component - -- type. Otherwise an array object can only be built using the public - -- subprograms for the component type, and calls to those will have - -- invariant checks. The invariant procedure is only generated for - -- a base type, not a subtype. - - Insert_Component_Invariant_Checks - (N, Base, Build_Array_Invariant_Proc (Base, N)); - end if; - end Expand_Freeze_Array_Type; - - ----------------------------------- - -- Expand_Freeze_Class_Wide_Type -- - ----------------------------------- - - procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is - Typ : constant Entity_Id := Entity (N); - Root : constant Entity_Id := Root_Type (Typ); - - function Is_C_Derivation (Typ : Entity_Id) return Boolean; - -- Given a type, determine whether it is derived from a C or C++ root - - --------------------- - -- Is_C_Derivation -- - --------------------- - - function Is_C_Derivation (Typ : Entity_Id) return Boolean is - T : Entity_Id; - - begin - T := Typ; - loop - if Is_CPP_Class (T) - or else Convention (T) = Convention_C - or else Convention (T) = Convention_CPP - then - return True; - end if; - - exit when T = Etype (T); - - T := Etype (T); - end loop; - - return False; - end Is_C_Derivation; - - -- Start of processing for Expand_Freeze_Class_Wide_Type - - begin - -- Certain run-time configurations and targets do not provide support - -- for controlled types. - - if Restriction_Active (No_Finalization) then - return; - - -- Do not create TSS routine Finalize_Address when dispatching calls are - -- disabled since the core of the routine is a dispatching call. - - elsif Restriction_Active (No_Dispatching_Calls) then - return; - - -- Do not create TSS routine Finalize_Address for concurrent class-wide - -- types. Ignore C, C++, CIL and Java types since it is assumed that the - -- non-Ada side will handle their destruction. - - elsif Is_Concurrent_Type (Root) - or else Is_C_Derivation (Root) - or else Convention (Typ) = Convention_CIL - or else Convention (Typ) = Convention_CPP - or else Convention (Typ) = Convention_Java - then - return; - - -- Do not create TSS routine Finalize_Address for .NET/JVM because these - -- targets do not support address arithmetic and unchecked conversions. - - elsif VM_Target /= No_VM then - return; - - -- Do not create TSS routine Finalize_Address when compiling in CodePeer - -- mode since the routine contains an Unchecked_Conversion. - - elsif CodePeer_Mode then - return; - end if; - - -- Create the body of TSS primitive Finalize_Address. This automatically - -- sets the TSS entry for the class-wide type. - - Make_Finalize_Address_Body (Typ); - end Expand_Freeze_Class_Wide_Type; - - ------------------------------------ - -- Expand_Freeze_Enumeration_Type -- - ------------------------------------ - - procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is - Typ : constant Entity_Id := Entity (N); - Loc : constant Source_Ptr := Sloc (Typ); - Ent : Entity_Id; - Lst : List_Id; - Num : Nat; - Arr : Entity_Id; - Fent : Entity_Id; - Ityp : Entity_Id; - Is_Contiguous : Boolean; - Pos_Expr : Node_Id; - Last_Repval : Uint; - - Func : Entity_Id; - pragma Warnings (Off, Func); - - begin - -- Various optimizations possible if given representation is contiguous - - Is_Contiguous := True; - - Ent := First_Literal (Typ); - Last_Repval := Enumeration_Rep (Ent); - - Next_Literal (Ent); - while Present (Ent) loop - if Enumeration_Rep (Ent) - Last_Repval /= 1 then - Is_Contiguous := False; - exit; - else - Last_Repval := Enumeration_Rep (Ent); - end if; - - Next_Literal (Ent); - end loop; - - if Is_Contiguous then - Set_Has_Contiguous_Rep (Typ); - Ent := First_Literal (Typ); - Num := 1; - Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent))); - - else - -- Build list of literal references - - Lst := New_List; - Num := 0; - - Ent := First_Literal (Typ); - while Present (Ent) loop - Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent))); - Num := Num + 1; - Next_Literal (Ent); - end loop; - end if; - - -- Now build an array declaration - - -- typA : array (Natural range 0 .. num - 1) of ctype := - -- (v, v, v, v, v, ....) - - -- where ctype is the corresponding integer type. If the representation - -- is contiguous, we only keep the first literal, which provides the - -- offset for Pos_To_Rep computations. - - Arr := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), 'A')); - - Append_Freeze_Action (Typ, - Make_Object_Declaration (Loc, - Defining_Identifier => Arr, - Constant_Present => True, - - Object_Definition => - Make_Constrained_Array_Definition (Loc, - Discrete_Subtype_Definitions => New_List ( - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc), - Constraint => - Make_Range_Constraint (Loc, - Range_Expression => - Make_Range (Loc, - Low_Bound => - Make_Integer_Literal (Loc, 0), - High_Bound => - Make_Integer_Literal (Loc, Num - 1))))), - - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => New_Occurrence_Of (Typ, Loc))), - - Expression => - Make_Aggregate (Loc, - Expressions => Lst))); - - Set_Enum_Pos_To_Rep (Typ, Arr); - - -- Now we build the function that converts representation values to - -- position values. This function has the form: - - -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is - -- begin - -- case ityp!(A) is - -- when enum-lit'Enum_Rep => return posval; - -- when enum-lit'Enum_Rep => return posval; - -- ... - -- when others => - -- [raise Constraint_Error when F "invalid data"] - -- return -1; - -- end case; - -- end; - - -- Note: the F parameter determines whether the others case (no valid - -- representation) raises Constraint_Error or returns a unique value - -- of minus one. The latter case is used, e.g. in 'Valid code. - - -- Note: the reason we use Enum_Rep values in the case here is to avoid - -- the code generator making inappropriate assumptions about the range - -- of the values in the case where the value is invalid. ityp is a - -- signed or unsigned integer type of appropriate width. - - -- Note: if exceptions are not supported, then we suppress the raise - -- and return -1 unconditionally (this is an erroneous program in any - -- case and there is no obligation to raise Constraint_Error here). We - -- also do this if pragma Restrictions (No_Exceptions) is active. - - -- Is this right??? What about No_Exception_Propagation??? - - -- Representations are signed - - if Enumeration_Rep (First_Literal (Typ)) < 0 then - - -- The underlying type is signed. Reset the Is_Unsigned_Type - -- explicitly, because it might have been inherited from - -- parent type. - - Set_Is_Unsigned_Type (Typ, False); - - if Esize (Typ) <= Standard_Integer_Size then - Ityp := Standard_Integer; - else - Ityp := Universal_Integer; - end if; - - -- Representations are unsigned - - else - if Esize (Typ) <= Standard_Integer_Size then - Ityp := RTE (RE_Unsigned); - else - Ityp := RTE (RE_Long_Long_Unsigned); - end if; - end if; - - -- The body of the function is a case statement. First collect case - -- alternatives, or optimize the contiguous case. - - Lst := New_List; - - -- If representation is contiguous, Pos is computed by subtracting - -- the representation of the first literal. - - if Is_Contiguous then - Ent := First_Literal (Typ); - - if Enumeration_Rep (Ent) = Last_Repval then - - -- Another special case: for a single literal, Pos is zero - - Pos_Expr := Make_Integer_Literal (Loc, Uint_0); - - else - Pos_Expr := - Convert_To (Standard_Integer, - Make_Op_Subtract (Loc, - Left_Opnd => - Unchecked_Convert_To - (Ityp, Make_Identifier (Loc, Name_uA)), - Right_Opnd => - Make_Integer_Literal (Loc, - Intval => Enumeration_Rep (First_Literal (Typ))))); - end if; - - Append_To (Lst, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List ( - Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), - Low_Bound => - Make_Integer_Literal (Loc, - Intval => Enumeration_Rep (Ent)), - High_Bound => - Make_Integer_Literal (Loc, Intval => Last_Repval))), - - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => Pos_Expr)))); - - else - Ent := First_Literal (Typ); - while Present (Ent) loop - Append_To (Lst, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List ( - Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), - Intval => Enumeration_Rep (Ent))), - - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Make_Integer_Literal (Loc, - Intval => Enumeration_Pos (Ent)))))); - - Next_Literal (Ent); - end loop; - end if; - - -- In normal mode, add the others clause with the test - - if not No_Exception_Handlers_Set then - Append_To (Lst, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List ( - Make_Raise_Constraint_Error (Loc, - Condition => Make_Identifier (Loc, Name_uF), - Reason => CE_Invalid_Data), - Make_Simple_Return_Statement (Loc, - Expression => - Make_Integer_Literal (Loc, -1))))); - - -- If either of the restrictions No_Exceptions_Handlers/Propagation is - -- active then return -1 (we cannot usefully raise Constraint_Error in - -- this case). See description above for further details. - - else - Append_To (Lst, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Make_Integer_Literal (Loc, -1))))); - end if; - - -- Now we can build the function body - - Fent := - Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); - - Func := - Make_Subprogram_Body (Loc, - Specification => - Make_Function_Specification (Loc, - Defining_Unit_Name => Fent, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uA), - Parameter_Type => New_Occurrence_Of (Typ, Loc)), - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uF), - Parameter_Type => - New_Occurrence_Of (Standard_Boolean, Loc))), - - Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)), - - Declarations => Empty_List, - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Case_Statement (Loc, - Expression => - Unchecked_Convert_To - (Ityp, Make_Identifier (Loc, Name_uA)), - Alternatives => Lst)))); - - Set_TSS (Typ, Fent); - - -- Set Pure flag (it will be reset if the current context is not Pure). - -- We also pretend there was a pragma Pure_Function so that for purposes - -- of optimization and constant-folding, we will consider the function - -- Pure even if we are not in a Pure context). - - Set_Is_Pure (Fent); - Set_Has_Pragma_Pure_Function (Fent); - - -- Unless we are in -gnatD mode, where we are debugging generated code, - -- this is an internal entity for which we don't need debug info. - - if not Debug_Generated_Code then - Set_Debug_Info_Off (Fent); - end if; - - exception - when RE_Not_Available => - return; - end Expand_Freeze_Enumeration_Type; - - ------------------------------- - -- Expand_Freeze_Record_Type -- - ------------------------------- - - procedure Expand_Freeze_Record_Type (N : Node_Id) is - Def_Id : constant Node_Id := Entity (N); - Type_Decl : constant Node_Id := Parent (Def_Id); - Comp : Entity_Id; - Comp_Typ : Entity_Id; - Has_AACC : Boolean; - Predef_List : List_Id; - - Renamed_Eq : Node_Id := Empty; - -- Defining unit name for the predefined equality function in the case - -- where the type has a primitive operation that is a renaming of - -- predefined equality (but only if there is also an overriding - -- user-defined equality function). Used to pass this entity from - -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. - - Wrapper_Decl_List : List_Id := No_List; - Wrapper_Body_List : List_Id := No_List; - - -- Start of processing for Expand_Freeze_Record_Type - - begin - -- Build discriminant checking functions if not a derived type (for - -- derived types that are not tagged types, always use the discriminant - -- checking functions of the parent type). However, for untagged types - -- the derivation may have taken place before the parent was frozen, so - -- we copy explicitly the discriminant checking functions from the - -- parent into the components of the derived type. - - if not Is_Derived_Type (Def_Id) - or else Has_New_Non_Standard_Rep (Def_Id) - or else Is_Tagged_Type (Def_Id) - then - Build_Discr_Checking_Funcs (Type_Decl); - - elsif Is_Derived_Type (Def_Id) - and then not Is_Tagged_Type (Def_Id) - - -- If we have a derived Unchecked_Union, we do not inherit the - -- discriminant checking functions from the parent type since the - -- discriminants are non existent. - - and then not Is_Unchecked_Union (Def_Id) - and then Has_Discriminants (Def_Id) - then - declare - Old_Comp : Entity_Id; - - begin - Old_Comp := - First_Component (Base_Type (Underlying_Type (Etype (Def_Id)))); - Comp := First_Component (Def_Id); - while Present (Comp) loop - if Ekind (Comp) = E_Component - and then Chars (Comp) = Chars (Old_Comp) - then - Set_Discriminant_Checking_Func (Comp, - Discriminant_Checking_Func (Old_Comp)); - end if; - - Next_Component (Old_Comp); - Next_Component (Comp); - end loop; - end; - end if; - - if Is_Derived_Type (Def_Id) - and then Is_Limited_Type (Def_Id) - and then Is_Tagged_Type (Def_Id) - then - Check_Stream_Attributes (Def_Id); - end if; - - -- Update task, protected, and controlled component flags, because some - -- of the component types may have been private at the point of the - -- record declaration. Detect anonymous access-to-controlled components. - - Has_AACC := False; - - Comp := First_Component (Def_Id); - while Present (Comp) loop - Comp_Typ := Etype (Comp); - - if Has_Task (Comp_Typ) then - Set_Has_Task (Def_Id); - end if; - - if Has_Protected (Comp_Typ) then - Set_Has_Protected (Def_Id); - end if; - - -- Do not set Has_Controlled_Component on a class-wide equivalent - -- type. See Make_CW_Equivalent_Type. - - if not Is_Class_Wide_Equivalent_Type (Def_Id) - and then - (Has_Controlled_Component (Comp_Typ) - or else (Chars (Comp) /= Name_uParent - and then (Is_Controlled_Active (Comp_Typ)))) - then - Set_Has_Controlled_Component (Def_Id); - end if; - - -- Non-self-referential anonymous access-to-controlled component - - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) - and then Designated_Type (Comp_Typ) /= Def_Id - then - Has_AACC := True; - end if; - - Next_Component (Comp); - end loop; - - -- Handle constructors of untagged CPP_Class types - - if not Is_Tagged_Type (Def_Id) and then Is_CPP_Class (Def_Id) then - Set_CPP_Constructors (Def_Id); - end if; - - -- Creation of the Dispatch Table. Note that a Dispatch Table is built - -- for regular tagged types as well as for Ada types deriving from a C++ - -- Class, but not for tagged types directly corresponding to C++ classes - -- In the later case we assume that it is created in the C++ side and we - -- just use it. - - if Is_Tagged_Type (Def_Id) then - - -- Add the _Tag component - - if Underlying_Type (Etype (Def_Id)) = Def_Id then - Expand_Tagged_Root (Def_Id); - end if; - - if Is_CPP_Class (Def_Id) then - Set_All_DT_Position (Def_Id); - - -- Create the tag entities with a minimum decoration - - if Tagged_Type_Expansion then - Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); - end if; - - Set_CPP_Constructors (Def_Id); - - else - if not Building_Static_DT (Def_Id) then - - -- Usually inherited primitives are not delayed but the first - -- Ada extension of a CPP_Class is an exception since the - -- address of the inherited subprogram has to be inserted in - -- the new Ada Dispatch Table and this is a freezing action. - - -- Similarly, if this is an inherited operation whose parent is - -- not frozen yet, it is not in the DT of the parent, and we - -- generate an explicit freeze node for the inherited operation - -- so it is properly inserted in the DT of the current type. - - declare - Elmt : Elmt_Id; - Subp : Entity_Id; - - begin - Elmt := First_Elmt (Primitive_Operations (Def_Id)); - while Present (Elmt) loop - Subp := Node (Elmt); - - if Present (Alias (Subp)) then - if Is_CPP_Class (Etype (Def_Id)) then - Set_Has_Delayed_Freeze (Subp); - - elsif Has_Delayed_Freeze (Alias (Subp)) - and then not Is_Frozen (Alias (Subp)) - then - Set_Is_Frozen (Subp, False); - Set_Has_Delayed_Freeze (Subp); - end if; - end if; - - Next_Elmt (Elmt); - end loop; - end; - end if; - - -- Unfreeze momentarily the type to add the predefined primitives - -- operations. The reason we unfreeze is so that these predefined - -- operations will indeed end up as primitive operations (which - -- must be before the freeze point). - - Set_Is_Frozen (Def_Id, False); - - -- Do not add the spec of predefined primitives in case of - -- CPP tagged type derivations that have convention CPP. - - if Is_CPP_Class (Root_Type (Def_Id)) - and then Convention (Def_Id) = Convention_CPP - then - null; - - -- Do not add the spec of predefined primitives in case of - -- CIL and Java tagged types - - elsif Convention (Def_Id) = Convention_CIL - or else Convention (Def_Id) = Convention_Java - then - null; - - -- Do not add the spec of the predefined primitives if we are - -- compiling under restriction No_Dispatching_Calls. - - elsif not Restriction_Active (No_Dispatching_Calls) then - Make_Predefined_Primitive_Specs - (Def_Id, Predef_List, Renamed_Eq); - Insert_List_Before_And_Analyze (N, Predef_List); - end if; - - -- Ada 2005 (AI-391): For a nonabstract null extension, create - -- wrapper functions for each nonoverridden inherited function - -- with a controlling result of the type. The wrapper for such - -- a function returns an extension aggregate that invokes the - -- parent function. - - if Ada_Version >= Ada_2005 - and then not Is_Abstract_Type (Def_Id) - and then Is_Null_Extension (Def_Id) - then - Make_Controlling_Function_Wrappers - (Def_Id, Wrapper_Decl_List, Wrapper_Body_List); - Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); - end if; - - -- Ada 2005 (AI-251): For a nonabstract type extension, build - -- null procedure declarations for each set of homographic null - -- procedures that are inherited from interface types but not - -- overridden. This is done to ensure that the dispatch table - -- entry associated with such null primitives are properly filled. - - if Ada_Version >= Ada_2005 - and then Etype (Def_Id) /= Def_Id - and then not Is_Abstract_Type (Def_Id) - and then Has_Interfaces (Def_Id) - then - Insert_Actions (N, Make_Null_Procedure_Specs (Def_Id)); - end if; - - Set_Is_Frozen (Def_Id); - if not Is_Derived_Type (Def_Id) - or else Is_Tagged_Type (Etype (Def_Id)) - then - Set_All_DT_Position (Def_Id); - - -- If this is a type derived from an untagged private type whose - -- full view is tagged, the type is marked tagged for layout - -- reasons, but it has no dispatch table. - - elsif Is_Derived_Type (Def_Id) - and then Is_Private_Type (Etype (Def_Id)) - and then not Is_Tagged_Type (Etype (Def_Id)) - then - return; - end if; - - -- Create and decorate the tags. Suppress their creation when - -- VM_Target because the dispatching mechanism is handled - -- internally by the VMs. - - if Tagged_Type_Expansion then - Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); - - -- Generate dispatch table of locally defined tagged type. - -- Dispatch tables of library level tagged types are built - -- later (see Analyze_Declarations). - - if not Building_Static_DT (Def_Id) then - Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); - end if; - - elsif VM_Target /= No_VM then - Append_Freeze_Actions (Def_Id, Make_VM_TSD (Def_Id)); - end if; - - -- If the type has unknown discriminants, propagate dispatching - -- information to its underlying record view, which does not get - -- its own dispatch table. - - if Is_Derived_Type (Def_Id) - and then Has_Unknown_Discriminants (Def_Id) - and then Present (Underlying_Record_View (Def_Id)) - then - declare - Rep : constant Entity_Id := Underlying_Record_View (Def_Id); - begin - Set_Access_Disp_Table - (Rep, Access_Disp_Table (Def_Id)); - Set_Dispatch_Table_Wrappers - (Rep, Dispatch_Table_Wrappers (Def_Id)); - Set_Direct_Primitive_Operations - (Rep, Direct_Primitive_Operations (Def_Id)); - end; - end if; - - -- Make sure that the primitives Initialize, Adjust and Finalize - -- are Frozen before other TSS subprograms. We don't want them - -- Frozen inside. - - if Is_Controlled (Def_Id) then - if not Is_Limited_Type (Def_Id) then - Append_Freeze_Actions (Def_Id, - Freeze_Entity - (Find_Prim_Op (Def_Id, Name_Adjust), Def_Id)); - end if; - - Append_Freeze_Actions (Def_Id, - Freeze_Entity - (Find_Prim_Op (Def_Id, Name_Initialize), Def_Id)); - - Append_Freeze_Actions (Def_Id, - Freeze_Entity - (Find_Prim_Op (Def_Id, Name_Finalize), Def_Id)); - end if; - - -- Freeze rest of primitive operations. There is no need to handle - -- the predefined primitives if we are compiling under restriction - -- No_Dispatching_Calls. - - if not Restriction_Active (No_Dispatching_Calls) then - Append_Freeze_Actions - (Def_Id, Predefined_Primitive_Freeze (Def_Id)); - end if; - end if; - - -- In the untagged case, ever since Ada 83 an equality function must - -- be provided for variant records that are not unchecked unions. - -- In Ada 2012 the equality function composes, and thus must be built - -- explicitly just as for tagged records. - - elsif Has_Discriminants (Def_Id) - and then not Is_Limited_Type (Def_Id) - then - declare - Comps : constant Node_Id := - Component_List (Type_Definition (Type_Decl)); - begin - if Present (Comps) - and then Present (Variant_Part (Comps)) - then - Build_Variant_Record_Equality (Def_Id); - end if; - end; - - -- Otherwise create primitive equality operation (AI05-0123) - - -- This is done unconditionally to ensure that tools can be linked - -- properly with user programs compiled with older language versions. - -- In addition, this is needed because "=" composes for bounded strings - -- in all language versions (see Exp_Ch4.Expand_Composite_Equality). - - elsif Comes_From_Source (Def_Id) - and then Convention (Def_Id) = Convention_Ada - and then not Is_Limited_Type (Def_Id) - then - Build_Untagged_Equality (Def_Id); - end if; - - -- Before building the record initialization procedure, if we are - -- dealing with a concurrent record value type, then we must go through - -- the discriminants, exchanging discriminals between the concurrent - -- type and the concurrent record value type. See the section "Handling - -- of Discriminants" in the Einfo spec for details. - - if Is_Concurrent_Record_Type (Def_Id) - and then Has_Discriminants (Def_Id) - then - declare - Ctyp : constant Entity_Id := - Corresponding_Concurrent_Type (Def_Id); - Conc_Discr : Entity_Id; - Rec_Discr : Entity_Id; - Temp : Entity_Id; - - begin - Conc_Discr := First_Discriminant (Ctyp); - Rec_Discr := First_Discriminant (Def_Id); - while Present (Conc_Discr) loop - Temp := Discriminal (Conc_Discr); - Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); - Set_Discriminal (Rec_Discr, Temp); - - Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); - Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); - - Next_Discriminant (Conc_Discr); - Next_Discriminant (Rec_Discr); - end loop; - end; - end if; - - if Has_Controlled_Component (Def_Id) then - Build_Controlling_Procs (Def_Id); - end if; - - Adjust_Discriminants (Def_Id); - - if Tagged_Type_Expansion or else not Is_Interface (Def_Id) then - - -- Do not need init for interfaces on e.g. CIL since they're - -- abstract. Helps operation of peverify (the PE Verify tool). - - Build_Record_Init_Proc (Type_Decl, Def_Id); - end if; - - -- For tagged type that are not interfaces, build bodies of primitive - -- operations. Note: do this after building the record initialization - -- procedure, since the primitive operations may need the initialization - -- routine. There is no need to add predefined primitives of interfaces - -- because all their predefined primitives are abstract. - - if Is_Tagged_Type (Def_Id) and then not Is_Interface (Def_Id) then - - -- Do not add the body of predefined primitives in case of CPP tagged - -- type derivations that have convention CPP. - - if Is_CPP_Class (Root_Type (Def_Id)) - and then Convention (Def_Id) = Convention_CPP - then - null; - - -- Do not add the body of predefined primitives in case of CIL and - -- Java tagged types. - - elsif Convention (Def_Id) = Convention_CIL - or else Convention (Def_Id) = Convention_Java - then - null; - - -- Do not add the body of the predefined primitives if we are - -- compiling under restriction No_Dispatching_Calls or if we are - -- compiling a CPP tagged type. - - elsif not Restriction_Active (No_Dispatching_Calls) then - - -- Create the body of TSS primitive Finalize_Address. This must - -- be done before the bodies of all predefined primitives are - -- created. If Def_Id is limited, Stream_Input and Stream_Read - -- may produce build-in-place allocations and for those the - -- expander needs Finalize_Address. - - Make_Finalize_Address_Body (Def_Id); - Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); - Append_Freeze_Actions (Def_Id, Predef_List); - end if; - - -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden - -- inherited functions, then add their bodies to the freeze actions. - - if Present (Wrapper_Body_List) then - Append_Freeze_Actions (Def_Id, Wrapper_Body_List); - end if; - - -- Create extra formals for the primitive operations of the type. - -- This must be done before analyzing the body of the initialization - -- procedure, because a self-referential type might call one of these - -- primitives in the body of the init_proc itself. - - declare - Elmt : Elmt_Id; - Subp : Entity_Id; - - begin - Elmt := First_Elmt (Primitive_Operations (Def_Id)); - while Present (Elmt) loop - Subp := Node (Elmt); - if not Has_Foreign_Convention (Subp) - and then not Is_Predefined_Dispatching_Operation (Subp) - then - Create_Extra_Formals (Subp); - end if; - - Next_Elmt (Elmt); - end loop; - end; - end if; - - -- Create a heterogeneous finalization master to service the anonymous - -- access-to-controlled components of the record type. - - if Has_AACC then - declare - Encl_Scope : constant Entity_Id := Scope (Def_Id); - Ins_Node : constant Node_Id := Parent (Def_Id); - Loc : constant Source_Ptr := Sloc (Def_Id); - Fin_Mas_Id : Entity_Id; - - Attributes_Set : Boolean := False; - Master_Built : Boolean := False; - -- Two flags which control the creation and initialization of a - -- common heterogeneous master. - - begin - Comp := First_Component (Def_Id); - while Present (Comp) loop - Comp_Typ := Etype (Comp); - - -- A non-self-referential anonymous access-to-controlled - -- component. - - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) - and then Designated_Type (Comp_Typ) /= Def_Id - then - if VM_Target = No_VM then - - -- Build a homogeneous master for the first anonymous - -- access-to-controlled component. This master may be - -- converted into a heterogeneous collection if more - -- components are to follow. - - if not Master_Built then - Master_Built := True; - - -- All anonymous access-to-controlled types allocate - -- on the global pool. Note that the finalization - -- master and the associated storage pool must be set - -- on the root type (both are "root type only"). - - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - - Build_Finalization_Master - (Typ => Root_Type (Comp_Typ), - For_Anonymous => True, - Context_Scope => Encl_Scope, - Insertion_Node => Ins_Node); - - Fin_Mas_Id := Finalization_Master (Comp_Typ); - - -- Subsequent anonymous access-to-controlled components - -- reuse the available master. - - else - -- All anonymous access-to-controlled types allocate - -- on the global pool. Note that both the finalization - -- master and the associated storage pool must be set - -- on the root type (both are "root type only"). - - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - - -- Shared the master among multiple components - - Set_Finalization_Master - (Root_Type (Comp_Typ), Fin_Mas_Id); - - -- Convert the master into a heterogeneous collection. - -- Generate: - -- Set_Is_Heterogeneous (<Fin_Mas_Id>); - - if not Attributes_Set then - Attributes_Set := True; - - Insert_Action (Ins_Node, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Set_Is_Heterogeneous), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Fin_Mas_Id, Loc)))); - end if; - end if; - - -- Since .NET/JVM targets do not support heterogeneous - -- masters, each component must have its own master. - - else - Build_Finalization_Master - (Typ => Comp_Typ, - For_Anonymous => True, - Context_Scope => Encl_Scope, - Insertion_Node => Ins_Node); - end if; - end if; - - Next_Component (Comp); - end loop; - end; - end if; - - -- Check whether individual components have a defined invariant, and add - -- the corresponding component invariant checks. - - -- Do not create an invariant procedure for some internally generated - -- subtypes, in particular those created for objects of a class-wide - -- type. Such types may have components to which invariant apply, but - -- the corresponding checks will be applied when an object of the parent - -- type is constructed. - - -- Such objects will show up in a class-wide postcondition, and the - -- invariant will be checked, if necessary, upon return from the - -- enclosing subprogram. - - if not Is_Class_Wide_Equivalent_Type (Def_Id) then - Insert_Component_Invariant_Checks - (N, Def_Id, Build_Record_Invariant_Proc (Def_Id, N)); - end if; - end Expand_Freeze_Record_Type; - ------------------------------ -- Freeze_Stream_Operations -- ------------------------------ @@ -7523,10 +7448,6 @@ package body Exp_Ch3 is -- node using Append_Freeze_Actions. function Freeze_Type (N : Node_Id) return Boolean is - GM : constant Ghost_Mode_Type := Ghost_Mode; - -- Save the current Ghost mode in effect in case the type being frozen - -- sets a different mode. - procedure Process_RACW_Types (Typ : Entity_Id); -- Validate and generate stubs for all RACW types associated with type -- Typ. @@ -7535,9 +7456,6 @@ package body Exp_Ch3 is -- Associate type Typ's Finalize_Address primitive with the finalization -- masters of pending access-to-Typ types. - procedure Restore_Globals; - -- Restore the values of all saved global variables - ------------------------ -- Process_RACW_Types -- ------------------------ @@ -7618,26 +7536,19 @@ package body Exp_Ch3 is end if; end Process_Pending_Access_Types; - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - -- Local variables Def_Id : constant Entity_Id := Entity (N); Result : Boolean := False; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + -- Start of processing for Freeze_Type begin - -- The type being frozen may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- freezing are properly flagged as ignored Ghost. + -- The type being frozen may be subject to pragma Ghost. Set the mode + -- now to ensure that any nodes generated during freezing are properly + -- marked as Ghost. Set_Ghost_Mode (N, Def_Id); @@ -7798,10 +7709,6 @@ package body Exp_Ch3 is elsif Ada_Version >= Ada_2012 and then Present (Associated_Storage_Pool (Def_Id)) - -- Omit this check on .NET/JVM where pools are not supported - - and then VM_Target = No_VM - -- Omit this check for the case of a configurable run-time that -- does not provide package System.Storage_Pools.Subpools. @@ -7954,12 +7861,12 @@ package body Exp_Ch3 is Process_Pending_Access_Types (Def_Id); Freeze_Stream_Operations (N, Def_Id); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; exception when RE_Not_Available => - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return False; end Freeze_Type; @@ -9910,11 +9817,6 @@ package body Exp_Ch3 is if Restriction_Active (No_Finalization) then null; - -- Finalization is not available for CIL value types - - elsif Is_Value_Type (Tag_Typ) then - null; - else if not Is_Limited_Type (Tag_Typ) then Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); @@ -10559,10 +10461,7 @@ package body Exp_Ch3 is -- we don't want an abstract version created because types derived from -- the abstract type may not even have Input available (for example if -- derived from a private view of the abstract type that doesn't have - -- a visible Input), but a VM such as .NET or the Java VM can treat the - -- operation as inherited anyway, and we don't want an abstract function - -- to be (implicitly) inherited in that case because it can lead to a VM - -- exception. + -- a visible Input). -- Do not generate stream routines for type Finalization_Master because -- a master may never appear in types and therefore cannot be read or diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index b7778da158b..0b1fe7920a0 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -463,7 +463,7 @@ package body Exp_Ch4 is -- Local variables Loc : constant Source_Ptr := Sloc (Unit_Id); - Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Unit_Decl); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl); Decls : List_Id; FM_Id : Entity_Id; Pref : Character; @@ -544,37 +544,30 @@ package body Exp_Ch4 is -- Step 2: Initialization actions - -- Do not set the base pool and mode of operation on .NET/JVM since - -- those targets do not support pools and all VM masters defaulted to - -- heterogeneous. - - if VM_Target = No_VM then - - -- Generate: - -- Set_Base_Pool - -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access); + -- Generate: + -- Set_Base_Pool + -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access); - Insert_And_Analyze (Decls, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (FM_Id, Loc), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc), - Attribute_Name => Name_Unrestricted_Access)))); + Insert_And_Analyze (Decls, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (FM_Id, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc), + Attribute_Name => Name_Unrestricted_Access)))); - -- Generate: - -- Set_Is_Heterogeneous (<FM_Id>); + -- Generate: + -- Set_Is_Heterogeneous (<FM_Id>); - Insert_And_Analyze (Decls, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (FM_Id, Loc)))); - end if; + Insert_And_Analyze (Decls, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (FM_Id, Loc)))); Pop_Scope; return FM_Id; @@ -762,7 +755,7 @@ package body Exp_Ch4 is begin if Ada_Version >= Ada_2005 and then Is_Class_Wide_Type (DesigT) - and then (Tagged_Type_Expansion or else VM_Target /= No_VM) + and then Tagged_Type_Expansion and then not Scope_Suppress.Suppress (Accessibility_Check) and then (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT) @@ -1079,21 +1072,6 @@ package body Exp_Ch4 is Build_Allocate_Deallocate_Proc (Temp_Decl, True); Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); - -- Attach the object to the associated finalization master. - -- This is done manually on .NET/JVM since those compilers do - -- no support pools and can't benefit from internally generated - -- Allocate / Deallocate procedures. - - if VM_Target /= No_VM - and then Is_Controlled (DesigT) - and then Present (Finalization_Master (PtrT)) - then - Insert_Action (N, - Make_Attach_Call - (Obj_Ref => New_Occurrence_Of (Temp, Loc), - Ptr_Typ => PtrT)); - end if; - else Node := Relocate_Node (N); Set_Analyzed (Node); @@ -1107,21 +1085,6 @@ package body Exp_Ch4 is Insert_Action (N, Temp_Decl); Build_Allocate_Deallocate_Proc (Temp_Decl, True); - - -- Attach the object to the associated finalization master. - -- This is done manually on .NET/JVM since those compilers do - -- no support pools and can't benefit from internally generated - -- Allocate / Deallocate procedures. - - if VM_Target /= No_VM - and then Is_Controlled (DesigT) - and then Present (Finalization_Master (PtrT)) - then - Insert_Action (N, - Make_Attach_Call - (Obj_Ref => New_Occurrence_Of (Temp, Loc), - Ptr_Typ => PtrT)); - end if; end if; -- Ada 2005 (AI-251): Handle allocators whose designated type is an @@ -1223,7 +1186,7 @@ package body Exp_Ch4 is -- Generate the tag assignment - -- Suppress the tag assignment when VM_Target because VM tags are + -- Suppress the tag assignment for VM targets because VM tags are -- represented implicitly in objects. if not Tagged_Type_Expansion then @@ -1342,21 +1305,6 @@ package body Exp_Ch4 is Build_Allocate_Deallocate_Proc (Temp_Decl, True); Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); - -- Attach the object to the associated finalization master. Thisis - -- done manually on .NET/JVM since those compilers do no support - -- pools and cannot benefit from internally generated Allocate and - -- Deallocate procedures. - - if VM_Target /= No_VM - and then Is_Controlled (DesigT) - and then Present (Finalization_Master (PtrT)) - then - Insert_Action (N, - Make_Attach_Call - (Obj_Ref => New_Occurrence_Of (Temp, Loc), - Ptr_Typ => PtrT)); - end if; - Rewrite (N, New_Occurrence_Of (Temp, Loc)); Analyze_And_Resolve (N, PtrT); @@ -1529,12 +1477,10 @@ package body Exp_Ch4 is begin -- Deal first with unpacked case, where we can call a runtime routine -- except that we avoid this for targets for which are not addressable - -- by bytes, and for the JVM/CIL, since they do not support direct - -- addressing of array components. + -- by bytes. if not Is_Bit_Packed_Array (Typ1) and then Byte_Addressable - and then VM_Target = No_VM then -- The call we generate is: @@ -1587,37 +1533,43 @@ package body Exp_Ch4 is end if; end if; - Remove_Side_Effects (Op1, Name_Req => True); - Remove_Side_Effects (Op2, Name_Req => True); + if RTE_Available (Comp) then - Rewrite (Op1, - Make_Function_Call (Sloc (Op1), - Name => New_Occurrence_Of (RTE (Comp), Loc), + -- Expand to a call only if the runtime function is available, + -- otherwise fall back to inline code. - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Op1), - Attribute_Name => Name_Address), + Remove_Side_Effects (Op1, Name_Req => True); + Remove_Side_Effects (Op2, Name_Req => True); - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Op2), - Attribute_Name => Name_Address), + Rewrite (Op1, + Make_Function_Call (Sloc (Op1), + Name => New_Occurrence_Of (RTE (Comp), Loc), - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Op1), - Attribute_Name => Name_Length), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op1), + Attribute_Name => Name_Address), - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Op2), - Attribute_Name => Name_Length)))); + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op2), + Attribute_Name => Name_Address), - Rewrite (Op2, - Make_Integer_Literal (Sloc (Op2), - Intval => Uint_0)); + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op1), + Attribute_Name => Name_Length), - Analyze_And_Resolve (Op1, Standard_Integer); - Analyze_And_Resolve (Op2, Standard_Integer); - return; + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op2), + Attribute_Name => Name_Length)))); + + Rewrite (Op2, + Make_Integer_Literal (Sloc (Op2), + Intval => Uint_0)); + + Analyze_And_Resolve (Op1, Standard_Integer); + Analyze_And_Resolve (Op2, Standard_Integer); + return; + end if; end if; -- Cases where we cannot make runtime call @@ -1674,10 +1626,6 @@ package body Exp_Ch4 is Insert_Action (N, Func_Body); Rewrite (N, Expr); Analyze_And_Resolve (N, Standard_Boolean); - - exception - when RE_Not_Available => - return; end Expand_Array_Comparison; --------------------------- @@ -4322,10 +4270,9 @@ package body Exp_Ch4 is end if; -- Anonymous access-to-controlled types allocate on the global pool. - -- Do not set this attribute on .NET/JVM since those targets do not - -- support pools. Note that this is a "root type only" attribute. + -- Note that this is a "root type only" attribute. - if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then + if No (Associated_Storage_Pool (PtrT)) then if Present (Rel_Typ) then Set_Associated_Storage_Pool (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ)); @@ -4361,9 +4308,7 @@ package body Exp_Ch4 is Set_Storage_Pool (N, Pool); if Is_RTE (Pool, RE_SS_Pool) then - if VM_Target = No_VM then - Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); - end if; + Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); -- In the case of an allocator for a simple storage pool, locate -- and save a reference to the pool type's Allocate routine. @@ -4563,12 +4508,9 @@ package body Exp_Ch4 is if No_Initialization (N) then -- Even though this might be a simple allocation, create a custom - -- Allocate if the context requires it. Since .NET/JVM compilers - -- do not support pools, this step is skipped. + -- Allocate if the context requires it. - if VM_Target = No_VM - and then Present (Finalization_Master (PtrT)) - then + if Present (Finalization_Master (PtrT)) then Build_Allocate_Deallocate_Proc (N => N, Is_Allocate => True); @@ -4870,24 +4812,6 @@ package body Exp_Ch4 is Make_Init_Call (Obj_Ref => New_Copy_Tree (Init_Arg1), Typ => T)); - - -- Special processing for .NET/JVM, the allocated object is - -- attached to the finalization master. Generate: - - -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1)); - - -- Types derived from [Limited_]Controlled are the only ones - -- considered since they have fields Prev and Next. - - if VM_Target /= No_VM - and then Is_Controlled (T) - and then Present (Finalization_Master (PtrT)) - then - Insert_Action (N, - Make_Attach_Call - (Obj_Ref => New_Copy_Tree (Init_Arg1), - Ptr_Typ => PtrT)); - end if; end if; Rewrite (N, New_Occurrence_Of (Temp, Loc)); @@ -4940,12 +4864,14 @@ package body Exp_Ch4 is return; end if; - -- If the case expression is a predicate specification, do not - -- expand, because it will be converted to the proper predicate - -- form when building the predicate function. + -- If the case expression is a predicate specification, and the type + -- to which it applies has a static predicate aspect, do not expand, + -- because it will be converted to the proper predicate form later. if Ekind_In (Current_Scope, E_Function, E_Procedure) and then Is_Predicate_Function (Current_Scope) + and then + Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope))) then return; end if; @@ -5117,12 +5043,49 @@ package body Exp_Ch4 is -------------------------------------- procedure Expand_N_Expression_With_Actions (N : Node_Id) is + Acts : constant List_Id := Actions (N); + + procedure Force_Boolean_Evaluation (Expr : Node_Id); + -- Force the evaluation of Boolean expression Expr + function Process_Action (Act : Node_Id) return Traverse_Result; -- Inspect and process a single action of an expression_with_actions for -- transient controlled objects. If such objects are found, the routine -- generates code to clean them up when the context of the expression is -- evaluated or elaborated. + ------------------------------ + -- Force_Boolean_Evaluation -- + ------------------------------ + + procedure Force_Boolean_Evaluation (Expr : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Flag_Decl : Node_Id; + Flag_Id : Entity_Id; + + begin + -- Relocate the expression to the actions list by capturing its value + -- in a Boolean flag. Generate: + -- Flag : constant Boolean := Expr; + + Flag_Id := Make_Temporary (Loc, 'F'); + + Flag_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => Relocate_Node (Expr)); + + Append (Flag_Decl, Acts); + Analyze (Flag_Decl); + + -- Replace the expression with a reference to the flag + + Rewrite (Expression (N), New_Occurrence_Of (Flag_Id, Loc)); + Analyze (Expression (N)); + end Force_Boolean_Evaluation; + -------------------- -- Process_Action -- -------------------- @@ -5155,9 +5118,7 @@ package body Exp_Ch4 is -- Local variables - Acts : constant List_Id := Actions (N); - Expr : constant Node_Id := Expression (N); - Act : Node_Id; + Act : Node_Id; -- Start of processing for Expand_N_Expression_With_Actions @@ -5165,7 +5126,7 @@ package body Exp_Ch4 is -- Do not evaluate the expression when it denotes an entity because the -- expression_with_actions node will be replaced by the reference. - if Is_Entity_Name (Expr) then + if Is_Entity_Name (Expression (N)) then null; -- Do not evaluate the expression when there are no actions because the @@ -5195,11 +5156,23 @@ package body Exp_Ch4 is -- <finalize Trans_Id> -- in Val end; - -- It is now safe to finalize the transient controlled object at the end - -- of the actions list. + -- Once this transformation is performed, it is safe to finalize the + -- transient controlled object at the end of the actions list. + + -- Note that Force_Evaluation does not remove side effects in operators + -- because it assumes that all operands are evaluated and side effect + -- free. This is not the case when an operand depends implicitly on the + -- transient controlled object through the use of access types. + + elsif Is_Boolean_Type (Etype (Expression (N))) then + Force_Boolean_Evaluation (Expression (N)); + + -- The expression of an expression_with_actions node may not necessarily + -- be Boolean when the node appears in an if expression. In this case do + -- the usual forced evaluation to encapsulate potential aliasing. else - Force_Evaluation (Expr); + Force_Evaluation (Expression (N)); end if; -- Process all transient controlled objects found within the actions of @@ -5520,9 +5493,6 @@ package body Exp_Ch4 is Rop : constant Node_Id := Right_Opnd (N); Static : constant Boolean := Is_OK_Static_Expression (N); - Ltyp : Entity_Id; - Rtyp : Entity_Id; - procedure Substitute_Valid_Check; -- Replaces node N by Lop'Valid. This is done when we have an explicit -- test for the left operand being in range of its subtype. @@ -5532,6 +5502,49 @@ package body Exp_Ch4 is ---------------------------- procedure Substitute_Valid_Check is + function Is_OK_Object_Reference (Nod : Node_Id) return Boolean; + -- Determine whether arbitrary node Nod denotes a source object that + -- may safely act as prefix of attribute 'Valid. + + ---------------------------- + -- Is_OK_Object_Reference -- + ---------------------------- + + function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is + Obj_Ref : Node_Id; + + begin + -- Inspect the original operand + + Obj_Ref := Original_Node (Nod); + + -- The object reference must be a source construct, otherwise the + -- codefix suggestion may refer to nonexistent code from a user + -- perspective. + + if Comes_From_Source (Obj_Ref) then + + -- Recover the actual object reference. There may be more cases + -- to consider??? + + loop + if Nkind_In (Obj_Ref, N_Type_Conversion, + N_Unchecked_Type_Conversion) + then + Obj_Ref := Expression (Obj_Ref); + else + exit; + end if; + end loop; + + return Is_Object_Reference (Obj_Ref); + end if; + + return False; + end Is_OK_Object_Reference; + + -- Start of processing for Substitute_Valid_Check + begin Rewrite (N, Make_Attribute_Reference (Loc, @@ -5540,20 +5553,27 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Restyp); - -- Give warning unless overflow checking is MINIMIZED or ELIMINATED, - -- in which case, this usage makes sense, and in any case, we have - -- actually eliminated the danger of optimization above. + -- Emit a warning when the left-hand operand of the membership test + -- is a source object, otherwise the use of attribute 'Valid would be + -- illegal. The warning is not given when overflow checking is either + -- MINIMIZED or ELIMINATED, as the danger of optimization has been + -- eliminated above. - if Overflow_Check_Mode not in Minimized_Or_Eliminated then + if Is_OK_Object_Reference (Lop) + and then Overflow_Check_Mode not in Minimized_Or_Eliminated + then Error_Msg_N ("??explicit membership test may be optimized away", N); Error_Msg_N -- CODEFIX ("\??use ''Valid attribute instead", N); end if; - - return; end Substitute_Valid_Check; + -- Local variables + + Ltyp : Entity_Id; + Rtyp : Entity_Id; + -- Start of processing for Expand_N_In begin @@ -5604,11 +5624,6 @@ package body Exp_Ch4 is and then Nkind (Rop) in N_Has_Entity and then Ltyp = Entity (Rop) - -- Skip in VM mode, where we have no sense of invalid values. The - -- warning still seems relevant, but not important enough to worry. - - and then VM_Target = No_VM - -- Skip this for predicated types, where such expressions are a -- reasonable way of testing if something meets the predicate. @@ -5684,10 +5699,6 @@ package body Exp_Ch4 is -- Relevant only for source cases and then Comes_From_Source (N) - - -- Omit for VM cases, where we don't have invalid values - - and then VM_Target = No_VM then Substitute_Valid_Check; goto Leave; @@ -5845,10 +5856,8 @@ package body Exp_Ch4 is if Is_Tagged_Type (Typ) then - -- No expansion will be performed when VM_Target, as the VM - -- back-ends will handle the membership tests directly (tags - -- are not explicitly represented in Java objects, so the - -- normal tagged membership expansion is not what we want). + -- No expansion will be performed for VM targets, as the VM + -- back-ends will handle the membership tests directly. if Tagged_Type_Expansion then Tagged_Membership (N, SCIL_Node, New_N); @@ -6105,11 +6114,9 @@ package body Exp_Ch4 is Left_Opnd => Obj, Right_Opnd => Make_Null (Loc)))); - -- No expansion will be performed when VM_Target, as + -- No expansion will be performed for VM targets, as -- the VM back-ends will handle the membership tests - -- directly (tags are not explicitly represented in - -- Java objects, so the normal tagged membership - -- expansion is not what we want). + -- directly. if Tagged_Type_Expansion then @@ -6317,7 +6324,7 @@ package body Exp_Ch4 is N_Procedure_Call_Statement) or else (Nkind (Parnt) = N_Parameter_Association and then - Nkind (Parent (Parnt)) = N_Procedure_Call_Statement) + Nkind (Parent (Parnt)) = N_Procedure_Call_Statement) then return; @@ -9807,7 +9814,7 @@ package body Exp_Ch4 is if not Is_Discrete_Type (Etype (N)) then null; - -- Don't do this on the left hand of an assignment statement. + -- Don't do this on the left-hand side of an assignment statement. -- Normally one would think that references like this would not -- occur, but they do in generated code, and mean that we really -- do want to assign the discriminant. @@ -10252,7 +10259,7 @@ package body Exp_Ch4 is Cons := No_List; -- If type is unconstrained we have to add a constraint, copied - -- from the actual value of the left hand side. + -- from the actual value of the left-hand side. if not Is_Constrained (Target_Type) then if Has_Discriminants (Operand_Type) then @@ -11449,15 +11456,6 @@ package body Exp_Ch4 is or else Chars (Comp) = Name_uTag - -- The .NET/JVM version of type Root_Controlled contains two - -- fields which should not be considered part of the object. To - -- achieve proper equiality between two controlled objects on - -- .NET/JVM, skip _Parent whenever it has type Root_Controlled. - - or else (Chars (Comp) = Name_uParent - and then VM_Target /= No_VM - and then Etype (Comp) = RTE (RE_Root_Controlled)) - -- Skip interface elements (secondary tags???) or else Is_Interface (Etype (Comp))); @@ -13255,11 +13253,6 @@ package body Exp_Ch4 is if Component_Size (Etype (Lhs)) /= System_Storage_Unit then return False; - -- Cannot do in place stuff on VM_Target since cannot pass addresses - - elsif VM_Target /= No_VM then - return False; - -- Cannot do in place stuff if non-standard Boolean representation elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 7156c76a8ef..dbefc051d47 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -130,9 +130,6 @@ package body Exp_Ch5 is -- Expand loop over arrays and containers that uses the form "for X of C" -- with an optional subtype mark, or "for Y in C". - procedure Expand_Iterator_Loop_Over_Array (N : Node_Id); - -- Expand loop over arrays that uses the form "for X of C" - procedure Expand_Iterator_Loop_Over_Container (N : Node_Id; Isc : Node_Id; @@ -387,14 +384,6 @@ package body Exp_Ch5 is and then (not Is_Constrained (Etype (Lhs)) or else not Is_First_Subtype (Etype (Lhs))) - - -- In the case of compiling for the Java or .NET Virtual Machine, - -- slices are always passed by making a copy, so we don't have to - -- worry about overlap. We also want to prevent generation of "<" - -- comparisons for array addresses, since that's a meaningless - -- operation on the VM. - - and then VM_Target = No_VM then Set_Forwards_OK (N, False); Set_Backwards_OK (N, False); @@ -764,7 +753,7 @@ package body Exp_Ch5 is -- The GCC back end can deal with all cases of overlap by falling -- back to memmove if it cannot use a more efficient approach. - if VM_Target = No_VM and not AAMP_On_Target then + if not AAMP_On_Target then return; -- Assume other back ends can handle it if Forwards_OK is set @@ -937,9 +926,9 @@ package body Exp_Ch5 is -- We normally compare addresses to find out which way round to -- do the loop, since this is reliable, and handles the cases of -- parameters, conversions etc. But we can't do that in the bit - -- packed case or the VM case, because addresses don't work there. + -- packed case, because addresses don't work there. - if not Is_Bit_Packed_Array (L_Type) and then VM_Target = No_VM then + if not Is_Bit_Packed_Array (L_Type) then Condition := Make_Op_Le (Loc, Left_Opnd => @@ -1627,22 +1616,6 @@ package body Exp_Ch5 is -- cannot just be passed on to the back end in untransformed state. procedure Expand_N_Assignment_Statement (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - - procedure Restore_Globals; - -- Restore the values of all saved global variables - - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - - -- Local variables - Crep : constant Boolean := Change_Of_Representation (N); Lhs : constant Node_Id := Name (N); Loc : constant Source_Ptr := Sloc (N); @@ -1650,12 +1623,12 @@ package body Exp_Ch5 is Typ : constant Entity_Id := Underlying_Type (Etype (Lhs)); Exp : Node_Id; - -- Start of processing for Expand_N_Assignment_Statement + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; begin - -- The assignment statement may be Ghost if the left hand side is Ghost. + -- The assignment statement is Ghost when the left hand side is Ghost. -- Set the mode now to ensure that any nodes generated during expansion - -- are properly flagged as ignored Ghost. + -- are properly marked as Ghost. Set_Ghost_Mode (N); @@ -1668,7 +1641,7 @@ package body Exp_Ch5 is if Componentwise_Assignment (N) then Expand_Assign_Record (N); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -1763,7 +1736,7 @@ package body Exp_Ch5 is Rewrite (N, Call); Analyze (N); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; end; @@ -1914,7 +1887,7 @@ package body Exp_Ch5 is Rewrite (N, Make_Null_Statement (Loc)); Analyze (N); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -2134,7 +2107,7 @@ package body Exp_Ch5 is if not Crep then Expand_Bit_Packed_Element_Set (N); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; -- Change of representation case @@ -2181,14 +2154,6 @@ package body Exp_Ch5 is then Make_Build_In_Place_Call_In_Assignment (N, Rhs); - elsif Is_Tagged_Type (Typ) and then Is_Value_Type (Etype (Lhs)) then - - -- Nothing to do for valuetypes - -- ??? Set_Scope_Is_Transient (False); - - Restore_Globals; - return; - elsif Is_Tagged_Type (Typ) or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ)) then @@ -2224,7 +2189,6 @@ package body Exp_Ch5 is -- generated. or else (Is_Tagged_Type (Typ) - and then not Is_Value_Type (Etype (Lhs)) and then Chars (Current_Scope) /= Name_uAssign and then Expand_Ctrl_Actions and then @@ -2242,7 +2206,7 @@ package body Exp_Ch5 is -- expansion, since they would be missed in -gnatc mode ??? Error_Msg_N ("assignment not available on limited type", N); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -2413,7 +2377,7 @@ package body Exp_Ch5 is -- it with all checks suppressed. Analyze (N, Suppress => All_Checks); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end Tagged_Case; @@ -2431,7 +2395,7 @@ package body Exp_Ch5 is end loop; Expand_Assign_Array (N, Actual_Rhs); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end; @@ -2439,7 +2403,7 @@ package body Exp_Ch5 is elsif Is_Record_Type (Typ) then Expand_Assign_Record (N); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; -- Scalar types. This is where we perform the processing related to the @@ -2552,11 +2516,11 @@ package body Exp_Ch5 is end if; end if; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; exception when RE_Not_Available => - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end Expand_N_Assignment_Statement; @@ -2590,9 +2554,20 @@ package body Exp_Ch5 is -- If the value is static but its subtype is predicated and the value -- does not obey the predicate, the value is marked non-static, and - -- there can be no corresponding static alternative. + -- there can be no corresponding static alternative. In that case we + -- replace the case statement with an exception, regardless of whether + -- assertions are enabled or not. if Compile_Time_Known_Value (Expr) + and then Has_Predicates (Etype (Expr)) + and then not Is_OK_Static_Expression (Expr) + then + Rewrite (N, + Make_Raise_Constraint_Error (Loc, Reason => CE_Invalid_Data)); + Analyze (N); + return; + + elsif Compile_Time_Known_Value (Expr) and then (not Has_Predicates (Etype (Expr)) or else Is_Static_Expression (Expr)) then @@ -2921,8 +2896,23 @@ package body Exp_Ch5 is -- Cursor := Next (Container, Cursor); -- end loop; + -- However this expansion is not legal if the element is indefinite. + -- In that case we create a block to hold a variable declaration + -- initialized with a call to Element, and generate: + + -- Cursor : Cursor_type := First (Container); + -- while Has_Element (Cursor, Container) loop + -- declare + -- Elmt : Element-Type := Element (Container, Cursor); + -- begin + -- <original loop statements> + -- Cursor := Next (Container, Cursor); + -- end; + -- end loop; + Build_Formal_Container_Iteration (N, Container, Cursor, Init, Advance, New_Loop); + Append_To (Stats, Advance); Set_Ekind (Cursor, E_Variable); Insert_Action (N, Init); @@ -2934,33 +2924,54 @@ package body Exp_Ch5 is Defining_Identifier => Element, Object_Definition => New_Occurrence_Of (Etype (Element_Op), Loc)); - -- The element is only modified in expanded code, so it appears as - -- unassigned to the warning machinery. We must suppress this spurious - -- warning explicitly. + if not Is_Constrained (Etype (Element_Op)) then + Set_Expression (Elmt_Decl, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Element_Op, Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Container, Loc), + New_Occurrence_Of (Cursor, Loc)))); + + Set_Statements (New_Loop, + New_List + (Make_Block_Statement (Loc, + Declarations => New_List (Elmt_Decl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stats)))); - Set_Warnings_Off (Element); + else + Elmt_Ref := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Element, Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Element_Op, Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Container, Loc), + New_Occurrence_Of (Cursor, Loc)))); - Elmt_Ref := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Element, Loc), - Expression => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Element_Op, Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Container, Loc), - New_Occurrence_Of (Cursor, Loc)))); + Prepend (Elmt_Ref, Stats); - Prepend (Elmt_Ref, Stats); - Append_To (Stats, Advance); + -- The element is assignable in the expanded code - -- The loop is rewritten as a block, to hold the element declaration + Set_Assignment_OK (Name (Elmt_Ref)); - New_Loop := - Make_Block_Statement (Loc, - Declarations => New_List (Elmt_Decl), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (New_Loop))); + -- The loop is rewritten as a block, to hold the element declaration + + New_Loop := + Make_Block_Statement (Loc, + Declarations => New_List (Elmt_Decl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (New_Loop))); + end if; + + -- The element is only modified in expanded code, so it appears as + -- unassigned to the warning machinery. We must suppress this spurious + -- warning explicitly. + + Set_Warnings_Off (Element); Rewrite (N, New_Loop); @@ -2971,7 +2982,6 @@ package body Exp_Ch5 is Analyze (Elmt_Decl); Set_Ekind (Defining_Identifier (Elmt_Decl), E_Loop_Parameter); - Set_Assignment_OK (Name (Elmt_Ref)); Analyze (N); end Expand_Formal_Container_Element_Loop; @@ -3337,44 +3347,36 @@ package body Exp_Ch5 is begin -- for Element of Array loop - -- This case requires an internally generated cursor to iterate over - -- the array. - - if Of_Present (I_Spec) then - Iterator := Make_Temporary (Loc, 'C'); + -- It requires an internally generated cursor to iterate over the array - -- Generate: - -- Element : Component_Type renames Array (Iterator); - -- Iterator is the index value, or a list of index values - -- in the case of a multidimensional array. + pragma Assert (Of_Present (I_Spec)); - Ind_Comp := - Make_Indexed_Component (Loc, - Prefix => Relocate_Node (Array_Node), - Expressions => New_List (New_Occurrence_Of (Iterator, Loc))); + Iterator := Make_Temporary (Loc, 'C'); - Prepend_To (Stats, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Id, - Subtype_Mark => - New_Occurrence_Of (Component_Type (Array_Typ), Loc), - Name => Ind_Comp)); - - -- Mark the loop variable as needing debug info, so that expansion - -- of the renaming will result in Materialize_Entity getting set via - -- Debug_Renaming_Declaration. (This setting is needed here because - -- the setting in Freeze_Entity comes after the expansion, which is - -- too late. ???) + -- Generate: + -- Element : Component_Type renames Array (Iterator); + -- Iterator is the index value, or a list of index values + -- in the case of a multidimensional array. - Set_Debug_Info_Needed (Id); + Ind_Comp := + Make_Indexed_Component (Loc, + Prefix => Relocate_Node (Array_Node), + Expressions => New_List (New_Occurrence_Of (Iterator, Loc))); - -- for Index in Array loop + Prepend_To (Stats, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Id, + Subtype_Mark => + New_Occurrence_Of (Component_Type (Array_Typ), Loc), + Name => Ind_Comp)); - -- This case utilizes the already given iterator name + -- Mark the loop variable as needing debug info, so that expansion + -- of the renaming will result in Materialize_Entity getting set via + -- Debug_Renaming_Declaration. (This setting is needed here because + -- the setting in Freeze_Entity comes after the expansion, which is + -- too late. ???) - else - Iterator := Id; - end if; + Set_Debug_Info_Needed (Id); -- Generate: @@ -3862,10 +3864,14 @@ package body Exp_Ch5 is Set_Debug_Info_Needed (Id); -- If the container does not have a variable indexing aspect, - -- the element is a constant in the loop. + -- the element is a constant in the loop. The container itself + -- may be constant, in which case the element is a constant as + -- well. The container has been rewritten as a call to Iterate, + -- so examine original node. if No (Find_Value_Of_Aspect (Container_Typ, Aspect_Variable_Indexing)) + or else not Is_Variable (Original_Node (Container)) then Set_Ekind (Id, E_Constant); end if; @@ -4582,11 +4588,6 @@ package body Exp_Ch5 is and then not Comp_Asn and then not No_Ctrl_Actions (N) and then Tagged_Type_Expansion; - -- Tags are not saved and restored when VM_Target because VM tags are - -- represented implicitly in objects. - - Next_Id : Entity_Id; - Prev_Id : Entity_Id; Tag_Id : Entity_Id; begin @@ -4647,48 +4648,6 @@ package body Exp_Ch5 is Tag_Id := Empty; end if; - -- Save the Prev and Next fields on .NET/JVM. This is not needed on non - -- VM targets since the fields are not part of the object. - - if VM_Target /= No_VM - and then Is_Controlled (T) - then - Prev_Id := Make_Temporary (Loc, 'P'); - Next_Id := Make_Temporary (Loc, 'N'); - - -- Generate: - -- Pnn : Root_Controlled_Ptr := Root_Controlled (L).Prev; - - Append_To (Res, - Make_Object_Declaration (Loc, - Defining_Identifier => Prev_Id, - Object_Definition => - New_Occurrence_Of (RTE (RE_Root_Controlled_Ptr), Loc), - Expression => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To - (RTE (RE_Root_Controlled), New_Copy_Tree (L)), - Selector_Name => - Make_Identifier (Loc, Name_Prev)))); - - -- Generate: - -- Nnn : Root_Controlled_Ptr := Root_Controlled (L).Next; - - Append_To (Res, - Make_Object_Declaration (Loc, - Defining_Identifier => Next_Id, - Object_Definition => - New_Occurrence_Of (RTE (RE_Root_Controlled_Ptr), Loc), - Expression => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To - (RTE (RE_Root_Controlled), New_Copy_Tree (L)), - Selector_Name => - Make_Identifier (Loc, Name_Next)))); - end if; - -- If the tagged type has a full rep clause, expand the assignment into -- component-wise assignments. Mark the node as unanalyzed in order to -- generate the proper code and propagate this scenario by setting a @@ -4714,39 +4673,6 @@ package body Exp_Ch5 is Expression => New_Occurrence_Of (Tag_Id, Loc))); end if; - -- Restore the Prev and Next fields on .NET/JVM - - if VM_Target /= No_VM - and then Is_Controlled (T) - then - -- Generate: - -- Root_Controlled (L).Prev := Prev_Id; - - Append_To (Res, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To - (RTE (RE_Root_Controlled), New_Copy_Tree (L)), - Selector_Name => - Make_Identifier (Loc, Name_Prev)), - Expression => New_Occurrence_Of (Prev_Id, Loc))); - - -- Generate: - -- Root_Controlled (L).Next := Next_Id; - - Append_To (Res, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To - (RTE (RE_Root_Controlled), New_Copy_Tree (L)), - Selector_Name => Make_Identifier (Loc, Name_Next)), - Expression => New_Occurrence_Of (Next_Id, Loc))); - end if; - -- Adjust the target after the assignment when controlled (not in the -- init proc since it is an initialization more than an assignment). diff --git a/gcc/ada/exp_ch5.ads b/gcc/ada/exp_ch5.ads index 7967164729d..9d859755899 100644 --- a/gcc/ada/exp_ch5.ads +++ b/gcc/ada/exp_ch5.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,4 +35,8 @@ package Exp_Ch5 is procedure Expand_N_Goto_Statement (N : Node_Id); procedure Expand_N_If_Statement (N : Node_Id); procedure Expand_N_Loop_Statement (N : Node_Id); + + procedure Expand_Iterator_Loop_Over_Array (N : Node_Id); + -- Expand loop over arrays that uses the form "for X of C" + end Exp_Ch5; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 67caf2f2787..517143b9ea2 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -23,60 +23,59 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; -with Checks; use Checks; -with Debug; use Debug; -with Einfo; use Einfo; -with Errout; use Errout; -with Elists; use Elists; -with Exp_Aggr; use Exp_Aggr; -with Exp_Atag; use Exp_Atag; -with Exp_Ch2; use Exp_Ch2; -with Exp_Ch3; use Exp_Ch3; -with Exp_Ch7; use Exp_Ch7; -with Exp_Ch9; use Exp_Ch9; -with Exp_Dbug; use Exp_Dbug; -with Exp_Disp; use Exp_Disp; -with Exp_Dist; use Exp_Dist; -with Exp_Intr; use Exp_Intr; -with Exp_Pakd; use Exp_Pakd; -with Exp_Prag; use Exp_Prag; -with Exp_Tss; use Exp_Tss; -with Exp_Unst; use Exp_Unst; -with Exp_Util; use Exp_Util; -with Freeze; use Freeze; -with Ghost; use Ghost; -with Inline; use Inline; -with Lib; use Lib; -with Namet; use Namet; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch13; use Sem_Ch13; -with Sem_Dim; use Sem_Dim; -with Sem_Disp; use Sem_Disp; -with Sem_Dist; use Sem_Dist; -with Sem_Eval; use Sem_Eval; -with Sem_Mech; use Sem_Mech; -with Sem_Res; use Sem_Res; -with Sem_SCIL; use Sem_SCIL; -with Sem_Util; use Sem_Util; -with Sinfo; use Sinfo; -with Snames; use Snames; -with Stand; use Stand; -with Stringt; use Stringt; +with Atree; use Atree; +with Checks; use Checks; +with Contracts; use Contracts; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Elists; use Elists; +with Exp_Aggr; use Exp_Aggr; +with Exp_Atag; use Exp_Atag; +with Exp_Ch2; use Exp_Ch2; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; +with Exp_Dbug; use Exp_Dbug; +with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; +with Exp_Intr; use Exp_Intr; +with Exp_Pakd; use Exp_Pakd; +with Exp_Tss; use Exp_Tss; +with Exp_Unst; use Exp_Unst; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Ghost; use Ghost; +with Inline; use Inline; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_SCIL; use Sem_SCIL; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; with Table; -with Targparm; use Targparm; -with Tbuild; use Tbuild; -with Uintp; use Uintp; -with Validsw; use Validsw; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Validsw; use Validsw; package body Exp_Ch6 is @@ -258,6 +257,17 @@ package body Exp_Ch6 is -- Expand simple return from function. In the case where we are returning -- from a function body this is called by Expand_N_Simple_Return_Statement. + procedure Rewrite_Function_Call_For_C (N : Node_Id); + -- When generating C code, replace a call to a function that returns an + -- array into the generated procedure with an additional out parameter. + + procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id); + -- N is a return statement for a function that returns its result on the + -- secondary stack. This sets the Sec_Stack_Needed_For_Return flag on the + -- function and all blocks and loops that the return statement is jumping + -- out of. This ensures that the secondary stack is not released; otherwise + -- the function result would be reclaimed before returning to the caller. + ---------------------------------------------- -- Add_Access_Actual_To_Build_In_Place_Call -- ---------------------------------------------- @@ -369,11 +379,9 @@ package body Exp_Ch6 is (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); -- Pass the Storage_Pool parameter. This parameter is omitted on - -- .NET/JVM/ZFP as those targets do not support pools. + -- ZFP as those targets do not support pools. - if VM_Target = No_VM - and then RTE_Available (RE_Root_Storage_Pool_Ptr) - then + if RTE_Available (RE_Root_Storage_Pool_Ptr) then Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool); Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal)); Add_Extra_Actual_To_Call @@ -666,6 +674,131 @@ package body Exp_Ch6 is return Extra_Formal; end Build_In_Place_Formal; + ------------------------------- + -- Build_Procedure_Body_Form -- + ------------------------------- + + function Build_Procedure_Body_Form + (Func_Id : Entity_Id; + Func_Body : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Func_Body); + + Proc_Decl : constant Node_Id := + Next (Unit_Declaration_Node (Func_Id)); + -- It is assumed that the next node following the declaration of the + -- corresponding subprogram spec is the declaration of the procedure + -- form. + + Proc_Id : constant Entity_Id := Defining_Entity (Proc_Decl); + + procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id); + -- Replace each return statement found in the list Stmts with an + -- assignment of the return expression to parameter Param_Id. + + --------------------- + -- Replace_Returns -- + --------------------- + + procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id) is + Stmt : Node_Id; + + begin + Stmt := First (Stmts); + while Present (Stmt) loop + if Nkind (Stmt) = N_Block_Statement then + Replace_Returns (Param_Id, Statements (Stmt)); + + elsif Nkind (Stmt) = N_Case_Statement then + declare + Alt : Node_Id; + begin + Alt := First (Alternatives (Stmt)); + while Present (Alt) loop + Replace_Returns (Param_Id, Statements (Alt)); + Next (Alt); + end loop; + end; + + elsif Nkind (Stmt) = N_If_Statement then + Replace_Returns (Param_Id, Then_Statements (Stmt)); + Replace_Returns (Param_Id, Else_Statements (Stmt)); + + declare + Part : Node_Id; + begin + Part := First (Elsif_Parts (Stmt)); + while Present (Part) loop + Replace_Returns (Part, Then_Statements (Part)); + Next (Part); + end loop; + end; + + elsif Nkind (Stmt) = N_Loop_Statement then + Replace_Returns (Param_Id, Statements (Stmt)); + + elsif Nkind (Stmt) = N_Simple_Return_Statement then + + -- Generate: + -- Param := Expr; + -- return; + + Rewrite (Stmt, + Make_Assignment_Statement (Sloc (Stmt), + Name => New_Occurrence_Of (Param_Id, Loc), + Expression => Relocate_Node (Expression (Stmt)))); + + Insert_After (Stmt, Make_Simple_Return_Statement (Loc)); + + -- Skip the added return + + Next (Stmt); + end if; + + Next (Stmt); + end loop; + end Replace_Returns; + + -- Local variables + + Stmts : List_Id; + New_Body : Node_Id; + + -- Start of processing for Build_Procedure_Body_Form + + begin + -- This routine replaces the original function body: + + -- function F (...) return Array_Typ is + -- begin + -- ... + -- return Something; + -- end F; + + -- with the following: + + -- procedure P (..., Result : out Array_Typ) is + -- begin + -- ... + -- Result := Something; + -- end P; + + Stmts := + Statements (Handled_Statement_Sequence (Func_Body)); + Replace_Returns (Last_Entity (Proc_Id), Stmts); + + New_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Subprogram_Spec (Specification (Proc_Decl)), + Declarations => Declarations (Func_Body), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + + return New_Body; + end Build_Procedure_Body_Form; + -------------------------------- -- Check_Overriding_Operation -- -------------------------------- @@ -1268,7 +1401,7 @@ package body Exp_Ch6 is Reset_Analyzed_Flags (Lhs); else - Lhs := New_Occurrence_Of (Var, Loc); + Lhs := New_Occurrence_Of (Var, Loc); end if; Set_Assignment_OK (Lhs); @@ -1981,10 +2114,6 @@ package body Exp_Ch6 is -- Tnnn; -- end; - -- Note: this won't do in Modify_Tree_For_C mode, but we - -- will deal with that later (it will require creating a - -- declaration for Temp, using Insert_Declaration) ??? - declare Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T'); FRTyp : constant Entity_Id := Etype (N); @@ -2357,7 +2486,6 @@ package body Exp_Ch6 is -- Local variables - Curr_S : constant Entity_Id := Current_Scope; Remote : constant Boolean := Is_Remote_Call (Call_Node); Actual : Node_Id; Formal : Entity_Id; @@ -2379,11 +2507,13 @@ package body Exp_Ch6 is -- Start of processing for Expand_Call begin - -- Expand the procedure call if the first actual has a dimension and if - -- the procedure is Put (Ada 2012). + -- Expand the function or procedure call if the first actual has a + -- declared dimension aspect, and the subprogram is declared in one + -- of the dimension I/O packages. if Ada_Version >= Ada_2012 - and then Nkind (Call_Node) = N_Procedure_Call_Statement + and then + Nkind_In (Call_Node, N_Procedure_Call_Statement, N_Function_Call) and then Present (Parameter_Associations (Call_Node)) then Expand_Put_Call_With_Symbol (Call_Node); @@ -2458,52 +2588,6 @@ package body Exp_Ch6 is end if; end if; - -- Detect the following code in System.Finalization_Masters only on - -- .NET/JVM targets: - - -- procedure Finalize (Master : in out Finalization_Master) is - -- begin - -- . . . - -- begin - -- Finalize (Curr_Ptr.all); - - -- Since .NET/JVM compilers lack address arithmetic and Deep_Finalize - -- cannot be named in library or user code, the compiler has to deal - -- with this by transforming the call to Finalize into Deep_Finalize. - - if VM_Target /= No_VM - and then Chars (Subp) = Name_Finalize - and then Ekind (Curr_S) = E_Block - and then Ekind (Scope (Curr_S)) = E_Procedure - and then Chars (Scope (Curr_S)) = Name_Finalize - and then Etype (First_Formal (Scope (Curr_S))) = - RTE (RE_Finalization_Master) - then - declare - Deep_Fin : constant Entity_Id := - Find_Prim_Op (RTE (RE_Root_Controlled), - TSS_Deep_Finalize); - begin - -- Since Root_Controlled is a tagged type, the compiler should - -- always generate Deep_Finalize for it. - - pragma Assert (Present (Deep_Fin)); - - -- Generate: - -- Deep_Finalize (Curr_Ptr.all); - - Rewrite (N, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Deep_Fin, Loc), - Parameter_Associations => - New_Copy_List_Tree (Parameter_Associations (N)))); - - Analyze (N); - return; - end; - end if; - -- Ada 2005 (AI-345): We have a procedure call as a triggering -- alternative in an asynchronous select or as an entry call in -- a conditional or timed select. Check whether the procedure call @@ -2547,6 +2631,18 @@ package body Exp_Ch6 is end; end if; + -- When generating C code, transform a function call that returns a + -- constrained array type into procedure form. + + if Modify_Tree_For_C + and then Nkind (Call_Node) = N_Function_Call + and then Is_Entity_Name (Name (Call_Node)) + and then Rewritten_For_C (Entity (Name (Call_Node))) + then + Rewrite_Function_Call_For_C (Call_Node); + return; + end if; + -- First step, compute extra actuals, corresponding to any Extra_Formals -- present. Note that we do not access Extra_Formals directly, instead -- we simply note the presence of the extra formals as we process the @@ -2952,15 +3048,6 @@ package body Exp_Ch6 is elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then null; - -- Suppress null checks when passing to access parameters of Java - -- and CIL subprograms. (Should this be done for other foreign - -- conventions as well ???) - - elsif Convention (Subp) = Convention_Java - or else Convention (Subp) = Convention_CIL - then - null; - else Install_Null_Excluding_Check (Prev); end if; @@ -3291,7 +3378,7 @@ package body Exp_Ch6 is -- extra actuals since this will be done on the re-analysis of the -- dispatching call. Note that we do not try to shorten the actual list -- for a dispatching call, it would not make sense to do so. Expansion - -- of dispatching calls is suppressed when VM_Target, because the VM + -- of dispatching calls is suppressed for VM targets, because the VM -- back-ends directly handle the generation of dispatching calls and -- would have to undo any expansion to an indirect call. @@ -3329,7 +3416,7 @@ package body Exp_Ch6 is if Subp = Eq_Prim_Op then - -- Mark the node as analyzed to avoid reanalizing this + -- Mark the node as analyzed to avoid reanalyzing this -- dispatching call (which would cause a never-ending loop) Prev_Call := Relocate_Node (Call_Node); @@ -3998,22 +4085,6 @@ package body Exp_Ch6 is procedure Expand_N_Extended_Return_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Par_Func : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - Result_Subt : constant Entity_Id := Etype (Par_Func); - Ret_Obj_Id : constant Entity_Id := - First_Entity (Return_Statement_Entity (N)); - Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); - - Is_Build_In_Place : constant Boolean := - Is_Build_In_Place_Function (Par_Func); - - Exp : Node_Id; - HSS : Node_Id; - Result : Node_Id; - Return_Stmt : Node_Id; - Stmts : List_Id; - function Build_Heap_Allocator (Temp_Id : Entity_Id; Temp_Typ : Entity_Id; @@ -4047,12 +4118,15 @@ package body Exp_Ch6 is -- temporary. Func_Id is the enclosing function. Ret_Typ is the return -- type of Func_Id. Alloc_Expr is the actual allocator. - function Move_Activation_Chain return Node_Id; + function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id; -- Construct a call to System.Tasking.Stages.Move_Activation_Chain -- with parameters: -- From current activation chain -- To activation chain passed in by the caller -- New_Master master passed in by the caller + -- + -- Func_Id is the entity of the function where the extended return + -- statement appears. -------------------------- -- Build_Heap_Allocator -- @@ -4068,12 +4142,9 @@ package body Exp_Ch6 is begin pragma Assert (Is_Build_In_Place_Function (Func_Id)); - -- Processing for build-in-place object allocation. This is disabled - -- on .NET/JVM because the targets do not support pools. + -- Processing for build-in-place object allocation. - if VM_Target = No_VM - and then Needs_Finalization (Ret_Typ) - then + if Needs_Finalization (Ret_Typ) then declare Decls : constant List_Id := New_List; Fin_Mas_Id : constant Entity_Id := @@ -4217,7 +4288,7 @@ package body Exp_Ch6 is -- Move_Activation_Chain -- --------------------------- - function Move_Activation_Chain return Node_Id is + function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id is begin return Make_Procedure_Call_Statement (Loc, @@ -4235,14 +4306,31 @@ package body Exp_Ch6 is -- Destination chain New_Occurrence_Of - (Build_In_Place_Formal (Par_Func, BIP_Activation_Chain), Loc), + (Build_In_Place_Formal (Func_Id, BIP_Activation_Chain), Loc), -- New master New_Occurrence_Of - (Build_In_Place_Formal (Par_Func, BIP_Task_Master), Loc))); + (Build_In_Place_Formal (Func_Id, BIP_Task_Master), Loc))); end Move_Activation_Chain; + -- Local variables + + Func_Id : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + Is_BIP_Func : constant Boolean := + Is_Build_In_Place_Function (Func_Id); + Ret_Obj_Id : constant Entity_Id := + First_Entity (Return_Statement_Entity (N)); + Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); + Ret_Typ : constant Entity_Id := Etype (Func_Id); + + Exp : Node_Id; + HSS : Node_Id; + Result : Node_Id; + Return_Stmt : Node_Id; + Stmts : List_Id; + -- Start of processing for Expand_N_Extended_Return_Statement begin @@ -4266,9 +4354,7 @@ package body Exp_Ch6 is -- with the scope finalizer. There is one flag per each return object -- in case of multiple returns. - if Is_Build_In_Place - and then Needs_Finalization (Etype (Ret_Obj_Id)) - then + if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then declare Flag_Decl : Node_Id; Flag_Id : Entity_Id; @@ -4277,7 +4363,7 @@ package body Exp_Ch6 is begin -- Recover the function body - Func_Bod := Unit_Declaration_Node (Par_Func); + Func_Bod := Unit_Declaration_Node (Func_Id); if Nkind (Func_Bod) = N_Subprogram_Declaration then Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); @@ -4312,7 +4398,7 @@ package body Exp_Ch6 is -- built in place (though we plan to do so eventually). if Present (HSS) - or else Is_Composite_Type (Result_Subt) + or else Is_Composite_Type (Ret_Typ) or else No (Exp) then if No (HSS) then @@ -4338,9 +4424,8 @@ package body Exp_Ch6 is -- result to be built in place, though that's necessarily true for -- the case of result types with task parts. - if Is_Build_In_Place - and then Has_Task (Result_Subt) - then + if Is_BIP_Func and then Has_Task (Ret_Typ) then + -- The return expression is an aggregate for a complex type which -- contains tasks. This particular case is left unexpanded since -- the regular expansion would insert all temporaries and @@ -4354,16 +4439,14 @@ package body Exp_Ch6 is -- contain tasks. if Has_Task (Etype (Ret_Obj_Id)) then - Append_To (Stmts, Move_Activation_Chain); + Append_To (Stmts, Move_Activation_Chain (Func_Id)); end if; end if; -- Update the state of the function right before the object is -- returned. - if Is_Build_In_Place - and then Needs_Finalization (Etype (Ret_Obj_Id)) - then + if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then declare Flag_Id : constant Entity_Id := Status_Flag_Or_Transient_Decl (Ret_Obj_Id); @@ -4413,7 +4496,7 @@ package body Exp_Ch6 is -- build-in-place function, and that function is responsible for -- the allocation of the return object. - if Is_Build_In_Place + if Is_BIP_Func and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration then pragma Assert @@ -4425,7 +4508,7 @@ package body Exp_Ch6 is Set_By_Ref (Return_Stmt); - elsif Is_Build_In_Place then + elsif Is_BIP_Func then -- Locate the implicit access parameter associated with the -- caller-supplied return object and convert the return @@ -4449,17 +4532,13 @@ package body Exp_Ch6 is -- ... declare - Return_Obj_Id : constant Entity_Id := - Defining_Identifier (Ret_Obj_Decl); - Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id); - Return_Obj_Expr : constant Node_Id := - Expression (Ret_Obj_Decl); - Constr_Result : constant Boolean := - Is_Constrained (Result_Subt); - Obj_Alloc_Formal : Entity_Id; - Object_Access : Entity_Id; - Obj_Acc_Deref : Node_Id; + Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl); + Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id); + Init_Assignment : Node_Id := Empty; + Obj_Acc_Formal : Entity_Id; + Obj_Acc_Deref : Node_Id; + Obj_Alloc_Formal : Entity_Id; begin -- Build-in-place results must be returned by reference @@ -4468,8 +4547,8 @@ package body Exp_Ch6 is -- Retrieve the implicit access parameter passed by the caller - Object_Access := - Build_In_Place_Formal (Par_Func, BIP_Object_Access); + Obj_Acc_Formal := + Build_In_Place_Formal (Func_Id, BIP_Object_Access); -- If the return object's declaration includes an expression -- and the declaration isn't marked as No_Initialization, then @@ -4487,16 +4566,16 @@ package body Exp_Ch6 is -- is a nonlimited descendant of a limited interface (the -- interface has no assignment operation). - if Present (Return_Obj_Expr) + if Present (Ret_Obj_Expr) and then not No_Initialization (Ret_Obj_Decl) - and then not Is_Interface (Return_Obj_Typ) + and then not Is_Interface (Ret_Obj_Typ) then Init_Assignment := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Return_Obj_Id, Loc), - Expression => Relocate_Node (Return_Obj_Expr)); + Name => New_Occurrence_Of (Ret_Obj_Id, Loc), + Expression => Relocate_Node (Ret_Obj_Expr)); - Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); + Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); Set_Assignment_OK (Name (Init_Assignment)); Set_No_Ctrl_Actions (Init_Assignment); @@ -4505,14 +4584,14 @@ package body Exp_Ch6 is Set_Expression (Ret_Obj_Decl, Empty); - if Is_Class_Wide_Type (Etype (Return_Obj_Id)) + if Is_Class_Wide_Type (Etype (Ret_Obj_Id)) and then not Is_Class_Wide_Type (Etype (Expression (Init_Assignment))) then Rewrite (Expression (Init_Assignment), Make_Type_Conversion (Loc, Subtype_Mark => - New_Occurrence_Of (Etype (Return_Obj_Id), Loc), + New_Occurrence_Of (Etype (Ret_Obj_Id), Loc), Expression => Relocate_Node (Expression (Init_Assignment)))); end if; @@ -4523,8 +4602,8 @@ package body Exp_Ch6 is -- the different forms of allocation (this is true for -- unconstrained and tagged result subtypes). - if Constr_Result - and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) + if Is_Constrained (Ret_Typ) + and then not Is_Tagged_Type (Underlying_Type (Ret_Typ)) then Insert_After (Ret_Obj_Decl, Init_Assignment); end if; @@ -4549,11 +4628,11 @@ package body Exp_Ch6 is -- called in dispatching contexts and must be handled similarly -- to functions with a class-wide result. - if not Constr_Result - or else Is_Tagged_Type (Underlying_Type (Result_Subt)) + if not Is_Constrained (Ret_Typ) + or else Is_Tagged_Type (Underlying_Type (Ret_Typ)) then Obj_Alloc_Formal := - Build_In_Place_Formal (Par_Func, BIP_Alloc_Form); + Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); declare Pool_Id : constant Entity_Id := @@ -4588,7 +4667,7 @@ package body Exp_Ch6 is Make_Access_To_Object_Definition (Loc, All_Present => True, Subtype_Indication => - New_Occurrence_Of (Return_Obj_Typ, Loc))); + New_Occurrence_Of (Ret_Obj_Typ, Loc))); Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); @@ -4612,7 +4691,7 @@ package body Exp_Ch6 is -- global heap. If there's an initialization expression, -- then create these as initialized allocators. - if Present (Return_Obj_Expr) + if Present (Ret_Obj_Expr) and then not No_Initialization (Ret_Obj_Decl) then -- Always use the type of the expression for the @@ -4629,9 +4708,8 @@ package body Exp_Ch6 is Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of - (Etype (Return_Obj_Expr), Loc), - Expression => - New_Copy_Tree (Return_Obj_Expr))); + (Etype (Ret_Obj_Expr), Loc), + Expression => New_Copy_Tree (Ret_Obj_Expr))); else -- If the function returns a class-wide type we cannot @@ -4639,17 +4717,17 @@ package body Exp_Ch6 is -- use the type of the expression, which must be an -- aggregate of a definite type. - if Is_Class_Wide_Type (Return_Obj_Typ) then + if Is_Class_Wide_Type (Ret_Obj_Typ) then Heap_Allocator := Make_Allocator (Loc, Expression => New_Occurrence_Of - (Etype (Return_Obj_Expr), Loc)); + (Etype (Ret_Obj_Expr), Loc)); else Heap_Allocator := Make_Allocator (Loc, Expression => - New_Occurrence_Of (Return_Obj_Typ, Loc)); + New_Occurrence_Of (Ret_Obj_Typ, Loc)); end if; -- If the object requires default initialization then @@ -4667,12 +4745,10 @@ package body Exp_Ch6 is Pool_Allocator := New_Copy_Tree (Heap_Allocator); -- Do not generate the renaming of the build-in-place - -- pool parameter on .NET/JVM/ZFP because the parameter - -- is not created in the first place. + -- pool parameter on ZFP because the parameter is not + -- created in the first place. - if VM_Target = No_VM - and then RTE_Available (RE_Root_Storage_Pool_Ptr) - then + if RTE_Available (RE_Root_Storage_Pool_Ptr) then Pool_Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Pool_Id, @@ -4683,7 +4759,7 @@ package body Exp_Ch6 is Make_Explicit_Dereference (Loc, New_Occurrence_Of (Build_In_Place_Formal - (Par_Func, BIP_Storage_Pool), Loc))); + (Func_Id, BIP_Storage_Pool), Loc))); Set_Storage_Pool (Pool_Allocator, Pool_Id); Set_Procedure_To_Call (Pool_Allocator, RTE (RE_Allocate_Any)); @@ -4721,29 +4797,26 @@ package body Exp_Ch6 is Set_Comes_From_Source (Pool_Allocator, True); end if; - -- The allocator is returned on the secondary stack. We - -- don't do this on VM targets, since the SS is not used. + -- The allocator is returned on the secondary stack. - if VM_Target = No_VM then - Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); - Set_Procedure_To_Call - (SS_Allocator, RTE (RE_SS_Allocate)); - - -- The allocator is returned on the secondary stack, - -- so indicate that the function return, as well as - -- the block that encloses the allocator, must not - -- release it. The flags must be set now because - -- the decision to use the secondary stack is done - -- very late in the course of expanding the return - -- statement, past the point where these flags are - -- normally set. - - Set_Sec_Stack_Needed_For_Return (Par_Func); - Set_Sec_Stack_Needed_For_Return - (Return_Statement_Entity (N)); - Set_Uses_Sec_Stack (Par_Func); - Set_Uses_Sec_Stack (Return_Statement_Entity (N)); - end if; + Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); + Set_Procedure_To_Call + (SS_Allocator, RTE (RE_SS_Allocate)); + + -- The allocator is returned on the secondary stack, + -- so indicate that the function return, as well as + -- all blocks that encloses the allocator, must not + -- release it. The flags must be set now because + -- the decision to use the secondary stack is done + -- very late in the course of expanding the return + -- statement, past the point where these flags are + -- normally set. + + Set_Uses_Sec_Stack (Func_Id); + Set_Uses_Sec_Stack (Return_Statement_Entity (N)); + Set_Sec_Stack_Needed_For_Return + (Return_Statement_Entity (N)); + Set_Enclosing_Sec_Stack_Return (N); -- Create an if statement to test the BIP_Alloc_Form -- formal and initialize the access object to either the @@ -4783,7 +4856,7 @@ package body Exp_Ch6 is Subtype_Mark => New_Occurrence_Of (Ref_Type, Loc), Expression => - New_Occurrence_Of (Object_Access, Loc)))), + New_Occurrence_Of (Obj_Acc_Formal, Loc)))), Elsif_Parts => New_List ( Make_Elsif_Part (Loc, @@ -4816,8 +4889,8 @@ package body Exp_Ch6 is Build_Heap_Allocator (Temp_Id => Alloc_Obj_Id, Temp_Typ => Ref_Type, - Func_Id => Par_Func, - Ret_Typ => Return_Obj_Typ, + Func_Id => Func_Id, + Ret_Typ => Ret_Obj_Typ, Alloc_Expr => Heap_Allocator)))), Else_Statements => New_List ( @@ -4825,8 +4898,8 @@ package body Exp_Ch6 is Build_Heap_Allocator (Temp_Id => Alloc_Obj_Id, Temp_Typ => Ref_Type, - Func_Id => Par_Func, - Ret_Typ => Return_Obj_Typ, + Func_Id => Func_Id, + Ret_Typ => Ret_Obj_Typ, Alloc_Expr => Pool_Allocator))); -- If a separate initialization assignment was created @@ -4842,8 +4915,7 @@ package body Exp_Ch6 is Make_Explicit_Dereference (Loc, Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc))); - Set_Etype - (Name (Init_Assignment), Etype (Return_Obj_Id)); + Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); Append_To (Then_Statements (Alloc_If_Stmt), Init_Assignment); @@ -4854,7 +4926,7 @@ package body Exp_Ch6 is -- Remember the local access object for use in the -- dereference of the renaming created below. - Object_Access := Alloc_Obj_Id; + Obj_Acc_Formal := Alloc_Obj_Id; end; end if; @@ -4864,17 +4936,16 @@ package body Exp_Ch6 is Obj_Acc_Deref := Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Object_Access, Loc)); + Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc)); Rewrite (Ret_Obj_Decl, Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Return_Obj_Id, + Defining_Identifier => Ret_Obj_Id, Access_Definition => Empty, - Subtype_Mark => - New_Occurrence_Of (Return_Obj_Typ, Loc), + Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc), Name => Obj_Acc_Deref)); - Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); + Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref); end; end if; @@ -4917,20 +4988,17 @@ package body Exp_Ch6 is --------------------------------------- procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; begin - -- The procedure call may be Ghost if the name is Ghost. Set the mode - -- now to ensure that any nodes generated during expansion are properly - -- flagged as ignored Ghost. + -- The procedure call is Ghost when the name is Ghost. Set the mode now + -- to ensure that any nodes generated during expansion are properly set + -- as Ghost. Set_Ghost_Mode (N); - Expand_Call (N); - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - Ghost_Mode := GM; + Expand_Call (N); + Ghost_Mode := Save_Ghost_Mode; end Expand_N_Procedure_Call_Statement; -------------------------------------- @@ -5005,28 +5073,22 @@ package body Exp_Ch6 is -- Wrap thread body procedure Expand_N_Subprogram_Body (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - Loc : constant Source_Ptr := Sloc (N); - HSS : constant Node_Id := Handled_Statement_Sequence (N); - Body_Id : Entity_Id; - Except_H : Node_Id; - L : List_Id; - Spec_Id : Entity_Id; - - procedure Add_Return (S : List_Id); - -- Append a return statement to the statement sequence S if the last - -- statement is not already a return or a goto statement. Note that - -- the latter test is not critical, it does not matter if we add a few - -- extra returns, since they get eliminated anyway later on. + Body_Id : constant Entity_Id := Defining_Entity (N); + HSS : constant Node_Id := Handled_Statement_Sequence (N); + Loc : constant Source_Ptr := Sloc (N); - procedure Restore_Globals; - -- Restore the values of all saved global variables + procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id); + -- Append a return statement to the statement sequence Stmts if the last + -- statement is not already a return or a goto statement. Note that the + -- latter test is not critical, it does not matter if we add a few extra + -- returns, since they get eliminated anyway later on. Spec_Id denotes + -- the corresponding spec of the subprogram body. ---------------- -- Add_Return -- ---------------- - procedure Add_Return (S : List_Id) is + procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id) is Last_Stmt : Node_Id; Loc : Source_Ptr; Stmt : Node_Id; @@ -5035,7 +5097,7 @@ package body Exp_Ch6 is -- Get last statement, ignoring any Pop_xxx_Label nodes, which are -- not relevant in this context since they are not executable. - Last_Stmt := Last (S); + Last_Stmt := Last (Stmts); while Nkind (Last_Stmt) in N_Pop_xxx_Label loop Prev (Last_Stmt); end loop; @@ -5051,8 +5113,8 @@ package body Exp_Ch6 is -- all the statements within the handler are made invisible -- to the debugger. - if Nkind (Parent (S)) = N_Exception_Handler - and then not Comes_From_Source (Parent (S)) + if Nkind (Parent (Stmts)) = N_Exception_Handler + and then not Comes_From_Source (Parent (Stmts)) then Loc := Sloc (Last_Stmt); elsif Present (End_Label (HSS)) then @@ -5077,7 +5139,7 @@ package body Exp_Ch6 is -- added to it. A guard in Sem_Elab is needed to prevent that -- spurious check, see Check_Elab_Call. - Append_To (S, Stmt); + Append_To (Stmts, Stmt); Set_Analyzed (Stmt); -- Call the _Postconditions procedure if the related subprogram @@ -5094,23 +5156,46 @@ package body Exp_Ch6 is end if; end Add_Return; - --------------------- - -- Restore_Globals -- - --------------------- + -- Local variables - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + + Except_H : Node_Id; + L : List_Id; + Spec_Id : Entity_Id; -- Start of processing for Expand_N_Subprogram_Body begin - -- The subprogram body may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- expansion are flagged as ignored Ghost. + if Present (Corresponding_Spec (N)) then + Spec_Id := Corresponding_Spec (N); + else + Spec_Id := Body_Id; + end if; - Set_Ghost_Mode (N); + -- If this is a Pure function which has any parameters whose root type + -- is System.Address, reset the Pure indication. + -- This check is also performed when the subprogram is frozen, but we + -- repeat it on the body so that the indication is consistent, and so + -- it applies as well to bodies without separate specifications. + + if Is_Pure (Spec_Id) + and then Is_Subprogram (Spec_Id) + and then not Has_Pragma_Pure_Function (Spec_Id) + then + Check_Function_With_Address_Parameter (Spec_Id); + + if Spec_Id /= Body_Id then + Set_Is_Pure (Body_Id, Is_Pure (Spec_Id)); + end if; + end if; + + -- The subprogram body is Ghost when it is stand alone and subject to + -- pragma Ghost or the corresponding spec is Ghost. To accomodate both + -- cases, set the mode now to ensure that any nodes generated during + -- expansion are marked as Ghost. + + Set_Ghost_Mode (N, Spec_Id); -- Set L to either the list of declarations if present, or to the list -- of statements if no declarations are present. This is used to insert @@ -5164,16 +5249,6 @@ package body Exp_Ch6 is end; end if; - -- Find entity for subprogram - - Body_Id := Defining_Entity (N); - - if Present (Corresponding_Spec (N)) then - Spec_Id := Corresponding_Spec (N); - else - Spec_Id := Body_Id; - end if; - -- Need poll on entry to subprogram if polling enabled. We only do this -- for non-empty subprograms, since it does not seem necessary to poll -- for a dummy null subprogram. @@ -5193,51 +5268,6 @@ package body Exp_Ch6 is end if; end if; - -- If this is a Pure function which has any parameters whose root type - -- is System.Address, reset the Pure indication, since it will likely - -- cause incorrect code to be generated as the parameter is probably - -- a pointer, and the fact that the same pointer is passed does not mean - -- that the same value is being referenced. - - -- Note that if the programmer gave an explicit Pure_Function pragma, - -- then we believe the programmer, and leave the subprogram Pure. - - -- This code should probably be at the freeze point, so that it happens - -- even on a -gnatc (or more importantly -gnatt) compile, so that the - -- semantic tree has Is_Pure set properly ??? - - if Is_Pure (Spec_Id) - and then Is_Subprogram (Spec_Id) - and then not Has_Pragma_Pure_Function (Spec_Id) - then - declare - F : Entity_Id; - - begin - F := First_Formal (Spec_Id); - while Present (F) loop - if Is_Descendent_Of_Address (Etype (F)) - - -- Note that this test is being made in the body of the - -- subprogram, not the spec, so we are testing the full - -- type for being limited here, as required. - - or else Is_Limited_Type (Etype (F)) - then - Set_Is_Pure (Spec_Id, False); - - if Spec_Id /= Body_Id then - Set_Is_Pure (Body_Id, False); - end if; - - exit; - end if; - - Next_Formal (F); - end loop; - end; - end if; - -- Initialize any scalar OUT args if Initialize/Normalize_Scalars if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then @@ -5288,7 +5318,7 @@ package body Exp_Ch6 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Make_Null_Statement (Loc)))); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; end if; @@ -5329,12 +5359,12 @@ package body Exp_Ch6 is -- the subprogram. if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then - Add_Return (Statements (HSS)); + Add_Return (Spec_Id, Statements (HSS)); if Present (Exception_Handlers (HSS)) then Except_H := First_Non_Pragma (Exception_Handlers (HSS)); while Present (Except_H) loop - Add_Return (Statements (Except_H)); + Add_Return (Spec_Id, Statements (Except_H)); Next_Non_Pragma (Except_H); end loop; end if; @@ -5424,7 +5454,7 @@ package body Exp_Ch6 is Unest_Bodies.Append ((Spec_Id, N)); end if; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; end Expand_N_Subprogram_Body; ----------------------------------- @@ -5451,21 +5481,77 @@ package body Exp_Ch6 is -- If the declaration is for a null procedure, emit null body procedure Expand_N_Subprogram_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - GM : constant Ghost_Mode_Type := Ghost_Mode; - Subp : constant Entity_Id := Defining_Entity (N); - Scop : constant Entity_Id := Scope (Subp); + Loc : constant Source_Ptr := Sloc (N); + Subp : constant Entity_Id := Defining_Entity (N); + + procedure Build_Procedure_Form; + -- Create a procedure declaration which emulates the behavior of + -- function Subp, for C-compatible generation. + + -------------------------- + -- Build_Procedure_Form -- + -------------------------- + + procedure Build_Procedure_Form is + Func_Formal : Entity_Id; + Proc_Formals : List_Id; + + begin + Proc_Formals := New_List; + + -- Create a list of formal parameters with the same types as the + -- function. + + Func_Formal := First_Formal (Subp); + while Present (Func_Formal) loop + Append_To (Proc_Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Func_Formal)), + Parameter_Type => + New_Occurrence_Of (Etype (Func_Formal), Loc))); + + Next_Formal (Func_Formal); + end loop; + + -- Add an extra out parameter to carry the function result + + Name_Len := 6; + Name_Buffer (1 .. Name_Len) := "RESULT"; + Append_To (Proc_Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars => Name_Find), + Out_Present => True, + Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc))); + + -- The new procedure declaration is inserted immediately after the + -- function declaration. The processing in Build_Procedure_Body_Form + -- relies on this order. + + Insert_After_And_Analyze (N, + Make_Subprogram_Declaration (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Subp)), + Parameter_Specifications => Proc_Formals))); + + -- Mark the function as having a procedure form + + Set_Rewritten_For_C (Subp); + end Build_Procedure_Form; + + -- Local variables + + Scop : constant Entity_Id := Scope (Subp); Prot_Bod : Node_Id; Prot_Decl : Node_Id; Prot_Id : Entity_Id; - begin - -- The subprogram declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- expansion are flagged as ignored Ghost. - - Set_Ghost_Mode (N); + -- Start of processing for Expand_N_Subprogram_Declaration + begin -- In SPARK, subprogram declarations are only allowed in package -- specifications. @@ -5567,10 +5653,22 @@ package body Exp_Ch6 is end; end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. + -- When generating C code, transform a function that returns a + -- constrained array type into a procedure with an out parameter + -- that carries the return value. + + -- We skip this transformation for unchecked conversions, since they + -- are not needed by the C generator (and this also produces cleaner + -- output). - Ghost_Mode := GM; + if Modify_Tree_For_C + and then Nkind (Specification (N)) = N_Function_Specification + and then Is_Array_Type (Etype (Subp)) + and then Is_Constrained (Etype (Subp)) + and then not Is_Unchecked_Conversion_Instance (Subp) + then + Build_Procedure_Form; + end if; end Expand_N_Subprogram_Declaration; -------------------------------- @@ -5748,7 +5846,7 @@ package body Exp_Ch6 is declare Decls : List_Id; - Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T'); + Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T'); begin Decls := New_List ( @@ -6035,17 +6133,21 @@ package body Exp_Ch6 is elsif not Requires_Transient_Scope (R_Type) then - -- Mutable records with no variable length components are not - -- returned on the sec-stack, so we need to make sure that the - -- backend will only copy back the size of the actual value, and not - -- the maximum size. We create an actual subtype for this purpose. + -- Mutable records with variable-length components are not returned + -- on the sec-stack, so we need to make sure that the back end will + -- only copy back the size of the actual value, and not the maximum + -- size. We create an actual subtype for this purpose. However we + -- need not do it if the expression is a function call since this + -- will be done in the called function and doing it here too would + -- cause a temporary with maximum size to be created. declare Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp)); Decl : Node_Id; Ent : Entity_Id; begin - if Has_Discriminants (Ubt) + if Nkind (Exp) /= N_Function_Call + and then Has_Discriminants (Ubt) and then not Is_Constrained (Ubt) and then not Has_Unchecked_Union (Ubt) then @@ -6061,44 +6163,10 @@ package body Exp_Ch6 is else -- Prevent the reclamation of the secondary stack by all enclosing - -- blocks and loops as well as the related function, otherwise the - -- result will be reclaimed too early or even clobbered. Due to a - -- possible mix of internally generated blocks, source blocks and - -- loops, the scope stack may not be contiguous as all labels are - -- inserted at the top level within the related function. Instead, - -- perform a parent-based traversal and mark all appropriate - -- constructs. - - declare - P : Node_Id; - - begin - P := N; - while Present (P) loop + -- blocks and loops as well as the related function; otherwise the + -- result would be reclaimed too early. - -- Mark the label of a source or internally generated block or - -- loop. - - if Nkind_In (P, N_Block_Statement, N_Loop_Statement) then - Set_Sec_Stack_Needed_For_Return (Entity (Identifier (P))); - - -- Mark the enclosing function - - elsif Nkind (P) = N_Subprogram_Body then - if Present (Corresponding_Spec (P)) then - Set_Sec_Stack_Needed_For_Return (Corresponding_Spec (P)); - else - Set_Sec_Stack_Needed_For_Return (Defining_Entity (P)); - end if; - - -- Do not go beyond the enclosing function - - exit; - end if; - - P := Parent (P); - end loop; - end; + Set_Enclosing_Sec_Stack_Return (N); -- Optimize the case where the result is a function call. In this -- case either the result is already on the secondary stack, or is @@ -6201,13 +6269,7 @@ package body Exp_Ch6 is else Check_Restriction (No_Secondary_Stack, N); Set_Storage_Pool (N, RTE (RE_SS_Pool)); - - -- If we are generating code for the VM do not use - -- SS_Allocate since everything is heap-allocated anyway. - - if VM_Target = No_VM then - Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); - end if; + Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); end if; end if; @@ -6709,1257 +6771,6 @@ package body Exp_Ch6 is end if; end Expand_Simple_Function_Return; - -------------------------------- - -- Expand_Subprogram_Contract -- - -------------------------------- - - procedure Expand_Subprogram_Contract (N : Node_Id) is - Body_Id : constant Entity_Id := Defining_Entity (N); - Spec_Id : constant Entity_Id := Corresponding_Spec (N); - - procedure Add_Invariant_And_Predicate_Checks - (Subp_Id : Entity_Id; - Stmts : in out List_Id; - Result : out Node_Id); - -- Process the result of function Subp_Id (if applicable) and all its - -- formals. Add invariant and predicate checks where applicable. The - -- routine appends all the checks to list Stmts. If Subp_Id denotes a - -- function, Result contains the entity of parameter _Result, to be - -- used in the creation of procedure _Postconditions. - - procedure Append_Enabled_Item (Item : Node_Id; List : in out List_Id); - -- Append a node to a list. If there is no list, create a new one. When - -- the item denotes a pragma, it is added to the list only when it is - -- enabled. - - procedure Build_Postconditions_Procedure - (Subp_Id : Entity_Id; - Stmts : List_Id; - Result : Entity_Id); - -- Create the body of procedure _Postconditions which handles various - -- assertion actions on exit from subprogram Subp_Id. Stmts is the list - -- of statements to be checked on exit. Parameter Result is the entity - -- of parameter _Result when Subp_Id denotes a function. - - function Build_Pragma_Check_Equivalent - (Prag : Node_Id; - Subp_Id : Entity_Id := Empty; - Inher_Id : Entity_Id := Empty) return Node_Id; - -- Transform a [refined] pre- or postcondition denoted by Prag into an - -- equivalent pragma Check. When the pre- or postcondition is inherited, - -- the routine corrects the references of all formals of Inher_Id to - -- point to the formals of Subp_Id. - - procedure Process_Contract_Cases (Stmts : in out List_Id); - -- Process pragma Contract_Cases. This routine prepends items to the - -- body declarations and appends items to list Stmts. - - procedure Process_Postconditions (Stmts : in out List_Id); - -- Collect all [inherited] spec and body postconditions and accumulate - -- their pragma Check equivalents in list Stmts. - - procedure Process_Preconditions; - -- Collect all [inherited] spec and body preconditions and prepend their - -- pragma Check equivalents to the declarations of the body. - - ---------------------------------------- - -- Add_Invariant_And_Predicate_Checks -- - ---------------------------------------- - - procedure Add_Invariant_And_Predicate_Checks - (Subp_Id : Entity_Id; - Stmts : in out List_Id; - Result : out Node_Id) - is - procedure Add_Invariant_Access_Checks (Id : Entity_Id); - -- Id denotes the return value of a function or a formal parameter. - -- Add an invariant check if the type of Id is access to a type with - -- invariants. The routine appends the generated code to Stmts. - - function Invariant_Checks_OK (Typ : Entity_Id) return Boolean; - -- Determine whether type Typ can benefit from invariant checks. To - -- qualify, the type must have a non-null invariant procedure and - -- subprogram Subp_Id must appear visible from the point of view of - -- the type. - - --------------------------------- - -- Add_Invariant_Access_Checks -- - --------------------------------- - - procedure Add_Invariant_Access_Checks (Id : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Ref : Node_Id; - Typ : Entity_Id; - - begin - Typ := Etype (Id); - - if Is_Access_Type (Typ) and then not Is_Access_Constant (Typ) then - Typ := Designated_Type (Typ); - - if Invariant_Checks_OK (Typ) then - Ref := - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Id, Loc)); - Set_Etype (Ref, Typ); - - -- Generate: - -- if <Id> /= null then - -- <invariant_call (<Ref>)> - -- end if; - - Append_Enabled_Item - (Item => - Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of (Id, Loc), - Right_Opnd => Make_Null (Loc)), - Then_Statements => New_List ( - Make_Invariant_Call (Ref))), - List => Stmts); - end if; - end if; - end Add_Invariant_Access_Checks; - - ------------------------- - -- Invariant_Checks_OK -- - ------------------------- - - function Invariant_Checks_OK (Typ : Entity_Id) return Boolean is - function Has_Null_Body (Proc_Id : Entity_Id) return Boolean; - -- Determine whether the body of procedure Proc_Id contains a sole - -- null statement, possibly followed by an optional return. - - function Has_Public_Visibility_Of_Subprogram return Boolean; - -- Determine whether type Typ has public visibility of subprogram - -- Subp_Id. - - ------------------- - -- Has_Null_Body -- - ------------------- - - function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is - Body_Id : Entity_Id; - Decl : Node_Id; - Spec : Node_Id; - Stmt1 : Node_Id; - Stmt2 : Node_Id; - - begin - Spec := Parent (Proc_Id); - Decl := Parent (Spec); - - -- Retrieve the entity of the invariant procedure body - - if Nkind (Spec) = N_Procedure_Specification - and then Nkind (Decl) = N_Subprogram_Declaration - then - Body_Id := Corresponding_Body (Decl); - - -- The body acts as a spec - - else - Body_Id := Proc_Id; - end if; - - -- The body will be generated later - - if No (Body_Id) then - return False; - end if; - - Spec := Parent (Body_Id); - Decl := Parent (Spec); - - pragma Assert - (Nkind (Spec) = N_Procedure_Specification - and then Nkind (Decl) = N_Subprogram_Body); - - Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); - - -- Look for a null statement followed by an optional return - -- statement. - - if Nkind (Stmt1) = N_Null_Statement then - Stmt2 := Next (Stmt1); - - if Present (Stmt2) then - return Nkind (Stmt2) = N_Simple_Return_Statement; - else - return True; - end if; - end if; - - return False; - end Has_Null_Body; - - ----------------------------------------- - -- Has_Public_Visibility_Of_Subprogram -- - ----------------------------------------- - - function Has_Public_Visibility_Of_Subprogram return Boolean is - Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); - - begin - -- An Initialization procedure must be considered visible even - -- though it is internally generated. - - if Is_Init_Proc (Defining_Entity (Subp_Decl)) then - return True; - - elsif Ekind (Scope (Typ)) /= E_Package then - return False; - - -- Internally generated code is never publicly visible except - -- for a subprogram that is the implementation of an expression - -- function. In that case the visibility is determined by the - -- last check. - - elsif not Comes_From_Source (Subp_Decl) - and then - (Nkind (Original_Node (Subp_Decl)) /= N_Expression_Function - or else not - Comes_From_Source (Defining_Entity (Subp_Decl))) - then - return False; - - -- Determine whether the subprogram is declared in the visible - -- declarations of the package containing the type. - - else - return List_Containing (Subp_Decl) = - Visible_Declarations - (Specification (Unit_Declaration_Node (Scope (Typ)))); - end if; - end Has_Public_Visibility_Of_Subprogram; - - -- Start of processing for Invariant_Checks_OK - - begin - return - Has_Invariants (Typ) - and then Present (Invariant_Procedure (Typ)) - and then not Has_Null_Body (Invariant_Procedure (Typ)) - and then Has_Public_Visibility_Of_Subprogram; - end Invariant_Checks_OK; - - -- Local variables - - Loc : constant Source_Ptr := Sloc (N); - -- Source location of subprogram contract - - Formal : Entity_Id; - Typ : Entity_Id; - - -- Start of processing for Add_Invariant_And_Predicate_Checks - - begin - Result := Empty; - - -- Process the result of a function - - if Ekind (Subp_Id) = E_Function then - Typ := Etype (Subp_Id); - - -- Generate _Result which is used in procedure _Postconditions to - -- verify the return value. - - Result := Make_Defining_Identifier (Loc, Name_uResult); - Set_Etype (Result, Typ); - - -- Add an invariant check when the return type has invariants and - -- the related function is visible to the outside. - - if Invariant_Checks_OK (Typ) then - Append_Enabled_Item - (Item => - Make_Invariant_Call (New_Occurrence_Of (Result, Loc)), - List => Stmts); - end if; - - -- Add an invariant check when the return type is an access to a - -- type with invariants. - - Add_Invariant_Access_Checks (Result); - end if; - - -- Add invariant and predicates for all formals that qualify - - Formal := First_Formal (Subp_Id); - while Present (Formal) loop - Typ := Etype (Formal); - - if Ekind (Formal) /= E_In_Parameter - or else Is_Access_Type (Typ) - then - if Invariant_Checks_OK (Typ) then - Append_Enabled_Item - (Item => - Make_Invariant_Call (New_Occurrence_Of (Formal, Loc)), - List => Stmts); - end if; - - Add_Invariant_Access_Checks (Formal); - - -- Note: we used to add predicate checks for OUT and IN OUT - -- formals here, but that was misguided, since such checks are - -- performed on the caller side, based on the predicate of the - -- actual, rather than the predicate of the formal. - - end if; - - Next_Formal (Formal); - end loop; - end Add_Invariant_And_Predicate_Checks; - - ------------------------- - -- Append_Enabled_Item -- - ------------------------- - - procedure Append_Enabled_Item (Item : Node_Id; List : in out List_Id) is - begin - -- Do not chain ignored or disabled pragmas - - if Nkind (Item) = N_Pragma - and then (Is_Ignored (Item) or else Is_Disabled (Item)) - then - null; - - -- Otherwise, add the item - - else - if No (List) then - List := New_List; - end if; - - -- If the pragma is a conjunct in a composite postcondition, it - -- has been processed in reverse order. In the postcondition body - -- if must appear before the others. - - if Nkind (Item) = N_Pragma - and then From_Aspect_Specification (Item) - and then Split_PPC (Item) - then - Prepend (Item, List); - else - Append (Item, List); - end if; - end if; - end Append_Enabled_Item; - - ------------------------------------ - -- Build_Postconditions_Procedure -- - ------------------------------------ - - procedure Build_Postconditions_Procedure - (Subp_Id : Entity_Id; - Stmts : List_Id; - Result : Entity_Id) - is - procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id); - -- Insert node Stmt before the first source declaration of the - -- related subprogram's body. If no such declaration exists, Stmt - -- becomes the last declaration. - - -------------------------------------------- - -- Insert_Before_First_Source_Declaration -- - -------------------------------------------- - - procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id) is - Decls : constant List_Id := Declarations (N); - Decl : Node_Id; - - begin - -- Inspect the declarations of the related subprogram body looking - -- for the first source declaration. - - if Present (Decls) then - Decl := First (Decls); - while Present (Decl) loop - if Comes_From_Source (Decl) then - Insert_Before (Decl, Stmt); - return; - end if; - - Next (Decl); - end loop; - - -- If we get there, then the subprogram body lacks any source - -- declarations. The body of _Postconditions now acts as the - -- last declaration. - - Append (Stmt, Decls); - - -- Ensure that the body has a declaration list - - else - Set_Declarations (N, New_List (Stmt)); - end if; - end Insert_Before_First_Source_Declaration; - - -- Local variables - - Loc : constant Source_Ptr := Sloc (N); - Params : List_Id := No_List; - Proc_Bod : Node_Id; - Proc_Id : Entity_Id; - - -- Start of processing for Build_Postconditions_Procedure - - begin - -- Nothing to do if there are no actions to check on exit - - if No (Stmts) then - return; - end if; - - Proc_Id := Make_Defining_Identifier (Loc, Name_uPostconditions); - Set_Debug_Info_Needed (Proc_Id); - Set_Postconditions_Proc (Subp_Id, Proc_Id); - - -- The related subprogram is a function, create the specification of - -- parameter _Result. - - if Present (Result) then - Params := New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Result, - Parameter_Type => - New_Occurrence_Of (Etype (Result), Loc))); - end if; - - -- Insert _Postconditions before the first source declaration of the - -- body. This ensures that the body will not cause any premature - -- freezing as it may mention types: - - -- procedure Proc (Obj : Array_Typ) is - -- procedure _postconditions is - -- begin - -- ... Obj ... - -- end _postconditions; - - -- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1)); - -- begin - - -- In the example above, Obj is of type T but the incorrect placement - -- of _Postconditions will cause a crash in gigi due to an out of - -- order reference. The body of _Postconditions must be placed after - -- the declaration of Temp to preserve correct visibility. - - -- Set an explicit End_Lavel to override the sloc of the implicit - -- RETURN statement, and prevent it from inheriting the sloc of one - -- the postconditions: this would cause confusing debug into to be - -- produced, interfering with coverage analysis tools. - - Proc_Bod := - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Proc_Id, - Parameter_Specifications => Params), - - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts, - End_Label => Make_Identifier (Loc, Chars (Proc_Id)))); - - Insert_Before_First_Source_Declaration (Proc_Bod); - Analyze (Proc_Bod); - end Build_Postconditions_Procedure; - - ----------------------------------- - -- Build_Pragma_Check_Equivalent -- - ----------------------------------- - - function Build_Pragma_Check_Equivalent - (Prag : Node_Id; - Subp_Id : Entity_Id := Empty; - Inher_Id : Entity_Id := Empty) return Node_Id - is - function Suppress_Reference (N : Node_Id) return Traverse_Result; - -- Detect whether node N references a formal parameter subject to - -- pragma Unreferenced. If this is the case, set Comes_From_Source - -- to False to suppress the generation of a reference when analyzing - -- N later on. - - ------------------------ - -- Suppress_Reference -- - ------------------------ - - function Suppress_Reference (N : Node_Id) return Traverse_Result is - Formal : Entity_Id; - - begin - if Is_Entity_Name (N) and then Present (Entity (N)) then - Formal := Entity (N); - - -- The formal parameter is subject to pragma Unreferenced. - -- Prevent the generation of a reference by resetting the - -- Comes_From_Source flag. - - if Is_Formal (Formal) - and then Has_Pragma_Unreferenced (Formal) - then - Set_Comes_From_Source (N, False); - end if; - end if; - - return OK; - end Suppress_Reference; - - procedure Suppress_References is - new Traverse_Proc (Suppress_Reference); - - -- Local variables - - Loc : constant Source_Ptr := Sloc (Prag); - Prag_Nam : constant Name_Id := Pragma_Name (Prag); - Check_Prag : Node_Id; - Formals_Map : Elist_Id; - Inher_Formal : Entity_Id; - Msg_Arg : Node_Id; - Nam : Name_Id; - Subp_Formal : Entity_Id; - - -- Start of processing for Build_Pragma_Check_Equivalent - - begin - Formals_Map := No_Elist; - - -- When the pre- or postcondition is inherited, map the formals of - -- the inherited subprogram to those of the current subprogram. - - if Present (Inher_Id) then - pragma Assert (Present (Subp_Id)); - - Formals_Map := New_Elmt_List; - - -- Create a relation <inherited formal> => <subprogram formal> - - Inher_Formal := First_Formal (Inher_Id); - Subp_Formal := First_Formal (Subp_Id); - while Present (Inher_Formal) and then Present (Subp_Formal) loop - Append_Elmt (Inher_Formal, Formals_Map); - Append_Elmt (Subp_Formal, Formals_Map); - - Next_Formal (Inher_Formal); - Next_Formal (Subp_Formal); - end loop; - end if; - - -- Copy the original pragma while performing substitutions (if - -- applicable). - - Check_Prag := - New_Copy_Tree - (Source => Prag, - Map => Formals_Map, - New_Scope => Current_Scope); - - -- Mark the pragma as being internally generated and reset the - -- Analyzed flag. - - Set_Analyzed (Check_Prag, False); - Set_Comes_From_Source (Check_Prag, False); - - -- The tree of the original pragma may contain references to the - -- formal parameters of the related subprogram. At the same time - -- the corresponding body may mark the formals as unreferenced: - - -- procedure Proc (Formal : ...) - -- with Pre => Formal ...; - - -- procedure Proc (Formal : ...) is - -- pragma Unreferenced (Formal); - -- ... - - -- This creates problems because all pragma Check equivalents are - -- analyzed at the end of the body declarations. Since all source - -- references have already been accounted for, reset any references - -- to such formals in the generated pragma Check equivalent. - - Suppress_References (Check_Prag); - - if Present (Corresponding_Aspect (Prag)) then - Nam := Chars (Identifier (Corresponding_Aspect (Prag))); - else - Nam := Prag_Nam; - end if; - - -- Convert the copy into pragma Check by correcting the name and - -- adding a check_kind argument. - - Set_Pragma_Identifier - (Check_Prag, Make_Identifier (Loc, Name_Check)); - - Prepend_To (Pragma_Argument_Associations (Check_Prag), - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Nam))); - - -- Update the error message when the pragma is inherited - - if Present (Inher_Id) then - Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag)); - - if Chars (Msg_Arg) = Name_Message then - String_To_Name_Buffer (Strval (Expression (Msg_Arg))); - - -- Insert "inherited" to improve the error message - - if Name_Buffer (1 .. 8) = "failed p" then - Insert_Str_In_Name_Buffer ("inherited ", 8); - Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer); - end if; - end if; - end if; - - return Check_Prag; - end Build_Pragma_Check_Equivalent; - - ---------------------------- - -- Process_Contract_Cases -- - ---------------------------- - - procedure Process_Contract_Cases (Stmts : in out List_Id) is - procedure Process_Contract_Cases_For (Subp_Id : Entity_Id); - -- Process pragma Contract_Cases for subprogram Subp_Id - - -------------------------------- - -- Process_Contract_Cases_For -- - -------------------------------- - - procedure Process_Contract_Cases_For (Subp_Id : Entity_Id) is - Items : constant Node_Id := Contract (Subp_Id); - Prag : Node_Id; - - begin - if Present (Items) then - Prag := Contract_Test_Cases (Items); - while Present (Prag) loop - if Pragma_Name (Prag) = Name_Contract_Cases then - Expand_Pragma_Contract_Cases - (CCs => Prag, - Subp_Id => Subp_Id, - Decls => Declarations (N), - Stmts => Stmts); - end if; - - Prag := Next_Pragma (Prag); - end loop; - end if; - end Process_Contract_Cases_For; - - -- Start of processing for Process_Contract_Cases - - begin - Process_Contract_Cases_For (Body_Id); - - if Present (Spec_Id) then - Process_Contract_Cases_For (Spec_Id); - end if; - end Process_Contract_Cases; - - ---------------------------- - -- Process_Postconditions -- - ---------------------------- - - procedure Process_Postconditions (Stmts : in out List_Id) is - procedure Process_Body_Postconditions (Post_Nam : Name_Id); - -- Collect all [refined] postconditions of a specific kind denoted - -- by Post_Nam that belong to the body and generate pragma Check - -- equivalents in list Stmts. - - procedure Process_Spec_Postconditions; - -- Collect all [inherited] postconditions of the spec and generate - -- pragma Check equivalents in list Stmts. - - --------------------------------- - -- Process_Body_Postconditions -- - --------------------------------- - - procedure Process_Body_Postconditions (Post_Nam : Name_Id) is - Items : constant Node_Id := Contract (Body_Id); - Unit_Decl : constant Node_Id := Parent (N); - Decl : Node_Id; - Prag : Node_Id; - - begin - -- Process the contract - - if Present (Items) then - Prag := Pre_Post_Conditions (Items); - while Present (Prag) loop - if Pragma_Name (Prag) = Post_Nam then - Append_Enabled_Item - (Item => Build_Pragma_Check_Equivalent (Prag), - List => Stmts); - end if; - - Prag := Next_Pragma (Prag); - end loop; - end if; - - -- The subprogram body being processed is actually the proper body - -- of a stub with a corresponding spec. The subprogram stub may - -- carry a postcondition pragma in which case it must be taken - -- into account. The pragma appears after the stub. - - if Present (Spec_Id) and then Nkind (Unit_Decl) = N_Subunit then - Decl := Next (Corresponding_Stub (Unit_Decl)); - while Present (Decl) loop - - -- Note that non-matching pragmas are skipped - - if Nkind (Decl) = N_Pragma then - if Pragma_Name (Decl) = Post_Nam then - Append_Enabled_Item - (Item => Build_Pragma_Check_Equivalent (Decl), - List => Stmts); - end if; - - -- Skip internally generated code - - elsif not Comes_From_Source (Decl) then - null; - - -- Postcondition pragmas are usually grouped together. There - -- is no need to inspect the whole declarative list. - - else - exit; - end if; - - Next (Decl); - end loop; - end if; - end Process_Body_Postconditions; - - --------------------------------- - -- Process_Spec_Postconditions -- - --------------------------------- - - procedure Process_Spec_Postconditions is - Subps : constant Subprogram_List := - Inherited_Subprograms (Spec_Id); - Items : Node_Id; - Prag : Node_Id; - Subp_Id : Entity_Id; - - begin - -- Process the contract - - Items := Contract (Spec_Id); - - if Present (Items) then - Prag := Pre_Post_Conditions (Items); - while Present (Prag) loop - if Pragma_Name (Prag) = Name_Postcondition then - Append_Enabled_Item - (Item => Build_Pragma_Check_Equivalent (Prag), - List => Stmts); - end if; - - Prag := Next_Pragma (Prag); - end loop; - end if; - - -- Process the contracts of all inherited subprograms, looking for - -- class-wide postconditions. - - for Index in Subps'Range loop - Subp_Id := Subps (Index); - Items := Contract (Subp_Id); - - if Present (Items) then - Prag := Pre_Post_Conditions (Items); - while Present (Prag) loop - if Pragma_Name (Prag) = Name_Postcondition - and then Class_Present (Prag) - then - Append_Enabled_Item - (Item => - Build_Pragma_Check_Equivalent - (Prag => Prag, - Subp_Id => Spec_Id, - Inher_Id => Subp_Id), - List => Stmts); - end if; - - Prag := Next_Pragma (Prag); - end loop; - end if; - end loop; - end Process_Spec_Postconditions; - - -- Start of processing for Process_Postconditions - - begin - -- The processing of postconditions is done in reverse order (body - -- first) to ensure the following arrangement: - - -- <refined postconditions from body> - -- <postconditions from body> - -- <postconditions from spec> - -- <inherited postconditions> - - Process_Body_Postconditions (Name_Refined_Post); - Process_Body_Postconditions (Name_Postcondition); - - if Present (Spec_Id) then - Process_Spec_Postconditions; - end if; - end Process_Postconditions; - - --------------------------- - -- Process_Preconditions -- - --------------------------- - - procedure Process_Preconditions is - Class_Pre : Node_Id := Empty; - -- The sole [inherited] class-wide precondition pragma that applies - -- to the subprogram. - - Insert_Node : Node_Id := Empty; - -- The insertion node after which all pragma Check equivalents are - -- inserted. - - procedure Merge_Preconditions (From : Node_Id; Into : Node_Id); - -- Merge two class-wide preconditions by "or else"-ing them. The - -- changes are accumulated in parameter Into. Update the error - -- message of Into. - - procedure Prepend_To_Decls (Item : Node_Id); - -- Prepend a single item to the declarations of the subprogram body - - procedure Prepend_To_Decls_Or_Save (Prag : Node_Id); - -- Save a class-wide precondition into Class_Pre or prepend a normal - -- precondition ot the declarations of the body and analyze it. - - procedure Process_Inherited_Preconditions; - -- Collect all inherited class-wide preconditions and merge them into - -- one big precondition to be evaluated as pragma Check. - - procedure Process_Preconditions_For (Subp_Id : Entity_Id); - -- Collect all preconditions of subprogram Subp_Id and prepend their - -- pragma Check equivalents to the declarations of the body. - - ------------------------- - -- Merge_Preconditions -- - ------------------------- - - procedure Merge_Preconditions (From : Node_Id; Into : Node_Id) is - function Expression_Arg (Prag : Node_Id) return Node_Id; - -- Return the boolean expression argument of a precondition while - -- updating its parenteses count for the subsequent merge. - - function Message_Arg (Prag : Node_Id) return Node_Id; - -- Return the message argument of a precondition - - -------------------- - -- Expression_Arg -- - -------------------- - - function Expression_Arg (Prag : Node_Id) return Node_Id is - Args : constant List_Id := Pragma_Argument_Associations (Prag); - Arg : constant Node_Id := Get_Pragma_Arg (Next (First (Args))); - - begin - if Paren_Count (Arg) = 0 then - Set_Paren_Count (Arg, 1); - end if; - - return Arg; - end Expression_Arg; - - ----------------- - -- Message_Arg -- - ----------------- - - function Message_Arg (Prag : Node_Id) return Node_Id is - Args : constant List_Id := Pragma_Argument_Associations (Prag); - begin - return Get_Pragma_Arg (Last (Args)); - end Message_Arg; - - -- Local variables - - From_Expr : constant Node_Id := Expression_Arg (From); - From_Msg : constant Node_Id := Message_Arg (From); - Into_Expr : constant Node_Id := Expression_Arg (Into); - Into_Msg : constant Node_Id := Message_Arg (Into); - Loc : constant Source_Ptr := Sloc (Into); - - -- Start of processing for Merge_Preconditions - - begin - -- Merge the two preconditions by "or else"-ing them - - Rewrite (Into_Expr, - Make_Or_Else (Loc, - Right_Opnd => Relocate_Node (Into_Expr), - Left_Opnd => From_Expr)); - - -- Merge the two error messages to produce a single message of the - -- form: - - -- failed precondition from ... - -- also failed inherited precondition from ... - - if not Exception_Locations_Suppressed then - Start_String (Strval (Into_Msg)); - Store_String_Char (ASCII.LF); - Store_String_Chars (" also "); - Store_String_Chars (Strval (From_Msg)); - - Set_Strval (Into_Msg, End_String); - end if; - end Merge_Preconditions; - - ---------------------- - -- Prepend_To_Decls -- - ---------------------- - - procedure Prepend_To_Decls (Item : Node_Id) is - Decls : List_Id := Declarations (N); - - begin - -- Ensure that the body has a declarative list - - if No (Decls) then - Decls := New_List; - Set_Declarations (N, Decls); - end if; - - Prepend_To (Decls, Item); - end Prepend_To_Decls; - - ------------------------------ - -- Prepend_To_Decls_Or_Save -- - ------------------------------ - - procedure Prepend_To_Decls_Or_Save (Prag : Node_Id) is - Check_Prag : Node_Id; - - begin - Check_Prag := Build_Pragma_Check_Equivalent (Prag); - - -- Save the sole class-wide precondition (if any) for the next - -- step where it will be merged with inherited preconditions. - - if Class_Present (Prag) then - pragma Assert (No (Class_Pre)); - Class_Pre := Check_Prag; - - -- Accumulate the corresponding Check pragmas at the top of the - -- declarations. Prepending the items ensures that they will be - -- evaluated in their original order. - - else - if Present (Insert_Node) then - Insert_After (Insert_Node, Check_Prag); - else - Prepend_To_Decls (Check_Prag); - end if; - - Analyze (Check_Prag); - end if; - end Prepend_To_Decls_Or_Save; - - ------------------------------------- - -- Process_Inherited_Preconditions -- - ------------------------------------- - - procedure Process_Inherited_Preconditions is - Subps : constant Subprogram_List := - Inherited_Subprograms (Spec_Id); - Check_Prag : Node_Id; - Items : Node_Id; - Prag : Node_Id; - Subp_Id : Entity_Id; - - begin - -- Process the contracts of all inherited subprograms, looking for - -- class-wide preconditions. - - for Index in Subps'Range loop - Subp_Id := Subps (Index); - Items := Contract (Subp_Id); - - if Present (Items) then - Prag := Pre_Post_Conditions (Items); - while Present (Prag) loop - if Pragma_Name (Prag) = Name_Precondition - and then Class_Present (Prag) - then - Check_Prag := - Build_Pragma_Check_Equivalent - (Prag => Prag, - Subp_Id => Spec_Id, - Inher_Id => Subp_Id); - - -- The spec or an inherited subprogram already yielded - -- a class-wide precondition. Merge the existing - -- precondition with the current one using "or else". - - if Present (Class_Pre) then - Merge_Preconditions (Check_Prag, Class_Pre); - else - Class_Pre := Check_Prag; - end if; - end if; - - Prag := Next_Pragma (Prag); - end loop; - end if; - end loop; - - -- Add the merged class-wide preconditions - - if Present (Class_Pre) then - Prepend_To_Decls (Class_Pre); - Analyze (Class_Pre); - end if; - end Process_Inherited_Preconditions; - - ------------------------------- - -- Process_Preconditions_For -- - ------------------------------- - - procedure Process_Preconditions_For (Subp_Id : Entity_Id) is - Items : constant Node_Id := Contract (Subp_Id); - Decl : Node_Id; - Prag : Node_Id; - Subp_Decl : Node_Id; - - begin - -- Process the contract - - if Present (Items) then - Prag := Pre_Post_Conditions (Items); - while Present (Prag) loop - if Pragma_Name (Prag) = Name_Precondition then - Prepend_To_Decls_Or_Save (Prag); - end if; - - Prag := Next_Pragma (Prag); - end loop; - end if; - - -- The subprogram declaration being processed is actually a body - -- stub. The stub may carry a precondition pragma in which case it - -- must be taken into account. The pragma appears after the stub. - - Subp_Decl := Unit_Declaration_Node (Subp_Id); - - if Nkind (Subp_Decl) = N_Subprogram_Body_Stub then - - -- Inspect the declarations following the body stub - - Decl := Next (Subp_Decl); - while Present (Decl) loop - - -- Note that non-matching pragmas are skipped - - if Nkind (Decl) = N_Pragma then - if Pragma_Name (Decl) = Name_Precondition then - Prepend_To_Decls_Or_Save (Decl); - end if; - - -- Skip internally generated code - - elsif not Comes_From_Source (Decl) then - null; - - -- Preconditions are usually grouped together. There is no - -- need to inspect the whole declarative list. - - else - exit; - end if; - - Next (Decl); - end loop; - end if; - end Process_Preconditions_For; - - -- Local variables - - Decls : constant List_Id := Declarations (N); - Decl : Node_Id; - - -- Start of processing for Process_Preconditions - - begin - -- Find the last internally generate declaration starting from the - -- top of the body declarations. This ensures that discriminals and - -- subtypes are properly visible to the pragma Check equivalents. - - if Present (Decls) then - Decl := First (Decls); - while Present (Decl) loop - exit when Comes_From_Source (Decl); - Insert_Node := Decl; - Next (Decl); - end loop; - end if; - - -- The processing of preconditions is done in reverse order (body - -- first) because each pragma Check equivalent is inserted at the - -- top of the declarations. This ensures that the final order is - -- consistent with following diagram: - - -- <inherited preconditions> - -- <preconditions from spec> - -- <preconditions from body> - - Process_Preconditions_For (Body_Id); - - if Present (Spec_Id) then - Process_Preconditions_For (Spec_Id); - Process_Inherited_Preconditions; - end if; - end Process_Preconditions; - - -- Local variables - - Restore_Scope : Boolean := False; - Result : Entity_Id; - Stmts : List_Id := No_List; - Subp_Id : Entity_Id; - - -- Start of processing for Expand_Subprogram_Contract - - begin - -- Obtain the entity of the initial declaration - - if Present (Spec_Id) then - Subp_Id := Spec_Id; - else - Subp_Id := Body_Id; - end if; - - -- Do not perform expansion activity when it is not needed - - if not Expander_Active then - return; - - -- ASIS requires an unaltered tree - - elsif ASIS_Mode then - return; - - -- GNATprove does not need the executable semantics of a contract - - elsif GNATprove_Mode then - return; - - -- The contract of a generic subprogram or one declared in a generic - -- context is not expanded as the corresponding instance will provide - -- the executable semantics of the contract. - - elsif Is_Generic_Subprogram (Subp_Id) or else Inside_A_Generic then - return; - - -- All subprograms carry a contract, but for some it is not significant - -- and should not be processed. This is a small optimization. - - elsif not Has_Significant_Contract (Subp_Id) then - return; - end if; - - -- Do not re-expand the same contract. This scenario occurs when a - -- construct is rewritten into something else during its analysis - -- (expression functions for instance). - - if Has_Expanded_Contract (Subp_Id) then - return; - - -- Otherwise mark the subprogram - - else - Set_Has_Expanded_Contract (Subp_Id); - end if; - - -- Ensure that the formal parameters are visible when expanding all - -- contract items. - - if not In_Open_Scopes (Subp_Id) then - Restore_Scope := True; - Push_Scope (Subp_Id); - - if Is_Generic_Subprogram (Subp_Id) then - Install_Generic_Formals (Subp_Id); - else - Install_Formals (Subp_Id); - end if; - end if; - - -- The expansion of a subprogram contract involves the creation of Check - -- pragmas to verify the contract assertions of the spec and body in a - -- particular order. The order is as follows: - - -- function Example (...) return ... is - -- procedure _Postconditions (...) is - -- begin - -- <refined postconditions from body> - -- <postconditions from body> - -- <postconditions from spec> - -- <inherited postconditions> - -- <contract case consequences> - -- <invariant check of function result> - -- <invariant and predicate checks of parameters> - -- end _Postconditions; - - -- <inherited preconditions> - -- <preconditions from spec> - -- <preconditions from body> - -- <contract case conditions> - - -- <source declarations> - -- begin - -- <source statements> - - -- _Preconditions (Result); - -- return Result; - -- end Example; - - -- Routine _Postconditions holds all contract assertions that must be - -- verified on exit from the related subprogram. - - -- Step 1: Handle all preconditions. This action must come before the - -- processing of pragma Contract_Cases because the pragma prepends items - -- to the body declarations. - - Process_Preconditions; - - -- Step 2: Handle all postconditions. This action must come before the - -- processing of pragma Contract_Cases because the pragma appends items - -- to list Stmts. - - Process_Postconditions (Stmts); - - -- Step 3: Handle pragma Contract_Cases. This action must come before - -- the processing of invariants and predicates because those append - -- items to list Smts. - - Process_Contract_Cases (Stmts); - - -- Step 4: Apply invariant and predicate checks on a function result and - -- all formals. The resulting checks are accumulated in list Stmts. - - Add_Invariant_And_Predicate_Checks (Subp_Id, Stmts, Result); - - -- Step 5: Construct procedure _Postconditions - - Build_Postconditions_Procedure (Subp_Id, Stmts, Result); - - if Restore_Scope then - End_Scope; - end if; - end Expand_Subprogram_Contract; - -------------------------------------------- -- Has_Unconstrained_Access_Discriminants -- -------------------------------------------- @@ -8205,8 +7016,8 @@ package body Exp_Ch6 is begin -- We suppress the initialization of the dispatch table entry when - -- VM_Target because the dispatching mechanism is handled internally - -- by the VM. + -- not Tagged_Type_Expansion because the dispatching mechanism is + -- handled internally by the target. if Is_Dispatching_Operation (Subp) and then not Is_Abstract_Subprogram (Subp) @@ -8290,7 +7101,7 @@ package body Exp_Ch6 is if Nkind (Parent (Subp)) = N_Procedure_Specification and then Null_Present (Parent (Subp)) then - Analyze_Subprogram_Contract (Subp); + Analyze_Entry_Or_Subprogram_Contract (Subp); end if; end Freeze_Subprogram; @@ -8481,9 +7292,7 @@ package body Exp_Ch6 is -- pool, and pass the pool. Use 'Unrestricted_Access because the -- pool may not be aliased. - if VM_Target = No_VM - and then Present (Associated_Storage_Pool (Acc_Type)) - then + if Present (Associated_Storage_Pool (Acc_Type)) then Alloc_Form := User_Storage_Pool; Pool := Make_Attribute_Reference (Loc, @@ -8884,14 +7693,14 @@ package body Exp_Ch6 is ---------------------------------------------------- procedure Make_Build_In_Place_Call_In_Object_Declaration - (Object_Decl : Node_Id; + (Obj_Decl : Node_Id; Function_Call : Node_Id) is - Loc : Source_Ptr; - Obj_Def_Id : constant Entity_Id := - Defining_Identifier (Object_Decl); - Enclosing_Func : constant Entity_Id := - Enclosing_Subprogram (Obj_Def_Id); + Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); + Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id); + Loc : constant Source_Ptr := Sloc (Function_Call); + Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl); + Call_Deref : Node_Id; Caller_Object : Node_Id; Def_Id : Entity_Id; @@ -8930,8 +7739,6 @@ package body Exp_Ch6 is Set_Is_Expanded_Build_In_Place_Call (Func_Call); - Loc := Sloc (Function_Call); - if Is_Entity_Name (Name (Func_Call)) then Function_Id := Entity (Name (Func_Call)); @@ -8973,11 +7780,11 @@ package body Exp_Ch6 is -- cause freezing. if Definite - and then not Is_Return_Object (Defining_Identifier (Object_Decl)) + and then not Is_Return_Object (Defining_Identifier (Obj_Decl)) then - Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); + Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl); else - Insert_Action (Object_Decl, Ptr_Typ_Decl); + Insert_Action (Obj_Decl, Ptr_Typ_Decl); end if; -- Force immediate freezing of Ptr_Typ because Res_Decl will be @@ -9002,35 +7809,32 @@ package body Exp_Ch6 is -- aggregate return object, when the call result should really be -- directly built in place in the aggregate and not in a temporary. ???) - if Is_Return_Object (Defining_Identifier (Object_Decl)) then + if Is_Return_Object (Defining_Identifier (Obj_Decl)) then Pass_Caller_Acc := True; -- When the enclosing function has a BIP_Alloc_Form formal then we -- pass it along to the callee (such as when the enclosing function -- has an unconstrained or tagged result type). - if Needs_BIP_Alloc_Form (Enclosing_Func) then - if VM_Target = No_VM and then - RTE_Available (RE_Root_Storage_Pool_Ptr) - then + if Needs_BIP_Alloc_Form (Encl_Func) then + if RTE_Available (RE_Root_Storage_Pool_Ptr) then Pool_Actual := - New_Occurrence_Of (Build_In_Place_Formal - (Enclosing_Func, BIP_Storage_Pool), Loc); + New_Occurrence_Of + (Build_In_Place_Formal (Encl_Func, BIP_Storage_Pool), Loc); - -- The build-in-place pool formal is not built on .NET/JVM + -- The build-in-place pool formal is not built on e.g. ZFP else Pool_Actual := Empty; end if; Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Func_Call, - Function_Id, + (Function_Call => Func_Call, + Function_Id => Function_Id, Alloc_Form_Exp => New_Occurrence_Of - (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form), - Loc), - Pool_Actual => Pool_Actual); + (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc), + Pool_Actual => Pool_Actual); -- Otherwise, if enclosing function has a definite result subtype, -- then caller allocation will be used. @@ -9040,27 +7844,27 @@ package body Exp_Ch6 is (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); end if; - if Needs_BIP_Finalization_Master (Enclosing_Func) then + if Needs_BIP_Finalization_Master (Encl_Func) then Fmaster_Actual := New_Occurrence_Of (Build_In_Place_Formal - (Enclosing_Func, BIP_Finalization_Master), Loc); + (Encl_Func, BIP_Finalization_Master), Loc); end if; -- Retrieve the BIPacc formal from the enclosing function and convert -- it to the access type of the callee's BIP_Object_Access formal. Caller_Object := - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of - (Etype - (Build_In_Place_Formal (Function_Id, BIP_Object_Access)), - Loc), - Expression => - New_Occurrence_Of - (Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access), - Loc)); + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Etype + (Build_In_Place_Formal (Function_Id, BIP_Object_Access)), + Loc), + Expression => + New_Occurrence_Of + (Build_In_Place_Formal (Encl_Func, BIP_Object_Access), + Loc)); -- In the definite case, add an implicit actual to the function call -- that provides access to the declared object. An unchecked conversion @@ -9082,6 +7886,35 @@ package body Exp_Ch6 is Add_Unconstrained_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); + -- The allocation for indefinite library-level objects occurs on the + -- heap as opposed to the secondary stack. This accommodates DLLs where + -- the secondary stack is destroyed after each library unload. This is + -- a hybrid mechanism where a stack-allocated object lives on the heap. + + elsif Is_Library_Level_Entity (Defining_Identifier (Obj_Decl)) + and then not Restriction_Active (No_Implicit_Heap_Allocations) + then + Add_Unconstrained_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Global_Heap); + Caller_Object := Empty; + + -- Create a finalization master for the access result type to ensure + -- that the heap allocation can properly chain the object and later + -- finalize it when the library unit goes out of scope. + + if Needs_Finalization (Etype (Func_Call)) then + Build_Finalization_Master + (Typ => Ptr_Typ, + For_Lib_Level => True, + Insertion_Node => Ptr_Typ_Decl); + + Fmaster_Actual := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc), + Attribute_Name => Name_Unrestricted_Access); + end if; + -- In other indefinite cases, pass an indication to do the allocation -- on the secondary stack and set Caller_Object to Empty so that a null -- value will be passed for the caller's object address. A transient @@ -9092,7 +7925,7 @@ package body Exp_Ch6 is (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); Caller_Object := Empty; - Establish_Transient_Scope (Object_Decl, Sec_Stack => True); + Establish_Transient_Scope (Obj_Decl, Sec_Stack => True); end if; -- Pass along any finalization master actual, which is needed in the @@ -9104,7 +7937,7 @@ package body Exp_Ch6 is Func_Id => Function_Id, Master_Exp => Fmaster_Actual); - if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement + if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement and then Has_Task (Result_Subt) then -- Here we're passing along the master that was passed in to this @@ -9113,8 +7946,8 @@ package body Exp_Ch6 is Add_Task_Actuals_To_Build_In_Place_Call (Func_Call, Function_Id, Master_Actual => - New_Occurrence_Of (Build_In_Place_Formal - (Enclosing_Func, BIP_Task_Master), Loc)); + New_Occurrence_Of + (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc)); else Add_Task_Actuals_To_Build_In_Place_Call @@ -9147,7 +7980,7 @@ package body Exp_Ch6 is -- the object as having no initialization. if Definite - and then not Is_Return_Object (Defining_Identifier (Object_Decl)) + and then not Is_Return_Object (Defining_Identifier (Obj_Decl)) then -- The related object declaration is encased in a transient block -- because the build-in-place function call contains at least one @@ -9161,14 +7994,12 @@ package body Exp_Ch6 is -- which prompted the generation of the transient block. To resolve -- this scenario, store the build-in-place call. - if Scope_Is_Transient - and then Node_To_Be_Wrapped = Object_Decl - then + if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl); end if; - Set_Expression (Object_Decl, Empty); - Set_No_Initialization (Object_Decl); + Set_Expression (Obj_Decl, Empty); + Set_No_Initialization (Obj_Decl); -- In case of an indefinite result subtype, or if the call is the -- return expression of an enclosing BIP function, rewrite the object @@ -9179,20 +8010,28 @@ package body Exp_Ch6 is else Call_Deref := - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Def_Id, Loc)); - - Loc := Sloc (Object_Decl); - Rewrite (Object_Decl, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'D'), - Access_Definition => Empty, - Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), + Make_Explicit_Dereference (Obj_Loc, + Prefix => New_Occurrence_Of (Def_Id, Obj_Loc)); + + Rewrite (Obj_Decl, + Make_Object_Renaming_Declaration (Obj_Loc, + Defining_Identifier => Make_Temporary (Obj_Loc, 'D'), + Subtype_Mark => New_Occurrence_Of (Result_Subt, Obj_Loc), Name => Call_Deref)); - Set_Renamed_Object (Defining_Identifier (Object_Decl), Call_Deref); + Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref); + + -- If the original entity comes from source, then mark the new + -- entity as needing debug information, even though it's defined + -- by a generated renaming that does not come from source, so that + -- the Materialize_Entity flag will be set on the entity when + -- Debug_Renaming_Declaration is called during analysis. + + if Comes_From_Source (Obj_Def_Id) then + Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl)); + end if; - Analyze (Object_Decl); + Analyze (Obj_Decl); -- Replace the internal identifier of the renaming declaration's -- entity with identifier of the original object entity. We also have @@ -9206,31 +8045,27 @@ package body Exp_Ch6 is -- corrupted. Finally, the homonym chain must be preserved as well. declare - Renaming_Def_Id : constant Entity_Id := - Defining_Identifier (Object_Decl); - Next_Entity_Temp : constant Entity_Id := - Next_Entity (Renaming_Def_Id); + Ren_Id : constant Entity_Id := Defining_Entity (Obj_Decl); + Next_Id : constant Entity_Id := Next_Entity (Ren_Id); + begin - Set_Chars (Renaming_Def_Id, Chars (Obj_Def_Id)); + Set_Chars (Ren_Id, Chars (Obj_Def_Id)); -- Swap next entity links in preparation for exchanging entities - Set_Next_Entity (Renaming_Def_Id, Next_Entity (Obj_Def_Id)); - Set_Next_Entity (Obj_Def_Id, Next_Entity_Temp); - Set_Homonym (Renaming_Def_Id, Homonym (Obj_Def_Id)); + Set_Next_Entity (Ren_Id, Next_Entity (Obj_Def_Id)); + Set_Next_Entity (Obj_Def_Id, Next_Id); + Set_Homonym (Ren_Id, Homonym (Obj_Def_Id)); - Exchange_Entities (Renaming_Def_Id, Obj_Def_Id); + Exchange_Entities (Ren_Id, Obj_Def_Id); -- Preserve source indication of original declaration, so that -- xref information is properly generated for the right entity. - Preserve_Comes_From_Source - (Object_Decl, Original_Node (Object_Decl)); - - Preserve_Comes_From_Source - (Obj_Def_Id, Original_Node (Object_Decl)); + Preserve_Comes_From_Source (Obj_Decl, Original_Node (Obj_Decl)); + Preserve_Comes_From_Source (Obj_Def_Id, Original_Node (Obj_Decl)); - Set_Comes_From_Source (Renaming_Def_Id, False); + Set_Comes_From_Source (Ren_Id, False); end; end if; @@ -9242,8 +8077,8 @@ package body Exp_Ch6 is -- improve this treatment when build-in-place functions with class-wide -- results are implemented. ??? - if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then - Set_Etype (Defining_Identifier (Object_Decl), Result_Subt); + if Is_Class_Wide_Type (Etype (Defining_Identifier (Obj_Decl))) then + Set_Etype (Defining_Identifier (Obj_Decl), Result_Subt); end if; end Make_Build_In_Place_Call_In_Object_Declaration; @@ -9489,6 +8324,143 @@ package body Exp_Ch6 is end if; end Needs_Result_Accessibility_Level; + --------------------------------- + -- Rewrite_Function_Call_For_C -- + --------------------------------- + + procedure Rewrite_Function_Call_For_C (N : Node_Id) is + Func_Id : constant Entity_Id := Entity (Name (N)); + Func_Decl : constant Node_Id := Unit_Declaration_Node (Func_Id); + Par : constant Node_Id := Parent (N); + Proc_Id : constant Entity_Id := Defining_Entity (Next (Func_Decl)); + Loc : constant Source_Ptr := Sloc (Par); + Actuals : List_Id; + Last_Formal : Entity_Id; + + begin + -- The actuals may be given by named associations, so the added actual + -- that is the target of the return value of the call must be a named + -- association as well, so we retrieve the name of the generated + -- out_formal. + + Last_Formal := First_Formal (Proc_Id); + while Present (Next_Formal (Last_Formal)) loop + Last_Formal := Next_Formal (Last_Formal); + end loop; + + Actuals := Parameter_Associations (N); + + -- The original function may lack parameters + + if No (Actuals) then + Actuals := New_List; + end if; + + -- If the function call is the expression of an assignment statement, + -- transform the assignment into a procedure call. Generate: + + -- LHS := Func_Call (...); + + -- Proc_Call (..., LHS); + + if Nkind (Par) = N_Assignment_Statement then + Append_To (Actuals, + Make_Parameter_Association (Loc, + Selector_Name => + Make_Identifier (Loc, Chars (Last_Formal)), + Explicit_Actual_Parameter => Name (Par))); + + Rewrite (Par, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc_Id, Loc), + Parameter_Associations => Actuals)); + Analyze (Par); + + -- Otherwise the context is an expression. Generate a temporary and a + -- procedure call to obtain the function result. Generate: + + -- ... Func_Call (...) ... + + -- Temp : ...; + -- Proc_Call (..., Temp); + -- ... Temp ... + + else + declare + Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); + Call : Node_Id; + Decl : Node_Id; + + begin + -- Generate: + -- Temp : ...; + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Object_Definition => + New_Occurrence_Of (Etype (Func_Id), Loc)); + + -- Generate: + -- Proc_Call (..., Temp); + + Append_To (Actuals, + Make_Parameter_Association (Loc, + Selector_Name => + Make_Identifier (Loc, Chars (Last_Formal)), + Explicit_Actual_Parameter => + New_Occurrence_Of (Temp_Id, Loc))); + + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc_Id, Loc), + Parameter_Associations => Actuals); + + Insert_Actions (Par, New_List (Decl, Call)); + Rewrite (N, New_Occurrence_Of (Temp_Id, Loc)); + end; + end if; + end Rewrite_Function_Call_For_C; + + ------------------------------------ + -- Set_Enclosing_Sec_Stack_Return -- + ------------------------------------ + + procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id) is + P : Node_Id := N; + + begin + -- Due to a possible mix of internally generated blocks, source blocks + -- and loops, the scope stack may not be contiguous as all labels are + -- inserted at the top level within the related function. Instead, + -- perform a parent-based traversal and mark all appropriate constructs. + + while Present (P) loop + + -- Mark the label of a source or internally generated block or + -- loop. + + if Nkind_In (P, N_Block_Statement, N_Loop_Statement) then + Set_Sec_Stack_Needed_For_Return (Entity (Identifier (P))); + + -- Mark the enclosing function + + elsif Nkind (P) = N_Subprogram_Body then + if Present (Corresponding_Spec (P)) then + Set_Sec_Stack_Needed_For_Return (Corresponding_Spec (P)); + else + Set_Sec_Stack_Needed_For_Return (Defining_Entity (P)); + end if; + + -- Do not go beyond the enclosing function + + exit; + end if; + + P := Parent (P); + end loop; + end Set_Enclosing_Sec_Stack_Return; + ------------------------ -- Unnest_Subprograms -- ------------------------ diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 5cbcc965cf4..7ae19de6377 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -41,12 +41,6 @@ package Exp_Ch6 is -- This procedure contains common processing for Expand_N_Function_Call, -- Expand_N_Procedure_Statement, and Expand_N_Entry_Call. - procedure Expand_Subprogram_Contract (N : Node_Id); - -- Expand the contracts of a subprogram body and its correspoding spec (if - -- any). This routine processes all [refined] pre- and postconditions as - -- well as Contract_Cases, invariants and predicates. N denotes the body of - -- the subprogram. - procedure Freeze_Subprogram (N : Node_Id); -- generate the appropriate expansions related to Subprogram freeze -- nodes (e.g. the filling of the corresponding Dispatch Table for @@ -116,6 +110,13 @@ package Exp_Ch6 is -- function Func, and returns its Entity_Id. It is a bug if not found; the -- caller should ensure this is called only when the extra formal exists. + function Build_Procedure_Body_Form + (Func_Id : Entity_Id; Func_Body : Node_Id) return Node_Id; + -- Create a procedure body which emulates the behavior of function Func_Id. + -- Func_Body is the root of the body of the function before its analysis. + -- The returned node is the root of the procedure body which will replace + -- the original function body, which is not needed for the C program. + procedure Initialize; -- Initialize internal tables @@ -178,7 +179,7 @@ package Exp_Ch6 is -- call. procedure Make_Build_In_Place_Call_In_Object_Declaration - (Object_Decl : Node_Id; + (Obj_Decl : Node_Id; Function_Call : Node_Id); -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that -- occurs as the expression initializing an object declaration by diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 23d97d502e8..f4db92fb5c6 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -61,7 +61,6 @@ with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Snames; use Snames; with Stand; use Stand; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; @@ -458,16 +457,13 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); - -- Create TSS primitive Finalize_Address for non-VM targets. JVM and - -- .NET do not support address arithmetic and unchecked conversions. + -- Create TSS primitive Finalize_Address. - if VM_Target = No_VM then - Set_TSS (Typ, - Make_Deep_Proc - (Prim => Address_Case, - Typ => Typ, - Stmts => Make_Deep_Array_Body (Address_Case, Typ))); - end if; + Set_TSS (Typ, + Make_Deep_Proc + (Prim => Address_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Address_Case, Typ))); end if; end Build_Array_Deep_Procs; @@ -767,6 +763,7 @@ package body Exp_Ch7 is procedure Build_Finalization_Master (Typ : Entity_Id; For_Anonymous : Boolean := False; + For_Lib_Level : Boolean := False; For_Private : Boolean := False; Context_Scope : Entity_Id := Empty; Insertion_Node : Node_Id := Empty) @@ -845,13 +842,11 @@ package body Exp_Ch7 is if Restriction_Active (No_Finalization) then return; - -- Do not process C, C++, CIL and Java types since it is assumend that - -- the non-Ada side will handle their clean up. + -- Do not process C, C++ types since it is assumed that the non-Ada side + -- will handle their clean up. elsif Convention (Desig_Typ) = Convention_C - or else Convention (Desig_Typ) = Convention_CIL or else Convention (Desig_Typ) = Convention_CPP - or else Convention (Desig_Typ) = Convention_Java then return; @@ -896,13 +891,6 @@ package body Exp_Ch7 is then return; - -- For .NET/JVM targets, allow the processing of access-to-controlled - -- types where the designated type is explicitly derived from [Limited_] - -- Controlled. - - elsif VM_Target /= No_VM and then not Is_Controlled (Desig_Typ) then - return; - -- Do not create finalization masters in GNATprove mode because this -- unwanted extra expansion. A compilation in this mode keeps the tree -- as close as possible to the original sources. @@ -948,85 +936,81 @@ package body Exp_Ch7 is New_Occurrence_Of (RTE (RE_Finalization_Master), Loc))); -- Set the associated pool and primitive Finalize_Address of the new - -- finalization master. This step is skipped on .NET/JVM because the - -- target does not support storage pools or address arithmetic. - - if VM_Target = No_VM then + -- finalization master. - -- The access type has a user-defined storage pool, use it + -- The access type has a user-defined storage pool, use it - if Present (Associated_Storage_Pool (Ptr_Typ)) then - Pool_Id := Associated_Storage_Pool (Ptr_Typ); + if Present (Associated_Storage_Pool (Ptr_Typ)) then + Pool_Id := Associated_Storage_Pool (Ptr_Typ); - -- Otherwise the default choice is the global storage pool + -- Otherwise the default choice is the global storage pool - else - Pool_Id := RTE (RE_Global_Pool_Object); - Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); - end if; + else + Pool_Id := RTE (RE_Global_Pool_Object); + Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); + end if; - -- Generate: - -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access); + -- Generate: + -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access); - Append_To (Actions, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Fin_Mas_Id, Loc), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Pool_Id, Loc), - Attribute_Name => Name_Unrestricted_Access)))); + Append_To (Actions, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Fin_Mas_Id, Loc), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Pool_Id, Loc), + Attribute_Name => Name_Unrestricted_Access)))); - -- Finalize_Address is not generated in CodePeer mode because the - -- body contains address arithmetic. Skip this step. + -- Finalize_Address is not generated in CodePeer mode because the + -- body contains address arithmetic. Skip this step. - if CodePeer_Mode then - null; + if CodePeer_Mode then + null; - -- Associate the Finalize_Address primitive of the designated type - -- with the finalization master of the access type. The designated - -- type must be forzen as Finalize_Address is generated when the - -- freeze node is expanded. + -- Associate the Finalize_Address primitive of the designated type + -- with the finalization master of the access type. The designated + -- type must be forzen as Finalize_Address is generated when the + -- freeze node is expanded. - elsif Is_Frozen (Desig_Typ) - and then Present (Finalize_Address (Desig_Typ)) + elsif Is_Frozen (Desig_Typ) + and then Present (Finalize_Address (Desig_Typ)) - -- The finalization master of an anonymous access type may need - -- to be inserted in a specific place in the tree. For instance: + -- The finalization master of an anonymous access type may need + -- to be inserted in a specific place in the tree. For instance: - -- type Comp_Typ; + -- type Comp_Typ; - -- <finalization master of "access Comp_Typ"> + -- <finalization master of "access Comp_Typ"> - -- type Rec_Typ is record - -- Comp : access Comp_Typ; - -- end record; + -- type Rec_Typ is record + -- Comp : access Comp_Typ; + -- end record; - -- <freeze node for Comp_Typ> - -- <freeze node for Rec_Typ> + -- <freeze node for Comp_Typ> + -- <freeze node for Rec_Typ> - -- Due to this oddity, the anonymous access type is stored for - -- later processing (see below). + -- Due to this oddity, the anonymous access type is stored for + -- later processing (see below). - and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type - then - -- Generate: - -- Set_Finalize_Address - -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); + and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type + then + -- Generate: + -- Set_Finalize_Address + -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); - Append_To (Actions, - Make_Set_Finalize_Address_Call - (Loc => Loc, - Ptr_Typ => Ptr_Typ)); + Append_To (Actions, + Make_Set_Finalize_Address_Call + (Loc => Loc, + Ptr_Typ => Ptr_Typ)); - -- Otherwise the designated type is either anonymous access or a - -- Taft-amendment type and has not been frozen. Store the access - -- type for later processing (see Freeze_Type). + -- Otherwise the designated type is either anonymous access or a + -- Taft-amendment type and has not been frozen. Store the access + -- type for later processing (see Freeze_Type). - else - Add_Pending_Access_Type (Desig_Typ, Ptr_Typ); - end if; + else + Add_Pending_Access_Type (Desig_Typ, Ptr_Typ); end if; -- A finalization master created for an anonymous access type or an @@ -1056,6 +1040,15 @@ package body Exp_Ch7 is Pop_Scope; + -- The finalization master belongs to an access result type related + -- to a build-in-place function call used to initialize a library + -- level object. The master must be inserted in front of the access + -- result type declaration denoted by Insertion_Node. + + elsif For_Lib_Level then + pragma Assert (Present (Insertion_Node)); + Insert_Actions (Insertion_Node, Actions); + -- Otherwise the finalization master and its initialization become a -- part of the freeze node. @@ -1116,7 +1109,7 @@ package body Exp_Ch7 is Finalizer_Decls : List_Id := No_List; -- Local variable declarations. This list holds the label declarations -- of all jump block alternatives as well as the declaration of the - -- local exception occurence and the raised flag: + -- local exception occurrence and the raised flag: -- E : Exception_Occurrence; -- Raised : Boolean := False; -- L<counter value> : label; @@ -1292,7 +1285,7 @@ package body Exp_Ch7 is Prepend_To (Decls, Counter_Decl); Prepend_To (Decls, Counter_Typ_Decl); - -- The counter and its associated type must be manually analized + -- The counter and its associated type must be manually analyzed -- since N has already been analyzed. Use the scope of the spec -- when inserting in a package. @@ -1844,6 +1837,15 @@ package body Exp_Ch7 is elsif Is_Ignored_Ghost_Entity (Obj_Id) then null; + -- The expansion of iterator loops generates an object + -- declaration where the Ekind is explicitly set to loop + -- parameter. This is to ensure that the loop parameter behaves + -- as a constant from user code point of view. Such object are + -- never controlled and do not require finalization. + + elsif Ekind (Obj_Id) = E_Loop_Parameter then + null; + -- The object is of the form: -- Obj : Typ [:= Expr]; @@ -2869,10 +2871,9 @@ package body Exp_Ch7 is -- end if; -- The generated code effectively detaches the temporary from the - -- caller finalization master and deallocates the object. This is - -- disabled on .NET/JVM because pools are not supported. + -- caller finalization master and deallocates the object. - if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then + if Is_Return_Object (Obj_Id) then declare Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id); begin @@ -3261,14 +3262,10 @@ package body Exp_Ch7 is -- order to detect this scenario, save the state of entry into the -- finalization code. - -- No need to do this for VM case, since VM version of Ada.Exceptions - -- does not include routine Raise_From_Controlled_Operation which is the - -- the sole user of flag Abort. - -- This is not needed for library-level finalizers as they are called by -- the environment task and cannot be aborted. - if VM_Target = No_VM and then not For_Package then + if not For_Package then if Abort_Allowed then Data.Abort_Id := Make_Temporary (Loc, 'A'); @@ -3294,7 +3291,7 @@ package body Exp_Ch7 is Data.Abort_Id := Empty; end if; - -- .NET/JVM or library-level finalizers + -- Library-level finalizers else Data.Abort_Id := Empty; @@ -3340,7 +3337,7 @@ package body Exp_Ch7 is Expr : Node_Id; begin - -- Standard run-time and .NET/JVM targets use the specialized routine + -- Standard run-time use the specialized routine -- Raise_From_Controlled_Operation. if Exception_Extra_Info @@ -3424,16 +3421,13 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); - -- Create TSS primitive Finalize_Address for non-VM targets. JVM and - -- .NET do not support address arithmetic and unchecked conversions. + -- Create TSS primitive Finalize_Address - if VM_Target = No_VM then - Set_TSS (Typ, - Make_Deep_Proc - (Prim => Address_Case, - Typ => Typ, - Stmts => Make_Deep_Record_Body (Address_Case, Typ))); - end if; + Set_TSS (Typ, + Make_Deep_Proc + (Prim => Address_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Address_Case, Typ))); end if; end Build_Record_Deep_Procs; @@ -3930,8 +3924,7 @@ package body Exp_Ch7 is Needs_Sec_Stack_Mark : constant Boolean := Uses_Sec_Stack (Scop) and then - not Sec_Stack_Needed_For_Return (Scop) - and then VM_Target = No_VM; + not Sec_Stack_Needed_For_Return (Scop); Needs_Custom_Cleanup : constant Boolean := Nkind (N) = N_Block_Statement and then Present (Cleanup_Actions (N)); @@ -4064,9 +4057,6 @@ package body Exp_Ch7 is -- -- Mnn : constant Mark_Id := SS_Mark; - -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the - -- secondary stack is never used on a VM. - if Needs_Sec_Stack_Mark then Mark := Make_Temporary (Loc, 'M'); @@ -4177,26 +4167,27 @@ package body Exp_Ch7 is -- Encode entity names in package body procedure Expand_N_Package_Body (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - Spec_Ent : constant Entity_Id := Corresponding_Spec (N); - Fin_Id : Entity_Id; + Spec_Id : constant Entity_Id := Corresponding_Spec (N); + Fin_Id : Entity_Id; + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; begin - -- The package body may be subject to pragma Ghost with policy Ignore. - -- Set the mode now to ensure that any nodes generated during expansion - -- are properly flagged as ignored Ghost. + -- The package body is Ghost when the corresponding spec is Ghost. Set + -- the mode now to ensure that any nodes generated during expansion are + -- properly marked as Ghost. - Set_Ghost_Mode (N); + Set_Ghost_Mode (N, Spec_Id); -- This is done only for non-generic packages - if Ekind (Spec_Ent) = E_Package then + if Ekind (Spec_Id) = E_Package then Push_Scope (Corresponding_Spec (N)); -- Build dispatch tables of library level tagged types if Tagged_Type_Expansion - and then Is_Library_Level_Entity (Spec_Ent) + and then Is_Library_Level_Entity (Spec_Id) then Build_Static_Dispatch_Tables (N); end if; @@ -4207,7 +4198,7 @@ package body Exp_Ch7 is -- assertion expression must be verified at the end of the body -- statements. - if Present (Get_Pragma (Spec_Ent, Pragma_Initial_Condition)) then + if Present (Get_Pragma (Spec_Id, Pragma_Initial_Condition)) then Expand_Pragma_Initial_Condition (N); end if; @@ -4215,13 +4206,13 @@ package body Exp_Ch7 is end if; Set_Elaboration_Flag (N, Corresponding_Spec (N)); - Set_In_Package_Body (Spec_Ent, False); + Set_In_Package_Body (Spec_Id, False); -- Set to encode entity names in package body before gigi is called Qualify_Entity_Names (N); - if Ekind (Spec_Ent) /= E_Generic_Package then + if Ekind (Spec_Id) /= E_Generic_Package then Build_Finalizer (N => N, Clean_Stmts => No_List, @@ -4244,10 +4235,7 @@ package body Exp_Ch7 is end if; end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Expand_N_Package_Body; ---------------------------------- @@ -4260,7 +4248,6 @@ package body Exp_Ch7 is -- appear. procedure Expand_N_Package_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; Id : constant Entity_Id := Defining_Entity (N); Spec : constant Node_Id := Specification (N); Decls : List_Id; @@ -4304,12 +4291,6 @@ package body Exp_Ch7 is return; end if; - -- The package declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - -- For a package declaration that implies no associated body, generate -- task activation call and RACW supporting bodies now (since we won't -- have a specific separate compilation unit for that). @@ -4383,11 +4364,6 @@ package body Exp_Ch7 is Set_Finalizer (Id, Fin_Id); end if; - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Expand_N_Package_Declaration; ----------------------------- @@ -4707,28 +4683,97 @@ package body Exp_Ch7 is -- Local variables + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + Built : Boolean := False; + Blk_Decl : Node_Id := Empty; + Blk_Decls : List_Id := No_List; + Blk_Ins : Node_Id; + Blk_Stmts : List_Id; Desig_Typ : Entity_Id; - Expr : Node_Id; - Fin_Block : Node_Id; + Fin_Call : Node_Id; Fin_Data : Finalization_Exception_Data; - Fin_Decls : List_Id; - Fin_Insrt : Node_Id; - Last_Fin : Node_Id := Empty; + Fin_Stmts : List_Id; + Hook_Clr : Node_Id := Empty; + Hook_Id : Entity_Id; + Hook_Ins : Node_Id; + Init_Expr : Node_Id; Loc : Source_Ptr; + Obj_Decl : Node_Id; Obj_Id : Entity_Id; Obj_Ref : Node_Id; Obj_Typ : Entity_Id; - Prev_Fin : Node_Id := Empty; - Ptr_Id : Entity_Id; - Stmt : Node_Id; - Stmts : List_Id; - Temp_Id : Entity_Id; - Temp_Ins : Node_Id; + Ptr_Typ : Entity_Id; -- Start of processing for Process_Transient_Objects begin + -- The expansion performed by this routine is as follows: + + -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ; + -- Hook_1 : Ptr_Typ_1 := null; + -- Ctrl_Trans_Obj_1 : ...; + -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access; + -- . . . + -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ; + -- Hook_N : Ptr_Typ_N := null; + -- Ctrl_Trans_Obj_N : ...; + -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access; + + -- declare + -- Abrt : constant Boolean := ...; + -- Ex : Exception_Occurrence; + -- Raised : Boolean := False; + + -- begin + -- begin + -- Hook_N := null; + -- [Deep_]Finalize (Ctrl_Trans_Obj_N); + + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (Ex, Get_Current_Excep.all.all); + -- end; + -- . . . + -- begin + -- Hook_1 := null; + -- [Deep_]Finalize (Ctrl_Trans_Obj_1); + + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (Ex, Get_Current_Excep.all.all); + -- end; + + -- if Raised and not Abrt then + -- Raise_From_Controlled_Operation (Ex); + -- end if; + -- end; + + -- When restriction No_Exception_Propagation is active, the expansion + -- is as follows: + + -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ; + -- Hook_1 : Ptr_Typ_1 := null; + -- Ctrl_Trans_Obj_1 : ...; + -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access; + -- . . . + -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ; + -- Hook_N : Ptr_Typ_N := null; + -- Ctrl_Trans_Obj_N : ...; + -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access; + + -- begin + -- Hook_N := null; + -- [Deep_]Finalize (Ctrl_Trans_Obj_N); + -- Hook_1 := null; + -- [Deep_]Finalize (Ctrl_Trans_Obj_1); + -- end; + -- Recognize a scenario where the transient context is an object -- declaration initialized by a build-in-place function call: @@ -4747,7 +4792,7 @@ package body Exp_Ch7 is and then Present (BIP_Initialization_Call (Defining_Identifier (N))) then Must_Hook := True; - Fin_Insrt := BIP_Initialization_Call (Defining_Identifier (N)); + Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N)); -- Search the context for at least one subprogram call. If found, the -- machinery exports all transient objects to the enclosing finalizer @@ -4755,24 +4800,28 @@ package body Exp_Ch7 is else Detect_Subprogram_Call (N); - Fin_Insrt := Last_Object; + Blk_Ins := Last_Object; + end if; + + if Clean then + Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup); end if; -- Examine all objects in the list First_Object .. Last_Object - Stmt := First_Object; - while Present (Stmt) loop - if Nkind (Stmt) = N_Object_Declaration - and then Analyzed (Stmt) - and then Is_Finalizable_Transient (Stmt, N) + Obj_Decl := First_Object; + while Present (Obj_Decl) loop + if Nkind (Obj_Decl) = N_Object_Declaration + and then Analyzed (Obj_Decl) + and then Is_Finalizable_Transient (Obj_Decl, N) -- Do not process the node to be wrapped since it will be -- handled by the enclosing finalizer. - and then Stmt /= Related_Node + and then Obj_Decl /= Related_Node then - Loc := Sloc (Stmt); - Obj_Id := Defining_Identifier (Stmt); + Loc := Sloc (Obj_Decl); + Obj_Id := Defining_Identifier (Obj_Decl); Obj_Typ := Base_Type (Etype (Obj_Id)); Desig_Typ := Obj_Typ; @@ -4784,18 +4833,8 @@ package body Exp_Ch7 is Desig_Typ := Available_View (Designated_Type (Desig_Typ)); end if; - -- Create the necessary entities and declarations the first - -- time around. - - if not Built then - Built := True; - Fin_Decls := New_List; - - Build_Object_Declarations (Fin_Data, Fin_Decls, Loc); - end if; - - -- Transient variables associated with subprogram calls need - -- extra processing. These variables are usually created right + -- Transient objects associated with subprogram calls need + -- extra processing. These objects are usually created right -- before the call and finalized immediately after the call. -- If an exception occurs during the call, the clean up code -- is skipped due to the sudden change in control and the @@ -4807,16 +4846,15 @@ package body Exp_Ch7 is if Must_Hook then - -- Step 1: Create an access type which provides a reference - -- to the transient object. Generate: - - -- Ann : access [all] <Desig_Typ>; + -- Create an access type which provides a reference to the + -- transient object. Generate: + -- type Ptr_Typ is access [all] Desig_Typ; - Ptr_Id := Make_Temporary (Loc, 'A'); + Ptr_Typ := Make_Temporary (Loc, 'A'); - Insert_Action (Stmt, + Insert_Action (Obj_Decl, Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ptr_Id, + Defining_Identifier => Ptr_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => @@ -4824,42 +4862,39 @@ package body Exp_Ch7 is Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)))); - -- Step 2: Create a temporary which acts as a hook to the - -- transient object. Generate: + -- Create a temporary which acts as a hook to the transient + -- object. Generate: + -- Hook : Ptr_Typ := null; - -- Temp : Ptr_Id := null; + Hook_Id := Make_Temporary (Loc, 'T'); - Temp_Id := Make_Temporary (Loc, 'T'); - - Insert_Action (Stmt, + Insert_Action (Obj_Decl, Make_Object_Declaration (Loc, - Defining_Identifier => Temp_Id, + Defining_Identifier => Hook_Id, Object_Definition => - New_Occurrence_Of (Ptr_Id, Loc))); + New_Occurrence_Of (Ptr_Typ, Loc))); - -- Mark the temporary as a transient hook. This signals the - -- machinery in Build_Finalizer to recognize this special - -- case. + -- Mark the temporary as a hook. This signals the machinery + -- in Build_Finalizer to recognize this special case. - Set_Status_Flag_Or_Transient_Decl (Temp_Id, Stmt); + Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl); - -- Step 3: Hook the transient object to the temporary + -- Hook the transient object to the temporary. Generate: + -- Hook := Ptr_Typ (Obj_Id); + -- <or> + -- Hook := Obj_Id'Unrestricted_Access; if Is_Access_Type (Obj_Typ) then - Expr := - Convert_To (Ptr_Id, New_Occurrence_Of (Obj_Id, Loc)); + Init_Expr := + Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc)); + else - Expr := + Init_Expr := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Obj_Id, Loc), Attribute_Name => Name_Unrestricted_Access); end if; - -- Generate: - -- Temp := Ptr_Id (Obj_Id); - -- <or> - -- Temp := Obj_Id'Unrestricted_Access; - -- When the transient object is initialized by an aggregate, -- the hook must capture the object after the last component -- assignment takes place. Only then is the object fully @@ -4868,55 +4903,88 @@ package body Exp_Ch7 is if Ekind (Obj_Id) = E_Variable and then Present (Last_Aggregate_Assignment (Obj_Id)) then - Temp_Ins := Last_Aggregate_Assignment (Obj_Id); + Hook_Ins := Last_Aggregate_Assignment (Obj_Id); -- Otherwise the hook seizes the related object immediately else - Temp_Ins := Stmt; + Hook_Ins := Obj_Decl; end if; - Insert_After_And_Analyze (Temp_Ins, + Insert_After_And_Analyze (Hook_Ins, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Hook_Id, Loc), + Expression => Init_Expr)); + + -- The transient object is about to be finalized by the + -- clean up code following the subprogram call. In order + -- to avoid double finalization, clear the hook. + + -- Generate: + -- Hook := null; + + Hook_Clr := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp_Id, Loc), - Expression => Expr)); + Name => New_Occurrence_Of (Hook_Id, Loc), + Expression => Make_Null (Loc)); end if; - Stmts := New_List; + -- Before generating the clean up code for the first transient + -- object, create a wrapper block which houses all hook clear + -- statements and finalization calls. This wrapper is needed by + -- the back-end. - -- The transient object is about to be finalized by the clean - -- up code following the subprogram call. In order to avoid - -- double finalization, clear the hook. + if not Built then + Built := True; + Blk_Stmts := New_List; - -- Generate: - -- Temp := null; + -- Create the declarations of all entities that participate + -- in exception detection and propagation. - if Must_Hook then - Append_To (Stmts, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp_Id, Loc), - Expression => Make_Null (Loc))); + if Exceptions_OK then + Blk_Decls := New_List; + + -- Generate: + -- Abrt : constant Boolean := ...; + -- Ex : Exception_Occurrence; + -- Raised : Boolean := False; + + Build_Object_Declarations (Fin_Data, Blk_Decls, Loc); + + -- Generate: + -- if Raised and then not Abrt then + -- Raise_From_Controlled_Operation (Ex); + -- end if; + + Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data)); + end if; + + Blk_Decl := + Make_Block_Statement (Loc, + Declarations => Blk_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Blk_Stmts)); end if; -- Generate: -- [Deep_]Finalize (Obj_Ref); - -- Set type of dereference, so that proper conversion are - -- generated when operation is inherited. - Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); if Is_Access_Type (Obj_Typ) then Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); - Set_Etype (Obj_Ref, Directly_Designated_Type (Obj_Typ)); + Set_Etype (Obj_Ref, Desig_Typ); end if; - Append_To (Stmts, - Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ)); + Fin_Call := + Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ); - -- Generate: - -- [Temp := null;] + -- When exception propagation is enabled wrap the hook clear + -- statement and the finalization call into a block to catch + -- potential exceptions raised during finalization. Generate: -- begin + -- [Temp := null;] -- [Deep_]Finalize (Obj_Ref); -- exception @@ -4928,60 +4996,48 @@ package body Exp_Ch7 is -- end if; -- end; - Fin_Block := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts, - Exception_Handlers => New_List ( - Build_Exception_Handler (Fin_Data)))); + if Exceptions_OK then + Fin_Stmts := New_List; - -- The single raise statement must be inserted after all the - -- finalization blocks, and we put everything into a wrapper - -- block to clearly expose the construct to the back-end. + if Present (Hook_Clr) then + Append_To (Fin_Stmts, Hook_Clr); + end if; - if Present (Prev_Fin) then - Insert_Before_And_Analyze (Prev_Fin, Fin_Block); - else - Insert_After_And_Analyze (Fin_Insrt, + Append_To (Fin_Stmts, Fin_Call); + + Prepend_To (Blk_Stmts, Make_Block_Statement (Loc, - Declarations => Fin_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Fin_Block)))); + Statements => Fin_Stmts, + Exception_Handlers => New_List ( + Build_Exception_Handler (Fin_Data))))); - Last_Fin := Fin_Block; - end if; + -- Otherwise generate: + -- [Temp := null;] + -- [Deep_]Finalize (Obj_Ref); - Prev_Fin := Fin_Block; + else + Prepend_To (Blk_Stmts, Fin_Call); + + if Present (Hook_Clr) then + Prepend_To (Blk_Stmts, Hook_Clr); + end if; + end if; end if; -- Terminate the scan after the last object has been processed to -- avoid touching unrelated code. - if Stmt = Last_Object then + if Obj_Decl = Last_Object then exit; end if; - Next (Stmt); + Next (Obj_Decl); end loop; - if Clean then - if Present (Prev_Fin) then - Insert_List_Before_And_Analyze (Prev_Fin, Act_Cleanup); - else - Insert_List_After_And_Analyze (Fin_Insrt, Act_Cleanup); - end if; - end if; - - -- Generate: - -- if Raised and then not Abort then - -- Raise_From_Controlled_Operation (E); - -- end if; - - if Built and then Present (Last_Fin) then - Insert_After_And_Analyze (Last_Fin, - Build_Raise_Statement (Fin_Data)); + if Present (Blk_Decl) then + Insert_After_And_Analyze (Blk_Ins, Blk_Decl); end if; end Process_Transient_Objects; @@ -5207,27 +5263,6 @@ package body Exp_Ch7 is end Make_Adjust_Call; ---------------------- - -- Make_Attach_Call -- - ---------------------- - - function Make_Attach_Call - (Obj_Ref : Node_Id; - Ptr_Typ : Entity_Id) return Node_Id - is - pragma Assert (VM_Target /= No_VM); - - Loc : constant Source_Ptr := Sloc (Obj_Ref); - begin - return - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Attach), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc), - Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref))); - end Make_Attach_Call; - - ---------------------- -- Make_Detach_Call -- ---------------------- @@ -5337,7 +5372,7 @@ package body Exp_Ch7 is -- Abort : constant Boolean := Triggered_By_Abort; -- <or> -- Abort : constant Boolean := False; -- no abort - -- E : Exception_Occurence; + -- E : Exception_Occurrence; -- Raised : Boolean := False; -- begin @@ -6101,7 +6136,7 @@ package body Exp_Ch7 is -- when others => -- if not Raised then -- Raised := True; - -- Save_Occurence (E, Get_Current_Excep.all.all); + -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; -- end if; @@ -6119,7 +6154,7 @@ package body Exp_Ch7 is -- Abort : constant Boolean := Triggered_By_Abort; -- <or> -- Abort : constant Boolean := False; -- no abort - -- E : Exception_Occurence; + -- E : Exception_Occurrence; -- Raised : Boolean := False; -- -- begin @@ -6130,7 +6165,7 @@ package body Exp_Ch7 is -- when others => -- if not Raised then -- Raised := True; - -- Save_Occurence (E, Get_Current_Excep.all.all); + -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; -- end if; @@ -6154,7 +6189,7 @@ package body Exp_Ch7 is -- when others => -- if not Raised then -- Raised := True; - -- Save_Occurence (E, Get_Current_Excep.all.all); + -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; -- . . . @@ -6165,7 +6200,7 @@ package body Exp_Ch7 is -- when others => -- if not Raised then -- Raised := True; - -- Save_Occurence (E, Get_Current_Excep.all.all); + -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end if; -- end; -- <<L0>> @@ -6587,7 +6622,7 @@ package body Exp_Ch7 is -- <or> -- Abort : constant Boolean := False; -- no abort - -- E : Exception_Occurence; + -- E : Exception_Occurrence; -- Raised : Boolean := False; -- begin @@ -7159,7 +7194,7 @@ package body Exp_Ch7 is -- <or> -- Abort : constant Boolean := False; -- no abort - -- E : Exception_Occurence; + -- E : Exception_Occurrence; -- Raised : Boolean := False; -- begin @@ -7720,8 +7755,8 @@ package body Exp_Ch7 is -- Procedure call or raise statement begin - -- Standard run-time, .NET/JVM targets: add choice parameter E and pass - -- it to Raise_From_Controlled_Operation so that the original exception + -- Standard run-time: add choice parameter E and pass it to + -- Raise_From_Controlled_Operation so that the original exception -- name and message can be recorded in the exception message for -- Program_Error. @@ -7942,8 +7977,7 @@ package body Exp_Ch7 is begin -- Case where only secondary stack use is involved - if VM_Target = No_VM - and then Uses_Sec_Stack (Current_Scope) + if Uses_Sec_Stack (Current_Scope) and then Nkind (Action) /= N_Simple_Return_Statement and then Nkind (Par) /= N_Exception_Handler then @@ -8148,18 +8182,16 @@ package body Exp_Ch7 is Curr_S := Current_Scope; Encl_S := Scope (Curr_S); - -- Insert all actions inluding cleanup generated while analyzing or + -- Insert all actions including cleanup generated while analyzing or -- expanding the transient context back into the tree. Manage the -- secondary stack when the object declaration appears in a library - -- level package [body]. This is not needed for .NET/JVM as those do - -- not support the secondary stack. + -- level package [body]. Insert_Actions_In_Scope_Around (N => N, Clean => True, Manage_SS => - VM_Target = No_VM - and then Uses_Sec_Stack (Curr_S) + Uses_Sec_Stack (Curr_S) and then Nkind (N) = N_Object_Declaration and then Ekind_In (Encl_S, E_Package, E_Package_Body) and then Is_Library_Level_Entity (Encl_S)); @@ -8171,10 +8203,9 @@ package body Exp_Ch7 is Transfer_Entities (Curr_S, Encl_S); -- Mark the enclosing dynamic scope to ensure that the secondary stack - -- is properly released upon exiting the said scope. This is not needed - -- for .NET/JVM as those do not support the secondary stack. + -- is properly released upon exiting the said scope. - if VM_Target = No_VM and then Uses_Sec_Stack (Curr_S) then + if Uses_Sec_Stack (Curr_S) then Curr_S := Enclosing_Dynamic_Scope (Curr_S); -- Do not mark a function that returns on the secondary stack as the diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 0fcc0458615..3f90f31580e 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -100,18 +100,21 @@ package Exp_Ch7 is procedure Build_Finalization_Master (Typ : Entity_Id; For_Anonymous : Boolean := False; + For_Lib_Level : Boolean := False; For_Private : Boolean := False; Context_Scope : Entity_Id := Empty; Insertion_Node : Node_Id := Empty); -- Build a finalization master for an access type. The designated type may -- not necessarely be controlled or need finalization actions depending on -- the context. Flag For_Anonymous must be set when creating a master for - -- an anonymous access type. Flag For_Private must be set when the - -- designated type contains a private component. Parameters Context_Scope - -- and Insertion_Node must be used in conjunction with flags For_Anonymous - -- and For_Private. Context_Scope is the scope of the context where the - -- finalization master must be analyzed. Insertion_Node is the insertion - -- point before which the master is inserted. + -- an anonymous access type. Flag For_Lib_Level must be set when creating + -- a master for a build-in-place function call access result type. Flag + -- For_Private must be set when the designated type contains a private + -- component. Parameters Context_Scope and Insertion_Node must be used in + -- conjunction with flags For_Anonymous and For_Private. Context_Scope is + -- the scope of the context where the finalization master must be analyzed. + -- Insertion_Node is the insertion point before which the master is to be + -- inserted. procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); -- Build one controlling procedure when a late body overrides one of @@ -169,18 +172,6 @@ package Exp_Ch7 is -- adjusted. Typ is the expected type of Obj_Ref. When Skip_Self is set, -- only the components (if any) are adjusted. - function Make_Attach_Call - (Obj_Ref : Node_Id; - Ptr_Typ : Entity_Id) return Node_Id; - -- Create a call to prepend an object to a finalization collection. Obj_Ref - -- is the object, Ptr_Typ is the access type that owns the collection. This - -- is used only for .NET/JVM, that is, when VM_Target /= No_VM. - -- Generate the following: - -- - -- Ada.Finalization.Heap_Management.Attach - -- (<Ptr_Typ>FC, - -- System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref)); - function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id; -- Create a call to unhook an object from an arbitrary list. Obj_Ref is the -- object. Generate the following: diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 2c47b7f2894..dfd1796ac77 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -50,13 +50,15 @@ package body Exp_Ch8 is --------------------------------------------- procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + Decl : Node_Id; begin - -- The exception renaming declaration may be subject to pragma Ghost - -- with policy Ignore. Set the mode now to ensure that any nodes - -- generated during expansion are properly flagged as ignored Ghost. + -- The exception renaming declaration is Ghost when it is subject to + -- pragma Ghost or renames a Ghost entity. To accomodate both cases, set + -- the mode now to ensure that any nodes generated during expansion are + -- properly marked as Ghost. Set_Ghost_Mode (N); @@ -66,10 +68,7 @@ package body Exp_Ch8 is Insert_Action (N, Decl); end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Expand_N_Exception_Renaming_Declaration; ------------------------------------------ @@ -159,14 +158,15 @@ package body Exp_Ch8 is -- Local variables - GM : constant Ghost_Mode_Type := Ghost_Mode; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; -- Start of processing for Expand_N_Object_Renaming_Declaration begin - -- The object renaming declaration may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes generated - -- during expansion are properly flagged as ignored Ghost. + -- The object renaming declaration is Ghost when it is subject to pragma + -- Ghost or renames a Ghost entity. To accomodate both cases, set the + -- mode now to ensure that any nodes generated during expansion are + -- properly marked as Ghost. Set_Ghost_Mode (N); @@ -213,10 +213,7 @@ package body Exp_Ch8 is Insert_Action (N, Decl); end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Expand_N_Object_Renaming_Declaration; ------------------------------------------- @@ -224,13 +221,15 @@ package body Exp_Ch8 is ------------------------------------------- procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + Decl : Node_Id; begin - -- The package renaming declaration may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes generated - -- during expansion are properly flagged as ignored Ghost. + -- The package renaming declaration is Ghost when it is subject to + -- pragma Ghost or renames a Ghost entity. To accomodate both cases, + -- set the mode now to ensure that any nodes generated during expansion + -- are properly marked as Ghost. Set_Ghost_Mode (N); @@ -273,10 +272,7 @@ package body Exp_Ch8 is end if; end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Expand_N_Package_Renaming_Declaration; ---------------------------------------------- @@ -326,15 +322,16 @@ package body Exp_Ch8 is -- Local variables - GM : constant Ghost_Mode_Type := Ghost_Mode; - Nam : constant Node_Id := Name (N); + Nam : constant Node_Id := Name (N); + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; -- Start of processing for Expand_N_Subprogram_Renaming_Declaration begin - -- The subprogram renaming declaration may be subject to pragma Ghost - -- with policy Ignore. Set the mode now to ensure that any nodes created - -- during expansion are properly flagged as ignored Ghost. + -- The subprogram renaming declaration is Ghost when it is subject to + -- pragma Ghost or renames a Ghost entity. To accomodate both cases, set + -- the mode now to ensure that any nodes created during expansion are + -- properly flagged as ignored Ghost. Set_Ghost_Mode (N); @@ -402,10 +399,7 @@ package body Exp_Ch8 is end; end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Expand_N_Subprogram_Renaming_Declaration; end Exp_Ch8; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 72b83440c20..4887c707f69 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -1019,14 +1019,16 @@ package body Exp_Ch9 is -- (whether coming from this routine, or directly from source). if Opt.Suppress_Control_Flow_Optimizations then - Stmt := Make_Implicit_If_Statement (Cond, - Condition => Cond, - Then_Statements => New_List ( - Make_Simple_Return_Statement (Loc, - New_Occurrence_Of (Standard_True, Loc))), - Else_Statements => New_List ( - Make_Simple_Return_Statement (Loc, - New_Occurrence_Of (Standard_False, Loc)))); + Stmt := + Make_Implicit_If_Statement (Cond, + Condition => Cond, + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + New_Occurrence_Of (Standard_True, Loc))), + + Else_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + New_Occurrence_Of (Standard_False, Loc)))); else Stmt := Make_Simple_Return_Statement (Loc, Cond); @@ -1061,22 +1063,24 @@ package body Exp_Ch9 is begin Set_Debug_Info_Needed (Def_Id); - return Make_Function_Specification (Loc, - Defining_Unit_Name => Def_Id, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uO), - Parameter_Type => - New_Occurrence_Of (RTE (RE_Address), Loc)), - - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uE), - Parameter_Type => - New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), - - Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)); + return + Make_Function_Specification (Loc, + Defining_Unit_Name => Def_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uO), + Parameter_Type => + New_Occurrence_Of (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uE), + Parameter_Type => + New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), + + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); end Build_Barrier_Function_Specification; -------------------------- @@ -1809,6 +1813,7 @@ package body Exp_Ch9 is -- type Ann is access all <actual-type> Comp_Nam := Make_Temporary (Loc, 'A'); + Set_Is_Param_Block_Component_Type (Comp_Nam); Append_To (Decls, Make_Full_Type_Declaration (Loc, @@ -4729,7 +4734,7 @@ package body Exp_Ch9 is Formal := First_Formal (Ent); while Present (Actual) loop - -- If it is a by_copy_type, copy it to a new variable. The + -- If it is a by-copy type, copy it to a new variable. The -- packaged record has a field that points to this variable. if Is_By_Copy_Type (Etype (Actual)) then @@ -4746,24 +4751,38 @@ package body Exp_Ch9 is Set_No_Initialization (N_Node); - -- We must make an assignment statement separate for the - -- case of limited type. We cannot assign it unless the + -- We must make a separate assignment statement for the + -- case of limited types. We cannot assign it unless the -- Assignment_OK flag is set first. An out formal of an - -- access type must also be initialized from the actual, - -- as stated in RM 6.4.1 (13), but no constraint is applied - -- before the call. + -- access type or whose type has a Default_Value must also + -- be initialized from the actual (see RM 6.4.1 (13-13.1)), + -- but no constraint, predicate, or null-exclusion check is + -- applied before the call. if Ekind (Formal) /= E_Out_Parameter or else Is_Access_Type (Etype (Formal)) + or else + (Is_Scalar_Type (Etype (Formal)) + and then + Present (Default_Aspect_Value (Etype (Formal)))) then N_Var := New_Occurrence_Of (Defining_Identifier (N_Node), Loc); Set_Assignment_OK (N_Var); Append_To (Stats, Make_Assignment_Statement (Loc, - Name => N_Var, + Name => N_Var, Expression => Relocate_Node (Actual))); + -- Mark the object as internal, so we don't later reset + -- No_Initialization flag in Default_Initialize_Object, + -- which would lead to needless default initialization. + -- We don't set this outside the if statement, because + -- out scalar parameters without Default_Value do require + -- default initialization if Initialize_Scalars applies. + + Set_Is_Internal (Defining_Identifier (N_Node)); + -- If actual is an out parameter of a null-excluding -- access type, there is access check on entry, so set -- Suppress_Assignment_Checks on the generated statement @@ -4777,28 +4796,9 @@ package body Exp_Ch9 is Append_To (Plist, Make_Attribute_Reference (Loc, Attribute_Name => Name_Unchecked_Access, - Prefix => - New_Occurrence_Of (Defining_Identifier (N_Node), Loc))); - - -- If it is a VM_By_Copy_Actual, copy it to a new variable - - elsif Is_VM_By_Copy_Actual (Actual) then - N_Node := - Make_Object_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'J'), - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (Etype (Formal), Loc), - Expression => New_Copy_Tree (Actual)); - Set_Assignment_OK (N_Node); - - Append (N_Node, Decls); - - Append_To (Plist, - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Unchecked_Access, - Prefix => - New_Occurrence_Of (Defining_Identifier (N_Node), Loc))); + Prefix => + New_Occurrence_Of + (Defining_Identifier (N_Node), Loc))); else -- Interface class-wide formal @@ -4820,7 +4820,7 @@ package body Exp_Ch9 is Make_Reference (Loc, Unchecked_Convert_To (Iface_Typ, Make_Selected_Component (Loc, - Prefix => + Prefix => Relocate_Node (Actual), Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))))); @@ -4852,7 +4852,7 @@ package body Exp_Ch9 is Parm3 := Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (P, Loc), + Prefix => New_Occurrence_Of (P, Loc), Attribute_Name => Name_Address); Append (Pdecl, Decls); @@ -4916,8 +4916,9 @@ package body Exp_Ch9 is Call := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of ( - RTE (RE_Protected_Single_Entry_Call), Loc), + Name => + New_Occurrence_Of + (RTE (RE_Protected_Single_Entry_Call), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, @@ -4934,7 +4935,8 @@ package body Exp_Ch9 is else Call := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Call_Simple), Loc), + Name => + New_Occurrence_Of (RTE (RE_Call_Simple), Loc), Parameter_Associations => New_List (Parm1, Parm2, Parm3)); end if; @@ -4950,17 +4952,16 @@ package body Exp_Ch9 is Set_Assignment_OK (Actual); while Present (Actual) loop - if (Is_By_Copy_Type (Etype (Actual)) - or else Is_VM_By_Copy_Actual (Actual)) + if Is_By_Copy_Type (Etype (Actual)) and then Ekind (Formal) /= E_In_Parameter then N_Node := Make_Assignment_Statement (Loc, - Name => New_Copy (Actual), + Name => New_Copy (Actual), Expression => Make_Explicit_Dereference (Loc, Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (P, Loc), + Prefix => New_Occurrence_Of (P, Loc), Selector_Name => Make_Identifier (Loc, Chars (Formal))))); @@ -5058,7 +5059,7 @@ package body Exp_Ch9 is Call := Make_Procedure_Call_Statement (Loc, - Name => Name, + Name => Name, Parameter_Associations => New_List (Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Chain, Loc), @@ -5341,7 +5342,7 @@ package body Exp_Ch9 is declare Bas : Entity_Id := Base_Type - (Etype (Discrete_Subtype_Definition (Parent (Efam)))); + (Etype (Discrete_Subtype_Definition (Parent (Efam)))); Bas_Decl : Node_Id := Empty; Lo, Hi : Node_Id; @@ -5611,10 +5612,8 @@ package body Exp_Ch9 is else if Is_Protected_Type (Ntyp) then Sel := Name_uObject; - elsif Is_Task_Type (Ntyp) then Sel := Name_uTask_Id; - else raise Program_Error; end if; @@ -5785,7 +5784,6 @@ package body Exp_Ch9 is -- Now add lengths of preceding entries and entry families Prev := First_Entity (Ttyp); - while Chars (Prev) /= Chars (Ent) or else (Ekind (Prev) /= Ekind (Ent)) or else not Sem_Ch6.Type_Conformant (Ent, Prev) @@ -6190,7 +6188,7 @@ package body Exp_Ch9 is Condition (Entry_Body_Formal_Part (N)); Prot : constant Entity_Id := Scope (Ent); Spec_Decl : constant Node_Id := Parent (Prot); - Func : Entity_Id; + Func : Entity_Id := Empty; B_F : Node_Id; Body_Decl : Node_Id; @@ -6212,6 +6210,11 @@ package body Exp_Ch9 is S := Scope (E); if Ekind (E) = E_Variable then + + -- If the variable is local to the barrier function generated + -- during expansion, it is ok. If expansion is not performed, + -- then Func is Empty so this test cannot succeed. + if Scope (E) = Func then null; @@ -6261,7 +6264,7 @@ package body Exp_Ch9 is -- version of it because it is never called. if Expander_Active then - B_F := Build_Barrier_Function (N, Ent, Prot); + B_F := Build_Barrier_Function (N, Ent, Prot); Func := Barrier_Function (Ent); Set_Corresponding_Spec (B_F, Func); @@ -7584,29 +7587,17 @@ package body Exp_Ch9 is Has_Created_Identifier => True, Is_Asynchronous_Call_Block => True); - -- For the VM call Update_Exception instead of Abort_Undefer. - -- See 4jexcept.ads for an explanation. + if Exception_Mechanism = Back_End_Exceptions then - if VM_Target = No_VM then - if Exception_Mechanism = Back_End_Exceptions then + -- Aborts are not deferred at beginning of exception handlers + -- in ZCX. - -- Aborts are not deferred at beginning of exception handlers - -- in ZCX. + Handler_Stmt := Make_Null_Statement (Loc); - Handler_Stmt := Make_Null_Statement (Loc); - - else - Handler_Stmt := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), - Parameter_Associations => No_List); - end if; else Handler_Stmt := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Update_Exception), Loc), - Parameter_Associations => New_List ( - Make_Function_Call (Loc, - Name => New_Occurrence_Of - (RTE (RE_Current_Target_Exception), Loc)))); + Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => No_List); end if; Stmts := New_List ( @@ -7687,7 +7678,7 @@ package body Exp_Ch9 is -- Create the inner block to protect the abortable part - Hdle := New_List (Build_Abort_Block_Handler (Loc)); + Hdle := New_List (Build_Abort_Block_Handler (Loc)); Prepend_To (Astats, Make_Procedure_Call_Statement (Loc, @@ -8345,6 +8336,7 @@ package body Exp_Ch9 is -- Declare new access type and then append Ctype := Make_Temporary (Loc, 'A'); + Set_Is_Param_Block_Component_Type (Ctype); Decl := Make_Full_Type_Declaration (Loc, @@ -8839,8 +8831,9 @@ package body Exp_Ch9 is -- the specs refer to this type. procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Prot_Typ : constant Entity_Id := Defining_Identifier (N); + Discr_Map : constant Elist_Id := New_Elmt_List; + Loc : constant Source_Ptr := Sloc (N); + Prot_Typ : constant Entity_Id := Defining_Identifier (N); Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ); -- This flag indicates whether the lock free implementation is active @@ -8848,20 +8841,19 @@ package body Exp_Ch9 is Pdef : constant Node_Id := Protected_Definition (N); -- This contains two lists; one for visible and one for private decls - Rec_Decl : Node_Id; + Body_Arr : Node_Id; + Body_Id : Entity_Id; Cdecls : List_Id; - Discr_Map : constant Elist_Id := New_Elmt_List; - Priv : Node_Id; - New_Priv : Node_Id; Comp : Node_Id; Comp_Id : Entity_Id; - Sub : Node_Id; Current_Node : Node_Id := N; - Entries_Aggr : Node_Id; - Body_Id : Entity_Id; - Body_Arr : Node_Id; E_Count : Int; + Entries_Aggr : Node_Id; + New_Priv : Node_Id; Object_Comp : Node_Id; + Priv : Node_Id; + Rec_Decl : Node_Id; + Sub : Node_Id; procedure Check_Inlining (Subp : Entity_Id); -- If the original operation has a pragma Inline, propagate the flag @@ -9032,6 +9024,7 @@ package body Exp_Ch9 is Make_Subprogram_Declaration (Loc, Specification => Build_Barrier_Function_Specification (Loc, Bdef)); + Set_Is_Entry_Barrier_Function (Sub); Insert_After (Current_Node, Sub); Analyze (Sub); @@ -9152,17 +9145,18 @@ package body Exp_Ch9 is -- is OK to miss this check in -gnatc mode. Check_Restriction (No_Implicit_Heap_Allocations, Priv); + Check_Restriction + (No_Implicit_Protected_Object_Allocations, Priv); elsif Restriction_Active (No_Implicit_Heap_Allocations) then if not Discriminated_Size (Defining_Identifier (Priv)) then - -- Any object of the type will be non-static. Error_Msg_N ("component has non-static size??", Priv); Error_Msg_NE - ("\creation of protected object of type& will" - & " violate restriction " + ("\creation of protected object of type& will " + & "violate restriction " & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ); else @@ -9174,6 +9168,32 @@ package body Exp_Ch9 is & " restriction No_Implicit_Heap_Allocations??", Priv, Prot_Typ); end if; + + -- Likewise for No_Implicit_Protected_Object_Allocations + + elsif Restriction_Active + (No_Implicit_Protected_Object_Allocations) + then + if not Discriminated_Size (Defining_Identifier (Priv)) + then + -- Any object of the type will be non-static. + + Error_Msg_N ("component has non-static size??", Priv); + Error_Msg_NE + ("\creation of protected object of type& will " + & "violate restriction " + & "No_Implicit_Protected_Object_Allocations??", + Priv, Prot_Typ); + else + -- Object will be non-static if discriminants are. + + Error_Msg_NE + ("creation of protected object of type& with " + & "non-static discriminants will violate " + & "restriction " + & "No_Implicit_Protected_Object_Allocations??", + Priv, Prot_Typ); + end if; end if; end if; @@ -9184,10 +9204,10 @@ package body Exp_Ch9 is declare Old_Comp : constant Node_Id := Component_Definition (Priv); Oent : constant Entity_Id := Defining_Identifier (Priv); - New_Comp : Node_Id; Nent : constant Entity_Id := Make_Defining_Identifier (Sloc (Oent), Chars => Chars (Oent)); + New_Comp : Node_Id; begin if Present (Subtype_Indication (Old_Comp)) then @@ -9195,15 +9215,15 @@ package body Exp_Ch9 is Make_Component_Definition (Sloc (Oent), Aliased_Present => False, Subtype_Indication => - New_Copy_Tree (Subtype_Indication (Old_Comp), - Discr_Map)); + New_Copy_Tree + (Subtype_Indication (Old_Comp), Discr_Map)); else New_Comp := Make_Component_Definition (Sloc (Oent), Aliased_Present => False, Access_Definition => - New_Copy_Tree (Access_Definition (Old_Comp), - Discr_Map)); + New_Copy_Tree + (Access_Definition (Old_Comp), Discr_Map)); end if; New_Priv := @@ -9271,12 +9291,12 @@ package body Exp_Ch9 is if not Lock_Free_Active then declare - Ritem : Node_Id; - Num_Attach_Handler : Int := 0; - Protection_Subtype : Node_Id; Entry_Count_Expr : constant Node_Id := Build_Entry_Count_Expression (Prot_Typ, Cdecls, Loc); + Num_Attach_Handler : Int := 0; + Protection_Subtype : Node_Id; + Ritem : Node_Id; begin if Has_Attach_Handler (Prot_Typ) then @@ -9468,9 +9488,7 @@ package body Exp_Ch9 is end if; elsif Nkind (Comp) = N_Entry_Declaration then - Expand_Entry_Declaration (Comp); - end if; Next (Comp); @@ -9500,28 +9518,31 @@ package body Exp_Ch9 is case Corresponding_Runtime_Package (Prot_Typ) is when System_Tasking_Protected_Objects_Entries => - Body_Arr := Make_Object_Declaration (Loc, - Defining_Identifier => Body_Id, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of ( - RTE (RE_Protected_Entry_Body_Array), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Range (Loc, - Make_Integer_Literal (Loc, 1), - Make_Integer_Literal (Loc, E_Count))))), - Expression => Entries_Aggr); + Body_Arr := + Make_Object_Declaration (Loc, + Defining_Identifier => Body_Id, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Protected_Entry_Body_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Make_Integer_Literal (Loc, 1), + Make_Integer_Literal (Loc, E_Count))))), + Expression => Entries_Aggr); when System_Tasking_Protected_Objects_Single_Entry => - Body_Arr := Make_Object_Declaration (Loc, - Defining_Identifier => Body_Id, - Aliased_Present => True, - Object_Definition => New_Occurrence_Of - (RTE (RE_Entry_Body), Loc), - Expression => Remove_Head (Expressions (Entries_Aggr))); + Body_Arr := + Make_Object_Declaration (Loc, + Defining_Identifier => Body_Id, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Entry_Body), Loc), + Expression => Remove_Head (Expressions (Entries_Aggr))); when others => raise Program_Error; @@ -11367,14 +11388,28 @@ package body Exp_Ch9 is end loop; end Expand_N_Selective_Accept; + ------------------------------------------- + -- Expand_N_Single_Protected_Declaration -- + ------------------------------------------- + + -- A single protected declaration should never be present after semantic + -- analysis because it is transformed into a protected type declaration + -- and an accompanying anonymous object. This routine ensures that the + -- transformation takes place. + + procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is + begin + raise Program_Error; + end Expand_N_Single_Protected_Declaration; + -------------------------------------- -- Expand_N_Single_Task_Declaration -- -------------------------------------- - -- Single task declarations should never be present after semantic - -- analysis, since we expect them to be replaced by a declaration of an - -- anonymous task type, followed by a declaration of the task object. We - -- include this routine to make sure that is happening. + -- A single task declaration should never be present after semantic + -- analysis because it is transformed into a task type declaration and + -- an accompanying anonymous object. This routine ensures that the + -- transformation takes place. procedure Expand_N_Single_Task_Declaration (N : Node_Id) is begin @@ -11494,6 +11529,7 @@ package body Exp_Ch9 is Specification => Build_Task_Proc_Specification (Ttyp), Declarations => Declarations (N), Handled_Statement_Sequence => Handled_Statement_Sequence (N)); + Set_Is_Task_Body_Procedure (New_N); -- If the task contains generic instantiations, cleanup actions are -- delayed until after instantiation. Transfer the activation chain to @@ -12034,6 +12070,7 @@ package body Exp_Ch9 is Body_Decl := Make_Subprogram_Declaration (Loc, Specification => Proc_Spec); + Set_Is_Task_Body_Procedure (Body_Decl); Insert_After (Rec_Decl, Body_Decl); @@ -14218,31 +14255,17 @@ package body Exp_Ch9 is -- it's actually inside the init procedure for the record type that -- corresponds to the task type. - -- This processing is causing a crash in the .NET/JVM back ends that - -- is not yet understood, so skip it in these cases ??? - - if VM_Target = No_VM then - Set_Itype (Ref, Subp_Ptr_Typ); - Append_Freeze_Action (Task_Rec, Ref); - - Append_To (Args, - Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), - Make_Qualified_Expression (Loc, - Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Body_Proc, Loc), - Attribute_Name => Name_Unrestricted_Access)))); + Set_Itype (Ref, Subp_Ptr_Typ); + Append_Freeze_Action (Task_Rec, Ref); - -- For the .NET/JVM cases revert to the original code below ??? - - else - Append_To (Args, - Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Body_Proc, Loc), - Attribute_Name => Name_Address))); - end if; + Append_To (Args, + Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Body_Proc, Loc), + Attribute_Name => Name_Unrestricted_Access)))); end; -- Discriminants parameter. This is just the address of the task @@ -14326,9 +14349,14 @@ package body Exp_Ch9 is Next_Op : Node_Id; begin + -- Check whether there is a subsequent body for a protected operation + -- in the current protected body. In Ada2012 that includes expression + -- functions that are completions. + Next_Op := Next (N); while Present (Next_Op) - and then not Nkind_In (Next_Op, N_Subprogram_Body, N_Entry_Body) + and then not Nkind_In (Next_Op, + N_Subprogram_Body, N_Entry_Body, N_Expression_Function) loop Next (Next_Op); end loop; diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index d9fa7d6d7fb..d49201bfe0d 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -266,12 +266,13 @@ package Exp_Ch9 is -- allows these two nodes to be found from the type, without benefit of -- further attributes, using Corresponding_Record. - procedure Expand_N_Requeue_Statement (N : Node_Id); - procedure Expand_N_Selective_Accept (N : Node_Id); - procedure Expand_N_Single_Task_Declaration (N : Node_Id); - procedure Expand_N_Task_Body (N : Node_Id); - procedure Expand_N_Task_Type_Declaration (N : Node_Id); - procedure Expand_N_Timed_Entry_Call (N : Node_Id); + procedure Expand_N_Requeue_Statement (N : Node_Id); + procedure Expand_N_Selective_Accept (N : Node_Id); + procedure Expand_N_Single_Protected_Declaration (N : Node_Id); + procedure Expand_N_Single_Task_Declaration (N : Node_Id); + procedure Expand_N_Task_Body (N : Node_Id); + procedure Expand_N_Task_Type_Declaration (N : Node_Id); + procedure Expand_N_Timed_Entry_Call (N : Node_Id); procedure Expand_Protected_Body_Declarations (N : Node_Id; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 1a05adb73c9..2c1d5180faa 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -38,7 +38,6 @@ with Sinfo; use Sinfo; with Stand; use Stand; with Stringt; use Stringt; with Table; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Urealp; use Urealp; @@ -373,14 +372,6 @@ package body Exp_Dbug is return Empty; end if; - -- Do not output those local variables in VM case, as this does not - -- help debugging (they are just unused), and might lead to duplicated - -- local variable names. - - if VM_Target /= No_VM then - return Empty; - end if; - -- Get renamed entity and compute suffix Name_Len := 0; @@ -584,9 +575,7 @@ package body Exp_Dbug is -- Couldn't we just test Original_Operating_Mode here? ??? - if Operating_Mode /= Generate_Code - and then not Generating_Code - then + if Operating_Mode /= Generate_Code and then not Generating_Code then return; end if; @@ -650,11 +639,11 @@ package body Exp_Dbug is Lo_Discr : constant Boolean := Nkind (Lo) = N_Identifier - and then Ekind (Entity (Lo)) = E_Discriminant; + and then Ekind (Entity (Lo)) = E_Discriminant; Hi_Discr : constant Boolean := Nkind (Hi) = N_Identifier - and then Ekind (Entity (Hi)) = E_Discriminant; + and then Ekind (Entity (Hi)) = E_Discriminant; Lo_Encode : constant Boolean := Lo_Con or Lo_Discr; Hi_Encode : constant Boolean := Hi_Con or Hi_Discr; @@ -726,11 +715,8 @@ package body Exp_Dbug is procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean := False; - Suffix : String := "") + Suffix : String := "") is - E : Entity_Id := Entity; - Kind : Entity_Kind; - procedure Get_Qualified_Name_And_Append (Entity : Entity_Id); -- Appends fully qualified name of given entity to Name_Buffer @@ -761,6 +747,10 @@ package body Exp_Dbug is end if; end Get_Qualified_Name_And_Append; + -- Local variables + + E : Entity_Id := Entity; + -- Start of processing for Get_External_Name begin @@ -786,15 +776,13 @@ package body Exp_Dbug is E := Defining_Identifier (Entity); end if; - Kind := Ekind (E); - -- Case of interface name being used - if (Kind = E_Procedure or else - Kind = E_Function or else - Kind = E_Constant or else - Kind = E_Variable or else - Kind = E_Exception) + if Ekind_In (E, E_Constant, + E_Exception, + E_Function, + E_Procedure, + E_Variable) and then Present (Interface_Name (E)) and then No (Address_Clause (E)) and then not Has_Suffix @@ -825,9 +813,7 @@ package body Exp_Dbug is if Is_Generic_Instance (E) and then Is_Subprogram (E) and then not Is_Compilation_Unit (Scope (E)) - and then (Ekind (Scope (E)) = E_Package - or else - Ekind (Scope (E)) = E_Package_Body) + and then Ekind_In (Scope (E), E_Package, E_Package_Body) and then Present (Related_Instance (Scope (E))) then E := Related_Instance (Scope (E)); diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index 352e57ff215..827f149f705 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -414,7 +414,7 @@ package Exp_Dbug is procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean := False; - Suffix : String := ""); + Suffix : String := ""); -- Set Name_Buffer and Name_Len to the external name of the entity. The -- external name is the Interface_Name, if specified, unless the entity -- has an address clause or Has_Suffix is true. @@ -1185,8 +1185,7 @@ package Exp_Dbug is function Make_Packed_Array_Impl_Type_Name (Typ : Entity_Id; - Csize : Uint) - return Name_Id; + Csize : Uint) return Name_Id; -- This function is used in Exp_Pakd to create the name that is encoded as -- described above. The entity Typ provides the name ttt, and the value -- Csize is the component size that provides the nnn value. diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index f50899b3c6b..7abc0b543a5 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -62,7 +62,6 @@ with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with SCIL_LL; use SCIL_LL; -with Targparm; use Targparm; with Tbuild; use Tbuild; package body Exp_Disp is @@ -291,7 +290,6 @@ package body Exp_Disp is return Static_Dispatch_Tables and then Is_Library_Level_Tagged_Type (Typ) - and then VM_Target = No_VM -- If the type is derived from a CPP class we cannot statically -- build the dispatch tables because we must inherit primitives @@ -1174,35 +1172,6 @@ package body Exp_Disp is end; if not Tagged_Type_Expansion then - if VM_Target /= No_VM then - if Is_Access_Type (Operand_Typ) then - Operand_Typ := Designated_Type (Operand_Typ); - end if; - - if Is_Class_Wide_Type (Operand_Typ) then - Operand_Typ := Root_Type (Operand_Typ); - end if; - - if not Is_Static and then Operand_Typ /= Iface_Typ then - Insert_Action (N, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of - (RTE (RE_Check_Interface_Conversion), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Expression (N)), - Attribute_Name => Name_Tag), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Iface_Typ, Loc), - Attribute_Name => Name_Tag)))); - end if; - - -- Just do a conversion ??? - - Rewrite (N, Unchecked_Convert_To (Etype (N), N)); - Analyze (N); - end if; - return; -- A static conversion to an interface type that is not classwide is @@ -3645,10 +3614,6 @@ package body Exp_Disp is -- end; function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is - GM : constant Ghost_Mode_Type := Ghost_Mode; - -- Save the current Ghost mode in effect in case the tagged type sets a - -- different mode. - Loc : constant Source_Ptr := Sloc (Typ); Max_Predef_Prims : constant Int := @@ -3711,9 +3676,6 @@ package body Exp_Disp is -- this secondary dispatch table by Make_Tags when its unique external -- name was generated. - procedure Restore_Globals; - -- Restore the values of all saved global variables - ------------------------------ -- Check_Premature_Freezing -- ------------------------------ @@ -3941,6 +3903,10 @@ package body Exp_Disp is end loop; end if; + if Generate_SCIL then + Nb_Predef_Prims := 0; + end if; + -- Stage 2: Create the thunks associated with the predefined -- primitives and save their entity to fill the aggregate. @@ -3962,6 +3928,7 @@ package body Exp_Disp is if Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) and then not Is_Eliminated (Prim) + and then not Generate_SCIL and then not Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) then @@ -4398,15 +4365,6 @@ package body Exp_Disp is Append_Elmt (Iface_DT, DT_Decl); end Make_Secondary_DT; - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - -- Local variables Elab_Code : constant List_Id := New_List; @@ -4436,6 +4394,8 @@ package body Exp_Disp is TSD_Aggr_List : List_Id; TSD_Tags_List : List_Id; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + -- The following name entries are used by Make_DT to generate a number -- of entities related to a tagged type. These entities may be generated -- in a scope other than that of the tagged type declaration, and if @@ -4477,9 +4437,9 @@ package body Exp_Disp is begin pragma Assert (Is_Frozen (Typ)); - -- The tagged type being processed may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes generated - -- during dispatch table creation are properly flagged as ignored Ghost. + -- The tagged type being processed may be subject to pragma Ghost. Set + -- the mode now to ensure that any nodes generated during dispatch table + -- creation are properly marked as Ghost. Set_Ghost_Mode (Declaration_Node (Typ), Typ); @@ -4488,15 +4448,13 @@ package body Exp_Disp is if Has_Dispatch_Table (Typ) or else No (Access_Disp_Table (Typ)) or else Is_CPP_Class (Typ) - or else Convention (Typ) = Convention_CIL - or else Convention (Typ) = Convention_Java then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; elsif No_Run_Time_Mode then Error_Msg_CRT ("tagged types", Typ); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; elsif not RTE_Available (RE_Tag) then @@ -4512,7 +4470,7 @@ package body Exp_Disp is Analyze_List (Result, Suppress => All_Checks); Error_Msg_CRT ("tagged types", Typ); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; end if; @@ -4523,14 +4481,14 @@ package body Exp_Disp is if RTE_Available (RE_Interface_Data) then if Max_Predef_Prims /= 15 then Error_Msg_N ("run-time library configuration error", Typ); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; end if; else if Max_Predef_Prims /= 9 then Error_Msg_N ("run-time library configuration error", Typ); Error_Msg_CRT ("tagged types", Typ); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; end if; end if; @@ -4667,6 +4625,10 @@ package body Exp_Disp is DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ))); Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))); + if Generate_SCIL then + Nb_Prim := 0; + end if; + Set_Is_Statically_Allocated (DT, Is_Library_Level_Tagged_Type (Typ)); Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ)); Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ)); @@ -4732,6 +4694,14 @@ package body Exp_Disp is Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); Set_SCIL_Entity (New_Node, Typ); Set_SCIL_Node (Last (Result), New_Node); + + goto Early_Exit_For_SCIL; + + -- Gnat2scil has its own implementation of dispatch tables, + -- different than what is being implemented here. Generating + -- further dispatch table initialization code would just + -- cause gnat2scil to generate useless Scil which CodePeer + -- would waste time and space analyzing, so we skip it. end if; -- Generate: @@ -4801,6 +4771,14 @@ package body Exp_Disp is Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); Set_SCIL_Entity (New_Node, Typ); Set_SCIL_Node (Last (Result), New_Node); + + goto Early_Exit_For_SCIL; + + -- Gnat2scil has its own implementation of dispatch tables, + -- different than what is being implemented here. Generating + -- further dispatch table initialization code would just + -- cause gnat2scil to generate useless Scil which CodePeer + -- would waste time and space analyzing, so we skip it. end if; Append_To (Result, @@ -6260,545 +6238,16 @@ package body Exp_Disp is end; end if; + <<Early_Exit_For_SCIL>> + -- Register the tagged type in the call graph nodes table Register_CG_Node (Typ); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; end Make_DT; - ----------------- - -- Make_VM_TSD -- - ----------------- - - function Make_VM_TSD (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Result : constant List_Id := New_List; - - function Count_Primitives (Typ : Entity_Id) return Nat; - -- Count the non-predefined primitive operations of Typ - - ---------------------- - -- Count_Primitives -- - ---------------------- - - function Count_Primitives (Typ : Entity_Id) return Nat is - Nb_Prim : Nat; - Prim_Elmt : Elmt_Id; - Prim : Entity_Id; - - begin - Nb_Prim := 0; - - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); - - if Is_Predefined_Dispatching_Operation (Prim) - or else Is_Predefined_Dispatching_Alias (Prim) - then - null; - - elsif Present (Interface_Alias (Prim)) then - null; - - else - Nb_Prim := Nb_Prim + 1; - end if; - - Next_Elmt (Prim_Elmt); - end loop; - - return Nb_Prim; - end Count_Primitives; - - -------------- - -- Make_OSD -- - -------------- - - function Make_OSD (Iface : Entity_Id) return Node_Id; - -- Generate the Object Specific Data table required to dispatch calls - -- through synchronized interfaces. Returns a node that references the - -- generated OSD object. - - function Make_OSD (Iface : Entity_Id) return Node_Id is - Nb_Prim : constant Nat := Count_Primitives (Iface); - OSD : Entity_Id; - OSD_Aggr_List : List_Id; - - begin - -- Generate - -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) := - -- (OSD_Table => (1 => <value>, - -- ... - -- N => <value>)); - - if Nb_Prim = 0 - or else Is_Abstract_Type (Typ) - or else Is_Controlled (Typ) - or else Restriction_Active (No_Dispatching_Calls) - or else not Is_Limited_Type (Typ) - or else not Has_Interfaces (Typ) - or else not RTE_Record_Component_Available (RE_OSD_Table) - then - -- No OSD table required - - return Make_Null (Loc); - - else - OSD_Aggr_List := New_List; - - declare - Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; - Prim : Entity_Id; - Prim_Alias : Entity_Id; - Prim_Elmt : Elmt_Id; - E : Entity_Id; - Count : Nat := 0; - Pos : Nat; - - begin - Prim_Table := (others => Empty); - Prim_Alias := Empty; - - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); - - if Present (Interface_Alias (Prim)) - and then Find_Dispatching_Type - (Interface_Alias (Prim)) = Iface - then - Prim_Alias := Interface_Alias (Prim); - E := Ultimate_Alias (Prim); - Pos := UI_To_Int (DT_Position (Prim_Alias)); - - if Present (Prim_Table (Pos)) then - pragma Assert (Prim_Table (Pos) = E); - null; - - else - Prim_Table (Pos) := E; - - Append_To (OSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, - DT_Position (Prim_Alias))), - Expression => - Make_Integer_Literal (Loc, - DT_Position (Alias (Prim))))); - - Count := Count + 1; - end if; - end if; - - Next_Elmt (Prim_Elmt); - end loop; - - pragma Assert (Count = Nb_Prim); - end; - - OSD := Make_Temporary (Loc, 'I'); - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => OSD, - Aliased_Present => True, - Constant_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Nb_Prim)))), - - Expression => - Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), - Expression => - Make_Integer_Literal (Loc, Nb_Prim)), - - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_OSD_Table), Loc)), - Expression => Make_Aggregate (Loc, - Component_Associations => OSD_Aggr_List)))))); - - return - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (OSD, Loc), - Attribute_Name => Name_Unchecked_Access); - end if; - end Make_OSD; - - -- Local variables - - Nb_Prim : constant Nat := Count_Primitives (Typ); - AI : Elmt_Id; - I_Depth : Nat; - Iface_Table_Node : Node_Id; - Num_Ifaces : Nat; - TSD_Aggr_List : List_Id; - Typ_Ifaces : Elist_Id; - TSD_Tags_List : List_Id; - - Tname : constant Name_Id := Chars (Typ); - Name_SSD : constant Name_Id := - New_External_Name (Tname, 'S', Suffix_Index => -1); - Name_TSD : constant Name_Id := - New_External_Name (Tname, 'B', Suffix_Index => -1); - SSD : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_SSD); - TSD : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_TSD); - begin - -- Generate code to create the storage for the type specific data object - -- with enough space to store the tags of the ancestors plus the tags - -- of all the implemented interfaces (as described in a-tags.ads). - - -- TSD : Type_Specific_Data (I_Depth) := - -- (Idepth => I_Depth, - -- Tag_Kind => <tag_kind-value>, - -- Access_Level => Type_Access_Level (Typ), - -- Alignment => Typ'Alignment, - -- HT_Link => null, - -- Type_Is_Abstract => <<boolean-value>>, - -- Type_Is_Library_Level => <<boolean-value>>, - -- Interfaces_Table => <<access-value>> - -- SSD => SSD_Table'Address - -- Tags_Table => (0 => Typ'Tag, - -- 1 => Parent'Tag - -- ...)); - - TSD_Aggr_List := New_List; - - -- Idepth: Count ancestors to compute the inheritance depth. For private - -- extensions, always go to the full view in order to compute the real - -- inheritance depth. - - declare - Current_Typ : Entity_Id; - Parent_Typ : Entity_Id; - - begin - I_Depth := 0; - Current_Typ := Typ; - loop - Parent_Typ := Etype (Current_Typ); - - if Is_Private_Type (Parent_Typ) then - Parent_Typ := Full_View (Base_Type (Parent_Typ)); - end if; - - exit when Parent_Typ = Current_Typ; - - I_Depth := I_Depth + 1; - Current_Typ := Parent_Typ; - end loop; - end; - - -- I_Depth - - Append_To (TSD_Aggr_List, - Make_Integer_Literal (Loc, I_Depth)); - - -- Tag_Kind - - Append_To (TSD_Aggr_List, Tagged_Kind (Typ)); - - -- Access_Level - - Append_To (TSD_Aggr_List, - Make_Integer_Literal (Loc, Type_Access_Level (Typ))); - - -- Alignment - - -- For CPP types we cannot rely on the value of 'Alignment provided - -- by the backend to initialize this TSD field. Why not??? - - if Convention (Typ) = Convention_CPP - or else Is_CPP_Class (Root_Type (Typ)) - then - Append_To (TSD_Aggr_List, - Make_Integer_Literal (Loc, 0)); - else - Append_To (TSD_Aggr_List, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Alignment)); - end if; - - -- HT_Link - - Append_To (TSD_Aggr_List, - Make_Null (Loc)); - - -- Type_Is_Abstract (Ada 2012: AI05-0173) - - declare - Type_Is_Abstract : Entity_Id; - - begin - Type_Is_Abstract := - Boolean_Literals (Is_Abstract_Type (Typ)); - - Append_To (TSD_Aggr_List, - New_Occurrence_Of (Type_Is_Abstract, Loc)); - end; - - -- Type_Is_Library_Level - - declare - Type_Is_Library_Level : Entity_Id; - begin - Type_Is_Library_Level := - Boolean_Literals (Is_Library_Level_Entity (Typ)); - Append_To (TSD_Aggr_List, - New_Occurrence_Of (Type_Is_Library_Level, Loc)); - end; - - -- Interfaces_Table (required for AI-405) - - if RTE_Record_Component_Available (RE_Interfaces_Table) then - - -- Count the number of interface types implemented by Typ - - Collect_Interfaces (Typ, Typ_Ifaces); - - Num_Ifaces := 0; - AI := First_Elmt (Typ_Ifaces); - while Present (AI) loop - Num_Ifaces := Num_Ifaces + 1; - Next_Elmt (AI); - end loop; - - if Num_Ifaces = 0 then - Iface_Table_Node := Make_Null (Loc); - - -- Generate the Interface_Table object - - else - declare - TSD_Ifaces_List : constant List_Id := New_List; - Iface : Entity_Id; - ITable : Node_Id; - - begin - AI := First_Elmt (Typ_Ifaces); - while Present (AI) loop - Iface := Node (AI); - - Append_To (TSD_Ifaces_List, - Make_Aggregate (Loc, - Expressions => New_List ( - - -- Iface_Tag - - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Iface, Loc), - Attribute_Name => Name_Tag), - - -- OSD - - Make_OSD (Iface)))); - - Next_Elmt (AI); - end loop; - - ITable := Make_Temporary (Loc, 'I'); - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => ITable, - Aliased_Present => True, - Constant_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Interface_Data), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint - (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Num_Ifaces)))), - - Expression => Make_Aggregate (Loc, - Expressions => New_List ( - Make_Integer_Literal (Loc, Num_Ifaces), - Make_Aggregate (Loc, - Expressions => TSD_Ifaces_List))))); - - Iface_Table_Node := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (ITable, Loc), - Attribute_Name => Name_Unchecked_Access); - end; - end if; - - Append_To (TSD_Aggr_List, Iface_Table_Node); - end if; - - -- Generate the Select Specific Data table for synchronized types that - -- implement synchronized interfaces. The size of the table is - -- constrained by the number of non-predefined primitive operations. - - if RTE_Record_Component_Available (RE_SSD) then - if Ada_Version >= Ada_2005 - and then Has_DT (Typ) - and then Is_Concurrent_Record_Type (Typ) - and then Has_Interfaces (Typ) - and then Nb_Prim > 0 - and then not Is_Abstract_Type (Typ) - and then not Is_Controlled (Typ) - and then not Restriction_Active (No_Dispatching_Calls) - and then not Restriction_Active (No_Select_Statements) - then - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => SSD, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of ( - RTE (RE_Select_Specific_Data), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Nb_Prim)))))); - - -- This table is initialized by Make_Select_Specific_Data_Table, - -- which calls Set_Entry_Index and Set_Prim_Op_Kind. - - Append_To (TSD_Aggr_List, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (SSD, Loc), - Attribute_Name => Name_Unchecked_Access)); - else - Append_To (TSD_Aggr_List, Make_Null (Loc)); - end if; - end if; - - -- Initialize the table of ancestor tags. In case of interface types - -- this table is not needed. - - TSD_Tags_List := New_List; - - -- Fill position 0 with Typ'Tag - - Append_To (TSD_Tags_List, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Tag)); - - -- Fill the rest of the table with the tags of the ancestors - - declare - Current_Typ : Entity_Id; - Parent_Typ : Entity_Id; - Pos : Nat; - - begin - Pos := 1; - Current_Typ := Typ; - - loop - Parent_Typ := Etype (Current_Typ); - - if Is_Private_Type (Parent_Typ) then - Parent_Typ := Full_View (Base_Type (Parent_Typ)); - end if; - - exit when Parent_Typ = Current_Typ; - - Append_To (TSD_Tags_List, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Parent_Typ, Loc), - Attribute_Name => Name_Tag)); - - Pos := Pos + 1; - Current_Typ := Parent_Typ; - end loop; - - pragma Assert (Pos = I_Depth + 1); - end; - - Append_To (TSD_Aggr_List, - Make_Aggregate (Loc, - Expressions => TSD_Tags_List)); - - -- Build the TSD object - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => TSD, - Aliased_Present => True, - Constant_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of ( - RTE (RE_Type_Specific_Data), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, I_Depth)))), - - Expression => Make_Aggregate (Loc, - Expressions => TSD_Aggr_List))); - - -- Generate: - -- Check_TSD (TSD => TSD'Unrestricted_Access); - - if Ada_Version >= Ada_2005 - and then Is_Library_Level_Entity (Typ) - and then RTE_Available (RE_Check_TSD) - and then not Duplicated_Tag_Checks_Suppressed (Typ) - then - Append_To (Result, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Check_TSD), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (TSD, Loc), - Attribute_Name => Name_Unrestricted_Access)))); - end if; - - -- Generate: - -- Register_TSD (TSD'Unrestricted_Access); - - Append_To (Result, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Register_TSD), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (TSD, Loc), - Attribute_Name => Name_Unrestricted_Access)))); - - -- Populate the two auxiliary tables used for dispatching asynchronous, - -- conditional and timed selects for synchronized types that implement - -- a limited interface. Skip this step in Ravenscar profile or when - -- general dispatching is forbidden. - - if Ada_Version >= Ada_2005 - and then Is_Concurrent_Record_Type (Typ) - and then Has_Interfaces (Typ) - and then not Restriction_Active (No_Dispatching_Calls) - and then not Restriction_Active (No_Select_Statements) - then - Append_List_To (Result, - Make_Select_Specific_Data_Table (Typ)); - end if; - - return Result; - end Make_VM_TSD; - ------------------------------------- -- Make_Select_Specific_Data_Table -- ------------------------------------- @@ -7660,12 +7109,12 @@ package body Exp_Disp is begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - pragma Assert (VM_Target = No_VM); -- Do not register in the dispatch table eliminated primitives if not RTE_Available (RE_Tag) or else Is_Eliminated (Ultimate_Alias (Prim)) + or else Generate_SCIL then return L; end if; diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index a1cc11068eb..4ec53e127f7 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -346,10 +346,6 @@ package Exp_Disp is -- tagged types this routine imports the forward declaration of the tag -- entity, that will be declared and exported by Make_DT. - function Make_VM_TSD (Typ : Entity_Id) return List_Id; - -- Build the Type Specific Data record associated with tagged type Typ. - -- Invoked only when generating code for VM targets. - function Register_Primitive (Loc : Source_Ptr; Prim : Entity_Id) return List_Id; diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 564c527927c..de4a60a8b47 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 8002fef8bc9..bbdcf774c6a 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -55,7 +55,6 @@ with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; @@ -394,7 +393,8 @@ package body Exp_Intr is Analyze_And_Resolve (N, Etype (Act_Constr)); -- Do not generate a run-time check on the built object if tag - -- checks are suppressed for the result type or VM_Target /= No_VM + -- checks are suppressed for the result type or tagged type expansion + -- is disabled. if Tag_Checks_Suppressed (Etype (Result_Typ)) or else not Tagged_Type_Expansion @@ -959,39 +959,15 @@ package body Exp_Intr is -- Expand_Unc_Deallocation -- ----------------------------- - -- Generate the following Code : - - -- if Arg /= null then - -- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types - -- Free (Arg); - -- Arg := Null; - -- end if; - - -- For a task, we also generate a call to Free_Task to ensure that the - -- task itself is freed if it is terminated, ditto for a simple protected - -- object, with a call to Finalize_Protection. For composite types that - -- have tasks or simple protected objects as components, we traverse the - -- structures to find and terminate those components. - procedure Expand_Unc_Deallocation (N : Node_Id) is Arg : constant Node_Id := First_Actual (N); Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (Arg); - Desig_T : constant Entity_Id := Designated_Type (Typ); - Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); - Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); + Desig_Typ : constant Entity_Id := Designated_Type (Typ); + Needs_Fin : constant Boolean := Needs_Finalization (Desig_Typ); + Root_Typ : constant Entity_Id := Underlying_Type (Root_Type (Typ)); + Pool : constant Entity_Id := Associated_Storage_Pool (Root_Typ); Stmts : constant List_Id := New_List; - Needs_Fin : constant Boolean := Needs_Finalization (Desig_T); - - Finalizer_Data : Finalization_Exception_Data; - - Blk : Node_Id := Empty; - Blk_Id : Entity_Id; - Deref : Node_Id; - Final_Code : List_Id; - Free_Arg : Node_Id; - Free_Node : Node_Id; - Gen_Code : Node_Id; Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); -- This captures whether we know the argument to be non-null so that @@ -999,6 +975,20 @@ package body Exp_Intr is -- that we analyze some generated statements before properly attaching -- them to the tree, and that can disturb current value settings. + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + + Abrt_Blk : Node_Id := Empty; + Abrt_Blk_Id : Entity_Id; + AUD : Entity_Id; + Fin_Blk : Node_Id; + Fin_Call : Node_Id; + Fin_Data : Finalization_Exception_Data; + Free_Arg : Node_Id; + Free_Nod : Node_Id; + Gen_Code : Node_Id; + Obj_Ref : Node_Id; + Dummy : Entity_Id; -- This variable captures an unused dummy internal entity, see the -- comment associated with its use. @@ -1010,149 +1000,166 @@ package body Exp_Intr is return; end if; - -- Processing for pointer to controlled type + -- Processing for pointer to controlled types. Generate: + + -- Abrt : constant Boolean := ...; + -- Ex : Exception_Occurrence; + -- Raised : Boolean := False; + + -- begin -- aborts allowed + -- Abort_Defer; + + -- begin -- exception propagation allowed + -- [Deep_]Finalize (Obj_Ref); + + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (Ex, Get_Current_Excep.all.all); + -- end; + -- at end + -- Abort_Undefer_Direct; + -- end; + + -- Depending on whether exception propagation is enabled and/or aborts + -- are allowed, the generated code may lack block statements. if Needs_Fin then - Deref := + Obj_Ref := Make_Explicit_Dereference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Arg)); - -- If the type is tagged, then we must force dispatching on the - -- finalization call because the designated type may not be the - -- actual type of the object. - - if Is_Tagged_Type (Desig_T) - and then not Is_Class_Wide_Type (Desig_T) - then - Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref); + -- If the designated type is tagged, the finalization call must + -- dispatch because the designated type may not be the actual type + -- of the object. - elsif not Is_Tagged_Type (Desig_T) then + if Is_Tagged_Type (Desig_Typ) then + if not Is_Class_Wide_Type (Desig_Typ) then + Obj_Ref := + Unchecked_Convert_To (Class_Wide_Type (Desig_Typ), Obj_Ref); + end if; - -- Set type of result, to force a conversion when needed (see - -- exp_ch7, Convert_View), given that Deep_Finalize may be - -- inherited from the parent type, and we need the type of the - -- expression to see whether the conversion is in fact needed. + -- Otherwise the designated type is untagged. Set the type of the + -- dereference explicitly to force a conversion when needed given + -- that [Deep_]Finalize may be inherited from a parent type. - Set_Etype (Deref, Desig_T); + else + Set_Etype (Obj_Ref, Desig_Typ); end if; - -- The finalization call is expanded wrapped in a block to catch any - -- possible exception. If an exception does occur, then Program_Error - -- must be raised following the freeing of the object and its removal - -- from the finalization collection's list. We set a flag to record - -- that an exception was raised, and save its occurrence for use in - -- the later raise. - -- -- Generate: - -- Abort : constant Boolean := - -- Exception_Occurrence (Get_Current_Excep.all.all) = - -- Standard'Abort_Signal'Identity; - -- <or> - -- Abort : constant Boolean := False; -- no abort + -- [Deep_]Finalize (Obj_Ref); + + Fin_Call := Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ); - -- E : Exception_Occurrence; + -- Generate: + -- Abrt : constant Boolean := ...; + -- Ex : Exception_Occurrence; -- Raised : Boolean := False; - -- + -- begin - -- [Deep_]Finalize (Obj); + -- <Fin_Call> + -- exception -- when others => - -- Raised := True; - -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (Ex, Get_Current_Excep.all.all); -- end; - Build_Object_Declarations (Finalizer_Data, Stmts, Loc); - - Final_Code := New_List ( - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Final_Call (Obj_Ref => Deref, Typ => Desig_T)), - Exception_Handlers => New_List ( - Build_Exception_Handler (Finalizer_Data))))); + if Exceptions_OK then + Build_Object_Declarations (Fin_Data, Stmts, Loc); - -- For .NET/JVM, detach the object from the containing finalization - -- collection before finalizing it. + Fin_Blk := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Call), + Exception_Handlers => New_List ( + Build_Exception_Handler (Fin_Data)))); - if VM_Target /= No_VM and then Is_Controlled (Desig_T) then - Prepend_To (Final_Code, - Make_Detach_Call (New_Copy_Tree (Arg))); - end if; + -- The finalization action must be protected by an abort defer + -- undefer pair when aborts are allowed. Generate: - -- If aborts are allowed, then the finalization code must be - -- protected by an abort defer/undefer pair. + -- begin + -- Abort_Defer; + -- <Fin_Blk> + -- at end + -- Abort_Undefer_Direct; + -- end; - if Abort_Allowed then - Prepend_To (Final_Code, Build_Runtime_Call (Loc, RE_Abort_Defer)); + if Abort_Allowed then + AUD := RTE (RE_Abort_Undefer_Direct); - declare - AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); - - begin - Blk := + Abrt_Blk := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => Final_Code, + Statements => New_List ( + Build_Runtime_Call (Loc, RE_Abort_Defer), + Fin_Blk), At_End_Proc => New_Occurrence_Of (AUD, Loc))); + Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id); + -- Present the Abort_Undefer_Direct function to the backend so -- that it can inline the call to the function. Add_Inlined_Body (AUD, N); - end; + Append_To (Stmts, Abrt_Blk); - Add_Block_Identifier (Blk, Blk_Id); + -- Otherwise aborts are not allowed. Generate a dummy entity to + -- ensure that the internal symbols are in sync when a unit is + -- compiled with and without aborts. - Append (Blk, Stmts); + else + Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); + Append_To (Stmts, Fin_Blk); + end if; - else - -- Generate a dummy entity to ensure that the internal symbols are - -- in sync when a unit is compiled with and without aborts. + -- Otherwise exception propagation is not allowed - Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); - Append_List_To (Stmts, Final_Code); + else + Append_To (Stmts, Fin_Call); end if; end if; - -- For a task type, call Free_Task before freeing the ATCB - - if Is_Task_Type (Desig_T) then - - -- We used to detect the case of Abort followed by a Free here, - -- because the Free wouldn't actually free if it happens before - -- the aborted task actually terminates. The warning was removed, - -- because Free now works properly (the task will be freed once - -- it terminates). + -- For a task type, call Free_Task before freeing the ATCB. We used to + -- detect the case of Abort followed by a Free here, because the Free + -- wouldn't actually free if it happens before the aborted task actually + -- terminates. The warning was removed, because Free now works properly + -- (the task will be freed once it terminates). + if Is_Task_Type (Desig_Typ) then Append_To (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); -- For composite types that contain tasks, recurse over the structure -- to build the selectors for the task subcomponents. - elsif Has_Task (Desig_T) then - if Is_Record_Type (Desig_T) then - Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); + elsif Has_Task (Desig_Typ) then + if Is_Array_Type (Desig_Typ) then + Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ)); - elsif Is_Array_Type (Desig_T) then - Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); + elsif Is_Record_Type (Desig_Typ) then + Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ)); end if; end if; -- Same for simple protected types. Eventually call Finalize_Protection -- before freeing the PO for each protected component. - if Is_Simple_Protected_Type (Desig_T) then + if Is_Simple_Protected_Type (Desig_Typ) then Append_To (Stmts, Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg))); - elsif Has_Simple_Protected_Object (Desig_T) then - if Is_Record_Type (Desig_T) then - Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); - elsif Is_Array_Type (Desig_T) then - Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); + elsif Has_Simple_Protected_Object (Desig_Typ) then + if Is_Array_Type (Desig_Typ) then + Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ)); + + elsif Is_Record_Type (Desig_Typ) then + Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ)); end if; end if; @@ -1160,10 +1167,10 @@ package body Exp_Intr is -- a renaming rather than a constant to ensure that the original context -- is always set to null after the deallocation takes place. - Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True); - Free_Node := Make_Free_Statement (Loc, Empty); - Append_To (Stmts, Free_Node); - Set_Storage_Pool (Free_Node, Pool); + Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True); + Free_Nod := Make_Free_Statement (Loc, Empty); + Append_To (Stmts, Free_Nod); + Set_Storage_Pool (Free_Nod, Pool); -- Attach to tree before analysis of generated subtypes below @@ -1184,23 +1191,24 @@ package body Exp_Intr is -- Deallocate (which is allowed), then the actual will simply be set -- to null. - elsif Present (Get_Rep_Pragma - (Etype (Pool), Name_Simple_Storage_Pool_Type)) + elsif Present + (Get_Rep_Pragma (Etype (Pool), Name_Simple_Storage_Pool_Type)) then declare - Pool_Type : constant Entity_Id := Base_Type (Etype (Pool)); - Dealloc_Op : Entity_Id; + Pool_Typ : constant Entity_Id := Base_Type (Etype (Pool)); + Dealloc : Entity_Id; + begin - Dealloc_Op := Get_Name_Entity_Id (Name_Deallocate); - while Present (Dealloc_Op) loop - if Scope (Dealloc_Op) = Scope (Pool_Type) - and then Present (First_Formal (Dealloc_Op)) - and then Etype (First_Formal (Dealloc_Op)) = Pool_Type + Dealloc := Get_Name_Entity_Id (Name_Deallocate); + while Present (Dealloc) loop + if Scope (Dealloc) = Scope (Pool_Typ) + and then Present (First_Formal (Dealloc)) + and then Etype (First_Formal (Dealloc)) = Pool_Typ then - Set_Procedure_To_Call (Free_Node, Dealloc_Op); + Set_Procedure_To_Call (Free_Nod, Dealloc); exit; else - Dealloc_Op := Homonym (Dealloc_Op); + Dealloc := Homonym (Dealloc); end if; end loop; end; @@ -1209,17 +1217,17 @@ package body Exp_Intr is -- Deallocate through the class-wide Deallocate_Any. elsif Is_Class_Wide_Type (Etype (Pool)) then - Set_Procedure_To_Call (Free_Node, RTE (RE_Deallocate_Any)); + Set_Procedure_To_Call (Free_Nod, RTE (RE_Deallocate_Any)); -- Case of a specific pool type: make a statically bound call else - Set_Procedure_To_Call (Free_Node, - Find_Prim_Op (Etype (Pool), Name_Deallocate)); + Set_Procedure_To_Call + (Free_Nod, Find_Prim_Op (Etype (Pool), Name_Deallocate)); end if; end if; - if Present (Procedure_To_Call (Free_Node)) then + if Present (Procedure_To_Call (Free_Nod)) then -- For all cases of a Deallocate call, the back-end needs to be able -- to compute the size of the object being freed. This may require @@ -1230,11 +1238,11 @@ package body Exp_Intr is -- size parameter computed by GIGI. Same for an access to -- unconstrained packed array. - if Is_Class_Wide_Type (Desig_T) + if Is_Class_Wide_Type (Desig_Typ) or else - (Is_Array_Type (Desig_T) - and then not Is_Constrained (Desig_T) - and then Is_Packed (Desig_T)) + (Is_Array_Type (Desig_Typ) + and then not Is_Constrained (Desig_Typ) + and then Is_Packed (Desig_Typ)) then declare Deref : constant Node_Id := @@ -1247,9 +1255,9 @@ package body Exp_Intr is -- Perform minor decoration as it is needed by the side effect -- removal mechanism. - Set_Etype (Deref, Desig_T); - Set_Parent (Deref, Free_Node); - D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T); + Set_Etype (Deref, Desig_Typ); + Set_Parent (Deref, Free_Nod); + D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_Typ); if Nkind (D_Subtyp) in N_Has_Entity then D_Type := Entity (D_Subtyp); @@ -1268,9 +1276,8 @@ package body Exp_Intr is Freeze_Itype (D_Type, Deref); - Set_Actual_Designated_Subtype (Free_Node, D_Type); + Set_Actual_Designated_Subtype (Free_Nod, D_Type); end; - end if; end if; @@ -1285,10 +1292,11 @@ package body Exp_Intr is if Is_Interface (Directly_Designated_Type (Typ)) and then Tagged_Type_Expansion then - Set_Expression (Free_Node, + Set_Expression (Free_Nod, Unchecked_Convert_To (Typ, Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc), + Name => + New_Occurrence_Of (RTE (RE_Base_Address), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Address), Free_Arg))))); @@ -1296,7 +1304,7 @@ package body Exp_Intr is -- free (Obj_Ptr) else - Set_Expression (Free_Node, Free_Arg); + Set_Expression (Free_Nod, Free_Arg); end if; -- Only remaining step is to set result to null, or generate a raise of @@ -1324,15 +1332,14 @@ package body Exp_Intr is -- exception occurrence. -- Generate: - -- if Raised and then not Abort then - -- raise Program_Error; -- for .NET and - -- -- restricted RTS + -- if Raised and then not Abrt then + -- raise Program_Error; -- for restricted RTS -- <or> -- Raise_From_Controlled_Operation (E); -- all other cases -- end if; - if Needs_Fin then - Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); + if Needs_Fin and then Exceptions_OK then + Append_To (Stmts, Build_Raise_Statement (Fin_Data)); end if; -- If we know the argument is non-null, then make a block statement @@ -1351,7 +1358,7 @@ package body Exp_Intr is else Gen_Code := Make_Implicit_If_Statement (N, - Condition => + Condition => Make_Op_Ne (Loc, Left_Opnd => Duplicate_Subexpr (Arg), Right_Opnd => Make_Null (Loc)), @@ -1366,9 +1373,10 @@ package body Exp_Intr is -- If we generated a block with an At_End_Proc, expand the exception -- handler. We need to wait until after everything else is analyzed. - if Present (Blk) then + if Present (Abrt_Blk) then Expand_At_End_Handler - (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); + (HSS => Handled_Statement_Sequence (Abrt_Blk), + Blk_Id => Entity (Identifier (Abrt_Blk))); end if; end Expand_Unc_Deallocation; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index a797f230bbf..62aa80da005 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -303,9 +303,8 @@ package body Exp_Prag is -------------------------- procedure Expand_Pragma_Check (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - Cond : constant Node_Id := Arg2 (N); - Nam : constant Name_Id := Chars (Arg1 (N)); + Cond : constant Node_Id := Arg2 (N); + Nam : constant Name_Id := Chars (Arg1 (N)); Msg : Node_Id; Loc : constant Source_Ptr := Sloc (First_Node (Cond)); @@ -322,6 +321,8 @@ package body Exp_Prag is -- Assert_Failure, so that coverage analysis tools can relate the -- call to the failed check. + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + begin -- Nothing to do if pragma is ignored @@ -329,13 +330,10 @@ package body Exp_Prag is return; end if; - -- Set the Ghost mode in effect from the pragma. In general both the - -- assertion policy and the Ghost policy of pragma Check must agree, - -- but there are cases where this can be circumvented. For instance, - -- a living subtype with an ignored predicate may be declared in one - -- packade, an ignored Ghost object in another and the compilation may - -- use -gnata to enable assertions. - -- ??? Ghost predicates are under redesign + -- Pragmas Assert, Assert_And_Cut, Assume, Check and Loop_Invariant are + -- Ghost when they apply to a Ghost entity. Set the mode now to ensure + -- that any nodes generated during expansion are properly flagged as + -- Ghost. Set_Ghost_Mode (N); @@ -493,7 +491,7 @@ package body Exp_Prag is if Is_Entity_Name (Original_Node (Cond)) and then Entity (Original_Node (Cond)) = Standard_False then - return; + null; elsif Nam = Name_Assert then Error_Msg_N ("?A?assertion will fail at run time", N); @@ -503,10 +501,7 @@ package body Exp_Prag is end if; end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Expand_Pragma_Check; --------------------------------- @@ -992,7 +987,8 @@ package body Exp_Prag is Aggr : constant Node_Id := Expression (First (Pragma_Argument_Associations (CCs))); - GM : constant Ghost_Mode_Type := Ghost_Mode; + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; Case_Guard : Node_Id; CG_Checks : Node_Id; @@ -1027,12 +1023,20 @@ package body Exp_Prag is return; end if; - -- The contract cases may be subject to pragma Ghost with policy Ignore. - -- Set the mode now to ensure that any nodes generated during expansion - -- are properly flagged as ignored Ghost. + -- The contract cases is Ghost when it applies to a Ghost entity. Set + -- the mode now to ensure that any nodes generated during expansion are + -- properly flagged as Ghost. Set_Ghost_Mode (CCs); + -- The expansion of contract cases is quite distributed as it produces + -- various statements to evaluate the case guards and consequences. To + -- preserve the original context, set the Is_Assertion_Expr flag. This + -- aids the Ghost legality checks when verifying the placement of a + -- reference to a Ghost entity. + + In_Assertion_Expr := In_Assertion_Expr + 1; + Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1; -- Create the counter which tracks the number of case guards that @@ -1258,10 +1262,8 @@ package body Exp_Prag is Append_To (Stmts, Conseq_Checks); - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + In_Assertion_Expr := In_Assertion_Expr - 1; + Ghost_Mode := Save_Ghost_Mode; end Expand_Pragma_Contract_Cases; --------------------------------------- @@ -1361,22 +1363,6 @@ package body Exp_Prag is ------------------------------------- procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - - procedure Restore_Globals; - -- Restore the values of all saved global variables - - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - - -- Local variables - Loc : constant Source_Ptr := Sloc (Spec_Or_Body); Check : Node_Id; Expr : Node_Id; @@ -1384,7 +1370,7 @@ package body Exp_Prag is List : List_Id; Pack_Id : Entity_Id; - -- Start of processing for Expand_Pragma_Initial_Condition + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; begin if Nkind (Spec_Or_Body) = N_Package_Body then @@ -1424,9 +1410,9 @@ package body Exp_Prag is Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition); - -- The initial condition be subject to pragma Ghost with policy Ignore. - -- Set the mode now to ensure that any nodes generated during expansion - -- are properly flagged as ignored Ghost. + -- The initial condition is Ghost when it applies to a Ghost entity. Set + -- the mode now to ensure that any nodes generated during expansion are + -- properly flagged as Ghost. Set_Ghost_Mode (Init_Cond); @@ -1442,7 +1428,7 @@ package body Exp_Prag is -- runtime check as it will repeat the illegality. if Error_Posted (Init_Cond) or else Error_Posted (Expr) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -1461,7 +1447,7 @@ package body Exp_Prag is Append_To (List, Check); Analyze (Check); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; end Expand_Pragma_Initial_Condition; ------------------------------------ @@ -1811,7 +1797,7 @@ package body Exp_Prag is -- Local variables - GM : constant Ghost_Mode_Type := Ghost_Mode; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; -- Start of processing for Expand_Pragma_Loop_Variant @@ -1825,12 +1811,20 @@ package body Exp_Prag is return; end if; - -- The loop variant may be subject to pragma Ghost with policy Ignore. - -- Set the mode now to ensure that any nodes generated during expansion - -- are properly flagged as ignored Ghost. + -- The loop variant is Ghost when it applies to a Ghost entity. Set + -- the mode now to ensure that any nodes generated during expansion + -- are properly flagged as Ghost. Set_Ghost_Mode (N); + -- The expansion of Loop_Variant is quite distributed as it produces + -- various statements to capture and compare the arguments. To preserve + -- the original context, set the Is_Assertion_Expr flag. This aids the + -- Ghost legality checks when verifying the placement of a reference to + -- a Ghost entity. + + In_Assertion_Expr := In_Assertion_Expr + 1; + -- Locate the enclosing loop for which this assertion applies. In the -- case of Ada 2012 array iteration, we might be dealing with nested -- loops. Only the outermost loop has an identifier. @@ -1892,10 +1886,8 @@ package body Exp_Prag is -- corresponding declarations and statements. We leave it in the tree -- for documentation purposes. It will be ignored by the backend. - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + In_Assertion_Expr := In_Assertion_Expr - 1; + Ghost_Mode := Save_Ghost_Mode; end Expand_Pragma_Loop_Variant; -------------------------------- diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index e3e875cd431..0fb50402bb4 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -25,6 +25,7 @@ with Atree; use Atree; with Einfo; use Einfo; +with Exp_Ch5; use Exp_Ch5; with Exp_Dbug; use Exp_Dbug; with Exp_Util; use Exp_Util; with Sem_Res; use Sem_Res; @@ -73,6 +74,26 @@ package body Exp_SPARK is when N_Object_Renaming_Declaration => Expand_SPARK_N_Object_Renaming_Declaration (N); + -- Loop iterations over arrays need to be expanded, to avoid getting + -- two names referring to the same object in memory (the array and + -- the iterator) in GNATprove, especially since both can be written + -- (thus possibly leading to interferences due to aliasing). No such + -- problem arises with quantified expressions over arrays, which are + -- dealt with specially in GNATprove. + + when N_Loop_Statement => + declare + Scheme : constant Node_Id := Iteration_Scheme (N); + begin + if Present (Scheme) + and then Present (Iterator_Specification (Scheme)) + and then + Is_Iterator_Over_Array (Iterator_Specification (Scheme)) + then + Expand_Iterator_Loop_Over_Array (N); + end if; + end; + -- In SPARK mode, no other constructs require expansion when others => diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 21d94472e24..88de827a90d 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1121,7 +1121,7 @@ package body Exp_Strm is Decl : out Node_Id; Fnam : out Entity_Id) is - B_Typ : constant Entity_Id := Base_Type (Typ); + B_Typ : constant Entity_Id := Underlying_Type (Base_Type (Typ)); Cn : Name_Id; Constr : List_Id; Decls : List_Id; diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index 2b6dc92d315..5bcccbb0a59 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -152,7 +152,7 @@ package body Exp_Tss is begin loop Btyp := Base_Type (Btyp); - Proc := TSS (Btyp, Nam); + Proc := TSS (Btyp, Nam); exit when Present (Proc) or else not Is_Derived_Type (Btyp); @@ -517,7 +517,7 @@ package body Exp_Tss is else Elmt := First_Elmt (TSS_Elist (FN)); while Present (Elmt) loop - if Chars (Node (Elmt)) = Nam then + if Chars (Node (Elmt)) = Nam then Subp := Node (Elmt); -- For stream subprograms, the TSS entity may be a renaming- diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index c2a72431d34..93fbf6cf562 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -275,9 +275,9 @@ package body Exp_Unst is -- First step, we must mark all nested subprograms that require a static -- link (activation record) because either they contain explicit uplevel - -- references (as indicated by ??? being set at this - -- point), or they make calls to other subprograms in the same nest that - -- require a static link (in which case we set this flag). + -- references (as indicated by Is_Uplevel_Referenced_Entity being set at + -- this point), or they make calls to other subprograms in the same nest + -- that require a static link (in which case we set this flag). -- This is a recursive definition, and to implement this, we have to -- build a call graph for the set of nested subprograms, and then go @@ -316,12 +316,12 @@ package body Exp_Unst is Callee : Entity_Id; procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean); - -- Given a type T, checks if it is a static type defined as a - -- type with no dynamic bounds in sight. If so, the only action - -- is to set Is_Static_Type True for T. If T is not a static - -- type, then all types with dynamic bounds associated with - -- T are detected, and their bounds are marked as uplevel - -- referenced if not at the library level, and DT is set True. + -- Given a type T, checks if it is a static type defined as a type + -- with no dynamic bounds in sight. If so, the only action is to + -- set Is_Static_Type True for T. If T is not a static type, then + -- all types with dynamic bounds associated with T are detected, + -- and their bounds are marked as uplevel referenced if not at the + -- library level, and DT is set True. procedure Note_Uplevel_Ref (E : Entity_Id; @@ -407,7 +407,7 @@ package body Exp_Unst is end if; end; - -- For record type, check all components + -- For record type, check all components elsif Is_Record_Type (T) then declare @@ -420,7 +420,7 @@ package body Exp_Unst is end loop; end; - -- For array type, check index types and component type + -- For array type, check index types and component type elsif Is_Array_Type (T) then declare @@ -466,12 +466,22 @@ package body Exp_Unst is if Caller = Callee then return; + + -- Callee may be a function that returns an array, and that has + -- been rewritten as a procedure. If caller is that procedure, + -- nothing to do either. + + elsif Ekind (Callee) = E_Function + and then Rewritten_For_C (Callee) + and then Next_Entity (Callee) = Caller + then + return; end if; -- We have a new uplevel referenced entity -- All we do at this stage is to add the uplevel reference to - -- the table. It's too earch to do anything else, since this + -- the table. It's too early to do anything else, since this -- uplevel reference may come from an unreachable subprogram -- in which case the entry will be deleted. @@ -520,7 +530,7 @@ package body Exp_Unst is -- of no corresponding body being available is ignored for now. elsif Nkind (N) = N_Subprogram_Body then - Ent := Corresponding_Spec_Of (N); + Ent := Unique_Defining_Entity (N); -- Ignore generic subprogram @@ -674,7 +684,7 @@ package body Exp_Unst is Modified : Boolean; begin - Subps.Table (1).Reachable := True; + Subps.Table (Subps_First).Reachable := True; -- We use a simple minded algorithm as follows (obviously this can -- be done more efficiently, using one of the standard algorithms @@ -773,6 +783,13 @@ package body Exp_Unst is S := URJ.Caller; loop S := Enclosing_Subprogram (S); + + -- if we are at the top level, as can happen with + -- references to formals in aspects of nested subprogram + -- declarations, there are no further subprograms to + -- mark as requiring activation records. + + exit when No (S); Subps.Table (Subp_Index (S)).Declares_AREC := True; exit when S = URJ.Callee; end loop; @@ -805,13 +822,13 @@ package body Exp_Unst is -- Remove unreachable subprograms from Subps table. Note that we do -- this after eliminating entries from the other two tables, since - -- thos elimination steps depend on referencing the Subps table. + -- those elimination steps depend on referencing the Subps table. declare New_SI : SI_Type; begin - New_SI := 0; + New_SI := Subps_First - 1; for J in Subps_First .. Subps.Last loop declare STJ : Subp_Entry renames Subps.Table (J); @@ -1173,7 +1190,11 @@ package body Exp_Unst is -- Now we can insert the AREC declarations into the body - -- type ARECnT is record .. end record; + -- type ARECnT is record .. end record; + -- pragma Suppress_Initialization (ARECnT); + + -- Note that we need to set the Suppress_Initialization + -- flag after Decl_ARECnT has been analyzed. Decl_ARECnT := Make_Full_Type_Declaration (Loc, @@ -1258,21 +1279,24 @@ package body Exp_Unst is Push_Scope (STJ.Ent); Analyze (Decl_ARECnT, Suppress => All_Checks); + + -- Note that we need to call Set_Suppress_Initialization + -- after Decl_ARECnT has been analyzed, but before + -- analyzing Decl_ARECnP so that the flag is properly + -- taking into account. + + Set_Suppress_Initialization (STJ.ARECnT); + Analyze (Decl_ARECnPT, Suppress => All_Checks); Analyze (Decl_ARECn, Suppress => All_Checks); Analyze (Decl_ARECnP, Suppress => All_Checks); if Present (Decl_Assign) then - Analyze (Decl_Assign, Suppress => All_Checks); + Analyze (Decl_Assign, Suppress => All_Checks); end if; Pop_Scope; - -- Mark the types as needing typedefs - - Set_Needs_Typedef (STJ.ARECnT); - Set_Needs_Typedef (STJ.ARECnPT); - -- Next step, for each uplevel referenced entity, add -- assignment operations to set the component in the -- activation record. @@ -1417,8 +1441,8 @@ package body Exp_Unst is -- probably happens as a result of not properly treating -- instance bodies. To be examined ??? - -- If this test is omitted, then the compilation of - -- freeze.adb and inline.adb fail in unnesting mode. + -- If this test is omitted, then the compilation of freeze.adb + -- and inline.adb fail in unnesting mode. if No (STJR.ARECnF) then goto Continue; @@ -1430,12 +1454,11 @@ package body Exp_Unst is Push_Scope (STJR.Ent); - -- Now we need to rewrite the reference. We have a - -- reference is from level STJR.Lev to level STJE.Lev. - -- The general form of the rewritten reference for - -- entity X is: + -- Now we need to rewrite the reference. We have a reference + -- from level STJR.Lev to level STJE.Lev. The general form of + -- the rewritten reference for entity X is: - -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X) + -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X) -- where a,b,c,d .. m = -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev @@ -1541,11 +1564,10 @@ package body Exp_Unst is begin if Present (STT.ARECnF) then - -- CTJ.N is a call to a subprogram which may require - -- a pointer to an activation record. The subprogram - -- containing the call is CTJ.From and the subprogram being - -- called is CTJ.To, so we have a call from level STF.Lev to - -- level STT.Lev. + -- CTJ.N is a call to a subprogram which may require a pointer + -- to an activation record. The subprogram containing the call + -- is CTJ.From and the subprogram being called is CTJ.To, so we + -- have a call from level STF.Lev to level STT.Lev. -- There are three possibilities: @@ -1555,10 +1577,10 @@ package body Exp_Unst is if STF.Lev = STT.Lev then Extra := New_Occurrence_Of (STF.ARECnF, Loc); - -- For a call that goes down a level, we pass a pointer - -- to the activation record constructed within the caller - -- (which may be the outer level subprogram, but also may - -- be a more deeply nested caller). + -- For a call that goes down a level, we pass a pointer to the + -- activation record constructed within the caller (which may + -- be the outer-level subprogram, but also may be a more deeply + -- nested caller). elsif STT.Lev = STF.Lev + 1 then Extra := New_Occurrence_Of (STF.ARECnP, Loc); @@ -1580,9 +1602,9 @@ package body Exp_Unst is pragma Assert (STT.Lev < STF.Lev); Extra := New_Occurrence_Of (STF.ARECnF, Loc); - SubX := Subp_Index (CTJ.Caller); + SubX := Subp_Index (CTJ.Caller); for K in reverse STT.Lev .. STF.Lev - 1 loop - SubX := Enclosing_Subp (SubX); + SubX := Enclosing_Subp (SubX); Extra := Make_Selected_Component (Loc, Prefix => Extra, @@ -1607,8 +1629,8 @@ package body Exp_Unst is Append (ExtraP, Parameter_Associations (CTJ.N)); - -- We need to deal with the actual parameter chain as well. - -- The newly added parameter is always the last actual. + -- We need to deal with the actual parameter chain as well. The + -- newly added parameter is always the last actual. Act := First_Named_Actual (CTJ.N); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index eec7149ebb2..f2d7b59b18a 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -206,7 +206,7 @@ package body Exp_Util is end case; -- Nothing to do for the identifier in an object renaming declaration, - -- the renaming itself does not need atomic syncrhonization. + -- the renaming itself does not need atomic synchronization. if Nkind (Parent (N)) = N_Object_Renaming_Declaration then return; @@ -605,12 +605,6 @@ package body Exp_Util is elsif No_Pool_Assigned (Ptr_Typ) then return; - - -- Access-to-controlled types are not supported on .NET/JVM since - -- these targets cannot support pools and address arithmetic. - - elsif VM_Target /= No_VM then - return; end if; -- The allocation / deallocation of a controlled object must be @@ -1314,7 +1308,7 @@ package body Exp_Util is Expr := Make_Function_Call (Loc, Name => New_Occurrence_Of (Defining_Entity (Fun), Loc)); - if not In_Init_Proc and then VM_Target = No_VM then + if not In_Init_Proc then Set_Uses_Sec_Stack (Defining_Entity (Fun)); end if; end if; @@ -2713,6 +2707,50 @@ package body Exp_Util is end if; end Find_Optional_Prim_Op; + ------------------------------- + -- Find_Primitive_Operations -- + ------------------------------- + + function Find_Primitive_Operations + (T : Entity_Id; + Name : Name_Id) return Node_Id + is + Prim_Elmt : Elmt_Id; + Prim_Id : Entity_Id; + Ref : Node_Id; + Typ : Entity_Id := T; + + begin + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + Typ := Underlying_Type (Typ); + + Ref := Empty; + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim_Id := Node (Prim_Elmt); + if Chars (Prim_Id) = Name then + + -- If this is the first primitive operation found, + -- create a reference to it. + + if No (Ref) then + Ref := New_Occurrence_Of (Prim_Id, Sloc (T)); + + -- Otherwise, add interpretation to existing reference + + else + Add_One_Interp (Ref, Prim_Id, Etype (Prim_Id)); + end if; + end if; + Next_Elmt (Prim_Elmt); + end loop; + + return Ref; + end Find_Primitive_Operations; + ------------------ -- Find_Prim_Op -- ------------------ @@ -3822,10 +3860,10 @@ package body Exp_Util is -- caller. Note that in the subexpression case, N is always the child we -- came from. - -- N_Raise_xxx_Error is an annoying special case, it is a statement if - -- it has type Standard_Void_Type, and a subexpression otherwise. - -- otherwise. Procedure calls, and similarly procedure attribute - -- references, are also statements. + -- N_Raise_xxx_Error is an annoying special case, it is a statement + -- if it has type Standard_Void_Type, and a subexpression otherwise. + -- Procedure calls, and similarly procedure attribute references, are + -- also statements. if Nkind (Assoc_Node) in N_Subexpr and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error @@ -4040,6 +4078,22 @@ package body Exp_Util is end if; return; + + -- Iteration scheme located in a transient scope + + elsif Nkind (P) = N_Iteration_Scheme + and then Present (Wrapped_Node) + then + -- If the enclosing iterator loop is marked as requiring the + -- secondary stack then the actions must be inserted in the + -- transient scope. + + if Uses_Sec_Stack + (Find_Enclosing_Iterator_Loop (Current_Scope)) + then + Store_Before_Actions_In_Scope (Ins_Actions); + return; + end if; end if; -- Statements, declarations, pragmas, representation clauses @@ -4174,7 +4228,7 @@ package body Exp_Util is when N_Raise_xxx_Error => if Etype (P) = Standard_Void_Type then - if P = Wrapped_Node then + if P = Wrapped_Node then Store_Before_Actions_In_Scope (Ins_Actions); else Insert_List_Before_And_Analyze (P, Ins_Actions); @@ -5309,12 +5363,6 @@ package body Exp_Util is T : constant Entity_Id := Etype (N); begin - -- Objects are never unaligned on VMs - - if VM_Target /= No_VM then - return False; - end if; - -- If renamed object, apply test to underlying object if Is_Entity_Name (N) @@ -5833,21 +5881,6 @@ package body Exp_Util is end if; end Is_Volatile_Reference; - -------------------------- - -- Is_VM_By_Copy_Actual -- - -------------------------- - - function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is - begin - return VM_Target /= No_VM - and then (Nkind (N) = N_Slice - or else - (Nkind (N) = N_Identifier - and then Present (Renamed_Object (Entity (N))) - and then Nkind (Renamed_Object (Entity (N))) = - N_Slice)); - end Is_VM_By_Copy_Actual; - -------------------- -- Kill_Dead_Code -- -------------------- @@ -6424,34 +6457,17 @@ package body Exp_Util is Expr : Node_Id; Mem : Boolean := False) return Node_Id is - GM : constant Ghost_Mode_Type := Ghost_Mode; - - procedure Restore_Globals; - -- Restore the values of all saved global variables - - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - - -- Local variables - Loc : constant Source_Ptr := Sloc (Expr); Call : Node_Id; PFM : Entity_Id; - -- Start of processing for Make_Predicate_Call + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; begin pragma Assert (Present (Predicate_Function (Typ))); - -- The related type may be subject to pragma Ghost with policy Ignore. - -- Set the mode now to ensure that the call is properly flagged as - -- ignored Ghost. + -- The related type may be subject to pragma Ghost. Set the mode now to + -- ensure that the call is properly marked as Ghost. Set_Ghost_Mode_From_Entity (Typ); @@ -6466,7 +6482,7 @@ package body Exp_Util is Name => New_Occurrence_Of (PFM, Loc), Parameter_Associations => New_List (Relocate_Node (Expr))); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Call; end if; end if; @@ -6479,7 +6495,7 @@ package body Exp_Util is New_Occurrence_Of (Predicate_Function (Typ), Loc), Parameter_Associations => New_List (Relocate_Node (Expr))); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Call; end Make_Predicate_Call; @@ -6491,13 +6507,14 @@ package body Exp_Util is (Typ : Entity_Id; Expr : Node_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Expr); - Nam : Name_Id; + Loc : constant Source_Ptr := Sloc (Expr); + Arg_List : List_Id; + Nam : Name_Id; begin - -- If predicate checks are suppressed, then return a null statement. - -- For this call, we check only the scope setting. If the caller wants - -- to check a specific entity's setting, they must do it manually. + -- If predicate checks are suppressed, then return a null statement. For + -- this call, we check only the scope setting. If the caller wants to + -- check a specific entity's setting, they must do it manually. if Predicate_Checks_Suppressed (Empty) then return Make_Null_Statement (Loc); @@ -6521,14 +6538,24 @@ package body Exp_Util is Nam := Name_Predicate; end if; + Arg_List := New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Nam)), + Make_Pragma_Argument_Association (Loc, + Expression => Make_Predicate_Call (Typ, Expr))); + + if Has_Aspect (Typ, Aspect_Predicate_Failure) then + Append_To (Arg_List, + Make_Pragma_Argument_Association (Loc, + Expression => + New_Copy_Tree + (Expression (Find_Aspect (Typ, Aspect_Predicate_Failure))))); + end if; + return Make_Pragma (Loc, Pragma_Identifier => Make_Identifier (Loc, Name_Check), - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Nam)), - Make_Pragma_Argument_Association (Loc, - Expression => Make_Predicate_Call (Typ, Expr)))); + Pragma_Argument_Associations => Arg_List); end Make_Predicate_Check; ---------------------------- @@ -6669,7 +6696,7 @@ package body Exp_Util is EQ_Typ : Entity_Id := Empty; begin - -- A class-wide equivalent type is not needed when VM_Target + -- A class-wide equivalent type is not needed on VM targets -- because the VM back-ends handle the class-wide object -- initialization itself (and doesn't need or want the -- additional intermediate type to handle the assignment). @@ -6870,13 +6897,10 @@ package body Exp_Util is if Restriction_Active (No_Finalization) then return False; - -- C++, CIL and Java types are not considered controlled. It is assumed - -- that the non-Ada side will handle their clean up. + -- C++ types are not considered controlled. It is assumed that the + -- non-Ada side will handle their clean up. - elsif Convention (T) = Convention_CIL - or else Convention (T) = Convention_CPP - or else Convention (T) = Convention_Java - then + elsif Convention (T) = Convention_CPP then return False; -- Never needs finalization if Disable_Controlled set @@ -8053,6 +8077,16 @@ package body Exp_Util is elsif Is_Ignored_Ghost_Entity (Obj_Id) then null; + -- The expansion of iterator loops generates an object declaration + -- where the Ekind is explicitly set to loop parameter. This is to + -- ensure that the loop parameter behaves as a constant from user + -- code point of view. Such object are never controlled and do not + -- require cleanup actions. An iterator loop over a container of + -- controlled objects does not produce such object declarations. + + elsif Ekind (Obj_Id) = E_Loop_Parameter then + return False; + -- The object is of the form: -- Obj : Typ [:= Expr]; -- @@ -8944,10 +8978,10 @@ package body Exp_Util is -- locate here if this node corresponds to a previous invocation of -- Remove_Side_Effects to avoid a never ending loop in the frontend. - elsif VM_Target /= No_VM - and then not Comes_From_Source (N) - and then Nkind (Parent (N)) = N_Object_Renaming_Declaration - and then Is_Class_Wide_Type (Typ) + elsif not Tagged_Type_Expansion + and then not Comes_From_Source (N) + and then Nkind (Parent (N)) = N_Object_Renaming_Declaration + and then Is_Class_Wide_Type (Typ) then return True; end if; @@ -9404,7 +9438,8 @@ package body Exp_Util is return Present (S) and then Get_TSS_Name (S) /= TSS_Null - and then not Is_Predicate_Function (S); + and then not Is_Predicate_Function (S) + and then not Is_Predicate_Function_M (S); end Within_Internal_Subprogram; ---------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index a7b942a7569..b6cf41d3b59 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -467,6 +467,13 @@ package Exp_Util is -- Ada 2005 (AI-251): Given a type T implementing the interface Iface, -- return the record component containing the tag of Iface. + function Find_Primitive_Operations + (T : Entity_Id; + Name : Name_Id) return Node_Id; + -- Return a reference to a primitive operation with given name. If + -- operation is overloaded, the node carries the corresponding set + -- of overloaded interpretations. + function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id; -- Find the first primitive operation of a tagged type T with name Name. -- This function allows the use of a primitive operation which is not @@ -719,10 +726,6 @@ package Exp_Util is -- or has Volatile_Components set. A slice of a volatile variable is -- also volatile. - function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean; - -- Returns True if we are compiling on VM targets and N is a node that - -- requires pass-by-copy in these targets. - procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False); -- N represents a node for a section of code that is known to be dead. Any -- exception handler references and warning messages relating to this code diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index ff1975955dc..4aa20d6f41b 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Debug; use Debug; with Debug_A; use Debug_A; with Exp_Aggr; use Exp_Aggr; with Exp_SPARK; use Exp_SPARK; @@ -67,6 +68,10 @@ package body Expander is Table_Increment => 200, Table_Name => "Expander_Flags"); + Abort_Bug_Box_Error : exception; + -- Arbitrary exception to raise for implementation of -gnatd.B. See "when + -- N_Abort_Statement" below. See also debug.adb. + ------------ -- Expand -- ------------ @@ -150,6 +155,13 @@ package body Expander is when N_Abort_Statement => Expand_N_Abort_Statement (N); + -- If -gnatd.B switch was given, crash the compiler. See + -- debug.adb for explanation. + + if Debug_Flag_Dot_BB then + raise Abort_Bug_Box_Error; + end if; + when N_Accept_Statement => Expand_N_Accept_Statement (N); @@ -420,6 +432,9 @@ package body Expander is when N_Selective_Accept => Expand_N_Selective_Accept (N); + when N_Single_Protected_Declaration => + Expand_N_Single_Protected_Declaration (N); + when N_Single_Task_Declaration => Expand_N_Single_Task_Declaration (N); @@ -459,7 +474,7 @@ package body Expander is when N_Variant_Part => Expand_N_Variant_Part (N); - -- For all other node kinds, no expansion activity required + -- For all other node kinds, no expansion activity required when others => null; diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c index a6c1c8fee03..4da70180b77 100644 --- a/gcc/ada/expect.c +++ b/gcc/ada/expect.c @@ -83,29 +83,6 @@ #include <io.h> #include "mingw32.h" -void -__gnat_kill (int pid, int sig, int close) -{ - HANDLE h = OpenProcess (PROCESS_ALL_ACCESS, FALSE, pid); - if (h == NULL) - return; - if (sig == 9) - { - TerminateProcess (h, 0); - __gnat_win32_remove_handle (NULL, pid); - } - else if (sig == SIGINT) - GenerateConsoleCtrlEvent (CTRL_C_EVENT, pid); - else if (sig == SIGBREAK) - GenerateConsoleCtrlEvent (CTRL_BREAK_EVENT, pid); - /* ??? The last two alternatives don't really work. SIGBREAK requires setting - up process groups at start time which we don't do; treating SIGINT is just - not possible apparently. So we really only support signal 9. Fortunately - that's all we use in GNAT.Expect */ - - CloseHandle (h); -} - int __gnat_waitpid (int pid) { @@ -214,12 +191,6 @@ __gnat_expect_poll (int *fd, #include <vms/iodef.h> #include <signal.h> -void -__gnat_kill (int pid, int sig, int close) -{ - kill (pid, sig); -} - int __gnat_waitpid (int pid) { @@ -371,12 +342,6 @@ typedef long fd_mask; #endif /* !_IBMR2 */ #endif /* !NO_FD_SET */ -void -__gnat_kill (int pid, int sig, int close) -{ - kill (pid, sig); -} - int __gnat_waitpid (int pid) { @@ -497,13 +462,6 @@ __gnat_expect_poll (int *fd, #else -void -__gnat_kill (int pid ATTRIBUTE_UNUSED, - int sig ATTRIBUTE_UNUSED, - int close ATTRIBUTE_UNUSED) -{ -} - int __gnat_waitpid (int pid ATTRIBUTE_UNUSED, int sig ATTRIBUTE_UNUSED) { diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 88686e8c449..36befa6b599 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2014, Free Software Foundation, Inc. * + * Copyright (C) 1992-2015, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -39,6 +39,10 @@ extern "C" { #endif +/* atree: */ + +#define Serious_Errors_Detected atree__serious_errors_detected + /* comperr: */ #define Compiler_Abort comperr__compiler_abort @@ -77,10 +81,6 @@ extern Boolean Is_Entity_Name (Node_Id); #define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, char); -/* atree: */ - -#define Serious_Errors_Detected atree__serious_errors_detected - /* errout: */ #define Error_Msg_N errout__error_msg_n @@ -194,11 +194,15 @@ extern Boolean No_Strict_Aliasing_CP; #define No_Exception_Handlers_Set restrict__no_exception_handlers_set #define Check_No_Implicit_Heap_Alloc restrict__check_no_implicit_heap_alloc +#define Check_No_Implicit_Task_Alloc restrict__check_no_implicit_task_alloc +#define Check_No_Implicit_Protected_Alloc restrict__check_no_implicit_protected_alloc #define Check_Elaboration_Code_Allowed restrict__check_elaboration_code_allowed #define Check_Implicit_Dynamic_Code_Allowed restrict__check_implicit_dynamic_code_allowed extern Boolean No_Exception_Handlers_Set (void); extern void Check_No_Implicit_Heap_Alloc (Node_Id); +extern void Check_No_Implicit_Task_Alloc (Node_Id); +extern void Check_No_Implicit_Protected_Alloc (Node_Id); extern void Check_Elaboration_Code_Allowed (Node_Id); extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id); diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index f5432096e28..77fa6c0d78d 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -478,7 +478,7 @@ package body Fmap is Buffer (Buffer_Last) := ASCII.LF; end Put_Line; - -- Start of Update_Mapping_File + -- Start of processing for Update_Mapping_File begin -- If the mapping file could not be read, then it will not be possible diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index c7ad86c1d41..59a49ced0ae 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -36,6 +36,7 @@ with Exp_Disp; use Exp_Disp; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; with Exp_Tss; use Exp_Tss; +with Fname; use Fname; with Ghost; use Ghost; with Layout; use Layout; with Lib; use Lib; @@ -581,7 +582,7 @@ package body Freeze is -- the body is analyzed when the renamed entity is frozen, it may -- be necessary to restore the proper scope (see package Exp_Ch13). - if Nkind (N) = N_Subprogram_Renaming_Declaration + if Nkind (N) = N_Subprogram_Renaming_Declaration and then Present (Corresponding_Spec (N)) then Set_Corresponding_Spec (Body_Node, Corresponding_Spec (N)); @@ -1196,9 +1197,14 @@ package body Freeze is Attribute_Scalar_Storage_Order); Comp_ADC_Present := Present (Comp_ADC); - -- Case of record or array component: check storage order compatibility + -- Case of record or array component: check storage order compatibility. + -- But, if the record has Complex_Representation, then it is treated as + -- a scalar in the back end so the storage order is irrelevant. - if Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then + if (Is_Record_Type (Comp_Type) + and then not Has_Complex_Representation (Comp_Type)) + or else Is_Array_Type (Comp_Type) + then Comp_SSO_Differs := Reverse_Storage_Order (Encl_Type) /= @@ -1592,7 +1598,7 @@ package body Freeze is end if; end Process_Flist; - -- Start or processing for Freeze_All_Ent + -- Start of processing for Freeze_All_Ent begin E := From; @@ -1870,10 +1876,6 @@ package body Freeze is ------------------- function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is - GM : constant Ghost_Mode_Type := Ghost_Mode; - -- Save the current Ghost mode in effect in case the entity being frozen - -- sets a different mode. - Loc : constant Source_Ptr := Sloc (N); Atype : Entity_Id; Comp : Entity_Id; @@ -1945,9 +1947,6 @@ package body Freeze is -- call, but rather must go in the package holding the function, so that -- the backend can process it in the proper context. - procedure Restore_Globals; - -- Restore the values of all saved global variables - procedure Wrap_Imported_Subprogram (E : Entity_Id); -- If E is an entity for an imported subprogram with pre/post-conditions -- then this procedure will create a wrapper to ensure that proper run- @@ -2807,6 +2806,15 @@ package body Freeze is then Set_Alignment (Arr, Alignment (Component_Type (Arr))); end if; + + -- A Ghost type cannot have a component of protected or task type + -- (SPARK RM 6.9(19)). + + if Is_Ghost_Entity (Arr) and then Is_Concurrent_Type (Ctyp) then + Error_Msg_N + ("ghost array type & cannot have concurrent component type", + Arr); + end if; end Freeze_Array_Type; ------------------------------- @@ -2930,7 +2938,6 @@ package body Freeze is and then ((Has_Non_Null_Base_Init_Proc (Etype (E)) and then not No_Initialization (Declaration_Node (E)) - and then not Is_Value_Type (Etype (E)) and then not Initialization_Suppressed (Etype (E))) or else (Needs_Simple_Initialization (Etype (E)) @@ -3133,7 +3140,6 @@ package body Freeze is and then Convention (F_Type) = Convention_Ada and then not Has_Warnings_Off (F_Type) and then not Has_Size_Clause (F_Type) - and then VM_Target = No_VM then Error_Msg_N ("& is an 8-bit Ada Boolean?x?", Formal); @@ -3180,11 +3186,6 @@ package body Freeze is and then Is_Array_Type (F_Type) and then not Is_Constrained (F_Type) and then Warn_On_Export_Import - - -- Exclude VM case, since both .NET and JVM can handle - -- unconstrained arrays without a problem. - - and then VM_Target = No_VM then Error_Msg_Qual_Level := 1; @@ -3302,7 +3303,6 @@ package body Freeze is elsif Root_Type (R_Type) = Standard_Boolean and then Convention (R_Type) = Convention_Ada - and then VM_Target = No_VM and then not Has_Warnings_Off (E) and then not Has_Warnings_Off (R_Type) and then not Has_Size_Clause (R_Type) @@ -3363,11 +3363,6 @@ package body Freeze is and then not Is_Imported (E) - -- Exclude VM case, since both .NET and JVM can handle return - -- of unconstrained arrays without a problem. - - and then VM_Target = No_VM - -- Check that general warning is enabled, and that it is not -- suppressed for this particular case. @@ -3375,8 +3370,9 @@ package body Freeze is and then not Has_Warnings_Off (E) and then not Has_Warnings_Off (R_Type) then - Error_Msg_N ("?x?foreign convention function& should not " & - "return unconstrained array!", E); + Error_Msg_N + ("?x?foreign convention function& should not return " + & "unconstrained array!", E); end if; end if; @@ -3958,61 +3954,74 @@ package body Freeze is Next_Entity (Comp); end loop; - -- Deal with default setting of reverse storage order + SSO_ADC := + Get_Attribute_Definition_Clause + (Rec, Attribute_Scalar_Storage_Order); - Set_SSO_From_Default (Rec); + -- If the record type has Complex_Representation, then it is treated + -- as a scalar in the back end so the storage order is irrelevant. - -- Check consistent attribute setting on component types + if Has_Complex_Representation (Rec) then + if Present (SSO_ADC) then + Error_Msg_N + ("??storage order has no effect with Complex_Representation", + SSO_ADC); + end if; - SSO_ADC := Get_Attribute_Definition_Clause - (Rec, Attribute_Scalar_Storage_Order); + else + -- Deal with default setting of reverse storage order - declare - Comp_ADC_Present : Boolean; - begin - Comp := First_Component (Rec); - while Present (Comp) loop - Check_Component_Storage_Order - (Encl_Type => Rec, - Comp => Comp, - ADC => SSO_ADC, - Comp_ADC_Present => Comp_ADC_Present); - SSO_ADC_Component := SSO_ADC_Component or Comp_ADC_Present; - Next_Component (Comp); - end loop; - end; + Set_SSO_From_Default (Rec); - -- Now deal with reverse storage order/bit order issues + -- Check consistent attribute setting on component types - if Present (SSO_ADC) then + declare + Comp_ADC_Present : Boolean; + begin + Comp := First_Component (Rec); + while Present (Comp) loop + Check_Component_Storage_Order + (Encl_Type => Rec, + Comp => Comp, + ADC => SSO_ADC, + Comp_ADC_Present => Comp_ADC_Present); + SSO_ADC_Component := SSO_ADC_Component or Comp_ADC_Present; + Next_Component (Comp); + end loop; + end; - -- Check compatibility of Scalar_Storage_Order with Bit_Order, if - -- the former is specified. + -- Now deal with reverse storage order/bit order issues - if Reverse_Bit_Order (Rec) /= Reverse_Storage_Order (Rec) then + if Present (SSO_ADC) then - -- Note: report error on Rec, not on SSO_ADC, as ADC may apply - -- to some ancestor type. + -- Check compatibility of Scalar_Storage_Order with Bit_Order, + -- if the former is specified. - Error_Msg_Sloc := Sloc (SSO_ADC); - Error_Msg_N - ("scalar storage order for& specified# inconsistent with " - & "bit order", Rec); - end if; + if Reverse_Bit_Order (Rec) /= Reverse_Storage_Order (Rec) then - -- Warn if there is an Scalar_Storage_Order attribute definition - -- clause but no component clause, no component that itself has - -- such an attribute definition, and no pragma Pack. + -- Note: report error on Rec, not on SSO_ADC, as ADC may + -- apply to some ancestor type. - if not (Placed_Component - or else - SSO_ADC_Component - or else - Is_Packed (Rec)) - then - Error_Msg_N - ("??scalar storage order specified but no component clause", - SSO_ADC); + Error_Msg_Sloc := Sloc (SSO_ADC); + Error_Msg_N + ("scalar storage order for& specified# inconsistent with " + & "bit order", Rec); + end if; + + -- Warn if there is a Scalar_Storage_Order attribute definition + -- clause but no component clause, no component that itself has + -- such an attribute definition, and no pragma Pack. + + if not (Placed_Component + or else + SSO_ADC_Component + or else + Is_Packed (Rec)) + then + Error_Msg_N + ("??scalar storage order specified but no component " + & "clause", SSO_ADC); + end if; end if; end if; @@ -4285,7 +4294,7 @@ package body Freeze is end if; end if; - -- The following checks are only relevant when SPARK_Mode is on as + -- The following checks are relevant only when SPARK_Mode is on as -- they are not standard Ada legality rules. if SPARK_Mode = On then @@ -4322,6 +4331,44 @@ package body Freeze is Next_Component (Comp); end loop; end if; + + -- A type which does not yield a synchronized object cannot have + -- a component that yields a synchronized object (SPARK RM 9.5). + + if not Yields_Synchronized_Object (Rec) then + Comp := First_Component (Rec); + while Present (Comp) loop + if Comes_From_Source (Comp) + and then Yields_Synchronized_Object (Etype (Comp)) + then + Error_Msg_Name_1 := Chars (Rec); + Error_Msg_N + ("component & of non-synchronized type % cannot be " + & "synchronized", Comp); + end if; + + Next_Component (Comp); + end loop; + end if; + + -- A Ghost type cannot have a component of protected or task type + -- (SPARK RM 6.9(19)). + + if Is_Ghost_Entity (Rec) then + Comp := First_Component (Rec); + while Present (Comp) loop + if Comes_From_Source (Comp) + and then Is_Concurrent_Type (Etype (Comp)) + then + Error_Msg_Name_1 := Chars (Rec); + Error_Msg_N + ("component & of ghost type % cannot be concurrent", + Comp); + end if; + + Next_Component (Comp); + end loop; + end if; end if; -- Make sure that if we have an iterator aspect, then we have @@ -4492,15 +4539,6 @@ package body Freeze is Append_List (Result, Decls); end Late_Freeze_Subprogram; - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - ------------------------------ -- Wrap_Imported_Subprogram -- ------------------------------ @@ -4644,12 +4682,16 @@ package body Freeze is end if; end Wrap_Imported_Subprogram; + -- Local variables + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + -- Start of processing for Freeze_Entity begin - -- The entity being frozen may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- freezing are properly flagged as ignored Ghost. + -- The entity being frozen may be subject to pragma Ghost. Set the mode + -- now to ensure that any nodes generated during freezing are properly + -- flagged as Ghost. Set_Ghost_Mode_From_Entity (E); @@ -4668,7 +4710,7 @@ package body Freeze is -- Do not freeze if already frozen since we only need one freeze node if Is_Frozen (E) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return No_List; -- It is improper to freeze an external entity within a generic because @@ -4683,7 +4725,7 @@ package body Freeze is Analyze_Aspects_At_Freeze_Point (E); end if; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return No_List; -- AI05-0213: A formal incomplete type does not freeze the actual. In @@ -4694,19 +4736,19 @@ package body Freeze is and then No (Full_View (Base_Type (E))) and then Ada_Version >= Ada_2012 then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return No_List; -- Formal subprograms are never frozen elsif Is_Formal_Subprogram (E) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return No_List; -- Generic types are never frozen as they lack delayed semantic checks elsif Is_Generic_Type (E) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return No_List; -- Do not freeze a global entity within an inner scope created during @@ -4740,7 +4782,7 @@ package body Freeze is then exit; else - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return No_List; end if; end if; @@ -4776,7 +4818,7 @@ package body Freeze is end loop; if No (S) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return No_List; end if; end; @@ -4784,7 +4826,7 @@ package body Freeze is elsif Ekind (E) = E_Generic_Package then Result := Freeze_Generic_Entities (E); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; end if; @@ -4867,7 +4909,7 @@ package body Freeze is if not Is_Internal (E) then if not Freeze_Profile (E) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; end if; end if; @@ -4892,7 +4934,7 @@ package body Freeze is if Late_Freezing then Late_Freeze_Subprogram (E); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return No_List; end if; @@ -5055,7 +5097,7 @@ package body Freeze is and then not Has_Delayed_Freeze (E)) then Check_Compile_Time_Size (E); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return No_List; end if; @@ -5077,12 +5119,19 @@ package body Freeze is end if; end; - -- A Ghost type cannot be effectively volatile (SPARK RM 6.9(8)) + if Is_Ghost_Entity (E) then - if Is_Ghost_Entity (E) - and then Is_Effectively_Volatile (E) - then - Error_Msg_N ("ghost type & cannot be volatile", E); + -- A Ghost type cannot be concurrent (SPARK RM 6.9(19)). Verify + -- this legality rule first to five a finer-grained diagnostic. + + if Is_Concurrent_Type (E) then + Error_Msg_N ("ghost type & cannot be concurrent", E); + + -- A Ghost type cannot be effectively volatile (SPARK RM 6.9(8)) + + elsif Is_Effectively_Volatile (E) then + Error_Msg_N ("ghost type & cannot be volatile", E); + end if; end if; -- Deal with special cases of freezing for subtype @@ -5330,7 +5379,7 @@ package body Freeze is if not Is_Frozen (Root_Type (E)) then Set_Is_Frozen (E, False); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; end if; @@ -5466,7 +5515,7 @@ package body Freeze is and then not Present (Full_View (E)) then Set_Is_Frozen (E, False); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; -- Case of full view present @@ -5558,7 +5607,7 @@ package body Freeze is Set_RM_Size (E, RM_Size (Full_View (E))); end if; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; -- Case of underlying full view present @@ -5588,7 +5637,7 @@ package body Freeze is Check_Debug_Info_Needed (E); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; -- Case of no full view present. If entity is derived or subtype, @@ -5602,7 +5651,7 @@ package body Freeze is else Set_Is_Frozen (E, False); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return No_List; end if; @@ -5616,7 +5665,6 @@ package body Freeze is while Present (Formal) loop if Ekind (Etype (Formal)) = E_Incomplete_Type and then No (Full_View (Etype (Formal))) - and then not Is_Value_Type (Etype (Formal)) then if Is_Tagged_Type (Etype (Formal)) then null; @@ -5651,7 +5699,7 @@ package body Freeze is -- generic processing), so we never need freeze nodes for them. if Is_Generic_Type (E) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; end if; @@ -6267,7 +6315,7 @@ package body Freeze is end if; end if; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return Result; end Freeze_Entity; @@ -7636,6 +7684,22 @@ package body Freeze is Set_Is_Pure (E, False); end if; + -- We also reset the Pure indication on a subprogram with an Address + -- parameter, because the parameter may be used as a pointer and the + -- referenced data may change even if the address value does not. + + -- Note that if the programmer gave an explicit Pure_Function pragma, + -- then we believe the programmer, and leave the subprogram Pure. + -- We also suppress this check on run-time files. + + if Is_Pure (E) + and then Is_Subprogram (E) + and then not Has_Pragma_Pure_Function (E) + and then not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)) + then + Check_Function_With_Address_Parameter (E); + end if; + -- For non-foreign convention subprograms, this is where we create -- the extra formals (for accessibility level and constrained bit -- information). We delay this till the freeze point precisely so @@ -7689,11 +7753,6 @@ package body Freeze is -- Warnings (Off) on specific entities here, probably so???) and then Warn_On_Export_Import - - -- Exclude the VM case, since return of unconstrained arrays - -- is properly handled in both the JVM and .NET cases. - - and then VM_Target = No_VM then Error_Msg_N ("?x?foreign convention function& should not return " & diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index b3c85f1f8bc..723096ccc1f 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -64,7 +64,6 @@ with Sinfo; use Sinfo; with Sinput; use Sinput; with Sinput.L; use Sinput.L; with SCIL_LL; use SCIL_LL; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Types; use Types; @@ -459,14 +458,9 @@ begin end if; end if; - -- Qualify all entity names in inner packages, package bodies, etc., - -- except when compiling for the VM back-ends, which depend on having - -- unqualified names in certain cases and handles the generation of - -- qualified names when needed. + -- Qualify all entity names in inner packages, package bodies, etc. - if VM_Target = No_VM then - Exp_Dbug.Qualify_All_Entity_Names; - end if; + Exp_Dbug.Qualify_All_Entity_Names; -- SCIL backend requirement. Check that SCIL nodes associated with -- dispatching calls reference subprogram calls. diff --git a/gcc/ada/g-arrspl.ads b/gcc/ada/g-arrspl.ads index fa7e6603c14..ce3158c5ef3 100644 --- a/gcc/ada/g-arrspl.ads +++ b/gcc/ada/g-arrspl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,7 +43,7 @@ generic -- The array which is a sequence of element type Element_Set is private; - -- This type represent a set of elements. This set does not defined a + -- This type represent a set of elements. This set does not define a -- specific order of the elements. The conversion of a sequence to a -- set and membership tests in the set is performed using the routines -- To_Set and Is_In defined below. @@ -74,7 +74,7 @@ package GNAT.Array_Split is type Slice_Set is private; -- This type uses by-reference semantics. This is a set of slices as -- returned by Create or Set routines below. The abstraction represents - -- a set of items. Each item is a part of the original string named a + -- a set of items. Each item is a part of the original array named a -- Slice. It is possible to access individual slices by using the Slice -- routine below. The first slice in the Set is at the position/index -- 1. The total number of slices in the set is returned by Slice_Count. diff --git a/gcc/ada/g-awk.ads b/gcc/ada/g-awk.ads index d6dc83eb64f..c52403e5ddf 100644 --- a/gcc/ada/g-awk.ads +++ b/gcc/ada/g-awk.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2011, AdaCore -- +-- Copyright (C) 2000-2015, AdaCore -- -- -- -- 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- -- @@ -465,7 +465,7 @@ package GNAT.AWK is Pattern : GNAT.Regpat.Pattern_Matcher; Action : Match_Action_Callback); -- Same as above but it pass the set of matches to the action - -- procedure. This is useful to analyse further why and where a regular + -- procedure. This is useful to analyze further why and where a regular -- expression did match. procedure Register diff --git a/gcc/ada/g-binenv.adb b/gcc/ada/g-binenv.adb new file mode 100644 index 00000000000..13e414d46fa --- /dev/null +++ b/gcc/ada/g-binenv.adb @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- G N A T . B I N D _ E N V I R O N M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2015, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by AdaCore. -- +-- -- +------------------------------------------------------------------------------ + +with System; + +package body GNAT.Bind_Environment is + + --------- + -- Get -- + --------- + + function Get (Key : String) return String is + use type System.Address; + + Bind_Env_Addr : System.Address; + pragma Import (C, Bind_Env_Addr, "__gl_bind_env_addr"); + -- Variable provided by init.c/s-init.ads, and initialized by + -- the binder generated file. + + Bind_Env : String (Positive); + for Bind_Env'Address use Bind_Env_Addr; + pragma Import (Ada, Bind_Env); + -- Import Bind_Env string from binder file. Note that we import + -- it here as a string with maximum boundaries. The "real" end + -- of the string is indicated by a NUL byte. + + Index, KLen, VLen : Integer; + + begin + if Bind_Env_Addr = System.Null_Address then + return ""; + end if; + + Index := Bind_Env'First; + loop + -- Index points to key length + + VLen := 0; + KLen := Character'Pos (Bind_Env (Index)); + exit when KLen = 0; + + Index := Index + KLen + 1; + + -- Index points to value length + + VLen := Character'Pos (Bind_Env (Index)); + exit when Bind_Env (Index - KLen .. Index - 1) = Key; + + Index := Index + VLen + 1; + end loop; + + return Bind_Env (Index + 1 .. Index + VLen); + end Get; + +end GNAT.Bind_Environment; diff --git a/gcc/ada/g-binenv.ads b/gcc/ada/g-binenv.ads new file mode 100644 index 00000000000..e3c181fafa2 --- /dev/null +++ b/gcc/ada/g-binenv.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- G N A T . B I N D _ E N V I R O N M E N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2015, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by AdaCore. -- +-- -- +------------------------------------------------------------------------------ + +package GNAT.Bind_Environment is + + pragma Pure; + + function Get (Key : String) return String; + -- Return the value associated with Key at bind time, + -- or an empty string if not found. + +end GNAT.Bind_Environment; diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 8d4372f6deb..5857094ff2b 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,6 +32,7 @@ with GNAT.IO; use GNAT.IO; with System.Address_Image; +with System.CRTL; with System.Memory; use System.Memory; with System.Soft_Links; use System.Soft_Links; @@ -88,6 +89,18 @@ package body GNAT.Debug_Pools is -- is high enough to make sure we still have enough frames to return to -- the user after we have hidden the frames internal to this package. + Disable : Boolean := False; + -- This variable is used to avoid infinite loops, where this package would + -- itself allocate memory and then call itself recursively, forever. Useful + -- when System_Memory_Debug_Pool_Enabled is True. + + System_Memory_Debug_Pool_Enabled : Boolean := False; + -- If True, System.Memory allocation uses Debug_Pool + + Allow_Unhandled_Memory : Boolean := False; + -- If True, protects Deallocate against releasing memory allocated before + -- System_Memory_Debug_Pool_Enabled was set. + --------------------------- -- Back Trace Hash Table -- --------------------------- @@ -115,11 +128,24 @@ package body GNAT.Debug_Pools is is access Traceback_Htable_Elem; type Traceback_Htable_Elem is record - Traceback : Tracebacks_Array_Access; - Kind : Traceback_Kind; - Count : Natural; - Total : Byte_Count; - Next : Traceback_Htable_Elem_Ptr; + Traceback : Tracebacks_Array_Access; + Kind : Traceback_Kind; + Count : Natural; + -- Size of the memory allocated/freed at Traceback since last Reset call + + Total : Byte_Count; + -- Number of chunk of memory allocated/freed at Traceback since last + -- Reset call. + + Frees : Natural; + -- Number of chunk of memory allocated at Traceback, currently freed + -- since last Reset call. (only for Alloc & Indirect_Alloc elements) + + Total_Frees : Byte_Count; + -- Size of the memory allocated at Traceback, currently freed since last + -- Reset call. (only for Alloc & Indirect_Alloc elements) + + Next : Traceback_Htable_Elem_Ptr; end record; -- Subprograms used for the Backtrace_Htable instantiation @@ -268,7 +294,35 @@ package body GNAT.Debug_Pools is -- up to the first one in the range: -- Ignored_Frame_Start .. Ignored_Frame_End + procedure Stdout_Put (S : String); + -- Wrapper for Put that ensures we always write to stdout instead of the + -- current output file defined in GNAT.IO. + + procedure Stdout_Put_Line (S : String); + -- Wrapper for Put_Line that ensures we always write to stdout instead of + -- the current output file defined in GNAT.IO. + + procedure Print_Traceback + (Output_File : File_Type; + Prefix : String; + Traceback : Traceback_Htable_Elem_Ptr); + -- Output Prefix & Traceback & EOL. + -- Print nothing if Traceback is null. + + procedure Print_Address (File : File_Type; Addr : Address); + -- Output System.Address without using secondary stack. + -- When System.Memory uses Debug_Pool, secondary stack cannot be used + -- during Allocate calls, as some Allocate calls are done to + -- register/initialize a secondary stack for a foreign thread. + -- During these calls, the secondary stack is not available yet. + package Validity is + function Is_Handled (Storage : System.Address) return Boolean; + pragma Inline (Is_Handled); + -- Return True if Storage is the address of a block that the debug pool + -- already had under its control. Used to allow System.Memory to use + -- Debug_Pools + function Is_Valid (Storage : System.Address) return Boolean; pragma Inline (Is_Valid); -- Return True if Storage is the address of a block that the debug pool @@ -420,6 +474,18 @@ package body GNAT.Debug_Pools is end if; end Output_File; + ------------------- + -- Print_Address -- + ------------------- + + procedure Print_Address (File : File_Type; Addr : Address) is + type My_Address is mod Memory_Size; + function To_My_Address is new Ada.Unchecked_Conversion + (System.Address, My_Address); + begin + Put (File, My_Address'Image (To_My_Address (Addr))); + end Print_Address; + -------------- -- Put_Line -- -------------- @@ -441,7 +507,8 @@ package body GNAT.Debug_Pools is procedure Print (Tr : Tracebacks_Array) is begin for J in Tr'Range loop - Put (File, "0x" & Address_Image (PC_For (Tr (J))) & ' '); + Print_Address (File, PC_For (Tr (J))); + Put (File, ' '); end loop; Put (File, ASCII.LF); end Print; @@ -519,12 +586,14 @@ package body GNAT.Debug_Pools is end if; declare + Disable_Exit_Value : constant Boolean := Disable; Trace : aliased Tracebacks_Array (1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels); Len, Start : Natural; Elem : Traceback_Htable_Elem_Ptr; begin + Disable := True; Call_Chain (Trace, Len); Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len, Ignored_Frame_Start, Ignored_Frame_End); @@ -539,10 +608,12 @@ package body GNAT.Debug_Pools is if Elem = null then Elem := new Traceback_Htable_Elem' (Traceback => new Tracebacks_Array'(Trace (Start .. Len)), - Count => 1, - Kind => Kind, - Total => Byte_Count (Size), - Next => null); + Count => 1, + Kind => Kind, + Total => Byte_Count (Size), + Frees => 0, + Total_Frees => 0, + Next => null); Backtrace_Htable.Set (Elem); else @@ -550,7 +621,12 @@ package body GNAT.Debug_Pools is Elem.Total := Elem.Total + Byte_Count (Size); end if; + Disable := Disable_Exit_Value; return Elem; + exception + when others => + Disable := Disable_Exit_Value; + raise; end; end Find_Or_Create_Traceback; @@ -579,7 +655,21 @@ package body GNAT.Debug_Pools is type Byte is mod 2 ** System.Storage_Unit; - type Validity_Bits is array (Validity_Byte_Index) of Byte; + type Validity_Bits_Part is array (Validity_Byte_Index) of Byte; + type Validity_Bits_Part_Ref is access all Validity_Bits_Part; + No_Validity_Bits_Part : constant Validity_Bits_Part_Ref := null; + + type Validity_Bits is record + Valid : Validity_Bits_Part_Ref := No_Validity_Bits_Part; + -- True if chunk of memory at this address is currently allocated + + Handled : Validity_Bits_Part_Ref := No_Validity_Bits_Part; + -- True if chunk of memory at this address was allocated once after + -- Allow_Unhandled_Memory was set to True. Used to know on Deallocate + -- if chunk of memory should be handled a block allocated by this + -- package. + + end record; type Validity_Bits_Ref is access all Validity_Bits; No_Validity_Bits : constant Validity_Bits_Ref := null; @@ -590,6 +680,13 @@ package body GNAT.Debug_Pools is function Hash (F : Integer_Address) return Header_Num; + function Is_Valid_Or_Handled + (Storage : System.Address; + Valid : Boolean) return Boolean; + pragma Inline (Is_Valid_Or_Handled); + -- Internal implementation of Is_Valid and Is_Handled. + -- Valid is used to select Valid or Handled arrays. + package Validy_Htable is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Validity_Bits_Ref, @@ -597,10 +694,11 @@ package body GNAT.Debug_Pools is Key => Integer_Address, Hash => Hash, Equal => "="); - -- Table to keep the validity bit blocks for the allocated data + -- Table to keep the validity and handled bit blocks for the allocated + -- data. function To_Pointer is new Ada.Unchecked_Conversion - (System.Address, Validity_Bits_Ref); + (System.Address, Validity_Bits_Part_Ref); procedure Memset (A : Address; C : Integer; N : size_t); pragma Import (C, Memset, "memset"); @@ -614,11 +712,13 @@ package body GNAT.Debug_Pools is return Header_Num (F mod Max_Header_Num); end Hash; - -------------- - -- Is_Valid -- - -------------- + ------------------------- + -- Is_Valid_Or_Handled -- + ------------------------- - function Is_Valid (Storage : System.Address) return Boolean is + function Is_Valid_Or_Handled + (Storage : System.Address; + Valid : Boolean) return Boolean is Int_Storage : constant Integer_Address := To_Integer (Storage); begin @@ -646,11 +746,39 @@ package body GNAT.Debug_Pools is if Ptr = No_Validity_Bits then return False; else - return (Ptr (Offset / System.Storage_Unit) and Bit) /= 0; + if Valid then + return (Ptr.Valid (Offset / System.Storage_Unit) + and Bit) /= 0; + else + if Ptr.Handled = No_Validity_Bits_Part then + return False; + else + return (Ptr.Handled (Offset / System.Storage_Unit) + and Bit) /= 0; + end if; + end if; end if; end; + end Is_Valid_Or_Handled; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Storage : System.Address) return Boolean is + begin + return Is_Valid_Or_Handled (Storage => Storage, Valid => True); end Is_Valid; + ----------------- + -- Is_Handled -- + ----------------- + + function Is_Handled (Storage : System.Address) return Boolean is + begin + return Is_Valid_Or_Handled (Storage => Storage, Valid => False); + end Is_Handled; + --------------- -- Set_Valid -- --------------- @@ -666,6 +794,28 @@ package body GNAT.Debug_Pools is Bit : constant Byte := 2 ** Natural (Offset mod System.Storage_Unit); + procedure Set_Handled; + pragma Inline (Set_Handled); + -- if Allow_Unhandled_Memory set Handled bit in table. + + ----------------- + -- Set_Handled -- + ----------------- + + procedure Set_Handled is + begin + if Allow_Unhandled_Memory then + if Ptr.Handled = No_Validity_Bits_Part then + Ptr.Handled := + To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); + Memset (Ptr.Handled.all'Address, 0, + size_t (Max_Validity_Byte_Index)); + end if; + Ptr.Handled (Offset / System.Storage_Unit) := + Ptr.Handled (Offset / System.Storage_Unit) or Bit; + end if; + end Set_Handled; + begin if Ptr = No_Validity_Bits then @@ -673,20 +823,24 @@ package body GNAT.Debug_Pools is -- it in the table. if Value then - Ptr := To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); + Ptr := new Validity_Bits; + Ptr.Valid := + To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); Validy_Htable.Set (Block_Number, Ptr); - Memset (Ptr.all'Address, 0, size_t (Max_Validity_Byte_Index)); - Ptr (Offset / System.Storage_Unit) := Bit; + Memset (Ptr.Valid.all'Address, 0, + size_t (Max_Validity_Byte_Index)); + Ptr.Valid (Offset / System.Storage_Unit) := Bit; + Set_Handled; end if; else if Value then - Ptr (Offset / System.Storage_Unit) := - Ptr (Offset / System.Storage_Unit) or Bit; - + Ptr.Valid (Offset / System.Storage_Unit) := + Ptr.Valid (Offset / System.Storage_Unit) or Bit; + Set_Handled; else - Ptr (Offset / System.Storage_Unit) := - Ptr (Offset / System.Storage_Unit) and (not Bit); + Ptr.Valid (Offset / System.Storage_Unit) := + Ptr.Valid (Offset / System.Storage_Unit) and (not Bit); end if; end if; end Set_Valid; @@ -720,10 +874,23 @@ package body GNAT.Debug_Pools is P : Ptr; Trace : Traceback_Htable_Elem_Ptr; + Disable_Exit_Value : constant Boolean := Disable; + begin <<Allocate_Label>> Lock_Task.all; + if Disable then + Storage_Address := + System.CRTL.malloc (System.CRTL.size_t (Size_In_Storage_Elements)); + Unlock_Task.all; + return; + end if; + + Disable := True; + + Pool.Alloc_Count := Pool.Alloc_Count + 1; + -- If necessary, start physically releasing memory. The reason this is -- done here, although Pool.Logically_Deallocated has not changed above, -- is so that we do this only after a series of deallocations (e.g loop @@ -824,12 +991,16 @@ package body GNAT.Debug_Pools is if Pool.Low_Level_Traces then Put (Output_File (Pool), "info: Allocated" - & Storage_Count'Image (Size_In_Storage_Elements) - & " bytes at 0x" & Address_Image (Storage_Address) - & " (physically:" - & Storage_Count'Image (Local_Storage_Array'Length) - & " bytes at 0x" & Address_Image (P.all'Address) - & "), at "); + & Storage_Count'Image (Size_In_Storage_Elements) + & " bytes at "); + Print_Address (Output_File (Pool), Storage_Address); + Put (Output_File (Pool), + " (physically:" + & Storage_Count'Image (Local_Storage_Array'Length) + & " bytes at "); + Print_Address (Output_File (Pool), P.all'Address); + Put (Output_File (Pool), + "), at "); Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, Allocate_Label'Address, Code_Address_For_Deallocate_End); @@ -840,18 +1011,19 @@ package body GNAT.Debug_Pools is Pool.Allocated := Pool.Allocated + Byte_Count (Size_In_Storage_Elements); - Current := Pool.Allocated - - Pool.Logically_Deallocated - - Pool.Physically_Deallocated; + Current := Pool.Current_Water_Mark; if Current > Pool.High_Water then Pool.High_Water := Current; end if; + Disable := Disable_Exit_Value; + Unlock_Task.all; exception when others => + Disable := Disable_Exit_Value; Unlock_Task.all; raise; end Allocate; @@ -1010,16 +1182,23 @@ package body GNAT.Debug_Pools is Next := Header.Next; if Pool.Low_Level_Traces then - Put_Line + Put (Output_File (Pool), "info: Freeing physical memory " - & Storage_Count'Image + & Storage_Count'Image ((abs Header.Block_Size) + Extra_Allocation) - & " bytes at 0x" - & Address_Image (Header.Allocation_Address)); + & " bytes at "); + Print_Address (Output_File (Pool), + Header.Allocation_Address); + Put_Line (Output_File (Pool), ""); + end if; + + if System_Memory_Debug_Pool_Enabled then + System.CRTL.free (Header.Allocation_Address); + else + System.Memory.Free (Header.Allocation_Address); end if; - System.Memory.Free (Header.Allocation_Address); Set_Valid (Tmp, False); -- Remove this block from the list @@ -1159,6 +1338,59 @@ package body GNAT.Debug_Pools is raise; end Free_Physically; + -------------- + -- Get_Size -- + -------------- + + procedure Get_Size + (Storage_Address : Address; + Size_In_Storage_Elements : out Storage_Count; + Valid : out Boolean) is + begin + Lock_Task.all; + + Valid := Is_Valid (Storage_Address); + + if Is_Valid (Storage_Address) then + declare + Header : constant Allocation_Header_Access := + Header_Of (Storage_Address); + begin + if Header.Block_Size >= 0 then + Valid := True; + Size_In_Storage_Elements := Header.Block_Size; + else + Valid := False; + end if; + end; + else + Valid := False; + end if; + + Unlock_Task.all; + + exception + when others => + Unlock_Task.all; + raise; + + end Get_Size; + + --------------------- + -- Print_Traceback -- + --------------------- + + procedure Print_Traceback + (Output_File : File_Type; + Prefix : String; + Traceback : Traceback_Htable_Elem_Ptr) is + begin + if Traceback /= null then + Put (Output_File, Prefix); + Put_Line (Output_File, 0, Traceback.Traceback); + end if; + end Print_Traceback; + ---------------- -- Deallocate -- ---------------- @@ -1183,7 +1415,31 @@ package body GNAT.Debug_Pools is if not Valid then Unlock_Task.all; - if Pool.Raise_Exceptions then + + if Storage_Address = System.Null_Address then + if Pool.Raise_Exceptions and then + Size_In_Storage_Elements /= Storage_Count'Last + then + raise Freeing_Not_Allocated_Storage; + else + Put (Output_File (Pool), + "error: Freeing Null_Address, at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End); + return; + end if; + end if; + + if Allow_Unhandled_Memory and then not Is_Handled (Storage_Address) + then + System.CRTL.free (Storage_Address); + return; + end if; + + if Pool.Raise_Exceptions and then + Size_In_Storage_Elements /= Storage_Count'Last + then raise Freeing_Not_Allocated_Storage; else Put (Output_File (Pool), @@ -1203,12 +1459,11 @@ package body GNAT.Debug_Pools is Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, Deallocate_Label'Address, Code_Address_For_Deallocate_End); - Put (Output_File (Pool), " Memory already deallocated at "); - Put_Line - (Output_File (Pool), 0, - To_Traceback (Header.Dealloc_Traceback).Traceback); - Put (Output_File (Pool), " Memory was allocated at "); - Put_Line (Output_File (Pool), 0, Header.Alloc_Traceback.Traceback); + Print_Traceback (Output_File (Pool), + " Memory already deallocated at ", + To_Traceback (Header.Dealloc_Traceback)); + Print_Traceback (Output_File (Pool), " Memory was allocated at ", + Header.Alloc_Traceback); end if; else @@ -1217,7 +1472,9 @@ package body GNAT.Debug_Pools is -- The code below is all based on the assumption that Header.all -- is not corrupted, such that the error is non-fatal. - if Header.Block_Size /= Size_In_Storage_Elements then + if Header.Block_Size /= Size_In_Storage_Elements and then + Size_In_Storage_Elements /= Storage_Count'Last + then Put_Line (Output_File (Pool), "error: Deallocate size " & Storage_Count'Image (Size_In_Storage_Elements) @@ -1228,17 +1485,21 @@ package body GNAT.Debug_Pools is if Pool.Low_Level_Traces then Put (Output_File (Pool), "info: Deallocated" - & Storage_Count'Image (Size_In_Storage_Elements) - & " bytes at 0x" & Address_Image (Storage_Address) - & " (physically" + & Storage_Count'Image (Header.Block_Size) + & " bytes at "); + Print_Address (Output_File (Pool), Storage_Address); + Put (Output_File (Pool), + " (physically" & Storage_Count'Image (Header.Block_Size + Extra_Allocation) - & " bytes at 0x" & Address_Image (Header.Allocation_Address) - & "), at "); + & " bytes at "); + Print_Address (Output_File (Pool), Header.Allocation_Address); + Put (Output_File (Pool), "), at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, Deallocate_Label'Address, Code_Address_For_Deallocate_End); - Put (Output_File (Pool), " Memory was allocated at "); - Put_Line (Output_File (Pool), 0, Header.Alloc_Traceback.Traceback); + Print_Traceback (Output_File (Pool), " Memory was allocated at ", + Header.Alloc_Traceback); end if; -- Remove this block from the list of used blocks @@ -1263,6 +1524,17 @@ package body GNAT.Debug_Pools is end if; end if; + -- Update the Alloc_Traceback Frees/Total_Frees members (if present) + + if Header.Alloc_Traceback /= null then + Header.Alloc_Traceback.Frees := Header.Alloc_Traceback.Frees + 1; + Header.Alloc_Traceback.Total_Frees := + Header.Alloc_Traceback.Total_Frees + + Byte_Count (Header.Block_Size); + end if; + + Pool.Free_Count := Pool.Free_Count + 1; + -- Update the header Header.all := @@ -1271,7 +1543,7 @@ package body GNAT.Debug_Pools is Dealloc_Traceback => To_Traceback (Find_Or_Create_Traceback (Pool, Dealloc, - Size_In_Storage_Elements, + Header.Block_Size, Deallocate_Label'Address, Code_Address_For_Deallocate_End)), Next => System.Null_Address, @@ -1373,14 +1645,10 @@ package body GNAT.Debug_Pools is (Output_File (Pool), Pool.Stack_Trace_Depth, null, Dereference_Label'Address, Code_Address_For_Dereference_End); - Put (Output_File (Pool), " First deallocation at "); - Put_Line - (Output_File (Pool), - 0, To_Traceback (Header.Dealloc_Traceback).Traceback); - Put (Output_File (Pool), " Initial allocation at "); - Put_Line - (Output_File (Pool), - 0, Header.Alloc_Traceback.Traceback); + Print_Traceback (Output_File (Pool), " First deallocation at ", + To_Traceback (Header.Dealloc_Traceback)); + Print_Traceback (Output_File (Pool), " Initial allocation at ", + Header.Alloc_Traceback); end if; end if; end if; @@ -1453,9 +1721,7 @@ package body GNAT.Debug_Pools is Put_Line ("Current Water Mark: " & - Byte_Count'Image - (Pool.Allocated - Pool.Logically_Deallocated - - Pool.Physically_Deallocated)); + Byte_Count'Image (Pool.Current_Water_Mark)); Put_Line ("High Water Mark: " & @@ -1470,10 +1736,12 @@ package body GNAT.Debug_Pools is Elem := new Traceback_Htable_Elem' (Traceback => new Tracebacks_Array'(Data.Traceback.all), - Count => Data.Count, - Kind => Data.Kind, - Total => Data.Total, - Next => null); + Count => Data.Count, + Kind => Data.Kind, + Total => Data.Total, + Frees => Data.Frees, + Total_Frees => Data.Total_Frees, + Next => null); Backtrace_Htable_Cumulate.Set (Elem); if Cumulate then @@ -1493,10 +1761,12 @@ package body GNAT.Debug_Pools is Elem := new Traceback_Htable_Elem' (Traceback => new Tracebacks_Array' (Data.Traceback (T .. Data.Traceback'Last)), - Count => Data.Count, - Kind => K, - Total => Data.Total, - Next => null); + Count => Data.Count, + Kind => K, + Total => Data.Total, + Frees => Data.Frees, + Total_Frees => Data.Total_Frees, + Next => null); Backtrace_Htable_Cumulate.Set (Elem); -- Properly take into account that the subprograms @@ -1564,10 +1834,12 @@ package body GNAT.Debug_Pools is Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: "); - for T in Header.Alloc_Traceback.Traceback'Range loop - Put ("0x" & Address_Image - (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' '); - end loop; + if Header.Alloc_Traceback /= null then + for T in Header.Alloc_Traceback.Traceback'Range loop + Put ("0x" & Address_Image + (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' '); + end loop; + end if; Put_Line (""); Current := Header.Next; @@ -1575,6 +1847,204 @@ package body GNAT.Debug_Pools is end if; end Print_Info; + ---------- + -- Dump -- + ---------- + + procedure Dump + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports) is + + Total_Freed : constant Byte_Count := + Pool.Logically_Deallocated + Pool.Physically_Deallocated; + + procedure Do_Report (Sort : Report_Type); + -- Do a specific type of report + + procedure Do_Report (Sort : Report_Type) is + Elem : Traceback_Htable_Elem_Ptr; + Bigger : Boolean; + Grand_Total : Float; + + Max : array (1 .. Size) of Traceback_Htable_Elem_Ptr := + (others => null); + -- Sorted array for the biggest memory users + + begin + New_Line; + case Sort is + when Memory_Usage | All_Reports => + Put_Line (Size'Img & " biggest memory users at this time:"); + Put_Line ("Results include bytes and chunks still allocated"); + Grand_Total := Float (Pool.Current_Water_Mark); + when Allocations_Count => + Put_Line (Size'Img & " biggest number of live allocations:"); + Put_Line ("Results include bytes and chunks still allocated"); + Grand_Total := Float (Pool.Current_Water_Mark); + when Sort_Total_Allocs => + Put_Line (Size'Img & " biggest number of allocations:"); + Put_Line ("Results include total bytes and chunks allocated,"); + Put_Line ("even if no longer allocated - Deallocations are" + & " ignored"); + Grand_Total := Float (Pool.Allocated); + when Marked_Blocks => + Put_Line ("Special blocks marked by Mark_Traceback"); + Grand_Total := 0.0; + end case; + + Elem := Backtrace_Htable.Get_First; + while Elem /= null loop + -- Handle only alloc elememts + if Elem.Kind = Alloc then + -- Ignore small blocks (depending on the sorting criteria) to + -- gain speed. + + if (Sort = Memory_Usage + and then Elem.Total - Elem.Total_Frees >= 1_000) + or else (Sort = Allocations_Count + and then Elem.Count - Elem.Frees >= 1) + or else (Sort = Sort_Total_Allocs and then Elem.Count > 1) + or else (Sort = Marked_Blocks + and then Elem.Total = 0) + then + if Sort = Marked_Blocks then + Grand_Total := Grand_Total + Float (Elem.Count); + end if; + + for M in Max'Range loop + Bigger := Max (M) = null; + if not Bigger then + case Sort is + when Memory_Usage | All_Reports => + Bigger := + Max (M).Total - Max (M).Total_Frees < + Elem.Total - Elem.Total_Frees; + when Allocations_Count => + Bigger := + Max (M).Count - Max (M).Frees + < Elem.Count - Elem.Frees; + when Sort_Total_Allocs | Marked_Blocks => + Bigger := Max (M).Count < Elem.Count; + end case; + end if; + + if Bigger then + Max (M + 1 .. Max'Last) := Max (M .. Max'Last - 1); + Max (M) := Elem; + exit; + end if; + end loop; + end if; + end if; + + Elem := Backtrace_Htable.Get_Next; + end loop; + + if Grand_Total = 0.0 then + Grand_Total := 1.0; + end if; + + for M in Max'Range loop + exit when Max (M) = null; + declare + type Percent is delta 0.1 range 0.0 .. 100.0; + Total : Byte_Count; + P : Percent; + begin + case Sort is + when Memory_Usage | Allocations_Count | All_Reports => + Total := Max (M).Total - Max (M).Total_Frees; + when Sort_Total_Allocs => + Total := Max (M).Total; + when Marked_Blocks => + Total := Byte_Count (Max (M).Count); + end case; + + P := Percent (100.0 * Float (Total) / Grand_Total); + + if Sort = Marked_Blocks then + Put (P'Img & "%:" + & Max (M).Count'Img & " chunks /" + & Integer (Grand_Total)'Img & " at"); + else + Put (P'Img & "%:" & Total'Img & " bytes in" + & Max (M).Count'Img & " chunks at"); + end if; + end; + + for J in Max (M).Traceback'Range loop + Put (" 0x" & Address_Image (PC_For (Max (M).Traceback (J)))); + end loop; + + New_Line; + end loop; + end Do_Report; + + begin + + Put_Line ("Ada Allocs:" & Pool.Allocated'Img + & " bytes in" & Pool.Alloc_Count'Img & " chunks"); + Put_Line ("Ada Free:" & Total_Freed'Img & " bytes in" & + Pool.Free_Count'Img + & " chunks"); + Put_Line ("Ada Current watermark: " + & Byte_Count'Image (Pool.Current_Water_Mark) + & " in" & Byte_Count'Image (Pool.Alloc_Count - + Pool.Free_Count) & " chunks"); + Put_Line ("Ada High watermark: " & Pool.High_Water_Mark'Img); + + case Report is + when All_Reports => + for Sort in Report_Type loop + if Sort /= All_Reports then + Do_Report (Sort); + end if; + end loop; + + when others => + Do_Report (Report); + end case; + + end Dump; + + ----------------- + -- Dump_Stdout -- + ----------------- + + procedure Dump_Stdout + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports) + is + + procedure Internal is new Dump + (Put_Line => Stdout_Put_Line, + Put => Stdout_Put); + + -- Start of processing for Dump_Stdout + + begin + Internal (Pool, Size, Report); + end Dump_Stdout; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + Elem : Traceback_Htable_Elem_Ptr; + begin + Elem := Backtrace_Htable.Get_First; + while Elem /= null loop + Elem.Count := 0; + Elem.Frees := 0; + Elem.Total := 0; + Elem.Total_Frees := 0; + Elem := Backtrace_Htable.Get_Next; + end loop; + end Reset; + ------------------ -- Storage_Size -- ------------------ @@ -1585,6 +2055,38 @@ package body GNAT.Debug_Pools is return Storage_Count'Last; end Storage_Size; + --------------------- + -- High_Water_Mark -- + --------------------- + + function High_Water_Mark + (Pool : Debug_Pool) return Byte_Count is + begin + return Pool.High_Water; + end High_Water_Mark; + + ------------------------ + -- Current_Water_Mark -- + ------------------------ + + function Current_Water_Mark + (Pool : Debug_Pool) return Byte_Count is + begin + return Pool.Allocated - Pool.Logically_Deallocated - + Pool.Physically_Deallocated; + end Current_Water_Mark; + + ------------------------------ + -- System_Memory_Debug_Pool -- + ------------------------------ + + procedure System_Memory_Debug_Pool + (Has_Unhandled_Memory : Boolean := True) is + begin + System_Memory_Debug_Pool_Enabled := True; + Allow_Unhandled_Memory := Has_Unhandled_Memory; + end System_Memory_Debug_Pool; + --------------- -- Configure -- --------------- @@ -1637,16 +2139,16 @@ package body GNAT.Debug_Pools is else Header := Header_Of (Storage); - Put_Line (Standard_Output, "0x" & Address_Image (A) - & " allocated at:"); - Put_Line (Standard_Output, 0, Header.Alloc_Traceback.Traceback); + Print_Address (Standard_Output, A); + Put_Line (Standard_Output, " allocated at:"); + Print_Traceback (Standard_Output, "", Header.Alloc_Traceback); if To_Traceback (Header.Dealloc_Traceback) /= null then - Put_Line (Standard_Output, "0x" & Address_Image (A) - & " logically freed memory, deallocated at:"); - Put_Line - (Standard_Output, 0, - To_Traceback (Header.Dealloc_Traceback).Traceback); + Print_Address (Standard_Output, A); + Put_Line (Standard_Output, + " logically freed memory, deallocated at:"); + Print_Traceback (Standard_Output, "", + To_Traceback (Header.Dealloc_Traceback)); end if; end if; end Print_Pool; @@ -1661,33 +2163,11 @@ package body GNAT.Debug_Pools is Display_Slots : Boolean := False; Display_Leaks : Boolean := False) is - procedure Stdout_Put (S : String); - procedure Stdout_Put_Line (S : String); - -- Wrappers for Put and Put_Line that ensure we always write to stdout - -- instead of the current output file defined in GNAT.IO. procedure Internal is new Print_Info (Put_Line => Stdout_Put_Line, Put => Stdout_Put); - ---------------- - -- Stdout_Put -- - ---------------- - - procedure Stdout_Put (S : String) is - begin - Put_Line (Standard_Output, S); - end Stdout_Put; - - --------------------- - -- Stdout_Put_Line -- - --------------------- - - procedure Stdout_Put_Line (S : String) is - begin - Put_Line (Standard_Output, S); - end Stdout_Put_Line; - -- Start of processing for Print_Info_Stdout begin @@ -1749,30 +2229,34 @@ package body GNAT.Debug_Pools is Actual_Size := size_t (Header.Block_Size); Tracebk := Header.Alloc_Traceback.Traceback; - Num_Calls := Tracebk'Length; - -- (Code taken from memtrack.adb in GNAT's sources) + if Header.Alloc_Traceback /= null then + Num_Calls := Tracebk'Length; - -- Logs allocation call using the format: + -- (Code taken from memtrack.adb in GNAT's sources) - -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn> + -- Logs allocation call using the format: - fputc (Character'Pos ('A'), File); - fwrite (Current'Address, Address_Size, 1, File); - fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1, - File); - fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements, 1, - File); - fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, - File); + -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn> - for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop - declare - Ptr : System.Address := PC_For (Tracebk (J)); - begin - fwrite (Ptr'Address, Address_Size, 1, File); - end; - end loop; + fputc (Character'Pos ('A'), File); + fwrite (Current'Address, Address_Size, 1, File); + fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, + 1, File); + fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements, + 1, File); + fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, + File); + + for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop + declare + Ptr : System.Address := PC_For (Tracebk (J)); + begin + fwrite (Ptr'Address, Address_Size, 1, File); + end; + end loop; + + end if; Current := Header.Next; end loop; @@ -1780,6 +2264,24 @@ package body GNAT.Debug_Pools is fclose (File); end Dump_Gnatmem; + ---------------- + -- Stdout_Put -- + ---------------- + + procedure Stdout_Put (S : String) is + begin + Put (Standard_Output, S); + end Stdout_Put; + + --------------------- + -- Stdout_Put_Line -- + --------------------- + + procedure Stdout_Put_Line (S : String) is + begin + Put_Line (Standard_Output, S); + end Stdout_Put_Line; + -- Package initialization begin diff --git a/gcc/ada/g-debpoo.ads b/gcc/ada/g-debpoo.ads index e87c0e4b18d..108422a3174 100644 --- a/gcc/ada/g-debpoo.ads +++ b/gcc/ada/g-debpoo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -254,6 +254,71 @@ package GNAT.Debug_Pools is -- deallocation of that memory chunk, its current status (allocated or -- logically freed), etc. + type Report_Type is + (All_Reports, + Memory_Usage, + Allocations_Count, + Sort_Total_Allocs, + Marked_Blocks); + for Report_Type use + (All_Reports => 0, + Memory_Usage => 1, + Allocations_Count => 2, + Sort_Total_Allocs => 3, + Marked_Blocks => 4); + + generic + with procedure Put_Line (S : String) is <>; + with procedure Put (S : String) is <>; + procedure Dump + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports); + -- Dump information about memory usage. + -- Size is the number of the biggest memory users we want to show. Report + -- indicates which sorting order is used in the report. + + procedure Dump_Stdout + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports); + -- Standard instantiation of Dump to print on standard_output. More + -- convenient to use where this is the intended location, and in particular + -- easier to use from the debugger. + + procedure Reset; + -- Reset all internal data. This is in general not needed, unless you want + -- to know what memory is used by specific parts of your application + + procedure Get_Size + (Storage_Address : Address; + Size_In_Storage_Elements : out Storage_Count; + Valid : out Boolean); + -- Set Valid if Storage_Address is the address of a chunk of memory + -- currently allocated by any pool. + -- If Valid is True, Size_In_Storage_Elements is set to the size of this + -- chunk of memory. + + type Byte_Count is mod System.Max_Binary_Modulus; + -- Type used for maintaining byte counts, needs to be large enough to + -- to accommodate counts allowing for repeated use of the same memory. + + function High_Water_Mark + (Pool : Debug_Pool) return Byte_Count; + -- Return the highest size of the memory allocated by the pool. + -- Memory used internally by the pool is not taken into account. + + function Current_Water_Mark + (Pool : Debug_Pool) return Byte_Count; + -- Return the size of the memory currently allocated by the pool. + -- Memory used internally by the pool is not taken into account. + + procedure System_Memory_Debug_Pool + (Has_Unhandled_Memory : Boolean := True); + -- Let the package know the System.Memory is using it. + -- If Has_Unhandled_Memory is true, some deallocation can be done for + -- memory not allocated with Allocate. + private -- The following are the standard primitive subprograms for a pool @@ -292,10 +357,6 @@ private -- on the setup of the storage pool. -- The parameters have the same semantics as defined in the ARM95. - type Byte_Count is mod System.Max_Binary_Modulus; - -- Type used for maintaining byte counts, needs to be large enough - -- to accommodate counts allowing for repeated use of the same memory. - type Debug_Pool is new System.Checked_Pools.Checked_Pool with record Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth; Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed; @@ -306,6 +367,12 @@ private Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; Low_Level_Traces : Boolean := Default_Low_Level_Traces; + Alloc_Count : Byte_Count := 0; + -- Total number of allocation + + Free_Count : Byte_Count := 0; + -- Total number of deallocation + Allocated : Byte_Count := 0; -- Total number of bytes allocated in this pool @@ -337,5 +404,6 @@ private -- for the advanced freeing algorithms that needs to traverse all these -- blocks to find possible references to the block being physically -- freed. + end record; end GNAT.Debug_Pools; diff --git a/gcc/ada/g-diopit.adb b/gcc/ada/g-diopit.adb index 3538deb2fff..dabea22616f 100644 --- a/gcc/ada/g-diopit.adb +++ b/gcc/ada/g-diopit.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, AdaCore -- +-- Copyright (C) 2001-2015, AdaCore -- -- -- -- 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- -- @@ -221,8 +221,8 @@ package body GNAT.Directory_Operations.Iteration is then -- Starting with "<drive>:\" - DS := Strings.Fixed.Index - (SP (SP'First + 3 .. SP'Last), Dir_Seps); + DS := Strings.Fixed.Index + (SP (SP'First + 3 .. SP'Last), Dir_Seps); if DS = 0 then diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads index c3c207f2e99..1b04b94615d 100644 --- a/gcc/ada/g-dirope.ads +++ b/gcc/ada/g-dirope.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2014, AdaCore -- +-- Copyright (C) 1998-2015, AdaCore -- -- -- -- 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- -- @@ -248,12 +248,6 @@ private type Dir_Type_Value is new System.Address; -- Low-level address directory structure as returned by opendir in C - -- - -- Note that we used to define this type in the body of this package, - -- but this was causing troubles in the context of .NET code generation - -- (because Taft amendment types are not fully implemented and cause - -- undefined references to the class), so we moved the type declaration - -- to the spec's private part, which is no problem in any case here. type Dir_Type is access Dir_Type_Value; diff --git a/gcc/ada/g-dynhta.adb b/gcc/ada/g-dynhta.adb index 929191d24aa..449ac17dec4 100644 --- a/gcc/ada/g-dynhta.adb +++ b/gcc/ada/g-dynhta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2014, AdaCore -- +-- Copyright (C) 2002-2015, AdaCore -- -- -- -- 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- -- @@ -157,7 +157,7 @@ package body GNAT.Dynamic_HTables is else loop - Next_Elmt := Next (Elmt); + Next_Elmt := Next (Elmt); if Next_Elmt = Null_Ptr then return; diff --git a/gcc/ada/g-dyntab.ads b/gcc/ada/g-dyntab.ads index cfffd2f8947..59d993200aa 100644 --- a/gcc/ada/g-dyntab.ads +++ b/gcc/ada/g-dyntab.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2013, AdaCore -- +-- Copyright (C) 2000-2015, AdaCore -- -- -- -- 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- -- @@ -58,7 +58,7 @@ generic package GNAT.Dynamic_Tables is -- Table_Component_Type and Table_Index_Type specify the type of the - -- array, Table_Low_Bound is the lower bound. Index_type must be an + -- array, Table_Low_Bound is the lower bound. Table_Index_Type must be an -- integer type. The effect is roughly to declare: -- Table : array (Table_Low_Bound .. <>) of Table_Component_Type; diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb index ce2428ddd85..81370117fc0 100644 --- a/gcc/ada/g-pehage.adb +++ b/gcc/ada/g-pehage.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2011, AdaCore -- +-- Copyright (C) 2002-2015, AdaCore -- -- -- -- 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- -- @@ -2586,7 +2586,7 @@ package body GNAT.Perfect_Hash_Generators is when Function_Table_1 => return Get_Table (T1, J, K); - when Function_Table_2 => + when Function_Table_2 => return Get_Table (T2, J, K); when Graph_Table => diff --git a/gcc/ada/g-spipat.ads b/gcc/ada/g-spipat.ads index 27cd8d564e1..fe10fed0f1f 100644 --- a/gcc/ada/g-spipat.ads +++ b/gcc/ada/g-spipat.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2013, AdaCore -- +-- Copyright (C) 1997-2015, AdaCore -- -- -- -- 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- -- @@ -899,7 +899,7 @@ package GNAT.Spitbol.Patterns is function Span (Str : VString_Func) return Pattern; -- Constructs a pattern that matches the longest possible string -- consisting entirely of characters from the given argument. The - -- string cannot be empty , so the pattern fails if the current + -- string cannot be empty, so the pattern fails if the current -- character is not one of the characters in Str. function Succeed return Pattern; diff --git a/gcc/ada/g-table.ads b/gcc/ada/g-table.ads index c9b75f61648..1b4b04c492d 100644 --- a/gcc/ada/g-table.ads +++ b/gcc/ada/g-table.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2013, AdaCore -- +-- Copyright (C) 1998-2015, AdaCore -- -- -- -- 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- -- @@ -57,7 +57,7 @@ package GNAT.Table is pragma Elaborate_Body; -- Table_Component_Type and Table_Index_Type specify the type of the - -- array, Table_Low_Bound is the lower bound. Index_type must be an + -- array, Table_Low_Bound is the lower bound. Table_Index_Type must be an -- integer type. The effect is roughly to declare: -- Table : array (Table_Index_Type range Table_Low_Bound .. <>) diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 77abd2b0b5a..a8ce6722491 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -243,6 +243,7 @@ GNAT_ADA_OBJS = \ ada/casing.o \ ada/checks.o \ ada/comperr.o \ + ada/contracts.o \ ada/csets.o \ ada/cstand.o \ ada/debug.o \ @@ -659,7 +660,7 @@ ada.tags: force # Generate documentation. -doc/gnat_ugn.info: ada/gnat_ugn.texi ada/projects.texi \ +doc/gnat_ugn.info: ada/gnat_ugn.texi \ $(gcc_docdir)/include/fdl.texi $(gcc_docdir)/include/gcc-common.texi \ gcc-vers.texi if [ x$(BUILD_INFO) = xinfo ]; then \ @@ -717,7 +718,7 @@ ada.html: ada.install-html: -doc/gnat_ugn.dvi: ada/gnat_ugn.texi ada/projects.texi \ +doc/gnat_ugn.dvi: ada/gnat_ugn.texi \ $(gcc_docdir)/include/fdl.texi \ $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< @@ -729,7 +730,7 @@ doc/gnat_rm.dvi: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \ doc/gnat-style.dvi: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< -doc/gnat_ugn.pdf: ada/gnat_ugn.texi ada/projects.texi \ +doc/gnat_ugn.pdf: ada/gnat_ugn.texi \ $(gcc_docdir)/include/fdl.texi \ $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi $(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $< @@ -1026,7 +1027,7 @@ ada_generated_files = ada/sinfo.h ada/einfo.h ada/nmake.adb ada/nmake.ads \ # When building from scratch we don't have dependency files, the only thing # we need to ensure is that the generated files are created first. -$(GNAT1_ADA_OBJS) $(GNATBIND_OBJS): | $(ada_generated_files) +$(GNAT1_OBJS) $(GNATBIND_OBJS): | $(ada_generated_files) # Manually include the auto-generated dependencies for the Ada host objects. ADA_DEPFILES = $(foreach obj,$(GNAT1_ADA_OBJS) $(GNATBIND_OBJS),\ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 1d03f865f6c..18ce6d5c244 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -885,8 +885,13 @@ ifeq ($(strip $(filter-out %86 wrs vxworks vxworks7,$(target_cpu) $(target_vendo SVX=system-vxworks7 else SVX=system-vxworks + EH_MECHANISM=-gcc endif + EXTRA_LIBGNAT_OBJS+=sigtramp-vxworks.o sigtramp-vxworks-vxsim.o + EXTRA_LIBGNAT_OBJS+=init-vxsim.o + EXTRA_LIBGNAT_SRCS+=sigtramp.h sigtramp-vxworks-target.inc + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-vxworks.ads \ i-vxwork.ads<i-vxwork-x86.ads \ @@ -923,13 +928,49 @@ ifeq ($(strip $(filter-out %86 wrs vxworks vxworks7,$(target_cpu) $(target_vendo s-tfsetr.adb<s-tfsetr-vxworks.adb endif + # The CPU setting for VxSim varies with the + # host (Windows or Linux) + # target (VxWorks6 or VxWorks7) + # runtime (rtp or kernel) + # ------------------------------------------------------------- + # vx6 vx7 + # Windows (host_os = mingw32) + # kernel SIMNT SIMNT + # rtp SIMPENTIUM SIMNT + # Linux (host_os = linux-gnu) + # kernel SIMLINUX SIMLINUX + # rtp SIMPENTIUM SIMLINUX + # ------------------------------------------------------------- + # It is overridden by VXSIM_CPU only in files init-vxsim.c and + # sigtramp-vxworks-vxsim.c which contain functions determined at + # runtime to be called if a program is running on VxSim vs real hardware + # (due to differences in signal context for unwinding). + + VXSIM_CPU = + + ifeq ($(strip $(filter-out vxworks rtp rtp-smp,$(target_os) $(THREAD_KIND))),) + VXSIM_CPU = SIMPENTIUM + else + ifeq ($(strip $(filter-out kernel kernel-smp rtp rtp-smp,$(THREAD_KIND))),) + ifeq ($(strip $(filter-out linux%,$(host_os))),) + # Linux + VXSIM_CPU = SIMLINUX + else + # Windows + VXSIM_CPU = SIMNT + endif + endif + endif + + GNATLIBCFLAGS_FOR_C := $(GNATLIBCFLAGS_FOR_C) -D__VXSIM_CPU__=$(VXSIM_CPU) + ifeq ($(strip $(filter-out rtp,$(THREAD_KIND))),) + # Runtime N/A for VxWorks7 (non-existent system file) LIBGNAT_TARGET_PAIRS += \ s-vxwext.ads<s-vxwext-rtp.ads \ s-vxwext.adb<s-vxwext-rtp.adb \ s-tpopsp.adb<s-tpopsp-vxworks-rtp.adb \ - system.ads<system-vxworks-x86-rtp.ads - + system.ads<$(SVX)-x86-rtp.ads else ifeq ($(strip $(filter-out rtp-smp, $(THREAD_KIND))),) LIBGNAT_TARGET_PAIRS += \ @@ -949,6 +990,7 @@ ifeq ($(strip $(filter-out %86 wrs vxworks vxworks7,$(target_cpu) $(target_vendo s-vxwext.ads<s-vxwext-kernel.ads \ s-vxwext.adb<s-vxwext-kernel-smp.adb \ system.ads<$(SVX)-x86-kernel.ads + EXTRA_LIBGNAT_OBJS+=affinity.o else LIBGNAT_TARGET_PAIRS += \ @@ -956,10 +998,11 @@ ifeq ($(strip $(filter-out %86 wrs vxworks vxworks7,$(target_cpu) $(target_vendo s-tpopsp.adb<s-tpopsp-vxworks.adb ifeq ($(strip $(filter-out kernel,$(THREAD_KIND))),) + # Runtime N/A for VxWorks7 (non-existent system file) LIBGNAT_TARGET_PAIRS += \ s-vxwext.ads<s-vxwext-kernel.ads \ s-vxwext.adb<s-vxwext-kernel.adb \ - system.ads<system-vxworks-x86-kernel.ads + system.ads<$(SVX)-x86-kernel.ads else LIBGNAT_TARGET_PAIRS += \ system.ads<system-vxworks-x86.ads @@ -974,6 +1017,7 @@ ifeq ($(strip $(filter-out %86 wrs vxworks vxworks7,$(target_cpu) $(target_vendo EXTRA_LIBGNAT_OBJS+=vx_stack_info.o ifneq ($(strip $(filter-out vxworks7%, $(target_os))),) + GCC_SPEC_FILES+=vxworks-crtbe-link.spec GCC_SPEC_FILES+=vxworks-x86-link.spec GCC_SPEC_FILES+=vxworks-cert-x86-link.spec GCC_SPEC_FILES+=vxworks-smp-x86-link.spec @@ -2381,6 +2425,17 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),) system.ads<system-darwin-arm.ads endif + ifeq ($(strip $(filter-out arm64 aarch64,$(target_cpu))),) + LIBGNAT_TARGET_PAIRS += \ + s-intman.adb<s-intman-susv3.adb \ + s-osprim.adb<s-osprim-darwin.adb \ + $(ATOMICS_TARGET_PAIRS) \ + $(ATOMICS_BUILTINS_TARGET_PAIRS) + + LIBGNAT_TARGET_PAIRS += \ + system.ads<system-darwin-arm64.ads + endif + TOOLS_TARGET_PAIRS = \ mlib-tgt-specific.adb<mlib-tgt-specific-darwin.adb \ indepsw.adb<indepsw-darwin.adb @@ -2413,6 +2468,14 @@ ifeq ($(filter a-except%,$(LIBGNAT_TARGET_PAIRS)),) a-except.adb<a-except-2005.adb endif +# Configuration of host tools + +# Under linux, host tools need to be linked with -ldl + +ifeq ($(strip $(filter-out linux%,$(host_os))),) + TOOLS1_LIBS=-ldl +endif + # LIBGNAT_SRCS is the list of all C files (including headers) of the runtime # library. LIBGNAT_OBJS is the list of object files for libgnat. # thread.c is special as put into GNATRTL_TASKING_OBJS by Makefile.rtl @@ -2618,10 +2681,10 @@ gnatlink-re: ../stamp-tools gnatmake-re # Likewise for the tools ../../gnatmake$(exeext): $(P) b_gnatm.o $(GNATMAKE_OBJS) - +$(GCC_LINK) $(ALL_CFLAGS) -o $@ b_gnatm.o $(GNATMAKE_OBJS) $(TOOLS_LIBS) + +$(GCC_LINK) $(ALL_CFLAGS) -o $@ b_gnatm.o $(GNATMAKE_OBJS) $(TOOLS_LIBS) $(TOOLS1_LIBS) ../../gnatlink$(exeext): $(P) b_gnatl.o $(GNATLINK_OBJS) - +$(GCC_LINK) $(ALL_CFLAGS) -o $@ b_gnatl.o $(GNATLINK_OBJS) $(TOOLS_LIBS) + +$(GCC_LINK) $(ALL_CFLAGS) -o $@ b_gnatl.o $(GNATLINK_OBJS) $(TOOLS_LIBS) $(TOOLS1_LIBS) ../stamp-gnatlib-$(RTSDIR): @if [ ! -f stamp-gnatlib-$(RTSDIR) ] ; \ @@ -3071,8 +3134,9 @@ mkdir.o : mkdir.c socket.o : socket.c gsocket.h sysdep.o : sysdep.c raise.o : raise.c raise.h -sigtramp-armdroid.o : sigtramp-armdroid.c sigtramp.h -sigtramp-vxworks.o : sigtramp-vxworks.c sigtramp.h +sigtramp-armdroid.o : sigtramp-armdroid.c sigtramp.h +sigtramp-vxworks.o : sigtramp-vxworks.c sigtramp.h sigtramp-vxworks-target.inc +sigtramp-vxworks-vxsim.o : sigtramp-vxworks-vxsim.c sigtramp.h sigtramp-vxworks-target.inc terminals.o : terminals.c vx_stack_info.o : vx_stack_info.c @@ -3089,6 +3153,10 @@ init.o : init.c adaint.h raise.h $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) +init-vxsim.o : init-vxsim.c + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ + $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) + initialize.o : initialize.c raise.h $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index ca36ce5180a..3922bb80cb3 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -2710,10 +2710,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1; -#ifdef ENABLE_CHECKING /* Check for other cases of overloading. */ - gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner)); -#endif + gcc_checking_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner)); } for (gnat_index = First_Index (gnat_entity); diff --git a/gcc/ada/gcc-interface/lang.opt b/gcc/ada/gcc-interface/lang.opt index 6c260c01024..302806c7b6b 100644 --- a/gcc/ada/gcc-interface/lang.opt +++ b/gcc/ada/gcc-interface/lang.opt @@ -54,11 +54,11 @@ Ada AdaWhy AdaSCIL Joined Separate Wall Ada AdaWhy AdaSCIL -Enable most warning messages +Enable most warning messages. k8 Driver -Synonym of -gnatk8 +Synonym of -gnatk8. nostdinc Ada AdaWhy AdaSCIL RejectNegative @@ -66,30 +66,30 @@ Ada AdaWhy AdaSCIL RejectNegative nostdlib Ada AdaWhy AdaSCIL -Do not look for object files in standard path +Do not look for object files in standard path. fRTS= Ada AdaWhy AdaSCIL Joined RejectNegative -Select the runtime +Select the runtime. fshort-enums Ada AdaWhy AdaSCIL -Use the narrowest integer type possible for enumeration types +Use the narrowest integer type possible for enumeration types. gant Ada AdaWhy AdaSCIL Joined Undocumented -Catch typos +Catch typos. gnatO Ada AdaWhy AdaSCIL Separate -Set name of output ALI file (internal switch) +Set name of output ALI file (internal switch). gnat Ada AdaWhy AdaSCIL Joined --gnat<options> Specify options to GNAT +-gnat<options> Specify options to GNAT. fbuiltin-printf Ada Undocumented -Ignored +Ignored. ; This comment is to ensure we retain the blank line above. diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 3252ea2732e..ac190bece98 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -8999,8 +8999,8 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, if (INTEGRAL_TYPE_P (gnu_in_basetype) ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb) : (FLOAT_TYPE_P (gnu_base_type) - ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb), - TREE_REAL_CST (gnu_out_lb)) + ? real_less (&TREE_REAL_CST (gnu_in_lb), + &TREE_REAL_CST (gnu_out_lb)) : 1)) gnu_cond = invert_truthvalue @@ -9011,8 +9011,8 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, if (INTEGRAL_TYPE_P (gnu_in_basetype) ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub) : (FLOAT_TYPE_P (gnu_base_type) - ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub), - TREE_REAL_CST (gnu_in_lb)) + ? real_less (&TREE_REAL_CST (gnu_out_ub), + &TREE_REAL_CST (gnu_in_lb)) : 1)) gnu_cond = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond, @@ -9048,8 +9048,8 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, /* Compute the exact value calc_type'Pred (0.5) at compile time. */ fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type)); real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type)); - REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf, - half_minus_pred_half); + real_arithmetic (&pred_half, MINUS_EXPR, &dconsthalf, + &half_minus_pred_half); gnu_pred_half = build_real (calc_type, pred_half); /* If the input is strictly negative, subtract this value @@ -9411,11 +9411,12 @@ assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type) gnu_result = extract_values (gnu_list, gnu_type); -#ifdef ENABLE_CHECKING - /* Verify that every entry in GNU_LIST was used. */ - for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list)) - gcc_assert (TREE_ADDRESSABLE (gnu_list)); -#endif + if (flag_checking) + { + /* Verify that every entry in GNU_LIST was used. */ + for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list)) + gcc_assert (TREE_ADDRESSABLE (gnu_list)); + } return gnu_result; } diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 0f3087d3dbf..f270713748f 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -1499,9 +1499,7 @@ relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op) /* The alias set shouldn't be copied between array types with different aliasing settings because this can break the aliasing relationship between the array type and its element type. */ -#ifndef ENABLE_CHECKING - if (flag_strict_aliasing) -#endif + if (flag_checking || flag_strict_aliasing) gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE && TREE_CODE (gnu_old_type) == ARRAY_TYPE && TYPE_NONALIASED_COMPONENT (gnu_new_type) @@ -5369,6 +5367,12 @@ enum c_builtin_type ARG6, ARG7) NAME, #define DEF_FUNCTION_TYPE_8(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ ARG6, ARG7, ARG8) NAME, +#define DEF_FUNCTION_TYPE_9(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7, ARG8, ARG9) NAME, +#define DEF_FUNCTION_TYPE_10(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7, ARG8, ARG9, ARG10) NAME, +#define DEF_FUNCTION_TYPE_11(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7, ARG8, ARG9, ARG10, ARG11) NAME, #define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME, #define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME, #define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME, @@ -5392,6 +5396,9 @@ enum c_builtin_type #undef DEF_FUNCTION_TYPE_6 #undef DEF_FUNCTION_TYPE_7 #undef DEF_FUNCTION_TYPE_8 +#undef DEF_FUNCTION_TYPE_9 +#undef DEF_FUNCTION_TYPE_10 +#undef DEF_FUNCTION_TYPE_11 #undef DEF_FUNCTION_TYPE_VAR_0 #undef DEF_FUNCTION_TYPE_VAR_1 #undef DEF_FUNCTION_TYPE_VAR_2 @@ -5493,6 +5500,18 @@ install_builtin_function_types (void) ARG6, ARG7, ARG8) \ def_fn_type (ENUM, RETURN, 0, 8, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \ ARG7, ARG8); +#define DEF_FUNCTION_TYPE_9(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7, ARG8, ARG9) \ + def_fn_type (ENUM, RETURN, 0, 9, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \ + ARG7, ARG8, ARG9); +#define DEF_FUNCTION_TYPE_10(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5,\ + ARG6, ARG7, ARG8, ARG9, ARG10) \ + def_fn_type (ENUM, RETURN, 0, 10, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \ + ARG7, ARG8, ARG9, ARG10); +#define DEF_FUNCTION_TYPE_11(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5,\ + ARG6, ARG7, ARG8, ARG9, ARG10, ARG11) \ + def_fn_type (ENUM, RETURN, 0, 11, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \ + ARG7, ARG8, ARG9, ARG10, ARG11); #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ def_fn_type (ENUM, RETURN, 1, 0); #define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \ @@ -5526,6 +5545,9 @@ install_builtin_function_types (void) #undef DEF_FUNCTION_TYPE_6 #undef DEF_FUNCTION_TYPE_7 #undef DEF_FUNCTION_TYPE_8 +#undef DEF_FUNCTION_TYPE_9 +#undef DEF_FUNCTION_TYPE_10 +#undef DEF_FUNCTION_TYPE_11 #undef DEF_FUNCTION_TYPE_VAR_0 #undef DEF_FUNCTION_TYPE_VAR_1 #undef DEF_FUNCTION_TYPE_VAR_2 diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 70737a9990b..47446ba8969 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -854,9 +854,8 @@ build_binary_op (enum tree_code op_code, tree result_type, { case INIT_EXPR: case MODIFY_EXPR: -#ifdef ENABLE_CHECKING - gcc_assert (result_type == NULL_TREE); -#endif + gcc_checking_assert (result_type == NULL_TREE); + /* If there were integral or pointer conversions on the LHS, remove them; we'll be putting them back below if needed. Likewise for conversions between array and record types, except for justified @@ -1039,9 +1038,8 @@ build_binary_op (enum tree_code op_code, tree result_type, case TRUTH_AND_EXPR: case TRUTH_OR_EXPR: case TRUTH_XOR_EXPR: -#ifdef ENABLE_CHECKING - gcc_assert (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE); -#endif + gcc_checking_assert + (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE); operation_type = left_base_type; left_operand = convert (operation_type, left_operand); right_operand = convert (operation_type, right_operand); @@ -1053,9 +1051,8 @@ build_binary_op (enum tree_code op_code, tree result_type, case LT_EXPR: case EQ_EXPR: case NE_EXPR: -#ifdef ENABLE_CHECKING - gcc_assert (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE); -#endif + gcc_checking_assert + (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE); /* If either operand is a NULL_EXPR, just return a new one. */ if (TREE_CODE (left_operand) == NULL_EXPR) return build2 (op_code, result_type, @@ -1335,9 +1332,8 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) break; case TRUTH_NOT_EXPR: -#ifdef ENABLE_CHECKING - gcc_assert (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE); -#endif + gcc_checking_assert + (TREE_CODE (get_base_type (result_type)) == BOOLEAN_TYPE); result = invert_truthvalue_loc (EXPR_LOCATION (operand), operand); /* When not optimizing, fold the result as invert_truthvalue_loc doesn't fold the result of comparisons. This is intended to undo @@ -2333,8 +2329,13 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type, /* Check that we aren't violating the associated restriction. */ if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node))) - Check_No_Implicit_Heap_Alloc (gnat_node); - + { + Check_No_Implicit_Heap_Alloc (gnat_node); + if (Has_Task (Etype (gnat_node))) + Check_No_Implicit_Task_Alloc (gnat_node); + if (Has_Protected (Etype (gnat_node))) + Check_No_Implicit_Protected_Alloc (gnat_node); + } return maybe_wrap_malloc (gnu_size, gnu_type, gnat_node); } } diff --git a/gcc/ada/get_spark_xrefs.adb b/gcc/ada/get_spark_xrefs.adb index ea1f1b45a0b..e0b58ce35dd 100644 --- a/gcc/ada/get_spark_xrefs.adb +++ b/gcc/ada/get_spark_xrefs.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -293,9 +293,6 @@ begin Col := Get_Nat; pragma Assert (Scope = Cur_Scope); - pragma Assert (Typ = 'K' - or else Typ = 'V' - or else Typ = 'U'); -- Scan out scope entity name diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 05295a0e3c3..f2ac16b5421 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -67,6 +67,12 @@ package body Ghost is -- Subsidiary to Check_Ghost_Context and Set_Ghost_Mode. Find the entity of -- a reference to a Ghost entity. Return Empty if there is no such entity. + function Is_Subject_To_Ghost (N : Node_Id) return Boolean; + -- Subsidiary to routines Is_OK_xxx and Set_Ghost_Mode. Determine whether + -- declaration or body N is subject to aspect or pragma Ghost. Use this + -- routine in cases where [source] pragma Ghost has not been analyzed yet, + -- but the context needs to establish the "ghostness" of N. + procedure Propagate_Ignored_Ghost_Code (N : Node_Id); -- Subsidiary to routines Mark_xxx_As_Ghost and Set_Ghost_Mode_From_xxx. -- Signal all enclosing scopes that they now contain ignored Ghost code. @@ -223,11 +229,6 @@ package body Ghost is elsif Is_Subject_To_Ghost (Decl) then return True; - - -- The declaration appears within an assertion expression - - elsif In_Assertion_Expr > 0 then - return True; end if; -- Special cases @@ -332,13 +333,13 @@ package body Ghost is if Is_Ghost_Pragma (Prag) then return True; - -- An assertion expression is a Ghost pragma when it contains a + -- An assertion expression pragma is Ghost when it contains a -- reference to a Ghost entity (SPARK RM 6.9(11)). elsif Assertion_Expression_Pragma (Prag_Id) then -- Predicates are excluded from this category when they do - -- not apply to a Ghost subtype (SPARK RM 6.9(12)). + -- not apply to a Ghost subtype (SPARK RM 6.9(11)). if Nam_In (Prag_Nam, Name_Dynamic_Predicate, Name_Predicate, @@ -408,7 +409,9 @@ package body Ghost is -- Special cases -- An if statement is a suitable context for a Ghost entity if it - -- is the byproduct of assertion expression expansion. + -- is the byproduct of assertion expression expansion. Note that + -- the assertion expression may not be related to a Ghost entity, + -- but it may still contain references to Ghost entities. elsif Nkind (Stmt) = N_If_Statement and then Nkind (Original_Node (Stmt)) = N_Pragma @@ -469,13 +472,26 @@ package body Ghost is -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then - return False; + exit; end if; Par := Parent (Par); end loop; - return False; + -- The expansion of assertion expression pragmas and attribute Old + -- may cause a legal Ghost entity reference to become illegal due + -- to node relocation. Check the In_Assertion_Expr counter as last + -- resort to try and infer the original legal context. + + if In_Assertion_Expr > 0 then + return True; + + -- Otherwise the context is not suitable for a reference to a + -- Ghost entity. + + else + return False; + end if; end if; end Is_OK_Ghost_Context; @@ -517,12 +533,10 @@ package body Ghost is Check_Ghost_Policy (Ghost_Id, Ghost_Ref); -- Otherwise the Ghost entity appears in a non-Ghost context and affects - -- its behavior or value. + -- its behavior or value (SPARK RM 6.9(11,12)). else - Error_Msg_N - ("ghost entity cannot appear in this context (SPARK RM 6.9(11))", - Ghost_Ref); + Error_Msg_N ("ghost entity cannot appear in this context", Ghost_Ref); end if; end Check_Ghost_Context; @@ -576,32 +590,32 @@ package body Ghost is (Subp : Entity_Id; Overridden_Subp : Entity_Id) is - Par_Subp : Entity_Id; + Over_Subp : Entity_Id; begin if Present (Subp) and then Present (Overridden_Subp) then - Par_Subp := Ultimate_Alias (Overridden_Subp); + Over_Subp := Ultimate_Alias (Overridden_Subp); -- The Ghost policy in effect at the point of declaration of a parent -- and an overriding subprogram must match (SPARK RM 6.9(17)). - if Is_Checked_Ghost_Entity (Par_Subp) + if Is_Checked_Ghost_Entity (Over_Subp) and then Is_Ignored_Ghost_Entity (Subp) then Error_Msg_N ("incompatible ghost policies in effect", Subp); - Error_Msg_Sloc := Sloc (Par_Subp); + Error_Msg_Sloc := Sloc (Over_Subp); Error_Msg_N ("\& declared # with ghost policy `Check`", Subp); Error_Msg_Sloc := Sloc (Subp); Error_Msg_N ("\overridden # with ghost policy `Ignore`", Subp); - elsif Is_Ignored_Ghost_Entity (Par_Subp) + elsif Is_Ignored_Ghost_Entity (Over_Subp) and then Is_Checked_Ghost_Entity (Subp) then Error_Msg_N ("incompatible ghost policies in effect", Subp); - Error_Msg_Sloc := Sloc (Par_Subp); + Error_Msg_Sloc := Sloc (Over_Subp); Error_Msg_N ("\& declared # with ghost policy `Ignore`", Subp); Error_Msg_Sloc := Sloc (Subp); @@ -670,15 +684,6 @@ package body Ghost is Ignored_Ghost_Units.Init; end Initialize; - --------------------- - -- Is_Ghost_Entity -- - --------------------- - - function Is_Ghost_Entity (Id : Entity_Id) return Boolean is - begin - return Is_Checked_Ghost_Entity (Id) or else Is_Ignored_Ghost_Entity (Id); - end Is_Ghost_Entity; - ------------------------- -- Is_Subject_To_Ghost -- ------------------------- @@ -701,8 +706,8 @@ package body Ghost is Expr := Get_Pragma_Arg (Expr); end if; - -- Determine whether the expression of the aspect is static and - -- denotes True. + -- Determine whether the expression of the aspect or pragma is static + -- and denotes True. if Present (Expr) then Preanalyze_And_Resolve (Expr); @@ -796,9 +801,10 @@ package body Ghost is Enables_Ghostness (First (Pragma_Argument_Associations (Decl))); -- A source construct ends the region where pragma Ghost may appear, - -- stop the traversal. + -- stop the traversal. Check the original node as source constructs + -- may be rewritten into something else by expansion. - elsif Comes_From_Source (Decl) then + elsif Comes_From_Source (Original_Node (Decl)) then exit; end if; diff --git a/gcc/ada/ghost.ads b/gcc/ada/ghost.ads index c267e70e0fc..3dbe5026aea 100644 --- a/gcc/ada/ghost.ads +++ b/gcc/ada/ghost.ads @@ -62,16 +62,6 @@ package Ghost is procedure Initialize; -- Initialize internal tables - function Is_Ghost_Entity (Id : Entity_Id) return Boolean; - -- Determine whether entity Id is Ghost. To qualify as such, the entity - -- must be subject to pragma Ghost. - - function Is_Subject_To_Ghost (N : Node_Id) return Boolean; - -- Determine whether declarative node N is subject to aspect or pragma - -- Ghost. Use this routine in cases where [source] pragma Ghost has not - -- been analyzed yet, but the context needs to establish the "ghostness" - -- of N. - procedure Lock; -- Lock internal tables before calling backend diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 662065ed0ee..586844d3a72 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -136,17 +136,24 @@ procedure Gnat1drv is Unnest_Subprogram_Mode := True; end if; - -- -gnatd.V or -gnatd.u enables special C expansion mode + -- -gnatd.u enables special C expansion mode - if Debug_Flag_Dot_VV or Debug_Flag_Dot_U then + if Debug_Flag_Dot_U then Modify_Tree_For_C := True; end if; - -- Other flags set if we are generating C code + -- Set all flags required when generating C code (-gnatd.V) if Debug_Flag_Dot_VV then Generate_C_Code := True; + Modify_Tree_For_C := True; Unnest_Subprogram_Mode := True; + Back_Annotate_Rep_Info := True; + + -- Set operating mode to Generate_Code to benefit from full front-end + -- expansion (e.g. generics). + + Operating_Mode := Generate_Code; end if; -- -gnatd.E sets Error_To_Warning mode, causing selected error messages @@ -229,6 +236,7 @@ procedure Gnat1drv is -- user specified Restrictions pragmas are ignored, see -- Sem_Prag.Process_Restrictions_Or_Restriction_Warnings. + Restrict.Restrictions.Set (No_Exception_Registration) := True; Restrict.Restrictions.Set (No_Initialize_Scalars) := True; Restrict.Restrictions.Set (No_Task_Hierarchy) := True; Restrict.Restrictions.Set (No_Abort_Statements) := True; @@ -378,10 +386,7 @@ procedure Gnat1drv is Optimization_Level := 0; -- Enable some restrictions systematically to simplify the generated - -- code (and ease analysis). Note that restriction checks are also - -- disabled in SPARK mode, see Restrict.Check_Restriction, and user - -- specified Restrictions pragmas are ignored, see - -- Sem_Prag.Process_Restrictions_Or_Restriction_Warnings. + -- code (and ease analysis). Restrict.Restrictions.Set (No_Initialize_Scalars) := True; @@ -599,10 +604,9 @@ procedure Gnat1drv is if Debug_Flag_Dot_LL then Back_End_Handles_Limited_Types := True; - -- If no debug flag, usage off for AAMP, VM, SCIL cases + -- If no debug flag, usage off for AAMP, SCIL cases elsif AAMP_On_Target - or else VM_Target /= No_VM or else Generate_SCIL then Back_End_Handles_Limited_Types := False; @@ -633,20 +637,20 @@ procedure Gnat1drv is -- back end some day, it would not be true for this test, but it -- would be non-GCC, so this is a bit troublesome ??? - Front_End_Inlining := VM_Target /= No_VM or else AAMP_On_Target; + Front_End_Inlining := AAMP_On_Target or Generate_C_Code; end if; -- Set back end inlining indication Back_End_Inlining := - -- No back end inlining available for VM targets + -- No back end inlining available on AAMP - VM_Target = No_VM + not AAMP_On_Target - -- No back end inlining available on AAMP + -- No back end inlining available on C generation - and then not AAMP_On_Target + and then not Generate_C_Code -- No back end inlining in GNATprove mode, since it just confuses -- the formal verification process. @@ -868,7 +872,7 @@ procedure Gnat1drv is -- back end for component layout where possible) but only for non-GCC -- back ends, as this is done a priori for GCC back ends. - if VM_Target /= No_VM or else AAMP_On_Target then + if AAMP_On_Target then Sem_Ch13.Validate_Independence; end if; @@ -1021,7 +1025,7 @@ begin Original_Operating_Mode := Operating_Mode; Frontend; - -- Exit with errors if the main source could not be parsed. + -- Exit with errors if the main source could not be parsed if Sinput.Main_Source_File = No_Source_File then Errout.Finalize (Last_Call => True); @@ -1165,8 +1169,9 @@ begin -- It is not an error to analyze in CodePeer mode a spec which requires -- a body, in order to generate SCIL for this spec. + -- Ditto for Generate_C_Code mode and generate a C header for a spec. - elsif CodePeer_Mode then + elsif CodePeer_Mode or Generate_C_Code then Back_End_Mode := Generate_Object; -- It is not an error to analyze in GNATprove mode a spec which requires @@ -1273,15 +1278,11 @@ begin -- Annotation is suppressed for targets where front-end layout is -- enabled, because the front end determines representations. - -- Annotation is also suppressed in the case of compiling for a VM, - -- since representations are largely symbolic there. - if Back_End_Mode = Declarations_Only and then (not (Back_Annotate_Rep_Info or Generate_SCIL or GNATprove_Mode) or else Main_Kind = N_Subunit - or else Frontend_Layout_On_Target - or else VM_Target /= No_VM) + or else Frontend_Layout_On_Target) then Post_Compilation_Validation_Checks; Errout.Finalize (Last_Call => True); @@ -1430,6 +1431,12 @@ begin -- say Storage_Error, giving a strong hint. Comperr.Compiler_Abort ("Storage_Error"); + + when Unrecoverable_Error => + raise; + + when others => + Comperr.Compiler_Abort ("exception"); end; <<End_Of_Program>> diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 281cb382bd7..d3eb6a90c57 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , May 12, 2015 +GNAT Reference Manual , October 23, 2015 AdaCore @@ -118,7 +118,6 @@ Implementation Defined Pragmas * Pragma Check_Float_Overflow:: * Pragma Check_Name:: * Pragma Check_Policy:: -* Pragma CIL_Constructor:: * Pragma Comment:: * Pragma Common_Object:: * Pragma Compile_Time_Error:: @@ -128,6 +127,7 @@ Implementation Defined Pragmas * Pragma Complete_Representation:: * Pragma Complex_Representation:: * Pragma Component_Alignment:: +* Pragma Constant_After_Elaboration:: * Pragma Contract_Cases:: * Pragma Convention_Identifier:: * Pragma CPP_Class:: @@ -135,6 +135,7 @@ Implementation Defined Pragmas * Pragma CPP_Virtual:: * Pragma CPP_Vtable:: * Pragma CPU:: +* Pragma Default_Initial_Condition:: * Pragma Debug:: * Pragma Debug_Policy:: * Pragma Default_Scalar_Storage_Order:: @@ -155,12 +156,14 @@ Implementation Defined Pragmas * Pragma Export_Valued_Procedure:: * Pragma Extend_System:: * Pragma Extensions_Allowed:: +* Pragma Extensions_Visible:: * Pragma External:: * Pragma External_Name_Casing:: * Pragma Fast_Math:: * Pragma Favor_Top_Level:: * Pragma Finalize_Storage_Only:: * Pragma Float_Representation:: +* Pragma Ghost:: * Pragma Global:: * Pragma Ident:: * Pragma Ignore_Pragma:: @@ -183,8 +186,6 @@ Implementation Defined Pragmas * Pragma Interrupt_Handler:: * Pragma Interrupt_State:: * Pragma Invariant:: -* Pragma Java_Constructor:: -* Pragma Java_Interface:: * Pragma Keep_Names:: * Pragma License:: * Pragma Link_With:: @@ -284,6 +285,7 @@ Implementation Defined Pragmas * Pragma Validity_Checks:: * Pragma Volatile:: * Pragma Volatile_Full_Access:: +* Pragma Volatile_Function:: * Pragma Warning_As_Error:: * Pragma Warnings:: * Pragma Weak_External:: @@ -295,14 +297,18 @@ Implementation Defined Aspects * Annotate:: * Aspect Async_Readers:: * Aspect Async_Writers:: +* Aspect Constant_After_Elaboration:: * Aspect Contract_Cases:: * Aspect Depends:: +* Aspect Default_Initial_Condition:: * Aspect Dimension:: * Aspect Dimension_System:: * Aspect Disable_Controlled:: * Aspect Effective_Reads:: * Aspect Effective_Writes:: +* Aspect Extensions_Visible:: * Aspect Favor_Top_Level:: +* Aspect Ghost:: * Aspect Global:: * Aspect Initial_Condition:: * Aspect Initializes:: @@ -341,6 +347,7 @@ Implementation Defined Aspects * Aspect Unreferenced_Objects:: * Aspect Value_Size:: * Aspect Volatile_Full_Access:: +* Aspect Volatile_Function:: * Aspect Warnings:: Implementation Defined Attributes @@ -408,7 +415,6 @@ Implementation Defined Attributes * Attribute Type_Class:: * Attribute Type_Key:: * Attribute TypeCode:: -* Attribute UET_Address:: * Attribute Unconstrained_Array:: * Attribute Universal_Literal_String:: * Attribute Unrestricted_Access:: @@ -439,6 +445,7 @@ Partition-Wide Restrictions * No_Access_Subprograms:: * No_Allocators:: * No_Anonymous_Allocators:: +* No_Asynchronous_Control:: * No_Calendar:: * No_Coextensions:: * No_Default_Initialization:: @@ -462,6 +469,8 @@ Partition-Wide Restrictions * No_Implicit_Dynamic_Code:: * No_Implicit_Heap_Allocations:: * No_Implicit_Loops:: +* No_Implicit_Protected_Object_Allocations:: +* No_Implicit_Task_Allocations:: * No_Initialize_Scalars:: * No_IO:: * No_Local_Allocators:: @@ -485,12 +494,15 @@ Partition-Wide Restrictions * No_Stream_Optimizations:: * No_Streams:: * No_Task_Allocators:: +* No_Task_At_Interrupt_Priority:: * No_Task_Attributes_Package:: * No_Task_Hierarchy:: * No_Task_Termination:: * No_Tasking:: * No_Terminate_Alternatives:: * No_Unchecked_Access:: +* No_Unchecked_Conversion:: +* No_Unchecked_Deallocation:: * No_Use_Of_Entity:: * Simple_Barriers:: * Static_Priorities:: @@ -693,6 +705,7 @@ The GNAT Library * GNAT.Altivec.Vector_Views (g-alvevi.ads): GNAT Altivec Vector_Views g-alvevi ads. * GNAT.Array_Split (g-arrspl.ads): GNAT Array_Split g-arrspl ads. * GNAT.AWK (g-awk.ads): GNAT AWK g-awk ads. +* GNAT.Bind_Environment (g-binenv.ads): GNAT Bind_Environment g-binenv ads. * GNAT.Bounded_Buffers (g-boubuf.ads): GNAT Bounded_Buffers g-boubuf ads. * GNAT.Bounded_Mailboxes (g-boumai.ads): GNAT Bounded_Mailboxes g-boumai ads. * GNAT.Bubble_Sort (g-bubsor.ads): GNAT Bubble_Sort g-bubsor ads. @@ -829,7 +842,7 @@ Code Generation for Array Aggregates * Static constant aggregates with static bounds:: * Constant aggregates with unconstrained nominal types:: * Aggregates with static bounds:: -* Aggregates with non-static bounds:: +* Aggregates with nonstatic bounds:: * Aggregates in assignment statements:: Obsolescent Features @@ -894,7 +907,8 @@ different compilers on different platforms. However, since Ada is designed to be used in a wide variety of applications, it also contains a number of system dependent features to be used in interfacing to the external world. -.. index:: Implementation-dependent features + +@geindex Implementation-dependent features @geindex Portability @@ -1152,7 +1166,6 @@ consideration, the use of these pragmas should be minimized. * Pragma Check_Float_Overflow:: * Pragma Check_Name:: * Pragma Check_Policy:: -* Pragma CIL_Constructor:: * Pragma Comment:: * Pragma Common_Object:: * Pragma Compile_Time_Error:: @@ -1162,6 +1175,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Complete_Representation:: * Pragma Complex_Representation:: * Pragma Component_Alignment:: +* Pragma Constant_After_Elaboration:: * Pragma Contract_Cases:: * Pragma Convention_Identifier:: * Pragma CPP_Class:: @@ -1169,6 +1183,7 @@ consideration, the use of these pragmas should be minimized. * Pragma CPP_Virtual:: * Pragma CPP_Vtable:: * Pragma CPU:: +* Pragma Default_Initial_Condition:: * Pragma Debug:: * Pragma Debug_Policy:: * Pragma Default_Scalar_Storage_Order:: @@ -1189,12 +1204,14 @@ consideration, the use of these pragmas should be minimized. * Pragma Export_Valued_Procedure:: * Pragma Extend_System:: * Pragma Extensions_Allowed:: +* Pragma Extensions_Visible:: * Pragma External:: * Pragma External_Name_Casing:: * Pragma Fast_Math:: * Pragma Favor_Top_Level:: * Pragma Finalize_Storage_Only:: * Pragma Float_Representation:: +* Pragma Ghost:: * Pragma Global:: * Pragma Ident:: * Pragma Ignore_Pragma:: @@ -1217,8 +1234,6 @@ consideration, the use of these pragmas should be minimized. * Pragma Interrupt_Handler:: * Pragma Interrupt_State:: * Pragma Invariant:: -* Pragma Java_Constructor:: -* Pragma Java_Interface:: * Pragma Keep_Names:: * Pragma License:: * Pragma Link_With:: @@ -1318,6 +1333,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Validity_Checks:: * Pragma Volatile:: * Pragma Volatile_Full_Access:: +* Pragma Volatile_Function:: * Pragma Warning_As_Error:: * Pragma Warnings:: * Pragma Weak_External:: @@ -2060,7 +2076,7 @@ are mentioned in @cite{with} clauses). Check names introduced by this pragma are subject to control by compiler switches (in particular -gnatp) in the usual manner. -@node Pragma Check_Policy,Pragma CIL_Constructor,Pragma Check_Name,Implementation Defined Pragmas +@node Pragma Check_Policy,Pragma Comment,Pragma Check_Name,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-check-policy}@anchor{31} @section Pragma Check_Policy @@ -2140,26 +2156,8 @@ compatibility with the standard @cite{Assertion_Policy} pragma. The check policy setting @cite{DISABLE} causes the second argument of a corresponding @cite{Check} pragma to be completely ignored and not analyzed. -@node Pragma CIL_Constructor,Pragma Comment,Pragma Check_Policy,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-cil-constructor}@anchor{32} -@section Pragma CIL_Constructor - - -Syntax: - -@example -pragma CIL_Constructor ([Entity =>] function_LOCAL_NAME); -@end example - -This pragma is used to assert that the specified Ada function should be -mapped to the .NET constructor for some Ada tagged record type. - -See section 4.1 of the -@cite{GNAT User's Guide: Supplement for the .NET Platform.} -for related information. - -@node Pragma Comment,Pragma Common_Object,Pragma CIL_Constructor,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-comment}@anchor{33} +@node Pragma Comment,Pragma Common_Object,Pragma Check_Policy,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-comment}@anchor{32} @section Pragma Comment @@ -2178,7 +2176,7 @@ anywhere in the main source unit), and if more than one pragma is used, all comments are retained. @node Pragma Common_Object,Pragma Compile_Time_Error,Pragma Comment,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-common-object}@anchor{34} +@anchor{gnat_rm/implementation_defined_pragmas pragma-common-object}@anchor{33} @section Pragma Common_Object @@ -2210,7 +2208,7 @@ indicating that the necessary attribute for implementation of this pragma is not available. @node Pragma Compile_Time_Error,Pragma Compile_Time_Warning,Pragma Common_Object,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-error}@anchor{35} +@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-error}@anchor{34} @section Pragma Compile_Time_Error @@ -2237,7 +2235,7 @@ the value given as the second argument. This string value may contain embedded ASCII.LF characters to break the message into multiple lines. @node Pragma Compile_Time_Warning,Pragma Compiler_Unit,Pragma Compile_Time_Error,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-warning}@anchor{36} +@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-warning}@anchor{35} @section Pragma Compile_Time_Warning @@ -2260,7 +2258,7 @@ with a first parameter of True is to warn a client about use of a package, for example that it is not fully implemented. @node Pragma Compiler_Unit,Pragma Compiler_Unit_Warning,Pragma Compile_Time_Warning,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit}@anchor{37} +@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit}@anchor{36} @section Pragma Compiler_Unit @@ -2275,7 +2273,7 @@ retained so that old versions of the GNAT run-time that use this pragma can be compiled with newer versions of the compiler. @node Pragma Compiler_Unit_Warning,Pragma Complete_Representation,Pragma Compiler_Unit,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit-warning}@anchor{38} +@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit-warning}@anchor{37} @section Pragma Compiler_Unit_Warning @@ -2293,7 +2291,7 @@ version of GNAT. For the exact list of restrictions, see the compiler sources and references to Check_Compiler_Unit. @node Pragma Complete_Representation,Pragma Complex_Representation,Pragma Compiler_Unit_Warning,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-complete-representation}@anchor{39} +@anchor{gnat_rm/implementation_defined_pragmas pragma-complete-representation}@anchor{38} @section Pragma Complete_Representation @@ -2312,7 +2310,7 @@ complete, and that this invariant is maintained if fields are added to the record in the future. @node Pragma Complex_Representation,Pragma Component_Alignment,Pragma Complete_Representation,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-complex-representation}@anchor{3a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-complex-representation}@anchor{39} @section Pragma Complex_Representation @@ -2333,8 +2331,8 @@ example, in some environments, there is a requirement for passing records by pointer, and the use of this pragma may result in passing this type in floating-point registers. -@node Pragma Component_Alignment,Pragma Contract_Cases,Pragma Complex_Representation,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-component-alignment}@anchor{3b} +@node Pragma Component_Alignment,Pragma Constant_After_Elaboration,Pragma Complex_Representation,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-component-alignment}@anchor{3a} @section Pragma Component_Alignment @@ -2424,7 +2422,15 @@ If the alignment for a record or array type is not specified (using pragma @cite{Pack}, pragma @cite{Component_Alignment}, or a record rep clause), the GNAT uses the default alignment as described previously. -@node Pragma Contract_Cases,Pragma Convention_Identifier,Pragma Component_Alignment,Implementation Defined Pragmas +@node Pragma Constant_After_Elaboration,Pragma Contract_Cases,Pragma Component_Alignment,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-constant-after-elaboration}@anchor{3b} +@section Pragma Constant_After_Elaboration + + +For the description of this pragma, see SPARK 2014 Reference Manual, +section 3.3.1. + +@node Pragma Contract_Cases,Pragma Convention_Identifier,Pragma Constant_After_Elaboration,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-contract-cases}@anchor{3c} @section Pragma Contract_Cases @@ -2664,7 +2670,7 @@ the same object layout as the G++ compiler by default. See @ref{3f,,Interfacing to C++} for related information. -@node Pragma CPU,Pragma Debug,Pragma CPP_Vtable,Implementation Defined Pragmas +@node Pragma CPU,Pragma Default_Initial_Condition,Pragma CPP_Vtable,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-cpu}@anchor{43} @section Pragma CPU @@ -2679,8 +2685,16 @@ This pragma is standard in Ada 2012, but is available in all earlier versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. -@node Pragma Debug,Pragma Debug_Policy,Pragma CPU,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-debug}@anchor{44} +@node Pragma Default_Initial_Condition,Pragma Debug,Pragma CPU,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-default-initial-condition}@anchor{44} +@section Pragma Default_Initial_Condition + + +For the description of this pragma, see SPARK 2014 Reference Manual, +section 7.3.3. + +@node Pragma Debug,Pragma Debug_Policy,Pragma Default_Initial_Condition,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-debug}@anchor{45} @section Pragma Debug @@ -2708,7 +2722,7 @@ or by use of the pragma @cite{Check_Policy} with a first argument of @cite{Debug}. @node Pragma Debug_Policy,Pragma Default_Scalar_Storage_Order,Pragma Debug,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-debug-policy}@anchor{45} +@anchor{gnat_rm/implementation_defined_pragmas pragma-debug-policy}@anchor{46} @section Pragma Debug_Policy @@ -2723,7 +2737,7 @@ with a first argument of @cite{Debug}. It is retained for historical compatibility reasons. @node Pragma Default_Scalar_Storage_Order,Pragma Default_Storage_Pool,Pragma Debug_Policy,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-default-scalar-storage-order}@anchor{46} +@anchor{gnat_rm/implementation_defined_pragmas pragma-default-scalar-storage-order}@anchor{47} @section Pragma Default_Scalar_Storage_Order @@ -2796,7 +2810,7 @@ it may significantly degrade the run-time performance of the software, instead the default scalar storage order ought to be changed only on a local basis. @node Pragma Default_Storage_Pool,Pragma Depends,Pragma Default_Scalar_Storage_Order,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-default-storage-pool}@anchor{47} +@anchor{gnat_rm/implementation_defined_pragmas pragma-default-storage-pool}@anchor{48} @section Pragma Default_Storage_Pool @@ -2813,7 +2827,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Depends,Pragma Detect_Blocking,Pragma Default_Storage_Pool,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-depends}@anchor{48} +@anchor{gnat_rm/implementation_defined_pragmas pragma-depends}@anchor{49} @section Pragma Depends @@ -2821,7 +2835,7 @@ For the description of this pragma, see SPARK 2014 Reference Manual, section 6.1.5. @node Pragma Detect_Blocking,Pragma Disable_Atomic_Synchronization,Pragma Depends,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-detect-blocking}@anchor{49} +@anchor{gnat_rm/implementation_defined_pragmas pragma-detect-blocking}@anchor{4a} @section Pragma Detect_Blocking @@ -2839,7 +2853,7 @@ blocking operations within a protected operation, and to raise Program_Error if that happens. @node Pragma Disable_Atomic_Synchronization,Pragma Dispatching_Domain,Pragma Detect_Blocking,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-disable-atomic-synchronization}@anchor{4a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-disable-atomic-synchronization}@anchor{4b} @section Pragma Disable_Atomic_Synchronization @@ -2865,7 +2879,7 @@ till the end of the scope. If an @cite{Entity} argument is present, the action applies only to that entity. @node Pragma Dispatching_Domain,Pragma Effective_Reads,Pragma Disable_Atomic_Synchronization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-dispatching-domain}@anchor{4b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-dispatching-domain}@anchor{4c} @section Pragma Dispatching_Domain @@ -2880,7 +2894,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Effective_Reads,Pragma Effective_Writes,Pragma Dispatching_Domain,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-reads}@anchor{4c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-reads}@anchor{4d} @section Pragma Effective_Reads @@ -2888,7 +2902,7 @@ For the description of this pragma, see SPARK 2014 Reference Manual, section 7.1.2. @node Pragma Effective_Writes,Pragma Elaboration_Checks,Pragma Effective_Reads,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-writes}@anchor{4d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-writes}@anchor{4e} @section Pragma Effective_Writes @@ -2896,7 +2910,7 @@ For the description of this pragma, see SPARK 2014 Reference Manual, section 7.1.2. @node Pragma Elaboration_Checks,Pragma Eliminate,Pragma Effective_Writes,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-elaboration-checks}@anchor{4e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-elaboration-checks}@anchor{4f} @section Pragma Elaboration_Checks @@ -2921,7 +2935,7 @@ used by the GNAT compiler, see the chapter on elaboration order handling in the @emph{GNAT User's Guide}. @node Pragma Eliminate,Pragma Enable_Atomic_Synchronization,Pragma Elaboration_Checks,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-eliminate}@anchor{4f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-eliminate}@anchor{50} @section Pragma Eliminate @@ -2999,7 +3013,7 @@ dispatch are considered to be unused (are never called as a result of a direct or a dispatching call). @node Pragma Enable_Atomic_Synchronization,Pragma Export_Function,Pragma Eliminate,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-enable-atomic-synchronization}@anchor{50} +@anchor{gnat_rm/implementation_defined_pragmas pragma-enable-atomic-synchronization}@anchor{51} @section Pragma Enable_Atomic_Synchronization @@ -3027,7 +3041,7 @@ till the end of the scope. If an @cite{Entity} argument is present, the action applies only to that entity. @node Pragma Export_Function,Pragma Export_Object,Pragma Enable_Atomic_Synchronization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-export-function}@anchor{51} +@anchor{gnat_rm/implementation_defined_pragmas pragma-export-function}@anchor{52} @section Pragma Export_Function @@ -3096,7 +3110,7 @@ string. In this case, no external name is generated. This form still allows the specification of parameter mechanisms. @node Pragma Export_Object,Pragma Export_Procedure,Pragma Export_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-export-object}@anchor{52} +@anchor{gnat_rm/implementation_defined_pragmas pragma-export-object}@anchor{53} @section Pragma Export_Object @@ -3121,7 +3135,7 @@ of portability), but it is not required. @cite{Size} is syntax checked, but otherwise ignored by GNAT. @node Pragma Export_Procedure,Pragma Export_Value,Pragma Export_Object,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-export-procedure}@anchor{53} +@anchor{gnat_rm/implementation_defined_pragmas pragma-export-procedure}@anchor{54} @section Pragma Export_Procedure @@ -3174,7 +3188,7 @@ string. In this case, no external name is generated. This form still allows the specification of parameter mechanisms. @node Pragma Export_Value,Pragma Export_Valued_Procedure,Pragma Export_Procedure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-export-value}@anchor{54} +@anchor{gnat_rm/implementation_defined_pragmas pragma-export-value}@anchor{55} @section Pragma Export_Value @@ -3195,7 +3209,7 @@ the application. This pragma is currently supported only for the AAMP target and is ignored for other targets. @node Pragma Export_Valued_Procedure,Pragma Extend_System,Pragma Export_Value,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-export-valued-procedure}@anchor{55} +@anchor{gnat_rm/implementation_defined_pragmas pragma-export-valued-procedure}@anchor{56} @section Pragma Export_Valued_Procedure @@ -3253,7 +3267,7 @@ string. In this case, no external name is generated. This form still allows the specification of parameter mechanisms. @node Pragma Extend_System,Pragma Extensions_Allowed,Pragma Export_Valued_Procedure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-extend-system}@anchor{56} +@anchor{gnat_rm/implementation_defined_pragmas pragma-extend-system}@anchor{57} @section Pragma Extend_System @@ -3303,8 +3317,8 @@ To compile it you will have to use the @emph{-gnatg} switch for compiling System units, as explained in the GNAT User's Guide. -@node Pragma Extensions_Allowed,Pragma External,Pragma Extend_System,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-allowed}@anchor{57} +@node Pragma Extensions_Allowed,Pragma Extensions_Visible,Pragma Extend_System,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-allowed}@anchor{58} @section Pragma Extensions_Allowed @@ -3336,8 +3350,16 @@ generic types. The result indicates if the corresponding actual is constrained. @end table -@node Pragma External,Pragma External_Name_Casing,Pragma Extensions_Allowed,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-external}@anchor{58} +@node Pragma Extensions_Visible,Pragma External,Pragma Extensions_Allowed,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{59} +@section Pragma Extensions_Visible + + +For the description of this pragma, see SPARK 2014 Reference Manual, +section 6.1.7. + +@node Pragma External,Pragma External_Name_Casing,Pragma Extensions_Visible,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-external}@anchor{5a} @section Pragma External @@ -3358,7 +3380,7 @@ used this pragma for exactly the same purposes as pragma @cite{Export} before the latter was standardized. @node Pragma External_Name_Casing,Pragma Fast_Math,Pragma External,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-external-name-casing}@anchor{59} +@anchor{gnat_rm/implementation_defined_pragmas pragma-external-name-casing}@anchor{5b} @section Pragma External_Name_Casing @@ -3447,7 +3469,7 @@ pragma External_Name_Casing (Uppercase, Uppercase); to enforce the upper casing of all external symbols. @node Pragma Fast_Math,Pragma Favor_Top_Level,Pragma External_Name_Casing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-fast-math}@anchor{5a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-fast-math}@anchor{5c} @section Pragma Fast_Math @@ -3476,7 +3498,7 @@ under control of the pragma, rather than use the preinstantiated versions. @end table @node Pragma Favor_Top_Level,Pragma Finalize_Storage_Only,Pragma Fast_Math,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{5b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{5d} @section Pragma Favor_Top_Level @@ -3496,7 +3518,7 @@ trampolines may be used on some targets for nested subprograms. See also the No_Implicit_Dynamic_Code restriction. @node Pragma Finalize_Storage_Only,Pragma Float_Representation,Pragma Favor_Top_Level,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-finalize-storage-only}@anchor{5c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-finalize-storage-only}@anchor{5e} @section Pragma Finalize_Storage_Only @@ -3512,8 +3534,8 @@ finalization is only used to deal with storage reclamation since in most environments it is not necessary to reclaim memory just before terminating execution, hence the name. -@node Pragma Float_Representation,Pragma Global,Pragma Finalize_Storage_Only,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-float-representation}@anchor{5d} +@node Pragma Float_Representation,Pragma Ghost,Pragma Finalize_Storage_Only,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-float-representation}@anchor{5f} @section Pragma Float_Representation @@ -3547,8 +3569,16 @@ For a digits value of 15, 64-bit IEEE long format will be used. No other value of digits is permitted. @end itemize -@node Pragma Global,Pragma Ident,Pragma Float_Representation,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-global}@anchor{5e} +@node Pragma Ghost,Pragma Global,Pragma Float_Representation,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-ghost}@anchor{60} +@section Pragma Ghost + + +For the description of this pragma, see SPARK 2014 Reference Manual, +section 6.9. + +@node Pragma Global,Pragma Ident,Pragma Ghost,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-global}@anchor{61} @section Pragma Global @@ -3556,7 +3586,7 @@ For the description of this pragma, see SPARK 2014 Reference Manual, section 6.1.4. @node Pragma Ident,Pragma Ignore_Pragma,Pragma Global,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ident}@anchor{5f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ident}@anchor{62} @section Pragma Ident @@ -3570,7 +3600,7 @@ This pragma is identical in effect to pragma @cite{Comment}. It is provided for compatibility with other Ada compilers providing this pragma. @node Pragma Ignore_Pragma,Pragma Implementation_Defined,Pragma Ident,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ignore-pragma}@anchor{60} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ignore-pragma}@anchor{63} @section Pragma Ignore_Pragma @@ -3590,7 +3620,7 @@ pragma allows such pragmas to be ignored, which may be useful in @cite{CodePeer} mode, or during porting of legacy code. @node Pragma Implementation_Defined,Pragma Implemented,Pragma Ignore_Pragma,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-implementation-defined}@anchor{61} +@anchor{gnat_rm/implementation_defined_pragmas pragma-implementation-defined}@anchor{64} @section Pragma Implementation_Defined @@ -3617,7 +3647,7 @@ for the purpose of implementing the No_Implementation_Identifiers restriction. @node Pragma Implemented,Pragma Implicit_Packing,Pragma Implementation_Defined,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-implemented}@anchor{62} +@anchor{gnat_rm/implementation_defined_pragmas pragma-implemented}@anchor{65} @section Pragma Implemented @@ -3663,7 +3693,7 @@ By_Any shares the behavior of By_Entry and By_Protected_Procedure depending on the target's overriding subprogram kind. @node Pragma Implicit_Packing,Pragma Import_Function,Pragma Implemented,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-implicit-packing}@anchor{63} +@anchor{gnat_rm/implementation_defined_pragmas pragma-implicit-packing}@anchor{66} @section Pragma Implicit_Packing @@ -3717,7 +3747,7 @@ sufficient. The use of pragma Implicit_Packing allows this record declaration to compile without an explicit pragma Pack. @node Pragma Import_Function,Pragma Import_Object,Pragma Implicit_Packing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-function}@anchor{64} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-function}@anchor{67} @section Pragma Import_Function @@ -3782,7 +3812,7 @@ notation. If the mechanism is not specified, the default mechanism is used. @node Pragma Import_Object,Pragma Import_Procedure,Pragma Import_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-object}@anchor{65} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-object}@anchor{68} @section Pragma Import_Object @@ -3808,7 +3838,7 @@ point of view). @cite{size} is syntax checked, but otherwise ignored by GNAT. @node Pragma Import_Procedure,Pragma Import_Valued_Procedure,Pragma Import_Object,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-procedure}@anchor{66} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-procedure}@anchor{69} @section Pragma Import_Procedure @@ -3848,7 +3878,7 @@ applies to a procedure rather than a function and the parameters @cite{Result_Type} and @cite{Result_Mechanism} are not permitted. @node Pragma Import_Valued_Procedure,Pragma Independent,Pragma Import_Procedure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-valued-procedure}@anchor{67} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-valued-procedure}@anchor{6a} @section Pragma Import_Valued_Procedure @@ -3901,7 +3931,7 @@ pragma Import that specifies the desired convention, since otherwise the default convention is Ada, which is almost certainly not what is required. @node Pragma Independent,Pragma Independent_Components,Pragma Import_Valued_Procedure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-independent}@anchor{68} +@anchor{gnat_rm/implementation_defined_pragmas pragma-independent}@anchor{6b} @section Pragma Independent @@ -3923,7 +3953,7 @@ constraints on the representation of the object (for instance prohibiting tight packing). @node Pragma Independent_Components,Pragma Initial_Condition,Pragma Independent,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-independent-components}@anchor{69} +@anchor{gnat_rm/implementation_defined_pragmas pragma-independent-components}@anchor{6c} @section Pragma Independent_Components @@ -3944,7 +3974,7 @@ constraints on the representation of the object (for instance prohibiting tight packing). @node Pragma Initial_Condition,Pragma Initialize_Scalars,Pragma Independent_Components,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{6a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{6d} @section Pragma Initial_Condition @@ -3952,7 +3982,7 @@ For the description of this pragma, see SPARK 2014 Reference Manual, section 7.1.6. @node Pragma Initialize_Scalars,Pragma Initializes,Pragma Initial_Condition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-initialize-scalars}@anchor{6b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-initialize-scalars}@anchor{6e} @section Pragma Initialize_Scalars @@ -4015,7 +4045,7 @@ checking (see description of stack checking in the GNAT User's Guide) when using this pragma. @node Pragma Initializes,Pragma Inline_Always,Pragma Initialize_Scalars,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-initializes}@anchor{6c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-initializes}@anchor{6f} @section Pragma Initializes @@ -4023,7 +4053,7 @@ For the description of this pragma, see SPARK 2014 Reference Manual, section 7.1.5. @node Pragma Inline_Always,Pragma Inline_Generic,Pragma Initializes,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{6d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{70} @section Pragma Inline_Always @@ -4038,7 +4068,7 @@ the use of option @emph{-gnatn} or @emph{-gnatN} and the inlining happens regardless of whether these options are used. @node Pragma Inline_Generic,Pragma Interface,Pragma Inline_Always,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-generic}@anchor{6e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-generic}@anchor{71} @section Pragma Inline_Generic @@ -4056,7 +4086,7 @@ than to check that the given names are all names of generic units or generic instances. @node Pragma Interface,Pragma Interface_Name,Pragma Inline_Generic,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interface}@anchor{6f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interface}@anchor{72} @section Pragma Interface @@ -4083,7 +4113,7 @@ maintaining Ada 83/Ada 95 compatibility and is compatible with other Ada 83 compilers. @node Pragma Interface_Name,Pragma Interrupt_Handler,Pragma Interface,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interface-name}@anchor{70} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interface-name}@anchor{73} @section Pragma Interface_Name @@ -4102,7 +4132,7 @@ for an interfaced subprogram, and is provided for compatibility with Ada least one of @cite{External_Name} or @cite{Link_Name}. @node Pragma Interrupt_Handler,Pragma Interrupt_State,Pragma Interface_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-handler}@anchor{71} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-handler}@anchor{74} @section Pragma Interrupt_Handler @@ -4122,7 +4152,7 @@ when this pragma is applied to a nonprotected procedure, the instruction maskable interrupts, in place of the normal return instruction. @node Pragma Interrupt_State,Pragma Invariant,Pragma Interrupt_Handler,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{72} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{75} @section Pragma Interrupt_State @@ -4204,8 +4234,8 @@ Overriding the default state of signals used by the Ada runtime may interfere with an application's runtime behavior in the cases of the synchronous signals, and in the case of the signal used to implement the @cite{abort} statement. -@node Pragma Invariant,Pragma Java_Constructor,Pragma Interrupt_State,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{73} +@node Pragma Invariant,Pragma Keep_Names,Pragma Interrupt_State,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{76} @section Pragma Invariant @@ -4243,44 +4273,8 @@ invariant pragma for the same entity. For further details on the use of this pragma, see the Ada 2012 documentation of the Type_Invariant aspect. -@node Pragma Java_Constructor,Pragma Java_Interface,Pragma Invariant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-java-constructor}@anchor{74} -@section Pragma Java_Constructor - - -Syntax: - -@example -pragma Java_Constructor ([Entity =>] function_LOCAL_NAME); -@end example - -This pragma is used to assert that the specified Ada function should be -mapped to the Java constructor for some Ada tagged record type. - -See section 7.3.2 of the -@cite{GNAT User's Guide: Supplement for the JVM Platform.} -for related information. - -@node Pragma Java_Interface,Pragma Keep_Names,Pragma Java_Constructor,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-java-interface}@anchor{75} -@section Pragma Java_Interface - - -Syntax: - -@example -pragma Java_Interface ([Entity =>] abstract_tagged_type_LOCAL_NAME); -@end example - -This pragma is used to assert that the specified Ada abstract tagged type -is to be mapped to a Java interface name. - -See sections 7.1 and 7.2 of the -@cite{GNAT User's Guide: Supplement for the JVM Platform.} -for related information. - -@node Pragma Keep_Names,Pragma License,Pragma Java_Interface,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-keep-names}@anchor{76} +@node Pragma Keep_Names,Pragma License,Pragma Invariant,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-keep-names}@anchor{77} @section Pragma Keep_Names @@ -4300,7 +4294,7 @@ use a @cite{Discard_Names} pragma in the @code{gnat.adc} file, but you want to retain the names for specific enumeration types. @node Pragma License,Pragma Link_With,Pragma Keep_Names,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-license}@anchor{77} +@anchor{gnat_rm/implementation_defined_pragmas pragma-license}@anchor{78} @section Pragma License @@ -4395,7 +4389,7 @@ GPL, but no warning for @cite{GNAT.Sockets} which is part of the GNAT run time, and is therefore licensed under the modified GPL. @node Pragma Link_With,Pragma Linker_Alias,Pragma License,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-link-with}@anchor{78} +@anchor{gnat_rm/implementation_defined_pragmas pragma-link-with}@anchor{79} @section Pragma Link_With @@ -4419,7 +4413,7 @@ separate arguments to the linker. In addition pragma Link_With allows multiple arguments, with the same effect as successive pragmas. @node Pragma Linker_Alias,Pragma Linker_Constructor,Pragma Link_With,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-alias}@anchor{79} +@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-alias}@anchor{7a} @section Pragma Linker_Alias @@ -4460,7 +4454,7 @@ end p; @end example @node Pragma Linker_Constructor,Pragma Linker_Destructor,Pragma Linker_Alias,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-constructor}@anchor{7a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-constructor}@anchor{7b} @section Pragma Linker_Constructor @@ -4490,7 +4484,7 @@ listed above. Where possible, the use of Stand Alone Libraries is preferable to the use of this pragma. @node Pragma Linker_Destructor,Pragma Linker_Section,Pragma Linker_Constructor,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-destructor}@anchor{7b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-destructor}@anchor{7c} @section Pragma Linker_Destructor @@ -4513,7 +4507,7 @@ See @cite{pragma Linker_Constructor} for the set of restrictions that apply because of these specific contexts. @node Pragma Linker_Section,Pragma Lock_Free,Pragma Linker_Destructor,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{7c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{7d} @section Pragma Linker_Section @@ -4587,7 +4581,7 @@ end IO_Card; @end example @node Pragma Lock_Free,Pragma Loop_Invariant,Pragma Linker_Section,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{7d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{7e} @section Pragma Lock_Free @@ -4598,7 +4592,7 @@ Compilation fails if the compiler cannot generate lock-free code for the operations. @node Pragma Loop_Invariant,Pragma Loop_Optimize,Pragma Lock_Free,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{7e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{7f} @section Pragma Loop_Invariant @@ -4631,7 +4625,7 @@ attribute can only be used within the expression of a @cite{Loop_Invariant} pragma. For full details, see documentation of attribute @cite{Loop_Entry}. @node Pragma Loop_Optimize,Pragma Loop_Variant,Pragma Loop_Invariant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-optimize}@anchor{7f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-optimize}@anchor{80} @section Pragma Loop_Optimize @@ -4693,7 +4687,7 @@ compiler in order to enable the relevant optimizations, that is to say vectorization. @node Pragma Loop_Variant,Pragma Machine_Attribute,Pragma Loop_Optimize,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-variant}@anchor{80} +@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-variant}@anchor{81} @section Pragma Loop_Variant @@ -4740,7 +4734,7 @@ The @cite{Loop_Entry} attribute may be used within the expressions of the @cite{Loop_Variant} pragma to refer to values on entry to the loop. @node Pragma Machine_Attribute,Pragma Main,Pragma Loop_Variant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-machine-attribute}@anchor{81} +@anchor{gnat_rm/implementation_defined_pragmas pragma-machine-attribute}@anchor{82} @section Pragma Machine_Attribute @@ -4765,7 +4759,7 @@ for some attributes. For further information see @cite{GNU Compiler Collection (GCC) Internals}. @node Pragma Main,Pragma Main_Storage,Pragma Machine_Attribute,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-main}@anchor{82} +@anchor{gnat_rm/implementation_defined_pragmas pragma-main}@anchor{83} @section Pragma Main @@ -4785,7 +4779,7 @@ This pragma is provided for compatibility with OpenVMS VAX Systems. It has no effect in GNAT, other than being syntax checked. @node Pragma Main_Storage,Pragma No_Body,Pragma Main,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-main-storage}@anchor{83} +@anchor{gnat_rm/implementation_defined_pragmas pragma-main-storage}@anchor{84} @section Pragma Main_Storage @@ -4804,7 +4798,7 @@ This pragma is provided for compatibility with OpenVMS VAX Systems. It has no effect in GNAT, other than being syntax checked. @node Pragma No_Body,Pragma No_Elaboration_Code_All,Pragma Main_Storage,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-body}@anchor{84} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-body}@anchor{85} @section Pragma No_Body @@ -4827,7 +4821,7 @@ dummy body with a No_Body pragma ensures that there is no interference from earlier versions of the package body. @node Pragma No_Elaboration_Code_All,Pragma No_Inline,Pragma No_Body,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{85} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{86} @section Pragma No_Elaboration_Code_All @@ -4846,7 +4840,7 @@ current unit, it must also have the No_Elaboration_Code_All aspect set. It may be applied to package or subprogram specs or their generic versions. @node Pragma No_Inline,Pragma No_Return,Pragma No_Elaboration_Code_All,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{86} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{87} @section Pragma No_Inline @@ -4864,7 +4858,7 @@ in particular it is not subject to the use of option @emph{-gnatn} or pragma @cite{Inline_Always} for the same @cite{NAME}. @node Pragma No_Return,Pragma No_Run_Time,Pragma No_Inline,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-return}@anchor{87} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-return}@anchor{88} @section Pragma No_Return @@ -4891,7 +4885,7 @@ available in all earlier versions of Ada as an implementation-defined pragma. @node Pragma No_Run_Time,Pragma No_Strict_Aliasing,Pragma No_Return,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-run-time}@anchor{88} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-run-time}@anchor{89} @section Pragma No_Run_Time @@ -4907,7 +4901,7 @@ internal testing. The pragma has been superseded by the reconfigurable runtime capability of @cite{GNAT}. @node Pragma No_Strict_Aliasing,Pragma No_Tagged_Streams,Pragma No_Run_Time,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-strict-aliasing}@anchor{89} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-strict-aliasing}@anchor{8a} @section Pragma No_Strict_Aliasing @@ -4929,7 +4923,7 @@ in the @cite{GNAT User's Guide}. This pragma currently has no effects on access to unconstrained array types. @node Pragma No_Tagged_Streams,Pragma Normalize_Scalars,Pragma No_Strict_Aliasing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-tagged-streams}@anchor{8a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-tagged-streams}@anchor{8b} @section Pragma No_Tagged_Streams @@ -4964,7 +4958,7 @@ applies to a complete hierarchy (this is necessary to deal with the class-wide dispatching versions of the stream routines). @node Pragma Normalize_Scalars,Pragma Obsolescent,Pragma No_Tagged_Streams,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{8b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{8c} @section Pragma Normalize_Scalars @@ -5046,7 +5040,7 @@ will always generate an invalid value if one exists. @end table @node Pragma Obsolescent,Pragma Optimize_Alignment,Pragma Normalize_Scalars,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-obsolescent}@anchor{8c}@anchor{gnat_rm/implementation_defined_pragmas id2}@anchor{8d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-obsolescent}@anchor{8d}@anchor{gnat_rm/implementation_defined_pragmas id2}@anchor{8e} @section Pragma Obsolescent @@ -5142,7 +5136,7 @@ So if you specify "Entity =>" for the Entity argument, and a Message argument is present, it must be preceded by "Message =>". @node Pragma Optimize_Alignment,Pragma Ordered,Pragma Obsolescent,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-optimize-alignment}@anchor{8e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-optimize-alignment}@anchor{8f} @section Pragma Optimize_Alignment @@ -5225,7 +5219,7 @@ latter are compiled by default in pragma Optimize_Alignment (Off) mode if no pragma appears at the start of the file. @node Pragma Ordered,Pragma Overflow_Mode,Pragma Optimize_Alignment,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ordered}@anchor{8f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ordered}@anchor{90} @section Pragma Ordered @@ -5317,7 +5311,7 @@ For additional information please refer to the description of the @emph{-gnatw.u} switch in the GNAT User's Guide. @node Pragma Overflow_Mode,Pragma Overriding_Renamings,Pragma Ordered,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-overflow-mode}@anchor{90} +@anchor{gnat_rm/implementation_defined_pragmas pragma-overflow-mode}@anchor{91} @section Pragma Overflow_Mode @@ -5356,7 +5350,7 @@ The pragma @cite{Unsuppress (Overflow_Check)} unsuppresses (enables) overflow checking, but does not affect the overflow mode. @node Pragma Overriding_Renamings,Pragma Partition_Elaboration_Policy,Pragma Overflow_Mode,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-overriding-renamings}@anchor{91} +@anchor{gnat_rm/implementation_defined_pragmas pragma-overriding-renamings}@anchor{92} @section Pragma Overriding_Renamings @@ -5391,7 +5385,7 @@ RM 8.3 (15) stipulates that an overridden operation is not visible within the declaration of the overriding operation. @node Pragma Partition_Elaboration_Policy,Pragma Part_Of,Pragma Overriding_Renamings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-partition-elaboration-policy}@anchor{92} +@anchor{gnat_rm/implementation_defined_pragmas pragma-partition-elaboration-policy}@anchor{93} @section Pragma Partition_Elaboration_Policy @@ -5408,7 +5402,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Part_Of,Pragma Passive,Pragma Partition_Elaboration_Policy,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{93} +@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{94} @section Pragma Part_Of @@ -5416,7 +5410,7 @@ For the description of this pragma, see SPARK 2014 Reference Manual, section 7.2.6. @node Pragma Passive,Pragma Persistent_BSS,Pragma Part_Of,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-passive}@anchor{94} +@anchor{gnat_rm/implementation_defined_pragmas pragma-passive}@anchor{95} @section Pragma Passive @@ -5440,7 +5434,7 @@ For more information on the subject of passive tasks, see the section 'Passive Task Optimization' in the GNAT Users Guide. @node Pragma Persistent_BSS,Pragma Polling,Pragma Passive,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{95} +@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{96} @section Pragma Persistent_BSS @@ -5471,7 +5465,7 @@ If this pragma is used on a target where this feature is not supported, then the pragma will be ignored. See also @cite{pragma Linker_Section}. @node Pragma Polling,Pragma Post,Pragma Persistent_BSS,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-polling}@anchor{96} +@anchor{gnat_rm/implementation_defined_pragmas pragma-polling}@anchor{97} @section Pragma Polling @@ -5513,7 +5507,7 @@ Note that polling can also be enabled by use of the @emph{-gnatP} switch. See the section on switches for gcc in the @cite{GNAT User's Guide}. @node Pragma Post,Pragma Postcondition,Pragma Polling,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{97} +@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{98} @section Pragma Post @@ -5538,7 +5532,7 @@ appear at the start of the declarations in a subprogram body (preceded only by other pragmas). @node Pragma Postcondition,Pragma Post_Class,Pragma Post,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{98} +@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{99} @section Pragma Postcondition @@ -5703,7 +5697,7 @@ Ada 2012, and has been retained in its original form for compatibility purposes. @node Pragma Post_Class,Pragma Pre,Pragma Postcondition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{99} +@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{9a} @section Pragma Post_Class @@ -5738,7 +5732,7 @@ policy that controls this pragma is @cite{Post'Class}, not @cite{Post_Class}. @node Pragma Pre,Pragma Precondition,Pragma Post_Class,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{9a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{9b} @section Pragma Pre @@ -5763,7 +5757,7 @@ appear at the start of the declarations in a subprogram body (preceded only by other pragmas). @node Pragma Precondition,Pragma Predicate,Pragma Pre,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-precondition}@anchor{9b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-precondition}@anchor{9c} @section Pragma Precondition @@ -5822,7 +5816,7 @@ Ada 2012, and has been retained in its original form for compatibility purposes. @node Pragma Predicate,Pragma Preelaborable_Initialization,Pragma Precondition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate}@anchor{9c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate}@anchor{9d} @section Pragma Predicate @@ -5876,7 +5870,7 @@ defined for subtype B). When following this approach, the use of predicates should be avoided. @node Pragma Preelaborable_Initialization,Pragma Prefix_Exception_Messages,Pragma Predicate,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-preelaborable-initialization}@anchor{9d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-preelaborable-initialization}@anchor{9e} @section Pragma Preelaborable_Initialization @@ -5891,7 +5885,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Prefix_Exception_Messages,Pragma Pre_Class,Pragma Preelaborable_Initialization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-prefix-exception-messages}@anchor{9e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-prefix-exception-messages}@anchor{9f} @section Pragma Prefix_Exception_Messages @@ -5922,7 +5916,7 @@ prefixing in this case, you can always call @cite{GNAT.Source_Info.Enclosing_Entity} and prepend the string manually. @node Pragma Pre_Class,Pragma Priority_Specific_Dispatching,Pragma Prefix_Exception_Messages,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-pre-class}@anchor{9f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-pre-class}@anchor{a0} @section Pragma Pre_Class @@ -5957,7 +5951,7 @@ policy that controls this pragma is @cite{Pre'Class}, not @cite{Pre_Class}. @node Pragma Priority_Specific_Dispatching,Pragma Profile,Pragma Pre_Class,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-priority-specific-dispatching}@anchor{a0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-priority-specific-dispatching}@anchor{a1} @section Pragma Priority_Specific_Dispatching @@ -5981,7 +5975,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Profile,Pragma Profile_Warnings,Pragma Priority_Specific_Dispatching,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-profile}@anchor{a1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-profile}@anchor{a2} @section Pragma Profile @@ -6229,7 +6223,7 @@ conforming Ada constructs. The profile enables the following three pragmas: @end itemize @node Pragma Profile_Warnings,Pragma Propagate_Exceptions,Pragma Profile,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{a2} +@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{a3} @section Pragma Profile_Warnings @@ -6247,7 +6241,7 @@ violations of the profile generate warning messages instead of error messages. @node Pragma Propagate_Exceptions,Pragma Provide_Shift_Operators,Pragma Profile_Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{a3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{a4} @section Pragma Propagate_Exceptions @@ -6266,7 +6260,7 @@ purposes. It used to be used in connection with optimization of a now-obsolete mechanism for implementation of exceptions. @node Pragma Provide_Shift_Operators,Pragma Psect_Object,Pragma Propagate_Exceptions,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{a4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{a5} @section Pragma Provide_Shift_Operators @@ -6286,7 +6280,7 @@ including the function declarations for these five operators, together with the pragma Import (Intrinsic, ...) statements. @node Pragma Psect_Object,Pragma Pure_Function,Pragma Provide_Shift_Operators,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{a5} +@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{a6} @section Pragma Psect_Object @@ -6306,7 +6300,7 @@ EXTERNAL_SYMBOL ::= This pragma is identical in effect to pragma @cite{Common_Object}. @node Pragma Pure_Function,Pragma Rational,Pragma Psect_Object,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{a6} +@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{a7} @section Pragma Pure_Function @@ -6368,7 +6362,7 @@ unit is not a Pure unit in the categorization sense. So for example, a function thus marked is free to @cite{with} non-pure units. @node Pragma Rational,Pragma Ravenscar,Pragma Pure_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{a7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{a8} @section Pragma Rational @@ -6386,7 +6380,7 @@ pragma Profile (Rational); @end example @node Pragma Ravenscar,Pragma Refined_Depends,Pragma Rational,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{a8} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{a9} @section Pragma Ravenscar @@ -6406,7 +6400,7 @@ pragma Profile (Ravenscar); which is the preferred method of setting the @cite{Ravenscar} profile. @node Pragma Refined_Depends,Pragma Refined_Global,Pragma Ravenscar,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{a9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{aa} @section Pragma Refined_Depends @@ -6414,7 +6408,7 @@ For the description of this pragma, see SPARK 2014 Reference Manual, section 6.1.5. @node Pragma Refined_Global,Pragma Refined_Post,Pragma Refined_Depends,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{aa} +@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{ab} @section Pragma Refined_Global @@ -6422,7 +6416,7 @@ For the description of this pragma, see SPARK 2014 Reference Manual, section 6.1.4. @node Pragma Refined_Post,Pragma Refined_State,Pragma Refined_Global,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{ab} +@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{ac} @section Pragma Refined_Post @@ -6430,7 +6424,7 @@ For the description of this pragma, see SPARK 2014 Reference Manual, section 7.2.7. @node Pragma Refined_State,Pragma Relative_Deadline,Pragma Refined_Post,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{ac} +@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{ad} @section Pragma Refined_State @@ -6438,7 +6432,7 @@ For the description of this pragma, see SPARK 2014 Reference Manual, section 7.2.2. @node Pragma Relative_Deadline,Pragma Remote_Access_Type,Pragma Refined_State,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{ad} +@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{ae} @section Pragma Relative_Deadline @@ -6453,7 +6447,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Remote_Access_Type,Pragma Restricted_Run_Time,Pragma Relative_Deadline,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{ae} +@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{af} @section Pragma Remote_Access_Type @@ -6479,7 +6473,7 @@ pertaining to remote access to class-wide types. At instantiation, the actual type must be a remote access to class-wide type. @node Pragma Restricted_Run_Time,Pragma Restriction_Warnings,Pragma Remote_Access_Type,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{af} +@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{b0} @section Pragma Restricted_Run_Time @@ -6500,7 +6494,7 @@ which is the preferred method of setting the restricted run time profile. @node Pragma Restriction_Warnings,Pragma Reviewable,Pragma Restricted_Run_Time,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{b0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{b1} @section Pragma Restriction_Warnings @@ -6538,7 +6532,7 @@ generating a warning, but any other use of implementation defined pragmas will cause a warning to be generated. @node Pragma Reviewable,Pragma Share_Generic,Pragma Restriction_Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{b1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{b2} @section Pragma Reviewable @@ -6642,7 +6636,7 @@ comprehensive messages identifying possible problems based on this information. @node Pragma Share_Generic,Pragma Shared,Pragma Reviewable,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{b2} +@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{b3} @section Pragma Share_Generic @@ -6660,7 +6654,7 @@ than to check that the given names are all names of generic units or generic instances. @node Pragma Shared,Pragma Short_Circuit_And_Or,Pragma Share_Generic,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{b3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{b4} @section Pragma Shared @@ -6668,7 +6662,7 @@ This pragma is provided for compatibility with Ada 83. The syntax and semantics are identical to pragma Atomic. @node Pragma Short_Circuit_And_Or,Pragma Short_Descriptors,Pragma Shared,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{b4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{b5} @section Pragma Short_Circuit_And_Or @@ -6687,7 +6681,7 @@ within the file being compiled, it applies only to the file being compiled. There is no requirement that all units in a partition use this option. @node Pragma Short_Descriptors,Pragma Simple_Storage_Pool_Type,Pragma Short_Circuit_And_Or,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{b5} +@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{b6} @section Pragma Short_Descriptors @@ -6701,7 +6695,7 @@ This pragma is provided for compatibility with other Ada implementations. It is recognized but ignored by all current versions of GNAT. @node Pragma Simple_Storage_Pool_Type,Pragma Source_File_Name,Pragma Short_Descriptors,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{b6} +@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{b7} @section Pragma Simple_Storage_Pool_Type @@ -6755,7 +6749,7 @@ storage-management discipline). An object of a simple storage pool type can be associated with an access type by specifying the attribute -@ref{b7,,Simple_Storage_Pool}. For example: +@ref{b8,,Simple_Storage_Pool}. For example: @example My_Pool : My_Simple_Storage_Pool_Type; @@ -6765,11 +6759,11 @@ type Acc is access My_Data_Type; for Acc'Simple_Storage_Pool use My_Pool; @end example -See attribute @ref{b7,,Simple_Storage_Pool} +See attribute @ref{b8,,Simple_Storage_Pool} for further details. @node Pragma Source_File_Name,Pragma Source_File_Name_Project,Pragma Simple_Storage_Pool_Type,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{b8}@anchor{gnat_rm/implementation_defined_pragmas id3}@anchor{b9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{b9}@anchor{gnat_rm/implementation_defined_pragmas id3}@anchor{ba} @section Pragma Source_File_Name @@ -6861,19 +6855,19 @@ aware of these pragmas, and so other tools that use the projet file would not be aware of the intended naming conventions. If you are using project files, file naming is controlled by Source_File_Name_Project pragmas, which are usually supplied automatically by the project manager. A pragma -Source_File_Name cannot appear after a @ref{ba,,Pragma Source_File_Name_Project}. +Source_File_Name cannot appear after a @ref{bb,,Pragma Source_File_Name_Project}. For more details on the use of the @cite{Source_File_Name} pragma, see the sections on @cite{Using Other File Names} and @cite{Alternative File Naming Schemes' in the :title:`GNAT User's Guide}. @node Pragma Source_File_Name_Project,Pragma Source_Reference,Pragma Source_File_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id4}@anchor{bb}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{ba} +@anchor{gnat_rm/implementation_defined_pragmas id4}@anchor{bc}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{bb} @section Pragma Source_File_Name_Project This pragma has the same syntax and semantics as pragma Source_File_Name. -It is only allowed as a stand alone configuration pragma. -It cannot appear after a @ref{b8,,Pragma Source_File_Name}, and +It is only allowed as a stand-alone configuration pragma. +It cannot appear after a @ref{b9,,Pragma Source_File_Name}, and most importantly, once pragma Source_File_Name_Project appears, no further Source_File_Name pragmas are allowed. @@ -6885,7 +6879,7 @@ Source_File_Name or Source_File_Name_Project pragmas (which would not be known to the project manager). @node Pragma Source_Reference,Pragma SPARK_Mode,Pragma Source_File_Name_Project,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{bc} +@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{bd} @section Pragma Source_Reference @@ -6909,7 +6903,7 @@ string expression other than a string literal. This is because its value is needed for error messages issued by all phases of the compiler. @node Pragma SPARK_Mode,Pragma Static_Elaboration_Desired,Pragma Source_Reference,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{bd} +@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{be} @section Pragma SPARK_Mode @@ -6991,7 +6985,7 @@ SPARK_Mode (@cite{Off}), then that pragma will need to be repeated in the package body. @node Pragma Static_Elaboration_Desired,Pragma Stream_Convert,Pragma SPARK_Mode,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{be} +@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{bf} @section Pragma Static_Elaboration_Desired @@ -7015,7 +7009,7 @@ construction of larger aggregates with static components that include an others choice.) @node Pragma Stream_Convert,Pragma Style_Checks,Pragma Static_Elaboration_Desired,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{bf} +@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{c0} @section Pragma Stream_Convert @@ -7092,7 +7086,7 @@ the pragma is silently ignored, and the default implementation of the stream attributes is used instead. @node Pragma Style_Checks,Pragma Subtitle,Pragma Stream_Convert,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{c0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{c1} @section Pragma Style_Checks @@ -7165,7 +7159,7 @@ Rf2 : Integer := ARG; -- OK, no error @end example @node Pragma Subtitle,Pragma Suppress,Pragma Style_Checks,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{c1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{c2} @section Pragma Subtitle @@ -7179,7 +7173,7 @@ This pragma is recognized for compatibility with other Ada compilers but is ignored by GNAT. @node Pragma Suppress,Pragma Suppress_All,Pragma Subtitle,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{c2} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{c3} @section Pragma Suppress @@ -7215,6 +7209,13 @@ that use such variables for synchronization purposes. for a duplicated tag value when a tagged type is declared. @item +@cite{Container_Checks} Can be used to suppress all checks within Ada.Containers +and instances of its children, including Tampering_Check. + +@item +@cite{Tampering_Check} Can be used to suppress tampering check in the containers. + +@item @cite{Predicate_Check} can be used to control whether predicate checks are active. It is applicable only to predicates for which the policy is @cite{Check}. Unlike @cite{Assertion_Policy}, which determines if a given @@ -7245,7 +7246,7 @@ Of course, run-time checks are omitted whenever the compiler can prove that they will not fail, whether or not checks are suppressed. @node Pragma Suppress_All,Pragma Suppress_Debug_Info,Pragma Suppress,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{c3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{c4} @section Pragma Suppress_All @@ -7264,7 +7265,7 @@ The use of the standard Ada pragma @cite{Suppress (All_Checks)} as a normal configuration pragma is the preferred usage in GNAT. @node Pragma Suppress_Debug_Info,Pragma Suppress_Exception_Locations,Pragma Suppress_All,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{c4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{c5} @section Pragma Suppress_Debug_Info @@ -7279,7 +7280,7 @@ for the specified entity. It is intended primarily for use in debugging the debugger, and navigating around debugger problems. @node Pragma Suppress_Exception_Locations,Pragma Suppress_Initialization,Pragma Suppress_Debug_Info,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{c5} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{c6} @section Pragma Suppress_Exception_Locations @@ -7302,7 +7303,7 @@ a partition, so it is fine to have some units within a partition compiled with this pragma and others compiled in normal mode without it. @node Pragma Suppress_Initialization,Pragma Task_Name,Pragma Suppress_Exception_Locations,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{c6} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{c7} @section Pragma Suppress_Initialization @@ -7347,7 +7348,7 @@ is suppressed, just as though its subtype had been given in a pragma Suppress_Initialization, as described above. @node Pragma Task_Name,Pragma Task_Storage,Pragma Suppress_Initialization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{c7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{c8} @section Pragma Task_Name @@ -7403,7 +7404,7 @@ end; @end example @node Pragma Task_Storage,Pragma Test_Case,Pragma Task_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{c8} +@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{c9} @section Pragma Task_Storage @@ -7423,7 +7424,7 @@ created, depending on the target. This pragma can appear anywhere a type. @node Pragma Test_Case,Pragma Thread_Local_Storage,Pragma Task_Storage,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{c9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{ca} @section Pragma Test_Case @@ -7479,7 +7480,7 @@ postcondition. Mode @cite{Robustness} indicates that the precondition and postcondition of the subprogram should be ignored for this test case. @node Pragma Thread_Local_Storage,Pragma Time_Slice,Pragma Test_Case,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{ca} +@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{cb} @section Pragma Thread_Local_Storage @@ -7513,7 +7514,7 @@ If this pragma is used on a system where @cite{TLS} is not supported, then an error message will be generated and the program will be rejected. @node Pragma Time_Slice,Pragma Title,Pragma Thread_Local_Storage,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{cb} +@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{cc} @section Pragma Time_Slice @@ -7529,7 +7530,7 @@ It is ignored if it is used in a system that does not allow this control, or if it appears in other than the main program unit. @node Pragma Title,Pragma Type_Invariant,Pragma Time_Slice,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{cc} +@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{cd} @section Pragma Title @@ -7554,7 +7555,7 @@ notation is used, and named and positional notation can be mixed following the normal rules for procedure calls in Ada. @node Pragma Type_Invariant,Pragma Type_Invariant_Class,Pragma Title,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{cd} +@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{ce} @section Pragma Type_Invariant @@ -7575,7 +7576,7 @@ controlled by the assertion identifier @cite{Type_Invariant} rather than @cite{Invariant}. @node Pragma Type_Invariant_Class,Pragma Unchecked_Union,Pragma Type_Invariant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{ce} +@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{cf} @section Pragma Type_Invariant_Class @@ -7602,7 +7603,7 @@ policy that controls this pragma is @cite{Type_Invariant'Class}, not @cite{Type_Invariant_Class}. @node Pragma Unchecked_Union,Pragma Unevaluated_Use_Of_Old,Pragma Type_Invariant_Class,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{cf} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{d0} @section Pragma Unchecked_Union @@ -7622,7 +7623,7 @@ version in all language modes (Ada 83, Ada 95, and Ada 2005). For full details, consult the Ada 2012 Reference Manual, section B.3.3. @node Pragma Unevaluated_Use_Of_Old,Pragma Unimplemented_Unit,Pragma Unchecked_Union,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{d0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{d1} @section Pragma Unevaluated_Use_Of_Old @@ -7677,7 +7678,7 @@ uses up to the end of the corresponding statement sequence or sequence of package declarations. @node Pragma Unimplemented_Unit,Pragma Universal_Aliasing,Pragma Unevaluated_Use_Of_Old,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{d1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{d2} @section Pragma Unimplemented_Unit @@ -7697,7 +7698,7 @@ The abort only happens if code is being generated. Thus you can use specs of unimplemented packages in syntax or semantic checking mode. @node Pragma Universal_Aliasing,Pragma Universal_Data,Pragma Unimplemented_Unit,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{d2} +@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{d3} @section Pragma Universal_Aliasing @@ -7716,7 +7717,7 @@ situations in which it must be suppressed, see the section on @cite{Optimization and Strict Aliasing} in the @cite{GNAT User's Guide}. @node Pragma Universal_Data,Pragma Unmodified,Pragma Universal_Aliasing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-data}@anchor{d3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-data}@anchor{d4} @section Pragma Universal_Data @@ -7740,7 +7741,7 @@ of this pragma is also available by applying the -univ switch on the compilations of units where universal addressing of the data is desired. @node Pragma Unmodified,Pragma Unreferenced,Pragma Universal_Data,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{d4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{d5} @section Pragma Unmodified @@ -7774,7 +7775,7 @@ Thus it is never necessary to use @cite{pragma Unmodified} for such variables, though it is harmless to do so. @node Pragma Unreferenced,Pragma Unreferenced_Objects,Pragma Unmodified,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{d5} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{d6} @section Pragma Unreferenced @@ -7818,7 +7819,7 @@ Note that if a warning is desired for all calls to a given subprogram, regardless of whether they occur in the same unit as the subprogram declaration, then this pragma should not be used (calls from another unit would not be flagged); pragma Obsolescent can be used instead -for this purpose, see @ref{8c,,Pragma Obsolescent}. +for this purpose, see @ref{8d,,Pragma Obsolescent}. The second form of pragma @cite{Unreferenced} is used within a context clause. In this case the arguments must be unit names of units previously @@ -7834,7 +7835,7 @@ Thus it is never necessary to use @cite{pragma Unreferenced} for such variables, though it is harmless to do so. @node Pragma Unreferenced_Objects,Pragma Unreserve_All_Interrupts,Pragma Unreferenced,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{d6} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{d7} @section Pragma Unreferenced_Objects @@ -7859,7 +7860,7 @@ compiler will automatically suppress unwanted warnings about these variables not being referenced. @node Pragma Unreserve_All_Interrupts,Pragma Unsuppress,Pragma Unreferenced_Objects,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{d7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{d8} @section Pragma Unreserve_All_Interrupts @@ -7895,7 +7896,7 @@ handled, see pragma @cite{Interrupt_State}, which subsumes the functionality of the @cite{Unreserve_All_Interrupts} pragma. @node Pragma Unsuppress,Pragma Use_VADS_Size,Pragma Unreserve_All_Interrupts,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{d8} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{d9} @section Pragma Unsuppress @@ -7926,12 +7927,12 @@ pragma Unsuppress (Duplicated_Tag_Check); This pragma is standard in Ada 2005. It is available in all earlier versions of Ada as an implementation-defined pragma. -Note that in addition to the checks defined in the Ada RM, GNAT recogizes -a number of implementation-defined check names. See description of pragma +Note that in addition to the checks defined in the Ada RM, GNAT recogizes a +number of implementation-defined check names. See the description of pragma @cite{Suppress} for full details. @node Pragma Use_VADS_Size,Pragma Validity_Checks,Pragma Unsuppress,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{d9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{da} @section Pragma Use_VADS_Size @@ -7955,7 +7956,7 @@ as implemented in the VADS compiler. See description of the VADS_Size attribute for further details. @node Pragma Validity_Checks,Pragma Volatile,Pragma Use_VADS_Size,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{da} +@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{db} @section Pragma Validity_Checks @@ -8012,7 +8013,7 @@ A := C; -- C will be validity checked @end example @node Pragma Volatile,Pragma Volatile_Full_Access,Pragma Validity_Checks,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{db} +@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{dc} @section Pragma Volatile @@ -8029,8 +8030,8 @@ in some Ada 83 compilers, including DEC Ada 83. The Ada 95 / Ada 2005 implementation of pragma Volatile is upwards compatible with the implementation in DEC Ada 83. -@node Pragma Volatile_Full_Access,Pragma Warning_As_Error,Pragma Volatile,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{dc} +@node Pragma Volatile_Full_Access,Pragma Volatile_Function,Pragma Volatile,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{dd} @section Pragma Volatile_Full_Access @@ -8061,8 +8062,16 @@ the same object. It is not permissible to specify @cite{Volatile_Full_Access} for a composite (record or array) type or object that has at least one @cite{Aliased} component. -@node Pragma Warning_As_Error,Pragma Warnings,Pragma Volatile_Full_Access,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{dd} +@node Pragma Volatile_Function,Pragma Warning_As_Error,Pragma Volatile_Full_Access,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{de} +@section Pragma Volatile_Function + + +For the description of this pragma, see SPARK 2014 Reference Manual, +section 7.1.2. + +@node Pragma Warning_As_Error,Pragma Warnings,Pragma Volatile_Function,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{df} @section Pragma Warning_As_Error @@ -8097,7 +8106,7 @@ as shown in the example below, to treat a class of warnings as errors. The above use of patterns to match the message applies only to warning messages generated by the front end. This pragma can also be applied to -warnings provided by the back end and mentioned in @ref{de,,Pragma Warnings}. +warnings provided by the back end and mentioned in @ref{e0,,Pragma Warnings}. By using a single full @emph{-Wxxx} switch in the pragma, such warnings can also be treated as errors. @@ -8147,7 +8156,7 @@ the tag is changed from "warning:" to "error:" and the string "[warning-as-error]" is appended to the end of the message. @node Pragma Warnings,Pragma Weak_External,Pragma Warning_As_Error,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id5}@anchor{df}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{de} +@anchor{gnat_rm/implementation_defined_pragmas id5}@anchor{e1}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{e0} @section Pragma Warnings @@ -8299,7 +8308,7 @@ selectively for each tool, and as a consequence to detect useless pragma Warnings with switch @cite{-gnatw.w}. @node Pragma Weak_External,Pragma Wide_Character_Encoding,Pragma Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{e0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{e2} @section Pragma Weak_External @@ -8350,7 +8359,7 @@ end External_Module; @end example @node Pragma Wide_Character_Encoding,,Pragma Weak_External,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{e1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{e3} @section Pragma Wide_Character_Encoding @@ -8377,7 +8386,7 @@ encoding within that file, and does not affect withed units, specs, or subunits. @node Implementation Defined Aspects,Implementation Defined Attributes,Implementation Defined Pragmas,Top -@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{e2}@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{e3}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{e4} +@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{e4}@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{e5}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{e6} @chapter Implementation Defined Aspects @@ -8436,14 +8445,18 @@ or attribute definition clause. * Annotate:: * Aspect Async_Readers:: * Aspect Async_Writers:: +* Aspect Constant_After_Elaboration:: * Aspect Contract_Cases:: * Aspect Depends:: +* Aspect Default_Initial_Condition:: * Aspect Dimension:: * Aspect Dimension_System:: * Aspect Disable_Controlled:: * Aspect Effective_Reads:: * Aspect Effective_Writes:: +* Aspect Extensions_Visible:: * Aspect Favor_Top_Level:: +* Aspect Ghost:: * Aspect Global:: * Aspect Initial_Condition:: * Aspect Initializes:: @@ -8482,12 +8495,13 @@ or attribute definition clause. * Aspect Unreferenced_Objects:: * Aspect Value_Size:: * Aspect Volatile_Full_Access:: +* Aspect Volatile_Function:: * Aspect Warnings:: @end menu @node Aspect Abstract_State,Annotate,,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{e5} +@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{e7} @section Aspect Abstract_State @@ -8496,7 +8510,7 @@ or attribute definition clause. This aspect is equivalent to pragma @cite{Abstract_State}. @node Annotate,Aspect Async_Readers,Aspect Abstract_State,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects annotate}@anchor{e6} +@anchor{gnat_rm/implementation_defined_aspects annotate}@anchor{e8} @section Annotate @@ -8522,7 +8536,7 @@ Equivalent to @cite{pragma Annotate (ID@comma{} ID @{@comma{} ARG@}@comma{} Enti @end table @node Aspect Async_Readers,Aspect Async_Writers,Annotate,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{e7} +@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{e9} @section Aspect Async_Readers @@ -8530,8 +8544,8 @@ Equivalent to @cite{pragma Annotate (ID@comma{} ID @{@comma{} ARG@}@comma{} Enti This boolean aspect is equivalent to pragma @cite{Async_Readers}. -@node Aspect Async_Writers,Aspect Contract_Cases,Aspect Async_Readers,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{e8} +@node Aspect Async_Writers,Aspect Constant_After_Elaboration,Aspect Async_Readers,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{ea} @section Aspect Async_Writers @@ -8539,8 +8553,17 @@ This boolean aspect is equivalent to pragma @cite{Async_Readers}. This boolean aspect is equivalent to pragma @cite{Async_Writers}. -@node Aspect Contract_Cases,Aspect Depends,Aspect Async_Writers,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{e9} +@node Aspect Constant_After_Elaboration,Aspect Contract_Cases,Aspect Async_Writers,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{eb} +@section Aspect Constant_After_Elaboration + + +@geindex Constant_After_Elaboration + +This aspect is equivalent to pragma @cite{Constant_After_Elaboration}. + +@node Aspect Contract_Cases,Aspect Depends,Aspect Constant_After_Elaboration,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{ec} @section Aspect Contract_Cases @@ -8550,8 +8573,8 @@ This aspect is equivalent to pragma @cite{Contract_Cases}, the sequence of clauses being enclosed in parentheses so that syntactically it is an aggregate. -@node Aspect Depends,Aspect Dimension,Aspect Contract_Cases,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{ea} +@node Aspect Depends,Aspect Default_Initial_Condition,Aspect Contract_Cases,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{ed} @section Aspect Depends @@ -8559,8 +8582,17 @@ aggregate. This aspect is equivalent to pragma @cite{Depends}. -@node Aspect Dimension,Aspect Dimension_System,Aspect Depends,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{eb} +@node Aspect Default_Initial_Condition,Aspect Dimension,Aspect Depends,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{ee} +@section Aspect Default_Initial_Condition + + +@geindex Default_Initial_Condition + +This aspect is equivalent to pragma @cite{Default_Initial_Condition}. + +@node Aspect Dimension,Aspect Dimension_System,Aspect Default_Initial_Condition,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{ef} @section Aspect Dimension @@ -8596,7 +8628,7 @@ Note that when the dimensioned type is an integer type, then any dimension value must be an integer literal. @node Aspect Dimension_System,Aspect Disable_Controlled,Aspect Dimension,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{ec} +@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{f0} @section Aspect Dimension_System @@ -8656,7 +8688,7 @@ See section 'Performing Dimensionality Analysis in GNAT' in the GNAT Users Guide for detailed examples of use of the dimension system. @node Aspect Disable_Controlled,Aspect Effective_Reads,Aspect Dimension_System,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{ed} +@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{f1} @section Aspect Disable_Controlled @@ -8669,7 +8701,7 @@ where for example you might want a record to be controlled or not depending on whether some run-time check is enabled or suppressed. @node Aspect Effective_Reads,Aspect Effective_Writes,Aspect Disable_Controlled,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{ee} +@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{f2} @section Aspect Effective_Reads @@ -8677,8 +8709,8 @@ whether some run-time check is enabled or suppressed. This aspect is equivalent to pragma @cite{Effective_Reads}. -@node Aspect Effective_Writes,Aspect Favor_Top_Level,Aspect Effective_Reads,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{ef} +@node Aspect Effective_Writes,Aspect Extensions_Visible,Aspect Effective_Reads,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{f3} @section Aspect Effective_Writes @@ -8686,8 +8718,17 @@ This aspect is equivalent to pragma @cite{Effective_Reads}. This aspect is equivalent to pragma @cite{Effective_Writes}. -@node Aspect Favor_Top_Level,Aspect Global,Aspect Effective_Writes,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{f0} +@node Aspect Extensions_Visible,Aspect Favor_Top_Level,Aspect Effective_Writes,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{f4} +@section Aspect Extensions_Visible + + +@geindex Extensions_Visible + +This aspect is equivalent to pragma @cite{Extensions_Visible}. + +@node Aspect Favor_Top_Level,Aspect Ghost,Aspect Extensions_Visible,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{f5} @section Aspect Favor_Top_Level @@ -8695,8 +8736,17 @@ This aspect is equivalent to pragma @cite{Effective_Writes}. This boolean aspect is equivalent to pragma @cite{Favor_Top_Level}. -@node Aspect Global,Aspect Initial_Condition,Aspect Favor_Top_Level,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{f1} +@node Aspect Ghost,Aspect Global,Aspect Favor_Top_Level,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{f6} +@section Aspect Ghost + + +@geindex Ghost + +This aspect is equivalent to pragma @cite{Ghost}. + +@node Aspect Global,Aspect Initial_Condition,Aspect Ghost,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{f7} @section Aspect Global @@ -8705,7 +8755,7 @@ This boolean aspect is equivalent to pragma @cite{Favor_Top_Level}. This aspect is equivalent to pragma @cite{Global}. @node Aspect Initial_Condition,Aspect Initializes,Aspect Global,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{f2} +@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{f8} @section Aspect Initial_Condition @@ -8714,7 +8764,7 @@ This aspect is equivalent to pragma @cite{Global}. This aspect is equivalent to pragma @cite{Initial_Condition}. @node Aspect Initializes,Aspect Inline_Always,Aspect Initial_Condition,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{f3} +@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{f9} @section Aspect Initializes @@ -8723,7 +8773,7 @@ This aspect is equivalent to pragma @cite{Initial_Condition}. This aspect is equivalent to pragma @cite{Initializes}. @node Aspect Inline_Always,Aspect Invariant,Aspect Initializes,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{f4} +@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{fa} @section Aspect Inline_Always @@ -8732,7 +8782,7 @@ This aspect is equivalent to pragma @cite{Initializes}. This boolean aspect is equivalent to pragma @cite{Inline_Always}. @node Aspect Invariant,Aspect Invariant'Class,Aspect Inline_Always,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{f5} +@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{fb} @section Aspect Invariant @@ -8743,7 +8793,7 @@ synonym for the language defined aspect @cite{Type_Invariant} except that it is separately controllable using pragma @cite{Assertion_Policy}. @node Aspect Invariant'Class,Aspect Iterable,Aspect Invariant,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{f6} +@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{fc} @section Aspect Invariant'Class @@ -8754,7 +8804,7 @@ synonym for the language defined aspect @cite{Type_Invariant'Class} except that it is separately controllable using pragma @cite{Assertion_Policy}. @node Aspect Iterable,Aspect Linker_Section,Aspect Invariant'Class,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{f7} +@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{fd} @section Aspect Iterable @@ -8830,7 +8880,7 @@ function Get_Element (Cont : Container; Position : Cursor) return Element_Type; This aspect is used in the GNAT-defined formal container packages. @node Aspect Linker_Section,Aspect Lock_Free,Aspect Iterable,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{f8} +@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{fe} @section Aspect Linker_Section @@ -8839,7 +8889,7 @@ This aspect is used in the GNAT-defined formal container packages. This aspect is equivalent to an @cite{Linker_Section} pragma. @node Aspect Lock_Free,Aspect No_Elaboration_Code_All,Aspect Linker_Section,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{f9} +@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{ff} @section Aspect Lock_Free @@ -8848,7 +8898,7 @@ This aspect is equivalent to an @cite{Linker_Section} pragma. This boolean aspect is equivalent to pragma @cite{Lock_Free}. @node Aspect No_Elaboration_Code_All,Aspect No_Tagged_Streams,Aspect Lock_Free,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{fa} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{100} @section Aspect No_Elaboration_Code_All @@ -8858,7 +8908,7 @@ This aspect is equivalent to a @cite{pragma No_Elaboration_Code_All} statement for a program unit. @node Aspect No_Tagged_Streams,Aspect Object_Size,Aspect No_Elaboration_Code_All,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{fb} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{101} @section Aspect No_Tagged_Streams @@ -8869,7 +8919,7 @@ argument specifying a root tagged type (thus this aspect can only be applied to such a type). @node Aspect Object_Size,Aspect Obsolescent,Aspect No_Tagged_Streams,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{fc} +@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{102} @section Aspect Object_Size @@ -8879,7 +8929,7 @@ This aspect is equivalent to an @cite{Object_Size} attribute definition clause. @node Aspect Obsolescent,Aspect Part_Of,Aspect Object_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{fd} +@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{103} @section Aspect Obsolescent @@ -8890,7 +8940,7 @@ evaluation of this aspect happens at the point of occurrence, it is not delayed until the freeze point. @node Aspect Part_Of,Aspect Persistent_BSS,Aspect Obsolescent,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{fe} +@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{104} @section Aspect Part_Of @@ -8899,7 +8949,7 @@ delayed until the freeze point. This aspect is equivalent to pragma @cite{Part_Of}. @node Aspect Persistent_BSS,Aspect Predicate,Aspect Part_Of,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{ff} +@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{105} @section Aspect Persistent_BSS @@ -8908,7 +8958,7 @@ This aspect is equivalent to pragma @cite{Part_Of}. This boolean aspect is equivalent to pragma @cite{Persistent_BSS}. @node Aspect Predicate,Aspect Pure_Function,Aspect Persistent_BSS,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{100} +@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{106} @section Aspect Predicate @@ -8922,7 +8972,7 @@ expression. It is also separately controllable using pragma @cite{Assertion_Policy}. @node Aspect Pure_Function,Aspect Refined_Depends,Aspect Predicate,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{101} +@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{107} @section Aspect Pure_Function @@ -8931,7 +8981,7 @@ expression. It is also separately controllable using pragma This boolean aspect is equivalent to pragma @cite{Pure_Function}. @node Aspect Refined_Depends,Aspect Refined_Global,Aspect Pure_Function,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{102} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{108} @section Aspect Refined_Depends @@ -8940,7 +8990,7 @@ This boolean aspect is equivalent to pragma @cite{Pure_Function}. This aspect is equivalent to pragma @cite{Refined_Depends}. @node Aspect Refined_Global,Aspect Refined_Post,Aspect Refined_Depends,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{103} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{109} @section Aspect Refined_Global @@ -8949,7 +8999,7 @@ This aspect is equivalent to pragma @cite{Refined_Depends}. This aspect is equivalent to pragma @cite{Refined_Global}. @node Aspect Refined_Post,Aspect Refined_State,Aspect Refined_Global,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{104} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{10a} @section Aspect Refined_Post @@ -8958,7 +9008,7 @@ This aspect is equivalent to pragma @cite{Refined_Global}. This aspect is equivalent to pragma @cite{Refined_Post}. @node Aspect Refined_State,Aspect Remote_Access_Type,Aspect Refined_Post,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{105} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{10b} @section Aspect Refined_State @@ -8967,7 +9017,7 @@ This aspect is equivalent to pragma @cite{Refined_Post}. This aspect is equivalent to pragma @cite{Refined_State}. @node Aspect Remote_Access_Type,Aspect Scalar_Storage_Order,Aspect Refined_State,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{106} +@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{10c} @section Aspect Remote_Access_Type @@ -8976,7 +9026,7 @@ This aspect is equivalent to pragma @cite{Refined_State}. This aspect is equivalent to pragma @cite{Remote_Access_Type}. @node Aspect Scalar_Storage_Order,Aspect Shared,Aspect Remote_Access_Type,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{107} +@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{10d} @section Aspect Scalar_Storage_Order @@ -8986,7 +9036,7 @@ This aspect is equivalent to a @cite{Scalar_Storage_Order} attribute definition clause. @node Aspect Shared,Aspect Simple_Storage_Pool,Aspect Scalar_Storage_Order,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{108} +@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{10e} @section Aspect Shared @@ -8996,7 +9046,7 @@ This boolean aspect is equivalent to pragma @cite{Shared}, and is thus a synonym for aspect @cite{Atomic}. @node Aspect Simple_Storage_Pool,Aspect Simple_Storage_Pool_Type,Aspect Shared,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{109} +@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{10f} @section Aspect Simple_Storage_Pool @@ -9006,7 +9056,7 @@ This aspect is equivalent to a @cite{Simple_Storage_Pool} attribute definition clause. @node Aspect Simple_Storage_Pool_Type,Aspect SPARK_Mode,Aspect Simple_Storage_Pool,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{10a} +@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{110} @section Aspect Simple_Storage_Pool_Type @@ -9015,7 +9065,7 @@ attribute definition clause. This boolean aspect is equivalent to pragma @cite{Simple_Storage_Pool_Type}. @node Aspect SPARK_Mode,Aspect Suppress_Debug_Info,Aspect Simple_Storage_Pool_Type,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{10b} +@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{111} @section Aspect SPARK_Mode @@ -9026,7 +9076,7 @@ may be specified for either or both of the specification and body of a subprogram or package. @node Aspect Suppress_Debug_Info,Aspect Suppress_Initialization,Aspect SPARK_Mode,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{10c} +@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{112} @section Aspect Suppress_Debug_Info @@ -9035,7 +9085,7 @@ of a subprogram or package. This boolean aspect is equivalent to pragma @cite{Suppress_Debug_Info}. @node Aspect Suppress_Initialization,Aspect Test_Case,Aspect Suppress_Debug_Info,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{10d} +@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{113} @section Aspect Suppress_Initialization @@ -9044,7 +9094,7 @@ This boolean aspect is equivalent to pragma @cite{Suppress_Debug_Info}. This boolean aspect is equivalent to pragma @cite{Suppress_Initialization}. @node Aspect Test_Case,Aspect Thread_Local_Storage,Aspect Suppress_Initialization,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{10e} +@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{114} @section Aspect Test_Case @@ -9053,7 +9103,7 @@ This boolean aspect is equivalent to pragma @cite{Suppress_Initialization}. This aspect is equivalent to pragma @cite{Test_Case}. @node Aspect Thread_Local_Storage,Aspect Universal_Aliasing,Aspect Test_Case,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{10f} +@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{115} @section Aspect Thread_Local_Storage @@ -9062,7 +9112,7 @@ This aspect is equivalent to pragma @cite{Test_Case}. This boolean aspect is equivalent to pragma @cite{Thread_Local_Storage}. @node Aspect Universal_Aliasing,Aspect Universal_Data,Aspect Thread_Local_Storage,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{110} +@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{116} @section Aspect Universal_Aliasing @@ -9071,7 +9121,7 @@ This boolean aspect is equivalent to pragma @cite{Thread_Local_Storage}. This boolean aspect is equivalent to pragma @cite{Universal_Aliasing}. @node Aspect Universal_Data,Aspect Unmodified,Aspect Universal_Aliasing,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-universal-data}@anchor{111} +@anchor{gnat_rm/implementation_defined_aspects aspect-universal-data}@anchor{117} @section Aspect Universal_Data @@ -9080,7 +9130,7 @@ This boolean aspect is equivalent to pragma @cite{Universal_Aliasing}. This aspect is equivalent to pragma @cite{Universal_Data}. @node Aspect Unmodified,Aspect Unreferenced,Aspect Universal_Data,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{112} +@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{118} @section Aspect Unmodified @@ -9089,7 +9139,7 @@ This aspect is equivalent to pragma @cite{Universal_Data}. This boolean aspect is equivalent to pragma @cite{Unmodified}. @node Aspect Unreferenced,Aspect Unreferenced_Objects,Aspect Unmodified,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{113} +@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{119} @section Aspect Unreferenced @@ -9100,7 +9150,7 @@ in the case of formal parameters, it is not permitted to have aspects for a formal parameter, so in this case the pragma form must be used. @node Aspect Unreferenced_Objects,Aspect Value_Size,Aspect Unreferenced,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{114} +@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{11a} @section Aspect Unreferenced_Objects @@ -9109,7 +9159,7 @@ a formal parameter, so in this case the pragma form must be used. This boolean aspect is equivalent to pragma @cite{Unreferenced_Objects}. @node Aspect Value_Size,Aspect Volatile_Full_Access,Aspect Unreferenced_Objects,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{115} +@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{11b} @section Aspect Value_Size @@ -9118,8 +9168,8 @@ This boolean aspect is equivalent to pragma @cite{Unreferenced_Objects}. This aspect is equivalent to a @cite{Value_Size} attribute definition clause. -@node Aspect Volatile_Full_Access,Aspect Warnings,Aspect Value_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{116} +@node Aspect Volatile_Full_Access,Aspect Volatile_Function,Aspect Value_Size,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{11c} @section Aspect Volatile_Full_Access @@ -9127,8 +9177,17 @@ attribute definition clause. This boolean aspect is equivalent to pragma @cite{Volatile_Full_Access}. -@node Aspect Warnings,,Aspect Volatile_Full_Access,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{117} +@node Aspect Volatile_Function,Aspect Warnings,Aspect Volatile_Full_Access,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{11d} +@section Aspect Volatile_Function + + +@geindex Volatile_Function + +This boolean aspect is equivalent to pragma @cite{Volatile_Function}. + +@node Aspect Warnings,,Aspect Volatile_Function,Implementation Defined Aspects +@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{11e} @section Aspect Warnings @@ -9139,7 +9198,7 @@ where the first argument is @cite{ON} or @cite{OFF} and the second argument is the entity. @node Implementation Defined Attributes,Standard and Implementation Defined Restrictions,Implementation Defined Aspects,Top -@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{118}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{119} +@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{11f}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{120} @chapter Implementation Defined Attributes @@ -9226,7 +9285,6 @@ consideration, you should minimize the use of these attributes. * Attribute Type_Class:: * Attribute Type_Key:: * Attribute TypeCode:: -* Attribute UET_Address:: * Attribute Unconstrained_Array:: * Attribute Universal_Literal_String:: * Attribute Unrestricted_Access:: @@ -9240,7 +9298,7 @@ consideration, you should minimize the use of these attributes. @end menu @node Attribute Abort_Signal,Attribute Address_Size,,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{11a} +@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{121} @section Attribute Abort_Signal @@ -9254,7 +9312,7 @@ completely outside the normal semantics of Ada, for a user program to intercept the abort exception). @node Attribute Address_Size,Attribute Asm_Input,Attribute Abort_Signal,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{11b} +@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{122} @section Attribute Address_Size @@ -9266,11 +9324,11 @@ intercept the abort exception). prefix) is a static constant giving the number of bits in an @cite{Address}. It is the same value as System.Address'Size, but has the advantage of being static, while a direct -reference to System.Address'Size is non-static because Address +reference to System.Address'Size is nonstatic because Address is a private type. @node Attribute Asm_Input,Attribute Asm_Output,Attribute Address_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{11c} +@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{123} @section Attribute Asm_Input @@ -9284,10 +9342,10 @@ to be a static expression, and is the constraint for the parameter, value to be used as the input argument. The possible values for the constant are the same as those used in the RTL, and are dependent on the configuration file used to built the GCC back end. -@ref{11d,,Machine Code Insertions} +@ref{124,,Machine Code Insertions} @node Attribute Asm_Output,Attribute Atomic_Always_Lock_Free,Attribute Asm_Input,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{11e} +@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{125} @section Attribute Asm_Output @@ -9303,10 +9361,10 @@ result. The possible values for constraint are the same as those used in the RTL, and are dependent on the configuration file used to build the GCC back end. If there are no output operands, then this argument may either be omitted, or explicitly given as @cite{No_Output_Operands}. -@ref{11d,,Machine Code Insertions} +@ref{124,,Machine Code Insertions} @node Attribute Atomic_Always_Lock_Free,Attribute Bit,Attribute Asm_Output,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{11f} +@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{126} @section Attribute Atomic_Always_Lock_Free @@ -9318,7 +9376,7 @@ and False otherwise. The result indicate whether atomic operations are supported by the target for the given type. @node Attribute Bit,Attribute Bit_Position,Attribute Atomic_Always_Lock_Free,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{120} +@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{127} @section Attribute Bit @@ -9349,7 +9407,7 @@ This attribute is designed to be compatible with the DEC Ada 83 definition and implementation of the @cite{Bit} attribute. @node Attribute Bit_Position,Attribute Code_Address,Attribute Bit,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{121} +@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{128} @section Attribute Bit_Position @@ -9364,7 +9422,7 @@ type @cite{Universal_Integer}. The value depends only on the field the containing record @cite{R}. @node Attribute Code_Address,Attribute Compiler_Version,Attribute Bit_Position,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{122} +@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{129} @section Attribute Code_Address @@ -9407,7 +9465,7 @@ the same value as is returned by the corresponding @cite{'Address} attribute. @node Attribute Compiler_Version,Attribute Constrained,Attribute Code_Address,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{123} +@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{12a} @section Attribute Compiler_Version @@ -9418,7 +9476,7 @@ prefix) yields a static string identifying the version of the compiler being used to compile the unit containing the attribute reference. @node Attribute Constrained,Attribute Default_Bit_Order,Attribute Compiler_Version,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{124} +@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{12b} @section Attribute Constrained @@ -9433,7 +9491,7 @@ record type without discriminants is always @cite{True}. This usage is compatible with older Ada compilers, including notably DEC Ada. @node Attribute Default_Bit_Order,Attribute Default_Scalar_Storage_Order,Attribute Constrained,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{125} +@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{12c} @section Attribute Default_Bit_Order @@ -9450,7 +9508,7 @@ as a @cite{Pos} value (0 for @cite{High_Order_First}, 1 for @cite{Default_Bit_Order} in package @cite{System}. @node Attribute Default_Scalar_Storage_Order,Attribute Deref,Attribute Default_Bit_Order,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{126} +@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{12d} @section Attribute Default_Scalar_Storage_Order @@ -9467,7 +9525,7 @@ equal to @cite{Default_Bit_Order} if unspecified) as a @cite{System.Bit_Order} value. This is a static attribute. @node Attribute Deref,Attribute Descriptor_Size,Attribute Default_Scalar_Storage_Order,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{127} +@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{12e} @section Attribute Deref @@ -9480,7 +9538,7 @@ a named access-to-@cite{typ} type, except that it yields a variable, so it can b used on the left side of an assignment. @node Attribute Descriptor_Size,Attribute Elaborated,Attribute Deref,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{128} +@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{12f} @section Attribute Descriptor_Size @@ -9490,7 +9548,7 @@ used on the left side of an assignment. @geindex Descriptor_Size -Non-static attribute @cite{Descriptor_Size} returns the size in bits of the +Nonstatic attribute @cite{Descriptor_Size} returns the size in bits of the descriptor allocated for a type. The result is non-zero only for unconstrained array types and the returned value is of type universal integer. In GNAT, an array descriptor contains bounds information and is located immediately before @@ -9507,7 +9565,7 @@ In the example above, the descriptor contains two values of type a size of 31 bits and an alignment of 4, the descriptor size is @cite{2 * Positive'Size + 2} or 64 bits. @node Attribute Elaborated,Attribute Elab_Body,Attribute Descriptor_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{129} +@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{130} @section Attribute Elaborated @@ -9522,7 +9580,7 @@ units has been completed. An exception is for units which need no elaboration, the value is always False for such units. @node Attribute Elab_Body,Attribute Elab_Spec,Attribute Elaborated,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{12a} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{131} @section Attribute Elab_Body @@ -9538,7 +9596,7 @@ e.g., if it is necessary to do selective re-elaboration to fix some error. @node Attribute Elab_Spec,Attribute Elab_Subp_Body,Attribute Elab_Body,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{12b} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{132} @section Attribute Elab_Spec @@ -9554,7 +9612,7 @@ Ada code, e.g., if it is necessary to do selective re-elaboration to fix some error. @node Attribute Elab_Subp_Body,Attribute Emax,Attribute Elab_Spec,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{12c} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{133} @section Attribute Elab_Subp_Body @@ -9568,7 +9626,7 @@ elaboration procedure by the binder in CodePeer mode only and is unrecognized otherwise. @node Attribute Emax,Attribute Enabled,Attribute Elab_Subp_Body,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{12d} +@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{134} @section Attribute Emax @@ -9581,7 +9639,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Enabled,Attribute Enum_Rep,Attribute Emax,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{12e} +@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{135} @section Attribute Enabled @@ -9605,7 +9663,7 @@ a @cite{pragma Suppress} or @cite{pragma Unsuppress} before instantiating the package or subprogram, controlling whether the check will be present. @node Attribute Enum_Rep,Attribute Enum_Val,Attribute Enabled,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{12f} +@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{136} @section Attribute Enum_Rep @@ -9642,7 +9700,7 @@ integer calculation is done at run time, then the call to @cite{Enum_Rep} may raise @cite{Constraint_Error}. @node Attribute Enum_Val,Attribute Epsilon,Attribute Enum_Rep,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{130} +@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{137} @section Attribute Enum_Val @@ -9665,7 +9723,7 @@ absence of an enumeration representation clause. This is a static attribute (i.e., the result is static if the argument is static). @node Attribute Epsilon,Attribute Fast_Math,Attribute Enum_Val,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{131} +@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{138} @section Attribute Epsilon @@ -9678,7 +9736,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Fast_Math,Attribute Fixed_Value,Attribute Epsilon,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{132} +@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{139} @section Attribute Fast_Math @@ -9689,7 +9747,7 @@ prefix) yields a static Boolean value that is True if pragma @cite{Fast_Math} is active, and False otherwise. @node Attribute Fixed_Value,Attribute From_Any,Attribute Fast_Math,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{133} +@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{13a} @section Attribute Fixed_Value @@ -9716,7 +9774,7 @@ This attribute is primarily intended for use in implementation of the input-output functions for fixed-point values. @node Attribute From_Any,Attribute Has_Access_Values,Attribute Fixed_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{134} +@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{13b} @section Attribute From_Any @@ -9726,7 +9784,7 @@ This internal attribute is used for the generation of remote subprogram stubs in the context of the Distributed Systems Annex. @node Attribute Has_Access_Values,Attribute Has_Discriminants,Attribute From_Any,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{135} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{13c} @section Attribute Has_Access_Values @@ -9744,7 +9802,7 @@ definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has access values. @node Attribute Has_Discriminants,Attribute Img,Attribute Has_Access_Values,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{136} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{13d} @section Attribute Has_Discriminants @@ -9760,7 +9818,7 @@ definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has discriminants. @node Attribute Img,Attribute Integer_Value,Attribute Has_Discriminants,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{137} +@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{13e} @section Attribute Img @@ -9790,7 +9848,7 @@ that returns the appropriate string when called. This means that in an instantiation as a function parameter. @node Attribute Integer_Value,Attribute Invalid_Value,Attribute Img,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{138} +@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{13f} @section Attribute Integer_Value @@ -9818,7 +9876,7 @@ This attribute is primarily intended for use in implementation of the standard input-output functions for fixed-point values. @node Attribute Invalid_Value,Attribute Iterable,Attribute Integer_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{139} +@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{140} @section Attribute Invalid_Value @@ -9832,7 +9890,7 @@ including the ability to modify the value with the binder -Sxx flag and relevant environment variables at run time. @node Attribute Iterable,Attribute Large,Attribute Invalid_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{13a} +@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{141} @section Attribute Iterable @@ -9841,7 +9899,7 @@ relevant environment variables at run time. Equivalent to Aspect Iterable. @node Attribute Large,Attribute Library_Level,Attribute Iterable,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{13b} +@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{142} @section Attribute Large @@ -9854,7 +9912,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Library_Level,Attribute Lock_Free,Attribute Large,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{13c} +@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{143} @section Attribute Library_Level @@ -9880,7 +9938,7 @@ end Gen; @end example @node Attribute Lock_Free,Attribute Loop_Entry,Attribute Library_Level,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{13d} +@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{144} @section Attribute Lock_Free @@ -9890,7 +9948,7 @@ end Gen; pragma @cite{Lock_Free} applies to P. @node Attribute Loop_Entry,Attribute Machine_Size,Attribute Lock_Free,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{13e} +@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{145} @section Attribute Loop_Entry @@ -9920,7 +9978,7 @@ entry. This copy is not performed if the loop is not entered, or if the corresponding pragmas are ignored or disabled. @node Attribute Machine_Size,Attribute Mantissa,Attribute Loop_Entry,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{13f} +@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{146} @section Attribute Machine_Size @@ -9930,7 +9988,7 @@ This attribute is identical to the @cite{Object_Size} attribute. It is provided for compatibility with the DEC Ada 83 attribute of this name. @node Attribute Mantissa,Attribute Maximum_Alignment,Attribute Machine_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{140} +@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{147} @section Attribute Mantissa @@ -9943,7 +10001,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Maximum_Alignment,Attribute Mechanism_Code,Attribute Mantissa,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{141}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{142} +@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{148}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{149} @section Attribute Maximum_Alignment @@ -9959,7 +10017,7 @@ for an object, guaranteeing that it is properly aligned in all cases. @node Attribute Mechanism_Code,Attribute Null_Parameter,Attribute Maximum_Alignment,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{143} +@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{14a} @section Attribute Mechanism_Code @@ -9990,7 +10048,7 @@ by reference @end table @node Attribute Null_Parameter,Attribute Object_Size,Attribute Mechanism_Code,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{144} +@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{14b} @section Attribute Null_Parameter @@ -10015,7 +10073,7 @@ There is no way of indicating this without the @cite{Null_Parameter} attribute. @node Attribute Object_Size,Attribute Old,Attribute Null_Parameter,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{145} +@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{14c} @section Attribute Object_Size @@ -10085,7 +10143,7 @@ Similar additional checks are performed in other contexts requiring statically matching subtypes. @node Attribute Old,Attribute Passed_By_Reference,Attribute Object_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{146} +@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{14d} @section Attribute Old @@ -10100,7 +10158,7 @@ definition are allowed under control of implementation defined pragma @cite{Unevaluated_Use_Of_Old}. @node Attribute Passed_By_Reference,Attribute Pool_Address,Attribute Old,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{147} +@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{14e} @section Attribute Passed_By_Reference @@ -10113,10 +10171,10 @@ implementation defined pragma @cite{Unevaluated_Use_Of_Old}. a value of type @cite{Boolean} value that is @cite{True} if the type is normally passed by reference and @cite{False} if the type is normally passed by copy in calls. For scalar types, the result is always @cite{False} -and is static. For non-scalar types, the result is non-static. +and is static. For non-scalar types, the result is nonstatic. @node Attribute Pool_Address,Attribute Range_Length,Attribute Passed_By_Reference,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{148} +@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{14f} @section Attribute Pool_Address @@ -10141,7 +10199,7 @@ For an object created by @cite{new}, @code{Ptr.all'Pool_Address} is what is passed to @cite{Allocate} and returned from @cite{Deallocate}. @node Attribute Range_Length,Attribute Restriction_Set,Attribute Pool_Address,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{149} +@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{150} @section Attribute Range_Length @@ -10154,7 +10212,7 @@ applied to the index subtype of a one dimensional array always gives the same result as @cite{Length} applied to the array itself. @node Attribute Restriction_Set,Attribute Result,Attribute Range_Length,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{14a} +@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{151} @section Attribute Restriction_Set @@ -10224,7 +10282,7 @@ Restrictions pragma, they are not analyzed semantically, so they do not have a type. @node Attribute Result,Attribute Safe_Emax,Attribute Restriction_Set,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{14b} +@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{152} @section Attribute Result @@ -10237,7 +10295,7 @@ For a further discussion of the use of this attribute and examples of its use, see the description of pragma Postcondition. @node Attribute Safe_Emax,Attribute Safe_Large,Attribute Result,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{14c} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{153} @section Attribute Safe_Emax @@ -10250,7 +10308,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Safe_Large,Attribute Safe_Small,Attribute Safe_Emax,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{14d} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{154} @section Attribute Safe_Large @@ -10263,7 +10321,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Safe_Small,Attribute Scalar_Storage_Order,Attribute Safe_Large,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{14e} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{155} @section Attribute Safe_Small @@ -10276,7 +10334,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Scalar_Storage_Order,Attribute Simple_Storage_Pool,Attribute Safe_Small,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{14f} +@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{156} @section Attribute Scalar_Storage_Order @@ -10393,7 +10451,7 @@ representation. It has no effect on the representation used by stream attributes. @node Attribute Simple_Storage_Pool,Attribute Small,Attribute Scalar_Storage_Order,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{b7}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{150} +@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{b8}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{157} @section Attribute Simple_Storage_Pool @@ -10456,7 +10514,7 @@ as defined in section 13.11.2 of the Ada Reference Manual, except that the term 'simple storage pool' is substituted for 'storage pool'. @node Attribute Small,Attribute Storage_Unit,Attribute Simple_Storage_Pool,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{151} +@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{158} @section Attribute Small @@ -10472,7 +10530,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute when applied to floating-point types. @node Attribute Storage_Unit,Attribute Stub_Type,Attribute Small,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{152} +@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{159} @section Attribute Storage_Unit @@ -10482,7 +10540,7 @@ this attribute when applied to floating-point types. prefix) provides the same value as @cite{System.Storage_Unit}. @node Attribute Stub_Type,Attribute System_Allocator_Alignment,Attribute Storage_Unit,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{153} +@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{15a} @section Attribute Stub_Type @@ -10506,7 +10564,7 @@ unit @cite{System.Partition_Interface}. Use of this attribute will create an implicit dependency on this unit. @node Attribute System_Allocator_Alignment,Attribute Target_Name,Attribute Stub_Type,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{154} +@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{15b} @section Attribute System_Allocator_Alignment @@ -10523,7 +10581,7 @@ with alignment too large or to enable a realignment circuitry if the alignment request is larger than this value. @node Attribute Target_Name,Attribute To_Address,Attribute System_Allocator_Alignment,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{155} +@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{15c} @section Attribute Target_Name @@ -10536,7 +10594,7 @@ standard gcc target name without the terminating slash (for example, GNAT 5.0 on windows yields "i586-pc-mingw32msv"). @node Attribute To_Address,Attribute To_Any,Attribute Target_Name,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{156} +@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{15d} @section Attribute To_Address @@ -10551,7 +10609,7 @@ a static expression, then the result of the attribute is a static expression. This means that such an expression can be used in contexts (e.g., preelaborable packages) which require a static expression and where the function call could not be used -(since the function call is always non-static, even if its +(since the function call is always nonstatic, even if its argument is static). The argument must be in the range -(2**(m-1) .. 2**m-1, where m is the memory size (typically 32 or 64). Negative values are intepreted in a @@ -10559,7 +10617,7 @@ modular manner (e.g., -1 means the same as 16#FFFF_FFFF# on a 32 bits machine). @node Attribute To_Any,Attribute Type_Class,Attribute To_Address,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{157} +@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{15e} @section Attribute To_Any @@ -10569,7 +10627,7 @@ This internal attribute is used for the generation of remote subprogram stubs in the context of the Distributed Systems Annex. @node Attribute Type_Class,Attribute Type_Key,Attribute To_Any,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{158} +@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{15f} @section Attribute Type_Class @@ -10599,7 +10657,7 @@ applies to all concurrent types. This attribute is designed to be compatible with the DEC Ada 83 attribute of the same name. @node Attribute Type_Key,Attribute TypeCode,Attribute Type_Class,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{159} +@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{160} @section Attribute Type_Key @@ -10610,8 +10668,8 @@ yields a value of type Standard.String containing encoded information about the type or subtype. This provides improved compatibility with other implementations that support this attribute. -@node Attribute TypeCode,Attribute UET_Address,Attribute Type_Key,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{15a} +@node Attribute TypeCode,Attribute Unconstrained_Array,Attribute Type_Key,Implementation Defined Attributes +@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{161} @section Attribute TypeCode @@ -10620,22 +10678,8 @@ other implementations that support this attribute. This internal attribute is used for the generation of remote subprogram stubs in the context of the Distributed Systems Annex. -@node Attribute UET_Address,Attribute Unconstrained_Array,Attribute TypeCode,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-uet-address}@anchor{15b} -@section Attribute UET_Address - - -@geindex UET_Address - -The @cite{UET_Address} attribute can only be used for a prefix which -denotes a library package. It yields the address of the unit exception -table when zero cost exception handling is used. This attribute is -intended only for use within the GNAT implementation. See the unit -@cite{Ada.Exceptions} in files @code{a-except.ads} and @code{a-except.adb} -for details on how this attribute is used in the implementation. - -@node Attribute Unconstrained_Array,Attribute Universal_Literal_String,Attribute UET_Address,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{15c} +@node Attribute Unconstrained_Array,Attribute Universal_Literal_String,Attribute TypeCode,Implementation Defined Attributes +@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{162} @section Attribute Unconstrained_Array @@ -10649,7 +10693,7 @@ still static, and yields the result of applying this test to the generic actual. @node Attribute Universal_Literal_String,Attribute Unrestricted_Access,Attribute Unconstrained_Array,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{15d} +@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{163} @section Attribute Universal_Literal_String @@ -10677,7 +10721,7 @@ end; @end example @node Attribute Unrestricted_Access,Attribute Update,Attribute Universal_Literal_String,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{15e} +@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{164} @section Attribute Unrestricted_Access @@ -10864,7 +10908,7 @@ In general this is a risky approach. It may appear to "work" but such uses of of @cite{GNAT} to another, so are best avoided if possible. @node Attribute Update,Attribute Valid_Scalars,Attribute Unrestricted_Access,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{15f} +@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{165} @section Attribute Update @@ -10945,7 +10989,7 @@ A := A'Update ((1, 2) => 20, (3, 4) => 30); which changes element (1,2) to 20 and (3,4) to 30. @node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Update,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{160} +@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{166} @section Attribute Valid_Scalars @@ -10980,7 +11024,7 @@ to write a function with a single use of the attribute, and then call that function from multiple places. @node Attribute VADS_Size,Attribute Value_Size,Attribute Valid_Scalars,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{161} +@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{167} @section Attribute VADS_Size @@ -11000,7 +11044,7 @@ gives the result that would be obtained by applying the attribute to the corresponding type. @node Attribute Value_Size,Attribute Wchar_T_Size,Attribute VADS_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{162} +@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{168} @section Attribute Value_Size @@ -11014,7 +11058,7 @@ a value of the given subtype. It is the same as @code{type'Size}, but, unlike @cite{Size}, may be set for non-first subtypes. @node Attribute Wchar_T_Size,Attribute Word_Size,Attribute Value_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{163} +@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{169} @section Attribute Wchar_T_Size @@ -11026,7 +11070,7 @@ primarily for constructing the definition of this type in package @cite{Interfaces.C}. The result is a static constant. @node Attribute Word_Size,,Attribute Wchar_T_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{164} +@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{16a} @section Attribute Word_Size @@ -11037,7 +11081,7 @@ prefix) provides the value @cite{System.Word_Size}. The result is a static constant. @node Standard and Implementation Defined Restrictions,Implementation Advice,Implementation Defined Attributes,Top -@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9}@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{165}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{166} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9}@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{16b}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{16c} @chapter Standard and Implementation Defined Restrictions @@ -11066,7 +11110,7 @@ language defined or GNAT-specific, are listed in the following. @end menu @node Partition-Wide Restrictions,Program Unit Level Restrictions,,Standard and Implementation Defined Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{167}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{168} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{16d}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{16e} @section Partition-Wide Restrictions @@ -11089,6 +11133,7 @@ then all compilation units in the partition must obey the restriction). * No_Access_Subprograms:: * No_Allocators:: * No_Anonymous_Allocators:: +* No_Asynchronous_Control:: * No_Calendar:: * No_Coextensions:: * No_Default_Initialization:: @@ -11112,6 +11157,8 @@ then all compilation units in the partition must obey the restriction). * No_Implicit_Dynamic_Code:: * No_Implicit_Heap_Allocations:: * No_Implicit_Loops:: +* No_Implicit_Protected_Object_Allocations:: +* No_Implicit_Task_Allocations:: * No_Initialize_Scalars:: * No_IO:: * No_Local_Allocators:: @@ -11135,12 +11182,15 @@ then all compilation units in the partition must obey the restriction). * No_Stream_Optimizations:: * No_Streams:: * No_Task_Allocators:: +* No_Task_At_Interrupt_Priority:: * No_Task_Attributes_Package:: * No_Task_Hierarchy:: * No_Task_Termination:: * No_Tasking:: * No_Terminate_Alternatives:: * No_Unchecked_Access:: +* No_Unchecked_Conversion:: +* No_Unchecked_Deallocation:: * No_Use_Of_Entity:: * Simple_Barriers:: * Static_Priorities:: @@ -11149,7 +11199,7 @@ then all compilation units in the partition must obey the restriction). @end menu @node Immediate_Reclamation,Max_Asynchronous_Select_Nesting,,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{169} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{16f} @subsection Immediate_Reclamation @@ -11161,7 +11211,7 @@ deallocation, any storage reserved at run time for an object is immediately reclaimed when the object no longer exists. @node Max_Asynchronous_Select_Nesting,Max_Entry_Queue_Length,Immediate_Reclamation,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{16a} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{170} @subsection Max_Asynchronous_Select_Nesting @@ -11173,7 +11223,7 @@ detected at compile time. Violations of this restriction with values other than zero cause Storage_Error to be raised. @node Max_Entry_Queue_Length,Max_Protected_Entries,Max_Asynchronous_Select_Nesting,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{16b} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{171} @subsection Max_Entry_Queue_Length @@ -11194,7 +11244,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node Max_Protected_Entries,Max_Select_Alternatives,Max_Entry_Queue_Length,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{16c} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{172} @subsection Max_Protected_Entries @@ -11205,7 +11255,7 @@ bounds of every entry family of a protected unit shall be static, or shall be defined by a discriminant of a subtype whose corresponding bound is static. @node Max_Select_Alternatives,Max_Storage_At_Blocking,Max_Protected_Entries,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{16d} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{173} @subsection Max_Select_Alternatives @@ -11214,7 +11264,7 @@ defined by a discriminant of a subtype whose corresponding bound is static. [RM D.7] Specifies the maximum number of alternatives in a selective accept. @node Max_Storage_At_Blocking,Max_Task_Entries,Max_Select_Alternatives,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{16e} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{174} @subsection Max_Storage_At_Blocking @@ -11225,7 +11275,7 @@ Storage_Size that can be retained by a blocked task. A violation of this restriction causes Storage_Error to be raised. @node Max_Task_Entries,Max_Tasks,Max_Storage_At_Blocking,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{16f} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{175} @subsection Max_Task_Entries @@ -11238,7 +11288,7 @@ defined by a discriminant of a subtype whose corresponding bound is static. @node Max_Tasks,No_Abort_Statements,Max_Task_Entries,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{170} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{176} @subsection Max_Tasks @@ -11251,7 +11301,7 @@ time. Violations of this restriction with values other than zero cause Storage_Error to be raised. @node No_Abort_Statements,No_Access_Parameter_Allocators,Max_Tasks,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{171} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{177} @subsection No_Abort_Statements @@ -11261,7 +11311,7 @@ Storage_Error to be raised. no calls to Task_Identification.Abort_Task. @node No_Access_Parameter_Allocators,No_Access_Subprograms,No_Abort_Statements,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{172} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{178} @subsection No_Access_Parameter_Allocators @@ -11272,7 +11322,7 @@ occurrences of an allocator as the actual parameter to an access parameter. @node No_Access_Subprograms,No_Allocators,No_Access_Parameter_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{173} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{179} @subsection No_Access_Subprograms @@ -11282,7 +11332,7 @@ parameter. declarations of access-to-subprogram types. @node No_Allocators,No_Anonymous_Allocators,No_Access_Subprograms,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{174} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{17a} @subsection No_Allocators @@ -11291,8 +11341,8 @@ declarations of access-to-subprogram types. [RM H.4] This restriction ensures at compile time that there are no occurrences of an allocator. -@node No_Anonymous_Allocators,No_Calendar,No_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{175} +@node No_Anonymous_Allocators,No_Asynchronous_Control,No_Allocators,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{17b} @subsection No_Anonymous_Allocators @@ -11301,18 +11351,28 @@ occurrences of an allocator. [RM H.4] This restriction ensures at compile time that there are no occurrences of an allocator of anonymous access type. -@node No_Calendar,No_Coextensions,No_Anonymous_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{176} +@node No_Asynchronous_Control,No_Calendar,No_Anonymous_Allocators,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{17c} +@subsection No_Asynchronous_Control + + +@geindex No_Asynchronous_Control + +[RM J.13] This restriction ensures at compile time that there are no semantic +dependences on the predefined package Asynchronous_Task_Control. + +@node No_Calendar,No_Coextensions,No_Asynchronous_Control,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{17d} @subsection No_Calendar @geindex No_Calendar -[GNAT] This restriction ensures at compile time that there is no implicit or -explicit dependence on the package @cite{Ada.Calendar}. +[GNAT] This restriction ensures at compile time that there are no semantic +dependences on package Calendar. @node No_Coextensions,No_Default_Initialization,No_Calendar,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{177} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{17e} @subsection No_Coextensions @@ -11322,7 +11382,7 @@ explicit dependence on the package @cite{Ada.Calendar}. coextensions. See 3.10.2. @node No_Default_Initialization,No_Delay,No_Coextensions,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{178} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{17f} @subsection No_Default_Initialization @@ -11339,27 +11399,27 @@ is to prohibit all cases of variables declared without a specific initializer (including the case of OUT scalar parameters). @node No_Delay,No_Dependence,No_Default_Initialization,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{179} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{180} @subsection No_Delay @geindex No_Delay [RM H.4] This restriction ensures at compile time that there are no -delay statements and no dependences on package Calendar. +delay statements and no semantic dependences on package Calendar. @node No_Dependence,No_Direct_Boolean_Operators,No_Delay,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{17a} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{181} @subsection No_Dependence @geindex No_Dependence -[RM 13.12.1] This restriction checks at compile time that there are no -dependence on a library unit. +[RM 13.12.1] This restriction ensures at compile time that there are no +dependences on a library unit. @node No_Direct_Boolean_Operators,No_Dispatch,No_Dependence,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{17b} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{182} @subsection No_Direct_Boolean_Operators @@ -11372,7 +11432,7 @@ protocol requires the use of short-circuit (and then, or else) forms for all composite boolean operations. @node No_Dispatch,No_Dispatching_Calls,No_Direct_Boolean_Operators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{17c} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{183} @subsection No_Dispatch @@ -11382,7 +11442,7 @@ composite boolean operations. occurrences of @cite{T'Class}, for any (tagged) subtype @cite{T}. @node No_Dispatching_Calls,No_Dynamic_Attachment,No_Dispatch,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{17d} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{184} @subsection No_Dispatching_Calls @@ -11443,7 +11503,7 @@ end Example; @end example @node No_Dynamic_Attachment,No_Dynamic_Priorities,No_Dispatching_Calls,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{17e} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{185} @subsection No_Dynamic_Attachment @@ -11462,7 +11522,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node No_Dynamic_Priorities,No_Entry_Calls_In_Elaboration_Code,No_Dynamic_Attachment,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{17f} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{186} @subsection No_Dynamic_Priorities @@ -11471,7 +11531,7 @@ warnings on obsolescent features are activated). [RM D.7] There are no semantic dependencies on the package Dynamic_Priorities. @node No_Entry_Calls_In_Elaboration_Code,No_Enumeration_Maps,No_Dynamic_Priorities,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{180} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{187} @subsection No_Entry_Calls_In_Elaboration_Code @@ -11483,7 +11543,7 @@ restriction, the compiler can assume that no code past an accept statement in a task can be executed at elaboration time. @node No_Enumeration_Maps,No_Exception_Handlers,No_Entry_Calls_In_Elaboration_Code,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{181} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{188} @subsection No_Enumeration_Maps @@ -11494,7 +11554,7 @@ enumeration maps are used (that is Image and Value attributes applied to enumeration types). @node No_Exception_Handlers,No_Exception_Propagation,No_Enumeration_Maps,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{182} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{189} @subsection No_Exception_Handlers @@ -11519,7 +11579,7 @@ statement generated by the compiler). The Line parameter when nonzero represents the line number in the source program where the raise occurs. @node No_Exception_Propagation,No_Exception_Registration,No_Exception_Handlers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{183} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{18a} @subsection No_Exception_Propagation @@ -11536,7 +11596,7 @@ the package GNAT.Current_Exception is not permitted, and reraise statements (raise with no operand) are not permitted. @node No_Exception_Registration,No_Exceptions,No_Exception_Propagation,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{184} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{18b} @subsection No_Exception_Registration @@ -11550,7 +11610,7 @@ code is simplified by omitting the otherwise-required global registration of exceptions when they are declared. @node No_Exceptions,No_Finalization,No_Exception_Registration,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{185} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{18c} @subsection No_Exceptions @@ -11560,7 +11620,7 @@ of exceptions when they are declared. raise statements and no exception handlers. @node No_Finalization,No_Fixed_Point,No_Exceptions,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{186} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{18d} @subsection No_Finalization @@ -11601,7 +11661,7 @@ object or a nested component, either declared on the stack or on the heap. The deallocation of a controlled object no longer finalizes its contents. @node No_Fixed_Point,No_Floating_Point,No_Finalization,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{187} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{18e} @subsection No_Fixed_Point @@ -11611,7 +11671,7 @@ deallocation of a controlled object no longer finalizes its contents. occurrences of fixed point types and operations. @node No_Floating_Point,No_Implicit_Conditionals,No_Fixed_Point,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{188} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{18f} @subsection No_Floating_Point @@ -11621,7 +11681,7 @@ occurrences of fixed point types and operations. occurrences of floating point types and operations. @node No_Implicit_Conditionals,No_Implicit_Dynamic_Code,No_Floating_Point,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{189} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{190} @subsection No_Implicit_Conditionals @@ -11637,7 +11697,7 @@ normal manner. Constructs generating implicit conditionals include comparisons of composite objects and the Max/Min attributes. @node No_Implicit_Dynamic_Code,No_Implicit_Heap_Allocations,No_Implicit_Conditionals,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{18a} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{191} @subsection No_Implicit_Dynamic_Code @@ -11667,7 +11727,7 @@ foreign-language convention; primitive operations of nested tagged types. @node No_Implicit_Heap_Allocations,No_Implicit_Loops,No_Implicit_Dynamic_Code,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{18b} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{192} @subsection No_Implicit_Heap_Allocations @@ -11675,8 +11735,8 @@ types. [RM D.7] No constructs are allowed to cause implicit heap allocation. -@node No_Implicit_Loops,No_Initialize_Scalars,No_Implicit_Heap_Allocations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{18c} +@node No_Implicit_Loops,No_Implicit_Protected_Object_Allocations,No_Implicit_Heap_Allocations,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{193} @subsection No_Implicit_Loops @@ -11692,8 +11752,27 @@ intermediate temporary, and without generating a loop to initialize individual components. Otherwise, a loop is created for arrays larger than about 5000 scalar components. -@node No_Initialize_Scalars,No_IO,No_Implicit_Loops,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{18d} +@node No_Implicit_Protected_Object_Allocations,No_Implicit_Task_Allocations,No_Implicit_Loops,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{194} +@subsection No_Implicit_Protected_Object_Allocations + + +@c index: No_Implicit_Protected_Object_Allocations + +[GNAT] No constructs are allowed to cause implicit heap allocation of a +protected object. + +@node No_Implicit_Task_Allocations,No_Initialize_Scalars,No_Implicit_Protected_Object_Allocations,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{195} +@subsection No_Implicit_Task_Allocations + + +@c index: No_Implicit_Task_Allocations + +[GNAT] No constructs are allowed to cause implicit heap allocation of a task. + +@node No_Initialize_Scalars,No_IO,No_Implicit_Task_Allocations,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{196} @subsection No_Initialize_Scalars @@ -11705,7 +11784,7 @@ code, and in particular eliminates dummy null initialization routines that are otherwise generated for some record and array types. @node No_IO,No_Local_Allocators,No_Initialize_Scalars,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{18e} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{197} @subsection No_IO @@ -11716,7 +11795,7 @@ dependences on any of the library units Sequential_IO, Direct_IO, Text_IO, Wide_Text_IO, Wide_Wide_Text_IO, or Stream_IO. @node No_Local_Allocators,No_Local_Protected_Objects,No_IO,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{18f} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{198} @subsection No_Local_Allocators @@ -11727,7 +11806,7 @@ occurrences of an allocator in subprograms, generic subprograms, tasks, and entry bodies. @node No_Local_Protected_Objects,No_Local_Timing_Events,No_Local_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{190} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{199} @subsection No_Local_Protected_Objects @@ -11737,7 +11816,7 @@ and entry bodies. only declared at the library level. @node No_Local_Timing_Events,No_Long_Long_Integers,No_Local_Protected_Objects,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{191} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{19a} @subsection No_Local_Timing_Events @@ -11747,7 +11826,7 @@ only declared at the library level. declared at the library level. @node No_Long_Long_Integers,No_Multiple_Elaboration,No_Local_Timing_Events,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{192} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{19b} @subsection No_Long_Long_Integers @@ -11759,7 +11838,7 @@ implicit base type is Long_Long_Integer, and modular types whose size exceeds Long_Integer'Size. @node No_Multiple_Elaboration,No_Nested_Finalization,No_Long_Long_Integers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{193} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{19c} @subsection No_Multiple_Elaboration @@ -11780,7 +11859,7 @@ possible, including non-Ada main programs, and Stand Alone libraries, are not permitted, and will be diagnosed by the binder. @node No_Nested_Finalization,No_Protected_Type_Allocators,No_Multiple_Elaboration,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{194} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{19d} @subsection No_Nested_Finalization @@ -11789,7 +11868,7 @@ permitted, and will be diagnosed by the binder. [RM D.7] All objects requiring finalization are declared at the library level. @node No_Protected_Type_Allocators,No_Protected_Types,No_Nested_Finalization,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{195} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{19e} @subsection No_Protected_Type_Allocators @@ -11799,7 +11878,7 @@ permitted, and will be diagnosed by the binder. expressions that attempt to allocate protected objects. @node No_Protected_Types,No_Recursion,No_Protected_Type_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{196} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{19f} @subsection No_Protected_Types @@ -11809,7 +11888,7 @@ expressions that attempt to allocate protected objects. declarations of protected types or protected objects. @node No_Recursion,No_Reentrancy,No_Protected_Types,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{197} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1a0} @subsection No_Recursion @@ -11819,7 +11898,7 @@ declarations of protected types or protected objects. part of its execution. @node No_Reentrancy,No_Relative_Delay,No_Recursion,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{198} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1a1} @subsection No_Reentrancy @@ -11829,7 +11908,7 @@ part of its execution. two tasks at the same time. @node No_Relative_Delay,No_Requeue_Statements,No_Reentrancy,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{199} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1a2} @subsection No_Relative_Delay @@ -11840,7 +11919,7 @@ relative statements and prevents expressions such as @cite{delay 1.23;} from appearing in source code. @node No_Requeue_Statements,No_Secondary_Stack,No_Relative_Delay,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{19a} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1a3} @subsection No_Requeue_Statements @@ -11858,7 +11937,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on oNobsolescent features are activated). @node No_Secondary_Stack,No_Select_Statements,No_Requeue_Statements,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{19b} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1a4} @subsection No_Secondary_Stack @@ -11870,7 +11949,7 @@ stack is used to implement functions returning unconstrained objects (arrays or records) on some targets. @node No_Select_Statements,No_Specific_Termination_Handlers,No_Secondary_Stack,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{19c} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1a5} @subsection No_Select_Statements @@ -11880,7 +11959,7 @@ stack is used to implement functions returning unconstrained objects kind are permitted, that is the keyword @cite{select} may not appear. @node No_Specific_Termination_Handlers,No_Specification_of_Aspect,No_Select_Statements,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{19d} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1a6} @subsection No_Specific_Termination_Handlers @@ -11890,7 +11969,7 @@ kind are permitted, that is the keyword @cite{select} may not appear. or to Ada.Task_Termination.Specific_Handler. @node No_Specification_of_Aspect,No_Standard_Allocators_After_Elaboration,No_Specific_Termination_Handlers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{19e} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1a7} @subsection No_Specification_of_Aspect @@ -11901,7 +11980,7 @@ specification, attribute definition clause, or pragma is given for a given aspect. @node No_Standard_Allocators_After_Elaboration,No_Standard_Storage_Pools,No_Specification_of_Aspect,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{19f} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1a8} @subsection No_Standard_Allocators_After_Elaboration @@ -11913,7 +11992,7 @@ library items of the partition has completed. Otherwise, Storage_Error is raised. @node No_Standard_Storage_Pools,No_Stream_Optimizations,No_Standard_Allocators_After_Elaboration,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1a0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1a9} @subsection No_Standard_Storage_Pools @@ -11925,7 +12004,7 @@ have an explicit Storage_Pool attribute defined specifying a user-defined storage pool. @node No_Stream_Optimizations,No_Streams,No_Standard_Storage_Pools,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1a1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1aa} @subsection No_Stream_Optimizations @@ -11938,7 +12017,7 @@ due to their supperior performance. When this restriction is in effect, the compiler performs all IO operations on a per-character basis. @node No_Streams,No_Task_Allocators,No_Stream_Optimizations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1a2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1ab} @subsection No_Streams @@ -11958,8 +12037,8 @@ To take maximum advantage of this space-saving optimization, any unit declaring a tagged type should be compiled with the restriction, though this is not required. -@node No_Task_Allocators,No_Task_Attributes_Package,No_Streams,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1a3} +@node No_Task_Allocators,No_Task_At_Interrupt_Priority,No_Streams,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1ac} @subsection No_Task_Allocators @@ -11968,8 +12047,20 @@ though this is not required. [RM D.7] There are no allocators for task types or types containing task subcomponents. -@node No_Task_Attributes_Package,No_Task_Hierarchy,No_Task_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1a4} +@node No_Task_At_Interrupt_Priority,No_Task_Attributes_Package,No_Task_Allocators,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1ad} +@subsection No_Task_At_Interrupt_Priority + + +@geindex No_Task_At_Interrupt_Priority + +[GNAT] This restriction ensures at compile time that there is no +Interrupt_Priority aspect or pragma for a task or a task type. As +a consequence, the tasks are always created with a priority below +that an interrupt priority. + +@node No_Task_Attributes_Package,No_Task_Hierarchy,No_Task_At_Interrupt_Priority,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1ae} @subsection No_Task_Attributes_Package @@ -11986,7 +12077,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node No_Task_Hierarchy,No_Task_Termination,No_Task_Attributes_Package,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1a5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1af} @subsection No_Task_Hierarchy @@ -11996,7 +12087,7 @@ warnings on obsolescent features are activated). directly on the environment task of the partition. @node No_Task_Termination,No_Tasking,No_Task_Hierarchy,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1a6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1b0} @subsection No_Task_Termination @@ -12005,7 +12096,7 @@ directly on the environment task of the partition. [RM D.7] Tasks that terminate are erroneous. @node No_Tasking,No_Terminate_Alternatives,No_Task_Termination,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1a7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1b1} @subsection No_Tasking @@ -12018,7 +12109,7 @@ and cause an error message to be output either by the compiler or binder. @node No_Terminate_Alternatives,No_Unchecked_Access,No_Tasking,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1a8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1b2} @subsection No_Terminate_Alternatives @@ -12026,8 +12117,8 @@ binder. [RM D.7] There are no selective accepts with terminate alternatives. -@node No_Unchecked_Access,No_Use_Of_Entity,No_Terminate_Alternatives,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1a9} +@node No_Unchecked_Access,No_Unchecked_Conversion,No_Terminate_Alternatives,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1b3} @subsection No_Unchecked_Access @@ -12036,8 +12127,28 @@ binder. [RM H.4] This restriction ensures at compile time that there are no occurrences of the Unchecked_Access attribute. -@node No_Use_Of_Entity,Simple_Barriers,No_Unchecked_Access,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{1aa} +@node No_Unchecked_Conversion,No_Unchecked_Deallocation,No_Unchecked_Access,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1b4} +@subsection No_Unchecked_Conversion + + +@geindex No_Unchecked_Conversion + +[RM J.13] This restriction ensures at compile time that there are no semantic +dependences on the predefined generic function Unchecked_Conversion. + +@node No_Unchecked_Deallocation,No_Use_Of_Entity,No_Unchecked_Conversion,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1b5} +@subsection No_Unchecked_Deallocation + + +@geindex No_Unchecked_Deallocation + +[RM J.13] This restriction ensures at compile time that there are no semantic +dependences on the predefined generic procedure Unchecked_Deallocation. + +@node No_Use_Of_Entity,Simple_Barriers,No_Unchecked_Deallocation,Partition-Wide Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{1b6} @subsection No_Use_Of_Entity @@ -12057,7 +12168,7 @@ No_Use_Of_Entity => Ada.Text_IO.Put_Line @end example @node Simple_Barriers,Static_Priorities,No_Use_Of_Entity,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{1ab} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{1b7} @subsection Simple_Barriers @@ -12076,7 +12187,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node Static_Priorities,Static_Storage_Size,Simple_Barriers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{1ac} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{1b8} @subsection Static_Priorities @@ -12087,7 +12198,7 @@ are static, and that there are no dependences on the package @cite{Ada.Dynamic_Priorities}. @node Static_Storage_Size,,Static_Priorities,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{1ad} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{1b9} @subsection Static_Storage_Size @@ -12097,7 +12208,7 @@ are static, and that there are no dependences on the package in a Storage_Size pragma or attribute definition clause is static. @node Program Unit Level Restrictions,,Partition-Wide Restrictions,Standard and Implementation Defined Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{1ae}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{1af} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{1ba}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{1bb} @section Program Unit Level Restrictions @@ -12124,7 +12235,7 @@ other compilation units in the partition. @end menu @node No_Elaboration_Code,No_Entry_Queue,,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{1b0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{1bc} @subsection No_Elaboration_Code @@ -12174,7 +12285,7 @@ code generation. If it is used in conjunction with "semantics only" checking, then some cases of violations may be missed. @node No_Entry_Queue,No_Implementation_Aspect_Specifications,No_Elaboration_Code,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{1b1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{1bd} @subsection No_Entry_Queue @@ -12187,7 +12298,7 @@ checked at compile time. A program execution is erroneous if an attempt is made to queue a second task on such an entry. @node No_Implementation_Aspect_Specifications,No_Implementation_Attributes,No_Entry_Queue,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{1b2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{1be} @subsection No_Implementation_Aspect_Specifications @@ -12198,7 +12309,7 @@ GNAT-defined aspects are present. With this restriction, the only aspects that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Attributes,No_Implementation_Identifiers,No_Implementation_Aspect_Specifications,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{1b3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{1bf} @subsection No_Implementation_Attributes @@ -12210,7 +12321,7 @@ attributes that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Identifiers,No_Implementation_Pragmas,No_Implementation_Attributes,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{1b4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{1c0} @subsection No_Implementation_Identifiers @@ -12221,7 +12332,7 @@ implementation-defined identifiers (marked with pragma Implementation_Defined) occur within language-defined packages. @node No_Implementation_Pragmas,No_Implementation_Restrictions,No_Implementation_Identifiers,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{1b5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{1c1} @subsection No_Implementation_Pragmas @@ -12232,7 +12343,7 @@ GNAT-defined pragmas are present. With this restriction, the only pragmas that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Restrictions,No_Implementation_Units,No_Implementation_Pragmas,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{1b6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{1c2} @subsection No_Implementation_Restrictions @@ -12244,7 +12355,7 @@ are present. With this restriction, the only other restriction identifiers that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Units,No_Implicit_Aliasing,No_Implementation_Restrictions,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{1b7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{1c3} @subsection No_Implementation_Units @@ -12255,7 +12366,7 @@ mention in the context clause of any implementation-defined descendants of packages Ada, Interfaces, or System. @node No_Implicit_Aliasing,No_Obsolescent_Features,No_Implementation_Units,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{1b8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{1c4} @subsection No_Implicit_Aliasing @@ -12270,7 +12381,7 @@ to be aliased, and in such cases, it can always be replaced by the standard attribute Unchecked_Access which is preferable. @node No_Obsolescent_Features,No_Wide_Characters,No_Implicit_Aliasing,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{1b9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{1c5} @subsection No_Obsolescent_Features @@ -12280,7 +12391,7 @@ the standard attribute Unchecked_Access which is preferable. features are used, as defined in Annex J of the Ada Reference Manual. @node No_Wide_Characters,SPARK_05,No_Obsolescent_Features,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{1ba} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{1c6} @subsection No_Wide_Characters @@ -12294,7 +12405,7 @@ appear in the program (that is literals representing characters not in type @cite{Character}). @node SPARK_05,,No_Wide_Characters,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{1bb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{1c7} @subsection SPARK_05 @@ -12454,7 +12565,7 @@ No use clause Aggregates must be qualified @item -Non-static choice in array aggregates not allowed +Nonstatic choice in array aggregates not allowed @item The only view conversions which are allowed as in-out parameters are conversions of a tagged type to an ancestor type @@ -12517,7 +12628,7 @@ No class-wide operations Initialization expressions must respect SPARK restrictions @item -Non-static ranges not allowed except in iteration schemes +Nonstatic ranges not allowed except in iteration schemes @item String subtypes must have lower bound of 1 @@ -12653,7 +12764,7 @@ violations will be reported for constructs forbidden in SPARK 95, instead of SPARK 2005. @node Implementation Advice,Implementation Defined Characteristics,Standard and Implementation Defined Restrictions,Top -@anchor{gnat_rm/implementation_advice doc}@anchor{1bc}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}@anchor{gnat_rm/implementation_advice id1}@anchor{1bd} +@anchor{gnat_rm/implementation_advice doc}@anchor{1c8}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}@anchor{gnat_rm/implementation_advice id1}@anchor{1c9} @chapter Implementation Advice @@ -12750,7 +12861,7 @@ case the text describes what GNAT does and why. @end menu @node RM 1 1 3 20 Error Detection,RM 1 1 3 31 Child Units,,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{1be} +@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{1ca} @section RM 1.1.3(20): Error Detection @@ -12767,7 +12878,7 @@ or diagnosed at compile time. @geindex Child Units @node RM 1 1 3 31 Child Units,RM 1 1 5 12 Bounded Errors,RM 1 1 3 20 Error Detection,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{1bf} +@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{1cb} @section RM 1.1.3(31): Child Units @@ -12783,7 +12894,7 @@ Followed. @geindex Bounded errors @node RM 1 1 5 12 Bounded Errors,RM 2 8 16 Pragmas,RM 1 1 3 31 Child Units,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{1c0} +@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{1cc} @section RM 1.1.5(12): Bounded Errors @@ -12800,7 +12911,7 @@ runtime. @geindex Pragmas @node RM 2 8 16 Pragmas,RM 2 8 17-19 Pragmas,RM 1 1 5 12 Bounded Errors,Implementation Advice -@anchor{gnat_rm/implementation_advice id2}@anchor{1c1}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{1c2} +@anchor{gnat_rm/implementation_advice id2}@anchor{1cd}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{1ce} @section RM 2.8(16): Pragmas @@ -12913,7 +13024,7 @@ that this advice not be followed. For details see @ref{7,,Implementation Defined Pragmas}. @node RM 2 8 17-19 Pragmas,RM 3 5 2 5 Alternative Character Sets,RM 2 8 16 Pragmas,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{1c3} +@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{1cf} @section RM 2.8(17-19): Pragmas @@ -12934,14 +13045,14 @@ replacing @cite{library_items}." @end itemize @end quotation -See @ref{1c2,,RM 2.8(16); Pragmas}. +See @ref{1ce,,RM 2.8(16); Pragmas}. @geindex Character Sets @geindex Alternative Character Sets @node RM 3 5 2 5 Alternative Character Sets,RM 3 5 4 28 Integer Types,RM 2 8 17-19 Pragmas,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{1c4} +@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{1d0} @section RM 3.5.2(5): Alternative Character Sets @@ -12969,7 +13080,7 @@ there is no such restriction. @geindex Integer types @node RM 3 5 4 28 Integer Types,RM 3 5 4 29 Integer Types,RM 3 5 2 5 Alternative Character Sets,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{1c5} +@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{1d1} @section RM 3.5.4(28): Integer Types @@ -12988,7 +13099,7 @@ are supported for convenient interface to C, and so that all hardware types of the machine are easily available. @node RM 3 5 4 29 Integer Types,RM 3 5 5 8 Enumeration Values,RM 3 5 4 28 Integer Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{1c6} +@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{1d2} @section RM 3.5.4(29): Integer Types @@ -13004,7 +13115,7 @@ Followed. @geindex Enumeration values @node RM 3 5 5 8 Enumeration Values,RM 3 5 7 17 Float Types,RM 3 5 4 29 Integer Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{1c7} +@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{1d3} @section RM 3.5.5(8): Enumeration Values @@ -13024,7 +13135,7 @@ Followed. @geindex Float types @node RM 3 5 7 17 Float Types,RM 3 6 2 11 Multidimensional Arrays,RM 3 5 5 8 Enumeration Values,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{1c8} +@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{1d4} @section RM 3.5.7(17): Float Types @@ -13054,7 +13165,7 @@ since this is a software rather than a hardware format. @geindex multidimensional @node RM 3 6 2 11 Multidimensional Arrays,RM 9 6 30-31 Duration'Small,RM 3 5 7 17 Float Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{1c9} +@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{1d5} @section RM 3.6.2(11): Multidimensional Arrays @@ -13072,7 +13183,7 @@ Followed. @geindex Duration'Small @node RM 9 6 30-31 Duration'Small,RM 10 2 1 12 Consistent Representation,RM 3 6 2 11 Multidimensional Arrays,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{1ca} +@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{1d6} @section RM 9.6(30-31): Duration'Small @@ -13093,7 +13204,7 @@ it need not be the same time base as used for @cite{Calendar.Clock}." Followed. @node RM 10 2 1 12 Consistent Representation,RM 11 4 1 19 Exception Information,RM 9 6 30-31 Duration'Small,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{1cb} +@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{1d7} @section RM 10.2.1(12): Consistent Representation @@ -13115,7 +13226,7 @@ advice without severely impacting efficiency of execution. @geindex Exception information @node RM 11 4 1 19 Exception Information,RM 11 5 28 Suppression of Checks,RM 10 2 1 12 Consistent Representation,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{1cc} +@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{1d8} @section RM 11.4.1(19): Exception Information @@ -13146,7 +13257,7 @@ Pragma @cite{Discard_Names}. @geindex suppression of @node RM 11 5 28 Suppression of Checks,RM 13 1 21-24 Representation Clauses,RM 11 4 1 19 Exception Information,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{1cd} +@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{1d9} @section RM 11.5(28): Suppression of Checks @@ -13161,7 +13272,7 @@ Followed. @geindex Representation clauses @node RM 13 1 21-24 Representation Clauses,RM 13 2 6-8 Packed Types,RM 11 5 28 Suppression of Checks,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{1ce} +@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{1da} @section RM 13.1 (21-24): Representation Clauses @@ -13171,8 +13282,8 @@ Followed. qualified as follows: An implementation need not support representation items containing -non-static expressions, except that an implementation should support a -representation item for a given entity if each non-static expression in +nonstatic expressions, except that an implementation should support a +representation item for a given entity if each nonstatic expression in the representation item is a name that statically denotes a constant declared before the entity." @end quotation @@ -13196,7 +13307,7 @@ constraints on the subtype and its composite subcomponents (if any) are all static constraints." @end example -Followed. Size Clauses are not permitted on non-static components, as +Followed. Size Clauses are not permitted on nonstatic components, as described above. @quotation @@ -13210,7 +13321,7 @@ Followed. @geindex Packed types @node RM 13 2 6-8 Packed Types,RM 13 3 14-19 Address Clauses,RM 13 1 21-24 Representation Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{1cf} +@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{1db} @section RM 13.2(6-8): Packed Types @@ -13249,7 +13360,7 @@ Followed. @geindex Address clauses @node RM 13 3 14-19 Address Clauses,RM 13 3 29-35 Alignment Clauses,RM 13 2 6-8 Packed Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{1d0} +@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{1dc} @section RM 13.3(14-19): Address Clauses @@ -13302,7 +13413,7 @@ Followed. @geindex Alignment clauses @node RM 13 3 29-35 Alignment Clauses,RM 13 3 42-43 Size Clauses,RM 13 3 14-19 Address Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{1d1} +@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{1dd} @section RM 13.3(29-35): Alignment Clauses @@ -13359,7 +13470,7 @@ Followed. @geindex Size clauses @node RM 13 3 42-43 Size Clauses,RM 13 3 50-56 Size Clauses,RM 13 3 29-35 Alignment Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{1d2} +@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{1de} @section RM 13.3(42-43): Size Clauses @@ -13377,7 +13488,7 @@ object's @cite{Alignment} (if the @cite{Alignment} is nonzero)." Followed. @node RM 13 3 50-56 Size Clauses,RM 13 3 71-73 Component Size Clauses,RM 13 3 42-43 Size Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{1d3} +@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{1df} @section RM 13.3(50-56): Size Clauses @@ -13428,7 +13539,7 @@ Followed. @geindex Component_Size clauses @node RM 13 3 71-73 Component Size Clauses,RM 13 4 9-10 Enumeration Representation Clauses,RM 13 3 50-56 Size Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{1d4} +@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{1e0} @section RM 13.3(71-73): Component Size Clauses @@ -13462,7 +13573,7 @@ Followed. @geindex enumeration @node RM 13 4 9-10 Enumeration Representation Clauses,RM 13 5 1 17-22 Record Representation Clauses,RM 13 3 71-73 Component Size Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{1d5} +@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{1e1} @section RM 13.4(9-10): Enumeration Representation Clauses @@ -13484,7 +13595,7 @@ Followed. @geindex records @node RM 13 5 1 17-22 Record Representation Clauses,RM 13 5 2 5 Storage Place Attributes,RM 13 4 9-10 Enumeration Representation Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{1d6} +@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{1e2} @section RM 13.5.1(17-22): Record Representation Clauses @@ -13544,7 +13655,7 @@ and all mentioned features are implemented. @geindex Storage place attributes @node RM 13 5 2 5 Storage Place Attributes,RM 13 5 3 7-8 Bit Ordering,RM 13 5 1 17-22 Record Representation Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{1d7} +@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{1e3} @section RM 13.5.2(5): Storage Place Attributes @@ -13564,7 +13675,7 @@ Followed. There are no such components in GNAT. @geindex Bit ordering @node RM 13 5 3 7-8 Bit Ordering,RM 13 7 37 Address as Private,RM 13 5 2 5 Storage Place Attributes,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{1d8} +@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{1e4} @section RM 13.5.3(7-8): Bit Ordering @@ -13584,7 +13695,7 @@ Thus non-default bit ordering is not supported. @geindex as private type @node RM 13 7 37 Address as Private,RM 13 7 1 16 Address Operations,RM 13 5 3 7-8 Bit Ordering,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{1d9} +@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{1e5} @section RM 13.7(37): Address as Private @@ -13602,7 +13713,7 @@ Followed. @geindex operations of @node RM 13 7 1 16 Address Operations,RM 13 9 14-17 Unchecked Conversion,RM 13 7 37 Address as Private,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{1da} +@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{1e6} @section RM 13.7.1(16): Address Operations @@ -13620,7 +13731,7 @@ operation raises @cite{Program_Error}, since all operations make sense. @geindex Unchecked conversion @node RM 13 9 14-17 Unchecked Conversion,RM 13 11 23-25 Implicit Heap Usage,RM 13 7 1 16 Address Operations,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{1db} +@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{1e7} @section RM 13.9(14-17): Unchecked Conversion @@ -13664,7 +13775,7 @@ Followed. @geindex implicit @node RM 13 11 23-25 Implicit Heap Usage,RM 13 11 2 17 Unchecked Deallocation,RM 13 9 14-17 Unchecked Conversion,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{1dc} +@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{1e8} @section RM 13.11(23-25): Implicit Heap Usage @@ -13715,7 +13826,7 @@ Followed. @geindex Unchecked deallocation @node RM 13 11 2 17 Unchecked Deallocation,RM 13 13 2 17 Stream Oriented Attributes,RM 13 11 23-25 Implicit Heap Usage,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{1dd} +@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{1e9} @section RM 13.11.2(17): Unchecked Deallocation @@ -13730,7 +13841,7 @@ Followed. @geindex Stream oriented attributes @node RM 13 13 2 17 Stream Oriented Attributes,RM A 1 52 Names of Predefined Numeric Types,RM 13 11 2 17 Unchecked Deallocation,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-13-2-17-stream-oriented-attributes}@anchor{1de} +@anchor{gnat_rm/implementation_advice rm-13-13-2-17-stream-oriented-attributes}@anchor{1ea} @section RM 13.13.2(17): Stream Oriented Attributes @@ -13785,7 +13896,7 @@ the @cite{GNAT and Libraries} section of the @cite{GNAT User's Guide}. @end itemize @node RM A 1 52 Names of Predefined Numeric Types,RM A 3 2 49 Ada Characters Handling,RM 13 13 2 17 Stream Oriented Attributes,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{1df} +@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{1eb} @section RM A.1(52): Names of Predefined Numeric Types @@ -13803,7 +13914,7 @@ Followed. @geindex Ada.Characters.Handling @node RM A 3 2 49 Ada Characters Handling,RM A 4 4 106 Bounded-Length String Handling,RM A 1 52 Names of Predefined Numeric Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{1e0} +@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{1ec} @section RM A.3.2(49): @cite{Ada.Characters.Handling} @@ -13820,7 +13931,7 @@ Followed. GNAT provides no such localized definitions. @geindex Bounded-length strings @node RM A 4 4 106 Bounded-Length String Handling,RM A 5 2 46-47 Random Number Generation,RM A 3 2 49 Ada Characters Handling,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{1e1} +@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{1ed} @section RM A.4.4(106): Bounded-Length String Handling @@ -13835,7 +13946,7 @@ Followed. No implicit pointers or dynamic allocation are used. @geindex Random number generation @node RM A 5 2 46-47 Random Number Generation,RM A 10 7 23 Get_Immediate,RM A 4 4 106 Bounded-Length String Handling,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{1e2} +@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{1ee} @section RM A.5.2(46-47): Random Number Generation @@ -13864,7 +13975,7 @@ condition here to hold true. @geindex Get_Immediate @node RM A 10 7 23 Get_Immediate,RM B 1 39-41 Pragma Export,RM A 5 2 46-47 Random Number Generation,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{1e3} +@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{1ef} @section RM A.10.7(23): @cite{Get_Immediate} @@ -13888,7 +13999,7 @@ this functionality. @geindex Export @node RM B 1 39-41 Pragma Export,RM B 2 12-13 Package Interfaces,RM A 10 7 23 Get_Immediate,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{1e4} +@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{1f0} @section RM B.1(39-41): Pragma @cite{Export} @@ -13936,7 +14047,7 @@ Followed. @geindex Interfaces @node RM B 2 12-13 Package Interfaces,RM B 3 63-71 Interfacing with C,RM B 1 39-41 Pragma Export,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{1e5} +@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{1f1} @section RM B.2(12-13): Package @cite{Interfaces} @@ -13966,7 +14077,7 @@ Followed. GNAT provides all the packages described in this section. @geindex interfacing with @node RM B 3 63-71 Interfacing with C,RM B 4 95-98 Interfacing with COBOL,RM B 2 12-13 Package Interfaces,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{1e6} +@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{1f2} @section RM B.3(63-71): Interfacing with C @@ -14054,7 +14165,7 @@ Followed. @geindex interfacing with @node RM B 4 95-98 Interfacing with COBOL,RM B 5 22-26 Interfacing with Fortran,RM B 3 63-71 Interfacing with C,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{1e7} +@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{1f3} @section RM B.4(95-98): Interfacing with COBOL @@ -14095,7 +14206,7 @@ Followed. @geindex interfacing with @node RM B 5 22-26 Interfacing with Fortran,RM C 1 3-5 Access to Machine Operations,RM B 4 95-98 Interfacing with COBOL,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{1e8} +@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{1f4} @section RM B.5(22-26): Interfacing with Fortran @@ -14146,7 +14257,7 @@ Followed. @geindex Machine operations @node RM C 1 3-5 Access to Machine Operations,RM C 1 10-16 Access to Machine Operations,RM B 5 22-26 Interfacing with Fortran,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{1e9} +@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{1f5} @section RM C.1(3-5): Access to Machine Operations @@ -14181,7 +14292,7 @@ object that is specified as exported." Followed. @node RM C 1 10-16 Access to Machine Operations,RM C 3 28 Interrupt Support,RM C 1 3-5 Access to Machine Operations,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{1ea} +@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{1f6} @section RM C.1(10-16): Access to Machine Operations @@ -14242,7 +14353,7 @@ Followed on any target supporting such operations. @geindex Interrupt support @node RM C 3 28 Interrupt Support,RM C 3 1 20-21 Protected Procedure Handlers,RM C 1 10-16 Access to Machine Operations,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{1eb} +@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{1f7} @section RM C.3(28): Interrupt Support @@ -14260,7 +14371,7 @@ of interrupt blocking. @geindex Protected procedure handlers @node RM C 3 1 20-21 Protected Procedure Handlers,RM C 3 2 25 Package Interrupts,RM C 3 28 Interrupt Support,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{1ec} +@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{1f8} @section RM C.3.1(20-21): Protected Procedure Handlers @@ -14286,7 +14397,7 @@ Followed. Compile time warnings are given when possible. @geindex Interrupts @node RM C 3 2 25 Package Interrupts,RM C 4 14 Pre-elaboration Requirements,RM C 3 1 20-21 Protected Procedure Handlers,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{1ed} +@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{1f9} @section RM C.3.2(25): Package @cite{Interrupts} @@ -14304,7 +14415,7 @@ Followed. @geindex Pre-elaboration requirements @node RM C 4 14 Pre-elaboration Requirements,RM C 5 8 Pragma Discard_Names,RM C 3 2 25 Package Interrupts,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{1ee} +@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{1fa} @section RM C.4(14): Pre-elaboration Requirements @@ -14320,7 +14431,7 @@ Followed. Executable code is generated in some cases, e.g., loops to initialize large arrays. @node RM C 5 8 Pragma Discard_Names,RM C 7 2 30 The Package Task_Attributes,RM C 4 14 Pre-elaboration Requirements,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{1ef} +@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{1fb} @section RM C.5(8): Pragma @cite{Discard_Names} @@ -14338,7 +14449,7 @@ Followed. @geindex Task_Attributes @node RM C 7 2 30 The Package Task_Attributes,RM D 3 17 Locking Policies,RM C 5 8 Pragma Discard_Names,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{1f0} +@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{1fc} @section RM C.7.2(30): The Package Task_Attributes @@ -14359,7 +14470,7 @@ Not followed. This implementation is not targeted to such a domain. @geindex Locking Policies @node RM D 3 17 Locking Policies,RM D 4 16 Entry Queuing Policies,RM C 7 2 30 The Package Task_Attributes,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{1f1} +@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{1fd} @section RM D.3(17): Locking Policies @@ -14376,7 +14487,7 @@ whose names (@cite{Inheritance_Locking} and @geindex Entry queuing policies @node RM D 4 16 Entry Queuing Policies,RM D 6 9-10 Preemptive Abort,RM D 3 17 Locking Policies,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{1f2} +@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{1fe} @section RM D.4(16): Entry Queuing Policies @@ -14391,7 +14502,7 @@ Followed. No such implementation-defined queuing policies exist. @geindex Preemptive abort @node RM D 6 9-10 Preemptive Abort,RM D 7 21 Tasking Restrictions,RM D 4 16 Entry Queuing Policies,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{1f3} +@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{1ff} @section RM D.6(9-10): Preemptive Abort @@ -14417,7 +14528,7 @@ Followed. @geindex Tasking restrictions @node RM D 7 21 Tasking Restrictions,RM D 8 47-49 Monotonic Time,RM D 6 9-10 Preemptive Abort,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{1f4} +@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{200} @section RM D.7(21): Tasking Restrictions @@ -14436,7 +14547,7 @@ pragma @cite{Profile (Restricted)} for more details. @geindex monotonic @node RM D 8 47-49 Monotonic Time,RM E 5 28-29 Partition Communication Subsystem,RM D 7 21 Tasking Restrictions,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{1f5} +@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{201} @section RM D.8(47-49): Monotonic Time @@ -14471,7 +14582,7 @@ Followed. @geindex PCS @node RM E 5 28-29 Partition Communication Subsystem,RM F 7 COBOL Support,RM D 8 47-49 Monotonic Time,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{1f6} +@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{202} @section RM E.5(28-29): Partition Communication Subsystem @@ -14499,7 +14610,7 @@ GNAT. @geindex COBOL support @node RM F 7 COBOL Support,RM F 1 2 Decimal Radix Support,RM E 5 28-29 Partition Communication Subsystem,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{1f7} +@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{203} @section RM F(7): COBOL Support @@ -14519,7 +14630,7 @@ Followed. @geindex Decimal radix support @node RM F 1 2 Decimal Radix Support,RM G Numerics,RM F 7 COBOL Support,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{1f8} +@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{204} @section RM F.1(2): Decimal Radix Support @@ -14535,7 +14646,7 @@ representations. @geindex Numerics @node RM G Numerics,RM G 1 1 56-58 Complex Types,RM F 1 2 Decimal Radix Support,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{1f9} +@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{205} @section RM G: Numerics @@ -14555,7 +14666,7 @@ Followed. @geindex Complex types @node RM G 1 1 56-58 Complex Types,RM G 1 2 49 Complex Elementary Functions,RM G Numerics,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{1fa} +@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{206} @section RM G.1.1(56-58): Complex Types @@ -14617,7 +14728,7 @@ Followed. @geindex Complex elementary functions @node RM G 1 2 49 Complex Elementary Functions,RM G 2 4 19 Accuracy Requirements,RM G 1 1 56-58 Complex Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{1fb} +@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{207} @section RM G.1.2(49): Complex Elementary Functions @@ -14639,7 +14750,7 @@ Followed. @geindex Accuracy requirements @node RM G 2 4 19 Accuracy Requirements,RM G 2 6 15 Complex Arithmetic Accuracy,RM G 1 2 49 Complex Elementary Functions,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{1fc} +@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{208} @section RM G.2.4(19): Accuracy Requirements @@ -14663,7 +14774,7 @@ Followed. @geindex complex arithmetic @node RM G 2 6 15 Complex Arithmetic Accuracy,RM H 6 15/2 Pragma Partition_Elaboration_Policy,RM G 2 4 19 Accuracy Requirements,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{1fd} +@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{209} @section RM G.2.6(15): Complex Arithmetic Accuracy @@ -14681,7 +14792,7 @@ Followed. @geindex Sequential elaboration policy @node RM H 6 15/2 Pragma Partition_Elaboration_Policy,,RM G 2 6 15 Complex Arithmetic Accuracy,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{1fe} +@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{20a} @section RM H.6(15/2): Pragma Partition_Elaboration_Policy @@ -14696,7 +14807,7 @@ immediately terminated." Not followed. @node Implementation Defined Characteristics,Intrinsic Subprograms,Implementation Advice,Top -@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{1ff}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{200} +@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{20b}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{20c} @chapter Implementation Defined Characteristics @@ -15320,18 +15431,11 @@ the last line is a single @cite{LF} character (@cite{16#0A#}). "Implementation-defined check names. See 11.5(27)." @end itemize -The implementation defined check name Alignment_Check controls checking of -address clause values for proper alignment (that is, the address supplied -must be consistent with the alignment of the type). - -The implementation defined check name Predicate_Check controls whether -predicate checks are generated. - -The implementation defined check name Validity_Check controls whether -validity checks are generated. - -In addition, a user program can add implementation-defined check names -by means of the pragma Check_Name. +The implementation defined check names include Alignment_Check, +Atomic_Synchronization, Duplicated_Tag_Check, Container_Checks, +Tampering_Check, Predicate_Check, and Validity_Check. In addition, a user +program can add implementation-defined check names by means of the pragma +Check_Name. See the description of pragma @cite{Suppress} for full details. @itemize * @@ -15898,7 +16002,7 @@ When the @cite{Pattern} parameter is not the null string, it is interpreted according to the syntax of regular expressions as defined in the @cite{GNAT.Regexp} package. -See @ref{201,,GNAT.Regexp (g-regexp.ads)}. +See @ref{20d,,GNAT.Regexp (g-regexp.ads)}. @itemize * @@ -16940,7 +17044,7 @@ H.4(27)." There are no restrictions on pragma @cite{Restrictions}. @node Intrinsic Subprograms,Representation Clauses and Pragmas,Implementation Defined Characteristics,Top -@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{202}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{203} +@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{20e}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{20f} @chapter Intrinsic Subprograms @@ -16977,7 +17081,7 @@ Ada standard does not require Ada compilers to implement this feature. @end menu @node Intrinsic Operators,Compilation_Date,,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{204}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{205} +@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{210}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{211} @section Intrinsic Operators @@ -17008,7 +17112,7 @@ It is also possible to specify such operators for private types, if the full views are appropriate arithmetic types. @node Compilation_Date,Compilation_Time,Intrinsic Operators,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{206}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{207} +@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{212}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{213} @section Compilation_Date @@ -17022,7 +17126,7 @@ application program should simply call the function the current compilation (in local time format MMM DD YYYY). @node Compilation_Time,Enclosing_Entity,Compilation_Date,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{208}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{209} +@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{214}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{215} @section Compilation_Time @@ -17036,7 +17140,7 @@ application program should simply call the function the current compilation (in local time format HH:MM:SS). @node Enclosing_Entity,Exception_Information,Compilation_Time,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{20a}@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{20b} +@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{216}@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{217} @section Enclosing_Entity @@ -17050,7 +17154,7 @@ application program should simply call the function the current subprogram, package, task, entry, or protected subprogram. @node Exception_Information,Exception_Message,Enclosing_Entity,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{20c}@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{20d} +@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{218}@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{219} @section Exception_Information @@ -17064,7 +17168,7 @@ so an application program should simply call the function the exception information associated with the current exception. @node Exception_Message,Exception_Name,Exception_Information,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{20e}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{20f} +@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{21a}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{21b} @section Exception_Message @@ -17078,7 +17182,7 @@ so an application program should simply call the function the message associated with the current exception. @node Exception_Name,File,Exception_Message,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{210}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{211} +@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{21c}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{21d} @section Exception_Name @@ -17092,7 +17196,7 @@ so an application program should simply call the function the name of the current exception. @node File,Line,Exception_Name,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms file}@anchor{212}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{213} +@anchor{gnat_rm/intrinsic_subprograms file}@anchor{21e}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{21f} @section File @@ -17106,7 +17210,7 @@ application program should simply call the function file. @node Line,Shifts and Rotates,File,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{214}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{215} +@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{220}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{221} @section Line @@ -17120,7 +17224,7 @@ application program should simply call the function source line. @node Shifts and Rotates,Source_Location,Line,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{216}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{217} +@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{222}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{223} @section Shifts and Rotates @@ -17159,7 +17263,7 @@ the Provide_Shift_Operators pragma, which provides the function declarations and corresponding pragma Import's for all five shift functions. @node Source_Location,,Shifts and Rotates,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{218}@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{219} +@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{224}@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{225} @section Source_Location @@ -17173,7 +17277,7 @@ application program should simply call the function source file location. @node Representation Clauses and Pragmas,Standard Library Routines,Intrinsic Subprograms,Top -@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d}@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{21a}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{21b} +@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d}@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{226}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{227} @chapter Representation Clauses and Pragmas @@ -17219,7 +17323,7 @@ and this section describes the additional capabilities provided. @end menu @node Alignment Clauses,Size Clauses,,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{21c}@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{21d} +@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{228}@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{229} @section Alignment Clauses @@ -17239,7 +17343,7 @@ For primitive types, the alignment is the minimum of the actual size of objects of the type divided by @cite{Storage_Unit}, and the maximum alignment supported by the target. (This maximum alignment is given by the GNAT-specific attribute -@cite{Standard'Maximum_Alignment}; see @ref{141,,Attribute Maximum_Alignment}.) +@cite{Standard'Maximum_Alignment}; see @ref{148,,Attribute Maximum_Alignment}.) @geindex Maximum_Alignment attribute @@ -17347,7 +17451,7 @@ assumption is non-portable, and other compilers may choose different alignments for the subtype @cite{RS}. @node Size Clauses,Storage_Size Clauses,Alignment Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{21e}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{21f} +@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{22a}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{22b} @section Size Clauses @@ -17424,7 +17528,7 @@ if it is known that a Size value can be accommodated in an object of type Integer. @node Storage_Size Clauses,Size of Variant Record Objects,Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{220}@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{221} +@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{22c}@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{22d} @section Storage_Size Clauses @@ -17497,7 +17601,7 @@ Of course in practice, there will not be any explicit allocators in the case of such an access declaration. @node Size of Variant Record Objects,Biased Representation,Storage_Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{222}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{223} +@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{22e}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{22f} @section Size of Variant Record Objects @@ -17607,7 +17711,7 @@ the maximum size, regardless of the current variant value, the variant value. @node Biased Representation,Value_Size and Object_Size Clauses,Size of Variant Record Objects,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{224}@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{225} +@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{230}@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{231} @section Biased Representation @@ -17645,7 +17749,7 @@ biased representation can be used for all discrete types except for enumeration types for which a representation clause is given. @node Value_Size and Object_Size Clauses,Component_Size Clauses,Biased Representation,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{226}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{227} +@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{232}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{233} @section Value_Size and Object_Size Clauses @@ -17952,7 +18056,7 @@ definition clause forces biased representation. This warning can be turned off using @cite{-gnatw.B}. @node Component_Size Clauses,Bit_Order Clauses,Value_Size and Object_Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{228}@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{229} +@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{234}@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{235} @section Component_Size Clauses @@ -17999,7 +18103,7 @@ and a pragma Pack for the same array type. if such duplicate clauses are given, the pragma Pack will be ignored. @node Bit_Order Clauses,Effect of Bit_Order on Byte Ordering,Component_Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{22a}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{22b} +@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{236}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{237} @section Bit_Order Clauses @@ -18105,7 +18209,7 @@ if desired. The following section contains additional details regarding the issue of byte ordering. @node Effect of Bit_Order on Byte Ordering,Pragma Pack for Arrays,Bit_Order Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{22c}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{22d} +@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{238}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{239} @section Effect of Bit_Order on Byte Ordering @@ -18362,7 +18466,7 @@ to set the boolean constant @cite{Master_Byte_First} in an appropriate manner. @node Pragma Pack for Arrays,Pragma Pack for Records,Effect of Bit_Order on Byte Ordering,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{22e}@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{22f} +@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{23a}@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{23b} @section Pragma Pack for Arrays @@ -18478,7 +18582,7 @@ Here 31-bit packing is achieved as required, and no warning is generated, since in this case the programmer intention is clear. @node Pragma Pack for Records,Record Representation Clauses,Pragma Pack for Arrays,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{230}@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{231} +@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{23c}@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{23d} @section Pragma Pack for Records @@ -18561,7 +18665,7 @@ the @cite{L6} field is aligned to the next byte boundary, and takes an integral number of bytes, i.e., 72 bits. @node Record Representation Clauses,Handling of Records with Holes,Pragma Pack for Records,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{232}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{233} +@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{23e}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{23f} @section Record Representation Clauses @@ -18646,7 +18750,7 @@ type, in particular, always starting on a byte boundary, and the length must be a multiple of the storage unit. @node Handling of Records with Holes,Enumeration Clauses,Record Representation Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{234}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{235} +@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{240}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{241} @section Handling of Records with Holes @@ -18723,7 +18827,7 @@ for Hrec'Size use 64; @end example @node Enumeration Clauses,Address Clauses,Handling of Records with Holes,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{236}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{237} +@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{242}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{243} @section Enumeration Clauses @@ -18766,7 +18870,7 @@ the overhead of converting representation values to the corresponding positional values, (i.e., the value delivered by the @cite{Pos} attribute). @node Address Clauses,Use of Address Clauses for Memory-Mapped I/O,Enumeration Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{238}@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{239} +@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{244}@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{245} @section Address Clauses @@ -18786,7 +18890,7 @@ a constant declared before the entity." @end quotation In practice this is applicable only to address clauses, since this is the -only case in which a non-static expression is permitted by the syntax. As +only case in which a nonstatic expression is permitted by the syntax. As the AARM notes in sections 13.1 (22.a-22.h): @quotation @@ -18821,7 +18925,7 @@ might be known at compile time anyway in many cases. @end quotation -GNAT does indeed permit many additional cases of non-static expressions. In +GNAT does indeed permit many additional cases of nonstatic expressions. In particular, if the type involved is elementary there are no restrictions (since in this case, holding a temporary copy of the initialization value, if one is present, is inexpensive). In addition, if there is no implicit or @@ -18839,7 +18943,7 @@ There is explicit or implicit initialization required for the object. Note that access values are always implicitly initialized. @item -The address value is non-static. Here GNAT is more permissive than the +The address value is nonstatic. Here GNAT is more permissive than the RM, and allows the address value to be the address of a previously declared stand-alone variable, as long as it does not itself have an address clause. @@ -18853,9 +18957,9 @@ However, the prefix of the address clause cannot be an array component, or a component of a discriminated record. @end itemize -As noted above in section 22.h, address values are typically non-static. In +As noted above in section 22.h, address values are typically nonstatic. In particular the To_Address function, even if applied to a literal value, is -a non-static function call. To avoid this minor annoyance, GNAT provides +a nonstatic function call. To avoid this minor annoyance, GNAT provides the implementation defined attribute 'To_Address. The following two expressions have identical values: @@ -19093,7 +19197,7 @@ then the program compiles without the warning and when run will generate the output @cite{X was not clobbered}. @node Use of Address Clauses for Memory-Mapped I/O,Effect of Convention on Representation,Address Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{23a}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{23b} +@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{246}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{247} @section Use of Address Clauses for Memory-Mapped I/O @@ -19151,7 +19255,7 @@ components to be atomic if you want the byte store, or explicitly writing the full word access sequence if that is what the hardware requires. @node Effect of Convention on Representation,Conventions and Anonymous Access Types,Use of Address Clauses for Memory-Mapped I/O,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{23c}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{23d} +@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{248}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{249} @section Effect of Convention on Representation @@ -19229,7 +19333,7 @@ when one of these values is read, any nonzero value is treated as True. @end itemize @node Conventions and Anonymous Access Types,Determining the Representations chosen by GNAT,Effect of Convention on Representation,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{23e}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{23f} +@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{24a}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{24b} @section Conventions and Anonymous Access Types @@ -19305,7 +19409,7 @@ package ConvComp is @end example @node Determining the Representations chosen by GNAT,,Conventions and Anonymous Access Types,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{240}@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{241} +@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{24c}@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{24d} @section Determining the Representations chosen by GNAT @@ -19457,7 +19561,7 @@ generated by the compiler into the original source to fix and guarantee the actual representation to be used. @node Standard Library Routines,The Implementation of Standard I/O,Representation Clauses and Pragmas,Top -@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e}@anchor{gnat_rm/standard_library_routines doc}@anchor{242}@anchor{gnat_rm/standard_library_routines id1}@anchor{243} +@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e}@anchor{gnat_rm/standard_library_routines doc}@anchor{24e}@anchor{gnat_rm/standard_library_routines id1}@anchor{24f} @chapter Standard Library Routines @@ -20280,7 +20384,7 @@ For packages in Interfaces and System, all the RM defined packages are available in GNAT, see the Ada 2012 RM for full details. @node The Implementation of Standard I/O,The GNAT Library,Standard Library Routines,Top -@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f}@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{244}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{245} +@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f}@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{250}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{251} @chapter The Implementation of Standard I/O @@ -20332,7 +20436,7 @@ these additional facilities are also described in this chapter. @end menu @node Standard I/O Packages,FORM Strings,,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{246}@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{247} +@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{252}@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{253} @section Standard I/O Packages @@ -20403,7 +20507,7 @@ flush the common I/O streams and in particular Standard_Output before elaborating the Ada code. @node FORM Strings,Direct_IO,Standard I/O Packages,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{248}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{249} +@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{254}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{255} @section FORM Strings @@ -20429,7 +20533,7 @@ unrecognized keyword appears in a form string, it is silently ignored and not considered invalid. @node Direct_IO,Sequential_IO,FORM Strings,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{24a}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{24b} +@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{256}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{257} @section Direct_IO @@ -20449,7 +20553,7 @@ There is no limit on the size of Direct_IO files, they are expanded as necessary to accommodate whatever records are written to the file. @node Sequential_IO,Text_IO,Direct_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{24c}@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{24d} +@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{258}@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{259} @section Sequential_IO @@ -20496,7 +20600,7 @@ using Stream_IO, and this is the preferred mechanism. In particular, the above program fragment rewritten to use Stream_IO will work correctly. @node Text_IO,Wide_Text_IO,Sequential_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{24e}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{24f} +@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{25a}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{25b} @section Text_IO @@ -20579,7 +20683,7 @@ the file. @end menu @node Stream Pointer Positioning,Reading and Writing Non-Regular Files,,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{250}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{251} +@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{25c}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{25d} @subsection Stream Pointer Positioning @@ -20615,7 +20719,7 @@ between two Ada files, then the difference may be observable in some situations. @node Reading and Writing Non-Regular Files,Get_Immediate,Stream Pointer Positioning,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{252}@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{253} +@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{25e}@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{25f} @subsection Reading and Writing Non-Regular Files @@ -20666,7 +20770,7 @@ to read data past that end of file indication, until another end of file indication is entered. @node Get_Immediate,Treating Text_IO Files as Streams,Reading and Writing Non-Regular Files,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{254}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{255} +@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{260}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{261} @subsection Get_Immediate @@ -20684,7 +20788,7 @@ possible), it is undefined whether the FF character will be treated as a page mark. @node Treating Text_IO Files as Streams,Text_IO Extensions,Get_Immediate,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{256}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{257} +@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{262}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{263} @subsection Treating Text_IO Files as Streams @@ -20700,7 +20804,7 @@ skipped and the effect is similar to that described above for @cite{Get_Immediate}. @node Text_IO Extensions,Text_IO Facilities for Unbounded Strings,Treating Text_IO Files as Streams,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{258}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{259} +@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{264}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{265} @subsection Text_IO Extensions @@ -20728,7 +20832,7 @@ the string is to be read. @end itemize @node Text_IO Facilities for Unbounded Strings,,Text_IO Extensions,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{25a}@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{25b} +@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{266}@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{267} @subsection Text_IO Facilities for Unbounded Strings @@ -20776,7 +20880,7 @@ files @code{a-szuzti.ads} and @code{a-szuzti.adb} provides similar extended @cite{Wide_Wide_Text_IO} functionality for unbounded wide wide strings. @node Wide_Text_IO,Wide_Wide_Text_IO,Text_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{25c}@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{25d} +@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{268}@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{269} @section Wide_Text_IO @@ -21023,12 +21127,12 @@ input also causes Constraint_Error to be raised. @end menu @node Stream Pointer Positioning<2>,Reading and Writing Non-Regular Files<2>,,Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{25e}@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{25f} +@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{26a}@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{26b} @subsection Stream Pointer Positioning @cite{Ada.Wide_Text_IO} is similar to @cite{Ada.Text_IO} in its handling -of stream pointer positioning (@ref{24f,,Text_IO}). There is one additional +of stream pointer positioning (@ref{25b,,Text_IO}). There is one additional case: If @cite{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the @@ -21047,7 +21151,7 @@ to a normal program using @cite{Wide_Text_IO}. However, this discrepancy can be observed if the wide text file shares a stream with another file. @node Reading and Writing Non-Regular Files<2>,,Stream Pointer Positioning<2>,Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{260}@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{261} +@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{26c}@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{26d} @subsection Reading and Writing Non-Regular Files @@ -21058,7 +21162,7 @@ treated as data characters), and @cite{End_Of_Page} always returns it is possible to read beyond an end of file. @node Wide_Wide_Text_IO,Stream_IO,Wide_Text_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{262}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{263} +@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{26e}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{26f} @section Wide_Wide_Text_IO @@ -21227,12 +21331,12 @@ input also causes Constraint_Error to be raised. @end menu @node Stream Pointer Positioning<3>,Reading and Writing Non-Regular Files<3>,,Wide_Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{264}@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{265} +@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{270}@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{271} @subsection Stream Pointer Positioning @cite{Ada.Wide_Wide_Text_IO} is similar to @cite{Ada.Text_IO} in its handling -of stream pointer positioning (@ref{24f,,Text_IO}). There is one additional +of stream pointer positioning (@ref{25b,,Text_IO}). There is one additional case: If @cite{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the @@ -21251,7 +21355,7 @@ to a normal program using @cite{Wide_Wide_Text_IO}. However, this discrepancy can be observed if the wide text file shares a stream with another file. @node Reading and Writing Non-Regular Files<3>,,Stream Pointer Positioning<3>,Wide_Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{266}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{267} +@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{272}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{273} @subsection Reading and Writing Non-Regular Files @@ -21262,7 +21366,7 @@ treated as data characters), and @cite{End_Of_Page} always returns it is possible to read beyond an end of file. @node Stream_IO,Text Translation,Wide_Wide_Text_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{268}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{269} +@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{274}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{275} @section Stream_IO @@ -21284,7 +21388,7 @@ manner described for stream attributes. @end itemize @node Text Translation,Shared Files,Stream_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{26a}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{26b} +@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{276}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{277} @section Text Translation @@ -21318,7 +21422,7 @@ mode. (corresponds to_O_U16TEXT). @end itemize @node Shared Files,Filenames encoding,Text Translation,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{26c}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{26d} +@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{278}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{279} @section Shared Files @@ -21381,7 +21485,7 @@ heterogeneous input-output. Although this approach will work in GNAT if for this purpose (using the stream attributes) @node Filenames encoding,File content encoding,Shared Files,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{26e}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{26f} +@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{27a}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{27b} @section Filenames encoding @@ -21421,7 +21525,7 @@ platform. On the other Operating Systems the run-time is supporting UTF-8 natively. @node File content encoding,Open Modes,Filenames encoding,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{270}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{271} +@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{27c}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{27d} @section File content encoding @@ -21454,7 +21558,7 @@ Unicode 8-bit encoding This encoding is only supported on the Windows platform. @node Open Modes,Operations on C Streams,File content encoding,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{272}@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{273} +@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{27e}@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{27f} @section Open Modes @@ -21557,7 +21661,7 @@ subsequently requires switching from reading to writing or vice-versa, then the file is reopened in @code{r+} mode to permit the required operation. @node Operations on C Streams,Interfacing to C Streams,Open Modes,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{274}@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{275} +@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{280}@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{281} @section Operations on C Streams @@ -21717,7 +21821,7 @@ end Interfaces.C_Streams; @end example @node Interfacing to C Streams,,Operations on C Streams,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{276}@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{277} +@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{282}@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{283} @section Interfacing to C Streams @@ -21810,7 +21914,7 @@ imported from a C program, allowing an Ada file to operate on an existing C file. @node The GNAT Library,Interfacing to Other Languages,The Implementation of Standard I/O,Top -@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10}@anchor{gnat_rm/the_gnat_library doc}@anchor{278}@anchor{gnat_rm/the_gnat_library id1}@anchor{279} +@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10}@anchor{gnat_rm/the_gnat_library doc}@anchor{284}@anchor{gnat_rm/the_gnat_library id1}@anchor{285} @chapter The GNAT Library @@ -21884,6 +21988,7 @@ of GNAT, and will generate a warning message. * GNAT.Altivec.Vector_Views (g-alvevi.ads): GNAT Altivec Vector_Views g-alvevi ads. * GNAT.Array_Split (g-arrspl.ads): GNAT Array_Split g-arrspl ads. * GNAT.AWK (g-awk.ads): GNAT AWK g-awk ads. +* GNAT.Bind_Environment (g-binenv.ads): GNAT Bind_Environment g-binenv ads. * GNAT.Bounded_Buffers (g-boubuf.ads): GNAT Bounded_Buffers g-boubuf ads. * GNAT.Bounded_Mailboxes (g-boumai.ads): GNAT Bounded_Mailboxes g-boumai ads. * GNAT.Bubble_Sort (g-bubsor.ads): GNAT Bubble_Sort g-bubsor ads. @@ -21996,7 +22101,7 @@ of GNAT, and will generate a warning message. @end menu @node Ada Characters Latin_9 a-chlat9 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,,The GNAT Library -@anchor{gnat_rm/the_gnat_library id2}@anchor{27a}@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{27b} +@anchor{gnat_rm/the_gnat_library id2}@anchor{286}@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{287} @section @cite{Ada.Characters.Latin_9} (@code{a-chlat9.ads}) @@ -22013,7 +22118,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Latin_1 a-cwila1 ads,Ada Characters Wide_Latin_9 a-cwila1 ads,Ada Characters Latin_9 a-chlat9 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{27c}@anchor{gnat_rm/the_gnat_library id3}@anchor{27d} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{288}@anchor{gnat_rm/the_gnat_library id3}@anchor{289} @section @cite{Ada.Characters.Wide_Latin_1} (@code{a-cwila1.ads}) @@ -22030,7 +22135,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Latin_9 a-cwila1 ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id4}@anchor{27e}@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{27f} +@anchor{gnat_rm/the_gnat_library id4}@anchor{28a}@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{28b} @section @cite{Ada.Characters.Wide_Latin_9} (@code{a-cwila1.ads}) @@ -22047,7 +22152,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Characters Wide_Latin_9 a-cwila1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{280}@anchor{gnat_rm/the_gnat_library id5}@anchor{281} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{28c}@anchor{gnat_rm/the_gnat_library id5}@anchor{28d} @section @cite{Ada.Characters.Wide_Wide_Latin_1} (@code{a-chzla1.ads}) @@ -22064,7 +22169,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{282}@anchor{gnat_rm/the_gnat_library id6}@anchor{283} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{28e}@anchor{gnat_rm/the_gnat_library id6}@anchor{28f} @section @cite{Ada.Characters.Wide_Wide_Latin_9} (@code{a-chzla9.ads}) @@ -22081,7 +22186,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id7}@anchor{284}@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{285} +@anchor{gnat_rm/the_gnat_library id7}@anchor{290}@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{291} @section @cite{Ada.Containers.Formal_Doubly_Linked_Lists} (@code{a-cfdlli.ads}) @@ -22100,7 +22205,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id8}@anchor{286}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{287} +@anchor{gnat_rm/the_gnat_library id8}@anchor{292}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{293} @section @cite{Ada.Containers.Formal_Hashed_Maps} (@code{a-cfhama.ads}) @@ -22119,7 +22224,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id9}@anchor{288}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{289} +@anchor{gnat_rm/the_gnat_library id9}@anchor{294}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{295} @section @cite{Ada.Containers.Formal_Hashed_Sets} (@code{a-cfhase.ads}) @@ -22138,7 +22243,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id10}@anchor{28a}@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{28b} +@anchor{gnat_rm/the_gnat_library id10}@anchor{296}@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{297} @section @cite{Ada.Containers.Formal_Ordered_Maps} (@code{a-cforma.ads}) @@ -22157,7 +22262,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Ordered_Maps a-cforma ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-sets-a-cforse-ads}@anchor{28c}@anchor{gnat_rm/the_gnat_library id11}@anchor{28d} +@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-sets-a-cforse-ads}@anchor{298}@anchor{gnat_rm/the_gnat_library id11}@anchor{299} @section @cite{Ada.Containers.Formal_Ordered_Sets} (@code{a-cforse.ads}) @@ -22176,7 +22281,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Formal_Ordered_Sets a-cforse ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id12}@anchor{28e}@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{28f} +@anchor{gnat_rm/the_gnat_library id12}@anchor{29a}@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{29b} @section @cite{Ada.Containers.Formal_Vectors} (@code{a-cofove.ads}) @@ -22195,7 +22300,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Bounded_Holders a-coboho ads,Ada Containers Formal_Vectors a-cofove ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id13}@anchor{290}@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{291} +@anchor{gnat_rm/the_gnat_library id13}@anchor{29c}@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{29d} @section @cite{Ada.Containers.Formal_Indefinite_Vectors} (@code{a-cfinve.ads}) @@ -22214,7 +22319,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Bounded_Holders a-coboho ads,Ada Command_Line Environment a-colien ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id14}@anchor{292}@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{293} +@anchor{gnat_rm/the_gnat_library id14}@anchor{29e}@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{29f} @section @cite{Ada.Containers.Bounded_Holders} (@code{a-coboho.ads}) @@ -22226,7 +22331,7 @@ This child of @cite{Ada.Containers} defines a modified version of Indefinite_Holders that avoids heap allocation. @node Ada Command_Line Environment a-colien ads,Ada Command_Line Remove a-colire ads,Ada Containers Bounded_Holders a-coboho ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{294}@anchor{gnat_rm/the_gnat_library id15}@anchor{295} +@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2a0}@anchor{gnat_rm/the_gnat_library id15}@anchor{2a1} @section @cite{Ada.Command_Line.Environment} (@code{a-colien.ads}) @@ -22239,7 +22344,7 @@ provides a mechanism for obtaining environment values on systems where this concept makes sense. @node Ada Command_Line Remove a-colire ads,Ada Command_Line Response_File a-clrefi ads,Ada Command_Line Environment a-colien ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id16}@anchor{296}@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{297} +@anchor{gnat_rm/the_gnat_library id16}@anchor{2a2}@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2a3} @section @cite{Ada.Command_Line.Remove} (@code{a-colire.ads}) @@ -22257,7 +22362,7 @@ to further calls on the subprograms in @cite{Ada.Command_Line} will not see the removed argument. @node Ada Command_Line Response_File a-clrefi ads,Ada Direct_IO C_Streams a-diocst ads,Ada Command_Line Remove a-colire ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{298}@anchor{gnat_rm/the_gnat_library id17}@anchor{299} +@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2a4}@anchor{gnat_rm/the_gnat_library id17}@anchor{2a5} @section @cite{Ada.Command_Line.Response_File} (@code{a-clrefi.ads}) @@ -22277,7 +22382,7 @@ Using a response file allow passing a set of arguments to an executable longer than the maximum allowed by the system on the command line. @node Ada Direct_IO C_Streams a-diocst ads,Ada Exceptions Is_Null_Occurrence a-einuoc ads,Ada Command_Line Response_File a-clrefi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id18}@anchor{29a}@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{29b} +@anchor{gnat_rm/the_gnat_library id18}@anchor{2a6}@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2a7} @section @cite{Ada.Direct_IO.C_Streams} (@code{a-diocst.ads}) @@ -22292,7 +22397,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Exceptions Is_Null_Occurrence a-einuoc ads,Ada Exceptions Last_Chance_Handler a-elchha ads,Ada Direct_IO C_Streams a-diocst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id19}@anchor{29c}@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{29d} +@anchor{gnat_rm/the_gnat_library id19}@anchor{2a8}@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2a9} @section @cite{Ada.Exceptions.Is_Null_Occurrence} (@code{a-einuoc.ads}) @@ -22306,7 +22411,7 @@ exception occurrence (@cite{Null_Occurrence}) without raising an exception. @node Ada Exceptions Last_Chance_Handler a-elchha ads,Ada Exceptions Traceback a-exctra ads,Ada Exceptions Is_Null_Occurrence a-einuoc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id20}@anchor{29e}@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{29f} +@anchor{gnat_rm/the_gnat_library id20}@anchor{2aa}@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{2ab} @section @cite{Ada.Exceptions.Last_Chance_Handler} (@code{a-elchha.ads}) @@ -22320,7 +22425,7 @@ exceptions (hence the name last chance), and perform clean ups before terminating the program. Note that this subprogram never returns. @node Ada Exceptions Traceback a-exctra ads,Ada Sequential_IO C_Streams a-siocst ads,Ada Exceptions Last_Chance_Handler a-elchha ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{2a0}@anchor{gnat_rm/the_gnat_library id21}@anchor{2a1} +@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{2ac}@anchor{gnat_rm/the_gnat_library id21}@anchor{2ad} @section @cite{Ada.Exceptions.Traceback} (@code{a-exctra.ads}) @@ -22333,7 +22438,7 @@ give a traceback array of addresses based on an exception occurrence. @node Ada Sequential_IO C_Streams a-siocst ads,Ada Streams Stream_IO C_Streams a-ssicst ads,Ada Exceptions Traceback a-exctra ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{2a2}@anchor{gnat_rm/the_gnat_library id22}@anchor{2a3} +@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{2ae}@anchor{gnat_rm/the_gnat_library id22}@anchor{2af} @section @cite{Ada.Sequential_IO.C_Streams} (@code{a-siocst.ads}) @@ -22348,7 +22453,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Streams Stream_IO C_Streams a-ssicst ads,Ada Strings Unbounded Text_IO a-suteio ads,Ada Sequential_IO C_Streams a-siocst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id23}@anchor{2a4}@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{2a5} +@anchor{gnat_rm/the_gnat_library id23}@anchor{2b0}@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{2b1} @section @cite{Ada.Streams.Stream_IO.C_Streams} (@code{a-ssicst.ads}) @@ -22363,7 +22468,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Strings Unbounded Text_IO a-suteio ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,Ada Streams Stream_IO C_Streams a-ssicst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{2a6}@anchor{gnat_rm/the_gnat_library id24}@anchor{2a7} +@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{2b2}@anchor{gnat_rm/the_gnat_library id24}@anchor{2b3} @section @cite{Ada.Strings.Unbounded.Text_IO} (@code{a-suteio.ads}) @@ -22380,7 +22485,7 @@ strings, avoiding the necessity for an intermediate operation with ordinary strings. @node Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,Ada Strings Unbounded Text_IO a-suteio ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id25}@anchor{2a8}@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{2a9} +@anchor{gnat_rm/the_gnat_library id25}@anchor{2b4}@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{2b5} @section @cite{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@code{a-swuwti.ads}) @@ -22397,7 +22502,7 @@ wide strings, avoiding the necessity for an intermediate operation with ordinary wide strings. @node Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,Ada Text_IO C_Streams a-tiocst ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{2aa}@anchor{gnat_rm/the_gnat_library id26}@anchor{2ab} +@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{2b6}@anchor{gnat_rm/the_gnat_library id26}@anchor{2b7} @section @cite{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads}) @@ -22414,7 +22519,7 @@ wide wide strings, avoiding the necessity for an intermediate operation with ordinary wide wide strings. @node Ada Text_IO C_Streams a-tiocst ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{2ac}@anchor{gnat_rm/the_gnat_library id27}@anchor{2ad} +@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{2b8}@anchor{gnat_rm/the_gnat_library id27}@anchor{2b9} @section @cite{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads}) @@ -22429,7 +22534,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Wide_Characters Unicode a-wichun ads,Ada Text_IO C_Streams a-tiocst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id28}@anchor{2ae}@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{2af} +@anchor{gnat_rm/the_gnat_library id28}@anchor{2ba}@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{2bb} @section @cite{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads}) @@ -22444,7 +22549,7 @@ execution (for example a standard input file may be redefined to be interactive). @node Ada Wide_Characters Unicode a-wichun ads,Ada Wide_Text_IO C_Streams a-wtcstr ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id29}@anchor{2b0}@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{2b1} +@anchor{gnat_rm/the_gnat_library id29}@anchor{2bc}@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{2bd} @section @cite{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads}) @@ -22457,7 +22562,7 @@ This package provides subprograms that allow categorization of Wide_Character values according to Unicode categories. @node Ada Wide_Text_IO C_Streams a-wtcstr ads,Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,Ada Wide_Characters Unicode a-wichun ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{2b2}@anchor{gnat_rm/the_gnat_library id30}@anchor{2b3} +@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{2be}@anchor{gnat_rm/the_gnat_library id30}@anchor{2bf} @section @cite{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads}) @@ -22472,7 +22577,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,Ada Wide_Wide_Characters Unicode a-zchuni ads,Ada Wide_Text_IO C_Streams a-wtcstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{2b4}@anchor{gnat_rm/the_gnat_library id31}@anchor{2b5} +@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{2c0}@anchor{gnat_rm/the_gnat_library id31}@anchor{2c1} @section @cite{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads}) @@ -22487,7 +22592,7 @@ execution (for example a standard input file may be redefined to be interactive). @node Ada Wide_Wide_Characters Unicode a-zchuni ads,Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id32}@anchor{2b6}@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{2b7} +@anchor{gnat_rm/the_gnat_library id32}@anchor{2c2}@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{2c3} @section @cite{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads}) @@ -22500,7 +22605,7 @@ This package provides subprograms that allow categorization of Wide_Wide_Character values according to Unicode categories. @node Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,Ada Wide_Wide_Characters Unicode a-zchuni ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id33}@anchor{2b8}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{2b9} +@anchor{gnat_rm/the_gnat_library id33}@anchor{2c4}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{2c5} @section @cite{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads}) @@ -22515,7 +22620,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,GNAT Altivec g-altive ads,Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id34}@anchor{2ba}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{2bb} +@anchor{gnat_rm/the_gnat_library id34}@anchor{2c6}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{2c7} @section @cite{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads}) @@ -22530,7 +22635,7 @@ change during execution (for example a standard input file may be redefined to be interactive). @node GNAT Altivec g-altive ads,GNAT Altivec Conversions g-altcon ads,Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{2bc}@anchor{gnat_rm/the_gnat_library id35}@anchor{2bd} +@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{2c8}@anchor{gnat_rm/the_gnat_library id35}@anchor{2c9} @section @cite{GNAT.Altivec} (@code{g-altive.ads}) @@ -22543,7 +22648,7 @@ definitions of constants and types common to all the versions of the binding. @node GNAT Altivec Conversions g-altcon ads,GNAT Altivec Vector_Operations g-alveop ads,GNAT Altivec g-altive ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id36}@anchor{2be}@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{2bf} +@anchor{gnat_rm/the_gnat_library id36}@anchor{2ca}@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{2cb} @section @cite{GNAT.Altivec.Conversions} (@code{g-altcon.ads}) @@ -22554,7 +22659,7 @@ binding. This package provides the Vector/View conversion routines. @node GNAT Altivec Vector_Operations g-alveop ads,GNAT Altivec Vector_Types g-alvety ads,GNAT Altivec Conversions g-altcon ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id37}@anchor{2c0}@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{2c1} +@anchor{gnat_rm/the_gnat_library id37}@anchor{2cc}@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{2cd} @section @cite{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads}) @@ -22568,7 +22673,7 @@ library. The hard binding is provided as a separate package. This unit is common to both bindings. @node GNAT Altivec Vector_Types g-alvety ads,GNAT Altivec Vector_Views g-alvevi ads,GNAT Altivec Vector_Operations g-alveop ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{2c2}@anchor{gnat_rm/the_gnat_library id38}@anchor{2c3} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{2ce}@anchor{gnat_rm/the_gnat_library id38}@anchor{2cf} @section @cite{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads}) @@ -22580,7 +22685,7 @@ This package exposes the various vector types part of the Ada binding to AltiVec facilities. @node GNAT Altivec Vector_Views g-alvevi ads,GNAT Array_Split g-arrspl ads,GNAT Altivec Vector_Types g-alvety ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{2c4}@anchor{gnat_rm/the_gnat_library id39}@anchor{2c5} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{2d0}@anchor{gnat_rm/the_gnat_library id39}@anchor{2d1} @section @cite{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads}) @@ -22595,7 +22700,7 @@ vector elements and provides a simple way to initialize vector objects. @node GNAT Array_Split g-arrspl ads,GNAT AWK g-awk ads,GNAT Altivec Vector_Views g-alvevi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{2c6}@anchor{gnat_rm/the_gnat_library id40}@anchor{2c7} +@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{2d2}@anchor{gnat_rm/the_gnat_library id40}@anchor{2d3} @section @cite{GNAT.Array_Split} (@code{g-arrspl.ads}) @@ -22607,8 +22712,8 @@ Useful array-manipulation routines: given a set of separators, split an array wherever the separators appear, and provide direct access to the resulting slices. -@node GNAT AWK g-awk ads,GNAT Bounded_Buffers g-boubuf ads,GNAT Array_Split g-arrspl ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id41}@anchor{2c8}@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{2c9} +@node GNAT AWK g-awk ads,GNAT Bind_Environment g-binenv ads,GNAT Array_Split g-arrspl ads,The GNAT Library +@anchor{gnat_rm/the_gnat_library id41}@anchor{2d4}@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{2d5} @section @cite{GNAT.AWK} (@code{g-awk.ads}) @@ -22622,8 +22727,21 @@ Provides AWK-like parsing functions, with an easy interface for parsing one or more files containing formatted data. The file is viewed as a database where each record is a line and a field is a data element in this line. -@node GNAT Bounded_Buffers g-boubuf ads,GNAT Bounded_Mailboxes g-boumai ads,GNAT AWK g-awk ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{2ca}@anchor{gnat_rm/the_gnat_library id42}@anchor{2cb} +@node GNAT Bind_Environment g-binenv ads,GNAT Bounded_Buffers g-boubuf ads,GNAT AWK g-awk ads,The GNAT Library +@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{2d6}@anchor{gnat_rm/the_gnat_library id42}@anchor{2d7} +@section @cite{GNAT.Bind_Environment} (@code{g-binenv.ads}) + + +@geindex GNAT.Bind_Environment (g-binenv.ads) + +@geindex Bind environment + +Provides access to key=value associations captured at bind time. +These associations can be specified using the @cite{-V} binder command +line switch. + +@node GNAT Bounded_Buffers g-boubuf ads,GNAT Bounded_Mailboxes g-boumai ads,GNAT Bind_Environment g-binenv ads,The GNAT Library +@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{2d8}@anchor{gnat_rm/the_gnat_library id43}@anchor{2d9} @section @cite{GNAT.Bounded_Buffers} (@code{g-boubuf.ads}) @@ -22638,7 +22756,7 @@ useful directly or as parts of the implementations of other abstractions, such as mailboxes. @node GNAT Bounded_Mailboxes g-boumai ads,GNAT Bubble_Sort g-bubsor ads,GNAT Bounded_Buffers g-boubuf ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{2cc}@anchor{gnat_rm/the_gnat_library id43}@anchor{2cd} +@anchor{gnat_rm/the_gnat_library id44}@anchor{2da}@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{2db} @section @cite{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads}) @@ -22651,7 +22769,7 @@ such as mailboxes. Provides a thread-safe asynchronous intertask mailbox communication facility. @node GNAT Bubble_Sort g-bubsor ads,GNAT Bubble_Sort_A g-busora ads,GNAT Bounded_Mailboxes g-boumai ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{2ce}@anchor{gnat_rm/the_gnat_library id44}@anchor{2cf} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{2dc}@anchor{gnat_rm/the_gnat_library id45}@anchor{2dd} @section @cite{GNAT.Bubble_Sort} (@code{g-bubsor.ads}) @@ -22666,7 +22784,7 @@ data items. Exchange and comparison procedures are provided by passing access-to-procedure values. @node GNAT Bubble_Sort_A g-busora ads,GNAT Bubble_Sort_G g-busorg ads,GNAT Bubble_Sort g-bubsor ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id45}@anchor{2d0}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{2d1} +@anchor{gnat_rm/the_gnat_library id46}@anchor{2de}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{2df} @section @cite{GNAT.Bubble_Sort_A} (@code{g-busora.ads}) @@ -22682,7 +22800,7 @@ access-to-procedure values. This is an older version, retained for compatibility. Usually @cite{GNAT.Bubble_Sort} will be preferable. @node GNAT Bubble_Sort_G g-busorg ads,GNAT Byte_Order_Mark g-byorma ads,GNAT Bubble_Sort_A g-busora ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id46}@anchor{2d2}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{2d3} +@anchor{gnat_rm/the_gnat_library id47}@anchor{2e0}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{2e1} @section @cite{GNAT.Bubble_Sort_G} (@code{g-busorg.ads}) @@ -22698,7 +22816,7 @@ if the procedures can be inlined, at the expense of duplicating code for multiple instantiations. @node GNAT Byte_Order_Mark g-byorma ads,GNAT Byte_Swapping g-bytswa ads,GNAT Bubble_Sort_G g-busorg ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id47}@anchor{2d4}@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{2d5} +@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{2e2}@anchor{gnat_rm/the_gnat_library id48}@anchor{2e3} @section @cite{GNAT.Byte_Order_Mark} (@code{g-byorma.ads}) @@ -22714,7 +22832,7 @@ the encoding of the string. The routine includes detection of special XML sequences for various UCS input formats. @node GNAT Byte_Swapping g-bytswa ads,GNAT Calendar g-calend ads,GNAT Byte_Order_Mark g-byorma ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{2d6}@anchor{gnat_rm/the_gnat_library id48}@anchor{2d7} +@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{2e4}@anchor{gnat_rm/the_gnat_library id49}@anchor{2e5} @section @cite{GNAT.Byte_Swapping} (@code{g-bytswa.ads}) @@ -22728,7 +22846,7 @@ General routines for swapping the bytes in 2-, 4-, and 8-byte quantities. Machine-specific implementations are available in some cases. @node GNAT Calendar g-calend ads,GNAT Calendar Time_IO g-catiio ads,GNAT Byte_Swapping g-bytswa ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{2d8}@anchor{gnat_rm/the_gnat_library id49}@anchor{2d9} +@anchor{gnat_rm/the_gnat_library id50}@anchor{2e6}@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{2e7} @section @cite{GNAT.Calendar} (@code{g-calend.ads}) @@ -22742,7 +22860,7 @@ Also provides conversion of @cite{Ada.Calendar.Time} values to and from the C @cite{timeval} format. @node GNAT Calendar Time_IO g-catiio ads,GNAT CRC32 g-crc32 ads,GNAT Calendar g-calend ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{2da}@anchor{gnat_rm/the_gnat_library id50}@anchor{2db} +@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{2e8}@anchor{gnat_rm/the_gnat_library id51}@anchor{2e9} @section @cite{GNAT.Calendar.Time_IO} (@code{g-catiio.ads}) @@ -22753,7 +22871,7 @@ C @cite{timeval} format. @geindex GNAT.Calendar.Time_IO (g-catiio.ads) @node GNAT CRC32 g-crc32 ads,GNAT Case_Util g-casuti ads,GNAT Calendar Time_IO g-catiio ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id51}@anchor{2dc}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{2dd} +@anchor{gnat_rm/the_gnat_library id52}@anchor{2ea}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{2eb} @section @cite{GNAT.CRC32} (@code{g-crc32.ads}) @@ -22770,7 +22888,7 @@ of this algorithm see Aug. 1988. Sarwate, D.V. @node GNAT Case_Util g-casuti ads,GNAT CGI g-cgi ads,GNAT CRC32 g-crc32 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{2de}@anchor{gnat_rm/the_gnat_library id52}@anchor{2df} +@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{2ec}@anchor{gnat_rm/the_gnat_library id53}@anchor{2ed} @section @cite{GNAT.Case_Util} (@code{g-casuti.ads}) @@ -22785,7 +22903,7 @@ without the overhead of the full casing tables in @cite{Ada.Characters.Handling}. @node GNAT CGI g-cgi ads,GNAT CGI Cookie g-cgicoo ads,GNAT Case_Util g-casuti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id53}@anchor{2e0}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{2e1} +@anchor{gnat_rm/the_gnat_library id54}@anchor{2ee}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{2ef} @section @cite{GNAT.CGI} (@code{g-cgi.ads}) @@ -22800,7 +22918,7 @@ builds a table whose index is the key and provides some services to deal with this table. @node GNAT CGI Cookie g-cgicoo ads,GNAT CGI Debug g-cgideb ads,GNAT CGI g-cgi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id54}@anchor{2e2}@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{2e3} +@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{2f0}@anchor{gnat_rm/the_gnat_library id55}@anchor{2f1} @section @cite{GNAT.CGI.Cookie} (@code{g-cgicoo.ads}) @@ -22815,7 +22933,7 @@ Common Gateway Interface (CGI). It exports services to deal with Web cookies (piece of information kept in the Web client software). @node GNAT CGI Debug g-cgideb ads,GNAT Command_Line g-comlin ads,GNAT CGI Cookie g-cgicoo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{2e4}@anchor{gnat_rm/the_gnat_library id55}@anchor{2e5} +@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{2f2}@anchor{gnat_rm/the_gnat_library id56}@anchor{2f3} @section @cite{GNAT.CGI.Debug} (@code{g-cgideb.ads}) @@ -22827,7 +22945,7 @@ This is a package to help debugging CGI (Common Gateway Interface) programs written in Ada. @node GNAT Command_Line g-comlin ads,GNAT Compiler_Version g-comver ads,GNAT CGI Debug g-cgideb ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id56}@anchor{2e6}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{2e7} +@anchor{gnat_rm/the_gnat_library id57}@anchor{2f4}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{2f5} @section @cite{GNAT.Command_Line} (@code{g-comlin.ads}) @@ -22840,7 +22958,7 @@ including the ability to scan for named switches with optional parameters and expand file names using wild card notations. @node GNAT Compiler_Version g-comver ads,GNAT Ctrl_C g-ctrl_c ads,GNAT Command_Line g-comlin ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{2e8}@anchor{gnat_rm/the_gnat_library id57}@anchor{2e9} +@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{2f6}@anchor{gnat_rm/the_gnat_library id58}@anchor{2f7} @section @cite{GNAT.Compiler_Version} (@code{g-comver.ads}) @@ -22858,7 +22976,7 @@ of the compiler if a consistent tool set is used to compile all units of a partition). @node GNAT Ctrl_C g-ctrl_c ads,GNAT Current_Exception g-curexc ads,GNAT Compiler_Version g-comver ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id58}@anchor{2ea}@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{2eb} +@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{2f8}@anchor{gnat_rm/the_gnat_library id59}@anchor{2f9} @section @cite{GNAT.Ctrl_C} (@code{g-ctrl_c.ads}) @@ -22869,7 +22987,7 @@ of a partition). Provides a simple interface to handle Ctrl-C keyboard events. @node GNAT Current_Exception g-curexc ads,GNAT Debug_Pools g-debpoo ads,GNAT Ctrl_C g-ctrl_c ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id59}@anchor{2ec}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{2ed} +@anchor{gnat_rm/the_gnat_library id60}@anchor{2fa}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{2fb} @section @cite{GNAT.Current_Exception} (@code{g-curexc.ads}) @@ -22886,7 +23004,7 @@ This is particularly useful in simulating typical facilities for obtaining information about exceptions provided by Ada 83 compilers. @node GNAT Debug_Pools g-debpoo ads,GNAT Debug_Utilities g-debuti ads,GNAT Current_Exception g-curexc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{2ee}@anchor{gnat_rm/the_gnat_library id60}@anchor{2ef} +@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{2fc}@anchor{gnat_rm/the_gnat_library id61}@anchor{2fd} @section @cite{GNAT.Debug_Pools} (@code{g-debpoo.ads}) @@ -22903,7 +23021,7 @@ problems. See @cite{The GNAT Debug_Pool Facility} section in the @cite{GNAT User's Guide}. @node GNAT Debug_Utilities g-debuti ads,GNAT Decode_String g-decstr ads,GNAT Debug_Pools g-debpoo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{2f0}@anchor{gnat_rm/the_gnat_library id61}@anchor{2f1} +@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{2fe}@anchor{gnat_rm/the_gnat_library id62}@anchor{2ff} @section @cite{GNAT.Debug_Utilities} (@code{g-debuti.ads}) @@ -22916,7 +23034,7 @@ to and from string images of address values. Supports both C and Ada formats for hexadecimal literals. @node GNAT Decode_String g-decstr ads,GNAT Decode_UTF8_String g-deutst ads,GNAT Debug_Utilities g-debuti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{2f2}@anchor{gnat_rm/the_gnat_library id62}@anchor{2f3} +@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{300}@anchor{gnat_rm/the_gnat_library id63}@anchor{301} @section @cite{GNAT.Decode_String} (@code{g-decstr.ads}) @@ -22940,7 +23058,7 @@ Useful in conjunction with Unicode character coding. Note there is a preinstantiation for UTF-8. See next entry. @node GNAT Decode_UTF8_String g-deutst ads,GNAT Directory_Operations g-dirope ads,GNAT Decode_String g-decstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{2f4}@anchor{gnat_rm/the_gnat_library id63}@anchor{2f5} +@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{302}@anchor{gnat_rm/the_gnat_library id64}@anchor{303} @section @cite{GNAT.Decode_UTF8_String} (@code{g-deutst.ads}) @@ -22961,7 +23079,7 @@ preinstantiation for UTF-8. See next entry. A preinstantiation of GNAT.Decode_Strings for UTF-8 encoding. @node GNAT Directory_Operations g-dirope ads,GNAT Directory_Operations Iteration g-diopit ads,GNAT Decode_UTF8_String g-deutst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id64}@anchor{2f6}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{2f7} +@anchor{gnat_rm/the_gnat_library id65}@anchor{304}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{305} @section @cite{GNAT.Directory_Operations} (@code{g-dirope.ads}) @@ -22974,7 +23092,7 @@ the current directory, making new directories, and scanning the files in a directory. @node GNAT Directory_Operations Iteration g-diopit ads,GNAT Dynamic_HTables g-dynhta ads,GNAT Directory_Operations g-dirope ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id65}@anchor{2f8}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{2f9} +@anchor{gnat_rm/the_gnat_library id66}@anchor{306}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{307} @section @cite{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads}) @@ -22986,7 +23104,7 @@ A child unit of GNAT.Directory_Operations providing additional operations for iterating through directories. @node GNAT Dynamic_HTables g-dynhta ads,GNAT Dynamic_Tables g-dyntab ads,GNAT Directory_Operations Iteration g-diopit ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{2fa}@anchor{gnat_rm/the_gnat_library id66}@anchor{2fb} +@anchor{gnat_rm/the_gnat_library id67}@anchor{308}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{309} @section @cite{GNAT.Dynamic_HTables} (@code{g-dynhta.ads}) @@ -23004,7 +23122,7 @@ dynamic instances of the hash table, while an instantiation of @cite{GNAT.HTable} creates a single instance of the hash table. @node GNAT Dynamic_Tables g-dyntab ads,GNAT Encode_String g-encstr ads,GNAT Dynamic_HTables g-dynhta ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{2fc}@anchor{gnat_rm/the_gnat_library id67}@anchor{2fd} +@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{30a}@anchor{gnat_rm/the_gnat_library id68}@anchor{30b} @section @cite{GNAT.Dynamic_Tables} (@code{g-dyntab.ads}) @@ -23024,7 +23142,7 @@ dynamic instances of the table, while an instantiation of @cite{GNAT.Table} creates a single instance of the table type. @node GNAT Encode_String g-encstr ads,GNAT Encode_UTF8_String g-enutst ads,GNAT Dynamic_Tables g-dyntab ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id68}@anchor{2fe}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{2ff} +@anchor{gnat_rm/the_gnat_library id69}@anchor{30c}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{30d} @section @cite{GNAT.Encode_String} (@code{g-encstr.ads}) @@ -23046,7 +23164,7 @@ encoding method. Useful in conjunction with Unicode character coding. Note there is a preinstantiation for UTF-8. See next entry. @node GNAT Encode_UTF8_String g-enutst ads,GNAT Exception_Actions g-excact ads,GNAT Encode_String g-encstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{300}@anchor{gnat_rm/the_gnat_library id69}@anchor{301} +@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{30e}@anchor{gnat_rm/the_gnat_library id70}@anchor{30f} @section @cite{GNAT.Encode_UTF8_String} (@code{g-enutst.ads}) @@ -23067,7 +23185,7 @@ Note there is a preinstantiation for UTF-8. See next entry. A preinstantiation of GNAT.Encode_Strings for UTF-8 encoding. @node GNAT Exception_Actions g-excact ads,GNAT Exception_Traces g-exctra ads,GNAT Encode_UTF8_String g-enutst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id70}@anchor{302}@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{303} +@anchor{gnat_rm/the_gnat_library id71}@anchor{310}@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{311} @section @cite{GNAT.Exception_Actions} (@code{g-excact.ads}) @@ -23080,7 +23198,7 @@ for specific exceptions, or when any exception is raised. This can be used for instance to force a core dump to ease debugging. @node GNAT Exception_Traces g-exctra ads,GNAT Exceptions g-expect ads,GNAT Exception_Actions g-excact ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{304}@anchor{gnat_rm/the_gnat_library id71}@anchor{305} +@anchor{gnat_rm/the_gnat_library id72}@anchor{312}@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{313} @section @cite{GNAT.Exception_Traces} (@code{g-exctra.ads}) @@ -23094,7 +23212,7 @@ Provides an interface allowing to control automatic output upon exception occurrences. @node GNAT Exceptions g-expect ads,GNAT Expect g-expect ads,GNAT Exception_Traces g-exctra ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id72}@anchor{306}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-expect-ads}@anchor{307} +@anchor{gnat_rm/the_gnat_library id73}@anchor{314}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-expect-ads}@anchor{315} @section @cite{GNAT.Exceptions} (@code{g-expect.ads}) @@ -23115,7 +23233,7 @@ predefined exceptions, and for example allow raising @cite{Constraint_Error} with a message from a pure subprogram. @node GNAT Expect g-expect ads,GNAT Expect TTY g-exptty ads,GNAT Exceptions g-expect ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id73}@anchor{308}@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{309} +@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{316}@anchor{gnat_rm/the_gnat_library id74}@anchor{317} @section @cite{GNAT.Expect} (@code{g-expect.ads}) @@ -23131,7 +23249,7 @@ It is not implemented for cross ports, and in particular is not implemented for VxWorks or LynxOS. @node GNAT Expect TTY g-exptty ads,GNAT Float_Control g-flocon ads,GNAT Expect g-expect ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id74}@anchor{30a}@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{30b} +@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{318}@anchor{gnat_rm/the_gnat_library id75}@anchor{319} @section @cite{GNAT.Expect.TTY} (@code{g-exptty.ads}) @@ -23143,7 +23261,7 @@ ports. It is not implemented for cross ports, and in particular is not implemented for VxWorks or LynxOS. @node GNAT Float_Control g-flocon ads,GNAT Formatted_String g-forstr ads,GNAT Expect TTY g-exptty ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id75}@anchor{30c}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{30d} +@anchor{gnat_rm/the_gnat_library id76}@anchor{31a}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{31b} @section @cite{GNAT.Float_Control} (@code{g-flocon.ads}) @@ -23157,7 +23275,7 @@ library calls may cause this mode to be modified, and the Reset procedure in this package can be used to reestablish the required mode. @node GNAT Formatted_String g-forstr ads,GNAT Heap_Sort g-heasor ads,GNAT Float_Control g-flocon ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id76}@anchor{30e}@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{30f} +@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{31c}@anchor{gnat_rm/the_gnat_library id77}@anchor{31d} @section @cite{GNAT.Formatted_String} (@code{g-forstr.ads}) @@ -23172,7 +23290,7 @@ derived from Integer, Float or enumerations as values for the formatted string. @node GNAT Heap_Sort g-heasor ads,GNAT Heap_Sort_A g-hesora ads,GNAT Formatted_String g-forstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{310}@anchor{gnat_rm/the_gnat_library id77}@anchor{311} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{31e}@anchor{gnat_rm/the_gnat_library id78}@anchor{31f} @section @cite{GNAT.Heap_Sort} (@code{g-heasor.ads}) @@ -23186,7 +23304,7 @@ access-to-procedure values. The algorithm used is a modified heap sort that performs approximately N*log(N) comparisons in the worst case. @node GNAT Heap_Sort_A g-hesora ads,GNAT Heap_Sort_G g-hesorg ads,GNAT Heap_Sort g-heasor ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id78}@anchor{312}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{313} +@anchor{gnat_rm/the_gnat_library id79}@anchor{320}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{321} @section @cite{GNAT.Heap_Sort_A} (@code{g-hesora.ads}) @@ -23202,7 +23320,7 @@ This differs from @cite{GNAT.Heap_Sort} in having a less convenient interface, but may be slightly more efficient. @node GNAT Heap_Sort_G g-hesorg ads,GNAT HTable g-htable ads,GNAT Heap_Sort_A g-hesora ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id79}@anchor{314}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{315} +@anchor{gnat_rm/the_gnat_library id80}@anchor{322}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{323} @section @cite{GNAT.Heap_Sort_G} (@code{g-hesorg.ads}) @@ -23216,7 +23334,7 @@ if the procedures can be inlined, at the expense of duplicating code for multiple instantiations. @node GNAT HTable g-htable ads,GNAT IO g-io ads,GNAT Heap_Sort_G g-hesorg ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id80}@anchor{316}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{317} +@anchor{gnat_rm/the_gnat_library id81}@anchor{324}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{325} @section @cite{GNAT.HTable} (@code{g-htable.ads}) @@ -23229,7 +23347,7 @@ data. Provides two approaches, one a simple static approach, and the other allowing arbitrary dynamic hash tables. @node GNAT IO g-io ads,GNAT IO_Aux g-io_aux ads,GNAT HTable g-htable ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id81}@anchor{318}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{319} +@anchor{gnat_rm/the_gnat_library id82}@anchor{326}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{327} @section @cite{GNAT.IO} (@code{g-io.ads}) @@ -23245,7 +23363,7 @@ Standard_Input, and writing characters, strings and integers to either Standard_Output or Standard_Error. @node GNAT IO_Aux g-io_aux ads,GNAT Lock_Files g-locfil ads,GNAT IO g-io ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id82}@anchor{31a}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{31b} +@anchor{gnat_rm/the_gnat_library id83}@anchor{328}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{329} @section @cite{GNAT.IO_Aux} (@code{g-io_aux.ads}) @@ -23259,7 +23377,7 @@ Provides some auxiliary functions for use with Text_IO, including a test for whether a file exists, and functions for reading a line of text. @node GNAT Lock_Files g-locfil ads,GNAT MBBS_Discrete_Random g-mbdira ads,GNAT IO_Aux g-io_aux ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id83}@anchor{31c}@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{31d} +@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{32a}@anchor{gnat_rm/the_gnat_library id84}@anchor{32b} @section @cite{GNAT.Lock_Files} (@code{g-locfil.ads}) @@ -23273,7 +23391,7 @@ Provides a general interface for using files as locks. Can be used for providing program level synchronization. @node GNAT MBBS_Discrete_Random g-mbdira ads,GNAT MBBS_Float_Random g-mbflra ads,GNAT Lock_Files g-locfil ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{31e}@anchor{gnat_rm/the_gnat_library id84}@anchor{31f} +@anchor{gnat_rm/the_gnat_library id85}@anchor{32c}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{32d} @section @cite{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads}) @@ -23285,7 +23403,7 @@ The original implementation of @cite{Ada.Numerics.Discrete_Random}. Uses a modified version of the Blum-Blum-Shub generator. @node GNAT MBBS_Float_Random g-mbflra ads,GNAT MD5 g-md5 ads,GNAT MBBS_Discrete_Random g-mbdira ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id85}@anchor{320}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{321} +@anchor{gnat_rm/the_gnat_library id86}@anchor{32e}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{32f} @section @cite{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads}) @@ -23297,7 +23415,7 @@ The original implementation of @cite{Ada.Numerics.Float_Random}. Uses a modified version of the Blum-Blum-Shub generator. @node GNAT MD5 g-md5 ads,GNAT Memory_Dump g-memdum ads,GNAT MBBS_Float_Random g-mbflra ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id86}@anchor{322}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{323} +@anchor{gnat_rm/the_gnat_library id87}@anchor{330}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{331} @section @cite{GNAT.MD5} (@code{g-md5.ads}) @@ -23310,7 +23428,7 @@ the HMAC-MD5 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT Memory_Dump g-memdum ads,GNAT Most_Recent_Exception g-moreex ads,GNAT MD5 g-md5 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id87}@anchor{324}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{325} +@anchor{gnat_rm/the_gnat_library id88}@anchor{332}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{333} @section @cite{GNAT.Memory_Dump} (@code{g-memdum.ads}) @@ -23323,7 +23441,7 @@ standard output or standard error files. Uses GNAT.IO for actual output. @node GNAT Most_Recent_Exception g-moreex ads,GNAT OS_Lib g-os_lib ads,GNAT Memory_Dump g-memdum ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id88}@anchor{326}@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{327} +@anchor{gnat_rm/the_gnat_library id89}@anchor{334}@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{335} @section @cite{GNAT.Most_Recent_Exception} (@code{g-moreex.ads}) @@ -23337,7 +23455,7 @@ various logging purposes, including duplicating functionality of some Ada 83 implementation dependent extensions. @node GNAT OS_Lib g-os_lib ads,GNAT Perfect_Hash_Generators g-pehage ads,GNAT Most_Recent_Exception g-moreex ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id89}@anchor{328}@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{329} +@anchor{gnat_rm/the_gnat_library id90}@anchor{336}@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{337} @section @cite{GNAT.OS_Lib} (@code{g-os_lib.ads}) @@ -23353,7 +23471,7 @@ including a portable spawn procedure, and access to environment variables and error return codes. @node GNAT Perfect_Hash_Generators g-pehage ads,GNAT Random_Numbers g-rannum ads,GNAT OS_Lib g-os_lib ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id90}@anchor{32a}@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{32b} +@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{338}@anchor{gnat_rm/the_gnat_library id91}@anchor{339} @section @cite{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads}) @@ -23371,7 +23489,7 @@ hashcode are in the same order. These hashing functions are very convenient for use with realtime applications. @node GNAT Random_Numbers g-rannum ads,GNAT Regexp g-regexp ads,GNAT Perfect_Hash_Generators g-pehage ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id91}@anchor{32c}@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{32d} +@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{33a}@anchor{gnat_rm/the_gnat_library id92}@anchor{33b} @section @cite{GNAT.Random_Numbers} (@code{g-rannum.ads}) @@ -23383,7 +23501,7 @@ Provides random number capabilities which extend those available in the standard Ada library and are more convenient to use. @node GNAT Regexp g-regexp ads,GNAT Registry g-regist ads,GNAT Random_Numbers g-rannum ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{201}@anchor{gnat_rm/the_gnat_library id92}@anchor{32e} +@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{20d}@anchor{gnat_rm/the_gnat_library id93}@anchor{33c} @section @cite{GNAT.Regexp} (@code{g-regexp.ads}) @@ -23399,7 +23517,7 @@ simplest of the three pattern matching packages provided, and is particularly suitable for 'file globbing' applications. @node GNAT Registry g-regist ads,GNAT Regpat g-regpat ads,GNAT Regexp g-regexp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id93}@anchor{32f}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{330} +@anchor{gnat_rm/the_gnat_library id94}@anchor{33d}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{33e} @section @cite{GNAT.Registry} (@code{g-regist.ads}) @@ -23413,7 +23531,7 @@ registry API, but at a lower level of abstraction, refer to the Win32.Winreg package provided with the Win32Ada binding @node GNAT Regpat g-regpat ads,GNAT Rewrite_Data g-rewdat ads,GNAT Registry g-regist ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id94}@anchor{331}@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{332} +@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{33f}@anchor{gnat_rm/the_gnat_library id95}@anchor{340} @section @cite{GNAT.Regpat} (@code{g-regpat.ads}) @@ -23428,7 +23546,7 @@ from the original V7 style regular expression library written in C by Henry Spencer (and binary compatible with this C library). @node GNAT Rewrite_Data g-rewdat ads,GNAT Secondary_Stack_Info g-sestin ads,GNAT Regpat g-regpat ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id95}@anchor{333}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{334} +@anchor{gnat_rm/the_gnat_library id96}@anchor{341}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{342} @section @cite{GNAT.Rewrite_Data} (@code{g-rewdat.ads}) @@ -23442,7 +23560,7 @@ full content to be processed is not loaded into memory all at once. This makes this interface usable for large files or socket streams. @node GNAT Secondary_Stack_Info g-sestin ads,GNAT Semaphores g-semaph ads,GNAT Rewrite_Data g-rewdat ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id96}@anchor{336} +@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{343}@anchor{gnat_rm/the_gnat_library id97}@anchor{344} @section @cite{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads}) @@ -23454,7 +23572,7 @@ Provide the capability to query the high water mark of the current task's secondary stack. @node GNAT Semaphores g-semaph ads,GNAT Serial_Communications g-sercom ads,GNAT Secondary_Stack_Info g-sestin ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id97}@anchor{338} +@anchor{gnat_rm/the_gnat_library id98}@anchor{345}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{346} @section @cite{GNAT.Semaphores} (@code{g-semaph.ads}) @@ -23465,7 +23583,7 @@ secondary stack. Provides classic counting and binary semaphores using protected types. @node GNAT Serial_Communications g-sercom ads,GNAT SHA1 g-sha1 ads,GNAT Semaphores g-semaph ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id98}@anchor{339}@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{33a} +@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id99}@anchor{348} @section @cite{GNAT.Serial_Communications} (@code{g-sercom.ads}) @@ -23477,7 +23595,7 @@ Provides a simple interface to send and receive data over a serial port. This is only supported on GNU/Linux and Windows. @node GNAT SHA1 g-sha1 ads,GNAT SHA224 g-sha224 ads,GNAT Serial_Communications g-sercom ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id99}@anchor{33c} +@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{349}@anchor{gnat_rm/the_gnat_library id100}@anchor{34a} @section @cite{GNAT.SHA1} (@code{g-sha1.ads}) @@ -23490,7 +23608,7 @@ and RFC 3174, and the HMAC-SHA1 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA224 g-sha224 ads,GNAT SHA256 g-sha256 ads,GNAT SHA1 g-sha1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id100}@anchor{33d}@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{33e} +@anchor{gnat_rm/the_gnat_library id101}@anchor{34b}@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{34c} @section @cite{GNAT.SHA224} (@code{g-sha224.ads}) @@ -23503,7 +23621,7 @@ and the HMAC-SHA224 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA256 g-sha256 ads,GNAT SHA384 g-sha384 ads,GNAT SHA224 g-sha224 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id101}@anchor{33f}@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{340} +@anchor{gnat_rm/the_gnat_library id102}@anchor{34d}@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{34e} @section @cite{GNAT.SHA256} (@code{g-sha256.ads}) @@ -23516,7 +23634,7 @@ and the HMAC-SHA256 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA384 g-sha384 ads,GNAT SHA512 g-sha512 ads,GNAT SHA256 g-sha256 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id102}@anchor{341}@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{342} +@anchor{gnat_rm/the_gnat_library id103}@anchor{34f}@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{350} @section @cite{GNAT.SHA384} (@code{g-sha384.ads}) @@ -23529,7 +23647,7 @@ and the HMAC-SHA384 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA512 g-sha512 ads,GNAT Signals g-signal ads,GNAT SHA384 g-sha384 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id103}@anchor{343}@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{344} +@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{351}@anchor{gnat_rm/the_gnat_library id104}@anchor{352} @section @cite{GNAT.SHA512} (@code{g-sha512.ads}) @@ -23542,7 +23660,7 @@ and the HMAC-SHA512 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT Signals g-signal ads,GNAT Sockets g-socket ads,GNAT SHA512 g-sha512 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{345}@anchor{gnat_rm/the_gnat_library id104}@anchor{346} +@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id105}@anchor{354} @section @cite{GNAT.Signals} (@code{g-signal.ads}) @@ -23554,7 +23672,7 @@ Provides the ability to manipulate the blocked status of signals on supported targets. @node GNAT Sockets g-socket ads,GNAT Source_Info g-souinf ads,GNAT Signals g-signal ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id105}@anchor{348} +@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{355}@anchor{gnat_rm/the_gnat_library id106}@anchor{356} @section @cite{GNAT.Sockets} (@code{g-socket.ads}) @@ -23569,7 +23687,7 @@ on all native GNAT ports and on VxWorks cross prots. It is not implemented for the LynxOS cross port. @node GNAT Source_Info g-souinf ads,GNAT Spelling_Checker g-speche ads,GNAT Sockets g-socket ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{349}@anchor{gnat_rm/the_gnat_library id106}@anchor{34a} +@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{357}@anchor{gnat_rm/the_gnat_library id107}@anchor{358} @section @cite{GNAT.Source_Info} (@code{g-souinf.ads}) @@ -23583,7 +23701,7 @@ subprograms yielding the date and time of the current compilation (like the C macros @cite{__DATE__} and @cite{__TIME__}) @node GNAT Spelling_Checker g-speche ads,GNAT Spelling_Checker_Generic g-spchge ads,GNAT Source_Info g-souinf ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{34b}@anchor{gnat_rm/the_gnat_library id107}@anchor{34c} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{359}@anchor{gnat_rm/the_gnat_library id108}@anchor{35a} @section @cite{GNAT.Spelling_Checker} (@code{g-speche.ads}) @@ -23595,7 +23713,7 @@ Provides a function for determining whether one string is a plausible near misspelling of another string. @node GNAT Spelling_Checker_Generic g-spchge ads,GNAT Spitbol Patterns g-spipat ads,GNAT Spelling_Checker g-speche ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id108}@anchor{34e} +@anchor{gnat_rm/the_gnat_library id109}@anchor{35b}@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{35c} @section @cite{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads}) @@ -23608,7 +23726,7 @@ determining whether one string is a plausible near misspelling of another string. @node GNAT Spitbol Patterns g-spipat ads,GNAT Spitbol g-spitbo ads,GNAT Spelling_Checker_Generic g-spchge ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id109}@anchor{34f}@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{350} +@anchor{gnat_rm/the_gnat_library id110}@anchor{35d}@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{35e} @section @cite{GNAT.Spitbol.Patterns} (@code{g-spipat.ads}) @@ -23624,7 +23742,7 @@ the SNOBOL4 dynamic pattern construction and matching capabilities, using the efficient algorithm developed by Robert Dewar for the SPITBOL system. @node GNAT Spitbol g-spitbo ads,GNAT Spitbol Table_Boolean g-sptabo ads,GNAT Spitbol Patterns g-spipat ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id110}@anchor{351}@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{352} +@anchor{gnat_rm/the_gnat_library id111}@anchor{35f}@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{360} @section @cite{GNAT.Spitbol} (@code{g-spitbo.ads}) @@ -23639,7 +23757,7 @@ useful for constructing arbitrary mappings from strings in the style of the SNOBOL4 TABLE function. @node GNAT Spitbol Table_Boolean g-sptabo ads,GNAT Spitbol Table_Integer g-sptain ads,GNAT Spitbol g-spitbo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id111}@anchor{353}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{354} +@anchor{gnat_rm/the_gnat_library id112}@anchor{361}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{362} @section @cite{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads}) @@ -23654,7 +23772,7 @@ for type @cite{Standard.Boolean}, giving an implementation of sets of string values. @node GNAT Spitbol Table_Integer g-sptain ads,GNAT Spitbol Table_VString g-sptavs ads,GNAT Spitbol Table_Boolean g-sptabo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id112}@anchor{355}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{356} +@anchor{gnat_rm/the_gnat_library id113}@anchor{363}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{364} @section @cite{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads}) @@ -23671,7 +23789,7 @@ for type @cite{Standard.Integer}, giving an implementation of maps from string to integer values. @node GNAT Spitbol Table_VString g-sptavs ads,GNAT SSE g-sse ads,GNAT Spitbol Table_Integer g-sptain ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id113}@anchor{357}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{358} +@anchor{gnat_rm/the_gnat_library id114}@anchor{365}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{366} @section @cite{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads}) @@ -23688,7 +23806,7 @@ a variable length string type, giving an implementation of general maps from strings to strings. @node GNAT SSE g-sse ads,GNAT SSE Vector_Types g-ssvety ads,GNAT Spitbol Table_VString g-sptavs ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id114}@anchor{359}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{35a} +@anchor{gnat_rm/the_gnat_library id115}@anchor{367}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{368} @section @cite{GNAT.SSE} (@code{g-sse.ads}) @@ -23700,7 +23818,7 @@ targets. It exposes vector component types together with a general introduction to the binding contents and use. @node GNAT SSE Vector_Types g-ssvety ads,GNAT Strings g-string ads,GNAT SSE g-sse ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{35b}@anchor{gnat_rm/the_gnat_library id115}@anchor{35c} +@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{369}@anchor{gnat_rm/the_gnat_library id116}@anchor{36a} @section @cite{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads}) @@ -23709,7 +23827,7 @@ introduction to the binding contents and use. SSE vector types for use with SSE related intrinsics. @node GNAT Strings g-string ads,GNAT String_Split g-strspl ads,GNAT SSE Vector_Types g-ssvety ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id116}@anchor{35d}@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{35e} +@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{36b}@anchor{gnat_rm/the_gnat_library id117}@anchor{36c} @section @cite{GNAT.Strings} (@code{g-string.ads}) @@ -23719,7 +23837,7 @@ Common String access types and related subprograms. Basically it defines a string access and an array of string access types. @node GNAT String_Split g-strspl ads,GNAT Table g-table ads,GNAT Strings g-string ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id117}@anchor{360} +@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{36d}@anchor{gnat_rm/the_gnat_library id118}@anchor{36e} @section @cite{GNAT.String_Split} (@code{g-strspl.ads}) @@ -23733,7 +23851,7 @@ to the resulting slices. This package is instantiated from @cite{GNAT.Array_Split}. @node GNAT Table g-table ads,GNAT Task_Lock g-tasloc ads,GNAT String_Split g-strspl ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id118}@anchor{361}@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{362} +@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{36f}@anchor{gnat_rm/the_gnat_library id119}@anchor{370} @section @cite{GNAT.Table} (@code{g-table.ads}) @@ -23753,7 +23871,7 @@ while an instantiation of @cite{GNAT.Dynamic_Tables} creates a type that can be used to define dynamic instances of the table. @node GNAT Task_Lock g-tasloc ads,GNAT Time_Stamp g-timsta ads,GNAT Table g-table ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{363}@anchor{gnat_rm/the_gnat_library id119}@anchor{364} +@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{371}@anchor{gnat_rm/the_gnat_library id120}@anchor{372} @section @cite{GNAT.Task_Lock} (@code{g-tasloc.ads}) @@ -23770,7 +23888,7 @@ single global task lock. Appropriate for use in situations where contention between tasks is very rarely expected. @node GNAT Time_Stamp g-timsta ads,GNAT Threads g-thread ads,GNAT Task_Lock g-tasloc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id120}@anchor{366} +@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{373}@anchor{gnat_rm/the_gnat_library id121}@anchor{374} @section @cite{GNAT.Time_Stamp} (@code{g-timsta.ads}) @@ -23785,7 +23903,7 @@ represents the current date and time in ISO 8601 format. This is a very simple routine with minimal code and there are no dependencies on any other unit. @node GNAT Threads g-thread ads,GNAT Traceback g-traceb ads,GNAT Time_Stamp g-timsta ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id121}@anchor{368} +@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{375}@anchor{gnat_rm/the_gnat_library id122}@anchor{376} @section @cite{GNAT.Threads} (@code{g-thread.ads}) @@ -23802,7 +23920,7 @@ further details if your program has threads that are created by a non-Ada environment which then accesses Ada code. @node GNAT Traceback g-traceb ads,GNAT Traceback Symbolic g-trasym ads,GNAT Threads g-thread ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id122}@anchor{369}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{36a} +@anchor{gnat_rm/the_gnat_library id123}@anchor{377}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{378} @section @cite{GNAT.Traceback} (@code{g-traceb.ads}) @@ -23814,7 +23932,7 @@ Provides a facility for obtaining non-symbolic traceback information, useful in various debugging situations. @node GNAT Traceback Symbolic g-trasym ads,GNAT UTF_32 g-table ads,GNAT Traceback g-traceb ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{36b}@anchor{gnat_rm/the_gnat_library id123}@anchor{36c} +@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{379}@anchor{gnat_rm/the_gnat_library id124}@anchor{37a} @section @cite{GNAT.Traceback.Symbolic} (@code{g-trasym.ads}) @@ -23823,7 +23941,7 @@ in various debugging situations. @geindex Trace back facilities @node GNAT UTF_32 g-table ads,GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Traceback Symbolic g-trasym ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id124}@anchor{36d}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{36e} +@anchor{gnat_rm/the_gnat_library id125}@anchor{37b}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{37c} @section @cite{GNAT.UTF_32} (@code{g-table.ads}) @@ -23842,7 +23960,7 @@ lower case to upper case fold routine corresponding to the Ada 2005 rules for identifier equivalence. @node GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Wide_Spelling_Checker g-wispch ads,GNAT UTF_32 g-table ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{36f}@anchor{gnat_rm/the_gnat_library id125}@anchor{370} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{37d}@anchor{gnat_rm/the_gnat_library id126}@anchor{37e} @section @cite{GNAT.Wide_Spelling_Checker} (@code{g-u3spch.ads}) @@ -23855,7 +23973,7 @@ near misspelling of another wide wide string, where the strings are represented using the UTF_32_String type defined in System.Wch_Cnv. @node GNAT Wide_Spelling_Checker g-wispch ads,GNAT Wide_String_Split g-wistsp ads,GNAT Wide_Spelling_Checker g-u3spch ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{371}@anchor{gnat_rm/the_gnat_library id126}@anchor{372} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{37f}@anchor{gnat_rm/the_gnat_library id127}@anchor{380} @section @cite{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads}) @@ -23867,7 +23985,7 @@ Provides a function for determining whether one wide string is a plausible near misspelling of another wide string. @node GNAT Wide_String_Split g-wistsp ads,GNAT Wide_Wide_Spelling_Checker g-zspche ads,GNAT Wide_Spelling_Checker g-wispch ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id127}@anchor{373}@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{374} +@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{381}@anchor{gnat_rm/the_gnat_library id128}@anchor{382} @section @cite{GNAT.Wide_String_Split} (@code{g-wistsp.ads}) @@ -23881,7 +23999,7 @@ to the resulting slices. This package is instantiated from @cite{GNAT.Array_Split}. @node GNAT Wide_Wide_Spelling_Checker g-zspche ads,GNAT Wide_Wide_String_Split g-zistsp ads,GNAT Wide_String_Split g-wistsp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{375}@anchor{gnat_rm/the_gnat_library id128}@anchor{376} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{383}@anchor{gnat_rm/the_gnat_library id129}@anchor{384} @section @cite{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads}) @@ -23893,7 +24011,7 @@ Provides a function for determining whether one wide wide string is a plausible near misspelling of another wide wide string. @node GNAT Wide_Wide_String_Split g-zistsp ads,Interfaces C Extensions i-cexten ads,GNAT Wide_Wide_Spelling_Checker g-zspche ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{377}@anchor{gnat_rm/the_gnat_library id129}@anchor{378} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{385}@anchor{gnat_rm/the_gnat_library id130}@anchor{386} @section @cite{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads}) @@ -23907,7 +24025,7 @@ to the resulting slices. This package is instantiated from @cite{GNAT.Array_Split}. @node Interfaces C Extensions i-cexten ads,Interfaces C Streams i-cstrea ads,GNAT Wide_Wide_String_Split g-zistsp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id130}@anchor{379}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{37a} +@anchor{gnat_rm/the_gnat_library id131}@anchor{387}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{388} @section @cite{Interfaces.C.Extensions} (@code{i-cexten.ads}) @@ -23918,7 +24036,7 @@ for use with either manually or automatically generated bindings to C libraries. @node Interfaces C Streams i-cstrea ads,Interfaces Packed_Decimal i-pacdec ads,Interfaces C Extensions i-cexten ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id131}@anchor{37b}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{37c} +@anchor{gnat_rm/the_gnat_library id132}@anchor{389}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{38a} @section @cite{Interfaces.C.Streams} (@code{i-cstrea.ads}) @@ -23931,7 +24049,7 @@ This package is a binding for the most commonly used operations on C streams. @node Interfaces Packed_Decimal i-pacdec ads,Interfaces VxWorks i-vxwork ads,Interfaces C Streams i-cstrea ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{37d}@anchor{gnat_rm/the_gnat_library id132}@anchor{37e} +@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{38b}@anchor{gnat_rm/the_gnat_library id133}@anchor{38c} @section @cite{Interfaces.Packed_Decimal} (@code{i-pacdec.ads}) @@ -23946,7 +24064,7 @@ from a packed decimal format compatible with that used on IBM mainframes. @node Interfaces VxWorks i-vxwork ads,Interfaces VxWorks IO i-vxwoio ads,Interfaces Packed_Decimal i-pacdec ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id133}@anchor{37f}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{380} +@anchor{gnat_rm/the_gnat_library id134}@anchor{38d}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{38e} @section @cite{Interfaces.VxWorks} (@code{i-vxwork.ads}) @@ -23962,7 +24080,7 @@ In particular, it interfaces with the VxWorks hardware interrupt facilities. @node Interfaces VxWorks IO i-vxwoio ads,System Address_Image s-addima ads,Interfaces VxWorks i-vxwork ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{381}@anchor{gnat_rm/the_gnat_library id134}@anchor{382} +@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{38f}@anchor{gnat_rm/the_gnat_library id135}@anchor{390} @section @cite{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads}) @@ -23985,7 +24103,7 @@ function codes. A particular use of this package is to enable the use of Get_Immediate under VxWorks. @node System Address_Image s-addima ads,System Assertions s-assert ads,Interfaces VxWorks IO i-vxwoio ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{383}@anchor{gnat_rm/the_gnat_library id135}@anchor{384} +@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{391}@anchor{gnat_rm/the_gnat_library id136}@anchor{392} @section @cite{System.Address_Image} (@code{s-addima.ads}) @@ -24001,7 +24119,7 @@ function that gives an (implementation dependent) string which identifies an address. @node System Assertions s-assert ads,System Atomic_Counters s-atocou ads,System Address_Image s-addima ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{385}@anchor{gnat_rm/the_gnat_library id136}@anchor{386} +@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{393}@anchor{gnat_rm/the_gnat_library id137}@anchor{394} @section @cite{System.Assertions} (@code{s-assert.ads}) @@ -24017,7 +24135,7 @@ by an run-time assertion failure, as well as the routine that is used internally to raise this assertion. @node System Atomic_Counters s-atocou ads,System Memory s-memory ads,System Assertions s-assert ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id137}@anchor{387}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{388} +@anchor{gnat_rm/the_gnat_library id138}@anchor{395}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{396} @section @cite{System.Atomic_Counters} (@code{s-atocou.ads}) @@ -24031,7 +24149,7 @@ on most targets, including all Alpha, ia64, PowerPC, SPARC V9, x86, and x86_64 platforms. @node System Memory s-memory ads,System Multiprocessors s-multip ads,System Atomic_Counters s-atocou ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{389}@anchor{gnat_rm/the_gnat_library id138}@anchor{38a} +@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{397}@anchor{gnat_rm/the_gnat_library id139}@anchor{398} @section @cite{System.Memory} (@code{s-memory.ads}) @@ -24049,7 +24167,7 @@ calls to this unit may be made for low level allocation uses (for example see the body of @cite{GNAT.Tables}). @node System Multiprocessors s-multip ads,System Multiprocessors Dispatching_Domains s-mudido ads,System Memory s-memory ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id139}@anchor{38b}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{38c} +@anchor{gnat_rm/the_gnat_library id140}@anchor{399}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{39a} @section @cite{System.Multiprocessors} (@code{s-multip.ads}) @@ -24062,7 +24180,7 @@ in GNAT we also make it available in Ada 95 and Ada 2005 (where it is technically an implementation-defined addition). @node System Multiprocessors Dispatching_Domains s-mudido ads,System Partition_Interface s-parint ads,System Multiprocessors s-multip ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{38d}@anchor{gnat_rm/the_gnat_library id140}@anchor{38e} +@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{39b}@anchor{gnat_rm/the_gnat_library id141}@anchor{39c} @section @cite{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads}) @@ -24075,7 +24193,7 @@ in GNAT we also make it available in Ada 95 and Ada 2005 (where it is technically an implementation-defined addition). @node System Partition_Interface s-parint ads,System Pool_Global s-pooglo ads,System Multiprocessors Dispatching_Domains s-mudido ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id141}@anchor{38f}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{390} +@anchor{gnat_rm/the_gnat_library id142}@anchor{39d}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{39e} @section @cite{System.Partition_Interface} (@code{s-parint.ads}) @@ -24088,7 +24206,7 @@ is used primarily in a distribution context when using Annex E with @cite{GLADE}. @node System Pool_Global s-pooglo ads,System Pool_Local s-pooloc ads,System Partition_Interface s-parint ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id142}@anchor{391}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{392} +@anchor{gnat_rm/the_gnat_library id143}@anchor{39f}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3a0} @section @cite{System.Pool_Global} (@code{s-pooglo.ads}) @@ -24105,7 +24223,7 @@ declared. It uses malloc/free to allocate/free and does not attempt to do any automatic reclamation. @node System Pool_Local s-pooloc ads,System Restrictions s-restri ads,System Pool_Global s-pooglo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{393}@anchor{gnat_rm/the_gnat_library id143}@anchor{394} +@anchor{gnat_rm/the_gnat_library id144}@anchor{3a1}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3a2} @section @cite{System.Pool_Local} (@code{s-pooloc.ads}) @@ -24122,7 +24240,7 @@ a list of allocated blocks, so that all storage allocated for the pool can be freed automatically when the pool is finalized. @node System Restrictions s-restri ads,System Rident s-rident ads,System Pool_Local s-pooloc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id144}@anchor{395}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{396} +@anchor{gnat_rm/the_gnat_library id145}@anchor{3a3}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3a4} @section @cite{System.Restrictions} (@code{s-restri.ads}) @@ -24138,7 +24256,7 @@ compiler determined information on which restrictions are violated by one or more packages in the partition. @node System Rident s-rident ads,System Strings Stream_Ops s-ststop ads,System Restrictions s-restri ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id145}@anchor{397}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{398} +@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3a5}@anchor{gnat_rm/the_gnat_library id146}@anchor{3a6} @section @cite{System.Rident} (@code{s-rident.ads}) @@ -24154,7 +24272,7 @@ since the necessary instantiation is included in package System.Restrictions. @node System Strings Stream_Ops s-ststop ads,System Unsigned_Types s-unstyp ads,System Rident s-rident ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id146}@anchor{399}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{39a} +@anchor{gnat_rm/the_gnat_library id147}@anchor{3a7}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{3a8} @section @cite{System.Strings.Stream_Ops} (@code{s-ststop.ads}) @@ -24170,7 +24288,7 @@ stream attributes are applied to string types, but the subprograms in this package can be used directly by application programs. @node System Unsigned_Types s-unstyp ads,System Wch_Cnv s-wchcnv ads,System Strings Stream_Ops s-ststop ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{39b}@anchor{gnat_rm/the_gnat_library id147}@anchor{39c} +@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{3a9}@anchor{gnat_rm/the_gnat_library id148}@anchor{3aa} @section @cite{System.Unsigned_Types} (@code{s-unstyp.ads}) @@ -24183,7 +24301,7 @@ also contains some related definitions for other specialized types used by the compiler in connection with packed array types. @node System Wch_Cnv s-wchcnv ads,System Wch_Con s-wchcon ads,System Unsigned_Types s-unstyp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{39d}@anchor{gnat_rm/the_gnat_library id148}@anchor{39e} +@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{3ab}@anchor{gnat_rm/the_gnat_library id149}@anchor{3ac} @section @cite{System.Wch_Cnv} (@code{s-wchcnv.ads}) @@ -24204,7 +24322,7 @@ encoding method. It uses definitions in package @cite{System.Wch_Con}. @node System Wch_Con s-wchcon ads,,System Wch_Cnv s-wchcnv ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{39f}@anchor{gnat_rm/the_gnat_library id149}@anchor{3a0} +@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{3ad}@anchor{gnat_rm/the_gnat_library id150}@anchor{3ae} @section @cite{System.Wch_Con} (@code{s-wchcon.ads}) @@ -24216,7 +24334,7 @@ in ordinary strings. These definitions are used by the package @cite{System.Wch_Cnv}. @node Interfacing to Other Languages,Specialized Needs Annexes,The GNAT Library,Top -@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{3a1}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{3a2} +@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{3af}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{3b0} @chapter Interfacing to Other Languages @@ -24234,7 +24352,7 @@ provided. @end menu @node Interfacing to C,Interfacing to C++,,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{3a3}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{3a4} +@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{3b1}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{3b2} @section Interfacing to C @@ -24372,7 +24490,7 @@ of the length corresponding to the @code{type'Size} value in Ada. @end itemize @node Interfacing to C++,Interfacing to COBOL,Interfacing to C,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{3a5}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{3f} +@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{3b3}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{3f} @section Interfacing to C++ @@ -24429,7 +24547,7 @@ The @cite{External_Name} is the name of the C++ RTTI symbol. You can then cover a specific C++ exception in an exception handler. @node Interfacing to COBOL,Interfacing to Fortran,Interfacing to C++,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{3a6}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{3a7} +@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{3b4}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{3b5} @section Interfacing to COBOL @@ -24437,7 +24555,7 @@ Interfacing to COBOL is achieved as described in section B.4 of the Ada Reference Manual. @node Interfacing to Fortran,Interfacing to non-GNAT Ada code,Interfacing to COBOL,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{3a8}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{3a9} +@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{3b6}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{3b7} @section Interfacing to Fortran @@ -24447,7 +24565,7 @@ multi-dimensional array causes the array to be stored in column-major order as required for convenient interface to Fortran. @node Interfacing to non-GNAT Ada code,,Interfacing to Fortran,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{3aa}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{3ab} +@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{3b8}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{3b9} @section Interfacing to non-GNAT Ada code @@ -24471,7 +24589,7 @@ values or simple record types without variants, or simple array types with fixed bounds. @node Specialized Needs Annexes,Implementation of Specific Ada Features,Interfacing to Other Languages,Top -@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{3ac}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{3ad} +@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{3ba}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{3bb} @chapter Specialized Needs Annexes @@ -24512,7 +24630,7 @@ in Ada 2005) is fully implemented. @end table @node Implementation of Specific Ada Features,Implementation of Ada 2012 Features,Specialized Needs Annexes,Top -@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{3ae}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{3af} +@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{3bc}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{3bd} @chapter Implementation of Specific Ada Features @@ -24530,7 +24648,7 @@ facilities. @end menu @node Machine Code Insertions,GNAT Implementation of Tasking,,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{11d}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{3b0} +@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{124}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{3be} @section Machine Code Insertions @@ -24698,7 +24816,7 @@ according to normal visibility rules. In particular if there is no qualification is required. @node GNAT Implementation of Tasking,GNAT Implementation of Shared Passive Packages,Machine Code Insertions,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{3b1}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{3b2} +@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{3bf}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{3c0} @section GNAT Implementation of Tasking @@ -24713,7 +24831,7 @@ to compliance with the Real-Time Systems Annex. @end menu @node Mapping Ada Tasks onto the Underlying Kernel Threads,Ensuring Compliance with the Real-Time Annex,,GNAT Implementation of Tasking -@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{3b3}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{3b4} +@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{3c1}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{3c2} @subsection Mapping Ada Tasks onto the Underlying Kernel Threads @@ -24778,10 +24896,11 @@ Some threads libraries offer a mechanism to fork a new process, with the child process duplicating the threads from the parent. GNAT does not support this functionality when the parent contains more than one task. -.. index:: Forking a new process + +@geindex Forking a new process @node Ensuring Compliance with the Real-Time Annex,,Mapping Ada Tasks onto the Underlying Kernel Threads,GNAT Implementation of Tasking -@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{3b5}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{3b6} +@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{3c3}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{3c4} @subsection Ensuring Compliance with the Real-Time Annex @@ -24830,21 +24949,23 @@ that were ready to execute in the priority queue where R has been placed at the end. @node GNAT Implementation of Shared Passive Packages,Code Generation for Array Aggregates,GNAT Implementation of Tasking,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{3b7}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{3b8} +@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{3c5}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{3c6} @section GNAT Implementation of Shared Passive Packages @geindex Shared passive packages -GNAT fully implements the pragma @cite{Shared_Passive} for -.. index:: pragma @cite{Shared_Passive} - +GNAT fully implements the +@geindex pragma Shared_Passive +pragma +@cite{Shared_Passive} for the purpose of designating shared passive packages. This allows the use of passive partitions in the context described in the Ada Reference Manual; i.e., for communication between separate partitions of a distributed application using the features in Annex E. -.. index:: Annex E + +@geindex Annex E @geindex Distribution Systems Annex @@ -24929,7 +25050,7 @@ GNAT supports shared passive packages on all platforms except for OpenVMS. @node Code Generation for Array Aggregates,The Size of Discriminated Records with Default Discriminants,GNAT Implementation of Shared Passive Packages,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{3b9}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{3ba} +@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{3c7}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{3c8} @section Code Generation for Array Aggregates @@ -24954,13 +25075,13 @@ component values and static subtypes also lead to simpler code. * Static constant aggregates with static bounds:: * Constant aggregates with unconstrained nominal types:: * Aggregates with static bounds:: -* Aggregates with non-static bounds:: +* Aggregates with nonstatic bounds:: * Aggregates in assignment statements:: @end menu @node Static constant aggregates with static bounds,Constant aggregates with unconstrained nominal types,,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{3bb}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{3bc} +@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{3c9}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{3ca} @subsection Static constant aggregates with static bounds @@ -25007,7 +25128,7 @@ Zero2: constant two_dim := (others => (others => 0)); @end example @node Constant aggregates with unconstrained nominal types,Aggregates with static bounds,Static constant aggregates with static bounds,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{3bd}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{3be} +@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{3cb}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{3cc} @subsection Constant aggregates with unconstrained nominal types @@ -25021,8 +25142,8 @@ type One_Unc is array (natural range <>) of integer; Cr_Unc : constant One_Unc := (12,24,36); @end example -@node Aggregates with static bounds,Aggregates with non-static bounds,Constant aggregates with unconstrained nominal types,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{3bf}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{3c0} +@node Aggregates with static bounds,Aggregates with nonstatic bounds,Constant aggregates with unconstrained nominal types,Code Generation for Array Aggregates +@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{3cd}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{3ce} @subsection Aggregates with static bounds @@ -25049,9 +25170,9 @@ for I in Cr_Var2'range loop end loop; @end example -@node Aggregates with non-static bounds,Aggregates in assignment statements,Aggregates with static bounds,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-non-static-bounds}@anchor{3c1}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{3c2} -@subsection Aggregates with non-static bounds +@node Aggregates with nonstatic bounds,Aggregates in assignment statements,Aggregates with static bounds,Code Generation for Array Aggregates +@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{3cf}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{3d0} +@subsection Aggregates with nonstatic bounds If the bounds of the aggregate are not statically compatible with the bounds @@ -25060,8 +25181,8 @@ generated on the bounds. For a multidimensional array, constraint checks may have to be applied to sub-arrays individually, if they do not have statically compatible subtypes. -@node Aggregates in assignment statements,,Aggregates with non-static bounds,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{3c3}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{3c4} +@node Aggregates in assignment statements,,Aggregates with nonstatic bounds,Code Generation for Array Aggregates +@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{3d1}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{3d2} @subsection Aggregates in assignment statements @@ -25103,7 +25224,7 @@ a temporary (created either by the front-end or the code generator) and then that temporary will be copied onto the target. @node The Size of Discriminated Records with Default Discriminants,Strict Conformance to the Ada Reference Manual,Code Generation for Array Aggregates,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{3c5}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{3c6} +@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{3d3}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{3d4} @section The Size of Discriminated Records with Default Discriminants @@ -25183,24 +25304,22 @@ say) must be consistent, so it is imperative that the object, once created, remain invariant. @node Strict Conformance to the Ada Reference Manual,,The Size of Discriminated Records with Default Discriminants,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{3c7}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{3c8} +@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{3d5}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{3d6} @section Strict Conformance to the Ada Reference Manual The dynamic semantics defined by the Ada Reference Manual impose a set of run-time checks to be generated. By default, the GNAT compiler will insert many run-time checks into the compiled code, including most of those required by the -Ada Reference Manual. However, there are three checks that are not enabled -in the default mode for efficiency reasons: arithmetic overflow checking for -integer operations (including division by zero), checks for access before -elaboration on subprogram calls, and stack overflow checking (most operating -systems do not perform this check by default). - -Strict conformance to the Ada Reference Manual can be achieved by adding -three compiler options for overflow checking for integer operations -(@emph{-gnato}), dynamic checks for access-before-elaboration on subprogram -calls and generic instantiations (@emph{-gnatE}), and stack overflow -checking (@emph{-fstack-check}). +Ada Reference Manual. However, there are two checks that are not enabled in +the default mode for efficiency reasons: checks for access before elaboration +on subprogram calls, and stack overflow checking (most operating systems do not +perform this check by default). + +Strict conformance to the Ada Reference Manual can be achieved by adding two +compiler options for dynamic checks for access-before-elaboration on subprogram +calls and generic instantiations (@emph{-gnatE}), and stack overflow checking +(@emph{-fstack-check}). Note that the result of a floating point arithmetic operation in overflow and invalid situations, when the @cite{Machine_Overflows} attribute of the result @@ -25212,7 +25331,7 @@ behavior (although at the cost of a significant performance penalty), so infinite and NaN values are properly generated. @node Implementation of Ada 2012 Features,Obsolescent Features,Implementation of Specific Ada Features,Top -@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{3c9}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{3ca} +@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{3d7}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{3d8} @chapter Implementation of Ada 2012 Features @@ -26069,7 +26188,7 @@ RM References: 4.03.01 (16) @emph{AI-0220 Needed components for aggregates (0000-00-00)} This AI addresses a wording problem in the RM that appears to permit some -complex cases of aggregates with non-static discriminants. GNAT has always +complex cases of aggregates with nonstatic discriminants. GNAT has always implemented the intended semantics. RM References: 4.03.01 (17) @@ -27378,7 +27497,7 @@ RM References: H.04 (8/1) @end itemize @node Obsolescent Features,Compatibility and Porting Guide,Implementation of Ada 2012 Features,Top -@anchor{gnat_rm/obsolescent_features id1}@anchor{3cb}@anchor{gnat_rm/obsolescent_features doc}@anchor{3cc}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15} +@anchor{gnat_rm/obsolescent_features id1}@anchor{3d9}@anchor{gnat_rm/obsolescent_features doc}@anchor{3da}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15} @chapter Obsolescent Features @@ -27397,7 +27516,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{3cd}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{3ce} +@anchor{gnat_rm/obsolescent_features id2}@anchor{3db}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{3dc} @section pragma No_Run_Time @@ -27410,7 +27529,7 @@ preferred usage is to use an appropriately configured run-time that includes just those features that are to be made accessible. @node pragma Ravenscar,pragma Restricted_Run_Time,pragma No_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id3}@anchor{3cf}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{3d0} +@anchor{gnat_rm/obsolescent_features id3}@anchor{3dd}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{3de} @section pragma Ravenscar @@ -27419,7 +27538,7 @@ The pragma @cite{Ravenscar} has exactly the same effect as pragma is part of the new Ada 2005 standard. @node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features -@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{3d1}@anchor{gnat_rm/obsolescent_features id4}@anchor{3d2} +@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{3df}@anchor{gnat_rm/obsolescent_features id4}@anchor{3e0} @section pragma Restricted_Run_Time @@ -27429,7 +27548,7 @@ preferred since the Ada 2005 pragma @cite{Profile} is intended for this kind of implementation dependent addition. @node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{3d3}@anchor{gnat_rm/obsolescent_features id5}@anchor{3d4} +@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{3e1}@anchor{gnat_rm/obsolescent_features id5}@anchor{3e2} @section pragma Task_Info @@ -27455,7 +27574,7 @@ in the spec of package System.Task_Info in the runtime library. @node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features -@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{3d5}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{3d6} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{3e3}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{3e4} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -27465,7 +27584,7 @@ to support the @cite{Task_Info} pragma. The predefined Ada package standard replacement for GNAT's @cite{Task_Info} functionality. @node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{3d7}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{3d8} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{3e5}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{3e6} @chapter Compatibility and Porting Guide @@ -27487,7 +27606,7 @@ applications developed in other Ada environments. @end menu @node Writing Portable Fixed-Point Declarations,Compatibility with Ada 83,,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{3d9}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{3da} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{3e7}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{3e8} @section Writing Portable Fixed-Point Declarations @@ -27609,7 +27728,7 @@ If you follow this scheme you will be guaranteed that your fixed-point types will be portable. @node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{3db}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{3dc} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{3e9}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{3ea} @section Compatibility with Ada 83 @@ -27637,7 +27756,7 @@ following subsections treat the most likely issues to be encountered. @end menu @node Legal Ada 83 programs that are illegal in Ada 95,More deterministic semantics,,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{3dd}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{3de} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{3eb}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{3ec} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -27737,7 +27856,7 @@ the fix is usually simply to add the @cite{(<>)} to the generic declaration. @end itemize @node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{3df}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{3e0} +@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{3ed}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{3ee} @subsection More deterministic semantics @@ -27765,7 +27884,7 @@ which open select branches are executed. @end itemize @node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{3e1}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{3e2} +@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{3ef}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{3f0} @subsection Changed semantics @@ -27807,7 +27926,7 @@ covers only the restricted range. @end itemize @node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{3e3}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{3e4} +@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{3f1}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{3f2} @subsection Other language compatibility issues @@ -27840,7 +27959,7 @@ include @cite{pragma Interface} and the floating point type attributes @end itemize @node Compatibility between Ada 95 and Ada 2005,Implementation-dependent characteristics,Compatibility with Ada 83,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{3e5}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{3e6} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{3f3}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{3f4} @section Compatibility between Ada 95 and Ada 2005 @@ -27912,7 +28031,7 @@ can declare a function returning a value from an anonymous access type. @end itemize @node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{3e7}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{3e8} +@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{3f5}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{3f6} @section Implementation-dependent characteristics @@ -27935,7 +28054,7 @@ transition from certain Ada 83 compilers. @end menu @node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{3e9}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{3ea} +@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{3f7}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{3f8} @subsection Implementation-defined pragmas @@ -27957,7 +28076,7 @@ avoiding compiler rejection of units that contain such pragmas; they are not relevant in a GNAT context and hence are not otherwise implemented. @node Implementation-defined attributes,Libraries,Implementation-defined pragmas,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{3eb}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{3ec} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{3f9}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{3fa} @subsection Implementation-defined attributes @@ -27971,7 +28090,7 @@ Ada 83, GNAT supplies the attributes @cite{Bit}, @cite{Machine_Size} and @cite{Type_Class}. @node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{3ed}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{3ee} +@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{3fb}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{3fc} @subsection Libraries @@ -28000,7 +28119,7 @@ be preferable to retrofit the application using modular types. @end itemize @node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{3ef}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{3f0} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{3fd}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{3fe} @subsection Elaboration order @@ -28036,7 +28155,7 @@ pragmas either globally (as an effect of the @emph{-gnatE} switch) or locally @end itemize @node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{3f1}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{3f2} +@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{3ff}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{400} @subsection Target-specific aspects @@ -28049,10 +28168,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus Ada 2005 and Ada 2012) are sometimes incompatible with typical Ada 83 compiler practices regarding implicit packing, the meaning of the Size attribute, and the size of access values. -GNAT's approach to these issues is described in @ref{3f3,,Representation Clauses}. +GNAT's approach to these issues is described in @ref{401,,Representation Clauses}. @node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{3f4}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{3f5} +@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{402}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{403} @section Compatibility with Other Ada Systems @@ -28095,7 +28214,7 @@ far beyond this minimal set, as described in the next section. @end itemize @node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{3f3}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{3f6} +@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{401}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{404} @section Representation Clauses @@ -28188,7 +28307,7 @@ with thin pointers. @end itemize @node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{3f7}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{3f8} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{405}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{406} @section Compatibility with HP Ada 83 @@ -28218,7 +28337,7 @@ extension of package System. @end itemize @node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top -@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{3f9}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{3fa} +@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{407}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{408} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 21fd59ef66e..1f465ae6035 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 , May 12, 2015 +GNAT User's Guide for Native Platforms , October 23, 2015 AdaCore @@ -6630,7 +6630,7 @@ If you want to generate a single Ada file and not the transitive closure, you can use instead the @emph{-fdump-ada-spec-slim} switch. You can optionally specify a parent unit, of which all generated units will -be children, using @cite{-fada-spec-parent=`@w{`}unit}. +be children, using @cite{-fada-spec-parent=<unit>}. Note that we recommend when possible to use the @emph{g++} driver to generate bindings, even for most C headers, since this will in general @@ -9130,7 +9130,7 @@ messages showing where implicit @cite{pragma Elaborate} and @cite{pragma Elaborate_All} are generated. This is useful in diagnosing elaboration circularities caused by these implicit pragmas when using the static elaboration -model. See the section in this guide on elaboration checking for +model. See See the section in this guide on elaboration checking for further details. These messages are not generated by default, and are intended only for temporary use when debugging circularity problems. @end table @@ -11028,7 +11028,7 @@ are not treated as errors if this switch is present. @item @code{-gnatw.e} -@emph{Activate every optional warning} +@emph{Activate every optional warning.} @geindex Warnings @geindex activate every optional warning @@ -11114,7 +11114,7 @@ This switch suppresses warnings for unrecognized pragmas. @item @code{-gnatw.g} -@emph{Warnings used for GNAT sources} +@emph{Warnings used for GNAT sources.} This switch sets the warning categories that are used by the standard GNAT style. Currently this is equivalent to @@ -11276,18 +11276,28 @@ Note that this warning option functions differently from the restriction @cite{No_Obsolescent_Features} in two respects. First, the restriction applies only to annex J features. Second, the restriction does flag uses of package @cite{ASCII}. +@end table + +@geindex -gnatwJ (gcc) + + +@table @asis @item @code{-gnatwJ} @emph{Suppress warnings on obsolescent features (Annex J).} -.. index:: -gnatwJ (gcc) This switch disables warnings on use of obsolescent features. +@end table + +@geindex -gnatwk (gcc) + + +@table @asis @item @code{-gnatwk} @emph{Activate warnings on variables that could be constants.} -.. index:: -gnatwk (gcc) This switch activates warnings for variables that are initialized but never modified, and then could be declared constants. The default is that @@ -12076,7 +12086,7 @@ procedure K (S : String) is @item @code{-gnatw.w} -@emph{Activate warnings on Warnings Off pragmas} +@emph{Activate warnings on Warnings Off pragmas.} This switch activates warnings for use of @cite{pragma Warnings (Off@comma{} entity)} where either the pragma is entirely useless (because it suppresses no @@ -12095,7 +12105,7 @@ The default is that these warnings are not given. @item @code{-gnatw.W} -@emph{Suppress warnings on unnecessary Warnings Off pragmas} +@emph{Suppress warnings on unnecessary Warnings Off pragmas.} This switch suppresses warnings for use of @cite{pragma Warnings (Off@comma{} ...)}. @end table @@ -12204,7 +12214,7 @@ incompatibilities between Ada language versions. @item @code{-gnatw.y} -@emph{Activate information messages for why package spec needs body} +@emph{Activate information messages for why package spec needs body.} There are a number of cases in which a package spec needs a body. For example, the use of pragma Elaborate_Body, or the declaration @@ -12224,7 +12234,7 @@ body. The default is that such information messages are not output. @item @code{-gnatw.Y} -@emph{Disable information messages for why package spec needs body} +@emph{Disable information messages for why package spec needs body.} This switch suppresses the output of information messages showing why a package specification needs a body. @@ -12692,7 +12702,7 @@ options. For example, @emph{-gnatVif} or @emph{-gnatVfi} @item @code{-gnatVi} -@emph{Validity checks for `in} mode parameters` +@emph{Validity checks for `in` mode parameters.} Arguments for parameters of mode @cite{in} are validity checked in function and procedure calls at the point of call. @@ -12705,7 +12715,7 @@ and procedure calls at the point of call. @item @code{-gnatVm} -@emph{Validity checks for `in out} mode parameters.` +@emph{Validity checks for `in out` mode parameters.} Arguments for parameters of mode @cite{in out} are validity checked in procedure calls at the point of call. The @cite{'m'} here stands for @@ -12730,11 +12740,16 @@ for case statements and left hand side subscripts. Note that the use of the switch @emph{-gnatp} suppresses all run-time checks, including validity checks, and thus implies @emph{-gnatVn}. When this switch is used, it cancels any other @emph{-gnatV} previously issued. +@end table + +@geindex -gnatVo (gcc) + + +@table @asis @item @code{-gnatVo} @emph{Validity checks for operator and attribute operands.} -.. index:: -gnatVo (gcc) Arguments for predefined operators and attributes are validity checked. This includes all operators in package @cite{Standard}, @@ -13469,7 +13484,7 @@ around conditions in @cite{if} statements, @cite{while} statements and @item @code{-gnatyy} -@emph{Set all standard style check options} +@emph{Set all standard style check options.} This is equivalent to @cite{gnaty3aAbcefhiklmnprst}, that is all checking options enabled with the exception of @emph{-gnatyB}, @emph{-gnatyd}, @@ -13484,7 +13499,7 @@ options enabled with the exception of @emph{-gnatyB}, @emph{-gnatyd}, @item @code{-gnaty-} -@emph{Remove style check options} +@emph{Remove style check options.} This causes any subsequent options in the string to act as canceling the corresponding style check option. To cancel maximum nesting level control, @@ -13502,7 +13517,7 @@ allowed after @emph{-}. @item @code{-gnaty+} -@emph{Enable style check options} +@emph{Enable style check options.} This causes any subsequent options in the string to enable the corresponding style check option. That is, it cancels the effect of a previous -, @@ -13601,13 +13616,11 @@ year). The compiler will generate code based on the assumption that the condition being checked is true, which can result in erroneous execution if that assumption is wrong. -The checks subject to suppression include all the checks defined by -the Ada standard, the additional implementation defined checks -@cite{Alignment_Check}, -@cite{Duplicated_Tag_Check}, @cite{Predicate_Check}, and -@cite{Validity_Check}, as well as any checks introduced using -@cite{pragma Check_Name}. Note that @cite{Atomic_Synchronization} -is not automatically suppressed by use of this option. +The checks subject to suppression include all the checks defined by the Ada +standard, the additional implementation defined checks @cite{Alignment_Check}, +@cite{Duplicated_Tag_Check}, @cite{Predicate_Check}, Container_Checks, Tampering_Check, +and @cite{Validity_Check}, as well as any checks introduced using @cite{pragma Check_Name}. Note that @cite{Atomic_Synchronization} is not automatically +suppressed by use of this option. If the code depends on certain checks being active, you can use pragma @cite{Unsuppress} either as a configuration pragma or as @@ -13890,7 +13903,7 @@ indicate Ada 83 compatibility mode. @table @asis -@item @code{-gnat83 (Ada 83 Compatibility Mode)} +@item @code{-gnat83} (Ada 83 Compatibility Mode) Although GNAT is primarily an Ada 95 / Ada 2005 compiler, this switch specifies that the program is to be compiled in Ada 83 mode. With @@ -13905,9 +13918,10 @@ where, due to contractual reasons, existing code needs to be maintained using only Ada 83 features. With few exceptions (most notably the need to use @cite{<>} on -.. index:: Generic formal parameters - -unconstrained generic formal parameters, the use of the new Ada 95 / Ada 2005 +unconstrained +@geindex Generic formal parameters +generic formal parameters, +the use of the new Ada 95 / Ada 2005 reserved words, and the use of packages with optional bodies), it is not necessary to specify the @emph{-gnat83} switch when compiling Ada 83 programs, because, with rare @@ -15135,14 +15149,16 @@ size of the environment task's secondary stack. Output complete list of elaboration-order dependencies. @end table -@geindex -E (gnatbind) +@geindex -Ea (gnatbind) @table @asis -@item @code{-E} +@item @code{-Ea} Store tracebacks in exception occurrences when the target supports it. +The "a" is for "address"; tracebacks will contain hexadecimal addresses, +unless symbolic tracebacks are enabled. See also the packages @cite{GNAT.Traceback} and @cite{GNAT.Traceback.Symbolic} for more information. @@ -15150,6 +15166,27 @@ Note that on x86 ports, you must not use @emph{-fomit-frame-pointer} @emph{gcc} option. @end table +@geindex -Es (gnatbind) + + +@table @asis + +@item @code{-Es} + +Store tracebacks in exception occurrences when the target supports it. +The "s" is for "symbolic"; symbolic tracebacks are enabled. +@end table + +@geindex -E (gnatbind) + + +@table @asis + +@item @code{-E} + +Currently the same as @cite{-Ea}. +@end table + @geindex -F (gnatbind) @@ -15173,7 +15210,7 @@ flag checks are generated. @item @code{-h} -Output usage (help) information +Output usage (help) information. @geindex -H32 (gnatbind) @@ -15282,7 +15319,7 @@ Output object list (to standard output or to the named file). @item @code{-p} -Pessimistic (worst-case) elaboration order +Pessimistic (worst-case) elaboration order. @geindex -P (gnatbind) @@ -15321,7 +15358,7 @@ The @cite{xxx} string specified with the switch is one of: @itemize * @item -@code{in} for an invalid value*. +@code{in} for an invalid value. If zero is invalid for the discrete type in question, then the scalar value is set to all zero bits. @@ -15390,7 +15427,7 @@ Link against a shared GNAT run time when available. @item @code{-t} -Tolerate time stamp and other consistency errors +Tolerate time stamp and other consistency errors. @geindex -T (gnatbind) @@ -15425,11 +15462,19 @@ platforms. (See @ref{125,,Dynamic Stack Usage Analysis} for details.) Verbose mode. Write error messages, header, summary output to @code{stdout}. +@geindex -V (gnatbind) + +@item @code{-V@emph{key}=@emph{value}} + +Store the given association of @cite{key} to @cite{value} in the bind environment. +Values stored this way can be retrieved at run time using +@cite{GNAT.Bind_Environment}. + @geindex -w (gnatbind) @item @code{-w@emph{x}} -Warning mode; @cite{x} = s/e for suppress/treat as error +Warning mode; @cite{x} = s/e for suppress/treat as error. @geindex -Wx (gnatbind) @@ -17821,7 +17866,9 @@ Whether the project is to be installed, values are @cite{true} An array attribute to declare a set of files not part of the sources to be installed. The array discriminant is the directory where the file is to be installed. If a relative directory then Prefix (see -below) is prepended. +below) is prepended. Note also that if the same file name occurs +multiple time in the attribute list, the last one will be the one +installed. @end quotation @geindex Prefix (GNAT Project Manager) @@ -21139,7 +21186,7 @@ in an executable. @item @strong{Run_Path_Origin}: single -Value is the string that may replace the path name of the executable +Value is the the string that may replace the path name of the executable directory in the run path options. @item @@ -21179,12 +21226,20 @@ case-insensitive values are "false" and "true" (the default). Value is the name of the target platform. Taken into account only in the main project. +Note that when the target is specified on the command line (usually with +a switch --target=), the value of attribute reference 'Target is the one +specified on the command line. + @item @strong{Runtime}: single, indexed, case-insensitive index Index is a language name. Indicates the runtime directory that is to be used when using the compiler of the language. Taken into account only in the main project. + +Note that when the runtime is specified for a language on the command line +(usually with a switch --RTS), the value of attribute reference 'Runtime +for this language is the one specified on the command line. @end itemize @item @@ -21256,7 +21311,7 @@ the prefix is "lib". @item @strong{Shared_Library_Suffix}: single -Value is the extension of the name of shared library files. When not +Value is the the extension of the name of shared library files. When not declared, the extension is ".so". @item @@ -21913,7 +21968,9 @@ Value is the directory used to generate the documentation of source code. An array attribute to declare a set of files not part of the sources to be installed. The array discriminant is the directory where the file is to be installed. If a relative directory then Prefix (see -below) is prepended. +below) is prepended. Note also that if the same file name occurs +multiple time in the attribute list, the last one will be the one +installed. @item @strong{Prefix}: single @@ -26321,6 +26378,15 @@ end STB; @end example @end quotation +@subsubheading Automatic Symbolic Tracebacks + + +Symbolic tracebacks may also be enabled by using the -Es switch to gnatbind (as +in @cite{gprbuild -g ... -bargs -Es}). +This will cause the Exception_Information to contain a symbolic traceback, +which will also be printed if an unhandled exception terminates the +program. + @geindex Code Coverage @geindex Profiling @@ -28464,8 +28530,13 @@ This retains compatibility with previous versions of GNAT which suppressed overflow checks by default and always used the base type for computation of intermediate results. -The switch @emph{-gnato} (with no digits following) is equivalent to -.. index:: -gnato (gcc) +@c Sphinx allows no emphasis within :index: role. As a workaround we +@c point the index to "switch" and use emphasis for "-gnato". + +The +@geindex -gnato (gcc) +switch @emph{-gnato} (with no digits following) +is equivalent to @quotation diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 0d99ccf155c..3a4ec5318e0 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -560,7 +560,16 @@ begin Shared_Libgnat := (Shared_Libgnat_Default = SHARED); end; - -- Scan the switches and arguments + -- Carry out package initializations. These are initializations which + -- might logically be performed at elaboration time, and we decide to be + -- consistent. Like elaboration, the order in which these calls are made + -- is in some cases important. + + Csets.Initialize; + Snames.Initialize; + + -- Scan the switches and arguments. Note that Snames must already be + -- initialized (for processing of the -V switch). -- First, scan to detect --version and/or --help @@ -616,14 +625,6 @@ begin Osint.Add_Default_Search_Dirs; - -- Carry out package initializations. These are initializations which - -- might logically be performed at elaboration time, and we decide to be - -- consistent. Like elaboration, the order in which these calls are made - -- is in some cases important. - - Csets.Initialize; - Snames.Initialize; - -- Acquire target parameters Targparm.Get_Target_Parameters; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 190aadfb206..f0eb7e973f3 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -376,7 +376,7 @@ procedure Gnatlink is new String'(Arg); elsif Arg'Length /= 0 and then Arg (1) = '-' then - if Arg'Length > 4 and then Arg (2 .. 5) = "gnat" then + if Arg'Length > 4 and then Arg (2 .. 5) = "gnat" then Exit_With_Error ("invalid switch: """ & Arg & """ (gnat not needed here)"); end if; @@ -1539,8 +1539,7 @@ begin loop -- Do not compile with the front end switches. However, --RTS -- is to be dealt with specially because it needs to be passed - -- if the binder-generated file is in Ada and may also be used - -- to drive the linker. + -- to compile the file generated by the binder. declare Arg : String_Ptr renames Args.Table (Index); @@ -1550,6 +1549,31 @@ begin Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := String_Access (Arg); + -- GNAT doesn't support GCC's multilib mechanism when it + -- is configured with --disable-libada. This means that, + -- when a multilib switch is used to request a particular + -- compilation mode, the corresponding --RTS switch must + -- also be specified. It is convenient to eliminate the + -- redundancy by keying the compilation mode on a single + -- switch, namely --RTS, and have the compiler reinstate + -- the multilib switch (see gcc-interface/lang-specs.h). + -- This switch must be passed to the driver at link time. + + if Arg'Length = 5 + and then Arg (Arg'First + 1 .. Arg'First + 4) = "mrtp" + then + Linker_Options.Increment_Last; + Linker_Options.Table + (Linker_Options.Last) := String_Access (Arg); + + elsif Arg'Length = 6 + and then Arg (Arg'First + 1 .. Arg'First + 5) = "fsjlj" + then + Linker_Options.Increment_Last; + Linker_Options.Table + (Linker_Options.Last) := String_Access (Arg); + end if; + elsif Arg'Length > 5 and then Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=" then @@ -1568,27 +1592,6 @@ begin Opt.RTS_Lib_Path_Name := Get_RTS_Search_Dir (Arg (Arg'First + 6 .. Arg'Last), Objects); - - -- GNAT doesn't support the GCC multilib mechanism. - -- This means that, when a multilib switch is used - -- to request a particular compilation mode, the - -- corresponding runtime switch (--RTS) must also be - -- specified. The long-term goal is to fully support the - -- multilib mechanism; however, in the meantime, it is - -- convenient to eliminate the redundancy by keying the - -- compilation mode on a single switch, namely --RTS. - - -- Pass -mrtp to the linker if --RTS=rtp was passed - - if Arg'Length > 8 - and then - (Arg (Arg'First + 6 .. Arg'First + 8) = "rtp" - or else Arg (Arg'Last - 2 .. Arg'Last) = "rtp") - then - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - new String'("-mrtp"); - end if; end if; end; end loop; @@ -1601,12 +1604,6 @@ begin Osint.Add_Default_Search_Dirs; Targparm.Get_Target_Parameters; - case VM_Target is - when JVM_Target => Gcc := new String'("jvm-gnatcompile"); - when CLI_Target => Gcc := new String'("dotnet-gnatcompile"); - when No_VM => null; - end case; - -- Compile the bind file with the following switches: -- -gnatA stops reading gnat.adc, since we don't know what @@ -1651,15 +1648,7 @@ begin end if; if Linker_Path = null then - if VM_Target = CLI_Target then - Linker_Path := System.OS_Lib.Locate_Exec_On_Path ("dotnet-ld"); - - if Linker_Path = null then - Exit_With_Error ("Couldn't locate dotnet-ld"); - end if; - else - Linker_Path := Gcc_Path; - end if; + Linker_Path := Gcc_Path; end if; Write_Header; @@ -1870,15 +1859,15 @@ begin -- been compiled. if Opt.CodePeer_Mode then + if Tname_FD /= Invalid_FD then + Delete (Tname); + end if; + return; end if; -- Now, actually link the program - -- Skip this step for now on JVM since the Java interpreter will do - -- the actual link at run time. We might consider packing all class files - -- in a .zip file during this step. - Link_Step : declare Num_Args : Natural := (Linker_Options.Last - Linker_Options.First + 1) + @@ -1986,7 +1975,7 @@ begin J := J + 1; end loop; - if Linker_Path = Gcc_Path and then VM_Target = No_VM then + if Linker_Path = Gcc_Path then -- For systems where the default is to link statically with -- libgcc, if gcc is not called with -shared-libgcc, call it @@ -2067,16 +2056,14 @@ begin System.OS_Lib.Spawn (Linker_Path.all, Args, Success); - if Success then - - -- Delete the temporary file used in conjunction with linking - -- if one was created. See Process_Bind_File for details. + -- Delete the temporary file used in conjunction with linking if one + -- was created. See Process_Bind_File for details. - if Tname_FD /= Invalid_FD then - Delete (Tname); - end if; + if Tname_FD /= Invalid_FD then + Delete (Tname); + end if; - else + if not Success then Error_Msg ("error when calling " & Linker_Path.all); Exit_Program (E_Fatal); end if; @@ -2091,10 +2078,7 @@ begin Delete (Binder_Ali_File.all & ASCII.NUL); Delete (Binder_Spec_Src_File.all & ASCII.NUL); Delete (Binder_Body_Src_File.all & ASCII.NUL); - - if VM_Target = No_VM then - Delete (Binder_Obj_File.all & ASCII.NUL); - end if; + Delete (Binder_Obj_File.all & ASCII.NUL); end if; Exit_Program (E_Success); diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index 82f32747948..a01bbb20eeb 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -434,7 +434,7 @@ procedure Gnatname is elsif Arg = "-h" then Usage_Needed := True; - -- -p + -- -P elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then if File_Set then @@ -609,10 +609,65 @@ begin Usage; end if; + if Create_Project then + declare + Gnatname : constant String_Access := + Program_Name ("gnatname", "gnatname"); + Arg_Len : Positive := Argument_Count; + Target : String_Access := null; + + begin + -- Find the target, if any + + if Gnatname.all /= "gnatname" then + Target := + new String'(Gnatname (Gnatname'First .. Gnatname'Last - 9)); + Arg_Len := Arg_Len + 1; + end if; + + declare + Args : Argument_List (1 .. Arg_Len); + Gprname : String_Access := + Locate_Exec_On_Path (Exec_Name => "gprname"); + Success : Boolean; + + begin + if Gprname /= null then + for J in 1 .. Argument_Count loop + Args (J) := new String'(Argument (J)); + end loop; + + -- Add the target if there is one + + if Target /= null then + Args (Args'Last) := new String'("--target=" & Target.all); + end if; + + Spawn (Gprname.all, Args, Success); + + Free (Gprname); + + if Success then + Exit_Program (E_Success); + end if; + end if; + end; + end; + end if; + + -- This only happens if gprname is not found or if the invocation of + -- gprname did not succeed. + + if Create_Project then + Write_Line + ("warning: gnatname -P is obsolete and will not be available in the " + & "next release; use gprname instead"); + end if; + -- If no Ada or foreign pattern was specified, print the usage and return if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0 - and then + and then Patterns.Last (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0 then if Argument_Count = 0 then @@ -629,9 +684,7 @@ begin -- information, the current directory is the directory of the specified -- file. - if Patterns.Last - (Arguments.Table (Arguments.Last).Directories) = 0 - then + if Patterns.Last (Arguments.Table (Arguments.Last).Directories) = 0 then Patterns.Append (Arguments.Table (Arguments.Last).Directories, new String'(".")); end if; diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb index 1611ed9b30e..7d2ec9ca37f 100644 --- a/gcc/ada/gnatxref.adb +++ b/gcc/ada/gnatxref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -176,16 +176,17 @@ procedure Gnatxref is elsif Src_Path_Name = null and then Lib_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adainclude and adalib directories"); + Osint.Fail + ("RTS path not valid: missing adainclude and " + & "adalib directories"); elsif Src_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adainclude directory"); + Osint.Fail + ("RTS path not valid: missing adainclude directory"); - elsif Lib_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adalib directory"); + elsif Lib_Path_Name = null then + Osint.Fail + ("RTS path not valid: missing adalib directory"); end if; end; @@ -200,8 +201,7 @@ procedure Gnatxref is Osint.Fail ("--ext cannot be specified multiple times"); end if; - if EXT_Specified'Length - = Osint.ALI_Default_Suffix'Length + if EXT_Specified'Length = Osint.ALI_Default_Suffix'Length then Osint.ALI_Suffix := EXT_Specified.all'Access; else diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index bd32e818549..6f6c9baee71 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -238,6 +238,7 @@ package body Impunit is ("g-alvevi", F), -- GNAT.Altivec.Vector_Views ("g-arrspl", F), -- GNAT.Array_Split ("g-awk ", F), -- GNAT.AWK + ("g-binenv", F), -- GNAT.Bind_Environment ("g-boubuf", F), -- GNAT.Bounded_Buffers ("g-boumai", F), -- GNAT.Bounded_Mailboxes ("g-bubsor", F), -- GNAT.Bubble_Sort diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 5754fae3619..243f3b80d57 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -46,6 +46,7 @@ that the __vxworks header appear before any other include. */ #ifdef __vxworks #include "vxWorks.h" +#include "version.h" /* for _WRS_VXWORKS_MAJOR */ #endif #ifdef __ANDROID__ @@ -93,7 +94,9 @@ extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); #endif -/* Global values computed by the binder. */ +/* Global values computed by the binder. Note that these variables are + declared here, not in the binder file, to avoid having unresolved + references in the shared libgnat. */ int __gl_main_priority = -1; int __gl_main_cpu = -1; int __gl_time_slice_val = -1; @@ -107,10 +110,12 @@ char *__gl_interrupt_states = 0; int __gl_num_interrupt_states = 0; int __gl_unreserve_all_interrupts = 0; int __gl_exception_tracebacks = 0; +int __gl_exception_tracebacks_symbolic = 0; int __gl_detect_blocking = 0; int __gl_default_stack_size = -1; int __gl_leap_seconds_support = 0; int __gl_canonical_streams = 0; +char *__gl_bind_env_addr = NULL; /* This value is not used anymore, but kept for bootstrapping purpose. */ int __gl_zero_cost_exceptions = 0; @@ -1711,7 +1716,7 @@ __gnat_install_handler (void) #include <iv.h> #endif -#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) +#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__) #include <vmLib.h> #endif @@ -1858,7 +1863,7 @@ __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, page if there's a match. Additionally we're are assured this is a genuine stack overflow condition and and set the message and exception to that effect. */ -#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) +#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__) /* We re-arm the guard page by marking it invalid */ @@ -1892,13 +1897,14 @@ __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, } } } -#endif /* defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) */ +#endif /* defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__) */ __gnat_clear_exception_count (); Raise_From_Signal_Handler (exception, msg); } -#if defined (__i386__) && !defined (VTHREADS) +#if defined (__i386__) && !defined (VTHREADS) && _WRS_VXWORKS_MAJOR < 7 + extern void __gnat_vxsim_error_handler (int sig, siginfo_t *si, void *sc); @@ -1913,6 +1919,20 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc) { sigset_t mask; + /* VxWorks 7 on e500v2 clears the SPE bit of the MSR when entering CPU + exception state. To allow the handler and exception to work properly + when they contain SPE instructions, we need to set it back before doing + anything else. */ +#if (CPU == PPCE500V2) && (_WRS_VXWORKS_MAJOR == 7) + register unsigned msr; + /* Read the MSR value */ + asm volatile ("mfmsr %0" : "=r" (msr)); + /* Force the SPE bit */ + msr |= 0x02000000; + /* Store to MSR */ + asm volatile ("mtmsr %0" : : "r" (msr)); +#endif + /* VxWorks will always mask out the signal during the signal handler and will reenable it on a longjmp. GNAT does not generate a longjmp to return from a signal handler so the signal will still be masked unless @@ -1921,7 +1941,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc) sigdelset (&mask, sig); sigprocmask (SIG_SETMASK, &mask, NULL); -#if defined (__ARMEL__) || defined (__PPC__) || defined (__i386__) +#if defined (__ARMEL__) || defined (__PPC__) || (defined (__i386__) && _WRS_VXWORKS_MAJOR < 7) /* On certain targets, kernel mode, we process signals through a Call Frame Info trampoline, voiding the need for myriads of fallback_frame_state variants in the ZCX runtime. We have no simple way to distinguish ZCX @@ -2021,7 +2041,7 @@ __gnat_install_handler (void) trap_0_entry->inst_fourth = 0xa1480000; #endif -#if defined (__i386__) && !defined (VTHREADS) +#if defined (__i386__) && !defined (VTHREADS) && _WRS_VXWORKS_MAJOR != 7 /* By experiment, found that sysModel () returns the following string prefix for vxsim when running on Linux and Windows. */ model = sysModel (); @@ -2231,17 +2251,58 @@ char __gnat_alternate_stack[32 * 1024]; /* 1 * MINSIGSTKSZ */ Tell the kernel to re-use alt stack when delivering a signal. */ #define UC_RESET_ALT_STACK 0x80000000 -#ifndef __arm__ +#if !(defined (__arm__) || defined (__arm64__)) #include <mach/mach_vm.h> #include <mach/mach_init.h> #include <mach/vm_statistics.h> #endif +#ifdef __arm64__ +#include <sys/ucontext.h> + +/* Trampoline inserted before raising the exception. It modifies the + stack so that PROC (D, M) looks to be called from the fault point. Note + that LR may be incorrectly set. */ +void __gnat_sigtramp (struct Exception_Data *d, const char *m, + mcontext_t ctxt, + void (*proc)(struct Exception_Data *, const char *)); + +asm("\n" +" .section __TEXT,__text,regular,pure_instructions\n" +" .align 2\n" +"___gnat_sigtramp:\n" +" .cfi_startproc\n" + /* Restore callee saved registers. */ +" ldp x19, x20, [x2, #168]\n" +" ldp x21, x22, [x2, #184]\n" +" ldp x23, x24, [x2, #200]\n" +" ldp x25, x26, [x2, #216]\n" +" ldp x27, x28, [x2, #232]\n" +" ldp q8, q9, [x2, #416]\n" +" ldp q10, q11, [x2, #448]\n" +" ldp q12, q13, [x2, #480]\n" +" ldp q14, q15, [x2, #512]\n" + /* Read FP from mcontext. */ +" ldp fp, lr, [x2, #248]\n" + /* Read SP and PC from mcontext. */ +" ldp x6, x7, [x2, #264]\n" +" add lr, x7, #1\n" +" mov sp, x6\n" + /* Create a standard frame. */ +" stp fp, lr, [sp, #-16]!\n" +" .cfi_def_cfa w29, 16\n" +" .cfi_offset w30, -8\n" +" .cfi_offset w29, -16\n" +" br x3\n" +" .cfi_endproc\n" +); +#endif + /* Return true if ADDR is within a stack guard area. */ static int __gnat_is_stack_guard (mach_vm_address_t addr) { -#ifndef __arm__ +#if !(defined (__arm__) || defined (__arm64__)) kern_return_t kret; vm_region_submap_info_data_64_t info; mach_vm_address_t start; @@ -2344,6 +2405,15 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext) for the next signal delivery. The stack can't be used in case of stack checking. */ syscall (SYS_sigreturn, NULL, UC_RESET_ALT_STACK); + +#ifdef __arm64__ + /* On arm64, use a trampoline so that the unwinder won't see the + signal frame. */ + __gnat_sigtramp (exception, msg, + ((ucontext_t *)ucontext)->uc_mcontext, + Raise_From_Signal_Handler); + return; +#endif break; case SIGFPE: diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index b36ec52908e..1330df9b918 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -158,7 +158,6 @@ package body Inline is Name : Entity_Id := Empty; Next : Subp_Index := No_Subp; First_Succ : Succ_Index := No_Succ; - Listed : Boolean := False; Main_Call : Boolean := False; Processed : Boolean := False; end record; @@ -180,8 +179,8 @@ package body Inline is -- called, and for the inlined subprogram that contains the call. If -- the call is in the main compilation unit, Caller is Empty. - procedure Add_Inlined_Subprogram (Index : Subp_Index); - -- Add the subprogram to the list of inlined subprogram for the unit + procedure Add_Inlined_Subprogram (E : Entity_Id); + -- Add subprogram E to the list of inlined subprogram for the unit function Add_Subp (E : Entity_Id) return Subp_Index; -- Make entry in Inlined table for subprogram E, or return table index @@ -347,15 +346,19 @@ package body Inline is return Inline_Package; end if; - -- The call is not in the main unit. See if it is in some inlined - -- subprogram. If so, inline the call and, if the inlining level is - -- set to 1, stop there; otherwise also compile the package as above. + -- The call is not in the main unit. See if it is in some subprogram + -- that can be inlined outside its unit. If so, inline the call and, + -- if the inlining level is set to 1, stop there; otherwise also + -- compile the package as above. Scop := Current_Scope; while Scope (Scop) /= Standard_Standard and then not Is_Child_Unit (Scop) loop - if Is_Overloadable (Scop) and then Is_Inlined (Scop) then + if Is_Overloadable (Scop) + and then Is_Inlined (Scop) + and then not Is_Nested (Scop) + then Add_Call (E, Scop); if Inline_Level = 1 then @@ -378,6 +381,15 @@ package body Inline is begin Append_New_Elmt (N, To => Backend_Calls); + -- Skip subprograms that cannot be inlined outside their unit + + if Is_Abstract_Subprogram (E) + or else Convention (E) = Convention_Protected + or else Is_Nested (E) + then + return; + end if; + -- Find unit containing E, and add to list of inlined bodies if needed. -- If the body is already present, no need to load any other unit. This -- is the case for an initialization procedure, which appears in the @@ -391,13 +403,6 @@ package body Inline is -- no enclosing package to retrieve. In this case, it is the body of -- the function that will have to be loaded. - if Is_Abstract_Subprogram (E) - or else Is_Nested (E) - or else Convention (E) = Convention_Protected - then - return; - end if; - Level := Must_Inline; if Level /= Dont_Inline then @@ -405,6 +410,11 @@ package body Inline is Pack : constant Entity_Id := Get_Code_Unit_Entity (E); begin + -- Ensure that Analyze_Inlined_Bodies will be invoked after + -- completing the analysis of the current unit. + + Inline_Processing_Required := True; + if Pack = E then -- Library-level inlined function. Add function itself to @@ -470,8 +480,7 @@ package body Inline is -- Add_Inlined_Subprogram -- ---------------------------- - procedure Add_Inlined_Subprogram (Index : Subp_Index) is - E : constant Entity_Id := Inlined.Table (Index).Name; + procedure Add_Inlined_Subprogram (E : Entity_Id) is Decl : constant Node_Id := Parent (Declaration_Node (E)); Pack : constant Entity_Id := Get_Code_Unit_Entity (E); @@ -533,8 +542,6 @@ package body Inline is else Register_Backend_Not_Inlined_Subprogram (E); end if; - - Inlined.Table (Index).Listed := True; end Add_Inlined_Subprogram; ------------------------ @@ -601,7 +608,6 @@ package body Inline is Inlined.Table (Inlined.Last).Name := E; Inlined.Table (Inlined.Last).Next := No_Subp; Inlined.Table (Inlined.Last).First_Succ := No_Succ; - Inlined.Table (Inlined.Last).Listed := False; Inlined.Table (Inlined.Last).Main_Call := False; Inlined.Table (Inlined.Last).Processed := False; end New_Entry; @@ -827,7 +833,7 @@ package body Inline is -- as part of an inlined package, but are not themselves called. An -- accurate computation of just those subprograms that are needed -- requires that we perform a transitive closure over the call graph, - -- starting from calls in the main program. + -- starting from calls in the main compilation unit. for Index in Inlined.First .. Inlined.Last loop if not Is_Called (Inlined.Table (Index).Name) then @@ -874,10 +880,8 @@ package body Inline is -- subprograms for the unit. for Index in Inlined.First .. Inlined.Last loop - if Is_Called (Inlined.Table (Index).Name) - and then not Inlined.Table (Index).Listed - then - Add_Inlined_Subprogram (Index); + if Is_Called (Inlined.Table (Index).Name) then + Add_Inlined_Subprogram (Inlined.Table (Index).Name); end if; end loop; @@ -1353,10 +1357,6 @@ package body Inline is -- Returns True if subprogram Id is defined in the visible part of a -- package specification. - function Is_Expression_Function (Id : Entity_Id) return Boolean; - -- Returns True if subprogram Id was defined originally as an expression - -- function. - --------------------------------------------------- -- Has_Formal_With_Discriminant_Dependent_Fields -- --------------------------------------------------- @@ -1468,20 +1468,6 @@ package body Inline is and then List_Containing (Decl) = Visible_Declarations (P); end In_Package_Visible_Spec; - ---------------------------- - -- Is_Expression_Function -- - ---------------------------- - - function Is_Expression_Function (Id : Entity_Id) return Boolean is - Decl : Node_Id := Parent (Parent (Id)); - begin - if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then - Decl := Parent (Decl); - end if; - - return Nkind (Original_Node (Decl)) = N_Expression_Function; - end Is_Expression_Function; - ------------------------ -- Is_Unit_Subprogram -- ------------------------ @@ -1500,7 +1486,7 @@ package body Inline is Id : Entity_Id; -- Procedure or function entity for the subprogram - -- Start of Can_Be_Inlined_In_GNATprove_Mode + -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode begin pragma Assert (Present (Spec_Id) or else Present (Body_Id)); @@ -1530,6 +1516,12 @@ package body Inline is elsif In_Package_Visible_Spec (Id) then return False; + -- Do not inline subprograms marked No_Return, possibly used for + -- signaling errors, which GNATprove handles specially. + + elsif No_Return (Id) then + return False; + -- Do not inline subprograms that have a contract on the spec or the -- body. Use the contract(s) instead in GNATprove. @@ -3452,14 +3444,12 @@ package body Inline is if Nkind (D) = N_Package_Declaration then Cannot_Inline - ("cannot inline & (nested package declaration)?", - D, Subp); + ("cannot inline & (nested package declaration)?", D, Subp); return True; elsif Nkind (D) = N_Package_Instantiation then Cannot_Inline - ("cannot inline & (nested package instantiation)?", - D, Subp); + ("cannot inline & (nested package instantiation)?", D, Subp); return True; end if; @@ -3472,8 +3462,7 @@ package body Inline is or else Nkind (D) = N_Single_Task_Declaration then Cannot_Inline - ("cannot inline & (nested task type declaration)?", - D, Subp); + ("cannot inline & (nested task type declaration)?", D, Subp); return True; elsif Nkind (D) = N_Protected_Type_Declaration @@ -3486,23 +3475,50 @@ package body Inline is elsif Nkind (D) = N_Subprogram_Body then Cannot_Inline - ("cannot inline & (nested subprogram)?", - D, Subp); + ("cannot inline & (nested subprogram)?", D, Subp); return True; elsif Nkind (D) = N_Function_Instantiation and then not Is_Unchecked_Conversion (D) then Cannot_Inline - ("cannot inline & (nested function instantiation)?", - D, Subp); + ("cannot inline & (nested function instantiation)?", D, Subp); return True; elsif Nkind (D) = N_Procedure_Instantiation then Cannot_Inline - ("cannot inline & (nested procedure instantiation)?", - D, Subp); + ("cannot inline & (nested procedure instantiation)?", D, Subp); return True; + + -- Subtype declarations with predicates will generate predicate + -- functions, i.e. nested subprogram bodies, so inlining is not + -- possible. + + elsif Nkind (D) = N_Subtype_Declaration + and then Present (Aspect_Specifications (D)) + then + declare + A : Node_Id; + A_Id : Aspect_Id; + + begin + A := First (Aspect_Specifications (D)); + while Present (A) loop + A_Id := Get_Aspect_Id (Chars (Identifier (A))); + + if A_Id = Aspect_Predicate + or else A_Id = Aspect_Static_Predicate + or else A_Id = Aspect_Dynamic_Predicate + then + Cannot_Inline + ("cannot inline & (subtype declaration with " + & "predicate)?", D, Subp); + return True; + end if; + + Next (A); + end loop; + end; end if; Next (D); diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index 5d1c5bb7278..b007b36cb67 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -30,17 +30,15 @@ -- b) Compilation of unit bodies that contain the bodies of inlined sub- -- programs. This is done only if inlining is enabled (-gnatn). Full inlining --- requires that a) an b) be mutually recursive, because each step may --- generate another generic expansion and further inlined calls. For now each --- of them uses a workpile algorithm, but they are called independently from --- Frontend, and thus are not mutually recursive. +-- requires that a) and b) be mutually recursive, because each step may +-- generate another generic expansion and further inlined calls. -- c) Front-end inlining for Inline_Always subprograms. This is primarily an -- expansion activity that is performed for performance reasons, and when the --- target does not use the gcc backend. +-- target does not use the GCC back end. -- d) Front-end inlining for GNATprove, to perform source transformations --- to simplify formal verification. The machinery used is the same than for +-- to simplify formal verification. The machinery used is the same as for -- Inline_Always subprograms, but there are fewer restrictions on the source -- of subprograms. @@ -165,7 +163,7 @@ package Inline is -- subsequently used for inline expansions at call sites. If subprogram can -- be inlined (depending on size and nature of local declarations) the -- template body is created. Otherwise subprogram body is treated normally - -- and calls are not inlined in the frontend. If proper warnings are + -- and calls are not inlined in the frontend. If proper warnings are -- enabled and the subprogram contains a construct that cannot be inlined, -- the problematic construct is flagged accordingly. diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 0c7a7777868..c8d7ed7f6c7 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -2430,7 +2430,7 @@ package body Layout is -- represents them the same way. if Is_Access_Type (E) then - Desig_Type := Underlying_Type (Designated_Type (E)); + Desig_Type := Underlying_Type (Designated_Type (E)); -- If we only have a limited view of the type, see whether the -- non-limited view is available. @@ -3412,7 +3412,7 @@ package body Layout is -- type is the partial or full view, so that types will always -- match on calls from one size function to another. - if Has_Private_Declaration (Vtype) then + if Has_Private_Declaration (Vtype) then Vtype_Primary_View := Etype (Vtype); else Vtype_Primary_View := Vtype; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 5a3dcc4d155..dfa1a5bc757 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -454,16 +454,7 @@ package body Lib.Writ is not Has_No_Elaboration_Code (Parent (Declaration_Node (Body_Entity (Uent)))))) then - if Convention (Uent) = Convention_CIL then - - -- Special case for generic CIL packages which never have - -- elaboration code - - Write_Info_Str (" NE"); - - else - Write_Info_Str (" EE"); - end if; + Write_Info_Str (" EE"); end if; if Has_No_Elaboration_Code (Unode) then diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index b38d65b23dd..3280d184a15 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -104,6 +104,10 @@ package body SPARK_Specific is function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range; -- Hash function for hash table + procedure Traverse_Declaration_Or_Statement + (N : Node_Id; + Process : Node_Processing; + Inside_Stubs : Boolean); procedure Traverse_Declarations_Or_Statements (L : List_Id; Process : Node_Processing; @@ -112,11 +116,11 @@ package body SPARK_Specific is (N : Node_Id; Process : Node_Processing; Inside_Stubs : Boolean); - procedure Traverse_Package_Body + procedure Traverse_Protected_Body (N : Node_Id; Process : Node_Processing; Inside_Stubs : Boolean); - procedure Traverse_Package_Declaration + procedure Traverse_Package_Body (N : Node_Id; Process : Node_Processing; Inside_Stubs : Boolean); @@ -154,7 +158,7 @@ package body SPARK_Specific is Traverse_Compilation_Unit (CU => Cunit (Ubody), Process => Detect_And_Add_SPARK_Scope'Access, - Inside_Stubs => False); + Inside_Stubs => True); end if; -- When two units are present for the same compilation unit, as it @@ -166,7 +170,7 @@ package body SPARK_Specific is Traverse_Compilation_Unit (CU => Cunit (Uspec), Process => Detect_And_Add_SPARK_Scope'Access, - Inside_Stubs => False); + Inside_Stubs => True); end if; end if; @@ -239,6 +243,11 @@ package body SPARK_Specific is procedure Add_SPARK_Scope (N : Node_Id) is E : constant Entity_Id := Defining_Entity (N); Loc : constant Source_Ptr := Sloc (E); + + -- The character describing the kind of scope is chosen to be the same + -- as the one describing the corresponding entity in cross references, + -- see Xref_Entity_Letters in lib-xrefs.ads + Typ : Character; begin @@ -249,39 +258,23 @@ package body SPARK_Specific is end if; case Ekind (E) is - when E_Function | E_Generic_Function => - Typ := 'V'; - - when E_Procedure | E_Generic_Procedure => - Typ := 'U'; - - when E_Subprogram_Body => - declare - Spec : Node_Id; - - begin - Spec := Parent (E); - - if Nkind (Spec) = N_Defining_Program_Unit_Name then - Spec := Parent (Spec); - end if; - - if Nkind (Spec) = N_Function_Specification then - Typ := 'V'; - else - pragma Assert - (Nkind (Spec) = N_Procedure_Specification); - Typ := 'U'; - end if; - end; - - when E_Package | E_Package_Body | E_Generic_Package => - Typ := 'K'; + when E_Entry + | E_Function + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Package + | E_Procedure + => + Typ := Xref_Entity_Letters (Ekind (E)); + + when E_Package_Body | E_Subprogram_Body => + Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E))); when E_Void => - -- Compilation of prj-attr.adb with -gnatn creates a node with - -- entity E_Void for the package defined at a-charac.ads16:13 + -- Compilation of prj-attr.adb with -gnatn creates a node with + -- entity E_Void for the package defined at a-charac.ads16:13. -- ??? TBD return; @@ -318,6 +311,16 @@ package body SPARK_Specific is function Get_Entity_Type (E : Entity_Id) return Character; -- Return a character representing the type of entity + function Is_Constant_Object_Without_Variable_Input + (E : Entity_Id) return Boolean; + -- Return True if E is known to have no variable input, as defined in + -- SPARK RM. + + function Is_Future_Scope_Entity + (E : Entity_Id; + S : Scope_Index) return Boolean; + -- Check whether entity E is in SPARK_Scope_Table at index S or higher + function Is_SPARK_Reference (E : Entity_Id; Typ : Character) return Boolean; @@ -328,11 +331,6 @@ package body SPARK_Specific is -- Return whether the entity or reference scope meets requirements for -- being an SPARK scope. - function Is_Future_Scope_Entity - (E : Entity_Id; - S : Scope_Index) return Boolean; - -- Check whether entity E is in SPARK_Scope_Table at index S or higher - function Lt (Op1 : Natural; Op2 : Natural) return Boolean; -- Comparison function for Sort call @@ -419,48 +417,47 @@ package body SPARK_Specific is return Scopes.Get (N).Num; end Get_Scope_Num; - ------------------------ - -- Is_SPARK_Reference -- - ------------------------ + ----------------------------------------------- + -- Is_Constant_Object_Without_Variable_Input -- + ----------------------------------------------- - function Is_SPARK_Reference - (E : Entity_Id; - Typ : Character) return Boolean + function Is_Constant_Object_Without_Variable_Input + (E : Entity_Id) return Boolean is - begin - -- The only references of interest on callable entities are calls. On - -- non-callable entities, the only references of interest are reads - -- and writes. + Result : Boolean; - if Ekind (E) in Overloadable_Kind then - return Typ = 's'; + begin + case Ekind (E) is - -- Objects of Task type or protected type are not SPARK references + -- A constant is known to have no variable input if its + -- initializing expression is static (a value which is + -- compile-time-known is not guaranteed to have no variable input + -- as defined in the SPARK RM). Otherwise, the constant may or not + -- have variable input. - elsif Present (Etype (E)) - and then Ekind (Etype (E)) in Concurrent_Kind - then - return False; - - -- In all other cases, result is true for reference/modify cases, - -- and false for all other cases. + when E_Constant => + declare + Decl : Node_Id; + begin + if Present (Full_View (E)) then + Decl := Parent (Full_View (E)); + else + Decl := Parent (E); + end if; + + pragma Assert (Present (Expression (Decl))); + Result := Is_Static_Expression (Expression (Decl)); + end; - else - return Typ = 'r' or else Typ = 'm'; - end if; - end Is_SPARK_Reference; + when E_Loop_Parameter | E_In_Parameter => + Result := True; - -------------------- - -- Is_SPARK_Scope -- - -------------------- + when others => + Result := False; + end case; - function Is_SPARK_Scope (E : Entity_Id) return Boolean is - begin - return Present (E) - and then not Is_Generic_Unit (E) - and then Renamed_Entity (E) = Empty - and then Get_Scope_Num (E) /= No_Scope; - end Is_SPARK_Scope; + return Result; + end Is_Constant_Object_Without_Variable_Input; ---------------------------- -- Is_Future_Scope_Entity -- @@ -482,12 +479,7 @@ package body SPARK_Specific is begin for Index in SPARK_Scope_Table.First .. S - 1 loop if SPARK_Scope_Table.Table (Index).Scope_Entity = E then - declare - Dummy : constant SPARK_Scope_Record := - SPARK_Scope_Table.Table (Index); - begin - return True; - end; + return True; end if; end loop; @@ -512,6 +504,49 @@ package body SPARK_Specific is return False; end Is_Future_Scope_Entity; + ------------------------ + -- Is_SPARK_Reference -- + ------------------------ + + function Is_SPARK_Reference + (E : Entity_Id; + Typ : Character) return Boolean + is + begin + -- The only references of interest on callable entities are calls. On + -- uncallable entities, the only references of interest are reads and + -- writes. + + if Ekind (E) in Overloadable_Kind then + return Typ = 's'; + + -- Objects of task or protected types are not SPARK references + + elsif Present (Etype (E)) + and then Ekind (Etype (E)) in Concurrent_Kind + then + return False; + + -- In all other cases, result is true for reference/modify cases, + -- and false for all other cases. + + else + return Typ = 'r' or else Typ = 'm'; + end if; + end Is_SPARK_Reference; + + -------------------- + -- Is_SPARK_Scope -- + -------------------- + + function Is_SPARK_Scope (E : Entity_Id) return Boolean is + begin + return Present (E) + and then not Is_Generic_Unit (E) + and then Renamed_Entity (E) = Empty + and then Get_Scope_Num (E) /= No_Scope; + end Is_SPARK_Scope; + -------- -- Lt -- -------- @@ -820,12 +855,15 @@ package body SPARK_Specific is Col := Int (Get_Column_Number (Ref_Entry.Def)); end if; - -- References to constant objects are considered specially in - -- SPARK section, because these will be translated as constants in - -- the intermediate language for formal verification, and should - -- therefore never appear in frame conditions. + -- References to constant objects without variable inputs (see + -- SPARK RM 3.3.1) are considered specially in SPARK section, + -- because these will be translated as constants in the + -- intermediate language for formal verification, and should + -- therefore never appear in frame conditions. Other constants may + -- later be treated the same, up to GNATprove to decide based on + -- its flow analysis. - if Is_Constant_Object (Ref.Ent) then + if Is_Constant_Object_Without_Variable_Input (Ref.Ent) then Typ := 'c'; else Typ := Ref.Typ; @@ -964,11 +1002,14 @@ package body SPARK_Specific is procedure Detect_And_Add_SPARK_Scope (N : Node_Id) is begin - if Nkind_In (N, N_Subprogram_Declaration, + if Nkind_In (N, N_Entry_Body, + N_Entry_Declaration, + N_Package_Body, + N_Package_Body_Stub, + N_Package_Declaration, N_Subprogram_Body, N_Subprogram_Body_Stub, - N_Package_Declaration, - N_Package_Body) + N_Subprogram_Declaration) then Add_SPARK_Scope (N); end if; @@ -991,6 +1032,13 @@ package body SPARK_Specific is and then Nkind (Parent (N)) in N_Subprogram_Specification then Result := Parent (Parent (Parent (N))); + + -- If this was a library-level subprogram then replace Result with + -- its Unit, which points to N_Subprogram_* node. + + if Nkind (Result) = N_Compilation_Unit then + Result := Unit (Result); + end if; else Result := N; end if; @@ -1049,6 +1097,10 @@ package body SPARK_Specific is Result := Parent (Result); end if; + when N_Entry_Body => + Result := Defining_Identifier (Result); + exit; + when others => Result := Parent (Result); end case; @@ -1151,17 +1203,6 @@ package body SPARK_Specific is end if; end Generate_Dereference; - ------------------------------------ - -- Traverse_All_Compilation_Units -- - ------------------------------------ - - procedure Traverse_All_Compilation_Units (Process : Node_Processing) is - begin - for U in Units.First .. Last_Unit loop - Traverse_Compilation_Unit (Cunit (U), Process, Inside_Stubs => False); - end loop; - end Traverse_All_Compilation_Units; - ------------------------------- -- Traverse_Compilation_Unit -- ------------------------------- @@ -1200,175 +1241,214 @@ package body SPARK_Specific is -- Traverse the unit - if Nkind (Lu) = N_Subprogram_Body then - Traverse_Subprogram_Body (Lu, Process, Inside_Stubs); - - elsif Nkind (Lu) = N_Subprogram_Declaration then - null; - - elsif Nkind (Lu) = N_Package_Declaration then - Traverse_Package_Declaration (Lu, Process, Inside_Stubs); - - elsif Nkind (Lu) = N_Package_Body then - Traverse_Package_Body (Lu, Process, Inside_Stubs); - - -- All other cases of compilation units (e.g. renamings), are not - -- declarations, or else generic declarations which are ignored. - - else - null; - end if; + Traverse_Declaration_Or_Statement (Lu, Process, Inside_Stubs); end Traverse_Compilation_Unit; - ----------------------------------------- - -- Traverse_Declarations_Or_Statements -- - ----------------------------------------- + --------------------------------------- + -- Traverse_Declaration_Or_Statement -- + --------------------------------------- - procedure Traverse_Declarations_Or_Statements - (L : List_Id; + procedure Traverse_Declaration_Or_Statement + (N : Node_Id; Process : Node_Processing; Inside_Stubs : Boolean) is - N : Node_Id; - begin - -- Loop through statements or declarations + case Nkind (N) is + when N_Package_Declaration => + declare + Spec : constant Node_Id := Specification (N); + begin + Traverse_Declarations_Or_Statements + (Visible_Declarations (Spec), Process, Inside_Stubs); + Traverse_Declarations_Or_Statements + (Private_Declarations (Spec), Process, Inside_Stubs); + end; - N := First (L); - while Present (N) loop - -- Call Process on all declarations + when N_Package_Body => + if Ekind (Defining_Entity (N)) /= E_Generic_Package then + Traverse_Package_Body (N, Process, Inside_Stubs); + end if; - if Nkind (N) in N_Declaration - or else - Nkind (N) in N_Later_Decl_Item - then - Process (N); - end if; + when N_Package_Body_Stub => + if Present (Library_Unit (N)) then + declare + Body_N : constant Node_Id := Get_Body_From_Stub (N); + begin + if Inside_Stubs + and then + Ekind (Defining_Entity (Body_N)) /= E_Generic_Package + then + Traverse_Package_Body (Body_N, Process, Inside_Stubs); + end if; + end; + end if; - case Nkind (N) is + when N_Subprogram_Declaration => + null; - -- Package declaration + when N_Entry_Body | N_Subprogram_Body => + if not Is_Generic_Subprogram (Defining_Entity (N)) then + Traverse_Subprogram_Body (N, Process, Inside_Stubs); + end if; - when N_Package_Declaration => - Traverse_Package_Declaration (N, Process, Inside_Stubs); + when N_Subprogram_Body_Stub => + if Present (Library_Unit (N)) then + declare + Body_N : constant Node_Id := Get_Body_From_Stub (N); + begin + if Inside_Stubs + and then + not Is_Generic_Subprogram (Defining_Entity (Body_N)) + then + Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs); + end if; + end; + end if; - -- Package body + when N_Protected_Body => + Traverse_Protected_Body (N, Process, Inside_Stubs); - when N_Package_Body => - if Ekind (Defining_Entity (N)) /= E_Generic_Package then - Traverse_Package_Body (N, Process, Inside_Stubs); - end if; + when N_Protected_Body_Stub => + if Present (Library_Unit (N)) then + declare + Body_N : constant Node_Id := Get_Body_From_Stub (N); + begin + if Inside_Stubs then + Traverse_Declarations_Or_Statements + (Declarations (Body_N), Process, Inside_Stubs); + end if; + end; + end if; - when N_Package_Body_Stub => - if Present (Library_Unit (N)) then - declare - Body_N : constant Node_Id := Get_Body_From_Stub (N); - begin - if Inside_Stubs - and then - Ekind (Defining_Entity (Body_N)) /= E_Generic_Package - then - Traverse_Package_Body (Body_N, Process, Inside_Stubs); - end if; - end; - end if; + when N_Protected_Type_Declaration | N_Single_Protected_Declaration => + declare + Def : constant Node_Id := Protected_Definition (N); + begin + Traverse_Declarations_Or_Statements + (Visible_Declarations (Def), Process, Inside_Stubs); + Traverse_Declarations_Or_Statements + (Private_Declarations (Def), Process, Inside_Stubs); + end; - -- Subprogram declaration + when N_Task_Definition => + Traverse_Declarations_Or_Statements + (Visible_Declarations (N), Process, Inside_Stubs); + Traverse_Declarations_Or_Statements + (Private_Declarations (N), Process, Inside_Stubs); - when N_Subprogram_Declaration => - null; + when N_Task_Body => + Traverse_Declarations_Or_Statements + (Declarations (N), Process, Inside_Stubs); + Traverse_Handled_Statement_Sequence + (Handled_Statement_Sequence (N), Process, Inside_Stubs); - -- Subprogram body + when N_Task_Body_Stub => + if Present (Library_Unit (N)) then + declare + Body_N : constant Node_Id := Get_Body_From_Stub (N); + begin + if Inside_Stubs then + Traverse_Declarations_Or_Statements + (Declarations (Body_N), Process, Inside_Stubs); + Traverse_Handled_Statement_Sequence + (Handled_Statement_Sequence (Body_N), Process, + Inside_Stubs); + end if; + end; + end if; - when N_Subprogram_Body => - if not Is_Generic_Subprogram (Defining_Entity (N)) then - Traverse_Subprogram_Body (N, Process, Inside_Stubs); - end if; + when N_Block_Statement => + Traverse_Declarations_Or_Statements + (Declarations (N), Process, Inside_Stubs); + Traverse_Handled_Statement_Sequence + (Handled_Statement_Sequence (N), Process, Inside_Stubs); - when N_Subprogram_Body_Stub => - if Present (Library_Unit (N)) then - declare - Body_N : constant Node_Id := Get_Body_From_Stub (N); - begin - if Inside_Stubs - and then - not Is_Generic_Subprogram (Defining_Entity (Body_N)) - then - Traverse_Subprogram_Body - (Body_N, Process, Inside_Stubs); - end if; - end; - end if; + when N_If_Statement => - -- Block statement + -- Traverse the statements in the THEN part - when N_Block_Statement => - Traverse_Declarations_Or_Statements - (Declarations (N), Process, Inside_Stubs); - Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process, Inside_Stubs); + Traverse_Declarations_Or_Statements + (Then_Statements (N), Process, Inside_Stubs); - when N_If_Statement => + -- Loop through ELSIF parts if present - -- Traverse the statements in the THEN part + if Present (Elsif_Parts (N)) then + declare + Elif : Node_Id := First (Elsif_Parts (N)); - Traverse_Declarations_Or_Statements - (Then_Statements (N), Process, Inside_Stubs); + begin + while Present (Elif) loop + Traverse_Declarations_Or_Statements + (Then_Statements (Elif), Process, Inside_Stubs); + Next (Elif); + end loop; + end; + end if; - -- Loop through ELSIF parts if present + -- Finally traverse the ELSE statements if present - if Present (Elsif_Parts (N)) then - declare - Elif : Node_Id := First (Elsif_Parts (N)); + Traverse_Declarations_Or_Statements + (Else_Statements (N), Process, Inside_Stubs); - begin - while Present (Elif) loop - Traverse_Declarations_Or_Statements - (Then_Statements (Elif), Process, Inside_Stubs); - Next (Elif); - end loop; - end; - end if; + when N_Case_Statement => - -- Finally traverse the ELSE statements if present + -- Process case branches - Traverse_Declarations_Or_Statements - (Else_Statements (N), Process, Inside_Stubs); + declare + Alt : Node_Id; + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + Traverse_Declarations_Or_Statements + (Statements (Alt), Process, Inside_Stubs); + Next (Alt); + end loop; + end; - -- Case statement + when N_Extended_Return_Statement => + Traverse_Handled_Statement_Sequence + (Handled_Statement_Sequence (N), Process, Inside_Stubs); - when N_Case_Statement => + when N_Loop_Statement => + Traverse_Declarations_Or_Statements + (Statements (N), Process, Inside_Stubs); - -- Process case branches + -- Generic declarations are ignored - declare - Alt : Node_Id; - begin - Alt := First (Alternatives (N)); - while Present (Alt) loop - Traverse_Declarations_Or_Statements - (Statements (Alt), Process, Inside_Stubs); - Next (Alt); - end loop; - end; + when others => + null; + end case; + end Traverse_Declaration_Or_Statement; - -- Extended return statement + ----------------------------------------- + -- Traverse_Declarations_Or_Statements -- + ----------------------------------------- - when N_Extended_Return_Statement => - Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process, Inside_Stubs); + procedure Traverse_Declarations_Or_Statements + (L : List_Id; + Process : Node_Processing; + Inside_Stubs : Boolean) + is + N : Node_Id; - -- Loop + begin + -- Loop through statements or declarations - when N_Loop_Statement => - Traverse_Declarations_Or_Statements - (Statements (N), Process, Inside_Stubs); + N := First (L); + while Present (N) loop + -- Call Process on all declarations - -- Generic declarations are ignored + if Nkind (N) in N_Declaration + or else + Nkind (N) in N_Later_Decl_Item + or else + Nkind (N) = N_Entry_Body + then + Process (N); + end if; - when others => - null; - end case; + Traverse_Declaration_Or_Statement (N, Process, Inside_Stubs); Next (N); end loop; @@ -1416,22 +1496,18 @@ package body SPARK_Specific is (Handled_Statement_Sequence (N), Process, Inside_Stubs); end Traverse_Package_Body; - ---------------------------------- - -- Traverse_Package_Declaration -- - ---------------------------------- + ----------------------------- + -- Traverse_Protected_Body -- + ----------------------------- - procedure Traverse_Package_Declaration + procedure Traverse_Protected_Body (N : Node_Id; Process : Node_Processing; - Inside_Stubs : Boolean) - is - Spec : constant Node_Id := Specification (N); + Inside_Stubs : Boolean) is begin Traverse_Declarations_Or_Statements - (Visible_Declarations (Spec), Process, Inside_Stubs); - Traverse_Declarations_Or_Statements - (Private_Declarations (Spec), Process, Inside_Stubs); - end Traverse_Package_Declaration; + (Declarations (N), Process, Inside_Stubs); + end Traverse_Protected_Body; ------------------------------ -- Traverse_Subprogram_Body -- diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 2ebdb146a2e..4751cd32666 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -66,7 +66,7 @@ package body Lib.Xref is Loc : Source_Ptr; -- Location of reference (Original_Location (Sloc field of N parameter - -- to Generate_Reference). Set to No_Location for the case of a + -- to Generate_Reference)). Set to No_Location for the case of a -- defining occurrence. Typ : Character; @@ -192,7 +192,7 @@ package body Lib.Xref is Set_Has_Xref_Entry (Key.Ent); -- It was already in Xref_Set, so throw away the tentatively-added - -- entry + -- entry. else Xrefs.Decrement_Last; @@ -622,7 +622,7 @@ package body Lib.Xref is -- Do not generate references if we are within a postcondition sub- -- program, because the reference does not comes from source, and the - -- pre-analysis of the aspect has already created an entry for the ali + -- pre-analysis of the aspect has already created an entry for the ALI -- file at the proper source location. if Chars (Current_Scope) = Name_uPostconditions then @@ -1073,7 +1073,7 @@ package body Lib.Xref is end if; Add_Entry - ((Ent => Ent, + ((Ent => Ent, Loc => Ref, Typ => Actual_Typ, Eun => Get_Code_Unit (Def), @@ -1120,7 +1120,7 @@ package body Lib.Xref is and then In_Extended_Main_Source_Unit (N) then -- Handle case in which the full-view and partial-view of the - -- first private entity are swapped + -- first private entity are swapped. declare First_Private : Entity_Id := First_Private_Entity (E); @@ -2491,7 +2491,7 @@ package body Lib.Xref is -- Write out information about generic parent, if entity -- is an instance. - if Is_Generic_Instance (XE.Key.Ent) then + if Is_Generic_Instance (XE.Key.Ent) then declare Gen_Par : constant Entity_Id := Generic_Parent diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index c463fe93737..63d78c7c169 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -624,10 +624,9 @@ package Lib.Xref is function Enclosing_Subprogram_Or_Library_Package (N : Node_Id) return Entity_Id; - -- Return the closest enclosing subprogram of package. Only return a - -- library level package. If the package is enclosed in a subprogram, - -- return the subprogram. This ensures that GNATprove can distinguish - -- local variables from global variables. + -- Return the closest enclosing subprogram or library-level package. + -- This ensures that GNATprove can distinguish local variables from + -- global variables. procedure Generate_Dereference (N : Node_Id; @@ -645,10 +644,6 @@ package Lib.Xref is -- Inside_Stubs is True, then the body of stubs is also traversed. -- Generic declarations are ignored. - procedure Traverse_All_Compilation_Units (Process : Node_Processing); - -- Call Process on all declarations through all compilation units. - -- Generic declarations are ignored. - procedure Collect_SPARK_Xrefs (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat); diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index d3324e70c79..f4bd63c81b2 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -87,10 +87,6 @@ package body Make is -- Every program depends on this package, that must then be checked, -- especially when -f and -a are used. - procedure Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer); - pragma Import (C, Kill, "__gnat_kill"); - -- Called by Sigint_Intercepted to kill all spawned compilation processes - type Sigint_Handler is access procedure; pragma Convention (C, Sigint_Handler); @@ -671,12 +667,7 @@ package body Make is -- Compiler, Binder & Linker Data and Subprograms -- ---------------------------------------------------- - Gcc : String_Access := Program_Name ("gcc", "gnatmake"); - Original_Gcc : constant String_Access := Gcc; - -- Original_Gcc is used to check if Gcc has been modified by a switch - -- --GCC=, so that for VM platforms, it is not modified again, as it can - -- result in incorrect error messages if the compiler cannot be found. - + Gcc : String_Access := Program_Name ("gcc", "gnatmake"); Gnatbind : String_Access := Program_Name ("gnatbind", "gnatmake"); Gnatlink : String_Access := Program_Name ("gnatlink", "gnatmake"); -- Default compiler, binder, linker programs @@ -1577,12 +1568,21 @@ package body Make is Source_Name : File_Name_Type; Text : Text_Buffer_Ptr; - Prev_Switch : String_Access; - -- Previous switch processed + First_Arg : Arg_Id; + -- Index of the first argument in Args.Table for a given unit + + Last_Arg : Arg_Id; + -- Index of the last argument in Args.Table for a given unit Arg : Arg_Id := Arg_Id'First; -- Current index in Args.Table for a given unit (init to stop warning) + Number_Of_Switches : Natural; + -- Number of switches recorded for a given unit + + Prev_Switch : String_Access; + -- Previous switch processed + Switch_Found : Boolean; -- True if a given switch has been found @@ -1725,7 +1725,7 @@ package body Make is for J in 1 .. Last_Argument loop - -- Skip non switches -c, -I and -o switches + -- Skip -c, -I and -o switches if Arguments (J) (1) = '-' and then Arguments (J) (2) /= 'c' @@ -1745,6 +1745,9 @@ package body Make is end if; end loop; + First_Arg := Units.Table (ALIs.Table (ALI).First_Unit).First_Arg; + Last_Arg := Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg; + for J in 1 .. Switches_To_Check.Last loop -- Comparing switches is delicate because gcc reorders a number @@ -1762,15 +1765,12 @@ package body Make is Prev_Switch (6) /= Switches_To_Check.Table (J) (6)) then Prev_Switch := Switches_To_Check.Table (J); - Arg := - Units.Table (ALIs.Table (ALI).First_Unit).First_Arg; + Arg := First_Arg; end if; Switch_Found := False; - for K in Arg .. - Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg - loop + for K in Arg .. Last_Arg loop if Switches_To_Check.Table (J).all = Args.Table (K).all then @@ -1792,17 +1792,25 @@ package body Make is end if; end loop; - if Switches_To_Check.Last /= - Integer (Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg - - Units.Table (ALIs.Table (ALI).First_Unit).First_Arg + 1) - then + Number_Of_Switches := Natural (Last_Arg - First_Arg + 1); + + -- Do not count the multilib switches reinstated by the compiler + -- according to the lang-specs.h.settings. + + for K in First_Arg .. Last_Arg loop + if Args.Table (K).all = "-mrtp" + or else Args.Table (K).all = "-fsjlj" + then + Number_Of_Switches := Number_Of_Switches - 1; + end if; + end loop; + + if Switches_To_Check.Last /= Number_Of_Switches then if Verbose_Mode then Verbose_Msg (ALIs.Table (ALI).Sfile, "different number of switches"); - for K in Units.Table (ALIs.Table (ALI).First_Unit).First_Arg - .. Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg - loop + for K in First_Arg .. Last_Arg loop Write_Str (Args.Table (K).all); Write_Char (' '); end loop; @@ -4107,7 +4115,7 @@ package body Make is procedure Globalize_Dirs is new Prj.Env.For_All_Object_Dirs (Globalize_Dir); - -- Start of procedure Globalize + -- Start of processing for Globalize begin Success := True; @@ -4861,12 +4869,10 @@ package body Make is end if; -- If the objects were up-to-date check if the executable file is also - -- up-to-date. For now always bind and link on the JVM since there is - -- currently no simple way to check whether objects are up to date wrt - -- the executable. Same in CodePeer mode where there is no executable. + -- up-to-date. For now always bind and link in CodePeer mode where there + -- is no executable. - if Targparm.VM_Target /= JVM_Target - and then not CodePeer_Mode + if not CodePeer_Mode and then First_Compiled_File = No_File then Executable_Stamp := File_Stamp (Executable); @@ -5812,8 +5818,8 @@ package body Make is Finish_Program (Project_Tree, E_Success); else - -- Call Get_Target_Parameters to ensure that VM_Target and - -- AAMP_On_Target get set before calling Usage. + -- Call Get_Target_Parameters to ensure that AAMP_On_Target gets + -- set before calling Usage. Targparm.Get_Target_Parameters; @@ -6027,39 +6033,6 @@ package body Make is Make_Failed ("*** make failed."); end; - -- Special processing for VM targets - - if Targparm.VM_Target /= No_VM then - - -- Set proper processing commands - - case Targparm.VM_Target is - when Targparm.JVM_Target => - - -- Do not check for an object file (".o") when compiling - -- to JVM machine since ".class" files are generated - -- instead. - - Check_Object_Consistency := False; - - -- Do not modify Gcc is --GCC= was specified - - if Gcc = Original_Gcc then - Gcc := new String'("jvm-gnatcompile"); - end if; - - when Targparm.CLI_Target => - -- Do not modify Gcc is --GCC= was specified - - if Gcc = Original_Gcc then - Gcc := new String'("dotnet-gnatcompile"); - end if; - - when Targparm.No_VM => - raise Program_Error; - end case; - end if; - Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all); Gnatbind_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all); Gnatlink_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all); @@ -6976,7 +6949,7 @@ package body Make is Get_Name_String (ALI_File); Link_Args (1) := new String'(Name_Buffer (1 .. Name_Len)); - Link_Args (2 .. Args'Length + 1) := Args; + Link_Args (2 .. Args'Length + 1) := Args; GNAT.OS_Lib.Normalize_Arguments (Link_Args); @@ -7329,8 +7302,6 @@ package body Make is ------------------------ procedure Sigint_Intercepted is - SIGINT : constant := 2; - begin Set_Standard_Error; Write_Line ("*** Interrupted ***"); @@ -7338,7 +7309,7 @@ package body Make is -- Send SIGINT to all outstanding compilation processes spawned for J in 1 .. Outstanding_Compiles loop - Kill (Running_Compile (J).Pid, SIGINT, 1); + Kill (Running_Compile (J).Pid, Hard_Kill => False); end loop; Finish_Program (Project_Tree, E_No_Compile); @@ -7607,29 +7578,28 @@ package body Make is elsif Src_Path_Name = null and then Lib_Path_Name = null then - Make_Failed ("RTS path not valid: missing " - & "adainclude and adalib directories"); + Make_Failed + ("RTS path not valid: missing adainclude and adalib " + & "directories"); elsif Src_Path_Name = null then - Make_Failed ("RTS path not valid: missing adainclude " - & "directory"); + Make_Failed + ("RTS path not valid: missing adainclude directory"); - elsif Lib_Path_Name = null then - Make_Failed ("RTS path not valid: missing adalib " - & "directory"); + elsif Lib_Path_Name = null then + Make_Failed + ("RTS path not valid: missing adalib directory"); end if; end; end if; - elsif Argv'Length > Source_Info_Option'Length and then - Argv (1 .. Source_Info_Option'Length) = Source_Info_Option + elsif Argv'Length > Source_Info_Option'Length + and then Argv (1 .. Source_Info_Option'Length) = Source_Info_Option then Project_Tree.Source_Info_File_Name := new String'(Argv (Source_Info_Option'Length + 1 .. Argv'Last)); - elsif Argv'Length >= 8 and then - Argv (1 .. 8) = "--param=" - then + elsif Argv'Length >= 8 and then Argv (1 .. 8) = "--param=" then Add_Switch (Argv, Compiler, And_Save => And_Save); Add_Switch (Argv, Linker, And_Save => And_Save); diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index e012e9426ba..c13a151dcb2 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -306,7 +306,7 @@ package Makeutl is -- least equal to Minimum_Verbosity, then print Prefix to standard output -- followed by N1 and S1. If N2 /= No_Name then N2 is printed after S1. S2 -- is printed last. Both N1 and N2 are printed in quotation marks. The two - -- forms differ only in taking Name_Id or File_name_Type arguments. + -- forms differ only in taking Name_Id or File_Name_Type arguments. ------------------------- -- Program termination -- @@ -476,7 +476,7 @@ package Makeutl is function Number_Of_Mains (Tree : Project_Tree_Ref) return Natural; -- Returns the number of mains in this project tree (if Tree is null, it - -- returns the total number of project trees) + -- returns the total number of project trees). procedure Fill_From_Project (Root_Project : Project_Id; diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb index e6eb5e936a3..03e3573aaca 100644 --- a/gcc/ada/mdll.adb +++ b/gcc/ada/mdll.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -326,7 +326,7 @@ package body MDLL is Adr_Opt'Unchecked_Access & All_Options; begin if Map_File then - Params := Map_Opt'Unchecked_Access & Params; + Params := Map_Opt'Unchecked_Access & Params; end if; Utl.Gcc (Output_File => Dll_File, diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index ff84abace85..97797b468e3 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2014, AdaCore -- +-- Copyright (C) 2001-2015, AdaCore -- -- -- -- 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- -- @@ -1816,7 +1816,7 @@ package body MLib.Prj is Delete := False; if (The_Build_Mode = Static - and then Name (1 .. Last) = Archive_Name) + and then Name (1 .. Last) = Archive_Name) or else ((The_Build_Mode = Dynamic or else diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 6def9f273b7..902f347b938 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -628,7 +628,11 @@ package body Namet is -- Get_Last_Two_Chars -- ------------------------ - procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character) is + procedure Get_Last_Two_Chars + (N : Name_Id; + C1 : out Character; + C2 : out Character) + is NE : Name_Entry renames Name_Entries.Table (N); NEL : constant Int := Int (NE.Name_Len); @@ -1309,6 +1313,37 @@ package body Namet is T = V11; end Nam_In; + ----------------- + -- Name_Equals -- + ----------------- + + function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean is + begin + if N1 = N2 then + return True; + end if; + + declare + L1 : constant Int := Int (Name_Entries.Table (N1).Name_Len); + L2 : constant Int := Int (Name_Entries.Table (N2).Name_Len); + + begin + if L1 /= L2 then + return False; + end if; + + declare + use Name_Chars; + I1 : constant Int := Name_Entries.Table (N1).Name_Chars_Index; + I2 : constant Int := Name_Entries.Table (N2).Name_Chars_Index; + + begin + return (Name_Chars.Table (1 + I1 .. I1 + L1) = + Name_Chars.Table (1 + I2 .. I2 + L2)); + end; + end; + end Name_Equals; + ------------------ -- Reinitialize -- ------------------ @@ -1421,7 +1456,6 @@ package body Namet is ----------------------------- procedure Store_Encoded_Character (C : Char_Code) is - procedure Set_Hex_Chars (C : Char_Code); -- Stores given value, which is in the range 0 .. 255, as two hex -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len. diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 4a21ef5b87c..fa30a8ad780 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -309,36 +309,24 @@ package Namet is -- Subprograms -- ----------------- + procedure Add_Char_To_Name_Buffer (C : Character); + pragma Inline (Add_Char_To_Name_Buffer); + -- Add given character to the end of the string currently stored in the + -- Name_Buffer, incrementing Name_Len. + + procedure Add_Nat_To_Name_Buffer (V : Nat); + -- Add decimal representation of given value to the end of the string + -- currently stored in Name_Buffer, incrementing Name_Len as required. + + procedure Add_Str_To_Name_Buffer (S : String); + -- Add characters of string S to the end of the string currently stored in + -- the Name_Buffer, incrementing Name_Len by the length of the string. + procedure Finalize; -- Called at the end of a use of the Namet package (before a subsequent -- call to Initialize). Currently this routine is only used to generate -- debugging output. - procedure Get_Name_String (Id : Name_Id); - -- Get_Name_String is used to retrieve the string associated with an entry - -- in the names table. The resulting string is stored in Name_Buffer and - -- Name_Len is set. It is an error to call Get_Name_String with one of the - -- special name Id values (No_Name or Error_Name). - - function Get_Name_String (Id : Name_Id) return String; - -- This functional form returns the result as a string without affecting - -- the contents of either Name_Buffer or Name_Len. The lower bound is 1. - - procedure Get_Unqualified_Name_String (Id : Name_Id); - -- Similar to the above except that qualification (as defined in unit - -- Exp_Dbug) is removed (including both preceding __ delimited names, and - -- also the suffixes used to indicate package body entities and to - -- distinguish between overloaded entities). Note that names are not - -- qualified until just before the call to gigi, so this routine is only - -- needed by processing that occurs after gigi has been called. This - -- includes all ASIS processing, since ASIS works on the tree written - -- after gigi has been called. - - procedure Get_Name_String_And_Append (Id : Name_Id); - -- Like Get_Name_String but the resulting characters are appended to the - -- current contents of the entry stored in Name_Buffer, and Name_Len is - -- incremented to include the added characters. - procedure Get_Decoded_Name_String (Id : Name_Id); -- Same calling sequence an interface as Get_Name_String, except that the -- result is decoded, so that upper half characters and wide characters @@ -346,15 +334,6 @@ package Namet is -- their source forms (special characters and enclosed in quotes), and -- character literals appear surrounded by apostrophes. - procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id); - -- Similar to the above except that qualification (as defined in unit - -- Exp_Dbug) is removed (including both preceding __ delimited names, and - -- also the suffix used to indicate package body entities). Note that - -- names are not qualified until just before the call to gigi, so this - -- routine is only needed by processing that occurs after gigi has been - -- called. This includes all ASIS processing, since ASIS works on the tree - -- written after gigi has been called. - procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id); -- This routine is similar to Decoded_Name, except that the brackets -- notation (Uhh replaced by ["hh"], Whhhh replaced by ["hhhh"], @@ -366,6 +345,34 @@ package Namet is -- by the character set options (e.g. in the binder generation of -- symbols). + procedure Get_Last_Two_Chars + (N : Name_Id; + C1 : out Character; + C2 : out Character); + -- Obtains last two characters of a name. C1 is last but one character and + -- C2 is last character. If name is less than two characters long then both + -- C1 and C2 are set to ASCII.NUL on return. + + procedure Get_Name_String (Id : Name_Id); + -- Get_Name_String is used to retrieve the string associated with an entry + -- in the names table. The resulting string is stored in Name_Buffer and + -- Name_Len is set. It is an error to call Get_Name_String with one of the + -- special name Id values (No_Name or Error_Name). + + function Get_Name_String (Id : Name_Id) return String; + -- This functional form returns the result as a string without affecting + -- the contents of either Name_Buffer or Name_Len. The lower bound is 1. + + procedure Get_Name_String_And_Append (Id : Name_Id); + -- Like Get_Name_String but the resulting characters are appended to the + -- current contents of the entry stored in Name_Buffer, and Name_Len is + -- incremented to include the added characters. + + function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean; + function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean; + function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean; + -- Fetches the Boolean values associated with the given name + function Get_Name_Table_Byte (Id : Name_Id) return Byte; pragma Inline (Get_Name_Table_Byte); -- Fetches the Byte value associated with the given name @@ -374,14 +381,24 @@ package Namet is pragma Inline (Get_Name_Table_Int); -- Fetches the Int value associated with the given name - function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean; - function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean; - function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean; - -- Fetches the Boolean values associated with the given name + procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id); + -- Similar to the above except that qualification (as defined in unit + -- Exp_Dbug) is removed (including both preceding __ delimited names, and + -- also the suffix used to indicate package body entities). Note that + -- names are not qualified until just before the call to gigi, so this + -- routine is only needed by processing that occurs after gigi has been + -- called. This includes all ASIS processing, since ASIS works on the tree + -- written after gigi has been called. - function Is_Operator_Name (Id : Name_Id) return Boolean; - -- Returns True if name given is of the form of an operator (that - -- is, it starts with an upper case O). + procedure Get_Unqualified_Name_String (Id : Name_Id); + -- Similar to the above except that qualification (as defined in unit + -- Exp_Dbug) is removed (including both preceding __ delimited names, and + -- also the suffixes used to indicate package body entities and to + -- distinguish between overloaded entities). Note that names are not + -- qualified until just before the call to gigi, so this routine is only + -- needed by processing that occurs after gigi has been called. This + -- includes all ASIS processing, since ASIS works on the tree written + -- after gigi has been called. procedure Initialize; -- This is a dummy procedure. It is retained for easy compatibility with @@ -391,16 +408,48 @@ package Namet is -- of Initialize being called more than once. See also Reinitialize which -- allows reinitialization of the tables. - procedure Lock; - -- Lock name tables before calling back end. We reserve some extra space - -- before locking to avoid unnecessary inefficiencies when we unlock. + procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive); + -- Inserts given string in name buffer, starting at Index. Any existing + -- characters at or past this location get moved beyond the inserted string + -- and Name_Len is incremented by the length of the string. - procedure Reinitialize; - -- Clears the name tables and removes all existing entries from the table. + function Is_Internal_Name return Boolean; + -- Like the form with an Id argument, except that the name to be tested is + -- passed in Name_Buffer and Name_Len (which are not affected by the call). + -- Name_Buffer (it loads these as for Get_Name_String). - procedure Unlock; - -- Unlocks the name table to allow use of the extra space reserved by the - -- call to Lock. See gnat1drv for details of the need for this. + function Is_Internal_Name (Id : Name_Id) return Boolean; + -- Returns True if the name is an internal name (i.e. contains a character + -- for which Is_OK_Internal_Letter is true, or if the name starts or ends + -- with an underscore. This call destroys the value of Name_Len and + -- Name_Buffer (it loads these as for Get_Name_String). + -- + -- Note: if the name is qualified (has a double underscore), then only the + -- final entity name is considered, not the qualifying names. Consider for + -- example that the name: + -- + -- pkg__B_1__xyz + -- + -- is not an internal name, because the B comes from the internal name of + -- a qualifying block, but the xyz means that this was indeed a declared + -- identifier called "xyz" within this block and there is nothing internal + -- about that name. + + function Is_OK_Internal_Letter (C : Character) return Boolean; + pragma Inline (Is_OK_Internal_Letter); + -- Returns true if C is a suitable character for using as a prefix or a + -- suffix of an internally generated name, i.e. it is an upper case letter + -- other than one of the ones used for encoding source names (currently the + -- set of reserved letters is O, Q, U, W) and also returns False for the + -- letter X, which is reserved for debug output (see Exp_Dbug). + + function Is_Operator_Name (Id : Name_Id) return Boolean; + -- Returns True if name given is of the form of an operator (that is, it + -- starts with an upper case O). + + function Is_Valid_Name (Id : Name_Id) return Boolean; + -- True if Id is a valid name - points to a valid entry in the Name_Entries + -- table. function Length_Of_Name (Id : Name_Id) return Nat; pragma Inline (Length_Of_Name); @@ -409,25 +458,14 @@ package Namet is -- calling Get_Name_String and reading Name_Len, except that a call to -- Length_Of_Name does not affect the contents of Name_Len and Name_Buffer. + procedure Lock; + -- Lock name tables before calling back end. We reserve some extra space + -- before locking to avoid unnecessary inefficiencies when we unlock. + function Name_Chars_Address return System.Address; -- Return starting address of name characters table (used in Back_End call -- to Gigi). - function Name_Find return Name_Id; - -- Name_Find is called with a string stored in Name_Buffer whose length is - -- in Name_Len (i.e. the characters of the name are in subscript positions - -- 1 to Name_Len in Name_Buffer). It searches the names table to see if the - -- string has already been stored. If so the Id of the existing entry is - -- returned. Otherwise a new entry is created with its Name_Table_Int - -- fields set to zero/false. The contents of Name_Buffer and Name_Len are - -- not modified by this call. Note that it is permissible for Name_Len to - -- be set to zero to lookup the null name string. - - function Name_Find_Str (S : String) return Name_Id; - -- Similar to Name_Find, except that the string is provided as an argument. - -- This call destroys the contents of Name_Buffer and Name_Len (by storing - -- the given string there. - function Name_Enter return Name_Id; -- Name_Enter has the same calling interface as Name_Find. The difference -- is that it does not search the table for an existing match, and also @@ -445,79 +483,47 @@ package Namet is function Name_Entries_Count return Nat; -- Return current number of entries in the names table - function Is_OK_Internal_Letter (C : Character) return Boolean; - pragma Inline (Is_OK_Internal_Letter); - -- Returns true if C is a suitable character for using as a prefix or a - -- suffix of an internally generated name, i.e. it is an upper case letter - -- other than one of the ones used for encoding source names (currently - -- the set of reserved letters is O, Q, U, W) and also returns False for - -- the letter X, which is reserved for debug output (see Exp_Dbug). + function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean; + -- Return whether N1 and N2 denote the same character sequence - function Is_Internal_Name (Id : Name_Id) return Boolean; - -- Returns True if the name is an internal name (i.e. contains a character - -- for which Is_OK_Internal_Letter is true, or if the name starts or ends - -- with an underscore. This call destroys the value of Name_Len and - -- Name_Buffer (it loads these as for Get_Name_String). - -- - -- Note: if the name is qualified (has a double underscore), then only the - -- final entity name is considered, not the qualifying names. Consider for - -- example that the name: - -- - -- pkg__B_1__xyz - -- - -- is not an internal name, because the B comes from the internal name of - -- a qualifying block, but the xyz means that this was indeed a declared - -- identifier called "xyz" within this block and there is nothing internal - -- about that name. + function Name_Find return Name_Id; + -- Name_Find is called with a string stored in Name_Buffer whose length is + -- in Name_Len (i.e. the characters of the name are in subscript positions + -- 1 to Name_Len in Name_Buffer). It searches the names table to see if the + -- string has already been stored. If so the Id of the existing entry is + -- returned. Otherwise a new entry is created with its Name_Table_Int + -- fields set to zero/false. The contents of Name_Buffer and Name_Len are + -- not modified by this call. Note that it is permissible for Name_Len to + -- be set to zero to lookup the null name string. - function Is_Internal_Name return Boolean; - -- Like the form with an Id argument, except that the name to be tested is - -- passed in Name_Buffer and Name_Len (which are not affected by the call). - -- Name_Buffer (it loads these as for Get_Name_String). + function Name_Find_Str (S : String) return Name_Id; + -- Similar to Name_Find, except that the string is provided as an argument. + -- This call destroys the contents of Name_Buffer and Name_Len (by storing + -- the given string there. - function Is_Valid_Name (Id : Name_Id) return Boolean; - -- True if Id is a valid name -- points to a valid entry in the - -- Name_Entries table. + procedure Reinitialize; + -- Clears the name tables and removes all existing entries from the table. procedure Reset_Name_Table; - -- This procedure is used when there are multiple source files to reset - -- the name table info entries associated with current entries in the - -- names table. There is no harm in keeping the names entries themselves - -- from one compilation to another, but we can't keep the entity info, - -- since this refers to tree nodes, which are destroyed between each main - -- source file. - - procedure Add_Char_To_Name_Buffer (C : Character); - pragma Inline (Add_Char_To_Name_Buffer); - -- Add given character to the end of the string currently stored in the - -- Name_Buffer, incrementing Name_Len. - - procedure Add_Nat_To_Name_Buffer (V : Nat); - -- Add decimal representation of given value to the end of the string - -- currently stored in Name_Buffer, incrementing Name_Len as required. - - procedure Add_Str_To_Name_Buffer (S : String); - -- Add characters of string S to the end of the string currently stored - -- in the Name_Buffer, incrementing Name_Len by the length of the string. - - procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive); - -- Inserts given string in name buffer, starting at Index. Any existing - -- characters at or past this location get moved beyond the inserted string - -- and Name_Len is incremented by the length of the string. + -- This procedure is used when there are multiple source files to reset the + -- name table info entries associated with current entries in the names + -- table. There is no harm in keeping the names entries themselves from one + -- compilation to another, but we can't keep the entity info, since this + -- refers to tree nodes, which are destroyed between each main source file. procedure Set_Character_Literal_Name (C : Char_Code); -- This procedure sets the proper encoded name for the character literal -- for the given character code. On return Name_Buffer and Name_Len are -- set to reflect the stored name. - procedure Set_Name_Table_Int (Id : Name_Id; Val : Int); - pragma Inline (Set_Name_Table_Int); - -- Sets the Int value associated with the given name - procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte); pragma Inline (Set_Name_Table_Byte); -- Sets the Byte value associated with the given name + procedure Set_Name_Table_Int (Id : Name_Id; Val : Int); + pragma Inline (Set_Name_Table_Int); + -- Sets the Int value associated with the given name + procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean); procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean); procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean); @@ -543,10 +549,9 @@ package Namet is -- Writes out internal tables to current tree file using the relevant -- Table.Tree_Write routines. - procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character); - -- Obtains last two characters of a name. C1 is last but one character - -- and C2 is last character. If name is less than two characters long, - -- then both C1 and C2 are set to ASCII.NUL on return. + procedure Unlock; + -- Unlocks the name table to allow use of the extra space reserved by the + -- call to Lock. See gnat1drv for details of the need for this. procedure Write_Name (Id : Name_Id); -- Write_Name writes the characters of the specified name using the diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h index 1ca589ba50c..82af02d58fe 100644 --- a/gcc/ada/namet.h +++ b/gcc/ada/namet.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2014, Free Software Foundation, Inc. * + * Copyright (C) 1992-2015, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -88,6 +88,9 @@ Get_Decoded_Name_String (Name_Id Id) return Name_Buffer; } +#define Name_Equals namet__name_equals +extern Boolean Name_Equals (Name_Id, Name_Id); + /* Like Get_Decoded_Name_String, but the result has all qualification and package body entity suffixes stripped, and also all letters are upper cased. This is used for building the enumeration literal table. */ diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 301b5510d59..e99c6b71b25 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -595,7 +595,12 @@ package Opt is Exception_Tracebacks : Boolean := False; -- GNATBIND - -- Set to True to store tracebacks in exception occurrences (-E) + -- Set to True to store tracebacks in exception occurrences (-Ea or -E) + + Exception_Tracebacks_Symbolic : Boolean := False; + -- GNATBIND + -- Set to True to store tracebacks in exception occurrences and enable + -- symbolic tracebacks (-Es). Extensions_Allowed : Boolean := False; -- GNAT @@ -745,9 +750,8 @@ package Opt is GNAT_Encodings : Int; pragma Import (C, GNAT_Encodings, "gnat_encodings"); -- Constant controlling the balance between GNAT encodings and standard - -- DWARF to emit in the debug information. See jmissing.c and aamissing.c - -- for definitions for dotnet/jgnat and GNAAMP back ends. It accepts the - -- following values. + -- DWARF to emit in the debug information. See aamissing.c for definitions + -- for the GNAAMP back end. It accepts the following values. DWARF_GNAT_Encodings_All : constant Int := 0; DWARF_GNAT_Encodings_GDB : constant Int := 1; @@ -819,7 +823,7 @@ package Opt is -- be inlined in GNATprove mode. Init_Or_Norm_Scalars : Boolean := False; - -- GNAT, GANTBIND + -- GNAT, GNATBIND -- Set True if a pragma Initialize_Scalars applies to the current unit. -- Also set True if a pragma Restriction (Normalize_Scalars) applies. @@ -1158,14 +1162,13 @@ package Opt is Optimization_Level : Int; pragma Import (C, Optimization_Level, "optimize"); -- Constant reflecting the optimization level (0,1,2,3 for -O0,-O1,-O2,-O3) - -- See jmissing.c and aamissing.c for definitions for dotnet/jgnat and - -- GNAAMP back ends. + -- See e.g. aamissing.c for definitions for the GNAAMP back end. Optimize_Size : Int; pragma Import (C, Optimize_Size, "optimize_size"); -- Constant reflecting setting of -Os (optimize for size). Set to nonzero - -- in -Os mode and set to zero otherwise. See jmissing.c and aamissing.c - -- for definitions of "optimize_size" for dotnet/jgnat and GNAAMP backends + -- in -Os mode and set to zero otherwise. See aamissing.c for definition + -- of "optimize_size" for the GNAAMP backend. Output_File_Name_Present : Boolean := False; -- GNATBIND, GNAT, GNATMAKE @@ -1431,8 +1434,7 @@ package Opt is -- GNAT -- Set True if tagged types and interfaces should be expanded by the -- front-end. If False, the original tree is left unexpanded for tagged - -- types and dispatching calls, assuming the underlying target supports - -- it (e.g. in the JVM case). + -- types and dispatching calls, assuming the underlying target supports it. Target_Dependent_Info_Read_Name : String_Ptr := null; -- GNAT diff --git a/gcc/ada/osint-c.ads b/gcc/ada/osint-c.ads index afd4e84a346..6819ec037ad 100644 --- a/gcc/ada/osint-c.ads +++ b/gcc/ada/osint-c.ads @@ -111,8 +111,7 @@ package Osint.C is procedure Set_File_Name (Ext : String); -- Sets a default file name from the main compiler source name. Ext is the -- extension, e.g. "ali" for a library information file. The name is in - -- Name_Buffer (with length in Name_Len) on return. This is visible in - -- the spec since it used directly by clients in the .Net case. + -- Name_Buffer (with length in Name_Len) on return. -------------------------------- -- Library Information Output -- diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 6347e4d413b..2e6f0904de3 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -760,7 +760,7 @@ private -- for this file. This routine merely constructs the name. procedure Write_Info (Info : String); - -- Implement Write_Binder_Info, Write_Debug_Info, and Write_Library_Info + -- Implements Write_Binder_Info, Write_Debug_Info, and Write_Library_Info procedure Write_With_Check (A : Address; N : Integer); -- Writes N bytes from buffer starting at address A to file whose FD is diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index 0a739370ae0..9261519b24b 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -350,6 +350,7 @@ package body Output is procedure Write_Char (C : Character) is begin + pragma Assert (Next_Col in Buffer'Range); if Next_Col = Buffer'Length then Write_Eol; end if; @@ -406,17 +407,29 @@ package body Output is --------------- procedure Write_Int (Val : Int) is + -- Type Int has one extra negative number (i.e. two's complement), so we + -- work with negative numbers here. Otherwise, negating Int'First will + -- overflow. + + subtype Nonpositive is Int range Int'First .. 0; + procedure Write_Abs (Val : Nonpositive); + -- Write out the absolute value of Val + + procedure Write_Abs (Val : Nonpositive) is + begin + if Val < -9 then + Write_Abs (Val / 10); -- Recursively write higher digits + end if; + + Write_Char (Character'Val (-(Val rem 10) + Character'Pos ('0'))); + end Write_Abs; + begin if Val < 0 then Write_Char ('-'); - Write_Int (-Val); - + Write_Abs (Val); else - if Val > 9 then - Write_Int (Val / 10); - end if; - - Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0'))); + Write_Abs (-Val); end if; end Write_Int; diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 39169e1fc80..cd1f91a0788 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -726,7 +726,7 @@ package body Ch12 is when Tok_Not => if P_Null_Exclusion then - Typedef_Node := P_Access_Type_Definition; + Typedef_Node := P_Access_Type_Definition; Set_Null_Exclusion_Present (Typedef_Node); return Typedef_Node; @@ -736,10 +736,10 @@ package body Ch12 is return Error; end if; - when Tok_Private => + when Tok_Private => return P_Formal_Private_Type_Definition; - when Tok_Tagged => + when Tok_Tagged => if Next_Token_Is (Tok_Semicolon) then Typedef_Node := New_Node (N_Formal_Incomplete_Type_Definition, Token_Ptr); diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 0be12177513..5859bcea05b 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -3030,8 +3030,23 @@ package body Ch3 is Set_Discriminant_Type (Specification_Node, P_Access_Definition (Not_Null_Present)); - else + -- Catch ouf-of-order keywords + + elsif Token = Tok_Constant then + Scan; + + if Token = Tok_Access then + Error_Msg_SC ("CONSTANT must appear after ACCESS"); + Set_Discriminant_Type + (Specification_Node, + P_Access_Definition (Not_Null_Present)); + + else + Error_Msg_SC ("misplaced CONSTANT"); + end if; + + else Set_Discriminant_Type (Specification_Node, P_Subtype_Mark); No_Constraint; @@ -3495,6 +3510,7 @@ package body Ch3 is end if; Ident_Sloc := Token_Ptr; + Check_Bad_Layout; Idents (1) := P_Defining_Identifier (C_Comma_Colon); Num_Idents := 1; @@ -4425,6 +4441,12 @@ package body Ch3 is else Error_Msg_SC ("aspect specifications not allowed here"); + + -- Assume that this is a misplaced aspect specification + -- within a declarative list. After discarding the + -- misplaced aspects we can continue the scan. + + Done := False; end if; declare @@ -4538,6 +4560,11 @@ package body Ch3 is Scan; -- past RECORD TF_Semicolon; + -- This might happen because of misplaced aspect specification. + -- After discarding the misplaced aspects we can continue the + -- scan. + + Done := False; else Restore_Scan_State (Scan_State); -- to END Done := True; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 7b1bc44f39d..a7d0e5a3d7b 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1729,7 +1729,7 @@ package body Ch5 is Node1 : Node_Id; begin - Node1 := New_Node (N_Iterator_Specification, Sloc (Def_Id)); + Node1 := New_Node (N_Iterator_Specification, Sloc (Def_Id)); Set_Defining_Identifier (Node1, Def_Id); if Token = Tok_Colon then diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 7cc2f5da1da..627e657cfb6 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index d2aeb5a797a..1137823133e 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1089,7 +1089,6 @@ package body Ch9 is Resync_Past_Semicolon; Pop_Scope_Stack; -- discard unused entry return Error; - end P_Accept_Statement; ------------------------ @@ -1098,12 +1097,45 @@ package body Ch9 is -- Parsed by P_Expression (4.4) + -------------------------- + -- 9.5.2 Entry Barrier -- + -------------------------- + + -- ENTRY_BARRIER ::= when CONDITION + + -- Error_Recovery: cannot raise Error_Resync + + function P_Entry_Barrier return Node_Id is + Bnode : Node_Id; + + begin + if Token = Tok_When then + Scan; -- past WHEN; + Bnode := P_Expression_No_Right_Paren; + + if Token = Tok_Colon_Equal then + Error_Msg_SC -- CODEFIX + ("|"":="" should be ""="""); + Scan; + Bnode := P_Expression_No_Right_Paren; + end if; + + else + T_When; -- to give error message + Bnode := Error; + end if; + + return Bnode; + end P_Entry_Barrier; + ----------------------- -- 9.5.2 Entry Body -- ----------------------- -- ENTRY_BODY ::= - -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is + -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART + -- [ASPECT_SPECIFICATIONS] ENTRY_BARRIER + -- is -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS @@ -1114,6 +1146,7 @@ package body Ch9 is -- Error_Recovery: cannot raise Error_Resync function P_Entry_Body return Node_Id is + Dummy_Node : Node_Id; Entry_Node : Node_Id; Formal_Part_Node : Node_Id; Name_Node : Node_Id; @@ -1135,8 +1168,34 @@ package body Ch9 is Formal_Part_Node := P_Entry_Body_Formal_Part; Set_Entry_Body_Formal_Part (Entry_Node, Formal_Part_Node); + -- Ada 2012 (AI12-0169): Aspect specifications may appear on an entry + -- body immediately after the formal part. Do not parse the aspect + -- specifications directly because the "when" of the entry barrier may + -- be interpreted as a misused "with". + + if Token = Tok_With then + P_Aspect_Specifications (Entry_Node, Semicolon => False); + end if; + Set_Condition (Formal_Part_Node, P_Entry_Barrier); + + -- Detect an illegal placement of aspect specifications following the + -- entry barrier. + + -- entry E ... when Barrier with Aspect is + + if Token = Tok_With then + Error_Msg_SC ("aspect specifications must come before entry barrier"); + + -- Consume the illegal aspects to allow for parsing to continue + + Dummy_Node := New_Node (N_Entry_Body, Sloc (Entry_Node)); + P_Aspect_Specifications (Dummy_Node, Semicolon => False); + end if; + + TF_Is; Parse_Decls_Begin_End (Entry_Node); + return Entry_Node; end P_Entry_Body; @@ -1185,38 +1244,6 @@ package body Ch9 is return Fpart_Node; end P_Entry_Body_Formal_Part; - -------------------------- - -- 9.5.2 Entry Barrier -- - -------------------------- - - -- ENTRY_BARRIER ::= when CONDITION - - -- Error_Recovery: cannot raise Error_Resync - - function P_Entry_Barrier return Node_Id is - Bnode : Node_Id; - - begin - if Token = Tok_When then - Scan; -- past WHEN; - Bnode := P_Expression_No_Right_Paren; - - if Token = Tok_Colon_Equal then - Error_Msg_SC -- CODEFIX - ("|"":="" should be ""="""); - Scan; - Bnode := P_Expression_No_Right_Paren; - end if; - - else - T_When; -- to give error message - Bnode := Error; - end if; - - TF_Is; - return Bnode; - end P_Entry_Barrier; - -------------------------------------- -- 9.5.2 Entry Index Specification -- -------------------------------------- diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 825929afa42..c317949d7c2 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1302,9 +1302,9 @@ begin Pragma_Check_Float_Overflow | Pragma_Check_Name | Pragma_Check_Policy | - Pragma_CIL_Constructor | Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning | + Pragma_Constant_After_Elaboration | Pragma_Contract_Cases | Pragma_Convention_Identifier | Pragma_CPP_Class | @@ -1376,8 +1376,6 @@ begin Pragma_Interrupt_State | Pragma_Interrupt_Priority | Pragma_Invariant | - Pragma_Java_Constructor | - Pragma_Java_Interface | Pragma_Keep_Names | Pragma_License | Pragma_Link_With | @@ -1423,6 +1421,7 @@ begin Pragma_Pre | Pragma_Precondition | Pragma_Predicate | + Pragma_Predicate_Failure | Pragma_Preelaborate | Pragma_Pre_Class | Pragma_Priority | @@ -1488,6 +1487,7 @@ begin Pragma_Volatile | Pragma_Volatile_Components | Pragma_Volatile_Full_Access | + Pragma_Volatile_Function | Pragma_Warning_As_Error | Pragma_Weak_External | Pragma_Validity_Checks => diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index a4658bf6939..7c38084033f 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -1577,11 +1577,14 @@ begin -- versions of these files. Another exception is System.RPC -- and its children. This allows a user to supply their own -- communication layer. + -- Similarly, we do not generate an error in CodePeer mode, + -- to allow users to analyze third-party compiler packages. if Comp_Unit_Node /= Error and then Operating_Mode = Generate_Code and then Current_Source_Unit = Main_Unit and then not GNAT_Mode + and then not CodePeer_Mode then declare Uname : constant String := diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 8593dab63d2..c1e6f037781 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -851,11 +851,12 @@ package body Par_SCO is -- Now we have the definitive set of SCO entries, register them in the -- corresponding hash table. - for I in 1 .. Hash_Entries.Last loop + for J in 1 .. Hash_Entries.Last loop SCO_Raw_Hash_Table.Set - (Hash_Entries.Table (I).Sloc, - Hash_Entries.Table (I).SCO_Index); + (Hash_Entries.Table (J).Sloc, + Hash_Entries.Table (J).SCO_Index); end loop; + Hash_Entries.Free; end Process_Decisions; diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb index f726b644bad..cc0bfe5f970 100644 --- a/gcc/ada/pprint.adb +++ b/gcc/ada/pprint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,13 +43,16 @@ package body Pprint is -- Expression_Image -- ---------------------- - function Expression_Image (Expr : Node_Id; Default : String) - return String is - Left : Node_Id := Original_Node (Expr); - Right : Node_Id := Original_Node (Expr); + function Expression_Image + (Expr : Node_Id; + Default : String) return String + is From_Source : constant Boolean := - Comes_From_Source (Expr) and then not Opt.Debug_Generated_Code; + Comes_From_Source (Expr) + and then not Opt.Debug_Generated_Code; Append_Paren : Boolean := False; + Left : Node_Id := Original_Node (Expr); + Right : Node_Id := Original_Node (Expr); function Expr_Name (Expr : Node_Id; @@ -76,6 +79,10 @@ package body Pprint is Add_Paren : Boolean := True) return String; -- Return a string corresponding to List + --------------- + -- List_Name -- + --------------- + function List_Name (List : Node_Id; Add_Space : Boolean := True; @@ -87,6 +94,7 @@ package body Pprint is Add_Space : Boolean := True; Add_Paren : Boolean := True; Num : Natural := 1) return String; + -- ??? what does this do ------------------------ -- Internal_List_Name -- @@ -100,6 +108,7 @@ package body Pprint is Num : Natural := 1) return String is function Prepend (S : String) return String; + -- ??? what does this do ------------- -- Prepend -- @@ -137,20 +146,22 @@ package body Pprint is end if; end if; + -- ??? the Internal_List_Name calls can be factored out + if First then - return Prepend - (Expr_Name (List) - & Internal_List_Name (Next (List), - First => False, - Add_Paren => Add_Paren, - Num => Num + 1)); + return Prepend (Expr_Name (List) + & Internal_List_Name + (List => Next (List), + First => False, + Add_Paren => Add_Paren, + Num => Num + 1)); else - return ", " & Expr_Name (List) & - Internal_List_Name - (Next (List), - First => False, - Add_Paren => Add_Paren, - Num => Num + 1); + return ", " & Expr_Name (List) + & Internal_List_Name + (List => Next (List), + First => False, + Add_Paren => Add_Paren, + Num => Num + 1); end if; end Internal_List_Name; @@ -164,10 +175,13 @@ package body Pprint is end if; List_Name_Count := List_Name_Count + 1; + declare Result : constant String := - Internal_List_Name - (List, Add_Space => Add_Space, Add_Paren => Add_Paren); + Internal_List_Name + (List => List, + Add_Space => Add_Space, + Add_Paren => Add_Paren); begin List_Name_Count := List_Name_Count - 1; return Result; @@ -197,14 +211,14 @@ package body Pprint is when N_Character_Literal => declare Char : constant Int := - UI_To_Int (Char_Literal_Value (Expr)); + UI_To_Int (Char_Literal_Value (Expr)); begin if Char in 32 .. 127 then return "'" & Character'Val (Char) & "'"; else UI_Image (Char_Literal_Value (Expr)); - return "'\" & UI_Image_Buffer (1 .. UI_Image_Length) - & "'"; + return + "'\" & UI_Image_Buffer (1 .. UI_Image_Length) & "'"; end if; end; @@ -223,8 +237,10 @@ package body Pprint is when N_Aggregate => if Present (Sinfo.Expressions (Expr)) then - return List_Name - (First (Sinfo.Expressions (Expr)), Add_Space => False); + return + List_Name + (List => First (Sinfo.Expressions (Expr)), + Add_Space => False); -- Do not return empty string for (others => <>) aggregate -- of a componentless record type. At least one caller (the @@ -237,27 +253,30 @@ package body Pprint is return ("(null record)"); else - return List_Name - (First (Component_Associations (Expr)), - Add_Space => False, Add_Paren => False); + return + List_Name + (List => First (Component_Associations (Expr)), + Add_Space => False, + Add_Paren => False); end if; when N_Extension_Aggregate => - return "(" & Expr_Name (Ancestor_Part (Expr)) & - " with " & - List_Name (First (Sinfo.Expressions (Expr)), - Add_Space => False, Add_Paren => False) & - ")"; + return "(" & Expr_Name (Ancestor_Part (Expr)) & " with " + & List_Name + (List => First (Sinfo.Expressions (Expr)), + Add_Space => False, + Add_Paren => False) & ")"; when N_Attribute_Reference => if Take_Prefix then declare - Str : constant String := Expr_Name (Prefix (Expr)) - & "'" & Get_Name_String (Attribute_Name (Expr)); Id : constant Attribute_Id := - Get_Attribute_Id (Attribute_Name (Expr)); - Ranges : List_Id; + Get_Attribute_Id (Attribute_Name (Expr)); + Str : constant String := + Expr_Name (Prefix (Expr)) & "'" + & Get_Name_String (Attribute_Name (Expr)); N : Node_Id; + Ranges : List_Id; begin if (Id = Attribute_First or else Id = Attribute_Last) @@ -271,22 +290,26 @@ package body Pprint is end if; if Nkind (N) = N_Subtype_Declaration then - Ranges := Constraints (Constraint - (Subtype_Indication (N))); + Ranges := + Constraints + (Constraint (Subtype_Indication (N))); if List_Length (Ranges) = 1 - and then Nkind_In - (First (Ranges), - N_Range, - N_Real_Range_Specification, - N_Signed_Integer_Type_Definition) + and then + Nkind_In + (First (Ranges), + N_Range, + N_Real_Range_Specification, + N_Signed_Integer_Type_Definition) then if Id = Attribute_First then - return Expression_Image - (Low_Bound (First (Ranges)), Str); + return + Expression_Image + (Low_Bound (First (Ranges)), Str); else - return Expression_Image - (High_Bound (First (Ranges)), Str); + return + Expression_Image + (High_Bound (First (Ranges)), Str); end if; end if; end if; @@ -300,7 +323,18 @@ package body Pprint is end if; when N_Explicit_Dereference => - if Take_Prefix then + + -- Return "Foo" instead of "Parameter_Block.Foo.all" + + if Hide_Parameter_Blocks + and then Nkind (Prefix (Expr)) = N_Selected_Component + and then Present (Etype (Prefix (Expr))) + and then Is_Access_Type (Etype (Prefix (Expr))) + and then Is_Param_Block_Component_Type (Etype (Prefix (Expr))) + then + return Expr_Name (Selector_Name (Prefix (Expr))); + + elsif Take_Prefix then return Expr_Name (Prefix (Expr)) & ".all"; else return ".all"; @@ -308,31 +342,36 @@ package body Pprint is when N_Expanded_Name | N_Selected_Component => if Take_Prefix then - return Expr_Name (Prefix (Expr)) - & "." & Expr_Name (Selector_Name (Expr)); + return + Expr_Name (Prefix (Expr)) & "." & + Expr_Name (Selector_Name (Expr)); else return "." & Expr_Name (Selector_Name (Expr)); end if; when N_Component_Association => return "(" - & List_Name (First (Choices (Expr)), - Add_Space => False, Add_Paren => False) + & List_Name + (List => First (Choices (Expr)), + Add_Space => False, + Add_Paren => False) & " => " & Expr_Name (Expression (Expr)) & ")"; when N_If_Expression => declare N : constant Node_Id := First (Sinfo.Expressions (Expr)); begin - return "if " & Expr_Name (N) & " then " & - Expr_Name (Next (N)) & " else " & - Expr_Name (Next (Next (N))); + return + "if " & Expr_Name (N) & " then " + & Expr_Name (Next (N)) & " else " + & Expr_Name (Next (Next (N))); end; when N_Qualified_Expression => declare Mark : constant String := - Expr_Name (Subtype_Mark (Expr), Expand_Type => False); + Expr_Name + (Subtype_Mark (Expr), Expand_Type => False); Str : constant String := Expr_Name (Expression (Expr)); begin if Str (Str'First) = '(' and then Str (Str'Last) = ')' then @@ -347,118 +386,145 @@ package body Pprint is when N_Raise_Constraint_Error => if Present (Condition (Expr)) then - return "[constraint_error when " & - Expr_Name (Condition (Expr)) & "]"; + return + "[constraint_error when " + & Expr_Name (Condition (Expr)) & "]"; else return "[constraint_error]"; end if; when N_Raise_Program_Error => if Present (Condition (Expr)) then - return "[program_error when " & - Expr_Name (Condition (Expr)) & "]"; + return + "[program_error when " + & Expr_Name (Condition (Expr)) & "]"; else return "[program_error]"; end if; when N_Range => - return Expr_Name (Low_Bound (Expr)) & ".." & + return + Expr_Name (Low_Bound (Expr)) & ".." & Expr_Name (High_Bound (Expr)); when N_Slice => - return Expr_Name (Prefix (Expr)) & " (" & + return + Expr_Name (Prefix (Expr)) & " (" & Expr_Name (Discrete_Range (Expr)) & ")"; when N_And_Then => - return Expr_Name (Left_Opnd (Expr)) & " and then " & + return + Expr_Name (Left_Opnd (Expr)) & " and then " & Expr_Name (Right_Opnd (Expr)); when N_In => - return Expr_Name (Left_Opnd (Expr)) & " in " & + return + Expr_Name (Left_Opnd (Expr)) & " in " & Expr_Name (Right_Opnd (Expr)); when N_Not_In => - return Expr_Name (Left_Opnd (Expr)) & " not in " & + return + Expr_Name (Left_Opnd (Expr)) & " not in " & Expr_Name (Right_Opnd (Expr)); when N_Or_Else => - return Expr_Name (Left_Opnd (Expr)) & " or else " & + return + Expr_Name (Left_Opnd (Expr)) & " or else " & Expr_Name (Right_Opnd (Expr)); when N_Op_And => - return Expr_Name (Left_Opnd (Expr)) & " and " & + return + Expr_Name (Left_Opnd (Expr)) & " and " & Expr_Name (Right_Opnd (Expr)); when N_Op_Or => - return Expr_Name (Left_Opnd (Expr)) & " or " & + return + Expr_Name (Left_Opnd (Expr)) & " or " & Expr_Name (Right_Opnd (Expr)); when N_Op_Xor => - return Expr_Name (Left_Opnd (Expr)) & " xor " & + return + Expr_Name (Left_Opnd (Expr)) & " xor " & Expr_Name (Right_Opnd (Expr)); when N_Op_Eq => - return Expr_Name (Left_Opnd (Expr)) & " = " & + return + Expr_Name (Left_Opnd (Expr)) & " = " & Expr_Name (Right_Opnd (Expr)); when N_Op_Ne => - return Expr_Name (Left_Opnd (Expr)) & " /= " & + return + Expr_Name (Left_Opnd (Expr)) & " /= " & Expr_Name (Right_Opnd (Expr)); when N_Op_Lt => - return Expr_Name (Left_Opnd (Expr)) & " < " & + return + Expr_Name (Left_Opnd (Expr)) & " < " & Expr_Name (Right_Opnd (Expr)); when N_Op_Le => - return Expr_Name (Left_Opnd (Expr)) & " <= " & + return + Expr_Name (Left_Opnd (Expr)) & " <= " & Expr_Name (Right_Opnd (Expr)); when N_Op_Gt => - return Expr_Name (Left_Opnd (Expr)) & " > " & + return + Expr_Name (Left_Opnd (Expr)) & " > " & Expr_Name (Right_Opnd (Expr)); when N_Op_Ge => - return Expr_Name (Left_Opnd (Expr)) & " >= " & + return + Expr_Name (Left_Opnd (Expr)) & " >= " & Expr_Name (Right_Opnd (Expr)); when N_Op_Add => - return Expr_Name (Left_Opnd (Expr)) & " + " & + return + Expr_Name (Left_Opnd (Expr)) & " + " & Expr_Name (Right_Opnd (Expr)); when N_Op_Subtract => - return Expr_Name (Left_Opnd (Expr)) & " - " & + return + Expr_Name (Left_Opnd (Expr)) & " - " & Expr_Name (Right_Opnd (Expr)); when N_Op_Multiply => - return Expr_Name (Left_Opnd (Expr)) & " * " & + return + Expr_Name (Left_Opnd (Expr)) & " * " & Expr_Name (Right_Opnd (Expr)); when N_Op_Divide => - return Expr_Name (Left_Opnd (Expr)) & " / " & + return + Expr_Name (Left_Opnd (Expr)) & " / " & Expr_Name (Right_Opnd (Expr)); when N_Op_Mod => - return Expr_Name (Left_Opnd (Expr)) & " mod " & + return + Expr_Name (Left_Opnd (Expr)) & " mod " & Expr_Name (Right_Opnd (Expr)); when N_Op_Rem => - return Expr_Name (Left_Opnd (Expr)) & " rem " & + return + Expr_Name (Left_Opnd (Expr)) & " rem " & Expr_Name (Right_Opnd (Expr)); when N_Op_Expon => - return Expr_Name (Left_Opnd (Expr)) & " ** " & + return + Expr_Name (Left_Opnd (Expr)) & " ** " & Expr_Name (Right_Opnd (Expr)); when N_Op_Shift_Left => - return Expr_Name (Left_Opnd (Expr)) & " << " & + return + Expr_Name (Left_Opnd (Expr)) & " << " & Expr_Name (Right_Opnd (Expr)); when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic => - return Expr_Name (Left_Opnd (Expr)) & " >> " & + return + Expr_Name (Left_Opnd (Expr)) & " >> " & Expr_Name (Right_Opnd (Expr)); when N_Op_Concat => - return Expr_Name (Left_Opnd (Expr)) & " & " & + return + Expr_Name (Left_Opnd (Expr)) & " & " & Expr_Name (Right_Opnd (Expr)); when N_Op_Plus => @@ -485,8 +551,9 @@ package body Pprint is when N_Indexed_Component => if Take_Prefix then - return Expr_Name (Prefix (Expr)) & - List_Name (First (Sinfo.Expressions (Expr))); + return + Expr_Name (Prefix (Expr)) + & List_Name (First (Sinfo.Expressions (Expr))); else return List_Name (First (Sinfo.Expressions (Expr))); end if; @@ -498,12 +565,15 @@ package body Pprint is -- parentheses around function call to mark it specially. if Default = "" then - return '(' & Expr_Name (Name (Expr)) & - List_Name (First (Sinfo.Parameter_Associations (Expr))) & - ')'; + return '(' + & Expr_Name (Name (Expr)) + & List_Name (First (Sinfo.Parameter_Associations (Expr))) + & ')'; else - return Expr_Name (Name (Expr)) & - List_Name (First (Sinfo.Parameter_Associations (Expr))); + return + Expr_Name (Name (Expr)) + & List_Name + (First (Sinfo.Parameter_Associations (Expr))); end if; when N_Null => @@ -538,18 +608,24 @@ package body Pprint is loop case Nkind (Left) is - when N_Binary_Op | N_Membership_Test | - N_And_Then | N_Or_Else => + when N_And_Then | + N_Binary_Op | + N_Membership_Test | + N_Or_Else => Left := Original_Node (Left_Opnd (Left)); - when N_Attribute_Reference | N_Expanded_Name | - N_Explicit_Dereference | N_Indexed_Component | - N_Reference | N_Selected_Component | - N_Slice => + when N_Attribute_Reference | + N_Expanded_Name | + N_Explicit_Dereference | + N_Indexed_Component | + N_Reference | + N_Selected_Component | + N_Slice => Left := Original_Node (Prefix (Left)); - when N_Designator | N_Defining_Program_Unit_Name | - N_Function_Call => + when N_Defining_Program_Unit_Name | + N_Designator | + N_Function_Call => Left := Original_Node (Name (Left)); when N_Range => @@ -567,11 +643,14 @@ package body Pprint is loop case Nkind (Right) is - when N_Op | N_Membership_Test | - N_And_Then | N_Or_Else => + when N_And_Then | + N_Membership_Test | + N_Op | + N_Or_Else => Right := Original_Node (Right_Opnd (Right)); - when N_Selected_Component | N_Expanded_Name => + when N_Expanded_Name | + N_Selected_Component => Right := Original_Node (Selector_Name (Right)); when N_Designator => @@ -635,10 +714,10 @@ package body Pprint is declare Scn : Source_Ptr := Original_Location (Sloc (Left)); - Src : constant Source_Buffer_Ptr := - Source_Text (Get_Source_File_Index (Scn)); End_Sloc : constant Source_Ptr := - Original_Location (Sloc (Right)); + Original_Location (Sloc (Right)); + Src : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (Scn)); begin if Scn > End_Sloc then @@ -647,9 +726,9 @@ package body Pprint is declare Buffer : String (1 .. Natural (End_Sloc - Scn)); + Index : Natural := 0; Skipping_Comment : Boolean := False; Underscore : Boolean := False; - Index : Natural := 0; begin if Right /= Expr then diff --git a/gcc/ada/pprint.ads b/gcc/ada/pprint.ads index 8fc1036b1e4..23160a04801 100644 --- a/gcc/ada/pprint.ads +++ b/gcc/ada/pprint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,15 +41,18 @@ package Pprint is with function String_Image (S : String_Id) return String; with function Ident_Image (Expr : Node_Id; Orig_Expr : Node_Id; - Expand_Type : Boolean) - return String; + Expand_Type : Boolean) return String; -- Will be called for printing N_Identifier and N_Defining_Identifier -- nodes -- ??? Expand_Type argument should be removed - function Expression_Image (Expr : Node_Id; - Default : String) - return String; + Hide_Parameter_Blocks : Boolean := False; + -- If true, then "Parameter_Block.Field_Name.all" is + -- instead displayed as "Field_Name". + + function Expression_Image + (Expr : Node_Id; + Default : String) return String; -- Given a Node for an expression, return a String that is meaningful for -- the programmer. If the expression comes from source, it is copied from -- there. diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb index c38234b052e..bb215c3b2c2 100644 --- a/gcc/ada/prep.adb +++ b/gcc/ada/prep.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 201d6b8636c..791fe2113f9 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -379,6 +379,24 @@ package body Prj.Attr is "Pstack#" & "LVswitches#" & + -- package Codepeer + + "Pcodepeer#" & + "SVoutput_directory#" & + "SVdatabase_directory#" & + "SVmessage_patterns#" & + "SVadditional_patterns#" & + "LVswitches#" & + "LVexcluded_source_files#" & + + -- package Prove + + "Pprove#" & + + -- package GnatTest + + "Pgnattest#" & + "#"; Initialized : Boolean := False; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 461bd87f56b..204e577c820 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -735,7 +735,7 @@ package body Prj.Dect is and then Variable_Kind_Of (Current_Attribute) /= Expression_Kind_Of (Expression, In_Tree) then - if Variable_Kind_Of (Current_Attribute) = Undefined then + if Variable_Kind_Of (Current_Attribute) = Undefined then Set_Variable_Kind_Of (Current_Attribute, To => Expression_Kind_Of (Expression, In_Tree)); diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb index 9ccd935f6af..2b05eaadefb 100644 --- a/gcc/ada/prj-pp.adb +++ b/gcc/ada/prj-pp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -522,7 +522,13 @@ package body Prj.PP is if Project_Of_Renamed_Package_Of (Node, In_Tree) /= Empty_Node then - Write_String (" renames ", Indent); + if First_Declarative_Item_Of (Node, In_Tree) = Empty_Node + then + Write_String (" renames ", Indent); + else + Write_String (" extends ", Indent); + end if; + Output_Name (Name_Of (Project_Of_Renamed_Package_Of (Node, In_Tree), @@ -530,6 +536,13 @@ package body Prj.PP is Indent); Write_String (".", Indent); Output_Name (Name_Of (Node, In_Tree), Indent); + end if; + + if Project_Of_Renamed_Package_Of (Node, In_Tree) /= + Empty_Node + and then + First_Declarative_Item_Of (Node, In_Tree) = Empty_Node + then Write_String (";", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After_End (Node, In_Tree), Indent); diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 0deb39beb29..ac5b445cdaf 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -143,7 +143,7 @@ package body Prj is while Last + S'Length > To'Last loop declare - New_Buffer : constant String_Access := + New_Buffer : constant String_Access := new String (1 .. 2 * To'Length); begin New_Buffer (1 .. Last) := To (1 .. Last); @@ -592,9 +592,14 @@ package body Prj is In_Aggregate_Lib : Boolean; From_Encapsulated_Lib : Boolean) is + package Name_Id_Set is + new Ada.Containers.Ordered_Sets (Element_Type => Path_Name_Type); + Seen_Name : Name_Id_Set.Set; -- This set is needed to ensure that we do not handle the same -- project twice in the context of aggregate libraries. + -- Since duplicate project names are possible in the context of + -- aggregated projects, we need to check the full paths. procedure Recursive_Check (Project : Project_Id; @@ -673,12 +678,12 @@ package body Prj is -- Start of processing for Recursive_Check begin - if not Seen_Name.Contains (Project.Name) then + if not Seen_Name.Contains (Project.Path.Name) then -- Even if a project is aggregated multiple times in an -- aggregated library, we will only return it once. - Seen_Name.Include (Project.Name); + Seen_Name.Include (Project.Path.Name); if not Imported_First then Action diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi deleted file mode 100644 index 2ca6babc55f..00000000000 --- a/gcc/ada/projects.texi +++ /dev/null @@ -1,5101 +0,0 @@ -@set gprconfig GPRconfig - -@c ------ projects.texi -@c Copyright (C) 2002-2014, Free Software Foundation, Inc. -@c This file is shared between the GNAT user's guide and gprbuild. It is not -@c compilable on its own, you should instead compile the other two manuals. -@c For that reason, there is no toplevel @menu - -@c --------------------------------------------- -@node GNAT Project Manager -@chapter GNAT Project Manager -@c --------------------------------------------- - -@noindent -@menu -* Introduction:: -* Building With Projects:: -* Organizing Projects into Subsystems:: -* Scenarios in Projects:: -* Library Projects:: -* Project Extension:: -* Aggregate Projects:: -* Aggregate Library Projects:: -* Project File Reference:: -@end menu - -@c --------------------------------------------- -@node Introduction -@section Introduction -@c --------------------------------------------- - -@noindent -This chapter describes GNAT's @emph{Project Manager}, a facility that allows -you to manage complex builds involving a number of source files, directories, -and options for different system configurations. In particular, -project files allow you to specify: - -@itemize @bullet -@item The directory or set of directories containing the source files, and/or the - names of the specific source files themselves -@item The directory in which the compiler's output - (@file{ALI} files, object files, tree files, etc.) is to be placed -@item The directory in which the executable programs are to be placed -@item Switch settings for any of the project-enabled tools; - you can apply these settings either globally or to individual compilation units. -@item The source files containing the main subprogram(s) to be built -@item The source programming language(s) -@item Source file naming conventions; you can specify these either globally or for - individual compilation units (@pxref{Naming Schemes}). -@item Change any of the above settings depending on external values, thus enabling - the reuse of the projects in various @b{scenarios} (@pxref{Scenarios in Projects}). -@item Automatically build libraries as part of the build process - (@pxref{Library Projects}). - -@end itemize - -@noindent -Project files are written in a syntax close to that of Ada, using familiar -notions such as packages, context clauses, declarations, default values, -assignments, and inheritance (@pxref{Project File Reference}). - -Project files can be built hierarchically from other project files, simplifying -complex system integration and project reuse (@pxref{Organizing Projects into -Subsystems}). - -@itemize @bullet -@item One project can import other projects containing needed source files. - More generally, the Project Manager lets you structure large development - efforts into hierarchical subsystems, where build decisions are delegated - to the subsystem level, and thus different compilation environments - (switch settings) used for different subsystems. -@item You can organize GNAT projects in a hierarchy: a child project - can extend a parent project, inheriting the parent's source files and - optionally overriding any of them with alternative versions - (@pxref{Project Extension}). - -@end itemize - -@noindent -Several tools support project files, generally in addition to specifying -the information on the command line itself). They share common switches -to control the loading of the project (in particular -@option{-P@emph{projectfile}} and -@option{-X@emph{vbl}=@emph{value}}). - -The Project Manager supports a wide range of development strategies, -for systems of all sizes. Here are some typical practices that are -easily handled: - -@itemize @bullet -@item Using a common set of source files and generating object files in different - directories via different switch settings. It can be used for instance, for - generating separate sets of object files for debugging and for production. -@item Using a mostly-shared set of source files with different versions of - some units or subunits. It can be used for instance, for grouping and hiding - all OS dependencies in a small number of implementation units. -@end itemize - -@noindent -Project files can be used to achieve some of the effects of a source -versioning system (for example, defining separate projects for -the different sets of sources that comprise different releases) but the -Project Manager is independent of any source configuration management tool -that might be used by the developers. - -The various sections below introduce the different concepts related to -projects. Each section starts with examples and use cases, and then goes into -the details of related project file capabilities. - -@c --------------------------------------------- -@node Building With Projects -@section Building With Projects -@c --------------------------------------------- - -@noindent -In its simplest form, a unique project is used to build a single executable. -This section concentrates on such a simple setup. Later sections will extend -this basic model to more complex setups. - -The following concepts are the foundation of project files, and will be further -detailed later in this documentation. They are summarized here as a reference. - -@table @asis -@item @b{Project file}: - A text file using an Ada-like syntax, generally using the @file{.gpr} - extension. It defines build-related characteristics of an application. - The characteristics include the list of sources, the location of those - sources, the location for the generated object files, the name of - the main program, and the options for the various tools involved in the - build process. - -@item @b{Project attribute}: - A specific project characteristic is defined by an attribute clause. Its - value is a string or a sequence of strings. All settings in a project - are defined through a list of predefined attributes with precise - semantics. @xref{Attributes}. - -@item @b{Package in a project}: - Global attributes are defined at the top level of a project. - Attributes affecting specific tools are grouped in a - package whose name is related to tool's function. The most common - packages are @code{Builder}, @code{Compiler}, @code{Binder}, - and @code{Linker}. @xref{Packages}. - -@item @b{Project variables}: - In addition to attributes, a project can use variables to store intermediate - values and avoid duplication in complex expressions. It can be initialized - with a value coming from the environment. - A frequent use of variables is to define scenarios. - @xref{External Values}, @xref{Scenarios in Projects}, and @xref{Variables}. - -@item @b{Source files} and @b{source directories}: - A source file is associated with a language through a naming convention. For - instance, @code{foo.c} is typically the name of a C source file; - @code{bar.ads} or @code{bar.1.ada} are two common naming conventions for a - file containing an Ada spec. A compilation unit is often composed of a main - source file and potentially several auxiliary ones, such as header files in C. - The naming conventions can be user defined @xref{Naming Schemes}, and will - drive the builder to call the appropriate compiler for the given source file. - Source files are searched for in the source directories associated with the - project through the @b{Source_Dirs} attribute. By default, all the files (in - these source directories) following the naming conventions associated with the - declared languages are considered to be part of the project. It is also - possible to limit the list of source files using the @b{Source_Files} or - @b{Source_List_File} attributes. Note that those last two attributes only - accept basenames with no directory information. - -@item @b{Object files} and @b{object directory}: - An object file is an intermediate file produced by the compiler from a - compilation unit. It is used by post-compilation tools to produce - final executables or libraries. Object files produced in the context of - a given project are stored in a single directory that can be specified by the - @b{Object_Dir} attribute. In order to store objects in - two or more object directories, the system must be split into - distinct subsystems with their own project file. - -@end table - -The following subsections introduce gradually all the attributes of interest -for simple build needs. Here is the simple setup that will be used in the -following examples. - -The Ada source files @file{pack.ads}, @file{pack.adb}, and @file{proc.adb} are in -the @file{common/} directory. The file @file{proc.adb} contains an Ada main -subprogram @code{Proc} that @code{with}s package @code{Pack}. We want to compile -these source files with the switch -@option{-O2}, and put the resulting files in -the directory @file{obj/}. - -@smallexample -@group -common/ - pack.ads - pack.adb - proc.adb -@end group -@group -common/obj/ - proc.ali, proc.o pack.ali, pack.o -@end group -@end smallexample - -@noindent -Our project is to be called @emph{Build}. The name of the -file is the name of the project (case-insensitive) with the -@file{.gpr} extension, therefore the project file name is @file{build.gpr}. This -is not mandatory, but a warning is issued when this convention is not followed. - -This is a very simple example, and as stated above, a single project -file is enough for it. We will thus create a new file, that for now -should contain the following code: - -@smallexample -@b{project} Build @b{is} -@b{end} Build; -@end smallexample - -@menu -* Source Files and Directories:: -* Duplicate Sources in Projects:: -* Object and Exec Directory:: -* Main Subprograms:: -* Tools Options in Project Files:: -* Compiling with Project Files:: -* Executable File Names:: -* Avoid Duplication With Variables:: -* Naming Schemes:: -* Installation:: -* Distributed support:: -@end menu - -@c --------------------------------------------- -@node Source Files and Directories -@subsection Source Files and Directories -@c --------------------------------------------- - -@noindent -When you create a new project, the first thing to describe is how to find the -corresponding source files. These are the only settings that are needed by all -the tools that will use this project (builder, compiler, binder and linker for -the compilation, IDEs to edit the source files,@dots{}). - -@cindex Source directories -The first step is to declare the source directories, which are the directories -to be searched to find source files. In the case of the example, -the @file{common} directory is the only source directory. - -@cindex @code{Source_Dirs} -There are several ways of defining source directories: - -@itemize @bullet -@item When the attribute @b{Source_Dirs} is not used, a project contains a - single source directory which is the one where the project file itself - resides. In our example, if @file{build.gpr} is placed in the @file{common} - directory, the project has the needed implicit source directory. - -@item The attribute @b{Source_Dirs} can be set to a list of path names, one - for each of the source directories. Such paths can either be absolute - names (for instance @file{"/usr/local/common/"} on UNIX), or relative to the - directory in which the project file resides (for instance "." if - @file{build.gpr} is inside @file{common/}, or "common" if it is one level up). - Each of the source directories must exist and be readable. - -@cindex portability - The syntax for directories is platform specific. For portability, however, - the project manager will always properly translate UNIX-like path names to - the native format of the specific platform. For instance, when the same - project file is to be used both on Unix and Windows, "/" should be used as - the directory separator rather than "\". - -@item The attribute @b{Source_Dirs} can automatically include subdirectories - using a special syntax inspired by some UNIX shells. If any of the paths in - the list ends with "@file{**}", then that path and all its subdirectories - (recursively) are included in the list of source directories. For instance, - @file{**} and @file{./**} represent the complete directory tree rooted at - the directory in which the project file resides. -@cindex Source directories, recursive - -@cindex @code{Excluded_Source_Dirs} - When using that construct, it can sometimes be convenient to also use the - attribute @b{Excluded_Source_Dirs}, which is also a list of paths. Each entry - specifies a directory whose immediate content, not including subdirs, is to - be excluded. It is also possible to exclude a complete directory subtree - using the "**" notation. - -@cindex @code{Ignore_Source_Sub_Dirs} - It is often desirable to remove, from the source directories, directory - subtrees rooted at some subdirectories. An example is the subdirectories - created by a Version Control System such as Subversion that creates directory - subtrees rooted at subdirectories ".svn". To do that, attribute - @b{Ignore_Source_Sub_Dirs} can be used. It specifies the list of simple - file names for the roots of these undesirable directory subtrees. - -@smallexample - @b{for} Source_Dirs @b{use} ("./**"); - @b{for} Ignore_Source_Sub_Dirs @b{use} (".svn"); -@end smallexample - -@end itemize - -@noindent -When applied to the simple example, and because we generally prefer to have -the project file at the toplevel directory rather than mixed with the sources, -we will create the following file - -@smallexample - build.gpr - @b{project} Build @b{is} - @b{for} Source_Dirs @b{use} ("common"); -- <<<< - @b{end} Build; -@end smallexample - -@noindent -Once source directories have been specified, one may need to indicate -source files of interest. By default, all source files present in the source -directories are considered by the project manager. When this is not desired, -it is possible to specify the list of sources to consider explicitly. -In such a case, only source file base names are indicated and not -their absolute or relative path names. The project manager is in charge of -locating the specified source files in the specified source directories. - -@itemize @bullet -@item By default, the project manager searches for all source files of all - specified languages in all the source directories. - - Since the project manager was initially developed for Ada environments, the - default language is usually Ada and the above project file is complete: it - defines without ambiguity the sources composing the project: that is to say, - all the sources in subdirectory "common" for the default language (Ada) using - the default naming convention. - -@cindex @code{Languages} - However, when compiling a multi-language application, or a pure C - application, the project manager must be told which languages are of - interest, which is done by setting the @b{Languages} attribute to a list of - strings, each of which is the name of a language. Tools like - @command{gnatmake} only know about Ada, while other tools like - @command{gprbuild} know about many more languages such as C, C++, Fortran, - assembly and others can be added dynamically. - -@cindex Naming scheme - Even when using only Ada, the default naming might not be suitable. Indeed, - how does the project manager recognizes an "Ada file" from any other - file? Project files can describe the naming scheme used for source files, - and override the default (@pxref{Naming Schemes}). The default is the - standard GNAT extension (@file{.adb} for bodies and @file{.ads} for - specs), which is what is used in our example, explaining why no naming scheme - is explicitly specified. - @xref{Naming Schemes}. - -@item @code{Source_Files} -@cindex @code{Source_Files} - In some cases, source directories might contain files that should not be - included in a project. One can specify the explicit list of file names to - be considered through the @b{Source_Files} attribute. - When this attribute is defined, instead of looking at every file in the - source directories, the project manager takes only those names into - consideration reports errors if they cannot be found in the source - directories or does not correspond to the naming scheme. - -@item For various reasons, it is sometimes useful to have a project with no - sources (most of the time because the attributes defined in the project - file will be reused in other projects, as explained in - @pxref{Organizing Projects into Subsystems}. To do this, the attribute - @emph{Source_Files} is set to the empty list, i.e. @code{()}. Alternatively, - @emph{Source_Dirs} can be set to the empty list, with the same - result. - -@item @code{Source_List_File} -@cindex @code{Source_List_File} - If there is a great number of files, it might be more convenient to use - the attribute @b{Source_List_File}, which specifies the full path of a file. - This file must contain a list of source file names (one per line, no - directory information) that are searched as if they had been defined - through @emph{Source_Files}. Such a file can easily be created through - external tools. - - A warning is issued if both attributes @code{Source_Files} and - @code{Source_List_File} are given explicit values. In this case, the - attribute @code{Source_Files} prevails. - -@item @code{Excluded_Source_Files} -@cindex @code{Excluded_Source_Files} -@cindex @code{Locally_Removed_Files} -@cindex @code{Excluded_Source_List_File} - Specifying an explicit list of files is not always convenient.It might be - more convenient to use the default search rules with specific exceptions. - This can be done thanks to the attribute @b{Excluded_Source_Files} - (or its synonym @b{Locally_Removed_Files}). - Its value is the list of file names that should not be taken into account. - This attribute is often used when extending a project, - @xref{Project Extension}. A similar attribute - @b{Excluded_Source_List_File} plays the same - role but takes the name of file containing file names similarly to - @code{Source_List_File}. - -@end itemize - -@noindent -In most simple cases, such as the above example, the default source file search -behavior provides the expected result, and we do not need to add anything after -setting @code{Source_Dirs}. The project manager automatically finds -@file{pack.ads}, @file{pack.adb} and @file{proc.adb} as source files of the -project. - -Note that by default a warning is issued when a project has no sources attached -to it and this is not explicitly indicated in the project file. - -@c --------------------------------------------- -@node Duplicate Sources in Projects -@subsection Duplicate Sources in Projects -@c --------------------------------------------- - -@noindent -If the order of the source directories is known statically, that is if -@code{"/**"} is not used in the string list @code{Source_Dirs}, then there may -be several files with the same name sitting in different directories of the -project. In this case, only the file in the first directory is considered as a -source of the project and the others are hidden. If @code{"/**"} is used in the -string list @code{Source_Dirs}, it is an error to have several files with the -same name in the same directory @code{"/**"} subtree, since there would be an -ambiguity as to which one should be used. However, two files with the same name -may exist in two single directories or directory subtrees. In this case, the -one in the first directory or directory subtree is a source of the project. - -If there are two sources in different directories of the same @code{"/**"} -subtree, one way to resolve the problem is to exclude the directory of the -file that should not be used as a source of the project. - -@c --------------------------------------------- -@node Object and Exec Directory -@subsection Object and Exec Directory -@c --------------------------------------------- - -@noindent -The next step when writing a project is to indicate where the compiler should -put the object files. In fact, the compiler and other tools might create -several different kind of files (for GNAT, there is the object file and the ALI -file for instance). One of the important concepts in projects is that most -tools may consider source directories as read-only and do not attempt to create -new or temporary files there. Instead, all files are created in the object -directory. It is of course not true for project-aware IDEs, whose purpose it is -to create the source files. - -@cindex @code{Object_Dir} -The object directory is specified through the @b{Object_Dir} attribute. -Its value is the path to the object directory, either absolute or -relative to the directory containing the project file. This -directory must already exist and be readable and writable, although -some tools have a switch to create the directory if needed (See -the switch @code{-p} for @command{gnatmake} -and @command{gprbuild}). - -If the attribute @code{Object_Dir} is not specified, it defaults to -the project directory, that is the directory containing the project file. - -For our example, we can specify the object dir in this way: - -@smallexample - @b{project} Build @b{is} - @b{for} Source_Dirs @b{use} ("common"); - @b{for} Object_Dir @b{use} "obj"; -- <<<< - @b{end} Build; -@end smallexample - -@noindent -As mentioned earlier, there is a single object directory per project. As a -result, if you have an existing system where the object files are spread across -several directories, you can either move all of them into the same directory if -you want to build it with a single project file, or study the section on -subsystems (@pxref{Organizing Projects into Subsystems}) to see how each -separate object directory can be associated with one of the subsystems -constituting the application. - -When the @command{linker} is called, it usually creates an executable. By -default, this executable is placed in the object directory of the project. It -might be convenient to store it in its own directory. - -@cindex @code{Exec_Dir} -This can be done through the @code{Exec_Dir} attribute, which, like -@emph{Object_Dir} contains a single absolute or relative path and must point to -an existing and writable directory, unless you ask the tool to create it on -your behalf. When not specified, It defaults to the object directory and -therefore to the project file's directory if neither @emph{Object_Dir} nor -@emph{Exec_Dir} was specified. - -In the case of the example, let's place the executable in the root -of the hierarchy, ie the same directory as @file{build.gpr}. Hence -the project file is now - -@smallexample - @b{project} Build @b{is} - @b{for} Source_Dirs @b{use} ("common"); - @b{for} Object_Dir @b{use} "obj"; - @b{for} Exec_Dir @b{use} "."; -- <<<< - @b{end} Build; -@end smallexample - -@c --------------------------------------------- -@node Main Subprograms -@subsection Main Subprograms -@c --------------------------------------------- - -@noindent -In the previous section, executables were mentioned. The project manager needs -to be taught what they are. In a project file, an executable is indicated by -pointing to the source file of a main subprogram. In C this is the file that -contains the @code{main} function, and in Ada the file that contains the main -unit. - -There can be any number of such main files within a given project, and thus -several executables can be built in the context of a single project file. Of -course, one given executable might not (and in fact will not) need all the -source files referenced by the project. As opposed to other build environments -such as @command{makefile}, one does not need to specify the list of -dependencies of each executable, the project-aware builder knows enough of the -semantics of the languages to build and link only the necessary elements. - -@cindex @code{Main} -The list of main files is specified via the @b{Main} attribute. It contains -a list of file names (no directories). If a project defines this -attribute, it is not necessary to identify main files on the -command line when invoking a builder, and editors like -@command{GPS} will be able to create extra menus to spawn or debug the -corresponding executables. - -@smallexample - @b{project} Build @b{is} - @b{for} Source_Dirs @b{use} ("common"); - @b{for} Object_Dir @b{use} "obj"; - @b{for} Exec_Dir @b{use} "."; - @b{for} Main @b{use} ("proc.adb"); -- <<<< - @b{end} Build; -@end smallexample - -@noindent -If this attribute is defined in the project, then spawning the builder -with a command such as - -@smallexample - gprbuild -Pbuild -@end smallexample - -@noindent -automatically builds all the executables corresponding to the files -listed in the @emph{Main} attribute. It is possible to specify one -or more executables on the command line to build a subset of them. - -@c --------------------------------------------- -@node Tools Options in Project Files -@subsection Tools Options in Project Files -@c --------------------------------------------- - -@noindent -We now have a project file that fully describes our environment, and can be -used to build the application with a simple @command{gprbuild} command as seen -in the previous section. In fact, the empty project we showed immediately at -the beginning (with no attribute at all) could already fulfill that need if it -was put in the @file{common} directory. - -Of course, we might want more control. This section shows you how to specify -the compilation switches that the various tools involved in the building of the -executable should use. - -@cindex command line length -Since source names and locations are described in the project file, it is not -necessary to use switches on the command line for this purpose (switches such -as -I for gcc). This removes a major source of command line length overflow. -Clearly, the builders will have to communicate this information one way or -another to the underlying compilers and tools they call but they usually use -response files for this and thus are not subject to command line overflows. - -Several tools participate to the creation of an executable: the compiler -produces object files from the source files; the binder (in the Ada case) -creates a "source" file that takes care, among other things, of elaboration -issues and global variable initialization; and the linker gathers everything -into a single executable that users can execute. All these tools are known to -the project manager and will be called with user defined switches from the -project files. However, we need to introduce a new project file concept to -express the switches to be used for any of the tools involved in the build. - -@cindex project file packages -A project file is subdivided into zero or more @b{packages}, each of which -contains the attributes specific to one tool (or one set of tools). Project -files use an Ada-like syntax for packages. Package names permitted in project -files are restricted to a predefined set (@pxref{Packages}), and the contents -of packages are limited to a small set of constructs and attributes -(@pxref{Attributes}). - -Our example project file can be extended with the following empty packages. At -this stage, they could all be omitted since they are empty, but they show which -packages would be involved in the build process. - -@smallexample - @b{project} Build @b{is} - @b{for} Source_Dirs @b{use} ("common"); - @b{for} Object_Dir @b{use} "obj"; - @b{for} Exec_Dir @b{use} "."; - @b{for} Main @b{use} ("proc.adb"); - - @b{package} Builder @b{is} --<<< for gnatmake and gprbuild - @b{end} Builder; - - @b{package} Compiler @b{is} --<<< for the compiler - @b{end} Compiler; - - @b{package} Binder @b{is} --<<< for the binder - @b{end} Binder; - - @b{package} Linker @b{is} --<<< for the linker - @b{end} Linker; - @b{end} Build; -@end smallexample - -@noindent -Let's first examine the compiler switches. As stated in the initial description -of the example, we want to compile all files with @option{-O2}. This is a -compiler switch, although it is usual, on the command line, to pass it to the -builder which then passes it to the compiler. It is recommended to use directly -the right package, which will make the setup easier to understand for other -people. - -Several attributes can be used to specify the switches: - -@table @asis -@item @b{Default_Switches}: -@cindex @code{Default_Switches} - This is the first mention in this manual of an @b{indexed attribute}. When - this attribute is defined, one must supply an @emph{index} in the form of a - literal string. - In the case of @emph{Default_Switches}, the index is the name of the - language to which the switches apply (since a different compiler will - likely be used for each language, and each compiler has its own set of - switches). The value of the attribute is a list of switches. - - In this example, we want to compile all Ada source files with the switch - @option{-O2}, and the resulting project file is as follows - (only the @code{Compiler} package is shown): - - @smallexample - @b{package} Compiler @b{is} - @b{for} Default_Switches ("Ada") @b{use} ("-O2"); - @b{end} Compiler; - @end smallexample - -@item @b{Switches}: -@cindex @code{Switches} - in some cases, we might want to use specific switches - for one or more files. For instance, compiling @file{proc.adb} might not be - possible at high level of optimization because of a compiler issue. - In such a case, the @emph{Switches} - attribute (indexed on the file name) can be used and will override the - switches defined by @emph{Default_Switches}. Our project file would - become: - - @smallexample - package Compiler is - for Default_Switches ("Ada") - use ("-O2"); - for Switches ("proc.adb") - use ("-O0"); - end Compiler; - @end smallexample - - @noindent - @code{Switches} may take a pattern as an index, such as in: - - @smallexample - package Compiler is - for Default_Switches ("Ada") - use ("-O2"); - for Switches ("pkg*") - use ("-O0"); - end Compiler; - @end smallexample - - @noindent - Sources @file{pkg.adb} and @file{pkg-child.adb} would be compiled with -O0, - not -O2. - - @noindent - @code{Switches} can also be given a language name as index instead of a file - name in which case it has the same semantics as @emph{Default_Switches}. - However, indexes with wild cards are never valid for language name. - -@item @b{Local_Configuration_Pragmas}: -@cindex @code{Local_Configuration_Pragmas} - this attribute may specify the path - of a file containing configuration pragmas for use by the Ada compiler, - such as @code{pragma Restrictions (No_Tasking)}. These pragmas will be - used for all the sources of the project. - -@end table - -The switches for the other tools are defined in a similar manner through the -@b{Default_Switches} and @b{Switches} attributes, respectively in the -@emph{Builder} package (for @command{gnatmake} and @command{gprbuild}), -the @emph{Binder} package (binding Ada executables) and the @emph{Linker} -package (for linking executables). - -@c --------------------------------------------- -@node Compiling with Project Files -@subsection Compiling with Project Files -@c --------------------------------------------- - -@noindent -Now that our project files are written, let's build our executable. -Here is the command we would use from the command line: - -@smallexample - gnatmake -Pbuild -@end smallexample - -@noindent -This will automatically build the executables specified through the -@emph{Main} attribute: for each, it will compile or recompile the -sources for which the object file does not exist or is not up-to-date; it -will then run the binder; and finally run the linker to create the -executable itself. - -@command{gnatmake} only knows how to handle Ada files. By using -@command{gprbuild} as a builder, you could automatically manage C files the -same way: create the file @file{utils.c} in the @file{common} directory, -set the attribute @emph{Languages} to @code{"(Ada, C)"}, and run - -@smallexample - gprbuild -Pbuild -@end smallexample - -@noindent -Gprbuild knows how to recompile the C files and will -recompile them only if one of their dependencies has changed. No direct -indication on how to build the various elements is given in the -project file, which describes the project properties rather than a -set of actions to be executed. Here is the invocation of -@command{gprbuild} when building a multi-language program: - -@smallexample -$ gprbuild -Pbuild -gcc -c proc.adb -gcc -c pack.adb -gcc -c utils.c -gprbind proc -... -gcc proc.o -o proc -@end smallexample - -@noindent -Notice the three steps described earlier: - -@itemize @bullet -@item The first three gcc commands correspond to the compilation phase. -@item The gprbind command corresponds to the post-compilation phase. -@item The last gcc command corresponds to the final link. - -@end itemize - -@noindent -@cindex @option{-v} option (for GPRbuild) -The default output of GPRbuild's execution is kept reasonably simple and easy -to understand. In particular, some of the less frequently used commands are not -shown, and some parameters are abbreviated. So it is not possible to rerun the -effect of the @command{gprbuild} command by cut-and-pasting its output. -GPRbuild's option @code{-v} provides a much more verbose output which includes, -among other information, more complete compilation, post-compilation and link -commands. - -@c --------------------------------------------- -@node Executable File Names -@subsection Executable File Names -@c --------------------------------------------- - -@noindent -@cindex @code{Executable} -By default, the executable name corresponding to a main file is -computed from the main source file name. Through the attribute -@b{Builder.Executable}, it is possible to change this default. - -For instance, instead of building @command{proc} (or @command{proc.exe} -on Windows), we could configure our project file to build "proc1" -(resp proc1.exe) with the following addition: - -@smallexample @c projectfile - @b{project} Build @b{is} - ... --@i{ same as before} - @b{package} Builder @b{is} - @b{for} Executable ("proc.adb") @b{use} "proc1"; - @b{end} Builder - @b{end} Build; -@end smallexample - -@noindent -@cindex @code{Executable_Suffix} -Attribute @b{Executable_Suffix}, when specified, may change the suffix -of the executable files, when no attribute @code{Executable} applies: -its value replaces the platform-specific executable suffix. -The default executable suffix is empty on UNIX and ".exe" on Windows. - -It is also possible to change the name of the produced executable by using the -command line switch @option{-o}. When several mains are defined in the project, -it is not possible to use the @option{-o} switch and the only way to change the -names of the executable is provided by Attributes @code{Executable} and -@code{Executable_Suffix}. - -@c --------------------------------------------- -@node Avoid Duplication With Variables -@subsection Avoid Duplication With Variables -@c --------------------------------------------- - -@noindent -To illustrate some other project capabilities, here is a slightly more complex -project using similar sources and a main program in C: - -@smallexample @c projectfile -@b{project} C_Main @b{is} - @b{for} Languages @b{use} ("Ada", "C"); - @b{for} Source_Dirs @b{use} ("common"); - @b{for} Object_Dir @b{use} "obj"; - @b{for} Main @b{use} ("main.c"); - @b{package} Compiler @b{is} - C_Switches := ("-pedantic"); - @b{for} Default_Switches ("C") @b{use} C_Switches; - @b{for} Default_Switches ("Ada") @b{use} ("-gnaty"); - @b{for} Switches ("main.c") @b{use} C_Switches & ("-g"); - @b{end} Compiler; -@b{end} C_Main; -@end smallexample - -@noindent -This project has many similarities with the previous one. -As expected, its @code{Main} attribute now refers to a C source. -The attribute @emph{Exec_Dir} is now omitted, thus the resulting -executable will be put in the directory @file{obj}. - -The most noticeable difference is the use of a variable in the -@emph{Compiler} package to store settings used in several attributes. -This avoids text duplication, and eases maintenance (a single place to -modify if we want to add new switches for C files). We will revisit -the use of variables in the context of scenarios (@pxref{Scenarios in -Projects}). - -In this example, we see how the file @file{main.c} can be compiled with -the switches used for all the other C files, plus @option{-g}. -In this specific situation the use of a variable could have been -replaced by a reference to the @code{Default_Switches} attribute: - -@smallexample @c projectfile - @b{for} Switches ("c_main.c") @b{use} Compiler'Default_Switches ("C") & ("-g"); -@end smallexample - -@noindent -Note the tick (@emph{'}) used to refer to attributes defined in a package. - -Here is the output of the GPRbuild command using this project: - -@smallexample -$gprbuild -Pc_main -gcc -c -pedantic -g main.c -gcc -c -gnaty proc.adb -gcc -c -gnaty pack.adb -gcc -c -pedantic utils.c -gprbind main.bexch -... -gcc main.o -o main -@end smallexample - -@noindent -The default switches for Ada sources, -the default switches for C sources (in the compilation of @file{lib.c}), -and the specific switches for @file{main.c} have all been taken into -account. - -@c --------------------------------------------- -@node Naming Schemes -@subsection Naming Schemes -@c --------------------------------------------- - -@noindent -Sometimes an Ada software system is ported from one compilation environment to -another (say GNAT), and the file are not named using the default GNAT -conventions. Instead of changing all the file names, which for a variety of -reasons might not be possible, you can define the relevant file naming scheme -in the @b{Naming} package of your project file. - -The naming scheme has two distinct goals for the project manager: it -allows finding of source files when searching in the source -directories, and given a source file name it makes it possible to guess -the associated language, and thus the compiler to use. - -Note that the use by the Ada compiler of pragmas Source_File_Name is not -supported when using project files. You must use the features described in this -paragraph. You can however specify other configuration pragmas. - -The following attributes can be defined in package @code{Naming}: - -@table @asis -@item @b{Casing}: -@cindex @code{Casing} - Its value must be one of @code{"lowercase"} (the default if - unspecified), @code{"uppercase"} or @code{"mixedcase"}. It describes the - casing of file names with regards to the Ada unit name. Given an Ada unit - My_Unit, the file name will respectively be @file{my_unit.adb} (lowercase), - @file{MY_UNIT.ADB} (uppercase) or @file{My_Unit.adb} (mixedcase). - On Windows, file names are case insensitive, so this attribute is - irrelevant. - -@item @b{Dot_Replacement}: -@cindex @code{Dot_Replacement} - This attribute specifies the string that should replace the "." in unit - names. Its default value is @code{"-"} so that a unit - @code{Parent.Child} is expected to be found in the file - @file{parent-child.adb}. The replacement string must satisfy the following - requirements to avoid ambiguities in the naming scheme: - - @itemize - - @item It must not be empty - @item It cannot start or end with an alphanumeric character - @item It cannot be a single underscore - @item It cannot start with an underscore followed by an alphanumeric - @item It cannot contain a dot @code{'.'} except if the entire string - is @code{"."} - - @end itemize - -@item @b{Spec_Suffix} and @b{Specification_Suffix}: -@cindex @code{Spec_Suffix} -@cindex @code{Specification_Suffix} - For Ada, these attributes give the suffix used in file names that contain - specifications. For other languages, they give the extension for files - that contain declaration (header files in C for instance). The attribute - is indexed on the language. - The two attributes are equivalent, but the latter is obsolescent. - - If the value of the attribute is the empty string, it indicates to the - Project Manager that the only specifications/header files for the language - are those specified with attributes @code{Spec} or - @code{Specification_Exceptions}. - - If @code{Spec_Suffix ("Ada")} is not specified, then the default is - @code{".ads"}. - - A non empty value must satisfy the following requirements: - - @itemize - - @item It must include at least one dot - @item If @code{Dot_Replacement} is a single dot, then it cannot include - more than one dot. - @end itemize - -@item @b{Body_Suffix} and @b{Implementation_Suffix}: -@cindex @code{Body_Suffix} -@cindex @code{Implementation_Suffix} - These attributes give the extension used for file names that contain - code (bodies in Ada). They are indexed on the language. The second - version is obsolescent and fully replaced by the first attribute. - - For each language of a project, one of these two attributes need to be - specified, either in the project itself or in the configuration project file. - - If the value of the attribute is the empty string, it indicates to the - Project Manager that the only source files for the language - are those specified with attributes @code{Body} or - @code{Implementation_Exceptions}. - - These attributes must satisfy the same requirements as @code{Spec_Suffix}. - In addition, they must be different from any of the values in - @code{Spec_Suffix}. - If @code{Body_Suffix ("Ada")} is not specified, then the default is - @code{".adb"}. - - If @code{Body_Suffix ("Ada")} and @code{Spec_Suffix ("Ada")} end with the - same string, then a file name that ends with the longest of these two - suffixes will be a body if the longest suffix is @code{Body_Suffix ("Ada")} - or a spec if the longest suffix is @code{Spec_Suffix ("Ada")}. - - If the suffix does not start with a '.', a file with a name exactly equal to - the suffix will also be part of the project (for instance if you define the - suffix as @code{Makefile.in}, a file called @file{Makefile.in} will be part - of the project. This capability is usually not interesting when building. - However, it might become useful when a project is also used to - find the list of source files in an editor, like the GNAT Programming System - (GPS). - -@item @b{Separate_Suffix}: -@cindex @code{Separate_Suffix} - This attribute is specific to Ada. It denotes the suffix used in file names - that contain separate bodies. If it is not specified, then it defaults to - same value as @code{Body_Suffix ("Ada")}. - - The value of this attribute cannot be the empty string. - - Otherwise, the same rules apply as for the - @code{Body_Suffix} attribute. The only accepted index is "Ada". - -@item @b{Spec} or @b{Specification}: -@cindex @code{Spec} -@cindex @code{Specification} - This attribute @code{Spec} can be used to define the source file name for a - given Ada compilation unit's spec. The index is the literal name of the Ada - unit (case insensitive). The value is the literal base name of the file that - contains this unit's spec (case sensitive or insensitive depending on the - operating system). This attribute allows the definition of exceptions to the - general naming scheme, in case some files do not follow the usual - convention. - - When a source file contains several units, the relative position of the unit - can be indicated. The first unit in the file is at position 1 - - @smallexample @c projectfile - for Spec ("MyPack.MyChild") use "mypack.mychild.spec"; - for Spec ("top") use "foo.a" at 1; - for Spec ("foo") use "foo.a" at 2; - @end smallexample - -@item @b{Body} or @b{Implementation}: -@cindex @code{Body} -@cindex @code{Implementation} - These attribute play the same role as @emph{Spec} for Ada bodies. - -@item @b{Specification_Exceptions} and @b{Implementation_Exceptions}: -@cindex @code{Specification_Exceptions} -@cindex @code{Implementation_Exceptions} - These attributes define exceptions to the naming scheme for languages - other than Ada. They are indexed on the language name, and contain - a list of file names respectively for headers and source code. - -@end table - -@set unw -For example, the following package models the Apex file naming rules: - -@smallexample @c projectfile -@group - @b{package} Naming @b{is} - @b{for} Casing @b{use} "lowercase"; - @b{for} Dot_Replacement @b{use} "."; - @b{for} Spec_Suffix ("Ada") @b{use} ".1.ada"; - @b{for} Body_Suffix ("Ada") @b{use} ".2.ada"; - @b{end} Naming; -@end group -@end smallexample - - -@c --------------------------------------------- -@node Installation -@subsection Installation -@c --------------------------------------------- - -@noindent -After building an application or a library it is often required to -install it into the development environment. For instance this step is -required if the library is to be used by another application. -The @command{gprinstall} tool provides an easy way to install -libraries, executable or object code generated during the build. The -@b{Install} package can be used to change the default locations. - -The following attributes can be defined in package @code{Install}: - -@table @asis - -@item @b{Active} - -Whether the project is to be installed, values are @code{true} -(default) or @code{false}. - -@item @b{Artifacts} -@cindex @code{Artifacts} - -An array attribute to declare a set of files not part of the sources -to be installed. The array discriminant is the directory where the -file is to be installed. If a relative directory then Prefix (see -below) is prepended. - -@item @b{Prefix}: -@cindex @code{Prefix} - -Root directory for the installation. - -@item @b{Exec_Subdir} - -Subdirectory of @b{Prefix} where executables are to be -installed. Default is @b{bin}. - -@item @b{Lib_Subdir} - -Subdirectory of @b{Prefix} where directory with the library or object -files is to be installed. Default is @b{lib}. - -@item @b{Sources_Subdir} - -Subdirectory of @b{Prefix} where directory with sources is to be -installed. Default is @b{include}. - -@item @b{Project_Subdir} - -Subdirectory of @b{Prefix} where the generated project file is to be -installed. Default is @b{share/gpr}. - -@item @b{Mode} - -The installation mode, it is either @b{dev} (default) or @b{usage}. -See @b{gprbuild} user's guide for details. - -@item @b{Install_Name} - -Specify the name to use for recording the installation. The default is -the project name without the extension. -@end table - -@c --------------------------------------------- -@node Distributed support -@subsection Distributed support -@c --------------------------------------------- - -@noindent -For large projects the compilation time can become a limitation in -the development cycle. To cope with that, GPRbuild supports -distributed compilation. - -The following attributes can be defined in package @code{Remote}: - -@table @asis - -@item @b{Root_Dir}: -@cindex @code{Root_Dir} - -Root directory of the project's sources. The default value is the -project's directory. - -@end table - -@c --------------------------------------------- -@node Organizing Projects into Subsystems -@section Organizing Projects into Subsystems -@c --------------------------------------------- - -@noindent -A @b{subsystem} is a coherent part of the complete system to be built. It is -represented by a set of sources and one single object directory. A system can -be composed of a single subsystem when it is simple as we have seen in the -first section. Complex systems are usually composed of several interdependent -subsystems. A subsystem is dependent on another subsystem if knowledge of the -other one is required to build it, and in particular if visibility on some of -the sources of this other subsystem is required. Each subsystem is usually -represented by its own project file. - -In this section, the previous example is being extended. Let's assume some -sources of our @code{Build} project depend on other sources. -For instance, when building a graphical interface, it is usual to depend upon -a graphical library toolkit such as GtkAda. Furthermore, we also need -sources from a logging module we had previously written. - -@menu -* Project Dependencies:: -* Cyclic Project Dependencies:: -* Sharing Between Projects:: -* Global Attributes:: -@end menu - -@c --------------------------------------------- -@node Project Dependencies -@subsection Project Dependencies -@c --------------------------------------------- - -@noindent -GtkAda comes with its own project file (appropriately called -@file{gtkada.gpr}), and we will assume we have already built a project -called @file{logging.gpr} for the logging module. With the information provided -so far in @file{build.gpr}, building the application would fail with an error -indicating that the gtkada and logging units that are relied upon by the sources -of this project cannot be found. - -This is solved by adding the following @b{with} clauses at the beginning of our -project: - -@smallexample @c projectfile - @b{with} "gtkada.gpr"; - @b{with} "a/b/logging.gpr"; - @b{project} Build @b{is} - ... --@i{ as before} - @b{end} Build; -@end smallexample - -@noindent -@cindex @code{Externally_Built} -When such a project is compiled, @command{gprbuild} will automatically check -the other projects and recompile their sources when needed. It will also -recompile the sources from @code{Build} when needed, and finally create the -executable. In some cases, the implementation units needed to recompile a -project are not available, or come from some third party and you do not want to -recompile it yourself. In this case, set the attribute @b{Externally_Built} to -"true", indicating to the builder that this project can be assumed to be -up-to-date, and should not be considered for recompilation. In Ada, if the -sources of this externally built project were compiled with another version of -the compiler or with incompatible options, the binder will issue an error. - -The project's @code{with} clause has several effects. It provides source -visibility between projects during the compilation process. It also guarantees -that the necessary object files from @code{Logging} and @code{GtkAda} are -available when linking @code{Build}. - -As can be seen in this example, the syntax for importing projects is similar -to the syntax for importing compilation units in Ada. However, project files -use literal strings instead of names, and the @code{with} clause identifies -project files rather than packages. - -Each literal string after @code{with} is the path -(absolute or relative) to a project file. The @code{.gpr} extension is -optional, although we recommend adding it. If no extension is specified, -and no project file with the @file{.gpr} extension is found, then -the file is searched for exactly as written in the @code{with} clause, -that is with no extension. - -As mentioned above, the path after a @code{with} has to be a literal -string, and you cannot use concatenation, or lookup the value of external -variables to change the directories from which a project is loaded. -A solution if you need something like this is to use aggregate projects -(@pxref{Aggregate Projects}). - -@cindex project path -When a relative path or a base name is used, the -project files are searched relative to each of the directories in the -@b{project path}. This path includes all the directories found with the -following algorithm, in this order; the first matching file is used: - -@itemize @bullet -@item First, the file is searched relative to the directory that contains the - current project file. - -@item -@cindex @code{GPR_PROJECT_PATH_FILE} -@cindex @code{GPR_PROJECT_PATH} -@cindex @code{ADA_PROJECT_PATH} - Then it is searched relative to all the directories specified in the - environment variables @b{GPR_PROJECT_PATH_FILE}, - @b{GPR_PROJECT_PATH} and @b{ADA_PROJECT_PATH} (in that order) if they exist. - The value of @b{GPR_PROJECT_PATH_FILE}, when defined, is the path name of - a text file that contains project directory path names, one per line. - @b{GPR_PROJECT_PATH} and @b{ADA_PROJECT_PATH}, when defined, contain - project directory path names separated by directory separators. - @b{ADA_PROJECT_PATH} is used for compatibility, it is recommended to - use @b{GPR_PROJECT_PATH_FILE} or @b{GPR_PROJECT_PATH}. - -@item Finally, it is searched relative to the default project directories. - Such directories depend on the tool used. The locations searched in the - specified order are: - - @itemize @bullet - @item @file{<prefix>/<target>/lib/gnat} - (for @command{gnatmake} in all cases, and for @command{gprbuild} if option - @option{--target} is specified) - @item @file{<prefix>/<target>/share/gpr} - (for @command{gnatmake} in all cases, and for @command{gprbuild} if option - @option{--target} is specified) - @item @file{<prefix>/share/gpr/} - (for @command{gnatmake} and @command{gprbuild}) - @item @file{<prefix>/lib/gnat/} - (for @command{gnatmake} and @command{gprbuild}) - @end itemize - - In our example, @file{gtkada.gpr} is found in the predefined directory if - it was installed at the same root as GNAT. -@end itemize - -@noindent -Some tools also support extending the project path from the command line, -generally through the @option{-aP}. You can see the value of the project -path by using the @command{gnatls -v} command. - -Any symbolic link will be fully resolved in the directory of the -importing project file before the imported project file is examined. - -Any source file in the imported project can be used by the sources of the -importing project, transitively. -Thus if @code{A} imports @code{B}, which imports @code{C}, the sources of -@code{A} may depend on the sources of @code{C}, even if @code{A} does not -import @code{C} explicitly. However, this is not recommended, because if -and when @code{B} ceases to import @code{C}, some sources in @code{A} will -no longer compile. @command{gprbuild} has a switch @option{--no-indirect-imports} -that will report such indirect dependencies. - -One very important aspect of a project hierarchy is that -@b{a given source can only belong to one project} (otherwise the project manager -would not know which settings apply to it and when to recompile it). It means -that different project files do not usually share source directories or -when they do, they need to specify precisely which project owns which sources -using attribute @code{Source_Files} or equivalent. By contrast, 2 projects -can each own a source with the same base file name as long as they live in -different directories. The latter is not true for Ada Sources because of the -correlation between source files and Ada units. - -@c --------------------------------------------- -@node Cyclic Project Dependencies -@subsection Cyclic Project Dependencies -@c --------------------------------------------- - -@noindent -Cyclic dependencies are mostly forbidden: -if @code{A} imports @code{B} (directly or indirectly) then @code{B} -is not allowed to import @code{A}. However, there are cases when cyclic -dependencies would be beneficial. For these cases, another form of import -between projects exists: the @b{limited with}. A project @code{A} that -imports a project @code{B} with a straight @code{with} may also be imported, -directly or indirectly, by @code{B} through a @code{limited with}. - -The difference between straight @code{with} and @code{limited with} is that -the name of a project imported with a @code{limited with} cannot be used in the -project importing it. In particular, its packages cannot be renamed and -its variables cannot be referred to. - -@smallexample @c 0projectfile -with "b.gpr"; -with "c.gpr"; -project A is - For Exec_Dir use B'Exec_Dir; -- ok -end A; - -limited with "a.gpr"; -- Cyclic dependency: A -> B -> A -project B is - For Exec_Dir use A'Exec_Dir; -- not ok -end B; - -with "d.gpr"; -project C is -end C; - -limited with "a.gpr"; -- Cyclic dependency: A -> C -> D -> A -project D is - For Exec_Dir use A'Exec_Dir; -- not ok -end D; -@end smallexample - -@c --------------------------------------------- -@node Sharing Between Projects -@subsection Sharing Between Projects -@c --------------------------------------------- - -@noindent -When building an application, it is common to have similar needs in several of -the projects corresponding to the subsystems under construction. For instance, -they will all have the same compilation switches. - -As seen before (@pxref{Tools Options in Project Files}), setting compilation -switches for all sources of a subsystem is simple: it is just a matter of -adding a @code{Compiler.Default_Switches} attribute to each project files with -the same value. Of course, that means duplication of data, and both places need -to be changed in order to recompile the whole application with different -switches. It can become a real problem if there are many subsystems and thus -many project files to edit. - -There are two main approaches to avoiding this duplication: - -@itemize @bullet -@item Since @file{build.gpr} imports @file{logging.gpr}, we could change it - to reference the attribute in Logging, either through a package renaming, - or by referencing the attribute. The following example shows both cases: - - @smallexample @c projectfile - project Logging is - package Compiler is - for Switches ("Ada") - use ("-O2"); - end Compiler; - package Binder is - for Switches ("Ada") - use ("-E"); - end Binder; - end Logging; - - with "logging.gpr"; - project Build is - package Compiler renames Logging.Compiler; - package Binder is - for Switches ("Ada") use Logging.Binder'Switches ("Ada"); - end Binder; - end Build; - @end smallexample - - @noindent - The solution used for @code{Compiler} gets the same value for all - attributes of the package, but you cannot modify anything from the - package (adding extra switches or some exceptions). The second - version is more flexible, but more verbose. - - If you need to refer to the value of a variable in an imported - project, rather than an attribute, the syntax is similar but uses - a "." rather than an apostrophe. For instance: - - @smallexample @c projectfile - with "imported"; - project Main is - Var1 := Imported.Var; - end Main; - @end smallexample - -@item The second approach is to define the switches in a third project. - That project is set up without any sources (so that, as opposed to - the first example, none of the project plays a special role), and - will only be used to define the attributes. Such a project is - typically called @file{shared.gpr}. - - @smallexample @c projectfile - abstract project Shared is - for Source_Files use (); -- no sources - package Compiler is - for Switches ("Ada") - use ("-O2"); - end Compiler; - end Shared; - - with "shared.gpr"; - project Logging is - package Compiler renames Shared.Compiler; - end Logging; - - with "shared.gpr"; - project Build is - package Compiler renames Shared.Compiler; - end Build; - @end smallexample - - @noindent - As for the first example, we could have chosen to set the attributes - one by one rather than to rename a package. The reason we explicitly - indicate that @code{Shared} has no sources is so that it can be created - in any directory and we are sure it shares no sources with @code{Build} - or @code{Logging}, which of course would be invalid. - -@cindex project qualifier - Note the additional use of the @b{abstract} qualifier in @file{shared.gpr}. - This qualifier is optional, but helps convey the message that we do not - intend this project to have sources (@pxref{Qualified Projects} for - more qualifiers). -@end itemize - -@c --------------------------------------------- -@node Global Attributes -@subsection Global Attributes -@c --------------------------------------------- - -@noindent -We have already seen many examples of attributes used to specify a special -option of one of the tools involved in the build process. Most of those -attributes are project specific. That it to say, they only affect the invocation -of tools on the sources of the project where they are defined. - -There are a few additional attributes that apply to all projects in a -hierarchy as long as they are defined on the "main" project. -The main project is the project explicitly mentioned on the command-line. -The project hierarchy is the "with"-closure of the main project. - -Here is a list of commonly used global attributes: - -@table @asis -@item @b{Builder.Global_Configuration_Pragmas}: -@cindex @code{Global_Configuration_Pragmas} - This attribute points to a file that contains configuration pragmas - to use when building executables. These pragmas apply for all - executables built from this project hierarchy. As we have seen before, - additional pragmas can be specified on a per-project basis by setting the - @code{Compiler.Local_Configuration_Pragmas} attribute. - -@item @b{Builder.Global_Compilation_Switches}: -@cindex @code{Global_Compilation_Switches} - This attribute is a list of compiler switches to use when compiling any - source file in the project hierarchy. These switches are used in addition - to the ones defined in the @code{Compiler} package, which only apply to - the sources of the corresponding project. This attribute is indexed on - the name of the language. - -@end table - -Using such global capabilities is convenient. It can also lead to unexpected -behavior. Especially when several subsystems are shared among different main -projects and the different global attributes are not -compatible. Note that using aggregate projects can be a safer and more powerful -replacement to global attributes. - -@c --------------------------------------------- -@node Scenarios in Projects -@section Scenarios in Projects -@c --------------------------------------------- - -@noindent -Various aspects of the projects can be modified based on @b{scenarios}. These -are user-defined modes that change the behavior of a project. Typical -examples are the setup of platform-specific compiler options, or the use of -a debug and a release mode (the former would activate the generation of debug -information, while the second will focus on improving code optimization). - -Let's enhance our example to support debug and release modes. The issue is to -let the user choose what kind of system he is building: use @option{-g} as -compiler switches in debug mode and @option{-O2} in release mode. We will also -set up the projects so that we do not share the same object directory in both -modes; otherwise switching from one to the other might trigger more -recompilations than needed or mix objects from the two modes. - -One naive approach is to create two different project files, say -@file{build_debug.gpr} and @file{build_release.gpr}, that set the appropriate -attributes as explained in previous sections. This solution does not scale -well, because in the presence of multiple projects depending on each other, you -will also have to duplicate the complete hierarchy and adapt the project files -to point to the right copies. - -@cindex scenarios -Instead, project files support the notion of scenarios controlled -by external values. Such values can come from several sources (in decreasing -order of priority): - -@table @asis -@item @b{Command line}: -@cindex @option{-X} - When launching @command{gnatmake} or @command{gprbuild}, the user can pass - extra @option{-X} switches to define the external value. In - our case, the command line might look like - - @smallexample - gnatmake -Pbuild.gpr -Xmode=debug - or gnatmake -Pbuild.gpr -Xmode=release - @end smallexample - -@item @b{Environment variables}: - When the external value does not come from the command line, it can come from - the value of environment variables of the appropriate name. - In our case, if an environment variable called "mode" - exists, its value will be taken into account. - -@item @b{External function second parameter}. - -@end table - -@cindex @code{external} -We now need to get that value in the project. The general form is to use -the predefined function @b{external} which returns the current value of -the external. For instance, we could set up the object directory to point to -either @file{obj/debug} or @file{obj/release} by changing our project to - -@smallexample @c projectfile - @b{project} Build @b{is} - @b{for} Object_Dir @b{use} "obj/" & @b{external} ("mode", "debug"); - ... --@i{ as before} - @b{end} Build; -@end smallexample - -@noindent -The second parameter to @code{external} is optional, and is the default -value to use if "mode" is not set from the command line or the environment. - -In order to set the switches according to the different scenarios, other -constructs have to be introduced such as typed variables and case constructions. - -@cindex typed variable -@cindex case construction -A @b{typed variable} is a variable that -can take only a limited number of values, similar to an enumeration in Ada. -Such a variable can then be used in a @b{case construction} and create conditional -sections in the project. The following example shows how this can be done: - -@smallexample @c projectfile - @b{project} Build @b{is} - @b{type} Mode_Type @b{is} ("debug", "release"); --@i{ all possible values} - Mode : Mode_Type := @b{external} ("mode", "debug"); --@i{ a typed variable} - - @b{package} Compiler @b{is} - @b{case} Mode @b{is} - @b{when} "debug" => - @b{for} Switches ("Ada") - @b{use} ("-g"); - @b{when} "release" => - @b{for} Switches ("Ada") - @b{use} ("-O2"); - @b{end} @b{case}; - @b{end} Compiler; - @b{end} Build; -@end smallexample - -@noindent -The project has suddenly grown in size, but has become much more flexible. -@code{Mode_Type} defines the only valid values for the @code{mode} variable. If -any other value is read from the environment, an error is reported and the -project is considered as invalid. - -The @code{Mode} variable is initialized with an external value -defaulting to @code{"debug"}. This default could be omitted and that would -force the user to define the value. Finally, we can use a case construction to set the -switches depending on the scenario the user has chosen. - -Most aspects of the projects can depend on scenarios. The notable exception -are project dependencies (@code{with} clauses), which cannot depend on a scenario. - -Scenarios work the same way with @b{project hierarchies}: you can either -duplicate a variable similar to @code{Mode} in each of the project (as long -as the first argument to @code{external} is always the same and the type is -the same), or simply set the variable in the @file{shared.gpr} project -(@pxref{Sharing Between Projects}). - -@c --------------------------------------------- -@node Library Projects -@section Library Projects -@c --------------------------------------------- - -@noindent -So far, we have seen examples of projects that create executables. However, -it is also possible to create libraries instead. A @b{library} is a specific -type of subsystem where, for convenience, objects are grouped together -using system-specific means such as archives or windows DLLs. - -Library projects provide a system- and language-independent way of building both @b{static} -and @b{dynamic} libraries. They also support the concept of @b{standalone -libraries} (SAL) which offer two significant properties: the elaboration -(e.g. initialization) of the library is either automatic or very simple; -a change in the -implementation part of the library implies minimal post-compilation actions on -the complete system and potentially no action at all for the rest of the -system in the case of dynamic SALs. - -There is a restriction on shared library projects: by default, they are only -allowed to import other shared library projects. They are not allowed to -import non library projects or static library projects. - -The GNAT Project Manager takes complete care of the library build, rebuild and -installation tasks, including recompilation of the source files for which -objects do not exist or are not up to date, assembly of the library archive, and -installation of the library (i.e., copying associated source, object and -@file{ALI} files to the specified location). - -@menu -* Building Libraries:: -* Using Library Projects:: -* Stand-alone Library Projects:: -* Installing a library with project files:: -@end menu - -@c --------------------------------------------- -@node Building Libraries -@subsection Building Libraries -@c --------------------------------------------- - -@noindent -Let's enhance our example and transform the @code{logging} subsystem into a -library. In order to do so, a few changes need to be made to -@file{logging.gpr}. Some attributes need to be defined: at least -@code{Library_Name} and @code{Library_Dir}; in addition, some other attributes -can be used to specify specific aspects of the library. For readability, it is -also recommended (although not mandatory), to use the qualifier @code{library} -in front of the @code{project} keyword. - -@table @asis -@item @b{Library_Name}: -@cindex @code{Library_Name} - This attribute is the name of the library to be built. There is no - restriction on the name of a library imposed by the project manager, except - for stand-alone libraries whose names must follow the syntax of Ada - identifiers; however, there may be system-specific restrictions on the name. - In general, it is recommended to stick to alphanumeric characters (and - possibly single underscores) to help portability. - -@item @b{Library_Dir}: -@cindex @code{Library_Dir} - This attribute is the path (absolute or relative) of the directory where - the library is to be installed. In the process of building a library, - the sources are compiled, the object files end up in the explicit or - implicit @code{Object_Dir} directory. When all sources of a library - are compiled, some of the compilation artifacts, including the library itself, - are copied to the library_dir directory. This directory must exist and be - writable. It must also be different from the object directory so that cleanup - activities in the Library_Dir do not affect recompilation needs. - -@end table - -Here is the new version of @file{logging.gpr} that makes it a library: - -@smallexample @c projectfile -library @b{project} Logging @b{is} --@i{ "library" is optional} - @b{for} Library_Name @b{use} "logging"; --@i{ will create "liblogging.a" on Unix} - @b{for} Object_Dir @b{use} "obj"; - @b{for} Library_Dir @b{use} "lib"; --@i{ different from object_dir} -@b{end} Logging; -@end smallexample - -@noindent -Once the above two attributes are defined, the library project is valid and -is enough for building a library with default characteristics. -Other library-related attributes can be used to change the defaults: - -@table @asis -@item @b{Library_Kind}: -@cindex @code{Library_Kind} - The value of this attribute must be either @code{"static"}, @code{"dynamic"} or - @code{"relocatable"} (the latter is a synonym for dynamic). It indicates - which kind of library should be built (the default is to build a - static library, that is an archive of object files that can potentially - be linked into a static executable). When the library is set to be dynamic, - a separate image is created that will be loaded independently, usually - at the start of the main program execution. Support for dynamic libraries is - very platform specific, for instance on Windows it takes the form of a DLL - while on GNU/Linux, it is a dynamic elf image whose suffix is usually - @file{.so}. Library project files, on the other hand, can be written in - a platform independent way so that the same project file can be used to build - a library on different operating systems. - - If you need to build both a static and a dynamic library, it is recommended - to use two different object directories, since in some cases some extra code - needs to be generated for the latter. For such cases, one can either define - two different project files, or a single one that uses scenarios to indicate - the various kinds of library to be built and their corresponding object_dir. - -@cindex @code{Library_ALI_Dir} -@item @b{Library_ALI_Dir}: - This attribute may be specified to indicate the directory where the ALI - files of the library are installed. By default, they are copied into the - @code{Library_Dir} directory, but as for the executables where we have a - separate @code{Exec_Dir} attribute, you might want to put them in a separate - directory since there can be hundreds of them. The same restrictions as for - the @code{Library_Dir} attribute apply. - -@cindex @code{Library_Version} -@item @b{Library_Version}: - This attribute is platform dependent, and has no effect on Windows. - On Unix, it is used only for dynamic libraries as the internal - name of the library (the @code{"soname"}). If the library file name (built - from the @code{Library_Name}) is different from the @code{Library_Version}, - then the library file will be a symbolic link to the actual file whose name - will be @code{Library_Version}. This follows the usual installation schemes - for dynamic libraries on many Unix systems. - -@smallexample @c projectfile -@group - @b{project} Logging @b{is} - Version := "1"; - @b{for} Library_Dir @b{use} "lib"; - @b{for} Library_Name @b{use} "logging"; - @b{for} Library_Kind @b{use} "dynamic"; - @b{for} Library_Version @b{use} "liblogging.so." & Version; - @b{end} Logging; -@end group -@end smallexample - - @noindent - After the compilation, the directory @file{lib} will contain both a - @file{libdummy.so.1} library and a symbolic link to it called - @file{libdummy.so}. - -@cindex @code{Library_GCC} -@item @b{Library_GCC}: - This attribute is the name of the tool to use instead of "gcc" to link shared - libraries. A common use of this attribute is to define a wrapper script that - accomplishes specific actions before calling gcc (which itself calls the - linker to build the library image). - -@item @b{Library_Options}: -@cindex @code{Library_Options} - This attribute may be used to specify additional switches (last switches) - when linking a shared library. - - It may also be used to add foreign object files to a static library. - Each string in Library_Options is an absolute or relative path of an object - file. When a relative path, it is relative to the object directory. - -@item @b{Leading_Library_Options}: -@cindex @code{Leading_Library_Options} - This attribute, that is taken into account only by @command{gprbuild}, may be - used to specified leading options (first switches) when linking a shared - library. - -@cindex @code{Linker_Options} -@item @b{Linker.Linker_Options}: - This attribute specifies additional switches to be given to the linker when - linking an executable. It is ignored when defined in the main project and - taken into account in all other projects that are imported directly or - indirectly. These switches complement the @code{Linker.Switches} - defined in the main project. This is useful when a particular subsystem - depends on an external library: adding this dependency as a - @code{Linker_Options} in the project of the subsystem is more convenient than - adding it to all the @code{Linker.Switches} of the main projects that depend - upon this subsystem. -@end table - -@c --------------------------------------------- -@node Using Library Projects -@subsection Using Library Projects -@c --------------------------------------------- - -@noindent -When the builder detects that a project file is a library project file, it -recompiles all sources of the project that need recompilation and rebuild the -library if any of the sources have been recompiled. It then groups all object -files into a single file, which is a shared or a static library. This library -can later on be linked with multiple executables. Note that the use -of shard libraries reduces the size of the final executable and can also reduce -the memory footprint at execution time when the library is shared among several -executables. - -It is also possible to build @b{multi-language libraries}. When using -@command{gprbuild} as a builder, multi-language library projects allow naturally -the creation of multi-language libraries . @command{gnatmake}, does not try to -compile non Ada sources. However, when the project is multi-language, it will -automatically link all object files found in the object directory, whether or -not they were compiled from an Ada source file. This specific behavior does not -apply to Ada-only projects which only take into account the objects -corresponding to the sources of the project. - -A non-library project can import a library project. When the builder is invoked -on the former, the library of the latter is only rebuilt when absolutely -necessary. For instance, if a unit of the library is not up-to-date but none of -the executables need this unit, then the unit is not recompiled and the library -is not reassembled. For instance, let's assume in our example that logging has -the following sources: @file{log1.ads}, @file{log1.adb}, @file{log2.ads} and -@file{log2.adb}. If @file{log1.adb} has been modified, then the library -@file{liblogging} will be rebuilt when compiling all the sources of -@code{Build} only if @file{proc.ads}, @file{pack.ads} or @file{pack.adb} -include a @code{"with Log1"}. - -To ensure that all the sources in the @code{Logging} library are -up to date, and that all the sources of @code{Build} are also up to date, -the following two commands need to be used: - -@smallexample -gnatmake -Plogging.gpr -gnatmake -Pbuild.gpr -@end smallexample - -@noindent -All @file{ALI} files will also be copied from the object directory to the -library directory. To build executables, @command{gnatmake} will use the -library rather than the individual object files. - -Library projects can also be useful to describe a library that needs to be used -but, for some reason, cannot be rebuilt. For instance, it is the case when some -of the library sources are not available. Such library projects need to use the -@code{Externally_Built} attribute as in the example below: - -@smallexample @c projectfile -library @b{project} Extern_Lib @b{is} - @b{for} Languages @b{use} ("Ada", "C"); - @b{for} Source_Dirs @b{use} ("lib_src"); - @b{for} Library_Dir @b{use} "lib2"; - @b{for} Library_Kind @b{use} "dynamic"; - @b{for} Library_Name @b{use} "l2"; - @b{for} Externally_Built @b{use} "true"; --@i{ <<<<} -@b{end} Extern_Lib; -@end smallexample - -@noindent -In the case of externally built libraries, the @code{Object_Dir} -attribute does not need to be specified because it will never be -used. - -The main effect of using such an externally built library project is mostly to -affect the linker command in order to reference the desired library. It can -also be achieved by using @code{Linker.Linker_Options} or @code{Linker.Switches} -in the project corresponding to the subsystem needing this external library. -This latter method is more straightforward in simple cases but when several -subsystems depend upon the same external library, finding the proper place -for the @code{Linker.Linker_Options} might not be easy and if it is -not placed properly, the final link command is likely to present ordering issues. -In such a situation, it is better to use the externally built library project -so that all other subsystems depending on it can declare this dependency thanks -to a project @code{with} clause, which in turn will trigger the builder to find -the proper order of libraries in the final link command. - -@c --------------------------------------------- -@node Stand-alone Library Projects -@subsection Stand-alone Library Projects -@c --------------------------------------------- - -@noindent -@cindex standalone libraries -A @b{stand-alone library} is a library that contains the necessary code to -elaborate the Ada units that are included in the library. A stand-alone -library is a convenient way to add an Ada subsystem to a more global system -whose main is not in Ada since it makes the elaboration of the Ada part mostly -transparent. However, stand-alone libraries are also useful when the main is in -Ada: they provide a means for minimizing relinking & redeployment of complex -systems when localized changes are made. - -The name of a stand-alone library, specified with attribute -@code{Library_Name}, must have the syntax of an Ada identifier. - -The most prominent characteristic of a stand-alone library is that it offers a -distinction between interface units and implementation units. Only the former -are visible to units outside the library. A stand-alone library project is thus -characterised by a third attribute, usually @b{Library_Interface}, in addition -to the two attributes that make a project a Library Project -(@code{Library_Name} and @code{Library_Dir}). This third attribute may also be -@b{Interfaces}. @b{Library_Interface} only works when the interface is in Ada -and takes a list of units as parameter. @b{Interfaces} works for any supported -language and takes a list of sources as parameter. - -@table @asis -@item @b{Library_Interface}: -@cindex @code{Library_Interface} - This attribute defines an explicit subset of the units of the project. Units - from projects importing this library project may only "with" units whose - sources are listed in the @code{Library_Interface}. Other sources are - considered implementation units. - -@smallexample @c projectfile -@group - @b{for} Library_Dir @b{use} "lib"; - @b{for} Library_Name @b{use} "logging"; - @b{for} Library_Interface @b{use} ("lib1", "lib2"); --@i{ unit names} -@end group -@end smallexample - -@item @b{Interfaces} - This attribute defines an explicit subset of the source files of a project. - Sources from projects importing this project, can only depend on sources from - this subset. This attribute can be used on non library projects. It can also - be used as a replacement for attribute @code{Library_Interface}, in which - case, units have to be replaced by source files. For multi-language library - projects, it is the only way to make the project a Stand-Alone Library project - whose interface is not purely Ada. - -@item @b{Library_Standalone}: -@cindex @code{Library_Standalone} - This attribute defines the kind of standalone library to - build. Values are either @code{standard} (the default), @code{no} or - @code{encapsulated}. When @code{standard} is used the code to elaborate and - finalize the library is embedded, when @code{encapsulated} is used the - library can furthermore depend only on static libraries (including - the GNAT runtime). This attribute can be set to @code{no} to make it clear - that the library should not be standalone in which case the - @code{Library_Interface} should not defined. Note that this attribute - only applies to shared libraries, so @code{Library_Kind} must be set - to @code{dynamic}. - -@smallexample @c projectfile -@group - @b{for} Library_Dir @b{use} "lib"; - @b{for} Library_Name @b{use} "logging"; - @b{for} Library_Kind @b{use} "dynamic"; - @b{for} Library_Interface @b{use} ("lib1", "lib2"); --@i{ unit names} - @b{for} Library_Standalone @b{use} "encapsulated"; -@end group -@end smallexample - -@end table - -In order to include the elaboration code in the stand-alone library, the binder -is invoked on the closure of the library units creating a package whose name -depends on the library name (b~logging.ads/b in the example). -This binder-generated package includes @b{initialization} and @b{finalization} -procedures whose names depend on the library name (@code{logginginit} and -@code{loggingfinal} in the example). The object corresponding to this package is -included in the library. - -@table @asis -@item @b{Library_Auto_Init}: -@cindex @code{Library_Auto_Init} - A dynamic stand-alone Library is automatically initialized - if automatic initialization of Stand-alone Libraries is supported on the - platform and if attribute @b{Library_Auto_Init} is not specified or - is specified with the value "true". A static Stand-alone Library is never - automatically initialized. Specifying "false" for this attribute - prevents automatic initialization. - - When a non-automatically initialized stand-alone library is used in an - executable, its initialization procedure must be called before any service of - the library is used. When the main subprogram is in Ada, it may mean that the - initialization procedure has to be called during elaboration of another - package. - -@item @b{Library_Dir}: -@cindex @code{Library_Dir} - For a stand-alone library, only the @file{ALI} files of the interface units - (those that are listed in attribute @code{Library_Interface}) are copied to - the library directory. As a consequence, only the interface units may be - imported from Ada units outside of the library. If other units are imported, - the binding phase will fail. - -@item @b{Binder.Default_Switches}: - When a stand-alone library is bound, the switches that are specified in - the attribute @b{Binder.Default_Switches ("Ada")} are - used in the call to @command{gnatbind}. - -@item @b{Library_Src_Dir}: -@cindex @code{Library_Src_Dir} - This attribute defines the location (absolute or relative to the project - directory) where the sources of the interface units are copied at - installation time. - These sources includes the specs of the interface units along with the - closure of sources necessary to compile them successfully. That may include - bodies and subunits, when pragmas @code{Inline} are used, or when there are - generic units in specs. This directory cannot point to the object directory - or one of the source directories, but it can point to the library directory, - which is the default value for this attribute. - -@item @b{Library_Symbol_Policy}: -@cindex @code{Library_Symbol_Policy} - This attribute controls the export of symbols and, on some platforms (like - VMS) that have the notions of major and minor IDs built in the library - files, it controls the setting of these IDs. It is not supported on all - platforms (where it will just have no effect). It may have one of the - following values: - - @itemize - - @item @code{"autonomous"} or @code{"default"}: exported symbols are not controlled - @item @code{"compliant"}: if attribute @b{Library_Reference_Symbol_File} - is not defined, then it is equivalent to policy "autonomous". If there - are exported symbols in the reference symbol file that are not in the - object files of the interfaces, the major ID of the library is increased. - If there are symbols in the object files of the interfaces that are not - in the reference symbol file, these symbols are put at the end of the list - in the newly created symbol file and the minor ID is increased. - @item @code{"controlled"}: the attribute @b{Library_Reference_Symbol_File} must be - defined. The library will fail to build if the exported symbols in the - object files of the interfaces do not match exactly the symbol in the - symbol file. - @item @code{"restricted"}: The attribute @b{Library_Symbol_File} must be defined. - The library will fail to build if there are symbols in the symbol file that - are not in the exported symbols of the object files of the interfaces. - Additional symbols in the object files are not added to the symbol file. - @item @code{"direct"}: The attribute @b{Library_Symbol_File} must be defined and - must designate an existing file in the object directory. This symbol file - is passed directly to the underlying linker without any symbol processing. - - @end itemize - -@item @b{Library_Reference_Symbol_File} -@cindex @code{Library_Reference_Symbol_File} - This attribute may define the path name of a reference symbol file that is - read when the symbol policy is either "compliant" or "controlled", on - platforms that support symbol control, such as VMS, when building a - stand-alone library. The path may be an absolute path or a path relative - to the project directory. - -@item @b{Library_Symbol_File} -@cindex @code{Library_Symbol_File} - This attribute may define the name of the symbol file to be created when - building a stand-alone library when the symbol policy is either "compliant", - "controlled" or "restricted", on platforms that support symbol control, - such as VMS. When symbol policy is "direct", then a file with this name - must exist in the object directory. -@end table - -@c --------------------------------------------- -@node Installing a library with project files -@subsection Installing a library with project files -@c --------------------------------------------- - -@noindent -When using project files, a usable version of the library is created in the -directory specified by the @code{Library_Dir} attribute of the library -project file. Thus no further action is needed in order to make use of -the libraries that are built as part of the general application build. - -You may want to install a library in a context different from where the library -is built. This situation arises with third party suppliers, who may want -to distribute a library in binary form where the user is not expected to be -able to recompile the library. The simplest option in this case is to provide -a project file slightly different from the one used to build the library, by -using the @code{externally_built} attribute. @ref{Using Library Projects} - -Another option is to use @command{gprinstall} to install the library in a -different context than the build location. @command{gprinstall} automatically -generates a project to use this library, and also copies the minimum set of -sources needed to use the library to the install location. -@ref{Installation} - -@c --------------------------------------------- -@node Project Extension -@section Project Extension -@c --------------------------------------------- - -@noindent -During development of a large system, it is sometimes necessary to use -modified versions of some of the source files, without changing the original -sources. This can be achieved through the @b{project extension} facility. - -Suppose for instance that our example @code{Build} project is built every night -for the whole team, in some shared directory. A developer usually needs to work -on a small part of the system, and might not want to have a copy of all the -sources and all the object files (mostly because that would require too much -disk space, time to recompile everything). He prefers to be able to override -some of the source files in his directory, while taking advantage of all the -object files generated at night. - -Another example can be taken from large software systems, where it is common to have -multiple implementations of a common interface; in Ada terms, multiple -versions of a package body for the same spec. For example, one implementation -might be safe for use in tasking programs, while another might be used only -in sequential applications. This can be modeled in GNAT using the concept -of @emph{project extension}. If one project (the ``child'') @emph{extends} -another project (the ``parent'') then by default all source files of the -parent project are inherited by the child, but the child project can -override any of the parent's source files with new versions, and can also -add new files or remove unnecessary ones. -This facility is the project analog of a type extension in -object-oriented programming. Project hierarchies are permitted (an extending -project may itself be extended), and a project that -extends a project can also import other projects. - -A third example is that of using project extensions to provide different -versions of the same system. For instance, assume that a @code{Common} -project is used by two development branches. One of the branches has now -been frozen, and no further change can be done to it or to @code{Common}. -However, the other development branch still needs evolution of @code{Common}. -Project extensions provide a flexible solution to create a new version -of a subsystem while sharing and reusing as much as possible from the original -one. - -A project extension implicitly inherits all the sources and objects from the -project it extends. It is possible to create a new version of some of the -sources in one of the additional source directories of the extending -project. Those new versions hide the original versions. Adding new sources or -removing existing ones is also possible. Here is an example on how to extend -the project @code{Build} from previous examples: - -@smallexample @c projectfile - @b{project} Work @b{extends} "../bld/build.gpr" @b{is} - @b{end} Work; -@end smallexample - -@noindent -The project after @b{extends} is the one being extended. As usual, it can be -specified using an absolute path, or a path relative to any of the directories -in the project path (@pxref{Project Dependencies}). This project does not -specify source or object directories, so the default values for these -attributes will be used that is to say the current directory (where project -@code{Work} is placed). We can compile that project with - -@smallexample - gprbuild -Pwork -@end smallexample - -@noindent -If no sources have been placed in the current directory, this command -won't do anything, since this project does not change the -sources it inherited from @code{Build}, therefore all the object files -in @code{Build} and its dependencies are still valid and are reused -automatically. - -Suppose we now want to supply an alternate version of @file{pack.adb} but use -the existing versions of @file{pack.ads} and @file{proc.adb}. We can create -the new file in Work's current directory (likely by copying the one from the -@code{Build} project and making changes to it. If new packages are needed at -the same time, we simply create new files in the source directory of the -extending project. - -When we recompile, @command{gprbuild} will now automatically recompile -this file (thus creating @file{pack.o} in the current directory) and -any file that depends on it (thus creating @file{proc.o}). Finally, the -executable is also linked locally. - -Note that we could have obtained the desired behavior using project import -rather than project inheritance. A @code{base} project would contain the -sources for @file{pack.ads} and @file{proc.adb}, and @code{Work} would -import @code{base} and add @file{pack.adb}. In this scenario, @code{base} -cannot contain the original version of @file{pack.adb} otherwise there would be -2 versions of the same unit in the closure of the project and this is not -allowed. Generally speaking, it is not recommended to put the spec and the -body of a unit in different projects since this affects their autonomy and -reusability. - -In a project file that extends another project, it is possible to -indicate that an inherited source is @b{not part} of the sources of the -extending project. This is necessary sometimes when a package spec has -been overridden and no longer requires a body: in this case, it is -necessary to indicate that the inherited body is not part of the sources -of the project, otherwise there will be a compilation error -when compiling the spec. - -@cindex @code{Excluded_Source_Files} -@cindex @code{Excluded_Source_List_File} -For that purpose, the attribute @b{Excluded_Source_Files} is used. -Its value is a list of file names. -It is also possible to use attribute @code{Excluded_Source_List_File}. -Its value is the path of a text file containing one file name per -line. - -@smallexample @c @projectfile -project Work extends "../bld/build.gpr" is - for Source_Files use ("pack.ads"); - -- New spec of Pkg does not need a completion - for Excluded_Source_Files use ("pack.adb"); -end Work; -@end smallexample - -@noindent -All packages that are not declared in the extending project are inherited from -the project being extended, with their attributes, with the exception of -@code{Linker'Linker_Options} which is never inherited. In particular, an -extending project retains all the switches specified in the project being -extended. - -At the project level, if they are not declared in the extending project, some -attributes are inherited from the project being extended. They are: -@code{Languages}, @code{Main} (for a root non library project) and -@code{Library_Name} (for a project extending a library project). - -@menu -* Project Hierarchy Extension:: -@end menu - -@c --------------------------------------------- -@node Project Hierarchy Extension -@subsection Project Hierarchy Extension -@c --------------------------------------------- - -@noindent -One of the fundamental restrictions in project extension is the following: -@b{A project is not allowed to import directly or indirectly at the same time an -extending project and one of its ancestors}. - -By means of example, consider the following hierarchy of projects. - -@smallexample - a.gpr contains package A1 - b.gpr, imports a.gpr and contains B1, which depends on A1 - c.gpr, imports b.gpr and contains C1, which depends on B1 -@end smallexample - -@noindent -If we want to locally extend the packages @code{A1} and @code{C1}, we need to -create several extending projects: - -@smallexample - a_ext.gpr which extends a.gpr, and overrides A1 - b_ext.gpr which extends b.gpr and imports a_ext.gpr - c_ext.gpr which extends c.gpr, imports b_ext.gpr and overrides C1 -@end smallexample - -@noindent -@smallexample @c projectfile - @b{project} A_Ext @b{extends} "a.gpr" @b{is} - @b{for} Source_Files @b{use} ("a1.adb", "a1.ads"); - @b{end} A_Ext; - - @b{with} "a_ext.gpr"; - @b{project} B_Ext @b{extends} "b.gpr" @b{is} - @b{end} B_Ext; - - @b{with} "b_ext.gpr"; - @b{project} C_Ext @b{extends} "c.gpr" @b{is} - @b{for} Source_Files @b{use} ("c1.adb"); - @b{end} C_Ext; -@end smallexample - -@noindent -The extension @file{b_ext.gpr} is required, even though we are not overriding -any of the sources of @file{b.gpr} because otherwise @file{c_expr.gpr} would -import @file{b.gpr} which itself knows nothing about @file{a_ext.gpr}. - -@cindex extends all -When extending a large system spanning multiple projects, it is often -inconvenient to extend every project in the hierarchy that is impacted by a -small change introduced in a low layer. In such cases, it is possible to create -an @b{implicit extension} of an entire hierarchy using @b{extends all} -relationship. - -When the project is extended using @code{extends all} inheritance, all projects -that are imported by it, both directly and indirectly, are considered virtually -extended. That is, the project manager creates implicit projects -that extend every project in the hierarchy; all these implicit projects do not -control sources on their own and use the object directory of -the "extending all" project. - -It is possible to explicitly extend one or more projects in the hierarchy -in order to modify the sources. These extending projects must be imported by -the "extending all" project, which will replace the corresponding virtual -projects with the explicit ones. - -When building such a project hierarchy extension, the project manager will -ensure that both modified sources and sources in implicit extending projects -that depend on them are recompiled. - -Thus, in our example we could create the following projects instead: - -@smallexample - a_ext.gpr, extends a.gpr and overrides A1 - c_ext.gpr, "extends all" c.gpr, imports a_ext.gpr and overrides C1 - -@end smallexample - -@noindent -@smallexample @c projectfile - @b{project} A_Ext @b{extends} "a.gpr" @b{is} - @b{for} Source_Files @b{use} ("a1.adb", "a1.ads"); - @b{end} A_Ext; - - @b{with} "a_ext.gpr"; - @b{project} C_Ext @b{extends} @b{all} "c.gpr" @b{is} - @b{for} Source_Files @b{use} ("c1.adb"); - @b{end} C_Ext; -@end smallexample - -@noindent -When building project @file{c_ext.gpr}, the entire modified project space is -considered for recompilation, including the sources of @file{b.gpr} that are -impacted by the changes in @code{A1} and @code{C1}. - -@c --------------------------------------------- -@node Aggregate Projects -@section Aggregate Projects -@c --------------------------------------------- - -@noindent - -Aggregate projects are an extension of the project paradigm, and are -meant to solve a few specific use cases that cannot be solved directly -using standard projects. This section will go over a few of these use -cases to try to explain what you can use aggregate projects for. - -@menu -* Building all main programs from a single project tree:: -* Building a set of projects with a single command:: -* Define a build environment:: -* Performance improvements in builder:: -* Syntax of aggregate projects:: -* package Builder in aggregate projects:: -@end menu - -@c ----------------------------------------------------------- -@node Building all main programs from a single project tree -@subsection Building all main programs from a single project tree -@c ----------------------------------------------------------- - -Most often, an application is organized into modules and submodules, -which are very conveniently represented as a project tree or graph -(the root project A @code{with}s the projects for each modules (say B and C), -which in turn @code{with} projects for submodules. - -Very often, modules will build their own executables (for testing -purposes for instance), or libraries (for easier reuse in various -contexts). - -However, if you build your project through @command{gnatmake} or -@command{gprbuild}, using a syntax similar to - -@smallexample - gprbuild -PA.gpr -@end smallexample - -this will only rebuild the main programs of project A, not those of the -imported projects B and C. Therefore you have to spawn several -@command{gnatmake} commands, one per project, to build all executables. -This is a little inconvenient, but more importantly is inefficient -because @command{gnatmake} needs to do duplicate work to ensure that sources are -up-to-date, and cannot easily compile things in parallel when using -the -j switch. - -Also libraries are always rebuilt when building a project. - -You could therefore define an aggregate project Agg that groups A, B -and C. Then, when you build with - -@smallexample - gprbuild -PAgg.gpr -@end smallexample - -this will build all mains from A, B and C. - -@smallexample @c projectfile - aggregate @b{project} Agg @b{is} - @b{for} Project_Files @b{use} ("a.gpr", "b.gpr", "c.gpr"); - @b{end} Agg; -@end smallexample - -If B or C do not define any main program (through their Main -attribute), all their sources are built. When you do not group them -in the aggregate project, only those sources that are needed by A -will be built. - -If you add a main to a project P not already explicitly referenced in the -aggregate project, you will need to add "p.gpr" in the list of project -files for the aggregate project, or the main will not be built when -building the aggregate project. - -Aggregate projects are supported only with @command{gprbuild}, not with -@command{gnatmake}. - -@c --------------------------------------------------------- -@node Building a set of projects with a single command -@subsection Building a set of projects with a single command -@c --------------------------------------------------------- - -One other case is when you have multiple applications and libraries -that are built independently from each other (but can be built in -parallel). For instance, you have a project tree rooted at A, and -another one (which might share some subprojects) rooted at B. - -Using only @command{gprbuild}, you could do - -@smallexample - gprbuild -PA.gpr - gprbuild -PB.gpr -@end smallexample - -to build both. But again, @command{gprbuild} has to do some duplicate work for -those files that are shared between the two, and cannot truly build -things in parallel efficiently. - -If the two projects are really independent, share no sources other -than through a common subproject, and have no source files with a -common basename, you could create a project C that imports A and -B. But these restrictions are often too strong, and one has to build -them independently. An aggregate project does not have these -limitations and can aggregate two project trees that have common -sources. - -This scenario is particularly useful in environments like VxWorks 653 -where the applications running in the multiple partitions can be built -in parallel through a single @command{gprbuild} command. This also works nicely -with Annex E. - -@c --------------------------------------------- -@node Define a build environment -@subsection Define a build environment -@c --------------------------------------------- - -The environment variables at the time you launch @command{gprbuild} -will influence the view these tools have of the project -(PATH to find the compiler, ADA_PROJECT_PATH or GPR_PROJECT_PATH to find the -projects, environment variables that are referenced in project files -through the "external" built-in function, ...). Several command line switches -can be used to override those (-X or -aP), but on some systems and -with some projects, this might make the command line too long, and on -all systems often make it hard to read. - -An aggregate project can be used to set the environment for all -projects built through that aggregate. One of the nice aspects is that -you can put the aggregate project under configuration management, and -make sure all your user have a consistent environment when -building. The syntax looks like - -@smallexample @c projectfile - aggregate @b{project} Agg @b{is} - @b{for} Project_Files @b{use} ("A.gpr", "B.gpr"); - @b{for} Project_Path @b{use} ("../dir1", "../dir1/dir2"); - @b{for} External ("BUILD") @b{use} "PRODUCTION"; - - @b{package} Builder @b{is} - @b{for} Switches ("Ada") @b{use} ("-q"); - @b{end} Builder; - @b{end} Agg; -@end smallexample - -One of the often requested features in projects is to be able to -reference external variables in @code{with} declarations, as in - -@smallexample @c projectfile - @b{with} @b{external}("SETUP") & "path/prj.gpr"; --@i{ ILLEGAL} - @b{project} MyProject @b{is} - ... - @b{end} MyProject; -@end smallexample - -For various reasons, this is not allowed. But using aggregate projects provide -an elegant solution. For instance, you could use a project file like: - -@smallexample @c projectfile -aggregate @b{project} Agg @b{is} - @b{for} Project_Path @b{use} (@b{external}("SETUP") & "path"); - @b{for} Project_Files @b{use} ("myproject.gpr"); -@b{end} Agg; - -@b{with} "prj.gpr"; --@i{ searched on Agg'Project_Path} -@b{project} MyProject @b{is} - ... -@b{end} MyProject; -@end smallexample - -@c -------------------------------------------- -@node Performance improvements in builder -@subsection Performance improvements in builder -@c -------------------------------------------- - -The loading of aggregate projects is optimized in @command{gprbuild}, -so that all files are searched for only once on the disk -(thus reducing the number of system calls and contributing to faster -compilation times, especially on systems with sources on remote -servers). As part of the loading, @command{gprbuild} -computes how and where a source file should be compiled, and even if it is -found several times in the aggregated projects it will be compiled only -once. - -Since there is no ambiguity as to which switches should be used, files -can be compiled in parallel (through the usual -j switch) and this can -be done while maximizing the use of CPUs (compared to launching -multiple @command{gprbuild} and @command{gnatmake} commands in parallel). - -@c ------------------------------------- -@node Syntax of aggregate projects -@subsection Syntax of aggregate projects -@c ------------------------------------- - -An aggregate project follows the general syntax of project files. The -recommended extension is still @file{.gpr}. However, a special -@code{aggregate} qualifier must be put before the keyword -@code{project}. - -An aggregate project cannot @code{with} any other project (standard or -aggregate), except an abstract project which can be used to share attribute -values. Also, aggregate projects cannot be extended or imported though a -@code{with} clause by any other project. Building other aggregate projects from -an aggregate project is done through the Project_Files attribute (see below). - -An aggregate project does not have any source files directly (only -through other standard projects). Therefore a number of the standard -attributes and packages are forbidden in an aggregate project. Here is the -(non exhaustive) list: - -@itemize @bullet -@item Languages -@item Source_Files, Source_List_File and other attributes dealing with - list of sources. -@item Source_Dirs, Exec_Dir and Object_Dir -@item Library_Dir, Library_Name and other library-related attributes -@item Main -@item Roots -@item Externally_Built -@item Inherit_Source_Path -@item Excluded_Source_Dirs -@item Locally_Removed_Files -@item Excluded_Source_Files -@item Excluded_Source_List_File -@item Interfaces -@end itemize - -The only package that is authorized (albeit optional) is -Builder. Other packages (in particular Compiler, Binder and Linker) -are forbidden. - -The following three attributes can be used only in an aggregate project: - -@table @asis -@item @b{Project_Files}: -@cindex @code{Project_Files} - -This attribute is compulsory (or else we are not aggregating any project, -and thus not doing anything). It specifies a list of @file{.gpr} files -that are grouped in the aggregate. The list may be empty. The project -files can be either other aggregate projects, or standard projects. When -grouping standard projects, you can have both the root of a project tree -(and you do not need to specify all its imported projects), and any project -within the tree. - -Basically, the idea is to specify all those projects that have -main programs you want to build and link, or libraries you want to -build. You can even specify projects that do not use the Main -attribute nor the @code{Library_*} attributes, and the result will be to -build all their source files (not just the ones needed by other -projects). - -The file can include paths (absolute or relative). Paths are relative to -the location of the aggregate project file itself (if you use a base name, -we expect to find the .gpr file in the same directory as the aggregate -project file). The environment variables @code{ADA_PROJECT_PATH}, -@code{GPR_PROJECT_PATH} and @code{GPR_PROJECT_PATH_FILE} are not used to find -the project files. The extension @file{.gpr} is mandatory, since this attribute -contains file names, not project names. - -Paths can also include the @code{"*"} and @code{"**"} globbing patterns. The -latter indicates that any subdirectory (recursively) will be -searched for matching files. The latter (@code{"**"}) can only occur at the -last position in the directory part (ie @code{"a/**/*.gpr"} is supported, but -not @code{"**/a/*.gpr"}). Starting the pattern with @code{"**"} is equivalent -to starting with @code{"./**"}. - -For now, the pattern @code{"*"} is only allowed in the filename part, not -in the directory part. This is mostly for efficiency reasons to limit the -number of system calls that are needed. - -Here are a few valid examples: - -@smallexample @c projectfile - @b{for} Project_Files @b{use} ("a.gpr", "subdir/b.gpr"); - --@i{ two specific projects relative to the directory of agg.gpr} - - @b{for} Project_Files @b{use} ("**/*.gpr"); - --@i{ all projects recursively} -@end smallexample - -@item @b{Project_Path}: -@cindex @code{Project_Path} - -This attribute can be used to specify a list of directories in -which to look for project files in @code{with} declarations. - -When you specify a project in Project_Files (say @code{x/y/a.gpr}), and -@code{a.gpr} imports a project @code{b.gpr}, only @code{b.gpr} is searched in -the project path. @code{a.gpr} must be exactly at -@code{<dir of the aggregate>/x/y/a.gpr}. - -This attribute, however, does not affect the search for the aggregated -project files specified with @code{Project_Files}. - -Each aggregate project has its own @code{Project_Path} (that is if -@code{agg1.gpr} includes @code{agg2.gpr}, they can potentially both have a -different @code{Project_Path}). - -This project path is defined as the concatenation, in that order, of: - -@itemize @bullet -@item the current directory; -@item followed by the command line -aP switches; -@item then the directories from the GPR_PROJECT_PATH and ADA_PROJECT_PATH environment -variables; -@item then the directories from the Project_Path attribute; -@item and finally the predefined directories. -@end itemize - -In the example above, agg2.gpr's project path is not influenced by -the attribute agg1'Project_Path, nor is agg1 influenced by -agg2'Project_Path. - -This can potentially lead to errors. In the following example: - -@smallexample - +---------------+ +----------------+ - | Agg1.gpr |-=--includes--=-->| Agg2.gpr | - | 'project_path| | 'project_path | - | | | | - +---------------+ +----------------+ - : : - includes includes - : : - v v - +-------+ +---------+ - | P.gpr |<---------- withs --------| Q.gpr | - +-------+---------\ +---------+ - | | - withs | - | | - v v - +-------+ +---------+ - | R.gpr | | R'.gpr | - +-------+ +---------+ -@end smallexample - -When looking for p.gpr, both aggregates find the same physical file on -the disk. However, it might happen that with their different project -paths, both aggregate projects would in fact find a different r.gpr. -Since we have a common project (p.gpr) "with"ing two different r.gpr, -this will be reported as an error by the builder. - -Directories are relative to the location of the aggregate project file. - -Example: - -@smallexample @c projectfile - @b{for} Project_Path @b{use} ("/usr/local/gpr", "gpr/"); -@end smallexample - -@item @b{External}: -@cindex @code{External} - -This attribute can be used to set the value of environment -variables as retrieved through the @code{external} function -in projects. It does not affect the environment variables -themselves (so for instance you cannot use it to change the value -of your PATH as seen from the spawned compiler). - -This attribute affects the external values as seen in the rest of -the aggregate project, and in the aggregated projects. - -The exact value of external a variable comes from one of three -sources (each level overrides the previous levels): - -@itemize @bullet -@item An External attribute in aggregate project, for instance - @code{for External ("BUILD_MODE") use "DEBUG"}; - -@item Environment variables - -These override the value given by the attribute, so that -users can override the value set in the (presumably shared -with others team members) aggregate project. - -@item The -X command line switch to @command{gprbuild} - -This always takes precedence. - -@end itemize - -This attribute is only taken into account in the main aggregate -project (i.e. the one specified on the command line to @command{gprbuild}), -and ignored in other aggregate projects. It is invalid -in standard projects. -The goal is to have a consistent value in all -projects that are built through the aggregate, which would not -be the case in the diamond case: A groups the aggregate -projects B and C, which both (either directly or indirectly) -build the project P. If B and C could set different values for -the environment variables, we would have two different views of -P, which in particular might impact the list of source files in P. - -@end table - -@c ---------------------------------------------- -@node package Builder in aggregate projects -@subsection package Builder in aggregate projects -@c ---------------------------------------------- - -As we mentioned before, only the package Builder can be specified in -an aggregate project. In this package, only the following attributes -are valid: - -@table @asis -@item @b{Switches}: -@cindex @code{Switches} -This attribute gives the list of switches to use for @command{gprbuild}. -Because no mains can be specified for aggregate projects, the only possible -index for attribute @code{Switches} is @code{others}. All other indexes will -be ignored. - -Example: - -@smallexample @c projectfile -@b{for} Switches (@b{others}) @b{use} ("-v", "-k", "-j8"); -@end smallexample - -These switches are only read from the main aggregate project (the -one passed on the command line), and ignored in all other aggregate -projects or projects. - -It can only contain builder switches, not compiler switches. - -@item @b{Global_Compilation_Switches} -@cindex @code{Global_Compilation_Switches} - -This attribute gives the list of compiler switches for the various -languages. For instance, - -@smallexample @c projectfile -@b{for} Global_Compilation_Switches ("Ada") @b{use} ("O1", "-g"); -@b{for} Global_Compilation_Switches ("C") @b{use} ("-O2"); -@end smallexample - -This attribute is only taken into account in the aggregate project -specified on the command line, not in other aggregate projects. - -In the projects grouped by that aggregate, the attribute -Builder.Global_Compilation_Switches is also ignored. However, the -attribute Compiler.Default_Switches will be taken into account (but -that of the aggregate have higher priority). The attribute -Compiler.Switches is also taken into account and can be used to -override the switches for a specific file. As a result, it always -has priority. - -The rules are meant to avoid ambiguities when compiling. For -instance, aggregate project Agg groups the projects A and B, that -both depend on C. Here is an extra for all of these projects: - -@smallexample @c projectfile - aggregate @b{project} Agg @b{is} - @b{for} Project_Files @b{use} ("a.gpr", "b.gpr"); - @b{package} Builder @b{is} - @b{for} Global_Compilation_Switches ("Ada") @b{use} ("-O2"); - @b{end} Builder; - @b{end} Agg; - - @b{with} "c.gpr"; - @b{project} A @b{is} - @b{package} Builder @b{is} - @b{for} Global_Compilation_Switches ("Ada") @b{use} ("-O1"); - --@i{ ignored} - @b{end} Builder; - - @b{package} Compiler @b{is} - @b{for} Default_Switches ("Ada") - @b{use} ("-O1", "-g"); - @b{for} Switches ("a_file1.adb") - @b{use} ("-O0"); - @b{end} Compiler; - @b{end} A; - - @b{with} "c.gpr"; - @b{project} B @b{is} - @b{package} Compiler @b{is} - @b{for} Default_Switches ("Ada") @b{use} ("-O0"); - @b{end} Compiler; - @b{end} B; - - @b{project} C @b{is} - @b{package} Compiler @b{is} - @b{for} Default_Switches ("Ada") - @b{use} ("-O3", - "-gnatn"); - @b{for} Switches ("c_file1.adb") - @b{use} ("-O0", "-g"); - @b{end} Compiler; - @b{end} C; -@end smallexample - -then the following switches are used: - -@itemize @bullet -@item all files from project A except a_file1.adb are compiled - with "-O2 -g", since the aggregate project has priority. -@item the file a_file1.adb is compiled with - "-O0", since the Compiler.Switches has priority -@item all files from project B are compiled with - "-O2", since the aggregate project has priority -@item all files from C are compiled with "-O2 -gnatn", except for - c_file1.adb which is compiled with "-O0 -g" -@end itemize - -Even though C is seen through two paths (through A and through -B), the switches used by the compiler are unambiguous. - -@item @b{Global_Configuration_Pragmas} -@cindex @code{Global_Configuration_Pragmas} - -This attribute can be used to specify a file containing -configuration pragmas, to be passed to the Ada compiler. Since we -ignore the package Builder in other aggregate projects and projects, -only those pragmas defined in the main aggregate project will be -taken into account. - -Projects can locally add to those by using the -@code{Compiler.Local_Configuration_Pragmas} attribute if they need. - -@item @b{Global_Config_File} -@cindex @code{Global_Config_File} - -This attribute, indexed with a language name, can be used to specify a config -when compiling sources of the language. For Ada, these files are configuration -pragmas files. - -@end table - -For projects that are built through the aggregate, the package Builder -is ignored, except for the Executable attribute which specifies the -name of the executables resulting from the link of the main programs, and -for the Executable_Suffix. - -@c --------------------------------------------- -@node Aggregate Library Projects -@section Aggregate Library Projects -@c --------------------------------------------- - -@noindent - -Aggregate library projects make it possible to build a single library -using object files built using other standard or library -projects. This gives the flexibility to describe an application as -having multiple modules (a GUI, database access, ...) using different -project files (so possibly built with different compiler options) and -yet create a single library (static or relocatable) out of the -corresponding object files. - -@menu -* Building aggregate library projects:: -* Syntax of aggregate library projects:: -@end menu - -@c --------------------------------------------- -@node Building aggregate library projects -@subsection Building aggregate library projects -@c --------------------------------------------- - -For example, we can define an aggregate project Agg that groups A, B -and C: - -@smallexample @c projectfile - aggregate library @b{project} Agg @b{is} - @b{for} Project_Files @b{use} ("a.gpr", "b.gpr", "c.gpr"); - @b{for} Library_Name @b{use} ("agg"); - @b{for} Library_Dir @b{use} ("lagg"); - @b{end} Agg; -@end smallexample - -Then, when you build with: - -@smallexample - gprbuild agg.gpr -@end smallexample - -This will build all units from projects A, B and C and will create a -static library named @file{libagg.a} in the @file{lagg} -directory. An aggregate library project has the same set of -restriction as a standard library project. - -Note that a shared aggregate library project cannot aggregate a -static library project. In platforms where a compiler option is -required to create relocatable object files, a Builder package in the -aggregate library project may be used: - -@smallexample @c projectfile - aggregate library @b{project} Agg @b{is} - @b{for} Project_Files @b{use} ("a.gpr", "b.gpr", "c.gpr"); - @b{for} Library_Name @b{use} ("agg"); - @b{for} Library_Dir @b{use} ("lagg"); - @b{for} Library_Kind @b{use} "relocatable"; - - @b{package} Builder @b{is} - @b{for} Global_Compilation_Switches ("Ada") @b{use} ("-fPIC"); - @b{end} Builder; - @b{end} Agg; -@end smallexample - -With the above aggregate library Builder package, the @code{-fPIC} -option will be passed to the compiler when building any source code -from projects @file{a.gpr}, @file{b.gpr} and @file{c.gpr}. - -@c --------------------------------------------- -@node Syntax of aggregate library projects -@subsection Syntax of aggregate library projects -@c --------------------------------------------- - -An aggregate library project follows the general syntax of project -files. The recommended extension is still @file{.gpr}. However, a special -@code{aggregate library} qualifier must be put before the keyword -@code{project}. - -An aggregate library project cannot @code{with} any other project -(standard or aggregate), except an abstract project which can be used -to share attribute values. - -An aggregate library project does not have any source files directly (only -through other standard projects). Therefore a number of the standard -attributes and packages are forbidden in an aggregate library -project. Here is the (non exhaustive) list: - -@itemize @bullet -@item Languages -@item Source_Files, Source_List_File and other attributes dealing with - list of sources. -@item Source_Dirs, Exec_Dir and Object_Dir -@item Main -@item Roots -@item Externally_Built -@item Inherit_Source_Path -@item Excluded_Source_Dirs -@item Locally_Removed_Files -@item Excluded_Source_Files -@item Excluded_Source_List_File -@item Interfaces -@end itemize - -The only package that is authorized (albeit optional) is Builder. - -The Project_Files attribute (See @pxref{Aggregate Projects}) is used to -described the aggregated projects whose object files have to be -included into the aggregate library. The environment variables -@code{ADA_PROJECT_PATH}, @code{GPR_PROJECT_PATH} and -@code{GPR_PROJECT_PATH_FILE} are not used to find the project files. - -@c --------------------------------------------- -@node Project File Reference -@section Project File Reference -@c --------------------------------------------- - -@noindent -This section describes the syntactic structure of project files, the various -constructs that can be used. Finally, it ends with a summary of all available -attributes. - -@menu -* Project Declaration:: -* Qualified Projects:: -* Declarations:: -* Packages:: -* Expressions:: -* External Values:: -* Typed String Declaration:: -* Variables:: -* Case Constructions:: -* Attributes:: -@end menu - -@c --------------------------------------------- -@node Project Declaration -@subsection Project Declaration -@c --------------------------------------------- - -@noindent -Project files have an Ada-like syntax. The minimal project file is: - -@smallexample @c projectfile -@group -@b{project} Empty @b{is} -@b{end} Empty; -@end group -@end smallexample - -@noindent -The identifier @code{Empty} is the name of the project. -This project name must be present after the reserved -word @code{end} at the end of the project file, followed by a semi-colon. - -@b{Identifiers} (i.e.@: the user-defined names such as project or variable names) -have the same syntax as Ada identifiers: they must start with a letter, -and be followed by zero or more letters, digits or underscore characters; -it is also illegal to have two underscores next to each other. Identifiers -are always case-insensitive ("Name" is the same as "name"). - -@smallexample -simple_name ::= identifier -name ::= simple_name @{ . simple_name @} -@end smallexample - -@noindent -@b{Strings} are used for values of attributes or as indexes for these -attributes. They are in general case sensitive, except when noted -otherwise (in particular, strings representing file names will be case -insensitive on some systems, so that "file.adb" and "File.adb" both -represent the same file). - -@b{Reserved words} are the same as for standard Ada 95, and cannot -be used for identifiers. In particular, the following words are currently -used in project files, but others could be added later on. In bold are the -extra reserved words in project files: @code{all, at, case, end, for, is, -limited, null, others, package, renames, type, use, when, with, @b{extends}, -@b{external}, @b{project}}. - -@b{Comments} in project files have the same syntax as in Ada, two consecutive -hyphens through the end of the line. - -A project may be an @b{independent project}, entirely defined by a single -project file. Any source file in an independent project depends only -on the predefined library and other source files in the same project. -But a project may also depend on other projects, either by importing them -through @b{with clauses}, or by @b{extending} at most one other project. Both -types of dependency can be used in the same project. - -A path name denotes a project file. It can be absolute or relative. -An absolute path name includes a sequence of directories, in the syntax of -the host operating system, that identifies uniquely the project file in the -file system. A relative path name identifies the project file, relative -to the directory that contains the current project, or relative to a -directory listed in the environment variables ADA_PROJECT_PATH and -GPR_PROJECT_PATH. Path names are case sensitive if file names in the host -operating system are case sensitive. As a special case, the directory -separator can always be "/" even on Windows systems, so that project files -can be made portable across architectures. -The syntax of the environment variables ADA_PROJECT_PATH and -GPR_PROJECT_PATH is a list of directory names separated by colons on UNIX and -semicolons on Windows. - -A given project name can appear only once in a context clause. - -It is illegal for a project imported by a context clause to refer, directly -or indirectly, to the project in which this context clause appears (the -dependency graph cannot contain cycles), except when one of the with clauses -in the cycle is a @b{limited with}. -@c ??? Need more details here - -@smallexample @c projectfile -@b{with} "other_project.gpr"; -@b{project} My_Project @b{extends} "extended.gpr" @b{is} -@b{end} My_Project; -@end smallexample - -@noindent -These dependencies form a @b{directed graph}, potentially cyclic when using -@b{limited with}. The subgraph reflecting the @b{extends} relations is a tree. - -A project's @b{immediate sources} are the source files directly defined by -that project, either implicitly by residing in the project source directories, -or explicitly through any of the source-related attributes. -More generally, a project's @b{sources} are the immediate sources of the -project together with the immediate sources (unless overridden) of any project -on which it depends directly or indirectly. - -A @b{project hierarchy} can be created, where projects are children of -other projects. The name of such a child project must be @code{Parent.Child}, -where @code{Parent} is the name of the parent project. In particular, this -makes all @code{with} clauses of the parent project automatically visible -in the child project. - -@smallexample -project ::= context_clause project_declaration - -context_clause ::= @{with_clause@} -with_clause ::= @i{with} path_name @{ , path_name @} ; -path_name ::= string_literal - -project_declaration ::= simple_project_declaration | project_extension -simple_project_declaration ::= - @i{project} @i{<project_>}name @i{is} - @{declarative_item@} - @i{end} <project_>simple_name; -@end smallexample - -@c --------------------------------------------- -@node Qualified Projects -@subsection Qualified Projects -@c --------------------------------------------- - -@noindent -Before the reserved @code{project}, there may be one or two @b{qualifiers}, that -is identifiers or reserved words, to qualify the project. -The current list of qualifiers is: - -@table @asis -@item @b{abstract}: qualifies a project with no sources. Such a - project must either have no declaration of attributes @code{Source_Dirs}, - @code{Source_Files}, @code{Languages} or @code{Source_List_File}, or one of - @code{Source_Dirs}, @code{Source_Files}, or @code{Languages} must be declared - as empty. If it extends another project, the project it extends must also be a - qualified abstract project. -@item @b{standard}: a standard project is a non library project with sources. - This is the default (implicit) qualifier. -@item @b{aggregate}: a project whose sources are aggregated from other -project files. -@item @b{aggregate library}: a library whose sources are aggregated -from other project or library project files. -@item @b{library}: a library project must declare both attributes - @code{Library_Name} and @code{Library_Dir}. -@item @b{configuration}: a configuration project cannot be in a project tree. - It describes compilers and other tools to @command{gprbuild}. -@end table - -@c --------------------------------------------- -@node Declarations -@subsection Declarations -@c --------------------------------------------- - -@noindent -Declarations introduce new entities that denote types, variables, attributes, -and packages. Some declarations can only appear immediately within a project -declaration. Others can appear within a project or within a package. - -@smallexample -declarative_item ::= simple_declarative_item - | typed_string_declaration - | package_declaration - -simple_declarative_item ::= variable_declaration - | typed_variable_declaration - | attribute_declaration - | case_construction - | empty_declaration - -empty_declaration ::= @i{null} ; -@end smallexample - -@noindent -An empty declaration is allowed anywhere a declaration is allowed. It has -no effect. - -@c --------------------------------------------- -@node Packages -@subsection Packages -@c --------------------------------------------- - -@noindent -A project file may contain @b{packages}, that group attributes (typically -all the attributes that are used by one of the GNAT tools). - -A package with a given name may only appear once in a project file. -The following packages are currently supported in project files -(See @pxref{Attributes} for the list of attributes that each can contain). - -@table @code -@item Binder - This package specifies characteristics useful when invoking the binder either - directly via the @command{gnat} driver or when using a builder such as - @command{gnatmake} or @command{gprbuild}. @xref{Main Subprograms}. -@item Builder - This package specifies the compilation options used when building an - executable or a library for a project. Most of the options should be - set in one of @code{Compiler}, @code{Binder} or @code{Linker} packages, - but there are some general options that should be defined in this - package. @xref{Main Subprograms}, and @pxref{Executable File Names} in - particular. -@ifclear FSFEDITION -@item Check - This package specifies the options used when calling the checking tool - @command{gnatcheck} via the @command{gnat} driver. Its attribute - @b{Default_Switches} has the same semantics as for the package - @code{Builder}. The first string should always be @code{-rules} to specify - that all the other options belong to the @code{-rules} section of the - parameters to @command{gnatcheck}. -@end ifclear -@item Clean - This package specifies the options used when cleaning a project or a project - tree using the tools @command{gnatclean} or @command{gprclean}. -@item Compiler - This package specifies the compilation options used by the compiler for - each languages. @xref{Tools Options in Project Files}. -@item Cross_Reference - This package specifies the options used when calling the library tool - @command{gnatxref} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{Switches} have the same semantics as for the - package @code{Builder}. -@ifclear FSFEDITION -@item Eliminate - This package specifies the options used when calling the tool - @command{gnatelim} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{Switches} have the same semantics as for the - package @code{Builder}. -@end ifclear -@item Finder - This package specifies the options used when calling the search tool - @command{gnatfind} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{Switches} have the same semantics as for the - package @code{Builder}. -@item Gnatls - This package specifies the options to use when invoking @command{gnatls} - via the @command{gnat} driver. -@ifclear FSFEDITION -@item Gnatstub - This package specifies the options used when calling the tool - @command{gnatstub} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{Switches} have the same semantics as for the - package @code{Builder}. -@end ifclear -@item IDE - This package specifies the options used when starting an integrated - development environment, for instance @command{GPS} or @command{Gnatbench}. -@item Install - This package specifies the options used when installing a project - with @command{gprinstall}. @xref{Installation}. -@item Linker - This package specifies the options used by the linker. - @xref{Main Subprograms}. -@ifclear FSFEDITION -@item Metrics - This package specifies the options used when calling the tool - @command{gnatmetric} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{Switches} have the same semantics as for the - package @code{Builder}. -@end ifclear -@item Naming - This package specifies the naming conventions that apply - to the source files in a project. In particular, these conventions are - used to automatically find all source files in the source directories, - or given a file name to find out its language for proper processing. - @xref{Naming Schemes}. -@ifclear FSFEDITION -@item Pretty_Printer - This package specifies the options used when calling the formatting tool - @command{gnatpp} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{Switches} have the same semantics as for the - package @code{Builder}. -@end ifclear -@item Remote - This package is used by @command{gprbuild} to describe how distributed - compilation should be done. -@item Stack - This package specifies the options used when calling the tool - @command{gnatstack} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{Switches} have the same semantics as for the - package @code{Builder}. -@item Synchronize - This package specifies the options used when calling the tool - @command{gnatsync} via the @command{gnat} driver. - -@end table - -In its simplest form, a package may be empty: - -@smallexample @c projectfile -@group -@b{project} Simple @b{is} - @b{package} Builder @b{is} - @b{end} Builder; -@b{end} Simple; -@end group -@end smallexample - -@noindent -A package may contain @b{attribute declarations}, -@b{variable declarations} and @b{case constructions}, as will be -described below. - -When there is ambiguity between a project name and a package name, -the name always designates the project. To avoid possible confusion, it is -always a good idea to avoid naming a project with one of the -names allowed for packages or any name that starts with @code{gnat}. - -A package can also be defined by a @b{renaming declaration}. The new package -renames a package declared in a different project file, and has the same -attributes as the package it renames. The name of the renamed package -must be the same as the name of the renaming package. The project must -contain a package declaration with this name, and the project -must appear in the context clause of the current project, or be its parent -project. It is not possible to add or override attributes to the renaming -project. If you need to do so, you should use an @b{extending declaration} -(see below). - -Packages that are renamed in other project files often come from project files -that have no sources: they are just used as templates. Any modification in the -template will be reflected automatically in all the project files that rename -a package from the template. This is a very common way to share settings -between projects. - -Finally, a package can also be defined by an @b{extending declaration}. This is -similar to a @b{renaming declaration}, except that it is possible to add or -override attributes. - -@smallexample -package_declaration ::= package_spec | package_renaming | package_extension -package_spec ::= - @i{package} @i{<package_>}simple_name @i{is} - @{simple_declarative_item@} - @i{end} package_identifier ; -package_renaming ::== - @i{package} @i{<package_>}simple_name @i{renames} @i{<project_>}simple_name.package_identifier ; -package_extension ::== - @i{package} @i{<package_>}simple_name @i{extends} @i{<project_>}simple_name.package_identifier @i{is} - @{simple_declarative_item@} - @i{end} package_identifier ; -@end smallexample - -@c --------------------------------------------- -@node Expressions -@subsection Expressions -@c --------------------------------------------- - -@noindent -An expression is any value that can be assigned to an attribute or a -variable. It is either a literal value, or a construct requiring runtime -computation by the project manager. In a project file, the computed value of -an expression is either a string or a list of strings. - -A string value is one of: -@itemize @bullet -@item A literal string, for instance @code{"comm/my_proj.gpr"} -@item The name of a variable that evaluates to a string (@pxref{Variables}) -@item The name of an attribute that evaluates to a string (@pxref{Attributes}) -@item An external reference (@pxref{External Values}) -@item A concatenation of the above, as in @code{"prefix_" & Var}. - -@end itemize - -@noindent -A list of strings is one of the following: - -@itemize @bullet -@item A parenthesized comma-separated list of zero or more string expressions, for - instance @code{(File_Name, "gnat.adc", File_Name & ".orig")} or @code{()}. -@item The name of a variable that evaluates to a list of strings -@item The name of an attribute that evaluates to a list of strings -@item A concatenation of a list of strings and a string (as defined above), for - instance @code{("A", "B") & "C"} -@item A concatenation of two lists of strings - -@end itemize - -@noindent -The following is the grammar for expressions - -@smallexample -string_literal ::= "@{string_element@}" -- Same as Ada -string_expression ::= string_literal - | @i{variable_}name - | external_value - | attribute_reference - | ( string_expression @{ & string_expression @} ) -string_list ::= ( string_expression @{ , string_expression @} ) - | @i{string_variable}_name - | @i{string_}attribute_reference -term ::= string_expression | string_list -expression ::= term @{ & term @} -- Concatenation -@end smallexample - -@noindent -Concatenation involves strings and list of strings. As soon as a list of -strings is involved, the result of the concatenation is a list of strings. The -following Ada declarations show the existing operators: - -@smallexample @c ada - @b{function} "&" (X : String; Y : String) @b{return} String; - @b{function} "&" (X : String_List; Y : String) @b{return} String_List; - @b{function} "&" (X : String_List; Y : String_List) @b{return} String_List; -@end smallexample - -@noindent -Here are some specific examples: - -@smallexample @c projectfile -@group - List := () & File_Name; --@i{ One string in this list} - List2 := List & (File_Name & ".orig"); --@i{ Two strings} - Big_List := List & Lists2; --@i{ Three strings} - Illegal := "gnat.adc" & List2; --@i{ Illegal, must start with list} -@end group -@end smallexample - -@c --------------------------------------------- -@node External Values -@subsection External Values -@c --------------------------------------------- - -@noindent -An external value is an expression whose value is obtained from the command -that invoked the processing of the current project file (typically a -@command{gnatmake} or @command{gprbuild} command). - -There are two kinds of external values, one that returns a single string, and -one that returns a string list. - -The syntax of a single string external value is: - -@smallexample -external_value ::= @i{external} ( string_literal [, string_literal] ) -@end smallexample - -@noindent -The first string_literal is the string to be used on the command line or -in the environment to specify the external value. The second string_literal, -if present, is the default to use if there is no specification for this -external value either on the command line or in the environment. - -Typically, the external value will either exist in the -environment variables -or be specified on the command line through the -@option{-X@emph{vbl}=@emph{value}} switch. If both -are specified, then the command line value is used, so that a user can more -easily override the value. - -The function @code{external} always returns a string. It is an error if the -value was not found in the environment and no default was specified in the -call to @code{external}. - -An external reference may be part of a string expression or of a string -list expression, and can therefore appear in a variable declaration or -an attribute declaration. - -Most of the time, this construct is used to initialize typed variables, which -are then used in @b{case} constructions to control the value assigned to -attributes in various scenarios. Thus such variables are often called -@b{scenario variables}. - -The syntax for a string list external value is: - -@smallexample -external_value ::= @i{external_as_list} ( string_literal , string_literal ) -@end smallexample - -@noindent -The first string_literal is the string to be used on the command line or -in the environment to specify the external value. The second string_literal is -the separator between each component of the string list. - -If the external value does not exist in the environment or on the command line, -the result is an empty list. This is also the case, if the separator is an -empty string or if the external value is only one separator. - -Any separator at the beginning or at the end of the external value is -discarded. Then, if there is no separator in the external value, the result is -a string list with only one string. Otherwise, any string between the beginning -and the first separator, between two consecutive separators and between the -last separator and the end are components of the string list. - -@smallexample - @i{external_as_list} ("SWITCHES", ",") -@end smallexample - -@noindent -If the external value is "-O2,-g", -the result is ("-O2", "-g"). - -If the external value is ",-O2,-g,", -the result is also ("-O2", "-g"). - -if the external value is "-gnatv", -the result is ("-gnatv"). - -If the external value is ",,", the result is (""). - -If the external value is ",", the result is (), the empty string list. - -@c --------------------------------------------- -@node Typed String Declaration -@subsection Typed String Declaration -@c --------------------------------------------- - -@noindent -A @b{type declaration} introduces a discrete set of string literals. -If a string variable is declared to have this type, its value -is restricted to the given set of literals. These are the only named -types in project files. A string type may only be declared at the project -level, not inside a package. - -@smallexample -typed_string_declaration ::= - @i{type} @i{<typed_string_>}_simple_name @i{is} ( string_literal @{, string_literal@} ); -@end smallexample - -@noindent -The string literals in the list are case sensitive and must all be different. -They may include any graphic characters allowed in Ada, including spaces. -Here is an example of a string type declaration: - -@smallexample @c projectfile - @b{type} OS @b{is} ("NT", "nt", "Unix", "GNU/Linux", "other OS"); -@end smallexample - -@noindent -Variables of a string type are called @b{typed variables}; all other -variables are called @b{untyped variables}. Typed variables are -particularly useful in @code{case} constructions, to support conditional -attribute declarations. (@pxref{Case Constructions}). - -A string type may be referenced by its name if it has been declared in the same -project file, or by an expanded name whose prefix is the name of the project -in which it is declared. - -@c --------------------------------------------- -@node Variables -@subsection Variables -@c --------------------------------------------- - -@noindent -@b{Variables} store values (strings or list of strings) and can appear -as part of an expression. The declaration of a variable creates the -variable and assigns the value of the expression to it. The name of the -variable is available immediately after the assignment symbol, if you -need to reuse its old value to compute the new value. Before the completion -of its first declaration, the value of a variable defaults to the empty -string (""). - -A @b{typed} variable can be used as part of a @b{case} expression to -compute the value, but it can only be declared once in the project file, -so that all case constructions see the same value for the variable. This -provides more consistency and makes the project easier to understand. -The syntax for its declaration is identical to the Ada syntax for an -object declaration. In effect, a typed variable acts as a constant. - -An @b{untyped} variable can be declared and overridden multiple times -within the same project. It is declared implicitly through an Ada -assignment. The first declaration establishes the kind of the variable -(string or list of strings) and successive declarations must respect -the initial kind. Assignments are executed in the order in which they -appear, so the new value replaces the old one and any subsequent reference -to the variable uses the new value. - -A variable may be declared at the project file level, or within a package. - -@smallexample -typed_variable_declaration ::= - @i{<typed_variable_>}simple_name : @i{<typed_string_>}name := string_expression; -variable_declaration ::= @i{<variable_>}simple_name := expression; -@end smallexample - -@noindent -Here are some examples of variable declarations: - -@smallexample @c projectfile -@group - This_OS : OS := @b{external} ("OS"); --@i{ a typed variable declaration} - That_OS := "GNU/Linux"; --@i{ an untyped variable declaration} - - Name := "readme.txt"; - Save_Name := Name & ".saved"; - - Empty_List := (); - List_With_One_Element := ("-gnaty"); - List_With_Two_Elements := List_With_One_Element & "-gnatg"; - Long_List := ("main.ada", "pack1_.ada", "pack1.ada", "pack2_.ada"); -@end group -@end smallexample - -@noindent -A @b{variable reference} may take several forms: - -@itemize @bullet -@item The simple variable name, for a variable in the current package (if any) - or in the current project -@item An expanded name, whose prefix is a context name. - -@end itemize - -@noindent -A @b{context} may be one of the following: - -@itemize @bullet -@item The name of an existing package in the current project -@item The name of an imported project of the current project -@item The name of an ancestor project (i.e., a project extended by the current - project, either directly or indirectly) -@item An expanded name whose prefix is an imported/parent project name, and - whose selector is a package name in that project. -@end itemize - -@c --------------------------------------------- -@node Case Constructions -@subsection Case Constructions -@c --------------------------------------------- - -@noindent -A @b{case} construction is used in a project file to effect conditional -behavior. Through this construction, you can set the value of attributes -and variables depending on the value previously assigned to a typed -variable. - -All choices in a choice list must be distinct. Unlike Ada, the choice -lists of all alternatives do not need to include all values of the type. -An @code{others} choice must appear last in the list of alternatives. - -The syntax of a @code{case} construction is based on the Ada case construction -(although the @code{null} declaration for empty alternatives is optional). - -The case expression must be a string variable, either typed or not, whose value -is often given by an external reference (@pxref{External Values}). - -Each alternative starts with the reserved word @code{when}, either a list of -literal strings separated by the @code{"|"} character or the reserved word -@code{others}, and the @code{"=>"} token. -When the case expression is a typed string variable, each literal string must -belong to the string type that is the type of the case variable. -After each @code{=>}, there are zero or more declarations. The only -declarations allowed in a case construction are other case constructions, -attribute declarations and variable declarations. String type declarations and -package declarations are not allowed. Variable declarations are restricted to -variables that have already been declared before the case construction. - -@smallexample -case_construction ::= - @i{case} @i{<variable_>}name @i{is} @{case_item@} @i{end case} ; - -case_item ::= - @i{when} discrete_choice_list => - @{case_declaration - | attribute_declaration - | variable_declaration - | empty_declaration@} - -discrete_choice_list ::= string_literal @{| string_literal@} | @i{others} -@end smallexample - -@noindent -Here is a typical example, with a typed string variable: - -@smallexample @c projectfile -@group -@b{project} MyProj @b{is} - @b{type} OS_Type @b{is} ("GNU/Linux", "Unix", "NT", "VMS"); - OS : OS_Type := @b{external} ("OS", "GNU/Linux"); - - @b{package} Compiler @b{is} - @b{case} OS @b{is} - @b{when} "GNU/Linux" | "Unix" => - @b{for} Switches ("Ada") - @b{use} ("-gnath"); - @b{when} "NT" => - @b{for} Switches ("Ada") - @b{use} ("-gnatP"); - @b{when} @b{others} => - @b{null}; - @b{end} @b{case}; - @b{end} Compiler; -@b{end} MyProj; -@end group -@end smallexample - -@c --------------------------------------------- -@node Attributes -@subsection Attributes -@c --------------------------------------------- - -@menu -* Project Level Attributes:: -* Package Binder Attributes:: -* Package Builder Attributes:: -@ifclear FSFEDITION -* Package Check Attributes:: -@end ifclear -* Package Clean Attributes:: -* Package Compiler Attributes:: -* Package Cross_Reference Attributes:: -@ifclear FSFEDITION -* Package Eliminate Attributes:: -@end ifclear -* Package Finder Attributes:: -* Package gnatls Attributes:: -@ifclear FSFEDITION -* Package gnatstub Attributes:: -@end ifclear -* Package IDE Attributes:: -* Package Install Attributes:: -* Package Linker Attributes:: -@ifclear FSFEDITION -* Package Metrics Attribute:: -@end ifclear -* Package Naming Attributes:: -@ifclear FSFEDITION -* Package Pretty_Printer Attributes:: -@end ifclear -* Package Remote Attributes:: -* Package Stack Attributes:: -* Package Synchronize Attributes:: -@end menu - -@noindent -A project (and its packages) may have @b{attributes} that define -the project's properties. Some attributes have values that are strings; -others have values that are string lists. - -@smallexample -attribute_declaration ::= - simple_attribute_declaration | indexed_attribute_declaration -simple_attribute_declaration ::= @i{for} attribute_designator @i{use} expression ; -indexed_attribute_declaration ::= - @i{for} @i{<indexed_attribute_>}simple_name ( string_literal) @i{use} expression ; -attribute_designator ::= - @i{<simple_attribute_>}simple_name - | @i{<indexed_attribute_>}simple_name ( string_literal ) -@end smallexample - -@noindent -There are two categories of attributes: @b{simple attributes} -and @b{indexed attributes}. -Each simple attribute has a default value: the empty string (for string -attributes) and the empty list (for string list attributes). -An attribute declaration defines a new value for an attribute, and overrides -the previous value. The syntax of a simple attribute declaration is similar to -that of an attribute definition clause in Ada. - -Some attributes are indexed. These attributes are mappings whose -domain is a set of strings. They are declared one association -at a time, by specifying a point in the domain and the corresponding image -of the attribute. -Like untyped variables and simple attributes, indexed attributes -may be declared several times. Each declaration supplies a new value for the -attribute, and replaces the previous setting. - -Here are some examples of attribute declarations: - -@smallexample @c projectfile - --@i{ simple attributes} - @b{for} Object_Dir @b{use} "objects"; - @b{for} Source_Dirs @b{use} ("units", "test/drivers"); - - --@i{ indexed attributes} - @b{for} Body ("main") @b{use} "Main.ada"; - @b{for} Switches ("main.ada") - @b{use} ("-v", "-gnatv"); - @b{for} Switches ("main.ada") @b{use} Builder'Switches ("main.ada") & "-g"; - - --@i{ indexed attributes copy (from package Builder in project Default)} - --@i{ The package name must always be specified, even if it is the current} - --@i{ package.} - @b{for} Default_Switches @b{use} Default.Builder'Default_Switches; -@end smallexample - -@noindent -Attributes references may appear anywhere in expressions, and are used -to retrieve the value previously assigned to the attribute. If an attribute -has not been set in a given package or project, its value defaults to the -empty string or the empty list, with some exceptions. - -@smallexample -attribute_reference ::= - attribute_prefix ' @i{<simple_attribute>_}simple_name [ (string_literal) ] -attribute_prefix ::= @i{project} - | @i{<project_>}simple_name - | package_identifier - | @i{<project_>}simple_name . package_identifier -@end smallexample - -@noindent -Examples are: - -@smallexample @c projectfile - @b{project}'Object_Dir - Naming'Dot_Replacement - Imported_Project'Source_Dirs - Imported_Project.Naming'Casing - Builder'Default_Switches ("Ada") -@end smallexample - -The exceptions to the empty defaults are: - -@itemize @bullet -@item Object_Dir: default is "." -@item Exec_Dir: default is 'Object_Dir, that is the value of attribute - Object_Dir in the same project, declared or defaulted. -@item Source_Dirs: default is (".") -@end itemize - -@noindent -The prefix of an attribute may be: - -@itemize @bullet -@item @code{project} for an attribute of the current project -@item The name of an existing package of the current project -@item The name of an imported project -@item The name of a parent project that is extended by the current project -@item An expanded name whose prefix is imported/parent project name, - and whose selector is a package name - -@end itemize - -@noindent - -In the following sections, all predefined attributes are succinctly described, -first the project level attributes, that is those attributes that are not in a -package, then the attributes in the different packages. - -It is possible for different tools to dynamically create new packages with -attributes, or new attributes in predefined packages. These attributes are -not documented here. - -The attributes under Configuration headings are usually found only in -configuration project files. - -The characteristics of each attribute are indicated as follows: - -@itemize @bullet - -@item @b{Type of value} - -The value of an attribute may be a single string, indicated by the word -"single", or a string list, indicated by the word "list". - -@item @b{Read-only} - -When the attribute is read-only, that is when it is not allowed to declare -the attribute, this is indicated by the words "read-only". - -@item @b{Optional index} - -If it is allowed in the value of the attribute (both single and list) to have -an optional index, this is indicated by the words "optional index". - -@item @b{Indexed attribute} - -When an it is an indexed attribute, this is indicated by the word "indexed". - -@item @b{Case-sensitivity of the index} - -For an indexed attribute, if the index is case-insensitive, this is indicated -by the words "case-insensitive index". - -@item @b{File name index} - -For an indexed attribute, when the index is a file name, this is indicated by -the words "file name index". The index may or may not be case-sensitive, -depending on the platform. - -@item @b{others allowed in index} - -For an indexed attribute, if it is allowed to use @b{others} as the index, -this is indicated by the words "others allowed". - -When @b{others} is used as the index of an indexed attribute, the value of -the attribute indexed by @b{others} is used when no other index would apply. - -@end itemize - -@node Project Level Attributes -@subsubsection Project Level Attributes -@noindent - -@itemize @bullet - -@item @b{General} - -@itemize @bullet - -@item @b{Name}: single, read-only - -The name of the project. - -@item @b{Project_Dir}: single, read-only - -The path name of the project directory. - -@item @b{Main}: list, optional index - -The list of main sources for the executables. - -@item @b{Languages}: list - -The list of languages of the sources of the project. - -@item @b{Roots}: list, indexed, file name index - -The index is the file name of an executable source. Indicates the list of units -from the main project that need to be bound and linked with their closures -with the executable. The index is either a file name, a language name or "*". -The roots for an executable source are those in @b{Roots} with an index that -is the executable source file name, if declared. Otherwise, they are those in -@b{Roots} with an index that is the language name of the executable source, -if present. Otherwise, they are those in @b{Roots ("*")}, if declared. If none -of these three possibilities are declared, then there are no roots for the -executable source. - -@item @b{Externally_Built}: single - -Indicates if the project is externally built. -Only case-insensitive values allowed are "true" and "false", the default. - -@end itemize -@noindent - -@item @b{Directories} - -@itemize @bullet - -@item @b{Object_Dir}: single - -Indicates the object directory for the project. - -@item @b{Exec_Dir}: single - -Indicates the exec directory for the project, that is the directory where the -executables are. - -@item @b{Source_Dirs}: list - -The list of source directories of the project. - -@item @b{Inherit_Source_Path}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of language names. Indicates that -in the source search path of the index language the source directories of -the languages in the list should be included. - -Example: - -for Inherit_Source_Path ("C++") use ("C"); - -@item @b{Exclude_Source_Dirs}: list - -The list of directories that are included in Source_Dirs but are not source -directories of the project. - -@item @b{Ignore_Source_Sub_Dirs}: list - -Value is a list of simple names for subdirectories that are removed from the -list of source directories, including theur subdirectories. - -@end itemize - -@item @b{Source Files} - -@itemize @bullet - -@item @b{Source_Files}: list - -Value is a list of source file simple names. - -@item @b{Locally_Removed_Files}: list - -Obsolescent. Equivalent to Excluded_Source_Files. - -@item @b{Excluded_Source_Files}: list - -Value is a list of simple file names that are not sources of the project. -Allows to remove sources that are inherited or found in the source directories -and that match the naming scheme. - -@item @b{Source_List_File}: single - -Value is a text file name that contains a list of source file simple names, -one on each line. - -@item @b{Excluded_Source_List_File}: single - -Value is a text file name that contains a list of file simple names that -are not sources of the project. - -@item @b{Interfaces}: list - -Value is a list of file names that constitutes the interfaces of the project. - -@end itemize - -@item @b{Aggregate Projects} - -@itemize @bullet - -@item @b{Project_Files}: list - -Value is the list of aggregated projects. - -@item @b{Project_Path}: list - -Value is a list of directories that are added to the project search path when -looking for the aggregated projects. - -@item @b{External}: single, indexed - -Index is the name of an external reference. Value is the value of the -external reference to be used when parsing the aggregated projects. - -@end itemize - -@item @b{Libraries} - -@itemize @bullet - -@item @b{Library_Dir}: single - -Value is the name of the library directory. This attribute needs to be -declared for each library project. - -@item @b{Library_Name}: single - -Value is the name of the library. This attribute needs to be declared or -inherited for each library project. - -@item @b{Library_Kind}: single - -Specifies the kind of library: static library (archive) or shared library. -Case-insensitive values must be one of "static" for archives (the default) or -"dynamic" or "relocatable" for shared libraries. - -@item @b{Library_Version}: single - -Value is the name of the library file. - -@item @b{Library_Interface}: list - -Value is the list of unit names that constitutes the interfaces -of a Stand-Alone Library project. - -@item @b{Library_Standalone}: single - -Specifies if a Stand-Alone Library (SAL) is encapsulated or not. -Only authorized case-insensitive values are "standard" for non encapsulated -SALs, "encapsulated" for encapsulated SALs or "no" for non SAL library project. - -@item @b{Library_Encapsulated_Options}: list - -Value is a list of options that need to be used when linking an encapsulated -Stand-Alone Library. - -@item @b{Library_Encapsulated_Supported}: single - -Indicates if encapsulated Stand-Alone Libraries are supported. Only -authorized case-insensitive values are "true" and "false" (the default). - -@item @b{Library_Auto_Init}: single - -Indicates if a Stand-Alone Library is auto-initialized. Only authorized -case-insentive values are "true" and "false". - -@item @b{Leading_Library_Options}: list - -Value is a list of options that are to be used at the beginning of -the command line when linking a shared library. - -@item @b{Library_Options}: list - -Value is a list of options that are to be used when linking a shared library. - -@item @b{Library_Rpath_Options}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of options for an invocation of the -compiler of the language. This invocation is done for a shared library project -with sources of the language. The output of the invocation is the path name -of a shared library file. The directory name is to be put in the run path -option switch when linking the shared library for the project. - -@item @b{Library_Src_Dir}: single - -Value is the name of the directory where copies of the sources of the -interfaces of a Stand-Alone Library are to be copied. - -@item @b{Library_ALI_Dir}: single - -Value is the name of the directory where the ALI files of the interfaces -of a Stand-Alone Library are to be copied. When this attribute is not declared, -the directory is the library directory. - -@item @b{Library_gcc}: single - -Obsolescent attribute. Specify the linker driver used to link a shared library. -Use instead attribute Linker'Driver. - -@item @b{Library_Symbol_File}: single - -Value is the name of the library symbol file. - -@item @b{Library_Symbol_Policy}: single - -Indicates the symbol policy kind. Only authorized case-insensitive values are -"autonomous", "default", "compliant", "controlled" or "direct". - -@item @b{Library_Reference_Symbol_File}: single - -Value is the name of the reference symbol file. - -@end itemize - -@item @b{Configuration - General} - -@itemize @bullet - -@item @b{Default_Language}: single - -Value is the case-insensitive name of the language of a project when attribute -Languages is not specified. - -@item @b{Run_Path_Option}: list - -Value is the list of switches to be used when specifying the run path option -in an executable. - -@item @b{Run_Path_Origin}: single - -Value is the string that may replace the path name of the executable -directory in the run path options. - -@item @b{Separate_Run_Path_Options}: single - -Indicates if there may be several run path options specified when linking an -executable. Only authorized case-insensitive values are "true" or "false" (the -default). - -@item @b{Toolchain_Version}: single, indexed, case-insensitive index - -Index is a language name. Specify the version of a toolchain for a language. - -@item @b{Toolchain_Description}: single, indexed, case-insensitive index - -Obsolescent. No longer used. - -@item @b{Object_Generated}: single, indexed, case-insensitive index - -Index is a language name. Indicates if invoking the compiler for a language -produces an object file. Only authorized case-insensitive values are "false" -and "true" (the default). - -@item @b{Objects_Linked}: single, indexed, case-insensitive index - -Index is a language name. Indicates if the object files created by the compiler -for a language need to be linked in the executable. Only authorized -case-insensitive values are "false" and "true" (the default). - -@item @b{Target}: single - -Value is the name of the target platform. Taken into account only in the main -project. - -@item @b{Runtime}: single, indexed, case-insensitive index - -Index is a language name. Indicates the runtime directory that is to be used -when using the compiler of the language. Taken into account only in the main -project. - -@end itemize - -@item @b{Configuration - Libraries} - -@itemize @bullet - -@item @b{Library_Builder}: single - -Value is the path name of the application that is to be used to build -libraries. Usually the path name of "gprlib". - -@item @b{Library_Support}: single - -Indicates the level of support of libraries. Only authorized case-insensitive -values are "static_only", "full" or "none" (the default). - -@end itemize - -@item @b{Configuration - Archives} - -@itemize @bullet - -@item @b{Archive_Builder}: list - -Value is the name of the application to be used to create a static library -(archive), followed by the options to be used. - -@item @b{Archive_Builder_Append_Option}: list - -Value is the list of options to be used when invoking the archive builder -to add project files into an archive. - -@item @b{Archive_Indexer}: list - -Value is the name of the archive indexer, followed by the required options. - -@item @b{Archive_Suffix}: single - -Value is the extension of archives. When not declared, the extension is ".a". - -@item @b{Library_Partial_Linker}: list - -Value is the name of the partial linker executable, followed by the required -options. - -@end itemize - -@item @b{Configuration - Shared Libraries} - -@itemize @bullet - -@item @b{Shared_Library_Prefix}: single - -Value is the prefix in the name of shared library files. When not declared, -the prefix is "lib". - -@item @b{Shared_Library_Suffix}: single - -Value is the extension of the name of shared library files. When not -declared, the extension is ".so". - -@item @b{Symbolic_Link_Supported}: single - -Indicates if symbolic links are supported on the platform. Only authorized -case-insensitive values are "true" and "false" (the default). - -@item @b{Library_Major_Minor_Id_Supported}: single - -Indicates if major and minor ids for shared library names are supported on -the platform. Only authorized case-insensitive values are "true" and "false" -(the default). - -@item @b{Library_Auto_Init_Supported}: single - -Indicates if auto-initialization of Stand-Alone Libraries is supported. Only -authorized case-insensitive values are "true" and "false" (the default). - -@item @b{Shared_Library_Minimum_Switches}: list - -Value is the list of required switches when linking a shared library. - -@item @b{Library_Version_Switches}: list - -Value is the list of switches to specify a internal name for a shared library. - -@item @b{Library_Install_Name_Option}: single - -Value is the name of the option that needs to be used, concatenated with the -path name of the library file, when linking a shared library. - -@item @b{Runtime_Library_Dir}: single, indexed, case-insensitive index - -Index is a language name. Value is the path name of the directory where the -runtime libraries are located. - -@item @b{Runtime_Source_Dir}: single, indexed, case-insensitive index - -Index is a language name. Value is the path name of the directory where the -sources of runtime libraries are located. - -@end itemize - -@end itemize - -@node Package Binder Attributes -@subsubsection Package Binder Attributes - -@itemize @bullet - -@item @b{General} - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of switches to be used when binding -code of the language, if there is no applicable attribute Switches. - -@item @b{Switches}: list, optional index, indexed, - case-insensitive index, others allowed - -Index is either a language name or a source file name. Value is the list of -switches to be used when binding code. Index is either the source file name -of the executable to be bound or the language name of the code to be bound. - -@end itemize - -@item @b{Configuration - Binding} - -@itemize @bullet - -@item @b{Driver}: single, indexed, case-insensitive index - -Index is a language name. Value is the name of the application to be used when -binding code of the language. - -@item @b{Required_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of the required switches to be -used when binding code of the language. - -@item @b{Prefix}: single, indexed, case-insensitive index - -Index is a language name. Value is a prefix to be used for the binder exchange -file name for the language. Used to have different binder exchange file names -when binding different languages. - -@item @b{Objects_Path}: single,indexed, case-insensitive index - -Index is a language name. Value is the name of the environment variable that -contains the path for the object directories. - -@item @b{Object_Path_File}: single,indexed, case-insensitive index - -Index is a language name. Value is the name of the environment variable. The -value of the environment variable is the path name of a text file that -contains the list of object directories. - -@end itemize - -@end itemize - -@node Package Builder Attributes -@subsubsection Package Builder Attributes - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of builder switches to be used when -building an executable of the language, if there is no applicable attribute -Switches. - -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed - -Index is either a language name or a source file name. Value is the list of -builder switches to be used when building an executable. Index is either the -source file name of the executable to be built or its language name. - -@item @b{Global_Compilation_Switches}: list, optional index, indexed, - case-insensitive index - -Index is either a language name or a source file name. Value is the list of -compilation switches to be used when building an executable. Index is either -the source file name of the executable to be built or its language name. - -@item @b{Executable}: single, indexed, case-insensitive index - -Index is an executable source file name. Value is the simple file name of the -executable to be built. - -@item @b{Executable_Suffix}: single - -Value is the extension of the file names of executable. When not specified, -the extension is the default extension of executables on the platform. - -@item @b{Global_Configuration_Pragmas}: single - -Value is the file name of a configuration pragmas file that is specified to -the Ada compiler when compiling any Ada source in the project tree. - -@item @b{Global_Config_File}: single, indexed, case-insensitive index - -Index is a language name. Value is the file name of a configuration file that -is specified to the compiler when compiling any source of the language in the -project tree. - -@end itemize - -@ifclear FSFEDITION -@node Package Check Attributes -@subsubsection Package Check Attributes - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of switches to be used when invoking -@code{gnatcheck} for a source of the language, if there is no applicable -attribute Switches. - -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed - -Index is a source file name. Value is the list of switches to be used when -invoking @code{gnatcheck} for the source. - -@end itemize -@end ifclear - -@node Package Clean Attributes -@subsubsection Package Clean Attributes - -@itemize @bullet - -@item @b{Switches}: list - -Value is a list of switches to be used by the cleaning application. - -@item @b{Source_Artifact_Extensions}: list, indexed, case-insensitive index - -Index is a language names. Value is the list of extensions for file names -derived from object file names that need to be cleaned in the object -directory of the project. - -@item @b{Object_Artifact_Extensions}: list, indexed, case-insensitive index - -Index is a language names. Value is the list of extensions for file names -derived from source file names that need to be cleaned in the object -directory of the project. - -@item @b{Artifacts_In_Object_Dir}: single - -Value is a list of file names expressed as regular expressions that are to be -deleted by gprclean in the object directory of the project. - -@item @b{Artifacts_In_Exec_Dir}: single - -Value is list of file names expressed as regular expressions that are to be -deleted by gprclean in the exec directory of the main project. - -@end itemize - -@node Package Compiler Attributes -@subsubsection Package Compiler Attributes - -@itemize @bullet - -@item @b{General} - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of switches to be used when invoking -the compiler for the language for a source of the project, if there is no -applicable attribute Switches. - -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed - -Index is a source file name or a language name. Value is the list of switches -to be used when invoking the compiler for the source or for its language. - -@item @b{Local_Configuration_Pragmas}: single - -Value is the file name of a configuration pragmas file that is specified to -the Ada compiler when compiling any Ada source in the project. - -@item @b{Local_Config_File}: single, indexed, case-insensitive index - -Index is a language name. Value is the file name of a configuration file that -is specified to the compiler when compiling any source of the language in the -project. - -@end itemize - -@item @b{Configuration - Compiling} - -@itemize @bullet - -@item @b{Driver}: single, indexed, case-insensitive index - -Index is a language name. Value is the name of the executable for the compiler -of the language. - -@item @b{Language_Kind}: single, indexed, case-insensitive index - -Index is a language name. Indicates the kind of the language, either file based -or unit based. Only authorized case-insensitive values are "unit_based" and -"file_based" (the default). - -@item @b{Dependency_Kind}: single, indexed, case-insensitive index - -Index is a language name. Indicates how the dependencies are handled for the -language. Only authorized case-insensitive values are "makefile", "ali_file", -"ali_closure" or "none" (the default). - -@item @b{Required_Switches}: list, indexed, case-insensitive index - -Equivalent to attribute Leading_Required_Switches. - -@item @b{Leading_Required_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of the minimum switches to be used -at the beginning of the command line when invoking the compiler for the -language. - -@item @b{Trailing_Required_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of the minimum switches to be used -at the end of the command line when invoking the compiler for the language. - -@item @b{PIC_Option}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of switches to be used when -compiling a source of the language when the project is a shared library -project. - -@item @b{Path_Syntax}: single, indexed, case-insensitive index - -Index is a language name. Value is the kind of path syntax to be used when -invoking the compiler for the language. Only authorized case-insensitive -values are "canonical" and "host" (the default). - -@item @b{Source_File_Switches}: single, indexed, case-insensitive index - -Index is a language name. Value is a list of switches to be used just before -the path name of the source to compile when invoking the compiler for a source -of the language. - -@item @b{Object_File_Suffix}: single, indexed, case-insensitive index - -Index is a language name. Value is the extension of the object files created -by the compiler of the language. When not specified, the extension is the -default one for the platform. - -@item @b{Object_File_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of switches to be used by the -compiler of the language to specify the path name of the object file. When not -specified, the switch used is "-o". - -@item @b{Multi_Unit_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of switches to be used to compile -a unit in a multi unit source of the language. The index of the unit in the -source is concatenated with the last switches in the list. - -@item @b{Multi_Unit_Object_Separator}: single, indexed, case-insensitive index - -Index is a language name. Value is the string to be used in the object file -name before the index of the unit, when compiling a unit in a multi unit source -of the language. - -@end itemize - -@item @b{Configuration - Mapping Files} - -@itemize @bullet - -@item @b{Mapping_File_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of switches to be used to specify -a mapping file when invoking the compiler for a source of the language. - -@item @b{Mapping_Spec_Suffix}: single, indexed, case-insensitive index - -Index is a language name. Value is the suffix to be used in a mapping file -to indicate that the source is a spec. - -@item @b{Mapping_Body_Suffix}: single, indexed, case-insensitive index - -Index is a language name. Value is the suffix to be used in a mapping file -to indicate that the source is a body. - -@end itemize - -@item @b{Configuration - Config Files} - -@itemize @bullet - -@item @b{Config_File_Switches}: list: single, indexed, case-insensitive index - -Index is a language name. Value is the list of switches to specify to the -compiler of the language a configuration file. - -@item @b{Config_Body_File_Name}: single, indexed, case-insensitive index - -Index is a language name. Value is the template to be used to indicate a -configuration specific to a body of the language in a configuration -file. - -@item @b{Config_Body_File_Name_Index}: single, indexed, case-insensitive index - -Index is a language name. Value is the template to be used to indicate a -configuration specific to the body a unit in a multi unit source of the -language in a configuration file. - -@item @b{Config_Body_File_Name_Pattern}: single, indexed, - case-insensitive index - -Index is a language name. Value is the template to be used to indicate a -configuration for all bodies of the languages in a configuration file. - -@item @b{Config_Spec_File_Name}: single, indexed, case-insensitive index - -Index is a language name. Value is the template to be used to indicate a -configuration specific to a spec of the language in a configuration -file. - -@item @b{Config_Spec_File_Name_Index}: single, indexed, case-insensitive index - -Index is a language name. Value is the template to be used to indicate a -configuration specific to the spec a unit in a multi unit source of the -language in a configuration file. - -@item @b{Config_Spec_File_Name_Pattern}: single, indexed, - case-insensitive index - -Index is a language name. Value is the template to be used to indicate a -configuration for all specs of the languages in a configuration file. - -@item @b{Config_File_Unique}: single, indexed, case-insensitive index - -Index is a language name. Indicates if there should be only one configuration -file specified to the compiler of the language. Only authorized -case-insensitive values are "true" and "false" (the default). - -@end itemize - -@item @b{Configuration - Dependencies} - -@itemize @bullet - -@item @b{Dependency_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of switches to be used to specify -to the compiler the dependency file when the dependency kind of the language is -file based, and when Dependency_Driver is not specified for the language. - -@item @b{Dependency_Driver}: list, indexed, case-insensitive index - -Index is a language name. Value is the name of the executable to be used to -create the dependency file for a source of the language, followed by the -required switches. - -@end itemize - -@item @b{Configuration - Search Paths} - -@itemize @bullet - -@item @b{Include_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of switches to specify to the -compiler of the language to indicate a directory to look for sources. - -@item @b{Include_Path}: single, indexed, case-insensitive index - -Index is a language name. Value is the name of an environment variable that -contains the path of all the directories that the compiler of the language -may search for sources. - -@item @b{Include_Path_File}: single, indexed, case-insensitive index - -Index is a language name. Value is the name of an environment variable the -value of which is the path name of a text file that contains the directories -that the compiler of the language may search for sources. - -@item @b{Object_Path_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is the list of switches to specify to the -compiler of the language the name of a text file that contains the list of -object directories. When this attribute is not declared, the text file is -not created. - -@end itemize - -@end itemize - -@node Package Cross_Reference Attributes -@subsubsection Package Cross_Reference Attributes - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of switches to be used when invoking -@code{gnatxref} for a source of the language, if there is no applicable -attribute Switches. - -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed - -Index is a source file name. Value is the list of switches to be used when -invoking @code{gnatxref} for the source. - -@end itemize - -@ifclear FSFEDITION -@node Package Eliminate Attributes -@subsubsection Package Eliminate Attributes - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of switches to be used when invoking -@code{gnatelim} for a source of the language, if there is no applicable -attribute Switches. - -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed - -Index is a source file name. Value is the list of switches to be used when -invoking @code{gnatelim} for the source. - -@end itemize -@end ifclear - -@node Package Finder Attributes -@subsubsection Package Finder Attributes - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of switches to be used when invoking -@code{gnatfind} for a source of the language, if there is no applicable -attribute Switches. - -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed - -Index is a source file name. Value is the list of switches to be used when -invoking @code{gnatfind} for the source. - -@end itemize - -@node Package gnatls Attributes -@subsubsection Package gnatls Attributes - -@itemize @bullet - -@item @b{Switches}: list - -Value is a list of switches to be used when invoking @code{gnatls}. - -@end itemize - -@ifclear FSFEDITION -@node Package gnatstub Attributes -@subsubsection Package gnatstub Attributes - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of switches to be used when invoking -@code{gnatstub} for a source of the language, if there is no applicable -attribute Switches. - -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed - -Index is a source file name. Value is the list of switches to be used when -invoking @code{gnatstub} for the source. - -@end itemize -@end ifclear - -@node Package IDE Attributes -@subsubsection Package IDE Attributes - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed - -Index is the name of an external tool that the GNAT Programming System (GPS) -is supporting. Value is a list of switches to use when invoking that tool. - -@item @b{Remote_Host}: single - -Value is a string that designates the remote host in a cross-compilation -environment, to be used for remote compilation and debugging. This attribute -should not be specified when running on the local machine. - -@item @b{Program_Host}: single - -Value is a string that specifies the name of IP address of the embedded target -in a cross-compilation environment, on which the program should execute. - -@item @b{Communication_Protocol}: single - -Value is the name of the protocol to use to communicate with the target -in a cross-compilation environment, for example @code{"wtx"} or -@code{"vxworks"}. - -@item @b{Compiler_Command}: single, indexed, case-insensitive index - -Index is a language Name. Value is a string that denotes the command to be -used to invoke the compiler. The value of @code{Compiler_Command ("Ada")} is -expected to be compatible with @command{gnatmake}, in particular in -the handling of switches. - -@item @b{Debugger_Command}: single - -Value is a string that specifies the name of the debugger to be used, such as -gdb, powerpc-wrs-vxworks-gdb or gdb-4. - -@item @b{gnatlist}: single - -Value is a string that specifies the name of the @command{gnatls} utility -to be used to retrieve information about the predefined path; for example, -@code{"gnatls"}, @code{"powerpc-wrs-vxworks-gnatls"}. - -@item @b{VCS_Kind}: single - -Value is a string used to specify the Version Control System (VCS) to be used -for this project, for example "Subversion", "ClearCase". If the -value is set to "Auto", the IDE will try to detect the actual VCS used -on the list of supported ones. - -@item @b{VCS_File_Check}: single - -Value is a string that specifies the command used by the VCS to check -the validity of a file, either when the user explicitly asks for a check, -or as a sanity check before doing the check-in. - -@item @b{VCS_Log_Check}: single - -Value is a string that specifies the command used by the VCS to check -the validity of a log file. - -@item @b{Documentation_Dir}: single - -Value is the directory used to generate the documentation of source code. - -@end itemize - -@node Package Install Attributes -@subsubsection Package Install Attributes - -@itemize @bullet - -@item @b{Artifacts}: list, indexed - -An array attribute to declare a set of files not part of the sources -to be installed. The array discriminant is the directory where the -file is to be installed. If a relative directory then Prefix (see -below) is prepended. - -@item @b{Prefix}: single - -Value is the install destination directory. - -@item @b{Sources_Subdir}: single - -Value is the sources directory or subdirectory of Prefix. - -@item @b{Exec_Subdir}: single - -Value is the executables directory or subdirectory of Prefix. - -@item @b{Lib_Subdir}: single - -Value is library directory or subdirectory of Prefix. - -@item @b{Project_Subdir}: single - -Value is the project directory or subdirectory of Prefix. - -@item @b{Active}: single - -Indicates that the project is to be installed or not. Case-insensitive value -"false" means that the project is not to be installed, all other values mean -that the project is to be installed. - -@item @b{Mode}: single - -Value is the installation mode, it is either @b{dev} (default) or @b{usage}. - -@item @b{Install_Name}: single - -Specify the name to use for recording the installation. The default is -the project name without the extension. - -@end itemize - -@node Package Linker Attributes -@subsubsection Package Linker Attributes - -@itemize @bullet - -@item @b{General} - -@itemize @bullet - -@item @b{Required_Switches}: list - -Value is a list of switches that are required when invoking the linker to link -an executable. - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of switches for the linker when -linking an executable for a main source of the language, when there is no -applicable Switches. - -@item @b{Leading_Switches}: list, optional index, indexed, - case-insensitive index, others allowed - -Index is a source file name or a language name. Value is the list of switches -to be used at the beginning of the command line when invoking the linker to -build an executable for the source or for its language. - -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed - -Index is a source file name or a language name. Value is the list of switches -to be used when invoking the linker to build an executable for the source or -for its language. - -@item @b{Trailing_Switches}: list, optional index, indexed, - case-insensitive index, others allowed - -Index is a source file name or a language name. Value is the list of switches -to be used at the end of the command line when invoking the linker to -build an executable for the source or for its language. These switches may -override the Required_Switches. - -@item @b{Linker_Options}: list - -Value is a list of switches/options that are to be added when linking an -executable from a project importing the current project directly or indirectly. -Linker_Options are not used when linking an executable from the current -project. - -@item @b{Map_File_Option}: single - -Value is the switch to specify the map file name that the linker needs to -create. - -@end itemize - -@item @b{Configuration - Linking} - -@itemize @bullet - -@item @b{Driver}: single - -Value is the name of the linker executable. - -@end itemize - -@item @b{Configuration - Response Files} - -@itemize @bullet - -@item @b{Max_Command_Line_Length}: single - -Value is the maximum number of character in the command line when invoking -the linker to link an executable. - -@item @b{Response_File_Format}: single - -Indicates the kind of response file to create when the length of the linking -command line is too large. Only authorized case-insensitive values are "none", -"gnu", "object_list", "gcc_gnu", "gcc_option_list" and "gcc_object_list". - -@item @b{Response_File_Switches}: list - -Value is the list of switches to specify a response file to the linker. - -@end itemize - -@end itemize - -@ifclear FSFEDITION -@node Package Metrics Attribute -@subsubsection Package Metrics Attribute - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of switches to be used when invoking -@code{gnatmetric} for a source of the language, if there is no applicable -attribute Switches. - -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed - -Index is a source file name. Value is the list of switches to be used when -invoking @code{gnatmetric} for the source. - -@end itemize -@end ifclear - -@node Package Naming Attributes -@subsubsection Package Naming Attributes - -@itemize @bullet - -@item @b{Specification_Suffix}: single, indexed, case-insensitive index - -Equivalent to attribute Spec_Suffix. - -@item @b{Spec_Suffix}: single, indexed, case-insensitive index - -Index is a language name. Value is the extension of file names for specs of -the language. - -@item @b{Implementation_Suffix}: single, indexed, case-insensitive index - -Equivalent to attribute Body_Suffix. - -@item @b{Body_Suffix}: single, indexed, case-insensitive index - -Index is a language name. Value is the extension of file names for bodies of -the language. - -@item @b{Separate_Suffix}: single - -Value is the extension of file names for subunits of Ada. - -@item @b{Casing}: single - -Indicates the casing of sources of the Ada language. Only authorized -case-insensitive values are "lowercase", "uppercase" and "mixedcase". - -@item @b{Dot_Replacement}: single - -Value is the string that replace the dot of unit names in the source file names -of the Ada language. - -@item @b{Specification}: single, optional index, indexed, - case-insensitive index - -Equivalent to attribute Spec. - -@item @b{Spec}: single, optional index, indexed, case-insensitive index - -Index is a unit name. Value is the file name of the spec of the unit. - -@item @b{Implementation}: single, optional index, indexed, - case-insensitive index - -Equivalent to attribute Body. - -@item @b{Body}: single, optional index, indexed, case-insensitive index - -Index is a unit name. Value is the file name of the body of the unit. - -@item @b{Specification_Exceptions}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of specs for the language that do not -necessarily follow the naming scheme for the language and that may or may not -be found in the source directories of the project. - -@item @b{Implementation_Exceptions}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of bodies for the language that do not -necessarily follow the naming scheme for the language and that may or may not -be found in the source directories of the project. - -@end itemize - -@ifclear FSFEDITION -@node Package Pretty_Printer Attributes -@subsubsection Package Pretty_Printer Attributes - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of switches to be used when invoking -@code{gnatpp} for a source of the language, if there is no applicable -attribute Switches. - -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed - -Index is a source file name. Value is the list of switches to be used when -invoking @code{gnatpp} for the source. - -@end itemize -@end ifclear - -@node Package Remote Attributes -@subsubsection Package Remote Attributes - -@itemize @bullet - -@item @b{Included_Patterns}: list - -If this attribute is defined it sets the patterns to -synchronized from the master to the slaves. It is exclusive -with Excluded_Patterns, that is it is an error to define -both. - -@item @b{Included_Artifact_Patterns}: list - -If this attribute is defined it sets the patterns of compilation -artifacts to synchronized from the slaves to the build master. -This attribute replace the default hard-coded patterns. - -@item @b{Excluded_Patterns}: list - -Set of patterns to ignore when synchronizing sources from the build -master to the slaves. A set of predefined patterns are supported -(e.g. *.o, *.ali, *.exe, etc.), this attributes make it possible to -add some more patterns. - -@item @b{Root_Dir}: single - -Value is the root directory used by the slave machines. - -@end itemize - -@node Package Stack Attributes -@subsubsection Package Stack Attributes - -@itemize @bullet - -@item @b{Switches}: list - -Value is the list of switches to be used when invoking @code{gnatstack}. - -@end itemize - -@node Package Synchronize Attributes -@subsubsection Package Synchronize Attributes - -@itemize @bullet - -@item @b{Default_Switches}: list, indexed, case-insensitive index - -Index is a language name. Value is a list of switches to be used when invoking -@code{gnatsync} for a source of the language, if there is no applicable -attribute Switches. - -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed - -Index is a source file name. Value is the list of switches to be used when -invoking @code{gnatsync} for the source. - -@end itemize diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 3915c30e7ed..51b8b67d983 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -726,16 +726,12 @@ package body Repinfo is Write_Line ("Assembler"); when Convention_C => Write_Line ("C"); - when Convention_CIL => - Write_Line ("CIL"); when Convention_COBOL => Write_Line ("COBOL"); when Convention_CPP => Write_Line ("C++"); when Convention_Fortran => Write_Line ("Fortran"); - when Convention_Java => - Write_Line ("Java"); when Convention_Stdcall => Write_Line ("Stdcall"); when Convention_Stubbed => diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 8c0f90260d1..aaaaf40bb0a 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -285,6 +285,24 @@ package body Restrict is Check_Restriction (No_Implicit_Heap_Allocations, N); end Check_No_Implicit_Heap_Alloc; + ---------------------------------- + -- Check_No_Implicit_Task_Alloc -- + ---------------------------------- + + procedure Check_No_Implicit_Task_Alloc (N : Node_Id) is + begin + Check_Restriction (No_Implicit_Task_Allocations, N); + end Check_No_Implicit_Task_Alloc; + + --------------------------------------- + -- Check_No_Implicit_Protected_Alloc -- + --------------------------------------- + + procedure Check_No_Implicit_Protected_Alloc (N : Node_Id) is + begin + Check_Restriction (No_Implicit_Protected_Object_Allocations, N); + end Check_No_Implicit_Protected_Alloc; + ----------------------------------- -- Check_Obsolescent_2005_Entity -- ----------------------------------- @@ -480,19 +498,21 @@ package body Restrict is begin Msg_Issued := False; - -- In CodePeer and SPARK mode, we do not want to check for any - -- restriction, or set additional restrictions other than those already - -- set in gnat1drv.adb so that we have consistency between each - -- compilation. + -- In CodePeer mode, we do not want to check for any restriction, or set + -- additional restrictions other than those already set in gnat1drv.adb + -- so that we have consistency between each compilation. - -- Just checking, SPARK does not allow restrictions to be set ??? + -- In GNATprove mode restrictions are checked, except for + -- No_Initialize_Scalars, which is implicitly set in gnat1drv.adb. - if CodePeer_Mode or GNATprove_Mode then + if CodePeer_Mode + or else (GNATprove_Mode and then R = No_Initialize_Scalars) + then return; end if; - -- In SPARK mode, issue an error for any use of class-wide, even if the - -- No_Dispatch restriction is not set. + -- In SPARK 05 mode, issue an error for any use of class-wide, even if + -- the No_Dispatch restriction is not set. if R = No_Dispatch then Check_SPARK_05_Restriction ("class-wide is not allowed", N); diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 4871b6ffe84..c34113a7da7 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -282,7 +282,7 @@ package Restrict is procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id); -- N is the node id for an N_Aspect_Specification. An error message - -- (warning) will be issued if a restriction (warning) was previous set + -- (warning) will be issued if a restriction (warning) was previously set -- for this aspect using Set_No_Specification_Of_Aspect. procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id); @@ -292,7 +292,7 @@ package Restrict is procedure Check_Restriction_No_Use_Of_Entity (N : Node_Id); -- N is the node id for an entity reference. An error message (warning) - -- will be issued if a restriction (warning) was previous set for this + -- will be issued if a restriction (warning) was previously set for this -- entity name using Set_No_Use_Of_Entity. procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id); @@ -337,6 +337,15 @@ package Restrict is -- Equivalent to Check_Restriction (No_Implicit_Heap_Allocations, N). -- Provided for easy use by back end, which has to check this restriction. + procedure Check_No_Implicit_Task_Alloc (N : Node_Id); + -- Equivalent to Check_Restriction (No_Implicit_Task_Allocations, N). + -- Provided for easy use by back end, which has to check this restriction. + + procedure Check_No_Implicit_Protected_Alloc (N : Node_Id); + -- Equivalent to: + -- Check_Restriction (No_Implicit_Protected_Object_Allocations, N) + -- Provided for easy use by back end, which has to check this restriction. + procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id); -- This routine checks if the entity E is one of the obsolescent entries -- in Ada.Characters.Handling in Ada 2005 and No_Obsolescent_Features @@ -488,7 +497,7 @@ package Restrict is -- and this flag is not set. Profile is set to a non-default value if the -- No_Dependence restriction comes from a Profile pragma. This procedure -- also takes care of setting the Boolean2 flag of the simple name for - -- the entity (to optimize table searches). + -- the entity (to optimize table searches). procedure Set_Restriction_No_Use_Of_Pragma (N : Node_Id; @@ -537,7 +546,7 @@ package Restrict is function Cunit_Boolean_Restrictions_Save return Save_Cunit_Boolean_Restrictions; -- This function saves the compilation unit restriction settings, leaving - -- then unchanged. This is used e.g. at the start of processing a context + -- them unchanged. This is used e.g. at the start of processing a context -- clause, so that the main unit restrictions can be restored after all -- the with'ed units have been processed. diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads index 615e17bfc78..2ebd4f8f034 100644 --- a/gcc/ada/rident.ads +++ b/gcc/ada/rident.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -42,7 +42,7 @@ -- Rather than have clients instantiate System.Rident directly, we have the -- single instantiation here at the library level, which means that we only --- have one copy of the image tables +-- have one copy of the image tables. with System.Rident; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index c96e708872e..3c84bbe1153 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -925,9 +925,7 @@ package body Rtsfind is -- Local variables - GM : constant Ghost_Mode_Type := Ghost_Mode; - -- Save the current Ghost mode in effect to ensure a clean environment - -- when analyzing the unit. + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; -- Start of processing for Load_RTU @@ -1043,9 +1041,7 @@ package body Rtsfind is Set_Is_Potentially_Use_Visible (U.Entity, True); end if; - -- Restore the original Ghost mode now that analysis has taken place - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Load_RTU; -------------------- @@ -1111,7 +1107,7 @@ package body Rtsfind is begin Clause := U.First_Implicit_With; while Present (Clause) loop - if Parent (Clause) = Cunit (Current_Sem_Unit) then + if Parent (Clause) = Cunit (Current_Sem_Unit) then return; end if; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index bc4674a6052..d320639f655 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -23,15 +23,15 @@ -- -- ------------------------------------------------------------------------------ -with Types; use Types; - -package Rtsfind is - -- This package contains the routine that is used to obtain runtime library -- entities, loading in the required runtime library packages on demand. It -- is also used for such purposes as finding System.Address when System has -- not been explicitly With'ed. +with Types; use Types; + +package Rtsfind is + ------------------------ -- Runtime Unit Table -- ------------------------ @@ -550,7 +550,6 @@ package Rtsfind is RE_Set_Deadline, -- Ada.Dispatching.EDF RE_Code_Loc, -- Ada.Exceptions - RE_Current_Target_Exception, -- Ada.Exceptions (JGNAT use only) RE_Exception_Id, -- Ada.Exceptions RE_Exception_Identity, -- Ada.Exceptions RE_Exception_Information, -- Ada.Exceptions @@ -1596,7 +1595,6 @@ package Rtsfind is RE_Get_Current_Excep, -- System.Soft_Links RE_Get_GNAT_Exception, -- System.Soft_Links RE_Save_Library_Occurrence, -- System.Soft_Links - RE_Update_Exception, -- System.Soft_Links RE_Bits_1, -- System.Unsigned_Types RE_Bits_2, -- System.Unsigned_Types @@ -1783,7 +1781,6 @@ package Rtsfind is RE_Set_Deadline => Ada_Dispatching_EDF, RE_Code_Loc => Ada_Exceptions, - RE_Current_Target_Exception => Ada_Exceptions, -- of JGNAT RE_Exception_Id => Ada_Exceptions, RE_Exception_Identity => Ada_Exceptions, RE_Exception_Information => Ada_Exceptions, @@ -2833,7 +2830,6 @@ package Rtsfind is RE_Get_Current_Excep => System_Soft_Links, RE_Get_GNAT_Exception => System_Soft_Links, RE_Save_Library_Occurrence => System_Soft_Links, - RE_Update_Exception => System_Soft_Links, RE_Bits_1 => System_Unsigned_Types, RE_Bits_2 => System_Unsigned_Types, diff --git a/gcc/ada/s-atocou-builtin.adb b/gcc/ada/s-atocou-builtin.adb index 55436aa8388..36a939fd89e 100644 --- a/gcc/ada/s-atocou-builtin.adb +++ b/gcc/ada/s-atocou-builtin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,25 +29,38 @@ -- -- ------------------------------------------------------------------------------ --- This package implements Atomic_Counter operatiobns for platforms where --- GCC supports __sync_add_and_fetch_4 and __sync_sub_and_fetch_4 builtins. +-- This package implements Atomic_Counter and Atomic_Unsigned operations +-- for platforms where GCC supports __sync_add_and_fetch_4 and +-- __sync_sub_and_fetch_4 builtins. package body System.Atomic_Counters is procedure Sync_Add_And_Fetch - (Ptr : access Unsigned_32; - Value : Unsigned_32); + (Ptr : access Atomic_Unsigned; + Value : Atomic_Unsigned); pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); function Sync_Sub_And_Fetch - (Ptr : access Unsigned_32; - Value : Unsigned_32) return Unsigned_32; + (Ptr : access Atomic_Unsigned; + Value : Atomic_Unsigned) return Atomic_Unsigned; pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); --------------- -- Decrement -- --------------- + procedure Decrement (Item : aliased in out Atomic_Unsigned) is + begin + if Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0 then + null; + end if; + end Decrement; + + function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is + begin + return Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0; + end Decrement; + function Decrement (Item : in out Atomic_Counter) return Boolean is begin -- Note: the use of Unrestricted_Access here is required because we @@ -62,6 +75,11 @@ package body System.Atomic_Counters is -- Increment -- --------------- + procedure Increment (Item : aliased in out Atomic_Unsigned) is + begin + Sync_Add_And_Fetch (Item'Unrestricted_Access, 1); + end Increment; + procedure Increment (Item : in out Atomic_Counter) is begin -- Note: the use of Unrestricted_Access here is required because we are diff --git a/gcc/ada/s-atocou-x86.adb b/gcc/ada/s-atocou-x86.adb index b85b40274fa..bee6755485b 100644 --- a/gcc/ada/s-atocou-x86.adb +++ b/gcc/ada/s-atocou-x86.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -44,7 +44,7 @@ package body System.Atomic_Counters is -- Decrement -- --------------- - function Decrement (Item : in out Atomic_Counter) return Boolean is + function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is Aux : Boolean; begin @@ -53,27 +53,44 @@ package body System.Atomic_Counters is "lock%; decl" & ASCII.HT & "%0" & ASCII.LF & ASCII.HT & "sete %1", Outputs => - (Unsigned_32'Asm_Output ("=m", Item.Value), + (Atomic_Unsigned'Asm_Output ("=m", Item), Boolean'Asm_Output ("=qm", Aux)), - Inputs => Unsigned_32'Asm_Input ("m", Item.Value), + Inputs => Atomic_Unsigned'Asm_Input ("m", Item), Volatile => True); return Aux; end Decrement; + procedure Decrement (Item : aliased in out Atomic_Unsigned) is + begin + if Decrement (Item) then + null; + end if; + end Decrement; + + function Decrement (Item : in out Atomic_Counter) return Boolean is + begin + return Decrement (Item.Value); + end Decrement; + --------------- -- Increment -- --------------- - procedure Increment (Item : in out Atomic_Counter) is + procedure Increment (Item : aliased in out Atomic_Unsigned) is begin System.Machine_Code.Asm (Template => "lock%; incl" & ASCII.HT & "%0", - Outputs => Unsigned_32'Asm_Output ("=m", Item.Value), - Inputs => Unsigned_32'Asm_Input ("m", Item.Value), + Outputs => Atomic_Unsigned'Asm_Output ("=m", Item), + Inputs => Atomic_Unsigned'Asm_Input ("m", Item), Volatile => True); end Increment; + procedure Increment (Item : in out Atomic_Counter) is + begin + Increment (Item.Value); + end Increment; + ---------------- -- Initialize -- ---------------- diff --git a/gcc/ada/s-atocou.adb b/gcc/ada/s-atocou.adb index 51cc79ba59d..2897c6c8368 100644 --- a/gcc/ada/s-atocou.adb +++ b/gcc/ada/s-atocou.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,12 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This is dummy version of the package, for use on platforms where this --- capability is not supported. Any use of any of the routines in this --- package will raise Program_Error. - --- Why don't we use pragma Unimplemented_Unit in a dummy spec, this would --- seem much more useful than raising an exception at run time ??? +-- This is version of the package, for use on platforms where this capability +-- is not supported. All Atomic_Counter operations raises Program_Error, +-- Atomic_Unsigned operations processed in non-atomic manner. package body System.Atomic_Counters is @@ -48,6 +45,18 @@ package body System.Atomic_Counters is return False; end Decrement; + function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is + begin + -- Could not use Item := Item - 1; because it is disabled in spec. + Item := Atomic_Unsigned'Pred (Item); + return Item = 0; + end Decrement; + + procedure Decrement (Item : aliased in out Atomic_Unsigned) is + begin + Item := Atomic_Unsigned'Pred (Item); + end Decrement; + --------------- -- Increment -- --------------- @@ -57,6 +66,11 @@ package body System.Atomic_Counters is raise Program_Error; end Increment; + procedure Increment (Item : aliased in out Atomic_Unsigned) is + begin + Item := Atomic_Unsigned'Succ (Item); + end Increment; + ---------------- -- Initialize -- ---------------- diff --git a/gcc/ada/s-atocou.ads b/gcc/ada/s-atocou.ads index a2e6d897efb..1147de7b45f 100644 --- a/gcc/ada/s-atocou.ads +++ b/gcc/ada/s-atocou.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,6 +39,7 @@ package System.Atomic_Counters is + pragma Pure; pragma Preelaborate; type Atomic_Counter is limited private; @@ -50,6 +51,8 @@ package System.Atomic_Counters is -- Atomic_Counter is declared as private limited type to provide highest -- level of protection from unexpected use. All available operations are -- declared below, and this set should be as small as possible. + -- Increment/Decrement operations for this type raise Program_Error on + -- platforms not supporting the atomic primitives. procedure Increment (Item : in out Atomic_Counter); pragma Inline_Always (Increment); @@ -69,11 +72,35 @@ package System.Atomic_Counters is -- intended to be used in special cases when the counter object cannot be -- initialized in standard way. + type Atomic_Unsigned is mod 2 ** 32 with Default_Value => 0, Atomic; + -- Modular compatible atomic unsigned type. + -- Increment/Decrement operations for this type are atomic only on + -- supported platforms. See top of the file. + + procedure Increment + (Item : aliased in out Atomic_Unsigned) with Inline_Always; + -- Increments value of atomic counter + + function Decrement + (Item : aliased in out Atomic_Unsigned) return Boolean with Inline_Always; + + procedure Decrement + (Item : aliased in out Atomic_Unsigned) with Inline_Always; + -- Decrements value of atomic counter + + -- The "+" and "-" abstract routine provided below to disable BT := BT + 1 + -- constructions. + + function "+" + (Left, Right : Atomic_Unsigned) return Atomic_Unsigned is abstract; + + function "-" + (Left, Right : Atomic_Unsigned) return Atomic_Unsigned is abstract; + private - type Unsigned_32 is mod 2 ** 32; - type Atomic_Counter is limited record - Value : aliased Unsigned_32 := 1; + type Atomic_Counter is record + Value : aliased Atomic_Unsigned := 1; pragma Atomic (Value); end record; diff --git a/gcc/ada/s-diflio.adb b/gcc/ada/s-diflio.adb index 527d7bbbaf8..5c553a0912e 100644 --- a/gcc/ada/s-diflio.adb +++ b/gcc/ada/s-diflio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -69,9 +69,11 @@ package body System.Dim.Float_IO is Exp : Field := Default_Exp; Symbol : String := "") is + Ptr : constant Natural := Symbol'Length; + begin - Num_Dim_Float_IO.Put (To, Item, Aft, Exp); - To := To & Symbol; + Num_Dim_Float_IO.Put (To (To'First .. To'Last - Ptr), Item, Aft, Exp); + To (To'Last - Ptr + 1 .. To'Last) := Symbol; end Put; ---------------- @@ -104,6 +106,27 @@ package body System.Dim.Float_IO is Symbol : String := "") is begin - To := Symbol; + To (1 .. Symbol'Length) := Symbol; end Put_Dim_Of; + + ----------- + -- Image -- + ----------- + + function Image + (Item : Num_Dim_Float; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := "") return String + is + Buffer : String (1 .. 50); + + begin + Put (Buffer, Item, Aft, Exp); + for I in Buffer'Range loop + if Buffer (I) /= ' ' then + return Buffer (I .. Buffer'Last) & Symbol; + end if; + end loop; + end Image; end System.Dim.Float_IO; diff --git a/gcc/ada/s-diflio.ads b/gcc/ada/s-diflio.ads index cd3410b4a97..df550929ea3 100644 --- a/gcc/ada/s-diflio.ads +++ b/gcc/ada/s-diflio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -175,4 +175,10 @@ package System.Dim.Float_IO is pragma Inline (Put); pragma Inline (Put_Dim_Of); + function Image + (Item : Num_Dim_Float; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := "") return String; + end System.Dim.Float_IO; diff --git a/gcc/ada/s-excdeb.adb b/gcc/ada/s-excdeb.adb index 851d5e60c66..d9410f0ca27 100644 --- a/gcc/ada/s-excdeb.adb +++ b/gcc/ada/s-excdeb.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,8 +37,10 @@ package body System.Exceptions_Debug is -- Debug_Raise_Exception -- --------------------------- - procedure Debug_Raise_Exception (E : SSL.Exception_Data_Ptr) is - pragma Inspection_Point (E); + procedure Debug_Raise_Exception + (E : SSL.Exception_Data_Ptr; Message : String) + is + pragma Inspection_Point (E, Message); begin null; end Debug_Raise_Exception; diff --git a/gcc/ada/s-excdeb.ads b/gcc/ada/s-excdeb.ads index 9984d7b37a9..21e6b525f4c 100644 --- a/gcc/ada/s-excdeb.ads +++ b/gcc/ada/s-excdeb.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,7 +46,8 @@ package System.Exceptions_Debug is -- To let some of the hooks below have formal parameters typed in -- accordance with what GDB expects. - procedure Debug_Raise_Exception (E : SSL.Exception_Data_Ptr); + procedure Debug_Raise_Exception + (E : SSL.Exception_Data_Ptr; Message : String); pragma Export (Ada, Debug_Raise_Exception, "__gnat_debug_raise_exception"); -- Hook called at a "raise" point for an exception E, when it is diff --git a/gcc/ada/s-exctra.adb b/gcc/ada/s-exctra.adb index 1a05cc1efd4..1d6cabfcc82 100644 --- a/gcc/ada/s-exctra.adb +++ b/gcc/ada/s-exctra.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2014, AdaCore -- +-- Copyright (C) 2000-2015, AdaCore -- -- -- -- 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- -- @@ -69,8 +69,6 @@ package body System.Exception_Traces is (Traceback : System.Address; Len : Natural) return String is - -- Note: do not use an address clause, which is not supported under .NET - subtype Trace_Array is Traceback_Entries.Tracebacks_Array (1 .. Len); type Trace_Array_Access is access all Trace_Array; @@ -116,6 +114,8 @@ package body System.Exception_Traces is Exception_Trace := Every_Raise; when Unhandled_Raise => Exception_Trace := Unhandled_Raise; + when Unhandled_Raise_In_Main => + Exception_Trace := Unhandled_Raise_In_Main; end case; end Trace_On; diff --git a/gcc/ada/s-exctra.ads b/gcc/ada/s-exctra.ads index 956f531284c..ae6936e93dd 100644 --- a/gcc/ada/s-exctra.ads +++ b/gcc/ada/s-exctra.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2014, AdaCore -- +-- Copyright (C) 2000-2015, AdaCore -- -- -- -- 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- -- @@ -48,6 +48,10 @@ -- may return any string output in association with a provided call chain. -- The decorator replaces the default backtrace mentioned above. +-- On systems that use DWARF debugging output, then if the "-g" compiler +-- switch and the "-Es" binder switch are used, the decorator is automatically +-- set to Symbolic_Traceback. + with System.Traceback_Entries; package System.Exception_Traces is @@ -61,10 +65,14 @@ package System.Exception_Traces is -- explicit or due to a specific language rule, within the context of a -- task or not. - Unhandled_Raise + Unhandled_Raise, -- Denotes the raise events corresponding to exceptions for which there - -- is no user defined handler, in particular, when a task dies due to an - -- unhandled exception. + -- is no user defined handler. This includes unhandled exceptions in + -- task bodies. + + Unhandled_Raise_In_Main + -- Same as Unhandled_Raise, except exceptions in task bodies are not + -- included. ); -- The following procedures can be used to activate and deactivate @@ -85,12 +93,15 @@ package System.Exception_Traces is -- output for a call chain provided by way of a tracebacks array. procedure Set_Trace_Decorator (Decorator : Traceback_Decorator); - -- Set the decorator to be used for future automatic outputs. Restore - -- the default behavior (output of raw addresses) if the provided - -- access value is null. + -- Set the decorator to be used for future automatic outputs. Restore the + -- default behavior if the provided access value is null. -- -- Note: System.Traceback.Symbolic.Symbolic_Traceback may be used as the -- Decorator, to get a symbolic traceback. This will cause a significant - -- cpu and memory overhead. + -- cpu and memory overhead on some platforms. + -- + -- Note: The Decorator is called when constructing the + -- Exception_Information; that needs to be taken into account + -- if the Decorator has any side effects. end System.Exception_Traces; diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb index 57703f4ff6e..35d037ac388 100644 --- a/gcc/ada/s-fatgen.adb +++ b/gcc/ada/s-fatgen.adb @@ -744,7 +744,7 @@ package body System.Fat_Gen is else Result := Machine (Radix_To_M_Minus_1 + Result) - Radix_To_M_Minus_1; - if Result > abs X then + if Result > abs X then Result := Result - 1.0; end if; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index 1d8882e3ad8..e9d54f84f47 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -433,8 +433,8 @@ package body System.File_IO is -- OPEN CREATE -- Append_File "r+" "w+" -- In_File "r" "w+" - -- Out_File (Direct_IO) "r+" "w" - -- Out_File (all others) "w" "w" + -- Out_File (Direct_IO, Stream_IO) "r+" "w" + -- Out_File (others) "w" "w" -- Inout_File "r+" "w+" -- Note: we do not use "a" or "a+" for Append_File, since this would not @@ -479,7 +479,7 @@ package body System.File_IO is end if; when Out_File => - if Amethod = 'D' and then not Creat then + if Amethod in 'D' | 'S' and then not Creat then Fopstr (1) := 'r'; Fopstr (2) := '+'; Fptr := 3; diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb index 918519b6781..c5ddff76955 100644 --- a/gcc/ada/s-finmas.adb +++ b/gcc/ada/s-finmas.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -212,7 +212,7 @@ package body System.Finalization_Masters is -- Skip the list header in order to offer proper object layout for -- finalization. - Obj_Addr := Curr_Ptr.all'Address + Header_Offset; + Obj_Addr := Curr_Ptr.all'Address + Header_Size; -- Retrieve TSS primitive Finalize_Address depending on the master's -- mode of operation. @@ -327,15 +327,6 @@ package body System.Finalization_Masters is return FM_Node'Size / Storage_Unit; end Header_Size; - ------------------- - -- Header_Offset -- - ------------------- - - function Header_Offset return System.Storage_Elements.Storage_Offset is - begin - return FM_Node'Size / Storage_Unit; - end Header_Offset; - ---------------- -- Initialize -- ---------------- diff --git a/gcc/ada/s-finmas.ads b/gcc/ada/s-finmas.ads index a94a8f99b60..a4e6cb15e48 100644 --- a/gcc/ada/s-finmas.ads +++ b/gcc/ada/s-finmas.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -111,9 +111,6 @@ package System.Finalization_Masters is function Finalization_Started (Master : Finalization_Master) return Boolean; -- Return the finalization status of a master - function Header_Offset return System.Storage_Elements.Storage_Offset; - -- Return the size of type FM_Node as Storage_Offset - function Header_Size return System.Storage_Elements.Storage_Count; -- Return the size of type FM_Node as Storage_Count diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb index 53302739457..2d6a3c6f477 100644 --- a/gcc/ada/s-htable.adb +++ b/gcc/ada/s-htable.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2013, AdaCore -- +-- Copyright (C) 1995-2015, AdaCore -- -- -- -- 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- -- @@ -149,7 +149,7 @@ package body System.HTable is else loop - Next_Elmt := Next (Elmt); + Next_Elmt := Next (Elmt); if Next_Elmt = Null_Ptr then return; diff --git a/gcc/ada/s-imgrea.adb b/gcc/ada/s-imgrea.adb index 075a5774000..827b5f578fb 100644 --- a/gcc/ada/s-imgrea.adb +++ b/gcc/ada/s-imgrea.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -147,12 +147,7 @@ package body System.Img_Real is is NFrac : constant Natural := Natural'Max (Aft, 1); Sign : Character; - X : aliased Long_Long_Float; - -- This is declared aliased because the expansion of X'Valid passes - -- X by access and JGNAT requires all access parameters to be aliased. - -- The Valid attribute probably needs to be handled via a different - -- expansion for JGNAT, and this use of aliased should be removed - -- once Valid is handled properly. ??? + X : Long_Long_Float; Scale : Integer; Expon : Integer; diff --git a/gcc/ada/s-mudido-affinity.adb b/gcc/ada/s-mudido-affinity.adb index 05e27719082..df3b4a83b51 100644 --- a/gcc/ada/s-mudido-affinity.adb +++ b/gcc/ada/s-mudido-affinity.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -119,11 +119,11 @@ package body System.Multiprocessors.Dispatching_Domains is end Create; function Create (Set : CPU_Set) return Dispatching_Domain is - ST_DD : aliased constant ST.Dispatching_Domain - := ST.Dispatching_Domain (Set); - subtype Rng is CPU_Range range - Get_First_CPU (ST_DD'Unrestricted_Access) .. - Get_Last_CPU (ST_DD'Unrestricted_Access); + ST_DD : aliased constant ST.Dispatching_Domain := + ST.Dispatching_Domain (Set); + First : constant CPU := Get_First_CPU (ST_DD'Unrestricted_Access); + Last : constant CPU_Range := Get_Last_CPU (ST_DD'Unrestricted_Access); + subtype Rng is CPU_Range range First .. Last; use type ST.Dispatching_Domain; use type ST.Dispatching_Domain_Access; @@ -134,7 +134,7 @@ package body System.Multiprocessors.Dispatching_Domains is New_System_Domain : ST.Dispatching_Domain := ST.System_Domain.all; - New_Domain : Dispatching_Domain; + ST_DD_Slice : constant ST.Dispatching_Domain := ST_DD (Rng); begin -- The set of processors for creating a dispatching domain must @@ -152,16 +152,27 @@ package body System.Multiprocessors.Dispatching_Domains is if Rng'Last > Number_Of_CPUs then raise Dispatching_Domain_Error with "CPU not supported by the target"; + end if; - elsif (ST_DD and not ST.System_Domain (Rng)) /= (Rng => False) then - raise Dispatching_Domain_Error with - "CPU not currently in System_Dispatching_Domain"; + declare + System_Domain_Slice : constant ST.Dispatching_Domain := + ST.System_Domain (Rng); + Actual : constant ST.Dispatching_Domain := + ST_DD_Slice and not System_Domain_Slice; + Expected : constant ST.Dispatching_Domain := (Rng => False); + begin + if Actual /= Expected then + raise Dispatching_Domain_Error with + "CPU not currently in System_Dispatching_Domain"; + end if; + end; - elsif Self /= Environment_Task then + if Self /= Environment_Task then raise Dispatching_Domain_Error with "only the environment task can create dispatching domains"; + end if; - elsif ST.Dispatching_Domains_Frozen then + if ST.Dispatching_Domains_Frozen then raise Dispatching_Domain_Error with "cannot create dispatching domain after call to main procedure"; end if; @@ -174,44 +185,44 @@ package body System.Multiprocessors.Dispatching_Domains is end if; end loop; - New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD; + New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD_Slice; if New_System_Domain = (New_System_Domain'Range => False) then raise Dispatching_Domain_Error with "would leave System_Dispatching_Domain empty"; end if; - New_Domain := new ST.Dispatching_Domain'(ST_DD); - - -- At this point we need to fix the processors belonging to the system - -- domain, and change the affinity of every task that has been created - -- and assigned to the system domain. - - ST.Initialization.Defer_Abort (Self); + return Result : constant Dispatching_Domain := + new ST.Dispatching_Domain'(ST_DD_Slice) + do + -- At this point we need to fix the processors belonging to the + -- system domain, and change the affinity of every task that has + -- been created and assigned to the system domain. - Lock_RTS; + ST.Initialization.Defer_Abort (Self); - ST.System_Domain (Rng) := New_System_Domain (Rng); - pragma Assert (ST.System_Domain.all = New_System_Domain); + Lock_RTS; - -- Iterate the list of tasks belonging to the default system - -- dispatching domain and set the appropriate affinity. + ST.System_Domain (Rng) := New_System_Domain (Rng); + pragma Assert (ST.System_Domain.all = New_System_Domain); - T := ST.All_Tasks_List; + -- Iterate the list of tasks belonging to the default system + -- dispatching domain and set the appropriate affinity. - while T /= null loop - if T.Common.Domain = ST.System_Domain then - Set_Task_Affinity (T); - end if; + T := ST.All_Tasks_List; - T := T.Common.All_Tasks_Link; - end loop; + while T /= null loop + if T.Common.Domain = ST.System_Domain then + Set_Task_Affinity (T); + end if; - Unlock_RTS; + T := T.Common.All_Tasks_Link; + end loop; - ST.Initialization.Undefer_Abort (Self); + Unlock_RTS; - return New_Domain; + ST.Initialization.Undefer_Abort (Self); + end return; end Create; ----------------------------- diff --git a/gcc/ada/s-multip.adb b/gcc/ada/s-multip.adb index 901cda0c654..239d5e0ee73 100644 --- a/gcc/ada/s-multip.adb +++ b/gcc/ada/s-multip.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2015, Free Software Foundation, Inc. -- -- -- --- GNARL is free software; you can redistribute it and/or modify it under -- +-- 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- -- diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 46fdd006784..dad157861da 100644 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2014, AdaCore -- +-- Copyright (C) 1995-2015, AdaCore -- -- -- -- 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- -- @@ -55,11 +55,13 @@ package body System.OS_Lib is pragma Import (C, Dup2, "__gnat_dup2"); function Copy_Attributes - (From, To : System.Address; - Mode : Integer) return Integer; + (From : System.Address; + To : System.Address; + Mode : Integer) return Integer; pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); -- Mode = 0 - copy only time stamps. -- Mode = 1 - copy time stamps and read/write/execute attributes + -- Mode = 2 - copy read/write/execute attributes On_Windows : constant Boolean := Directory_Separator = '\'; -- An indication that we are on Windows. Used in Normalize_Pathname, to @@ -186,8 +188,14 @@ package body System.OS_Lib is is Max_Args : constant Integer := Arg_String'Length; New_Argv : Argument_List (1 .. Max_Args); - New_Argc : Natural := 0; Idx : Integer; + New_Argc : Natural := 0; + + Cleaned : String (1 .. Arg_String'Length); + Cleaned_Idx : Natural; + -- A cleaned up version of the argument. This function is taking + -- backslash escapes when computing the bounds for arguments. It is + -- then removing the extra backslashes from the argument. begin Idx := Arg_String'First; @@ -196,12 +204,11 @@ package body System.OS_Lib is exit when Idx > Arg_String'Last; declare - Quoted : Boolean := False; Backqd : Boolean := False; - Old_Idx : Integer; + Quoted : Boolean := False; begin - Old_Idx := Idx; + Cleaned_Idx := Cleaned'First; loop -- An unquoted space is the end of an argument @@ -217,25 +224,34 @@ package body System.OS_Lib is and then Arg_String (Idx) = '"' then Quoted := True; + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; -- End of a quoted string and end of an argument elsif (Quoted and not Backqd) and then Arg_String (Idx) = '"' then + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; Idx := Idx + 1; exit; - -- Following character is backquoted - - elsif Arg_String (Idx) = '\' then - Backqd := True; - -- Turn off backquoting after advancing one character elsif Backqd then Backqd := False; + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; + + -- Following character is backquoted + elsif Arg_String (Idx) = '\' then + Backqd := True; + + else + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; end if; Idx := Idx + 1; @@ -246,7 +262,7 @@ package body System.OS_Lib is New_Argc := New_Argc + 1; New_Argv (New_Argc) := - new String'(Arg_String (Old_Idx .. Idx - 1)); + new String'(Cleaned (Cleaned'First .. Cleaned_Idx - 1)); -- Skip extraneous spaces @@ -310,7 +326,7 @@ package body System.OS_Lib is -- Returns pathname Dir concatenated with File adding the directory -- separator only if needed. - procedure Copy (From, To : File_Descriptor); + procedure Copy (From : File_Descriptor; To : File_Descriptor); -- Read data from From and place them into To. In both cases the -- operations uses the current file position. Raises Constraint_Error -- if a problem occurs during the copy. @@ -323,11 +339,6 @@ package body System.OS_Lib is ---------------- function Build_Path (Dir : String; File : String) return String is - Res : String (1 .. Dir'Length + File'Length + 1); - - Base_File_Ptr : Integer; - -- The base file name is File (Base_File_Ptr + 1 .. File'Last) - function Is_Dirsep (C : Character) return Boolean; pragma Inline (Is_Dirsep); -- Returns True if C is a directory separator. On Windows we @@ -342,6 +353,13 @@ package body System.OS_Lib is return C = Directory_Separator or else C = '/'; end Is_Dirsep; + -- Local variables + + Base_File_Ptr : Integer; + -- The base file name is File (Base_File_Ptr + 1 .. File'Last) + + Res : String (1 .. Dir'Length + File'Length + 1); + -- Start of processing for Build_Path begin @@ -378,7 +396,7 @@ package body System.OS_Lib is -- Copy -- ---------- - procedure Copy (From, To : File_Descriptor) is + procedure Copy (From : File_Descriptor; To : File_Descriptor) is Buf_Size : constant := 200_000; type Buf is array (1 .. Buf_Size) of Character; type Buf_Ptr is access Buf; @@ -476,7 +494,6 @@ package body System.OS_Lib is C_To (C_To'Last) := ASCII.NUL; case Preserve is - when Time_Stamps => if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then raise Copy_Error; @@ -607,11 +624,55 @@ package body System.OS_Lib is Free (Ada_Pathname); end Copy_File; + -------------------------- + -- Copy_File_Attributes -- + -------------------------- + + procedure Copy_File_Attributes + (From : String; + To : String; + Success : out Boolean; + Copy_Timestamp : Boolean := True; + Copy_Permissions : Boolean := True) + is + F : aliased String (1 .. From'Length + 1); + Mode : Integer; + T : aliased String (1 .. To'Length + 1); + + begin + if Copy_Timestamp then + if Copy_Permissions then + Mode := 1; + else + Mode := 0; + end if; + else + if Copy_Permissions then + Mode := 2; + else + Success := True; + return; -- nothing to do + end if; + end if; + + F (1 .. From'Length) := From; + F (F'Last) := ASCII.NUL; + + T (1 .. To'Length) := To; + T (T'Last) := ASCII.NUL; + + Success := Copy_Attributes (F'Address, T'Address, Mode) /= -1; + end Copy_File_Attributes; + ---------------------- -- Copy_Time_Stamps -- ---------------------- - procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is + procedure Copy_Time_Stamps + (Source : String; + Dest : String; + Success : out Boolean) + is begin if Is_Regular_File (Source) and then Is_Writable_File (Dest) then declare @@ -638,8 +699,9 @@ package body System.OS_Lib is end Copy_Time_Stamps; procedure Copy_Time_Stamps - (Source, Dest : C_File_Name; - Success : out Boolean) + (Source : C_File_Name; + Dest : C_File_Name; + Success : out Boolean) is Ada_Source : String_Access := To_Path_String_Access @@ -712,10 +774,11 @@ package body System.OS_Lib is ----------------------------- function Create_Output_Text_File (Name : String) return File_Descriptor is - function C_Create_File - (Name : C_File_Name) return File_Descriptor; + function C_Create_File (Name : C_File_Name) return File_Descriptor; pragma Import (C, C_Create_File, "__gnat_create_output_file"); + C_Name : String (1 .. Name'Length + 1); + begin C_Name (1 .. Name'Length) := Name; C_Name (C_Name'Last) := ASCII.NUL; @@ -787,10 +850,11 @@ package body System.OS_Lib is function Create_New_Output_Text_File (Name : String) return File_Descriptor is - function C_Create_File - (Name : C_File_Name) return File_Descriptor; + function C_Create_File (Name : C_File_Name) return File_Descriptor; pragma Import (C, C_Create_File, "__gnat_create_output_file_new"); + C_Name : String (1 .. Name'Length + 1); + begin C_Name (1 .. Name'Length) := Name; C_Name (C_Name'Last) := ASCII.NUL; @@ -1022,9 +1086,9 @@ package body System.OS_Lib is procedure Get_Suffix_Ptr (Length, Ptr : Address); pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr"); - Suffix_Ptr : Address; - Suffix_Length : Integer; Result : String_Access; + Suffix_Length : Integer; + Suffix_Ptr : Address; begin Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); @@ -1045,9 +1109,9 @@ package body System.OS_Lib is procedure Get_Suffix_Ptr (Length, Ptr : Address); pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr"); - Suffix_Ptr : Address; - Suffix_Length : Integer; Result : String_Access; + Suffix_Length : Integer; + Suffix_Ptr : Address; begin Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); @@ -1068,9 +1132,9 @@ package body System.OS_Lib is procedure Get_Suffix_Ptr (Length, Ptr : Address); pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr"); - Suffix_Ptr : Address; - Suffix_Length : Integer; Result : String_Access; + Suffix_Length : Integer; + Suffix_Ptr : Address; begin Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); @@ -1092,8 +1156,8 @@ package body System.OS_Lib is pragma Import (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension"); - Suffix_Length : Integer; Result : String_Access; + Suffix_Length : Integer; begin Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr)); @@ -1116,8 +1180,8 @@ package body System.OS_Lib is pragma Import (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension"); - Suffix_Length : Integer; Result : String_Access; + Suffix_Length : Integer; begin Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr)); @@ -1140,8 +1204,8 @@ package body System.OS_Lib is pragma Import (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension"); - Suffix_Length : Integer; Result : String_Access; + Suffix_Length : Integer; begin Suffix_Length := Integer (CRTL.strlen (Target_Object_Ext_Ptr)); @@ -1294,7 +1358,13 @@ package body System.OS_Lib is Second : out Second_Type) is procedure To_GM_Time - (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address); + (P_Time_T : Address; + P_Year : Address; + P_Month : Address; + P_Day : Address; + P_Hours : Address; + P_Mins : Address; + P_Secs : Address); pragma Import (C, To_GM_Time, "__gnat_to_gm_time"); T : OS_Time := Date; @@ -1311,8 +1381,13 @@ package body System.OS_Lib is Locked_Processing : begin SSL.Lock_Task.all; To_GM_Time - (T'Address, Y'Address, Mo'Address, D'Address, - H'Address, Mn'Address, S'Address); + (P_Time_T => T'Address, + P_Year => Y'Address, + P_Month => Mo'Address, + P_Day => D'Address, + P_Hours => H'Address, + P_Mins => Mn'Address, + P_Secs => S'Address); SSL.Unlock_Task.all; exception @@ -1342,12 +1417,26 @@ package body System.OS_Lib is Second : Second_Type) return OS_Time is procedure To_OS_Time - (P_Time_T : Address; Year, Month, Day, Hours, Mins, Secs : Integer); + (P_Time_T : Address; + P_Year : Integer; + P_Month : Integer; + P_Day : Integer; + P_Hours : Integer; + P_Mins : Integer; + P_Secs : Integer); pragma Import (C, To_OS_Time, "__gnat_to_os_time"); + Result : OS_Time; + begin To_OS_Time - (Result'Address, Year - 1900, Month - 1, Day, Hour, Minute, Second); + (P_Time_T => Result'Address, + P_Year => Year - 1900, + P_Month => Month - 1, + P_Day => Day, + P_Hours => Hour, + P_Mins => Minute, + P_Secs => Second); return Result; end GM_Time_Of; @@ -1497,6 +1586,25 @@ package body System.OS_Lib is return Is_Writable_File (F_Name'Address); end Is_Writable_File; + ---------- + -- Kill -- + ---------- + + procedure Kill (Pid : Process_Id; Hard_Kill : Boolean := True) is + SIGKILL : constant := 9; + SIGINT : constant := 2; + + procedure C_Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer); + pragma Import (C, C_Kill, "__gnat_kill"); + + begin + if Hard_Kill then + C_Kill (Pid, SIGKILL, 1); + else + C_Kill (Pid, SIGINT, 1); + end if; + end Kill; + ------------------------- -- Locate_Exec_On_Path -- ------------------------- @@ -1611,9 +1719,10 @@ package body System.OS_Lib is (Program_Name : String; Args : Argument_List) return Process_Id is - Pid : Process_Id; Junk : Integer; pragma Warnings (Off, Junk); + Pid : Process_Id; + begin Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False); return Pid; @@ -1625,9 +1734,9 @@ package body System.OS_Lib is Output_File_Descriptor : File_Descriptor; Err_To_Out : Boolean := True) return Process_Id is - Saved_Output : File_Descriptor; - Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning Pid : Process_Id; + Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning + Saved_Output : File_Descriptor; begin if Output_File_Descriptor = Invalid_FD then @@ -1684,8 +1793,9 @@ package body System.OS_Lib is return Invalid_Pid; else - Result := Non_Blocking_Spawn - (Program_Name, Args, Output_File_Descriptor, Err_To_Out); + Result := + Non_Blocking_Spawn + (Program_Name, Args, Output_File_Descriptor, Err_To_Out); -- Close the file just created for the output, as the file descriptor -- cannot be used anywhere, being a local value. It is safe to do @@ -1704,15 +1814,14 @@ package body System.OS_Lib is Stdout_File : String; Stderr_File : String) return Process_Id is - Stdout_FD : constant File_Descriptor := - Create_Output_Text_File (Stdout_File); Stderr_FD : constant File_Descriptor := - Create_Output_Text_File (Stderr_File); + Create_Output_Text_File (Stderr_File); + Stdout_FD : constant File_Descriptor := + Create_Output_Text_File (Stdout_File); - Saved_Output : File_Descriptor; + Result : Process_Id; Saved_Error : File_Descriptor; - - Result : Process_Id; + Saved_Output : File_Descriptor; begin -- Do not attempt to spawn if the output files could not be created @@ -1751,7 +1860,6 @@ package body System.OS_Lib is ------------------------- procedure Normalize_Arguments (Args : in out Argument_List) is - procedure Quote_Argument (Arg : in out String_Access); -- Add quote around argument if it contains spaces (or HT characters) @@ -1764,9 +1872,9 @@ package body System.OS_Lib is -------------------- procedure Quote_Argument (Arg : in out String_Access) is - Res : String (1 .. Arg'Length * 2); J : Positive := 1; Quote_Needed : Boolean := False; + Res : String (1 .. Arg'Length * 2); begin if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then @@ -1863,33 +1971,19 @@ package body System.OS_Lib is Resolve_Links : Boolean := True; Case_Sensitive : Boolean := True) return String is - Max_Path : Integer; - pragma Import (C, Max_Path, "__gnat_max_path_len"); - -- Maximum length of a path name - procedure Get_Current_Dir (Dir : System.Address; Length : System.Address); pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); - Path_Buffer : String (1 .. Max_Path + Max_Path + 2); - End_Path : Natural := 0; - Link_Buffer : String (1 .. Max_Path + 2); - Status : Integer; - Last : Positive; - Start : Natural; - Finish : Positive; - - Max_Iterations : constant := 500; - function Get_File_Names_Case_Sensitive return Integer; pragma Import (C, Get_File_Names_Case_Sensitive, "__gnat_get_file_names_case_sensitive"); - Fold_To_Lower_Case : constant Boolean := - not Case_Sensitive - and then Get_File_Names_Case_Sensitive = 0; + Max_Path : Integer; + pragma Import (C, Max_Path, "__gnat_max_path_len"); + -- Maximum length of a path name function Readlink (Path : System.Address; @@ -1903,9 +1997,9 @@ package body System.OS_Lib is (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); -- Convert possible foreign file syntax to canonical form - The_Name : String (1 .. Name'Length + 1); - Canonical_File_Addr : System.Address; - Canonical_File_Len : Integer; + Fold_To_Lower_Case : constant Boolean := + not Case_Sensitive + and then Get_File_Names_Case_Sensitive = 0; function Final_Value (S : String) return String; -- Make final adjustment to the returned string. This function strips @@ -2019,6 +2113,22 @@ package body System.OS_Lib is end if; end Get_Directory; + -- Local variables + + Max_Iterations : constant := 500; + + Canonical_File_Addr : System.Address; + Canonical_File_Len : Integer; + + End_Path : Natural := 0; + Finish : Positive; + Last : Positive; + Link_Buffer : String (1 .. Max_Path + 2); + Path_Buffer : String (1 .. Max_Path + Max_Path + 2); + Start : Natural; + Status : Integer; + The_Name : String (1 .. Name'Length + 1); + -- Start of processing for Normalize_Pathname begin @@ -2203,15 +2313,12 @@ package body System.OS_Lib is if Last = 1 then return (1 => Directory_Separator); else - if Fold_To_Lower_Case then System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1)); end if; return Path_Buffer (1 .. Last - 1); - end if; - else Path_Buffer (Last + 1 .. End_Path - 2) := Path_Buffer (Last + 3 .. End_Path); @@ -2261,9 +2368,11 @@ package body System.OS_Lib is begin Path_Buffer (Finish + 1) := ASCII.NUL; - Status := Readlink (Path_Buffer'Address, - Link_Buffer'Address, - Link_Buffer'Length); + Status := + Readlink + (Path => Path_Buffer'Address, + Buf => Link_Buffer'Address, + Bufsiz => Link_Buffer'Length); Path_Buffer (Finish + 1) := Saved; end; @@ -2598,9 +2707,10 @@ package body System.OS_Lib is (Program_Name : String; Args : Argument_List) return Integer is - Result : Integer; Junk : Process_Id; pragma Warnings (Off, Junk); + Result : Integer; + begin Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True); return Result; @@ -2622,8 +2732,8 @@ package body System.OS_Lib is Return_Code : out Integer; Err_To_Out : Boolean := True) is - Saved_Output : File_Descriptor; Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning + Saved_Output : File_Descriptor; begin -- Set standard output and error to the temporary file @@ -2694,7 +2804,6 @@ package body System.OS_Lib is Pid : out Process_Id; Blocking : Boolean) is - procedure Spawn (Args : Argument_List); -- Call Spawn with given argument list @@ -2709,8 +2818,8 @@ package body System.OS_Lib is type Chars is array (Positive range <>) of aliased Character; type Char_Ptr is access constant Character; - Command_Len : constant Positive := Program_Name'Length + 1 - + Args_Length (Args); + Command_Len : constant Positive := Program_Name'Length + 1 + + Args_Length (Args); Command_Last : Natural := 0; Command : aliased Chars (1 .. Command_Len); -- Command contains all characters of the Program_Name and Args, all diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index abffa531aa8..dcc1deab687 100644 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -48,9 +48,6 @@ -- be used by other predefined packages. User access to this package is via -- a renaming of this package in GNAT.OS_Lib (file g-os_lib.ads). --- Note: a distinct body for this spec is included in the .NET runtime library --- and must be kept in sync with changes made in this file. - pragma Compiler_Unit_Warning; with System; @@ -69,14 +66,14 @@ package System.OS_Lib is subtype String_Access is Strings.String_Access; - function "=" (Left, Right : String_Access) return Boolean + function "=" (Left : String_Access; Right : String_Access) return Boolean renames Strings."="; procedure Free (X : in out String_Access) renames Strings.Free; subtype String_List is Strings.String_List; - function "=" (Left, Right : String_List) return Boolean + function "=" (Left : String_List; Right : String_List) return Boolean renames Strings."="; function "&" (Left : String_Access; Right : String_Access) @@ -90,11 +87,11 @@ package System.OS_Lib is subtype String_List_Access is Strings.String_List_Access; - function "=" (Left, Right : String_List_Access) return Boolean - renames Strings."="; + function "=" + (Left : String_List_Access; + Right : String_List_Access) return Boolean renames Strings."="; - procedure Free (Arg : in out String_List_Access) - renames Strings.Free; + procedure Free (Arg : in out String_List_Access) renames Strings.Free; --------------------- -- Time/Date Stuff -- @@ -113,6 +110,14 @@ package System.OS_Lib is Invalid_Time : constant OS_Time; -- A special unique value used to flag an invalid time stamp value + function "<" (X : OS_Time; Y : OS_Time) return Boolean; + function ">" (X : OS_Time; Y : OS_Time) return Boolean; + function ">=" (X : OS_Time; Y : OS_Time) return Boolean; + function "<=" (X : OS_Time; Y : OS_Time) return Boolean; + -- Basic comparison operators on OS_Time with obvious meanings. Note that + -- these have Intrinsic convention, so for example it is not permissible + -- to create accesses to any of these functions. + subtype Year_Type is Integer range 1900 .. 2099; subtype Month_Type is Integer range 1 .. 12; subtype Day_Type is Integer range 1 .. 31; @@ -124,6 +129,10 @@ package System.OS_Lib is function Current_Time return OS_Time; -- Return the system clock value as OS_Time + function Current_Time_String return String; + -- Returns current local time in the form YYYY-MM-DD HH:MM:SS. The result + -- has bounds 1 .. 19. + function GM_Year (Date : OS_Time) return Year_Type; function GM_Month (Date : OS_Time) return Month_Type; function GM_Day (Date : OS_Time) return Day_Type; @@ -132,14 +141,6 @@ package System.OS_Lib is function GM_Second (Date : OS_Time) return Second_Type; -- Functions to extract information from OS_Time value in GMT form - function "<" (X, Y : OS_Time) return Boolean; - function ">" (X, Y : OS_Time) return Boolean; - function ">=" (X, Y : OS_Time) return Boolean; - function "<=" (X, Y : OS_Time) return Boolean; - -- Basic comparison operators on OS_Time with obvious meanings. Note that - -- these have Intrinsic convention, so for example it is not permissible - -- to create accesses to any of these functions. - procedure GM_Split (Date : OS_Time; Year : out Year_Type; @@ -163,10 +164,6 @@ package System.OS_Lib is -- component parts to be interpreted in the local time zone, and returns -- an OS_Time. Returns Invalid_Time if the creation fails. - function Current_Time_String return String; - -- Returns current local time in the form YYYY-MM-DD HH:MM:SS. The result - -- has bounds 1 .. 19. - ---------------- -- File Stuff -- ---------------- @@ -194,6 +191,87 @@ package System.OS_Lib is Invalid_FD : constant File_Descriptor := -1; -- File descriptor returned when error in opening/creating file + procedure Close (FD : File_Descriptor; Status : out Boolean); + -- Close file referenced by FD. Status is False if the underlying service + -- failed. Reasons for failure include: disk full, disk quotas exceeded + -- and invalid file descriptor (the file may have been closed twice). + + procedure Close (FD : File_Descriptor); + -- Close file referenced by FD. This form is used when the caller wants to + -- ignore any possible error (see above for error cases). + + type Copy_Mode is + (Copy, + -- Copy the file. It is an error if the target file already exists. The + -- time stamps and other file attributes are preserved in the copy. + + Overwrite, + -- If the target file exists, the file is replaced otherwise the file + -- is just copied. The time stamps and other file attributes are + -- preserved in the copy. + + Append); + -- If the target file exists, the contents of the source file is + -- appended at the end. Otherwise the source file is just copied. The + -- time stamps and other file attributes are preserved if the + -- destination file does not exist. + + type Attribute is + (Time_Stamps, + -- Copy time stamps from source file to target file. All other + -- attributes are set to normal default values for file creation. + + Full, + -- All attributes are copied from the source file to the target file. + -- This includes the timestamps, and for example also includes + -- read/write/execute attributes in Unix systems. + + None); + -- No attributes are copied. All attributes including the time stamp + -- values are set to normal default values for file creation. + + -- Note: The default is Time_Stamps, which corresponds to the normal + -- default on Windows style systems. Full corresponds to the typical + -- effect of "cp -p" on Unix systems, and None corresponds to the typical + -- effect of "cp" on Unix systems. + + -- Note: Time_Stamps and Full are not supported on VxWorks 5 + + procedure Copy_File + (Name : String; + Pathname : String; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps); + -- Copy a file. Name must designate a single file (no wild cards allowed). + -- Pathname can be a filename or directory name. In the latter case Name + -- is copied into the directory preserving the same file name. Mode + -- defines the kind of copy, see above with the default being a normal + -- copy in which the target file must not already exist. Success is set to + -- True or False indicating if the copy is successful (depending on the + -- specified Mode). + + procedure Copy_File_Attributes + (From : String; + To : String; + Success : out Boolean; + Copy_Timestamp : Boolean := True; + Copy_Permissions : Boolean := True); + -- Copy some of the file attributes from one file to another. Both files + -- must exist, or Success is set to False. + + procedure Copy_Time_Stamps + (Source : String; + Dest : String; + Success : out Boolean); + -- Copy Source file time stamps (last modification and last access time + -- stamps) to Dest file. Source and Dest must be valid filenames, + -- furthermore Dest must be writable. Success will be set to True if the + -- operation was successful and False otherwise. + -- + -- Note: this procedure is not supported on VxWorks 5. On this platform, + -- Success is always set to False. + type Mode is (Binary, Text); for Mode'Size use Integer'Size; for Mode use (Binary => 0, Text => 1); @@ -205,26 +283,6 @@ package System.OS_Lib is -- of Text where appropriate allows programs to take a portable Unix view -- of DOS-format files and process them appropriately. - function Open_Read - (Name : String; - Fmode : Mode) return File_Descriptor; - -- Open file Name for reading, returning its file descriptor. File - -- descriptor returned is Invalid_FD if the file cannot be opened. - - function Open_Read_Write - (Name : String; - Fmode : Mode) return File_Descriptor; - -- Open file Name for both reading and writing, returning its file - -- descriptor. File descriptor returned is Invalid_FD if the file - -- cannot be opened. - - function Open_Append - (Name : String; - Fmode : Mode) return File_Descriptor; - -- Opens file Name for appending, returning its file descriptor. File - -- descriptor returned is Invalid_FD if the file cannot be successfully - -- opened. - function Create_File (Name : String; Fmode : Mode) return File_Descriptor; @@ -233,11 +291,6 @@ package System.OS_Lib is -- overwritten. File descriptor returned is Invalid_FD if file cannot be -- successfully created. - function Create_Output_Text_File (Name : String) return File_Descriptor; - -- Creates new text file with given name suitable to redirect standard - -- output, returning file descriptor. File descriptor returned is - -- Invalid_FD if file cannot be successfully created. - function Create_New_File (Name : String; Fmode : Mode) return File_Descriptor; @@ -246,6 +299,11 @@ package System.OS_Lib is -- that it fails if the file already exists. File descriptor returned is -- Invalid_FD if the file exists or cannot be created. + function Create_Output_Text_File (Name : String) return File_Descriptor; + -- Creates new text file with given name suitable to redirect standard + -- output, returning file descriptor. File descriptor returned is + -- Invalid_FD if file cannot be successfully created. + Temp_File_Len : constant Integer := 12; -- Length of name returned by Create_Temp_File call (GNAT-XXXXXX & NUL) @@ -299,126 +357,133 @@ package System.OS_Lib is -- There is no race condition problem between processes trying to create -- temp files at the same time in the same directory. - procedure Close (FD : File_Descriptor; Status : out Boolean); - -- Close file referenced by FD. Status is False if the underlying service - -- failed. Reasons for failure include: disk full, disk quotas exceeded - -- and invalid file descriptor (the file may have been closed twice). - - procedure Close (FD : File_Descriptor); - -- Close file referenced by FD. This form is used when the caller wants to - -- ignore any possible error (see above for error cases). - - procedure Set_Close_On_Exec - (FD : File_Descriptor; - Close_On_Exec : Boolean; - Status : out Boolean); - -- When Close_On_Exec is True, mark FD to be closed automatically when new - -- program is executed by the calling process (i.e. prevent FD from being - -- inherited by child processes). When Close_On_Exec is False, mark FD to - -- not be closed on exec (i.e. allow it to be inherited). Status is False - -- if the operation could not be performed. - procedure Delete_File (Name : String; Success : out Boolean); -- Deletes file. Success is set True or False indicating if the delete is -- successful. - procedure Rename_File - (Old_Name : String; - New_Name : String; - Success : out Boolean); - -- Rename a file. Success is set True or False indicating if the rename is - -- successful or not. - -- - -- WARNING: In one very important respect, this function is significantly - -- non-portable. If New_Name already exists then on Unix systems, the call - -- deletes the existing file, and the call signals success. On Windows, the - -- call fails, without doing the rename operation. See also the procedure - -- Ada.Directories.Rename, which portably provides the windows semantics, - -- i.e. fails if the output file already exists. + function File_Length (FD : File_Descriptor) return Long_Integer; + pragma Import (C, File_Length, "__gnat_file_length_long"); - -- The following defines the mode for the Copy_File procedure below. Note - -- that "time stamps and other file attributes" in the descriptions below - -- refers to the creation and last modification times, and also the file - -- access (read/write/execute) status flags. + type Large_File_Size is range -2**63 .. 2**63 - 1; + -- Maximum supported size for a file (8 exabytes = 8 million terabytes, + -- should be enough to accomodate all possible needs for quite a while). - type Copy_Mode is - (Copy, - -- Copy the file. It is an error if the target file already exists. The - -- time stamps and other file attributes are preserved in the copy. + function File_Length64 (FD : File_Descriptor) return Large_File_Size; + pragma Import (C, File_Length64, "__gnat_file_length"); + -- Get length of file from file descriptor FD - Overwrite, - -- If the target file exists, the file is replaced otherwise the file - -- is just copied. The time stamps and other file attributes are - -- preserved in the copy. + function File_Time_Stamp (Name : String) return OS_Time; + -- Given the name of a file or directory, Name, obtains and returns the + -- time stamp. This function can be used for an unopened file. Returns + -- Invalid_Time is Name doesn't correspond to an existing file. - Append); - -- If the target file exists, the contents of the source file is - -- appended at the end. Otherwise the source file is just copied. The - -- time stamps and other file attributes are preserved if the - -- destination file does not exist. + function File_Time_Stamp (FD : File_Descriptor) return OS_Time; + -- Get time stamp of file from file descriptor FD Returns Invalid_Time is + -- FD doesn't correspond to an existing file. - type Attribute is - (Time_Stamps, - -- Copy time stamps from source file to target file. All other - -- attributes are set to normal default values for file creation. + function Get_Debuggable_Suffix return String_Access; + -- Return the debuggable suffix convention. Usually this is the same as + -- the convention for Get_Executable_Suffix. The result is allocated on + -- the heap and should be freed after use to avoid storage leaks. - Full, - -- All attributes are copied from the source file to the target file. - -- This includes the timestamps, and for example also includes - -- read/write/execute attributes in Unix systems. + function Get_Executable_Suffix return String_Access; + -- Return the executable suffix convention. The result is allocated on the + -- heap and should be freed after use to avoid storage leaks. - None); - -- No attributes are copied. All attributes including the time stamp - -- values are set to normal default values for file creation. + function Get_Object_Suffix return String_Access; + -- Return the object suffix convention. The result is allocated on the heap + -- and should be freed after use to avoid storage leaks. - -- Note: The default is Time_Stamps, which corresponds to the normal - -- default on Windows style systems. Full corresponds to the typical - -- effect of "cp -p" on Unix systems, and None corresponds to the typical - -- effect of "cp" on Unix systems. + function Get_Target_Debuggable_Suffix return String_Access; + -- Return the target debuggable suffix convention. Usually this is the same + -- as the convention for Get_Executable_Suffix. The result is allocated on + -- the heap and should be freed after use to avoid storage leaks. - -- Note: Time_Stamps and Full are not supported on VxWorks 5 + function Get_Target_Executable_Suffix return String_Access; + -- Return the target executable suffix convention. The result is allocated + -- on the heap and should be freed after use to avoid storage leaks. - procedure Copy_File - (Name : String; - Pathname : String; - Success : out Boolean; - Mode : Copy_Mode := Copy; - Preserve : Attribute := Time_Stamps); - -- Copy a file. Name must designate a single file (no wild cards allowed). - -- Pathname can be a filename or directory name. In the latter case Name - -- is copied into the directory preserving the same file name. Mode - -- defines the kind of copy, see above with the default being a normal - -- copy in which the target file must not already exist. Success is set to - -- True or False indicating if the copy is successful (depending on the - -- specified Mode). - -- - procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean); - -- Copy Source file time stamps (last modification and last access time - -- stamps) to Dest file. Source and Dest must be valid filenames, - -- furthermore Dest must be writable. Success will be set to True if the - -- operation was successful and False otherwise. + function Get_Target_Object_Suffix return String_Access; + -- Return the target object suffix convention. The result is allocated on + -- the heap and should be freed after use to avoid storage leaks. + + function Is_Absolute_Path (Name : String) return Boolean; + -- Returns True if Name is an absolute path name, i.e. it designates a + -- file or directory absolutely rather than relative to another directory. + + function Is_Directory (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of a directory. + -- Returns True if so, False otherwise. Name may be an absolute path + -- name or a relative path name, including a simple file name. If it is + -- a relative path name, it is relative to the current working directory. + + function Is_Executable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is executable. Returns True if so, False otherwise. Note that this + -- function simply interrogates the file attributes (e.g. using the C + -- function stat), so it does not indicate a situation in which a file may + -- not actually be readable due to some other process having exclusive + -- access. + + function Is_Readable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is readable. Returns True if so, False otherwise. Note that this + -- function simply interrogates the file attributes (e.g. using the C + -- function stat), so it does not indicate a situation in which a file may + -- not actually be readable due to some other process having exclusive + -- access. + + function Is_Regular_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing + -- regular file. Returns True if so, False otherwise. Name may be an + -- absolute path name or a relative path name, including a simple file + -- name. If it is a relative path name, it is relative to the current + -- working directory. + + function Is_Symbolic_Link (Name : String) return Boolean; + -- Determines if the given string, Name, is the path of a symbolic link on + -- systems that support it. Returns True if so, False if the path is not a + -- symbolic link or if the system does not support symbolic links. -- - -- Note: this procedure is not supported on VxWorks 5. On this platform, - -- Success is always set to False. + -- A symbolic link is an indirect pointer to a file; its directory entry + -- contains the name of the file to which it is linked. Symbolic links may + -- span file systems and may refer to directories. - procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time); - -- Given the name of a file or directory, Name, set the last modification - -- time stamp. This function must be used for an unopened file. + function Is_Writable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is writable. Returns True if so, False otherwise. Note that this + -- function simply interrogates the file attributes (e.g. using the C + -- function stat), so it does not indicate a situation in which a file may + -- not actually be writeable due to some other process having exclusive + -- access. - function Read - (FD : File_Descriptor; - A : System.Address; - N : Integer) return Integer; - -- Read N bytes to address A from file referenced by FD. Returned value is - -- count of bytes actually read, which can be less than N at EOF. + function Locate_Exec_On_Path (Exec_Name : String) return String_Access; + -- Try to locate an executable whose name is given by Exec_Name in the + -- directories listed in the environment Path. If the Exec_Name does not + -- have the executable suffix, it will be appended before the search. + -- Otherwise works like Locate_Regular_File below. If the executable is + -- not found, null is returned. + -- + -- Note that this function allocates memory for the returned value. This + -- memory needs to be deallocated after use. - function Write - (FD : File_Descriptor; - A : System.Address; - N : Integer) return Integer; - -- Write N bytes from address A to file referenced by FD. The returned - -- value is the number of bytes written, which can be less than N if a - -- disk full condition was detected. + function Locate_Regular_File + (File_Name : String; + Path : String) return String_Access; + -- Try to locate a regular file whose name is given by File_Name in the + -- directories listed in Path. If a file is found, its full pathname is + -- returned; otherwise, a null pointer is returned. If the File_Name given + -- is an absolute pathname, then Locate_Regular_File just checks that the + -- file exists and is a regular file. Otherwise, if the File_Name given + -- includes directory information, Locate_Regular_File first checks if the + -- file exists relative to the current directory. If it does not, or if + -- the File_Name given is a simple file name, the Path argument is parsed + -- according to OS conventions, and for each directory in the Path a check + -- is made if File_Name is a relative pathname of a regular file from that + -- directory. + -- + -- Note that this function allocates some memory for the returned value. + -- This memory needs to be deallocated after use. Seek_Cur : constant := 1; Seek_End : constant := 2; @@ -434,26 +499,6 @@ package System.OS_Lib is -- to the current position (origin = SEEK_CUR), end of file (origin = -- SEEK_END), or start of file (origin = SEEK_SET). - type Large_File_Size is range -2**63 .. 2**63 - 1; - -- Maximum supported size for a file (8 exabytes = 8 million terabytes, - -- should be enough to accomodate all possible needs for quite a while). - - function File_Length (FD : File_Descriptor) return Long_Integer; - pragma Import (C, File_Length, "__gnat_file_length_long"); - - function File_Length64 (FD : File_Descriptor) return Large_File_Size; - pragma Import (C, File_Length64, "__gnat_file_length"); - -- Get length of file from file descriptor FD - - function File_Time_Stamp (Name : String) return OS_Time; - -- Given the name of a file or directory, Name, obtains and returns the - -- time stamp. This function can be used for an unopened file. Returns - -- Invalid_Time is Name doesn't correspond to an existing file. - - function File_Time_Stamp (FD : File_Descriptor) return OS_Time; - -- Get time stamp of file from file descriptor FD Returns Invalid_Time is - -- FD doesn't correspond to an existing file. - function Normalize_Pathname (Name : String; Directory : String := ""; @@ -496,66 +541,61 @@ package System.OS_Lib is -- results. If Case_Sensitive is set to True, this function does not change -- the casing of file and directory names. - function Is_Absolute_Path (Name : String) return Boolean; - -- Returns True if Name is an absolute path name, i.e. it designates a - -- file or directory absolutely rather than relative to another directory. - - function Is_Regular_File (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of an existing - -- regular file. Returns True if so, False otherwise. Name may be an - -- absolute path name or a relative path name, including a simple file - -- name. If it is a relative path name, it is relative to the current - -- working directory. - - function Is_Directory (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of a directory. - -- Returns True if so, False otherwise. Name may be an absolute path - -- name or a relative path name, including a simple file name. If it is - -- a relative path name, it is relative to the current working directory. + function Open_Append + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Opens file Name for appending, returning its file descriptor. File + -- descriptor returned is Invalid_FD if the file cannot be successfully + -- opened. - function Is_Readable_File (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of an existing file - -- that is readable. Returns True if so, False otherwise. Note that this - -- function simply interrogates the file attributes (e.g. using the C - -- function stat), so it does not indicate a situation in which a file may - -- not actually be readable due to some other process having exclusive - -- access. + function Open_Read + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Open file Name for reading, returning its file descriptor. File + -- descriptor returned is Invalid_FD if the file cannot be opened. - function Is_Executable_File (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of an existing file - -- that is executable. Returns True if so, False otherwise. Note that this - -- function simply interrogates the file attributes (e.g. using the C - -- function stat), so it does not indicate a situation in which a file may - -- not actually be readable due to some other process having exclusive - -- access. + function Open_Read_Write + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Open file Name for both reading and writing, returning its file + -- descriptor. File descriptor returned is Invalid_FD if the file + -- cannot be opened. - function Is_Writable_File (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of an existing file - -- that is writable. Returns True if so, False otherwise. Note that this - -- function simply interrogates the file attributes (e.g. using the C - -- function stat), so it does not indicate a situation in which a file may - -- not actually be writeable due to some other process having exclusive - -- access. + function Read + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer; + -- Read N bytes to address A from file referenced by FD. Returned value is + -- count of bytes actually read, which can be less than N at EOF. - function Is_Symbolic_Link (Name : String) return Boolean; - -- Determines if the given string, Name, is the path of a symbolic link on - -- systems that support it. Returns True if so, False if the path is not a - -- symbolic link or if the system does not support symbolic links. + procedure Rename_File + (Old_Name : String; + New_Name : String; + Success : out Boolean); + -- Rename a file. Success is set True or False indicating if the rename is + -- successful or not. -- - -- A symbolic link is an indirect pointer to a file; its directory entry - -- contains the name of the file to which it is linked. Symbolic links may - -- span file systems and may refer to directories. - - procedure Set_Writable (Name : String); - -- Change permissions on the named file to make it writable for its owner + -- WARNING: In one very important respect, this function is significantly + -- non-portable. If New_Name already exists then on Unix systems, the call + -- deletes the existing file, and the call signals success. On Windows, the + -- call fails, without doing the rename operation. See also the procedure + -- Ada.Directories.Rename, which portably provides the windows semantics, + -- i.e. fails if the output file already exists. - procedure Set_Non_Writable (Name : String); - -- Change permissions on the named file to make it non-writable for its - -- owner. The readable and executable permissions are not modified. + -- The following defines the mode for the Copy_File procedure below. Note + -- that "time stamps and other file attributes" in the descriptions below + -- refers to the creation and last modification times, and also the file + -- access (read/write/execute) status flags. - procedure Set_Read_Only (Name : String) renames Set_Non_Writable; - -- This renaming is provided for backwards compatibility with previous - -- versions. The use of Set_Non_Writable is preferred (clearer name). + procedure Set_Close_On_Exec + (FD : File_Descriptor; + Close_On_Exec : Boolean; + Status : out Boolean); + -- When Close_On_Exec is True, mark FD to be closed automatically when new + -- program is executed by the calling process (i.e. prevent FD from being + -- inherited by child processes). When Close_On_Exec is False, mark FD to + -- not be closed on exec (i.e. allow it to be inherited). Status is False + -- if the operation could not be performed. S_Owner : constant := 1; S_Group : constant := 2; @@ -567,69 +607,37 @@ package System.OS_Lib is -- for its owner, group or others, according to the setting of Mode. -- As indicated, the default if no Mode parameter is given is owner. - procedure Set_Readable (Name : String); - -- Change permissions on the named file to make it readable for its - -- owner. + procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time); + -- Given the name of a file or directory, Name, set the last modification + -- time stamp. This function must be used for an unopened file. procedure Set_Non_Readable (Name : String); -- Change permissions on the named file to make it non-readable for -- its owner. The writable and executable permissions are not -- modified. - function Locate_Exec_On_Path - (Exec_Name : String) return String_Access; - -- Try to locate an executable whose name is given by Exec_Name in the - -- directories listed in the environment Path. If the Exec_Name does not - -- have the executable suffix, it will be appended before the search. - -- Otherwise works like Locate_Regular_File below. If the executable is - -- not found, null is returned. - -- - -- Note that this function allocates memory for the returned value. This - -- memory needs to be deallocated after use. - - function Locate_Regular_File - (File_Name : String; - Path : String) return String_Access; - -- Try to locate a regular file whose name is given by File_Name in the - -- directories listed in Path. If a file is found, its full pathname is - -- returned; otherwise, a null pointer is returned. If the File_Name given - -- is an absolute pathname, then Locate_Regular_File just checks that the - -- file exists and is a regular file. Otherwise, if the File_Name given - -- includes directory information, Locate_Regular_File first checks if the - -- file exists relative to the current directory. If it does not, or if - -- the File_Name given is a simple file name, the Path argument is parsed - -- according to OS conventions, and for each directory in the Path a check - -- is made if File_Name is a relative pathname of a regular file from that - -- directory. - -- - -- Note that this function allocates some memory for the returned value. - -- This memory needs to be deallocated after use. - - function Get_Debuggable_Suffix return String_Access; - -- Return the debuggable suffix convention. Usually this is the same as - -- the convention for Get_Executable_Suffix. The result is allocated on - -- the heap and should be freed after use to avoid storage leaks. - - function Get_Target_Debuggable_Suffix return String_Access; - -- Return the target debuggable suffix convention. Usually this is the same - -- as the convention for Get_Executable_Suffix. The result is allocated on - -- the heap and should be freed after use to avoid storage leaks. + procedure Set_Non_Writable (Name : String); + -- Change permissions on the named file to make it non-writable for its + -- owner. The readable and executable permissions are not modified. - function Get_Executable_Suffix return String_Access; - -- Return the executable suffix convention. The result is allocated on the - -- heap and should be freed after use to avoid storage leaks. + procedure Set_Read_Only (Name : String) renames Set_Non_Writable; + -- This renaming is provided for backwards compatibility with previous + -- versions. The use of Set_Non_Writable is preferred (clearer name). - function Get_Object_Suffix return String_Access; - -- Return the object suffix convention. The result is allocated on the heap - -- and should be freed after use to avoid storage leaks. + procedure Set_Readable (Name : String); + -- Change permissions on the named file to make it readable for its + -- owner. - function Get_Target_Executable_Suffix return String_Access; - -- Return the target executable suffix convention. The result is allocated - -- on the heap and should be freed after use to avoid storage leaks. + procedure Set_Writable (Name : String); + -- Change permissions on the named file to make it writable for its owner - function Get_Target_Object_Suffix return String_Access; - -- Return the target object suffix convention. The result is allocated on - -- the heap and should be freed after use to avoid storage leaks. + function Write + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer; + -- Write N bytes from address A to file referenced by FD. The returned + -- value is the number of bytes written, which can be less than N if a + -- disk full condition was detected. -- The following section contains low-level routines using addresses to -- pass file name and executable name. In each routine the name must be @@ -642,17 +650,17 @@ package System.OS_Lib is -- All the following functions need comments ??? - function Open_Read - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; - - function Open_Read_Write - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; + procedure Copy_File + (Name : C_File_Name; + Pathname : C_File_Name; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps); - function Open_Append - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; + procedure Copy_Time_Stamps + (Source : C_File_Name; + Dest : C_File_Name; + Success : out Boolean); function Create_File (Name : C_File_Name; @@ -664,36 +672,37 @@ package System.OS_Lib is procedure Delete_File (Name : C_File_Name; Success : out Boolean); - procedure Rename_File - (Old_Name : C_File_Name; - New_Name : C_File_Name; - Success : out Boolean); - - procedure Copy_File - (Name : C_File_Name; - Pathname : C_File_Name; - Success : out Boolean; - Mode : Copy_Mode := Copy; - Preserve : Attribute := Time_Stamps); - - procedure Copy_Time_Stamps - (Source, Dest : C_File_Name; - Success : out Boolean); - function File_Time_Stamp (Name : C_File_Name) return OS_Time; -- Returns Invalid_Time is Name doesn't correspond to an existing file - function Is_Regular_File (Name : C_File_Name) return Boolean; function Is_Directory (Name : C_File_Name) return Boolean; - function Is_Readable_File (Name : C_File_Name) return Boolean; function Is_Executable_File (Name : C_File_Name) return Boolean; - function Is_Writable_File (Name : C_File_Name) return Boolean; + function Is_Readable_File (Name : C_File_Name) return Boolean; + function Is_Regular_File (Name : C_File_Name) return Boolean; function Is_Symbolic_Link (Name : C_File_Name) return Boolean; + function Is_Writable_File (Name : C_File_Name) return Boolean; function Locate_Regular_File (File_Name : C_File_Name; Path : C_File_Name) return String_Access; + function Open_Append + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + function Open_Read + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + function Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + procedure Rename_File + (Old_Name : C_File_Name; + New_Name : C_File_Name; + Success : out Boolean); + ------------------ -- Subprocesses -- ------------------ @@ -708,6 +717,84 @@ package System.OS_Lib is -- Note that there is a Free procedure declared for this subtype which -- frees the array and all referenced strings. + type Process_Id is private; + -- A private type used to identify a process activated by the following + -- non-blocking calls. The only meaningful operation on this type is a + -- comparison for equality. + + Invalid_Pid : constant Process_Id; + -- A special value used to indicate errors, as described below + + function Argument_String_To_List + (Arg_String : String) return Argument_List_Access; + -- Take a string that is a program and its arguments and parse it into an + -- Argument_List. Note that the result is allocated on the heap, and must + -- be freed by the programmer (when it is no longer needed) to avoid + -- memory leaks. + + procedure Kill (Pid : Process_Id; Hard_Kill : Boolean := True); + -- Kill the process designated by Pid. Does nothing if Pid is Invalid_Pid + -- or on platforms where it is not supported, such as VxWorks. Hard_Kill + -- is True by default, and when True the process is terminated immediately. + -- If Hard_Kill is False, then a signal SIGINT is sent to the process on + -- POSIX OS or a ctrl-C event on Windows, allowing the process a chance to + -- terminate properly using a corresponding handler. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List) return Process_Id; + -- This is a non blocking call. The Process_Id of the spawned process is + -- returned. Parameters are to be used as in Spawn. If Invalid_Pid is + -- returned the program could not be spawned. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + -- + -- This function will always return Invalid_Pid under VxWorks, since there + -- is no notion of executables under this OS. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Err_To_Out : Boolean := True) return Process_Id; + -- Similar to the procedure above, but redirects the output to the file + -- designated by Output_File_Descriptor. If Err_To_Out is True, then the + -- Standard Error output is also redirected. Invalid_Pid is returned + -- if the program could not be spawned successfully. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + -- + -- This function will always return Invalid_Pid under VxWorks, since there + -- is no notion of executables under this OS. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Err_To_Out : Boolean := True) return Process_Id; + -- Similar to the procedure above, but saves the output of the command to + -- a file with the name Output_File. + -- + -- Invalid_Pid is returned if the output file could not be created or if + -- the program could not be spawned successfully. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + -- + -- This function will always return Invalid_Pid under VxWorks, since there + -- is no notion of executables under this OS. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Stdout_File : String; + Stderr_File : String) return Process_Id; + -- Similar to the procedure above, but saves the standard output of the + -- command to a file with the name Stdout_File and the standard output + -- of the command to a file with the name Stderr_File. + procedure Normalize_Arguments (Args : in out Argument_List); -- Normalize all arguments in the list. This ensure that the argument list -- is compatible with the running OS and will works fine with Spawn and @@ -720,6 +807,10 @@ package System.OS_Lib is -- individual referenced arguments in Argument_List are on the heap, and -- may free them and reallocate if they are modified. + function Pid_To_Integer (Pid : Process_Id) return Integer; + -- Convert a process id to an Integer. Useful for writing hash functions + -- for type Process_Id or to compare two Process_Id (e.g. for sorting). + procedure Spawn (Program_Name : String; Args : Argument_List; @@ -798,73 +889,6 @@ package System.OS_Lib is -- Spawning processes from tasking programs is not recommended. See -- "NOTE: Spawn in tasking programs" below. - type Process_Id is private; - -- A private type used to identify a process activated by the following - -- non-blocking calls. The only meaningful operation on this type is a - -- comparison for equality. - - Invalid_Pid : constant Process_Id; - -- A special value used to indicate errors, as described below - - function Pid_To_Integer (Pid : Process_Id) return Integer; - -- Convert a process id to an Integer. Useful for writing hash functions - -- for type Process_Id or to compare two Process_Id (e.g. for sorting). - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List) return Process_Id; - -- This is a non blocking call. The Process_Id of the spawned process is - -- returned. Parameters are to be used as in Spawn. If Invalid_Pid is - -- returned the program could not be spawned. - -- - -- Spawning processes from tasking programs is not recommended. See - -- "NOTE: Spawn in tasking programs" below. - -- - -- This function will always return Invalid_Pid under VxWorks, since there - -- is no notion of executables under this OS. - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List; - Output_File_Descriptor : File_Descriptor; - Err_To_Out : Boolean := True) return Process_Id; - -- Similar to the procedure above, but redirects the output to the file - -- designated by Output_File_Descriptor. If Err_To_Out is True, then the - -- Standard Error output is also redirected. Invalid_Pid is returned - -- if the program could not be spawned successfully. - -- - -- Spawning processes from tasking programs is not recommended. See - -- "NOTE: Spawn in tasking programs" below. - -- - -- This function will always return Invalid_Pid under VxWorks, since there - -- is no notion of executables under this OS. - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List; - Output_File : String; - Err_To_Out : Boolean := True) return Process_Id; - -- Similar to the procedure above, but saves the output of the command to - -- a file with the name Output_File. - -- - -- Invalid_Pid is returned if the output file could not be created or if - -- the program could not be spawned successfully. - -- - -- Spawning processes from tasking programs is not recommended. See - -- "NOTE: Spawn in tasking programs" below. - -- - -- This function will always return Invalid_Pid under VxWorks, since there - -- is no notion of executables under this OS. - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List; - Stdout_File : String; - Stderr_File : String) return Process_Id; - -- Similar to the procedure above, but saves the standard output of the - -- command to a file with the name Stdout_File and the standard output - -- of the command to a file with the name Stderr_File. - procedure Wait_Process (Pid : out Process_Id; Success : out Boolean); -- Wait for the completion of any of the processes created by previous -- calls to Non_Blocking_Spawn. The caller will be suspended until one of @@ -879,13 +903,6 @@ package System.OS_Lib is -- This function will always set success to False under VxWorks, since -- there is no notion of executables under this OS. - function Argument_String_To_List - (Arg_String : String) return Argument_List_Access; - -- Take a string that is a program and its arguments and parse it into an - -- Argument_List. Note that the result is allocated on the heap, and must - -- be freed by the programmer (when it is no longer needed) to avoid - -- memory leaks. - ------------------------------------- -- NOTE: Spawn in Tasking Programs -- ------------------------------------- @@ -955,6 +972,17 @@ package System.OS_Lib is -- Miscellaneous -- ------------------- + function Errno return Integer; + pragma Import (C, Errno, "__get_errno"); + -- Return the task-safe last error number + + function Errno_Message + (Err : Integer := Errno; + Default : String := "") return String; + -- Return a message describing the given Errno value. If none is provided + -- by the system, return Default if not empty, else return a generic + -- message indicating the numeric errno value. + function Getenv (Name : String) return String_Access; -- Get the value of the environment variable. Returns an access to the -- empty string if the environment variable does not exist or has an @@ -964,16 +992,12 @@ package System.OS_Lib is -- case), and needs to be freed explicitly when no longer needed to avoid -- memory leaks. - procedure Setenv (Name : String; Value : String); - -- Set the value of the environment variable Name to Value. This call - -- modifies the current environment, but does not modify the parent - -- process environment. After a call to Setenv, Getenv (Name) will always - -- return a String_Access referencing the same String as Value. This is - -- true also for the null string case (the actual effect may be to either - -- set an explicit null as the value, or to remove the entry, this is - -- operating system dependent). Note that any following calls to Spawn - -- will pass an environment to the spawned process that includes the - -- changes made by Setenv calls. + procedure OS_Abort; + pragma Import (C, OS_Abort, "abort"); + pragma No_Return (OS_Abort); + -- Exit to OS signalling an abort (traceback or other appropriate + -- diagnostic information should be given if possible, or entry made to + -- the debugger if that is possible). procedure OS_Exit (Status : Integer); pragma No_Return (OS_Exit); @@ -994,27 +1018,20 @@ package System.OS_Lib is -- change the implementation of OS_Exit by redirecting OS_Exit_Ptr to an -- other implementation. - procedure OS_Abort; - pragma Import (C, OS_Abort, "abort"); - pragma No_Return (OS_Abort); - -- Exit to OS signalling an abort (traceback or other appropriate - -- diagnostic information should be given if possible, or entry made to - -- the debugger if that is possible). - - function Errno return Integer; - pragma Import (C, Errno, "__get_errno"); - -- Return the task-safe last error number - procedure Set_Errno (Errno : Integer); pragma Import (C, Set_Errno, "__set_errno"); -- Set the task-safe error number - function Errno_Message - (Err : Integer := Errno; - Default : String := "") return String; - -- Return a message describing the given Errno value. If none is provided - -- by the system, return Default if not empty, else return a generic - -- message indicating the numeric errno value. + procedure Setenv (Name : String; Value : String); + -- Set the value of the environment variable Name to Value. This call + -- modifies the current environment, but does not modify the parent + -- process environment. After a call to Setenv, Getenv (Name) will always + -- return a String_Access referencing the same String as Value. This is + -- true also for the null string case (the actual effect may be to either + -- set an explicit null as the value, or to remove the entry, this is + -- operating system dependent). Note that any following calls to Spawn + -- will pass an environment to the spawned process that includes the + -- changes made by Setenv calls. Directory_Separator : constant Character; -- The character that is used to separate parts of a pathname diff --git a/gcc/ada/s-osinte-aix.ads b/gcc/ada/s-osinte-aix.ads index 5df0353ea7c..02e843718b6 100644 --- a/gcc/ada/s-osinte-aix.ads +++ b/gcc/ada/s-osinte-aix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -319,8 +319,7 @@ package System.OS_Interface is -- Returns the stack base of the specified thread. Only call this function -- when Stack_Base_Available is True. - function Get_Page_Size return size_t; - function Get_Page_Size return Address; + function Get_Page_Size return int; pragma Import (C, Get_Page_Size, "getpagesize"); -- Returns the size of a page diff --git a/gcc/ada/s-osinte-android.adb b/gcc/ada/s-osinte-android.adb index 3b89e777a17..81103ee78d1 100644 --- a/gcc/ada/s-osinte-android.adb +++ b/gcc/ada/s-osinte-android.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2014, AdaCore -- +-- Copyright (C) 1995-2015, AdaCore -- -- -- -- 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- -- @@ -39,7 +39,6 @@ pragma Polling (Off); -- that are needed by children of System. with Interfaces.C; use Interfaces.C; -with Interfaces.C.Extensions; use Interfaces.C.Extensions; package body System.OS_Interface is @@ -76,48 +75,4 @@ package body System.OS_Interface is tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; - ------------------- - -- clock_gettime -- - ------------------- - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int - is - pragma Unreferenced (clock_id); - - -- Android/Linux don't have clock_gettime, so use gettimeofday - - use Interfaces; - - type timeval is array (1 .. 3) of C.long; - -- The timeval array is sized to contain long_long sec and long usec. - -- If long_long'Size = long'Size then it will be overly large but that - -- won't effect the implementation since it's not accessed directly. - - procedure timeval_to_duration - (T : not null access timeval; - sec : not null access C.Extensions.long_long; - usec : not null access C.long); - pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); - - Micro : constant := 10**6; - sec : aliased C.Extensions.long_long; - usec : aliased C.long; - TV : aliased timeval; - Result : int; - - function gettimeofday - (Tv : access timeval; - Tz : System.Address := System.Null_Address) return int; - pragma Import (C, gettimeofday, "gettimeofday"); - - begin - Result := gettimeofday (TV'Access, System.Null_Address); - pragma Assert (Result = 0); - timeval_to_duration (TV'Access, sec'Access, usec'Access); - tp.all := To_Timespec (Duration (sec) + Duration (usec) / Micro); - return Result; - end clock_gettime; - end System.OS_Interface; diff --git a/gcc/ada/s-osinte-android.ads b/gcc/ada/s-osinte-android.ads index abf5daec645..88dc03eb7ca 100644 --- a/gcc/ada/s-osinte-android.ads +++ b/gcc/ada/s-osinte-android.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -208,8 +208,8 @@ package System.OS_Interface is type clockid_t is new int; function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; + (clock_id : clockid_t; tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); function clock_getres (clock_id : clockid_t; @@ -317,8 +317,7 @@ package System.OS_Interface is return Address is (Null_Address); -- This is a dummy procedure to share some GNULLI files - function Get_Page_Size return size_t; - function Get_Page_Size return Address; + function Get_Page_Size return int; pragma Import (C, Get_Page_Size, "_getpagesize"); -- Returns the size of a page diff --git a/gcc/ada/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads index 9eaa2129171..0dbbdfe0599 100644 --- a/gcc/ada/s-osinte-darwin.ads +++ b/gcc/ada/s-osinte-darwin.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -299,8 +299,7 @@ package System.OS_Interface is -- returns the stack base of the specified thread. Only call this function -- when Stack_Base_Available is True. - function Get_Page_Size return size_t; - function Get_Page_Size return System.Address; + function Get_Page_Size return int; pragma Import (C, Get_Page_Size, "getpagesize"); -- Returns the size of a page diff --git a/gcc/ada/s-osinte-freebsd.ads b/gcc/ada/s-osinte-freebsd.ads index 625d2dcd661..8a0eec63c6e 100644 --- a/gcc/ada/s-osinte-freebsd.ads +++ b/gcc/ada/s-osinte-freebsd.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -332,8 +332,7 @@ package System.OS_Interface is -- returns the stack base of the specified thread. Only call this function -- when Stack_Base_Available is True. - function Get_Page_Size return size_t; - function Get_Page_Size return Address; + function Get_Page_Size return int; pragma Import (C, Get_Page_Size, "getpagesize"); -- Returns the size of a page diff --git a/gcc/ada/s-osinte-hpux.ads b/gcc/ada/s-osinte-hpux.ads index 6beb0501899..ab22dad81c8 100644 --- a/gcc/ada/s-osinte-hpux.ads +++ b/gcc/ada/s-osinte-hpux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -301,8 +301,7 @@ package System.OS_Interface is -- Returns the stack base of the specified thread. Only call this function -- when Stack_Base_Available is True. - function Get_Page_Size return size_t; - function Get_Page_Size return Address; + function Get_Page_Size return int; pragma Import (C, Get_Page_Size, "getpagesize"); -- Returns the size of a page diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads index c71bebc8d8a..2bcf56e500d 100644 --- a/gcc/ada/s-osinte-linux.ads +++ b/gcc/ada/s-osinte-linux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -224,6 +224,10 @@ package System.OS_Interface is subtype timeval is System.Linux.timeval; subtype clockid_t is System.Linux.clockid_t; + function clock_gettime + (clock_id : clockid_t; tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + function clock_getres (clock_id : clockid_t; res : access timespec) return int; @@ -526,6 +530,10 @@ package System.OS_Interface is destructor : destructor_pointer) return int; pragma Import (C, pthread_key_create, "pthread_key_create"); + ---------------- + -- Extensions -- + ---------------- + CPU_SETSIZE : constant := 1_024; -- Size of the cpu_set_t mask on most linux systems (SUSE 11 uses 4_096). -- This is kept for backward compatibility (System.Task_Info uses it), but diff --git a/gcc/ada/s-osinte-solaris-posix.ads b/gcc/ada/s-osinte-solaris-posix.ads index 4e27fd1f4f7..09f9f1f3490 100644 --- a/gcc/ada/s-osinte-solaris-posix.ads +++ b/gcc/ada/s-osinte-solaris-posix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -300,8 +300,7 @@ package System.OS_Interface is -- Returns the stack base of the specified thread. Only call this function -- when Stack_Base_Available is True. - function Get_Page_Size return size_t; - function Get_Page_Size return Address; + function Get_Page_Size return int; pragma Import (C, Get_Page_Size, "getpagesize"); -- Returns the size of a page diff --git a/gcc/ada/s-osprim-darwin.adb b/gcc/ada/s-osprim-darwin.adb index d47c608a74e..688371d19f4 100644 --- a/gcc/ada/s-osprim-darwin.adb +++ b/gcc/ada/s-osprim-darwin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -90,12 +90,6 @@ package body System.OS_Primitives is return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; end Clock; - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - ----------------- -- To_Timespec -- ----------------- diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb index 13c5354b0d7..9f7af90c521 100644 --- a/gcc/ada/s-osprim-mingw.adb +++ b/gcc/ada/s-osprim-mingw.adb @@ -90,6 +90,14 @@ package body System.OS_Primitives is Signature : Signature_Type := 0; pragma Atomic (Signature); + function Monotonic_Clock return Duration; + pragma Export (Ada, Monotonic_Clock, "__gnat_monotonic_clock"); + -- Return "absolute" time, represented as an offset relative to "the Unix + -- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is + -- immune to the system's clock changes. Export this function so that it + -- can be imported from s-taprop-mingw.adb without changing the shared + -- spec (s-osprim.ads). + procedure Get_Base_Time (Data : in out Clock_Data); -- Retrieve the base time and base ticks. These values will be used by -- clock to compute the current time by adding to it a fraction of the diff --git a/gcc/ada/s-osprim-posix.adb b/gcc/ada/s-osprim-posix.adb index 04aece75e05..04344d31b4f 100644 --- a/gcc/ada/s-osprim-posix.adb +++ b/gcc/ada/s-osprim-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -93,12 +93,6 @@ package body System.OS_Primitives is return Duration (sec) + Duration (usec) / Micro; end Clock; - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - ----------------- -- To_Timespec -- ----------------- diff --git a/gcc/ada/s-osprim-solaris.adb b/gcc/ada/s-osprim-solaris.adb index d629b4b9ec3..3bddaa5c8e3 100644 --- a/gcc/ada/s-osprim-solaris.adb +++ b/gcc/ada/s-osprim-solaris.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -70,12 +70,6 @@ package body System.OS_Primitives is return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; end Clock; - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - ----------------- -- Timed_Delay -- ----------------- diff --git a/gcc/ada/s-osprim-unix.adb b/gcc/ada/s-osprim-unix.adb index 973ce032570..732a15c5c32 100644 --- a/gcc/ada/s-osprim-unix.adb +++ b/gcc/ada/s-osprim-unix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -70,12 +70,6 @@ package body System.OS_Primitives is return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; end Clock; - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - ----------------- -- Timed_Delay -- ----------------- diff --git a/gcc/ada/s-osprim-vxworks.adb b/gcc/ada/s-osprim-vxworks.adb index 1eccae5612a..92dfc993a9b 100644 --- a/gcc/ada/s-osprim-vxworks.adb +++ b/gcc/ada/s-osprim-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -102,12 +102,6 @@ package body System.OS_Primitives is return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; end Clock; - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - ----------------- -- Timed_Delay -- ----------------- diff --git a/gcc/ada/s-osprim-x32.adb b/gcc/ada/s-osprim-x32.adb index e0c020c78f9..b457f5b3201 100644 --- a/gcc/ada/s-osprim-x32.adb +++ b/gcc/ada/s-osprim-x32.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2013-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2013-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -88,12 +88,6 @@ package body System.OS_Primitives is return Duration (sec) + Duration (usec) / Micro; end Clock; - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - ----------------- -- To_Timespec -- ----------------- diff --git a/gcc/ada/s-osprim.ads b/gcc/ada/s-osprim.ads index 05683b2484e..ad4ffbee96d 100644 --- a/gcc/ada/s-osprim.ads +++ b/gcc/ada/s-osprim.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -63,12 +63,6 @@ package System.OS_Primitives is -- Epoch", which is Jan 1, 1970 00:00:00 UTC on UNIX systems. This -- implementation is affected by system's clock changes. - function Monotonic_Clock return Duration; - pragma Inline (Monotonic_Clock); - -- Returns "absolute" time, represented as an offset relative to "the Unix - -- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is - -- immune to the system's clock changes. - Relative : constant := 0; Absolute_Calendar : constant := 1; Absolute_RT : constant := 2; diff --git a/gcc/ada/s-poosiz.adb b/gcc/ada/s-poosiz.adb index c2dd03bf5d4..683f32e315d 100644 --- a/gcc/ada/s-poosiz.adb +++ b/gcc/ada/s-poosiz.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -51,7 +51,7 @@ package body System.Pool_Size is function To_Storage_Count_Access is new Ada.Unchecked_Conversion (Address, Storage_Count_Access); - SC_Size : constant := SSE.Storage_Count'Object_Size / System.Storage_Unit; + SC_Size : constant := SSE.Storage_Count'Object_Size / System.Storage_Unit; package Variable_Size_Management is diff --git a/gcc/ada/s-regexp.adb b/gcc/ada/s-regexp.adb index 68cef650aac..6a445340b14 100644 --- a/gcc/ada/s-regexp.adb +++ b/gcc/ada/s-regexp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2013, AdaCore -- +-- Copyright (C) 1999-2015, AdaCore -- -- -- -- 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- -- @@ -1084,7 +1084,7 @@ package body System.Regexp is return J; end Next_Sub_Expression; - -- Start of Create_Primary_Table + -- Start of processing for Create_Primary_Table begin Table.all := (others => (others => 0)); diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/s-regpat.adb index d5ef0229e47..4127ec99523 100644 --- a/gcc/ada/s-regpat.adb +++ b/gcc/ada/s-regpat.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1999-2014, AdaCore -- +-- Copyright (C) 1999-2015, AdaCore -- -- -- -- 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- -- @@ -413,7 +413,7 @@ package body System.Regpat is Capturing : Boolean; Flags : out Expression_Flags; IP : out Pointer); - -- Parse regular expression, i.e. main body or parenthesized thing + -- Parse regular expression, i.e. main body or parenthesized thing. -- Caller must absorb opening parenthesis. Capturing should be set to -- True when we have an open parenthesis from which we want the user -- to extra text. @@ -422,7 +422,7 @@ package body System.Regpat is (Flags : out Expression_Flags; First : Boolean; IP : out Pointer); - -- Implements the concatenation operator and handles '|' + -- Implements the concatenation operator and handles '|'. -- First should be true if this is the first item of the alternative. procedure Parse_Piece diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index 7b18d2f4089..446ddb9f412 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -119,6 +119,8 @@ package System.Rident is No_Implicit_Conditionals, -- GNAT No_Implicit_Dynamic_Code, -- GNAT No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3)) + No_Implicit_Task_Allocations, -- GNAT + No_Implicit_Protected_Object_Allocations, -- GNAT No_Implicit_Loops, -- GNAT No_Initialize_Scalars, -- GNAT No_Local_Allocators, -- (RM H.4(8)) @@ -142,6 +144,7 @@ package System.Rident is No_Streams, -- GNAT No_Task_Allocators, -- (RM D.7(7)) No_Task_Attributes_Package, -- GNAT + No_Task_At_Interrupt_Priority, -- GNAT No_Task_Hierarchy, -- (RM D.7(3), H.4(3)) No_Task_Termination, -- GNAT (Ravenscar) No_Tasking, -- GNAT @@ -168,6 +171,7 @@ package System.Rident is -- units, it applies to all units in this extended main source. Immediate_Reclamation, -- (RM H.4(10)) + No_Dynamic_Sized_Objects, -- GNAT No_Implementation_Aspect_Specifications, -- Ada 2012 AI-241 No_Implementation_Attributes, -- Ada 2005 AI-257 No_Implementation_Identifiers, -- Ada 2012 AI-246 @@ -458,7 +462,7 @@ package System.Rident is -- pragma Dispatching_Policy (FIFO_Within_Priorities); -- pragma Locking_Policy (Ceiling_Locking); - -- pragma Detect_Blocking + -- pragma Detect_Blocking; Ravenscar => diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb index 6e0749c14ce..2d9b9e8b876 100644 --- a/gcc/ada/s-shasto.adb +++ b/gcc/ada/s-shasto.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -201,7 +201,7 @@ package body System.Shared_Storage is -- Release least recently used entry if we have to - if Shared_Var_Files_Open = Max_Shared_Var_Files then + if Shared_Var_Files_Open = Max_Shared_Var_Files then Freed := LRU_Head; if Freed.Next /= null then diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb index 2bbc2aa0b36..b3efac83c47 100644 --- a/gcc/ada/s-soflin.adb +++ b/gcc/ada/s-soflin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -303,13 +303,4 @@ package body System.Soft_Links is null; end Task_Unlock_NT; - ------------------------- - -- Update_Exception_NT -- - ------------------------- - - procedure Update_Exception_NT (X : EO := Current_Target_Exception) is - begin - Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X); - end Update_Exception_NT; - end System.Soft_Links; diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads index f850cd2ffb0..35dc9628b98 100644 --- a/gcc/ada/s-soflin.ads +++ b/gcc/ada/s-soflin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -143,12 +143,6 @@ package System.Soft_Links is -- Handle task abort (non-tasking case, does nothing). Currently, no port -- makes use of this, but we retain the interface for possible future use. - procedure Update_Exception_NT (X : EO := Current_Target_Exception); - -- Handle exception setting. This routine is provided for targets that - -- have built-in exception handling such as the Java Virtual Machine. - -- Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on - -- how this routine is used. - function Check_Abort_Status_NT return Integer; -- Returns Boolean'Pos (True) iff abort signal should raise -- Standard'Abort_Signal. @@ -177,9 +171,6 @@ package System.Soft_Links is Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access; -- Handle task abort (task/non-task case as appropriate) - Update_Exception : Special_EO_Call := Update_Exception_NT'Access; - -- Handle exception setting and tasking polling when appropriate - Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access; -- Called when Abort_Signal is delivered to the process. Checks to -- see if signal should result in raising Standard'Abort_Signal. @@ -263,9 +254,9 @@ package System.Soft_Links is procedure Enter_Master_NT; procedure Complete_Master_NT; - Current_Master : Get_Integer_Call := Current_Master_NT'Access; - Enter_Master : No_Param_Proc := Enter_Master_NT'Access; - Complete_Master : No_Param_Proc := Complete_Master_NT'Access; + Current_Master : Get_Integer_Call := Current_Master_NT'Access; + Enter_Master : No_Param_Proc := Enter_Master_NT'Access; + Complete_Master : No_Param_Proc := Complete_Master_NT'Access; ---------------------- -- Delay Soft-Links -- diff --git a/gcc/ada/s-solita.adb b/gcc/ada/s-solita.adb index a8f101d0fd8..d1ca2c474c7 100644 --- a/gcc/ada/s-solita.adb +++ b/gcc/ada/s-solita.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -159,8 +159,7 @@ package body System.Soft_Links.Tasking is -- We do not want to enable this check and e.g. call System.OS_Lib.Abort -- here because some restricted run-times may not have System.OS_Lib - -- (e.g. JVM), and calling abort may do more harm than good to the - -- main application. + -- and calling abort may do more harm than good to the main application. pragma Assert (Self_Id = STPO.Environment_Task); diff --git a/gcc/ada/s-stalib.ads b/gcc/ada/s-stalib.ads index 447662b5e91..5cfd6b37e03 100644 --- a/gcc/ada/s-stalib.ads +++ b/gcc/ada/s-stalib.ads @@ -220,12 +220,23 @@ package System.Standard_Library is -- This is the default behavior. Every_Raise, - -- Denotes every possible raise event, either explicit or due to - -- a specific language rule, within the context of a task or not. - - Unhandled_Raise - -- Denotes the raise events corresponding to exceptions for which - -- there is no user defined handler. + -- Denotes the initial raise event for any exception occurrence, either + -- explicit or due to a specific language rule, within the context of a + -- task or not. + + Unhandled_Raise, + -- Denotes the raise events corresponding to exceptions for which there + -- is no user defined handler. This includes unhandled exceptions in + -- task bodies. + + Unhandled_Raise_In_Main + -- Same as Unhandled_Raise, except exceptions in task bodies are not + -- included. Same as RM_Convention, except (1) the message is printed as + -- soon as the environment task completes due to an unhandled exception + -- (before awaiting the termination of dependent tasks, and before + -- library-level finalization), and (2) a symbolic traceback is given + -- if possible. This is the default behavior if the binder switch -E is + -- used. ); -- Provide a way to denote different kinds of automatic traces related -- to exceptions that can be requested. diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index 16c875aa6d5..c7d2819ca9c 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -281,7 +281,7 @@ package body System.Storage_Pools.Subpools is -- +- Header_And_Padding --+ N_Ptr := Address_To_FM_Node_Ptr - (N_Addr + Header_And_Padding - Header_Offset); + (N_Addr + Header_And_Padding - Header_Size); -- Prepend the allocated object to the finalization master @@ -414,7 +414,7 @@ package body System.Storage_Pools.Subpools is -- Convert the bits preceding the object into a list header - N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Offset); + N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size); -- Detach the object from the related finalization master. This -- action does not need to know the prior context used during diff --git a/gcc/ada/s-stposu.ads b/gcc/ada/s-stposu.ads index 68f6b17920d..f473dc279b9 100644 --- a/gcc/ada/s-stposu.ads +++ b/gcc/ada/s-stposu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, 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 -- @@ -106,7 +106,7 @@ package System.Storage_Pools.Subpools is (Pool : in out Root_Storage_Pool_With_Subpools) return not null Subpool_Handle; -- Return a common subpool which is used for object allocations without a - -- Subpool_Handle_name in the allocator. The default implementation of this + -- Subpool_Handle_Name in the allocator. The default implementation of this -- routine raises Program_Error. function Pool_Of_Subpool diff --git a/gcc/ada/s-taasde.ads b/gcc/ada/s-taasde.ads index 46dc17877f3..11227539dd7 100644 --- a/gcc/ada/s-taasde.ads +++ b/gcc/ada/s-taasde.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -133,7 +133,7 @@ private -- A double linked list end record; - -- The above "overlaying" of Self_ID and Level to hold other data that has + -- The above "overlaying" of Self_Id and Level to hold other data that has -- a non-overlapping lifetime is an unabashed hack to save memory. procedure Time_Enqueue diff --git a/gcc/ada/s-tadeca.adb b/gcc/ada/s-tadeca.adb index 6faf4d04d6c..4ebbee7ab32 100644 --- a/gcc/ada/s-tadeca.adb +++ b/gcc/ada/s-tadeca.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -66,7 +66,7 @@ begin if SOSC.CLOCK_RT_Ada /= SOSC.CLOCK_REALTIME then pragma Warnings (On); - RT_T := RT_T - OS_Primitives.Monotonic_Clock + STPO.Monotonic_Clock; + RT_T := RT_T - OS_Primitives.Clock + STPO.Monotonic_Clock; end if; System.Tasking.Initialization.Defer_Abort diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index a43133a9dee..2aad75ebead 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,7 +39,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Interfaces.C; -with Interfaces.C.Extensions; with System.Task_Info; with System.Tasking.Debug; @@ -64,7 +63,6 @@ package body System.Task_Primitives.Operations is use System.Tasking.Debug; use System.Tasking; use Interfaces.C; - use Interfaces.C.Extensions; use System.OS_Interface; use System.Parameters; use System.OS_Primitives; @@ -629,30 +627,14 @@ package body System.Task_Primitives.Operations is --------------------- function Monotonic_Clock return Duration is - use Interfaces; - - procedure timeval_to_duration - (T : not null access timeval; - sec : not null access C.Extensions.long_long; - usec : not null access C.long); - pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); - - Micro : constant := 10**6; - sec : aliased C.Extensions.long_long; - usec : aliased C.long; - TV : aliased timeval; + TS : aliased timespec; Result : int; - - function gettimeofday - (Tv : access timeval; - Tz : System.Address := System.Null_Address) return int; - pragma Import (C, gettimeofday, "gettimeofday"); - begin - Result := gettimeofday (TV'Access, System.Null_Address); + Result := clock_gettime + (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access); pragma Assert (Result = 0); - timeval_to_duration (TV'Access, sec'Access, usec'Access); - return Duration (sec) + Duration (usec) / Micro; + + return To_Duration (TS); end Monotonic_Clock; ------------------- diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index cecb7e5fabf..c945e1dfcc7 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1068,8 +1068,12 @@ package body System.Task_Primitives.Operations is -- Monotonic_Clock -- --------------------- - function Monotonic_Clock return Duration - renames System.OS_Primitives.Monotonic_Clock; + function Monotonic_Clock return Duration is + function Internal_Clock return Duration; + pragma Import (Ada, Internal_Clock, "__gnat_monotonic_clock"); + begin + return Internal_Clock; + end Monotonic_Clock; ------------------- -- RT_Resolution -- diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index cdbc0643d7a..5ed7badc853 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -278,7 +278,7 @@ package body System.Task_Primitives.Operations is -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada) elsif Mode = Absolute_RT - or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME + or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME then pragma Warnings (On); Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); @@ -293,10 +293,10 @@ package body System.Task_Primitives.Operations is else declare - Cal_Check_Time : constant Duration := - OS_Primitives.Monotonic_Clock; + Cal_Check_Time : constant Duration := OS_Primitives.Clock; RT_Time : constant Duration := Time + Check_Time - Cal_Check_Time; + begin Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time); @@ -315,21 +315,20 @@ package body System.Task_Primitives.Operations is procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); - Guard_Page_Address : Address; - - Res : Interfaces.C.int; + Page_Size : Address; + Res : Interfaces.C.int; begin if Stack_Base_Available then -- Compute the guard page address - Guard_Page_Address := - Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; - + Page_Size := Address (Get_Page_Size); Res := - mprotect (Guard_Page_Address, Get_Page_Size, - prot => (if On then PROT_ON else PROT_OFF)); + mprotect + (Stack_Base - (Stack_Base mod Page_Size) + Page_Size, + size_t (Page_Size), + prot => (if On then PROT_ON else PROT_OFF)); pragma Assert (Res = 0); end if; end Stack_Guard; @@ -978,7 +977,8 @@ package body System.Task_Primitives.Operations is is Attributes : aliased pthread_attr_t; Adjusted_Stack_Size : Interfaces.C.size_t; - Page_Size : constant Interfaces.C.size_t := Get_Page_Size; + Page_Size : constant Interfaces.C.size_t := + Interfaces.C.size_t (Get_Page_Size); Result : Interfaces.C.int; function Thread_Body_Access is new diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index 871ab5abcce..dddad762e34 100644 --- a/gcc/ada/s-tasini.adb +++ b/gcc/ada/s-tasini.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -58,7 +58,6 @@ package body System.Tasking.Initialization is package STPO renames System.Task_Primitives.Operations; package SSL renames System.Soft_Links; - package AE renames Ada.Exceptions; use Parameters; use Task_Primitives.Operations; @@ -94,10 +93,6 @@ package body System.Tasking.Initialization is function Get_Current_Excep return SSL.EOA; -- Task-safe version of SSL.Get_Current_Excep - procedure Update_Exception - (X : AE.Exception_Occurrence := SSL.Current_Target_Exception); - -- Handle exception setting and check for pending actions - function Task_Name return String; -- Returns current task's name @@ -371,7 +366,6 @@ package body System.Tasking.Initialization is SSL.Unlock_Task := Task_Unlock'Access; SSL.Check_Abort_Status := Check_Abort_Status'Access; SSL.Task_Name := Task_Name'Access; - SSL.Update_Exception := Update_Exception'Access; SSL.Get_Current_Excep := Get_Current_Excep'Access; -- Initialize the tasking soft links (if not done yet) that are common @@ -709,50 +703,6 @@ package body System.Tasking.Initialization is end if; end Abort_Undefer; - ---------------------- - -- Update_Exception -- - ---------------------- - - -- Call only when holding no locks - - procedure Update_Exception - (X : AE.Exception_Occurrence := SSL.Current_Target_Exception) - is - Self_Id : constant Task_Id := Self; - use Ada.Exceptions; - - begin - Save_Occurrence (Self_Id.Common.Compiler_Data.Current_Excep, X); - - if Self_Id.Deferral_Level = 0 then - if Self_Id.Pending_Action then - Self_Id.Pending_Action := False; - Self_Id.Deferral_Level := Self_Id.Deferral_Level + 1; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_Id); - Self_Id.Pending_Action := False; - Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Self_Id.Deferral_Level := Self_Id.Deferral_Level - 1; - - if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then - if not Self_Id.Aborting then - Self_Id.Aborting := True; - raise Standard'Abort_Signal; - end if; - end if; - end if; - end if; - end Update_Exception; - -------------------------- -- Wakeup_Entry_Caller -- -------------------------- diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index f48d98d0634..539d08854fb 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1135,20 +1135,23 @@ package System.Tasking is -- User-writeable location, for use in debugging tasks; also provides a -- simple task specific data. + Free_On_Termination : Boolean := False; + -- Deallocate the ATCB when the task terminates. This flag is normally + -- False, and is set True when Unchecked_Deallocation is called on a + -- non-terminated task so that the associated storage is automatically + -- reclaimed when the task terminates. + Attributes : Attribute_Array := (others => 0); -- Task attributes + -- IMPORTANT Note: the Entry_Queues field is last for efficiency of + -- access to other fields, do not put new fields after this one. + Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num); -- An array of task entry queues -- -- Protection: Self.L. Once a task has set Self.Stage to Completing, it -- has exclusive access to this field. - - Free_On_Termination : Boolean := False; - -- Deallocate the ATCB when the task terminates. This flag is normally - -- False, and is set True when Unchecked_Deallocation is called on a - -- non-terminated task so that the associated storage is automatically - -- reclaimed when the task terminates. end record; -------------------- diff --git a/gcc/ada/s-taspri-solaris.ads b/gcc/ada/s-taspri-solaris.ads index 93c520da02a..e06d4d4dbbe 100644 --- a/gcc/ada/s-taspri-solaris.ads +++ b/gcc/ada/s-taspri-solaris.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -94,7 +94,7 @@ private type Lock is record L : aliased Base_Lock; Ceiling : System.Any_Priority := System.Any_Priority'First; - Saved_Priority : System.Any_Priority := System.Any_Priority'First; + Saved_Priority : System.Any_Priority := System.Any_Priority'First; Owner : Owner_ID; Next : Lock_Ptr; Level : Private_Task_Serial_Number := 0; diff --git a/gcc/ada/s-traceb-hpux.adb b/gcc/ada/s-traceb-hpux.adb index 9987cb3fe64..dcd6ad0b64f 100644 --- a/gcc/ada/s-traceb-hpux.adb +++ b/gcc/ada/s-traceb-hpux.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -262,15 +262,14 @@ package body System.Traceback is -- but it is not usable when frames with dynamically allocated space are -- on the way. --- procedure Call_Chain --- (Traceback : System.Address; --- Max_Len : Natural; --- Len : out Natural; --- Exclude_Min : System.Address := System.Null_Address; --- Exclude_Max : System.Address := System.Null_Address; --- Skip_Frames : Natural := 1); --- -- Same as the exported version, but takes Traceback as an Address --- ???See declaration in the spec for why this is temporarily commented out. + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the exported version, but takes Traceback as an Address ------------------ -- C_Call_Chain -- diff --git a/gcc/ada/s-traceb-mastop.adb b/gcc/ada/s-traceb-mastop.adb index 0ce7c50f933..1a00d97f1e6 100644 --- a/gcc/ada/s-traceb-mastop.adb +++ b/gcc/ada/s-traceb-mastop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2014, AdaCore -- +-- Copyright (C) 1999-2015, AdaCore -- -- -- -- 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- -- @@ -37,15 +37,14 @@ package body System.Traceback is use System.Machine_State_Operations; --- procedure Call_Chain --- (Traceback : System.Address; --- Max_Len : Natural; --- Len : out Natural; --- Exclude_Min : System.Address := System.Null_Address; --- Exclude_Max : System.Address := System.Null_Address; --- Skip_Frames : Natural := 1); --- -- Same as the exported version, but takes Traceback as an Address --- ???See declaration in the spec for why this is temporarily commented out. + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the exported version, but takes Traceback as an Address ---------------- -- Call_Chain -- diff --git a/gcc/ada/s-traceb.adb b/gcc/ada/s-traceb.adb index 4855644434e..e4671135ade 100644 --- a/gcc/ada/s-traceb.adb +++ b/gcc/ada/s-traceb.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -38,6 +38,15 @@ pragma Compiler_Unit_Warning; package body System.Traceback is + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the exported version, but takes Traceback as an Address + ------------------ -- C_Call_Chain -- ------------------ diff --git a/gcc/ada/s-traceb.ads b/gcc/ada/s-traceb.ads index dbfea6a6f6f..283bd5cd072 100644 --- a/gcc/ada/s-traceb.ads +++ b/gcc/ada/s-traceb.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -78,19 +78,6 @@ package System.Traceback is -- number of stored entries. The first entry is the most recent call, -- and the last entry is the highest level call. - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1); - -- Same as the previous version, but takes Traceback as an Address. The - -- previous version is preferred. ???This version should be removed from - -- this spec, and calls replaced with calls to the previous version. This - -- declaration can be moved to the bodies (s-traceb.adb, s-traceb-hpux.adb, - -- and s-traceb-mastop.adb), but it should not be visible to clients. - function C_Call_Chain (Traceback : System.Address; Max_Len : Natural) return Natural; diff --git a/gcc/ada/s-trasym.adb b/gcc/ada/s-trasym.adb index ad5588761d1..b98d1c334dd 100644 --- a/gcc/ada/s-trasym.adb +++ b/gcc/ada/s-trasym.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2014, AdaCore -- +-- Copyright (C) 1999-2015, AdaCore -- -- -- -- 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- -- @@ -30,8 +30,12 @@ ------------------------------------------------------------------------------ -- This is the default implementation for platforms where the full capability --- is not supported. It returns tracebacks as lists of LF separated strings of --- the form "0x..." corresponding to the addresses. +-- is not supported. It returns tracebacks as lists of hexadecimal addresses +-- of the form "0x...". + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we can get +-- elaboration circularities when polling is turned on. with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; with System.Address_Image; @@ -63,9 +67,10 @@ package body System.Traceback.Symbolic is Last := Last + 2; Result (Last + 1 .. Last + Img'Length) := Img; Last := Last + Img'Length + 1; - Result (Last) := ASCII.LF; + Result (Last) := ' '; end loop; + Result (Last) := ASCII.LF; return Result (1 .. Last); end; end if; diff --git a/gcc/ada/s-trasym.ads b/gcc/ada/s-trasym.ads index ea0b46bf9fc..2aa1d1f335a 100644 --- a/gcc/ada/s-trasym.ads +++ b/gcc/ada/s-trasym.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2014, AdaCore -- +-- Copyright (C) 1999-2015, AdaCore -- -- -- -- 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- -- @@ -62,6 +62,10 @@ -- Symbolic_Traceback return a list of addresses expressed as "0x..." -- separated by line feed. +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we can get +-- elaboration circularities when polling is turned on. + with Ada.Exceptions; package System.Traceback.Symbolic is diff --git a/gcc/ada/s-valllu.adb b/gcc/ada/s-valllu.adb index a641be31959..44dbff7c3df 100644 --- a/gcc/ada/s-valllu.adb +++ b/gcc/ada/s-valllu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -142,7 +142,7 @@ package body System.Val_LLU is if Base not in 2 .. 16 then Overflow := True; - Base := 16; + Base := 16; end if; -- Scan out based integer diff --git a/gcc/ada/s-valuns.adb b/gcc/ada/s-valuns.adb index b679807803f..009d0bc88c1 100644 --- a/gcc/ada/s-valuns.adb +++ b/gcc/ada/s-valuns.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -142,7 +142,7 @@ package body System.Val_Uns is if Base not in 2 .. 16 then Overflow := True; - Base := 16; + Base := 16; end if; -- Scan out based integer diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 7bf8ea2eacc..f0a9013a8b8 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -641,7 +641,7 @@ package body Scng is end loop; end Scan_Integer; - -- Start of Processing for Nlit + -- Start of processing for Nlit begin Base := 10; @@ -1834,14 +1834,19 @@ package body Scng is -- Apostrophe. This can either be the start of a character literal, -- or an isolated apostrophe used in a qualified expression or an - -- attribute. We treat it as a character literal if it does not - -- follow a right parenthesis, identifier, the keyword ALL or - -- a literal. This means that we correctly treat constructs like: + -- attribute. In the following: -- A := CHARACTER'('A'); - -- Note that RM-2.2(7) does not require a separator between - -- "CHARACTER" and "'" in the above. + -- the first apostrophe is treated as an isolated apostrophe, and the + -- second one is treated as the start of the character literal 'A'. + -- Note that RM-2.2(7) does not require a separator between "'" and + -- "(" in the above, so we cannot use lookahead to distinguish the + -- cases; we use look-back instead. Analysis of the grammar shows + -- that some tokens can be followed by an apostrophe, and some by a + -- character literal, but none by both. Some cannot be followed by + -- either, so it doesn't matter what we do in those cases, except to + -- get good error behavior. when ''' => Char_Literal_Case : declare Code : Char_Code; @@ -1851,17 +1856,18 @@ package body Scng is Accumulate_Checksum ('''); Scan_Ptr := Scan_Ptr + 1; - -- Here is where we make the test to distinguish the cases. Treat - -- as apostrophe if previous token is an identifier, right paren - -- or the reserved word "all" (latter case as in A.all'Address) - -- (or the reserved word "project" in project files). Also treat - -- it as apostrophe after a literal (this catches some legitimate - -- cases, like A."abs"'Address, and also gives better error - -- behavior for impossible cases like 123'xxx). + -- Distinguish between apostrophe and character literal. It's an + -- apostrophe if the previous token is one of the following. + -- Reserved words are included for things like A.all'Address and + -- T'Digits'Img. Strings literals are included for things like + -- "abs"'Address. Other literals are included to give better error + -- behavior for illegal cases like 123'Img. if Prev_Token = Tok_Identifier or else Prev_Token = Tok_Right_Paren or else Prev_Token = Tok_All + or else Prev_Token = Tok_Delta + or else Prev_Token = Tok_Digits or else Prev_Token = Tok_Project or else Prev_Token in Token_Class_Literal then diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 0f8f173a5ff..819bcd5d959 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -29,6 +29,7 @@ with Debug_A; use Debug_A; with Elists; use Elists; with Expander; use Expander; with Fname; use Fname; +with Ghost; use Ghost; with Lib; use Lib; with Lib.Load; use Lib.Load; with Nlists; use Nlists; @@ -95,9 +96,7 @@ package body Sem is ------------- procedure Analyze (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - -- Save the current Ghost mode in effect in case the construct sets a - -- different mode. + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; begin Debug_A_Entry ("analyzing ", N); @@ -109,6 +108,14 @@ package body Sem is return; end if; + -- A declaration may be subject to pragma Ghost. Set the mode now to + -- ensure that any nodes generated during analysis and expansion are + -- marked as Ghost. + + if Is_Declaration (N) then + Set_Ghost_Mode (N); + end if; + -- Otherwise processing depends on the node kind case Nkind (N) is @@ -720,10 +727,7 @@ package body Sem is Expand (N); end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Analyze; -- Version with check(s) suppressed @@ -1310,9 +1314,7 @@ package body Sem is ---------------- procedure Do_Analyze is - GM : constant Ghost_Mode_Type := Ghost_Mode; - -- Save the current Ghost mode in effect in case the compilation unit - -- is withed from a unit with a different Ghost mode. + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; List : Elist_Id; @@ -1343,7 +1345,7 @@ package body Sem is Pop_Scope; Restore_Scope_Stack (List); - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Do_Analyze; -- Local variables @@ -1444,10 +1446,6 @@ package body Sem is or else Debug_Flag_X - -- Or if we are generating C code - - or else Generate_C_Code - -- Or if in configuration run-time mode. We do this so we get -- error messages about missing entities in the run-time even -- if we are compiling in -gnatc (no code generation) mode. diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 5300d3ab87f..60cd1319872 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -42,6 +42,7 @@ with Nmake; use Nmake; with Nlists; use Nlists; with Opt; use Opt; with Restrict; use Restrict; +with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; @@ -401,7 +402,7 @@ package body Sem_Aggr is -- is set in Resolve_Array_Aggregate but the aggregate is not -- immediately replaced with a raise CE. In fact, Array_Aggr_Subtype must -- first construct the proper itype for the aggregate (Gigi needs - -- this). After constructing the proper itype we will eventually replace + -- this). After constructing the proper itype we will eventually replace -- the top-level aggregate with a raise CE (done in Resolve_Aggregate). -- Of course in cases such as: -- @@ -412,7 +413,7 @@ package body Sem_Aggr is -- (in this particular case the bounds will be 1 .. 2). procedure Make_String_Into_Aggregate (N : Node_Id); - -- A string literal can appear in a context in which a one dimensional + -- A string literal can appear in a context in which a one dimensional -- array of characters is expected. This procedure simply rewrites the -- string as an aggregate, prior to resolution. @@ -1967,6 +1968,14 @@ package body Sem_Aggr is return Failure; end if; + if not (All_Composite_Constraints_Static (Low) + and then All_Composite_Constraints_Static (High) + and then All_Composite_Constraints_Static (S_Low) + and then All_Composite_Constraints_Static (S_High)) + then + Check_Restriction (No_Dynamic_Sized_Objects, Choice); + end if; + Nb_Discrete_Choices := Nb_Discrete_Choices + 1; Table (Nb_Discrete_Choices).Lo := Low; Table (Nb_Discrete_Choices).Hi := High; @@ -2718,7 +2727,7 @@ package body Sem_Aggr is if Etype (Imm_Type) = Base_Type (A_Type) then return True; - -- The base type of the parent type may appear as a private + -- The base type of the parent type may appear as a private -- extension if it is declared as such in a parent unit of the -- current one. For consistency of the subsequent analysis use -- the partial view for the ancestor part. @@ -4416,7 +4425,7 @@ package body Sem_Aggr is -- have already been inserted into the component -- list of the current aggregate. - if Nkind (Def_Node) = N_Record_Definition + if Nkind (Def_Node) = N_Record_Definition and then Present (Component_List (Def_Node)) and then Present diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 20ce9df0f13..7112869f4a8 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -388,8 +388,8 @@ package body Sem_Attr is -- itself of the form of a library unit name. Note that this is -- quite different from Check_Program_Unit, since it only checks -- the syntactic form of the name, not the semantic identity. This - -- is because it is used with attributes (Elab_Body, Elab_Spec, - -- UET_Address and Elaborated) which can refer to non-visible unit. + -- is because it is used with attributes (Elab_Body, Elab_Spec and + -- Elaborated) which can refer to non-visible unit. procedure Error_Attr (Msg : String; Error_Node : Node_Id); pragma No_Return (Error_Attr); @@ -1330,7 +1330,7 @@ package body Sem_Attr is if Nkind (Prag) = N_Aspect_Specification then Subp_Decl := Parent (Prag); else - Subp_Decl := Find_Related_Subprogram_Or_Body (Prag); + Subp_Decl := Find_Related_Declaration_Or_Body (Prag); end if; -- The aspect or pragma where the attribute resides should be @@ -1351,7 +1351,7 @@ package body Sem_Attr is -- If we get here, then the attribute is legal Legal := True; - Spec_Id := Corresponding_Spec_Of (Subp_Decl); + Spec_Id := Unique_Defining_Entity (Subp_Decl); end Analyze_Attribute_Old_Result; --------------------------------- @@ -1531,7 +1531,7 @@ package body Sem_Attr is ("expression for dimension must be static!", E1); Error_Attr; - elsif UI_To_Int (Expr_Value (E1)) > D + elsif UI_To_Int (Expr_Value (E1)) > D or else UI_To_Int (Expr_Value (E1)) < 1 then Error_Attr ("invalid dimension number for array type", E1); @@ -2675,7 +2675,6 @@ package body Sem_Attr is if Aname /= Name_Elab_Body and then Aname /= Name_Elab_Spec and then Aname /= Name_Elab_Subp_Body and then - Aname /= Name_UET_Address and then Aname /= Name_Enabled and then Aname /= Name_Old then @@ -3866,7 +3865,7 @@ package body Sem_Attr is Check_E0; Analyze (P); - if Etype (P) = Standard_Exception_Type then + if Etype (P) = Standard_Exception_Type then Set_Etype (N, RTE (RE_Exception_Id)); -- Ada 2005 (AI-345): Attribute 'Identity may be applied to task @@ -4284,10 +4283,13 @@ package body Sem_Attr is -- Locate the enclosing loop (if any). Note that Ada 2012 array -- iteration may be expanded into several nested loops, we are - -- interested in the outermost one which has the loop identifier. + -- interested in the outermost one which has the loop identifier, + -- and comes from source. elsif Nkind (Stmt) = N_Loop_Statement and then Present (Identifier (Stmt)) + and then Comes_From_Source (Original_Node (Stmt)) + and then Nkind (Original_Node (Stmt)) = N_Loop_Statement then Enclosing_Loop := Stmt; @@ -4310,10 +4312,10 @@ package body Sem_Attr is Stmt := Parent (Stmt); end loop; - -- Loop_Entry must appear within a Loop_Assertion pragma (Assert, - -- Assert_And_Cut, Assume count as loop assertion pragmas for this - -- purpose if they appear in an appropriate location in a loop, - -- which was already checked by the top level pragma circuit). + -- Loop_Entry must appear within a Loop_Assertion pragma (Assert, + -- Assert_And_Cut, Assume count as loop assertion pragmas for this + -- purpose if they appear in an appropriate location in a loop, + -- which was already checked by the top level pragma circuit). if No (Enclosing_Pragma) then Error_Attr ("attribute% must appear within appropriate pragma", N); @@ -6023,15 +6025,6 @@ package body Sem_Attr is Analyze_And_Resolve (N, Standard_String); - ----------------- - -- UET_Address -- - ----------------- - - when Attribute_UET_Address => - Check_E0; - Check_Unit_Name (P); - Set_Etype (N, RTE (RE_Address)); - ----------------------- -- Unbiased_Rounding -- ----------------------- @@ -7216,10 +7209,11 @@ package body Sem_Attr is -- We skip evaluation if the expander is not active. This is not just -- an optimization. It is of key importance that we not rewrite the -- attribute in a generic template, since we want to pick up the - -- setting of the check in the instance, and testing expander active - -- is as easy way of doing this as any. + -- setting of the check in the instance, Testing Expander_Active + -- might seem an easy way of doing this, but we need to account for + -- ASIS needs, so check explicitly for a generic context. - if Expander_Active then + if not Inside_A_Generic then declare C : constant Check_Id := Get_Check_Id (Chars (P)); R : Boolean; @@ -7271,20 +7265,63 @@ package body Sem_Attr is return; end if; - -- Special processing for cases where the prefix is an object. For - -- this purpose, a string literal counts as an object (attributes - -- of string literals can only appear in generated code). + -- Special processing for cases where the prefix is an object. For this + -- purpose, a string literal counts as an object (attributes of string + -- literals can only appear in generated code). if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then -- For Component_Size, the prefix is an array object, and we apply - -- the attribute to the type of the object. This is allowed for - -- both unconstrained and constrained arrays, since the bounds - -- have no influence on the value of this attribute. + -- the attribute to the type of the object. This is allowed for both + -- unconstrained and constrained arrays, since the bounds have no + -- influence on the value of this attribute. if Id = Attribute_Component_Size then P_Entity := Etype (P); + -- For Enum_Rep, evaluation depends on the nature of the prefix and + -- the optional argument. + + elsif Id = Attribute_Enum_Rep then + if Is_Entity_Name (P) then + + -- The prefix denotes a constant or an enumeration literal, the + -- attribute can be folded. A generated loop variable for an + -- iterator is a constant, but cannot be constant-folded. + + if Ekind (Entity (P)) = E_Enumeration_Literal + or else + (Ekind (Entity (P)) = E_Constant + and then Ekind (Scope (Entity (P))) /= E_Loop) + then + P_Entity := Etype (P); + + -- The prefix denotes an enumeration type. Folding can occur + -- when the argument is a constant or an enumeration literal. + + elsif Is_Enumeration_Type (Entity (P)) + and then Present (E1) + and then Is_Entity_Name (E1) + and then Ekind_In (Entity (E1), E_Constant, + E_Enumeration_Literal) + then + P_Entity := Etype (P); + + -- Otherwise the attribute must be expanded into a conversion + -- and evaluated at run time. + + else + Check_Expressions; + return; + end if; + + -- Otherwise the attribute is illegal, do not attempt to perform + -- any kind of folding. + + else + return; + end if; + -- For First and Last, the prefix is an array object, and we apply -- the attribute to the type of the array, but we need a constrained -- type for this, so we use the actual subtype if available. @@ -7977,7 +8014,26 @@ package body Sem_Attr is -- Enum_Rep -- -------------- - when Attribute_Enum_Rep => + when Attribute_Enum_Rep => Enum_Rep : declare + Val : Node_Id; + + begin + -- The attribute appears in the form: + + -- Enum_Typ'Enum_Rep (Const) + -- Enum_Typ'Enum_Rep (Enum_Lit) + + if Present (E1) then + Val := E1; + + -- Otherwise the prefix denotes a constant or enumeration literal: + + -- Const'Enum_Rep + -- Enum_Lit'Enum_Rep + + else + Val := P; + end if; -- For an enumeration type with a non-standard representation use -- the Enumeration_Rep field of the proper constant. Note that this @@ -7989,15 +8045,16 @@ package body Sem_Attr is if Is_Enumeration_Type (P_Type) and then Has_Non_Standard_Rep (P_Type) then - Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static); + Fold_Uint (N, Enumeration_Rep (Expr_Value_E (Val)), Static); - -- For enumeration types with standard representations and all - -- other cases (i.e. all integer and modular types), Enum_Rep - -- is equivalent to Pos. + -- For enumeration types with standard representations and all other + -- cases (i.e. all integer and modular types), Enum_Rep is equivalent + -- to Pos. else - Fold_Uint (N, Expr_Value (E1), Static); + Fold_Uint (N, Expr_Value (Val), Static); end if; + end Enum_Rep; -------------- -- Enum_Val -- @@ -9707,7 +9764,6 @@ package body Sem_Attr is Attribute_Terminated | Attribute_To_Address | Attribute_Type_Key | - Attribute_UET_Address | Attribute_Unchecked_Access | Attribute_Universal_Literal_String | Attribute_Unrestricted_Access | @@ -11057,16 +11113,6 @@ package body Sem_Attr is when Attribute_Result => null; - ----------------- - -- UET_Address -- - ----------------- - - -- Prefix must not be resolved in this case, since it is not a - -- real entity reference. No action of any kind is require. - - when Attribute_UET_Address => - return; - ---------------------- -- Unchecked_Access -- ---------------------- diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index c1e592844fa..d71acb33140 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -508,16 +508,6 @@ package Sem_Attr is -- Aux_DEC into System, then the type Type_Class can be referenced -- as an entity within System, as can its enumeration literals. - ----------------- - -- UET_Address -- - ----------------- - - Attribute_UET_Address => True, - -- Unit'UET_Address, where Unit is a program unit, yields the address - -- of the unit exception table for the specified unit. This is only - -- used in the internal implementation of exception handling. See the - -- implementation of unit Ada.Exceptions for details on its use. - ------------------------------ -- Universal_Literal_String -- ------------------------------ diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 136c37b834c..f704f93d5de 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -120,7 +120,7 @@ package body Sem_Aux is -- If there is an expression, return it elsif Present (Expression (D)) then - return (Expression (D)); + return Expression (D); -- For a constant, see if we have a full view @@ -291,7 +291,7 @@ package body Sem_Aux is if Is_Itype (Ent) then null; - elsif Ekind (Ent) = E_Discriminant + elsif Ekind (Ent) = E_Discriminant and then Is_Completely_Hidden (Ent) then return True; @@ -819,8 +819,8 @@ package body Sem_Aux is -- Generic subprogram body elsif Is_Subprogram (S) - and then Nkind (Unit_Declaration_Node (S)) - = N_Generic_Subprogram_Declaration + and then Nkind (Unit_Declaration_Node (S)) = + N_Generic_Subprogram_Declaration then return True; end if; @@ -1380,7 +1380,7 @@ package body Sem_Aux is -- Number_Components -- ----------------------- - function Number_Components (Typ : Entity_Id) return Pos is + function Number_Components (Typ : Entity_Id) return Nat is N : Int; Comp : Entity_Id; @@ -1649,6 +1649,8 @@ package body Sem_Aux is -- Isn't there some better way to express the following ??? while Nkind (N) /= N_Abstract_Subprogram_Declaration + and then Nkind (N) /= N_Entry_Body + and then Nkind (N) /= N_Entry_Declaration and then Nkind (N) /= N_Formal_Package_Declaration and then Nkind (N) /= N_Function_Instantiation and then Nkind (N) /= N_Generic_Package_Declaration diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index db0931e0713..ba60284daac 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -377,7 +377,7 @@ package Sem_Aux is -- The result returned is the next _Tag field in this record, or Empty -- if this is the last such field. - function Number_Components (Typ : Entity_Id) return Pos; + function Number_Components (Typ : Entity_Id) return Nat; -- Typ is a record type, yields number of components (including -- discriminants) in type. diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 201855b5e36..a23358afe2e 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -766,8 +766,14 @@ package body Sem_Case is if Has_Predicate then Pred := First (Static_Discrete_Predicate (Bounds_Type)); - Prev_Lo := Uint_Minus_1; - Prev_Hi := Uint_Minus_1; + + -- Make initial value smaller than 'First of type, so that first + -- range comparison succeeds. This applies both to integer types + -- and to enumeration types. + + Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1; + Prev_Hi := Prev_Lo; + Error := False; for Index in 1 .. Num_Choices loop diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index f8cf3ab9831..28742e45683 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -185,9 +185,10 @@ package body Sem_Cat is begin -- Intrinsic subprograms are preelaborated, so do not impose any - -- categorization dependencies. + -- categorization dependencies. Also, ignore categorization + -- dependencies when compilation switch -gnatdu is used. - if Is_Intrinsic_Subprogram (Depended_Entity) then + if Is_Intrinsic_Subprogram (Depended_Entity) or else Debug_Flag_U then return; end if; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 55456e6996f..5de074e1f25 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -23,50 +23,50 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; -with Atree; use Atree; -with Debug; use Debug; -with Einfo; use Einfo; -with Errout; use Errout; -with Exp_Util; use Exp_Util; -with Elists; use Elists; -with Fname; use Fname; -with Fname.UF; use Fname.UF; -with Freeze; use Freeze; -with Impunit; use Impunit; -with Inline; use Inline; -with Lib; use Lib; -with Lib.Load; use Lib.Load; -with Lib.Xref; use Lib.Xref; -with Namet; use Namet; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Output; use Output; -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_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch7; use Sem_Ch7; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch12; use Sem_Ch12; -with Sem_Dist; use Sem_Dist; -with Sem_Prag; use Sem_Prag; -with Sem_Util; use Sem_Util; -with Sem_Warn; use Sem_Warn; -with Stand; use Stand; -with Sinfo; use Sinfo; -with Sinfo.CN; use Sinfo.CN; -with Sinput; use Sinput; -with Snames; use Snames; -with Style; use Style; -with Stylesw; use Stylesw; -with Tbuild; use Tbuild; -with Uname; use Uname; +with Aspects; use Aspects; +with Atree; use Atree; +with Contracts; use Contracts; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Util; use Exp_Util; +with Elists; use Elists; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Freeze; use Freeze; +with Impunit; use Impunit; +with Inline; use Inline; +with Lib; use Lib; +with Lib.Load; use Lib.Load; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +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_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Dist; use Sem_Dist; +with Sem_Prag; use Sem_Prag; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Sinput; use Sinput; +with Snames; use Snames; +with Style; use Style; +with Stylesw; use Stylesw; +with Tbuild; use Tbuild; +with Uname; use Uname; package body Sem_Ch10 is @@ -939,16 +939,7 @@ package body Sem_Ch10 is if Nkind_In (Unit_Node, N_Generic_Subprogram_Declaration, N_Subprogram_Declaration) then - Analyze_Subprogram_Contract (Defining_Entity (Unit_Node)); - - -- Capture all global references in a generic subprogram that acts as - -- a compilation unit now that the contract has been analyzed. - - if Is_Generic_Declaration_Or_Body (Unit_Node) then - Save_Global_References_In_Contract - (Templ => Original_Node (Unit_Node), - Gen_Id => Defining_Entity (Unit_Node)); - end if; + Analyze_Entry_Or_Subprogram_Contract (Defining_Entity (Unit_Node)); end if; -- Generate distribution stubs if requested and no error @@ -1935,17 +1926,6 @@ package body Sem_Ch10 is Error_Msg_N ("missing specification for Protected body", N); else - -- Currently there are no language-defined aspects that can apply to - -- a protected body stub. Issue an error and remove the aspects to - -- prevent cascaded errors. - - if Has_Aspects (N) then - Error_Msg_N - ("aspects on protected bodies are not allowed", - First (Aspect_Specifications (N))); - Remove_Aspects (N); - end if; - Set_Scope (Defining_Entity (N), Current_Scope); Set_Has_Completion (Etype (Nam)); Set_Corresponding_Spec_Of_Stub (N, Nam); @@ -2006,39 +1986,6 @@ package body Sem_Ch10 is Restore_Opt_Config_Switches (Opts); end Analyze_Subprogram_Body_Stub; - ------------------------------------------- - -- Analyze_Subprogram_Body_Stub_Contract -- - ------------------------------------------- - - procedure Analyze_Subprogram_Body_Stub_Contract (Stub_Id : Entity_Id) is - Stub_Decl : constant Node_Id := Parent (Parent (Stub_Id)); - Spec_Id : constant Entity_Id := Corresponding_Spec_Of_Stub (Stub_Decl); - - begin - -- A subprogram body stub may act as its own spec or as the completion - -- of a previous declaration. Depending on the context, the contract of - -- the stub may contain two sets of pragmas. - - -- The stub is a completion, the applicable pragmas are: - -- Refined_Depends - -- Refined_Global - - if Present (Spec_Id) then - Analyze_Subprogram_Body_Contract (Stub_Id); - - -- The stub acts as its own spec, the applicable pragmas are: - -- Contract_Cases - -- Depends - -- Global - -- Postcondition - -- Precondition - -- Test_Case - - else - Analyze_Subprogram_Contract (Stub_Id); - end if; - end Analyze_Subprogram_Body_Stub_Contract; - --------------------- -- Analyze_Subunit -- --------------------- @@ -2432,17 +2379,6 @@ package body Sem_Ch10 is Error_Msg_N ("missing specification for task body", N); else - -- Currently there are no language-defined aspects that can apply to - -- a task body stub. Issue an error and remove the aspects to prevent - -- cascaded errors. - - if Has_Aspects (N) then - Error_Msg_N - ("aspects on task bodies are not allowed", - First (Aspect_Specifications (N))); - Remove_Aspects (N); - end if; - Set_Scope (Defining_Entity (N), Current_Scope); Generate_Reference (Nam, Defining_Identifier (N), 'b'); Set_Corresponding_Spec_Of_Stub (N, Nam); @@ -2467,7 +2403,7 @@ package body Sem_Ch10 is if Expander_Active then Insert_After (N, Make_Assignment_Statement (Loc, - Name => + Name => Make_Identifier (Loc, Chars => New_External_Name (Chars (Etype (Nam)), 'E')), Expression => New_Occurrence_Of (Standard_True, Loc))); @@ -3127,7 +3063,7 @@ package body Sem_Ch10 is -- visible, so analyze the declaration for B now, in case it -- has not been done yet. - Ent := Entity (Selector_Name (Nam)); + Ent := Entity (Selector_Name (Nam)); Analyze (Parent (Unit_Declaration_Node (Entity (Selector_Name (Nam))))); diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads index c003526ecbe..d4b28cde8af 100644 --- a/gcc/ada/sem_ch10.ads +++ b/gcc/ada/sem_ch10.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Types; use Types; + package Sem_Ch10 is procedure Analyze_Compilation_Unit (N : Node_Id); procedure Analyze_With_Clause (N : Node_Id); @@ -33,19 +34,6 @@ package Sem_Ch10 is procedure Analyze_Protected_Body_Stub (N : Node_Id); procedure Analyze_Subunit (N : Node_Id); - procedure Analyze_Subprogram_Body_Stub_Contract (Stub_Id : Entity_Id); - -- Analyze all delayed aspects chained on the contract of a subprogram body - -- stub Stub_Id as if they appeared at the end of a declarative region. The - -- aspects in question are: - -- Contract_Cases - -- Depends - -- Global - -- Postcondition - -- Precondition - -- Refined_Depends - -- Refined_Global - -- Test_Case - procedure Install_Context (N : Node_Id); -- Installs the entities from the context clause of the given compilation -- unit into the visibility chains. This is done before analyzing a unit. diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 82b59e92d7f..0b9f8ef829d 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -46,6 +46,7 @@ with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; +with Snames; use Snames; with Stand; use Stand; package body Sem_Ch11 is @@ -55,17 +56,10 @@ package body Sem_Ch11 is ----------------------------------- procedure Analyze_Exception_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - Id : constant Entity_Id := Defining_Identifier (N); - PF : constant Boolean := Is_Pure (Current_Scope); + Id : constant Entity_Id := Defining_Identifier (N); + PF : constant Boolean := Is_Pure (Current_Scope); begin - -- The exception declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - Generate_Definition (Id); Enter_Name (Id); Set_Ekind (Id, E_Exception); @@ -83,11 +77,6 @@ package body Sem_Ch11 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Id); end if; - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Analyze_Exception_Declaration; -------------------------------- @@ -429,9 +418,13 @@ package body Sem_Ch11 is -- If the current scope is a subprogram, then this is the right place to -- check for hanging useless assignments from the statement sequence of - -- the subprogram body. + -- the subprogram body. Skip this in the body of a postcondition, + -- since in that case there are no source references, and we need to + -- preserve deferred references from the enclosing scope. - if Is_Subprogram (Current_Scope) then + if Is_Subprogram (Current_Scope) + and then Chars (Current_Scope) /= Name_uPostconditions + then Warn_On_Useless_Assignments (Current_Scope); end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index ecc3a8e0b0c..61803ed290e 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -23,60 +23,61 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; -with Atree; use Atree; -with Einfo; use Einfo; -with Elists; use Elists; -with Errout; use Errout; -with Expander; use Expander; -with Exp_Disp; use Exp_Disp; -with Fname; use Fname; -with Fname.UF; use Fname.UF; -with Freeze; use Freeze; -with Ghost; use Ghost; -with Itypes; use Itypes; -with Lib; use Lib; -with Lib.Load; use Lib.Load; -with Lib.Xref; use Lib.Xref; -with Nlists; use Nlists; -with Namet; use Namet; -with Nmake; use Nmake; -with Opt; use Opt; -with Rident; use Rident; -with Restrict; use Restrict; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -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_Ch10; use Sem_Ch10; -with Sem_Ch13; use Sem_Ch13; -with Sem_Dim; use Sem_Dim; -with Sem_Disp; use Sem_Disp; -with Sem_Elab; use Sem_Elab; -with Sem_Elim; use Sem_Elim; -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 Stand; use Stand; -with Sinfo; use Sinfo; -with Sinfo.CN; use Sinfo.CN; -with Sinput; use Sinput; -with Sinput.L; use Sinput.L; -with Snames; use Snames; -with Stringt; use Stringt; -with Uname; use Uname; +with Aspects; use Aspects; +with Atree; use Atree; +with Contracts; use Contracts; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Expander; use Expander; +with Exp_Disp; use Exp_Disp; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Freeze; use Freeze; +with Ghost; use Ghost; +with Itypes; use Itypes; +with Lib; use Lib; +with Lib.Load; use Lib.Load; +with Lib.Xref; use Lib.Xref; +with Nlists; use Nlists; +with Namet; use Namet; +with Nmake; use Nmake; +with Opt; use Opt; +with Rident; use Rident; +with Restrict; use Restrict; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +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_Ch10; use Sem_Ch10; +with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; +with Sem_Disp; use Sem_Disp; +with Sem_Elab; use Sem_Elab; +with Sem_Elim; use Sem_Elim; +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 Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Sinput; use Sinput; +with Sinput.L; use Sinput.L; +with Snames; use Snames; +with Stringt; use Stringt; +with Uname; use Uname; with Table; -with Tbuild; use Tbuild; -with Uintp; use Uintp; -with Urealp; use Urealp; -with Warnsw; use Warnsw; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; +with Warnsw; use Warnsw; with GNAT.HTable; @@ -148,7 +149,7 @@ package body Sem_Ch12 is -- However, for private types, this by itself does not insure that the -- proper VIEW of the entity is used (the full type may be visible at the -- point of generic definition, but not at instantiation, or vice-versa). - -- In order to reference the proper view, we special-case any reference + -- In order to reference the proper view, we special-case any reference -- to private types in the generic object, by saving both views, one in -- the generic and one in the semantic copy. At time of instantiation, we -- check whether the two views are consistent, and exchange declarations if @@ -707,7 +708,7 @@ package body Sem_Ch12 is -- If the instantiation happens textually before the body of the generic, -- the instantiation of the body must be analyzed after the generic body, -- and not at the point of instantiation. Such early instantiations can - -- happen if the generic and the instance appear in a package declaration + -- happen if the generic and the instance appear in a package declaration -- because the generic body can only appear in the corresponding package -- body. Early instantiations can also appear if generic, instance and -- body are all in the declarative part of a subprogram or entry. Entities @@ -806,7 +807,7 @@ package body Sem_Ch12 is -- Within the generic part, entities in the formal package are -- visible. To validate subsequent type declarations, indicate -- the correspondence between the entities in the analyzed formal, - -- and the entities in the actual package. There are three packages + -- and the entities in the actual package. There are three packages -- involved in the instantiation of a formal package: the parent -- generic P1 which appears in the generic declaration, the fake -- instantiation P2 which appears in the analyzed generic, and whose @@ -842,10 +843,6 @@ package body Sem_Ch12 is -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List -- set to No_Elist. - procedure Save_Global_References_In_Aspects (N : Node_Id); - -- Save all global references found within the expressions of all aspects - -- that appear on node N. - procedure Set_Instance_Env (Gen_Unit : Entity_Id; Act_Unit : Entity_Id); @@ -1075,7 +1072,7 @@ package body Sem_Ch12 is -- package. As usual an other association must be last in the list. procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id); - -- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance + -- Apply RM 12.3(9): if a formal subprogram is overloaded, the instance -- cannot have a named association for it. AI05-0025 extends this rule -- to formals of formal packages by AI05-0025, and it also applies to -- box-initialized formals. @@ -1104,8 +1101,8 @@ package body Sem_Ch12 is -- include an Others clause. procedure Process_Default (F : Entity_Id); - -- Add a copy of the declaration of generic formal F to the list of - -- associations, and add an explicit box association for F if there + -- Add a copy of the declaration of generic formal F to the list of + -- associations, and add an explicit box association for F if there -- is none yet, and the default comes from an Others_Choice. function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; @@ -1235,7 +1232,7 @@ package body Sem_Ch12 is elsif No (Selector_Name (Actual)) then Found_Assoc := Actual; - Act := Explicit_Generic_Actual_Parameter (Actual); + Act := Explicit_Generic_Actual_Parameter (Actual); Num_Matched := Num_Matched + 1; Next (Actual); @@ -1254,7 +1251,7 @@ package body Sem_Ch12 is Set_Etype (Selector_Name (Actual), Etype (A_F)); Generate_Reference (A_F, Selector_Name (Actual)); Found_Assoc := Actual; - Act := Explicit_Generic_Actual_Parameter (Actual); + Act := Explicit_Generic_Actual_Parameter (Actual); Num_Matched := Num_Matched + 1; exit; end if; @@ -1271,7 +1268,7 @@ package body Sem_Ch12 is -- insert actuals for those defaults, and cannot rely on their -- names to disambiguate them. - if Actual = First_Named then + if Actual = First_Named then Next (First_Named); elsif Present (Actual) then @@ -2382,22 +2379,17 @@ package body Sem_Ch12 is ---------------------------------------- procedure Analyze_Formal_Package_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Pack_Id : constant Entity_Id := Defining_Identifier (N); - Formal : Entity_Id; - Gen_Id : constant Node_Id := Name (N); - Gen_Decl : Node_Id; - Gen_Unit : Entity_Id; - New_N : Node_Id; - Parent_Installed : Boolean := False; - Renaming : Node_Id; - Parent_Instance : Entity_Id; - Renaming_In_Par : Entity_Id; - Associations : Boolean := True; + Gen_Id : constant Node_Id := Name (N); + Loc : constant Source_Ptr := Sloc (N); + Pack_Id : constant Entity_Id := Defining_Identifier (N); + Formal : Entity_Id; + Gen_Decl : Node_Id; + Gen_Unit : Entity_Id; + Renaming : Node_Id; Vis_Prims_List : Elist_Id := No_Elist; -- List of primitives made temporarily visible in the instantiation - -- to match the visibility of the formal type + -- to match the visibility of the formal type. function Build_Local_Package return Node_Id; -- The formal package is rewritten so that its parameters are replaced @@ -2509,6 +2501,17 @@ package body Sem_Ch12 is return Pack_Decl; end Build_Local_Package; + -- Local variables + + Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode; + -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit + + Associations : Boolean := True; + New_N : Node_Id; + Parent_Installed : Boolean := False; + Parent_Instance : Entity_Id; + Renaming_In_Par : Entity_Id; + -- Start of processing for Analyze_Formal_Package_Declaration begin @@ -2608,19 +2611,18 @@ package body Sem_Ch12 is Formal := New_Copy (Pack_Id); Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); - begin - -- Make local generic without formals. The formals will be replaced - -- with internal declarations. + -- Make local generic without formals. The formals will be replaced with + -- internal declarations. + begin New_N := Build_Local_Package; - -- If there are errors in the parameter list, Analyze_Associations - -- raises Instantiation_Error. Patch the declaration to prevent - -- further exception propagation. + -- If there are errors in the parameter list, Analyze_Associations + -- raises Instantiation_Error. Patch the declaration to prevent further + -- exception propagation. exception when Instantiation_Error => - Enter_Name (Formal); Set_Ekind (Formal, E_Variable); Set_Etype (Formal, Any_Type); @@ -2645,6 +2647,14 @@ package body Sem_Ch12 is Set_Inner_Instances (Formal, New_Elmt_List); Push_Scope (Formal); + -- Manually set the SPARK_Mode from the context because the package + -- declaration is never analyzed. + + Set_SPARK_Pragma (Formal, SPARK_Mode_Pragma); + Set_SPARK_Aux_Pragma (Formal, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Formal); + Set_SPARK_Aux_Pragma_Inherited (Formal); + if Is_Child_Unit (Gen_Unit) and then Parent_Installed then -- Similarly, we have to make the name of the formal visible in the @@ -2664,6 +2674,15 @@ package body Sem_Ch12 is Append_Entity (Renaming_In_Par, Parent_Instance); end if; + -- A formal package declaration behaves as a package instantiation with + -- respect to SPARK_Mode "off". If the annotation is "off" or altogether + -- missing, set the global flag which signals Analyze_Pragma to ingnore + -- all SPARK_Mode pragmas within the generic_package_name. + + if SPARK_Mode /= On then + Ignore_Pragma_SPARK_Mode := True; + end if; + Analyze (Specification (N)); -- The formals for which associations are provided are not visible @@ -2709,8 +2728,8 @@ package body Sem_Ch12 is Set_Has_Completion (Formal, True); - -- Add semantic information to the original defining identifier. - -- for ASIS use. + -- Add semantic information to the original defining identifier for ASIS + -- use. Set_Ekind (Pack_Id, E_Package); Set_Etype (Pack_Id, Standard_Void_Type); @@ -2721,6 +2740,8 @@ package body Sem_Ch12 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Pack_Id); end if; + + Ignore_Pragma_SPARK_Mode := Save_IPSM; end Analyze_Formal_Package_Declaration; --------------------------------- @@ -2820,8 +2841,19 @@ package body Sem_Ch12 is if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then Set_Is_Abstract_Subprogram (Nam); + Set_Is_Dispatching_Operation (Nam); + -- A formal abstract procedure cannot have a null default + -- (RM 12.6(4.1/2)). + + if Nkind (Spec) = N_Procedure_Specification + and then Null_Present (Spec) + then + Error_Msg_N + ("a formal abstract subprogram cannot default to null", Spec); + end if; + declare Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam); begin @@ -2867,7 +2899,7 @@ package body Sem_Ch12 is end if; -- Default name may be overloaded, in which case the interpretation - -- with the correct profile must be selected, as for a renaming. + -- with the correct profile must be selected, as for a renaming. -- If the definition is an indexed component, it must denote a -- member of an entry family. If it is a selected component, it -- can be a protected operation. @@ -3124,7 +3156,6 @@ package body Sem_Ch12 is ------------------------------------------ procedure Analyze_Generic_Package_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; Loc : constant Source_Ptr := Sloc (N); Decls : constant List_Id := Visible_Declarations (Specification (N)); @@ -3135,11 +3166,6 @@ package body Sem_Ch12 is Save_Parent : Node_Id; begin - -- The generic package declaration may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes generated - -- during analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); Check_SPARK_05_Restriction ("generic is not allowed", N); -- We introduce a renaming of the enclosing package, to have a usable @@ -3291,11 +3317,6 @@ package body Sem_Ch12 is end if; end; end if; - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Analyze_Generic_Package_Declaration; -------------------------------------------- @@ -3303,7 +3324,6 @@ package body Sem_Ch12 is -------------------------------------------- procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; Formals : List_Id; Id : Entity_Id; New_N : Node_Id; @@ -3313,12 +3333,6 @@ package body Sem_Ch12 is Typ : Entity_Id; begin - -- The generic subprogram declaration may be subject to pragma Ghost - -- with policy Ignore. Set the mode now to ensure that any nodes - -- generated during analysis and expansion are properly flagged as - -- ignored Ghost. - - Set_Ghost_Mode (N); Check_SPARK_05_Restriction ("generic is not allowed", N); -- Create copy of generic unit, and save for instantiation. If the unit @@ -3467,11 +3481,6 @@ package body Sem_Ch12 is Generate_Reference_To_Formals (Id); List_Inherited_Pre_Post_Aspects (Id); - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Analyze_Generic_Subprogram_Declaration; ----------------------------------- @@ -3576,7 +3585,7 @@ package body Sem_Ch12 is begin Check_SPARK_05_Restriction ("generic is not allowed", N); - -- Very first thing: check for Text_IO sp[ecial unit in case we are + -- Very first thing: check for Text_IO special unit in case we are -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Check_Text_IO_Special_Unit (Name (N)); @@ -3604,7 +3613,7 @@ package body Sem_Ch12 is New_Copy_Tree (Name (Defining_Unit_Name (N))), Defining_Identifier => Act_Decl_Id); else - Act_Decl_Name := Act_Decl_Id; + Act_Decl_Name := Act_Decl_Id; end if; -- Case of instantiation of a formal package @@ -3727,11 +3736,12 @@ package body Sem_Ch12 is goto Leave; else - -- If the context of the instance is subject to SPARK_Mode "off", - -- set the global flag which signals Analyze_Pragma to ignore all - -- SPARK_Mode pragmas within the instance. + -- If the context of the instance is subject to SPARK_Mode "off" or + -- the annotation is altogether missing, set the global flag which + -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within + -- the instance. - if SPARK_Mode = Off then + if SPARK_Mode /= On then Ignore_Pragma_SPARK_Mode := True; end if; @@ -4606,14 +4616,14 @@ package body Sem_Ch12 is Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := Use_Clauses (J); Install_Use_Clauses (Use_Clauses (J)); - end loop; + end loop; else for J in reverse 1 .. Num_Scopes loop Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := Use_Clauses (J); Install_Use_Clauses (Use_Clauses (J)); - end loop; + end loop; end if; -- Restore status of instances. If one of them is a body, make its @@ -4679,12 +4689,41 @@ package body Sem_Ch12 is (N : Node_Id; Subp : Entity_Id) return Boolean is + + function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean; + -- Return True if E is an inlined subprogram, an inlined renaming or a + -- subprogram nested in an inlined subprogram. The inlining machinery + -- totally disregards nested subprograms since it considers that they + -- will always be compiled if the parent is (see Inline.Is_Nested). + + ------------------------------------ + -- Is_Inlined_Or_Child_Of_Inlined -- + ------------------------------------ + + function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean is + Scop : Entity_Id; + + begin + if Is_Inlined (E) or else Is_Inlined (Alias (E)) then + return True; + end if; + + Scop := Scope (E); + while Scop /= Standard_Standard loop + if Ekind (Scop) in Subprogram_Kind and then Is_Inlined (Scop) then + return True; + end if; + + Scop := Scope (Scop); + end loop; + + return False; + end Is_Inlined_Or_Child_Of_Inlined; + begin - -- Must be inlined (or inlined renaming) + -- Must be in the main unit or inlined (or child of inlined) - if (Is_In_Main_Unit (N) - or else Is_Inlined (Subp) - or else Is_Inlined (Alias (Subp))) + if (Is_In_Main_Unit (N) or else Is_Inlined_Or_Child_Of_Inlined (Subp)) -- Must be generating code or analyzing code in ASIS/GNATprove mode @@ -4776,11 +4815,6 @@ package body Sem_Ch12 is -- aspects that appear in the generic. This renaming declaration is -- inserted after the instance declaration which it renames. - procedure Instantiate_Subprogram_Contract (Templ : Node_Id); - -- Instantiate all source pragmas found in the contract of the generic - -- subprogram declaration template denoted by Templ. The instantiated - -- pragmas are added to list Renaming_List. - ------------------------------------ -- Analyze_Instance_And_Renamings -- ------------------------------------ @@ -4878,9 +4912,9 @@ package body Sem_Ch12 is Set_Debug_Info_Needed (Anon_Id); Act_Decl_Id := New_Copy (Anon_Id); - Set_Parent (Act_Decl_Id, Parent (Anon_Id)); - Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N))); - Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N))); + Set_Parent (Act_Decl_Id, Parent (Anon_Id)); + Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N))); + Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N))); -- Subprogram instance comes from source only if generic does @@ -4978,57 +5012,10 @@ package body Sem_Ch12 is end loop; if No (Renaming_Decl) then - Append (Unit_Renaming, Renaming_List); + Append (Unit_Renaming, Renaming_List); end if; end Build_Subprogram_Renaming; - ------------------------------------- - -- Instantiate_Subprogram_Contract -- - ------------------------------------- - - procedure Instantiate_Subprogram_Contract (Templ : Node_Id) is - procedure Instantiate_Pragmas (First_Prag : Node_Id); - -- Instantiate all contract-related source pragmas found in the list - -- starting with pragma First_Prag. Each instantiated pragma is added - -- to list Renaming_List. - - ------------------------- - -- Instantiate_Pragmas -- - ------------------------- - - procedure Instantiate_Pragmas (First_Prag : Node_Id) is - Inst_Prag : Node_Id; - Prag : Node_Id; - - begin - Prag := First_Prag; - while Present (Prag) loop - if Is_Generic_Contract_Pragma (Prag) then - Inst_Prag := - Copy_Generic_Node (Prag, Empty, Instantiating => True); - - Set_Analyzed (Inst_Prag, False); - Append_To (Renaming_List, Inst_Prag); - end if; - - Prag := Next_Pragma (Prag); - end loop; - end Instantiate_Pragmas; - - -- Local variables - - Items : constant Node_Id := Contract (Defining_Entity (Templ)); - - -- Start of processing for Instantiate_Subprogram_Contract - - begin - if Present (Items) then - Instantiate_Pragmas (Pre_Post_Conditions (Items)); - Instantiate_Pragmas (Contract_Test_Cases (Items)); - Instantiate_Pragmas (Classifications (Items)); - end if; - end Instantiate_Subprogram_Contract; - -- Local variables Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode; @@ -5102,11 +5089,12 @@ package body Sem_Ch12 is Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); else - -- If the context of the instance is subject to SPARK_Mode "off", - -- set the global flag which signals Analyze_Pragma to ignore all - -- SPARK_Mode pragmas within the instance. + -- If the context of the instance is subject to SPARK_Mode "off" or + -- the annotation is altogether missing, set the global flag which + -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within + -- the instance. - if SPARK_Mode = Off then + if SPARK_Mode /= On then Ignore_Pragma_SPARK_Mode := True; end if; @@ -5199,9 +5187,10 @@ package body Sem_Ch12 is -- must be instantiated explicitly because they are not part of the -- subprogram template. - Instantiate_Subprogram_Contract (Original_Node (Gen_Decl)); - Build_Subprogram_Renaming; + Instantiate_Subprogram_Contract + (Original_Node (Gen_Decl), Renaming_List); + Build_Subprogram_Renaming; Analyze_Instance_And_Renamings; -- If the generic is marked Import (Intrinsic), then so is the @@ -5291,28 +5280,24 @@ package body Sem_Ch12 is if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then Check_Forward_Instantiation (Gen_Decl); - -- The wrapper package is always delayed, because it does not - -- constitute a freeze point, but to insure that the freeze - -- node is placed properly, it is created directly when - -- instantiating the body (otherwise the freeze node might - -- appear to early for nested instantiations). + -- The wrapper package is always delayed, because it does not + -- constitute a freeze point, but to insure that the freeze node + -- is placed properly, it is created directly when instantiating + -- the body (otherwise the freeze node might appear to early for + -- nested instantiations). For ASIS purposes, indicate that the + -- wrapper package has replaced the instantiation node. elsif Nkind (Parent (N)) = N_Compilation_Unit then - - -- For ASIS purposes, indicate that the wrapper package has - -- replaced the instantiation node. - Rewrite (N, Unit (Parent (N))); Set_Unit (Parent (N), N); end if; - elsif Nkind (Parent (N)) = N_Compilation_Unit then - - -- Replace instance node for library-level instantiations of - -- intrinsic subprograms, for ASIS use. + -- Replace instance node for library-level instantiations of + -- intrinsic subprograms, for ASIS use. - Rewrite (N, Unit (Parent (N))); - Set_Unit (Parent (N), N); + elsif Nkind (Parent (N)) = N_Compilation_Unit then + Rewrite (N, Unit (Parent (N))); + Set_Unit (Parent (N), N); end if; if Parent_Installed then @@ -5332,7 +5317,6 @@ package body Sem_Ch12 is if SPARK_Mode = On then Dynamic_Elaboration_Checks := False; end if; - end if; <<Leave>> @@ -5761,6 +5745,11 @@ package body Sem_Ch12 is -- same entity we may have to traverse several definitions to recover -- the ultimate entity that they refer to. + function Same_Instantiated_Function (E1, E2 : Entity_Id) return Boolean; + -- The formal and the actual must be identical, but if both are + -- given by attributes they end up renaming different generated bodies, + -- and we must verify that the attributes themselves match. + function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean; -- Similarly, if the formal comes from a nested formal package, the -- actual may designate the formal through multiple renamings, which @@ -5815,7 +5804,7 @@ package body Sem_Ch12 is return False; elsif Is_Entity_Name (Constant_Value (Ent)) then - if Entity (Constant_Value (Ent)) = E1 then + if Entity (Constant_Value (Ent)) = E1 then return True; else Ent := Entity (Constant_Value (Ent)); @@ -5836,6 +5825,35 @@ package body Sem_Ch12 is end Same_Instantiated_Constant; -------------------------------- + -- Same_Instantiated_Function -- + -------------------------------- + + function Same_Instantiated_Function + (E1, E2 : Entity_Id) return Boolean + is + U1, U2 : Node_Id; + begin + if Alias (E1) = Alias (E2) then + return True; + + elsif Present (Alias (E2)) then + U1 := Original_Node (Unit_Declaration_Node (E1)); + U2 := Original_Node (Unit_Declaration_Node (Alias (E2))); + + return Nkind (U1) = N_Subprogram_Renaming_Declaration + and then Nkind (Name (U1)) = N_Attribute_Reference + + and then Nkind (U2) = N_Subprogram_Renaming_Declaration + and then Nkind (Name (U2)) = N_Attribute_Reference + + and then + Attribute_Name (Name (U1)) = Attribute_Name (Name (U2)); + else + return False; + end if; + end Same_Instantiated_Function; + + -------------------------------- -- Same_Instantiated_Variable -- -------------------------------- @@ -5895,7 +5913,7 @@ package body Sem_Ch12 is and then not Comes_From_Source (E1) and then Chars (E1) /= Chars (E2) then - while Present (E1) and then Chars (E1) /= Chars (E2) loop + while Present (E1) and then Chars (E1) /= Chars (E2) loop Next_Entity (E1); end loop; end if; @@ -6052,7 +6070,8 @@ package body Sem_Ch12 is else Check_Mismatch - (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); + (Ekind (E2) /= Ekind (E1) + or else not Same_Instantiated_Function (E1, E2)); end if; else @@ -6070,8 +6089,9 @@ package body Sem_Ch12 is --------------------------- procedure Check_Formal_Packages (P_Id : Entity_Id) is - E : Entity_Id; - Formal_P : Entity_Id; + E : Entity_Id; + Formal_P : Entity_Id; + Formal_Decl : Node_Id; begin -- Iterate through the declarations in the instance, looking for package @@ -6089,15 +6109,35 @@ package body Sem_Ch12 is elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then null; - elsif not Box_Present (Parent (Associated_Formal_Package (E))) then - Formal_P := Next_Entity (E); - Check_Formal_Package_Instance (Formal_P, E); + else + Formal_Decl := Parent (Associated_Formal_Package (E)); + + -- Nothing to check if the formal has a box or an others_clause + -- (necessarily with a box). - -- After checking, remove the internal validating package. It - -- is only needed for semantic checks, and as it may contain - -- generic formal declarations it should not reach gigi. + if Box_Present (Formal_Decl) then + null; - Remove (Unit_Declaration_Node (Formal_P)); + elsif Nkind (First (Generic_Associations (Formal_Decl))) = + N_Others_Choice + then + -- The internal validating package was generated but formal + -- and instance are known to be compatible. + + Formal_P := Next_Entity (E); + Remove (Unit_Declaration_Node (Formal_P)); + + else + Formal_P := Next_Entity (E); + Check_Formal_Package_Instance (Formal_P, E); + + -- After checking, remove the internal validating package. + -- It is only needed for semantic checks, and as it may + -- contain generic formal declarations it should not reach + -- gigi. + + Remove (Unit_Declaration_Node (Formal_P)); + end if; end if; end if; @@ -7671,14 +7711,14 @@ package body Sem_Ch12 is begin E1 := First_Entity (P); - while Present (E1) and then E1 /= Instance loop + while Present (E1) and then E1 /= Instance loop if Ekind (E1) = E_Package and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration then if Renamed_Object (E1) = Pack then return True; - elsif E1 = P or else Renamed_Object (E1) = P then + elsif E1 = P or else Renamed_Object (E1) = P then return False; elsif Is_Actual_Of_Previous_Formal (E1) then @@ -8069,7 +8109,7 @@ package body Sem_Ch12 is return Freeze_Node (Id); end Package_Freeze_Node; - -- Start of processing of Freeze_Subprogram_Body + -- Start of processing for Freeze_Subprogram_Body begin -- If the instance and the generic body appear within the same unit, and @@ -8700,7 +8740,7 @@ package body Sem_Ch12 is if Scop = Par_I then null; - -- If the next node is a source body we must freeze in + -- If the next node is a source body we must freeze in -- the current scope as well. elsif Present (Next (N)) @@ -9443,12 +9483,12 @@ package body Sem_Ch12 is -- no one-to-one correspondence between the two lists (for example, -- the actual may include subtypes, itypes, and inherited primitive -- operations, interspersed among the renaming declarations for the - -- actuals) . We retrieve the corresponding actual by name because each + -- actuals). We retrieve the corresponding actual by name because each -- actual has the same name as the formal, and they do appear in the -- same order. function Get_Formal_Entity (N : Node_Id) return Entity_Id; - -- Retrieve entity of defining entity of generic formal parameter. + -- Retrieve entity of defining entity of generic formal parameter. -- Only the declarations of formals need to be considered when -- linking them to actuals, but the declarative list may include -- internal entities generated during analysis, and those are ignored. @@ -9547,7 +9587,7 @@ package body Sem_Ch12 is Actual := Entity (Name (Original_Node (Formal_Node))); - -- The actual in the formal package declaration may be a + -- The actual in the formal package declaration may be a -- renamed generic package, in which case we want to retrieve -- the original generic in order to traverse its formal part. @@ -9686,7 +9726,7 @@ package body Sem_Ch12 is Analyze (Actual); if not Is_Entity_Name (Actual) - or else Ekind (Entity (Actual)) /= E_Package + or else Ekind (Entity (Actual)) /= E_Package then Error_Msg_N ("expect package instance to instantiate formal", Actual); @@ -10601,17 +10641,18 @@ package body Sem_Ch12 is ("actual must exclude null to match generic formal#", Actual); end if; - -- An effectively volatile object cannot be used as an actual in - -- a generic instance. The following check is only relevant when - -- SPARK_Mode is on as it is not a standard Ada legality rule. + -- An effectively volatile object cannot be used as an actual in a + -- generic instantiation (SPARK RM 7.1.3(7)). The following check is + -- relevant only when SPARK_Mode is on as it is not a standard Ada + -- legality rule. if SPARK_Mode = On and then Present (Actual) and then Is_Effectively_Volatile_Object (Actual) then Error_Msg_N - ("volatile object cannot act as actual in generic instantiation " - & "(SPARK RM 7.1.3(8))", Actual); + ("volatile object cannot act as actual in generic instantiation", + Actual); end if; return List; @@ -10636,17 +10677,18 @@ package body Sem_Ch12 is Act_Spec : constant Node_Id := Specification (Act_Decl); Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec); + Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode; + Save_Style_Check : constant Boolean := Style_Check; + + Act_Body : Node_Id; + Act_Body_Id : Entity_Id; Act_Body_Name : Node_Id; Gen_Body : Node_Id; Gen_Body_Id : Node_Id; - Act_Body : Node_Id; - Act_Body_Id : Entity_Id; + Par_Ent : Entity_Id := Empty; + Par_Vis : Boolean := False; Parent_Installed : Boolean := False; - Save_Style_Check : constant Boolean := Style_Check; - - Par_Ent : Entity_Id := Empty; - Par_Vis : Boolean := False; Vis_Prims_List : Elist_Id := No_Elist; -- List of primitives made temporarily visible in the instantiation @@ -10737,7 +10779,7 @@ package body Sem_Ch12 is -- Re-establish the state of information on which checks are suppressed. -- This information was set in Body_Info at the point of instantiation, -- and now we restore it so that the instance is compiled using the - -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01). + -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01). Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; Scope_Suppress := Body_Info.Scope_Suppress; @@ -10787,8 +10829,17 @@ package body Sem_Ch12 is if Present (Gen_Body_Id) then Save_Env (Gen_Unit, Act_Decl_Id); Style_Check := False; - Current_Sem_Unit := Body_Info.Current_Sem_Unit; + -- If the context of the instance is subject to SPARK_Mode "off" or + -- the annotation is altogether missing, set the global flag which + -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within + -- the instance. + + if SPARK_Mode /= On then + Ignore_Pragma_SPARK_Mode := True; + end if; + + Current_Sem_Unit := Body_Info.Current_Sem_Unit; Gen_Body := Unit_Declaration_Node (Gen_Body_Id); Create_Instantiation_Source @@ -10798,9 +10849,12 @@ package body Sem_Ch12 is Copy_Generic_Node (Original_Node (Gen_Body), Empty, Instantiating => True); - -- Build new name (possibly qualified) for body declaration + -- Create proper (possibly qualified) defining name for the body, to + -- correspond to the one in the spec. - Act_Body_Id := New_Copy (Act_Decl_Id); + Act_Body_Id := + Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); + Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); -- Some attributes of spec entity are not inherited by body entity @@ -10811,10 +10865,11 @@ package body Sem_Ch12 is then Act_Body_Name := Make_Defining_Program_Unit_Name (Loc, - Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))), + Name => + New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))), Defining_Identifier => Act_Body_Id); else - Act_Body_Name := Act_Body_Id; + Act_Body_Name := Act_Body_Id; end if; Set_Defining_Unit_Name (Act_Body, Act_Body_Name); @@ -10947,6 +11002,7 @@ package body Sem_Ch12 is end if; Restore_Env; + Ignore_Pragma_SPARK_Mode := Save_IPSM; Style_Check := Save_Style_Check; -- If we have no body, and the unit requires a body, then complain. This @@ -11018,15 +11074,17 @@ package body Sem_Ch12 is Gen_Id : constant Node_Id := Name (Inst_Node); Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); - Anon_Id : constant Entity_Id := + Act_Decl_Id : constant Entity_Id := Defining_Unit_Name (Specification (Act_Decl)); Pack_Id : constant Entity_Id := Defining_Unit_Name (Parent (Act_Decl)); + Saved_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode; Saved_Style_Check : constant Boolean := Style_Check; Saved_Warnings : constant Warning_Record := Save_Warnings; Act_Body : Node_Id; + Act_Body_Id : Entity_Id; Gen_Body : Node_Id; Gen_Body_Id : Node_Id; Pack_Body : Node_Id; @@ -11052,7 +11110,7 @@ package body Sem_Ch12 is -- Re-establish the state of information on which checks are suppressed. -- This information was set in Body_Info at the point of instantiation, -- and now we restore it so that the instance is compiled using the - -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01). + -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01). Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; Scope_Suppress := Body_Info.Scope_Suppress; @@ -11068,11 +11126,11 @@ package body Sem_Ch12 is -- the spec entity appropriately. if Is_Imported (Gen_Unit) then - Set_Is_Imported (Anon_Id); - Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit)); - Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit)); - Set_Convention (Anon_Id, Convention (Gen_Unit)); - Set_Has_Completion (Anon_Id); + Set_Is_Imported (Act_Decl_Id); + Set_First_Rep_Item (Act_Decl_Id, First_Rep_Item (Gen_Unit)); + Set_Interface_Name (Act_Decl_Id, Interface_Name (Gen_Unit)); + Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); + Set_Has_Completion (Act_Decl_Id); return; -- For other cases, compile the body @@ -11102,12 +11160,22 @@ package body Sem_Ch12 is ("missing proper body for instantiation", Gen_Body); end if; - Set_Has_Completion (Anon_Id); + Set_Has_Completion (Act_Decl_Id); return; end if; - Save_Env (Gen_Unit, Anon_Id); + Save_Env (Gen_Unit, Act_Decl_Id); Style_Check := False; + + -- If the context of the instance is subject to SPARK_Mode "off" or + -- the annotation is altogether missing, set the global flag which + -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within + -- the instance. + + if SPARK_Mode /= On then + Ignore_Pragma_SPARK_Mode := True; + end if; + Current_Sem_Unit := Body_Info.Current_Sem_Unit; Create_Instantiation_Source (Inst_Node, @@ -11119,14 +11187,17 @@ package body Sem_Ch12 is Copy_Generic_Node (Original_Node (Gen_Body), Empty, Instantiating => True); - -- Create proper defining name for the body, to correspond to - -- the one in the spec. + -- Create proper defining name for the body, to correspond to the one + -- in the spec. + + Act_Body_Id := + Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); + + Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); + Set_Defining_Unit_Name (Specification (Act_Body), Act_Body_Id); - Set_Defining_Unit_Name (Specification (Act_Body), - Make_Defining_Identifier - (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id))); - Set_Corresponding_Spec (Act_Body, Anon_Id); - Set_Has_Completion (Anon_Id); + Set_Corresponding_Spec (Act_Body, Act_Decl_Id); + Set_Has_Completion (Act_Decl_Id); Check_Generic_Actuals (Pack_Id, False); -- Generate a reference to link the visible subprogram instance to @@ -11207,6 +11278,7 @@ package body Sem_Ch12 is end if; Restore_Env; + Ignore_Pragma_SPARK_Mode := Saved_IPSM; Style_Check := Saved_Style_Check; Restore_Warnings (Saved_Warnings); @@ -11224,16 +11296,16 @@ package body Sem_Ch12 is if Body_Optional then return; - elsif Ekind (Anon_Id) = E_Procedure then + elsif Ekind (Act_Decl_Id) = E_Procedure then Act_Body := Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => - Make_Defining_Identifier (Loc, Chars (Anon_Id)), + Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)), Parameter_Specifications => New_Copy_List - (Parameter_Specifications (Parent (Anon_Id)))), + (Parameter_Specifications (Parent (Act_Decl_Id)))), Declarations => Empty_List, Handled_Statement_Sequence => @@ -11249,7 +11321,7 @@ package body Sem_Ch12 is Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); - Set_Etype (Ret_Expr, (Etype (Anon_Id))); + Set_Etype (Ret_Expr, (Etype (Act_Decl_Id))); Set_Analyzed (Ret_Expr); Act_Body := @@ -11257,12 +11329,12 @@ package body Sem_Ch12 is Specification => Make_Function_Specification (Loc, Defining_Unit_Name => - Make_Defining_Identifier (Loc, Chars (Anon_Id)), + Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)), Parameter_Specifications => New_Copy_List - (Parameter_Specifications (Parent (Anon_Id))), + (Parameter_Specifications (Parent (Act_Decl_Id))), Result_Definition => - New_Occurrence_Of (Etype (Anon_Id), Loc)), + New_Occurrence_Of (Etype (Act_Decl_Id), Loc)), Declarations => Empty_List, Handled_Statement_Sequence => @@ -11272,9 +11344,10 @@ package body Sem_Ch12 is (Make_Simple_Return_Statement (Loc, Ret_Expr)))); end if; - Pack_Body := Make_Package_Body (Loc, - Defining_Unit_Name => New_Copy (Pack_Id), - Declarations => New_List (Act_Body)); + Pack_Body := + Make_Package_Body (Loc, + Defining_Unit_Name => New_Copy (Pack_Id), + Declarations => New_List (Act_Body)); Insert_After (Inst_Node, Pack_Body); Set_Corresponding_Spec (Pack_Body, Pack_Id); @@ -11970,7 +12043,7 @@ package body Sem_Ch12 is -- If the formal and actual types are abstract, check that there -- are no abstract primitives of the actual type that correspond to -- nonabstract primitives of the formal type (second sentence of - -- RM95-3.9.3(9)). + -- RM95 3.9.3(9)). if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then Check_Abstract_Primitives : declare @@ -12202,7 +12275,7 @@ package body Sem_Ch12 is end if; -- Verify that limitedness matches. If parent is a limited - -- interface then the generic formal is not unless declared + -- interface then the generic formal is not unless declared -- explicitly so. If not declared limited, the actual cannot be -- limited (see AI05-0087). @@ -14739,10 +14812,9 @@ package body Sem_Ch12 is elsif Is_Generic_Contract_Pragma (Prag) and then Prag /= Templ then if Is_Package_Contract_Annotation (Prag) then Context := Find_Related_Package_Or_Body (Prag); - else pragma Assert (Is_Subprogram_Contract_Annotation (Prag)); - Context := Find_Related_Subprogram_Or_Body (Prag); + Context := Find_Related_Declaration_Or_Body (Prag); end if; -- The use of Original_Node accounts for the case when the @@ -14866,63 +14938,6 @@ package body Sem_Ch12 is end loop; end Save_Global_References_In_Aspects; - ---------------------------------------- - -- Save_Global_References_In_Contract -- - ---------------------------------------- - - procedure Save_Global_References_In_Contract - (Templ : Node_Id; - Gen_Id : Entity_Id) - is - procedure Save_Global_References_In_List (First_Prag : Node_Id); - -- Save all global references in contract-related source pragmas found - -- in the list starting with pragma First_Prag. - - ------------------------------------ - -- Save_Global_References_In_List -- - ------------------------------------ - - procedure Save_Global_References_In_List (First_Prag : Node_Id) is - Prag : Node_Id; - - begin - Prag := First_Prag; - while Present (Prag) loop - if Is_Generic_Contract_Pragma (Prag) then - Save_Global_References (Prag); - end if; - - Prag := Next_Pragma (Prag); - end loop; - end Save_Global_References_In_List; - - -- Local variables - - Items : constant Node_Id := Contract (Defining_Entity (Templ)); - - -- Start of processing for Save_Global_References_In_Contract - - begin - -- The entity of the analyzed generic copy must be on the scope stack - -- to ensure proper detection of global references. - - Push_Scope (Gen_Id); - - if Permits_Aspect_Specifications (Templ) - and then Has_Aspects (Templ) - then - Save_Global_References_In_Aspects (Templ); - end if; - - if Present (Items) then - Save_Global_References_In_List (Pre_Post_Conditions (Items)); - Save_Global_References_In_List (Contract_Test_Cases (Items)); - Save_Global_References_In_List (Classifications (Items)); - end if; - - Pop_Scope; - end Save_Global_References_In_Contract; - -------------------------------------- -- Set_Copied_Sloc_For_Inlined_Body -- -------------------------------------- diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads index 53ff6c50e95..c54d7359dee 100644 --- a/gcc/ada/sem_ch12.ads +++ b/gcc/ada/sem_ch12.ads @@ -152,12 +152,9 @@ package Sem_Ch12 is -- restored in stack-like fashion. Front-end inlining also uses these -- structures for the management of private/full views. - procedure Save_Global_References_In_Contract - (Templ : Node_Id; - Gen_Id : Entity_Id); - -- Save all global references found within the aspect specifications and - -- the contract-related source pragmas assocated with generic template - -- Templ. Gen_Id denotes the entity of the analyzed generic copy. + procedure Save_Global_References_In_Aspects (N : Node_Id); + -- Save all global references found within the expressions of all aspects + -- that appear on node N. procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id); -- This procedure is used when a subprogram body is inlined. This process diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5494d332184..36eb7ad5490 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -122,7 +122,7 @@ package body Sem_Ch13 is -- to generate appropriate semantic checks that are delayed until this -- point (they had to be delayed this long for cases of delayed aspects, -- e.g. analysis of statically predicated subtypes in choices, for which - -- we have to be sure the subtypes in question are frozen before checking. + -- we have to be sure the subtypes in question are frozen before checking). function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding @@ -471,10 +471,10 @@ package body Sem_Ch13 is ("machine scalar rules not followed for&", First_Bit (CC), Comp); - Error_Msg_Uint_1 := Lbit; + Error_Msg_Uint_1 := Lbit + 1; Error_Msg_Uint_2 := Max_Machine_Scalar_Size; Error_Msg_F - ("\last bit (^) exceeds maximum machine " + ("\last bit + 1 (^) exceeds maximum machine " & "scalar size (^)", First_Bit (CC)); @@ -482,7 +482,7 @@ package body Sem_Ch13 is Error_Msg_Uint_1 := SSU; Error_Msg_F ("\and is not a multiple of Storage_Unit (^) " - & "(RM 13.4.1(10))", + & "(RM 13.5.1(10))", First_Bit (CC)); else @@ -1208,26 +1208,28 @@ package body Sem_Ch13 is procedure Decorate (Asp : Node_Id; Prag : Node_Id); -- Establish linkages between an aspect and its corresponding pragma - procedure Insert_After_SPARK_Mode - (Prag : Node_Id; - Ins_Nod : Node_Id; - Decls : List_Id); - -- Subsidiary to the analysis of aspects Abstract_State, Ghost, - -- Initializes, Initial_Condition and Refined_State. Insert node Prag - -- before node Ins_Nod. If Ins_Nod is for pragma SPARK_Mode, then skip - -- SPARK_Mode. Decls is the associated declarative list where Prag is to - -- reside. - - procedure Insert_Pragma (Prag : Node_Id); - -- Subsidiary to the analysis of aspects Attach_Handler, Contract_Cases, - -- Depends, Global, Post, Pre, Refined_Depends and Refined_Global. + procedure Insert_Pragma + (Prag : Node_Id; + Is_Instance : Boolean := False); + -- Subsidiary to the analysis of aspects + -- Abstract_State + -- Attach_Handler + -- Contract_Cases + -- Depends + -- Ghost + -- Global + -- Initial_Condition + -- Initializes + -- Post + -- Pre + -- Refined_Depends + -- Refined_Global + -- Refined_State + -- SPARK_Mode + -- Warnings -- Insert pragma Prag such that it mimics the placement of a source - -- pragma of the same kind. - -- - -- procedure Proc (Formal : ...) with Global => ...; - -- - -- procedure Proc (Formal : ...); - -- pragma Global (...); + -- pragma of the same kind. Flag Is_Generic should be set when the + -- context denotes a generic instance. -------------- -- Decorate -- @@ -1241,82 +1243,184 @@ package body Sem_Ch13 is Set_Parent (Prag, Asp); end Decorate; - ----------------------------- - -- Insert_After_SPARK_Mode -- - ----------------------------- + ------------------- + -- Insert_Pragma -- + ------------------- - procedure Insert_After_SPARK_Mode - (Prag : Node_Id; - Ins_Nod : Node_Id; - Decls : List_Id) + procedure Insert_Pragma + (Prag : Node_Id; + Is_Instance : Boolean := False) is - Decl : Node_Id := Ins_Nod; + Aux : Node_Id; + Decl : Node_Id; + Decls : List_Id; + Def : Node_Id; begin - -- Skip SPARK_Mode + -- When the aspect appears on a package, protected unit, subprogram + -- or task unit body, insert the generated pragma at the top of the + -- body declarations to emulate the behavior of a source pragma. - if Present (Decl) - and then Nkind (Decl) = N_Pragma - and then Pragma_Name (Decl) = Name_SPARK_Mode + -- package body Pack with Aspect is + + -- package body Pack is + -- pragma Prag; + + if Nkind_In (N, N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body) then - Decl := Next (Decl); - end if; + Decls := Declarations (N); + + if No (Decls) then + Decls := New_List; + Set_Declarations (N, Decls); + end if; + + -- Skip other internally generated pragmas from aspects to find + -- the proper insertion point. As a result the order of pragmas + -- is the same as the order of aspects. + + -- As precondition pragmas generated from conjuncts in the + -- precondition aspect are presented in reverse order to + -- Insert_Pragma, insert them in the correct order here by not + -- skipping previously inserted precondition pragmas when the + -- current pragma is a precondition. + + Decl := First (Decls); + while Present (Decl) loop + if Nkind (Decl) = N_Pragma + and then From_Aspect_Specification (Decl) + and then not (Get_Pragma_Id (Decl) = Pragma_Precondition + and then + Get_Pragma_Id (Prag) = Pragma_Precondition) + then + Next (Decl); + else + exit; + end if; + end loop; - if Present (Decl) then - Insert_Before (Decl, Prag); + if Present (Decl) then + Insert_Before (Decl, Prag); + else + Append_To (Decls, Prag); + end if; - -- Aitem acts as the last declaration + -- When the aspect is associated with a [generic] package declaration + -- insert the generated pragma at the top of the visible declarations + -- to emulate the behavior of a source pragma. - else - Append_To (Decls, Prag); - end if; - end Insert_After_SPARK_Mode; + -- package Pack with Aspect is - ------------------- - -- Insert_Pragma -- - ------------------- + -- package Pack is + -- pragma Prag; - procedure Insert_Pragma (Prag : Node_Id) is - Aux : Node_Id; - Decl : Node_Id; + elsif Nkind_In (N, N_Generic_Package_Declaration, + N_Package_Declaration) + then + Decls := Visible_Declarations (Specification (N)); - begin - if Nkind (N) = N_Subprogram_Body then - if Present (Declarations (N)) then - - -- Skip other internally generated pragmas from aspects to find - -- the proper insertion point. As a result the order of pragmas - -- is the same as the order of aspects. - - -- As precondition pragmas generated from conjuncts in the - -- precondition aspect are presented in reverse order to - -- Insert_Pragma, insert them in the correct order here by not - -- skipping previously inserted precondition pragmas when the - -- current pragma is a precondition. - - Decl := First (Declarations (N)); - while Present (Decl) loop - if Nkind (Decl) = N_Pragma - and then From_Aspect_Specification (Decl) - and then not (Get_Pragma_Id (Decl) = Pragma_Precondition - and then - Get_Pragma_Id (Prag) = Pragma_Precondition) - then - Next (Decl); - else - exit; - end if; + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (Specification (N), Decls); + end if; + + -- The visible declarations of a generic instance have the + -- following structure: + + -- <renamings of generic formals> + -- <renamings of internally-generated spec and body> + -- <first source declaration> + + -- Insert the pragma before the first source declaration by + -- skipping the instance "header". + + if Is_Instance then + Decl := First (Decls); + while Present (Decl) and then not Comes_From_Source (Decl) loop + Decl := Next (Decl); end loop; + -- The instance "header" is followed by at least one source + -- declaration. + if Present (Decl) then Insert_Before (Decl, Prag); + + -- Otherwise the pragma is placed after the instance "header" + else - Append (Prag, Declarations (N)); + Append_To (Decls, Prag); end if; + + -- Otherwise this is not a generic instance + else - Set_Declarations (N, New_List (Prag)); + Prepend_To (Decls, Prag); + end if; + + -- When the aspect is associated with a protected unit declaration, + -- insert the generated pragma at the top of the visible declarations + -- the emulate the behavior of a source pragma. + + -- protected [type] Prot with Aspect is + + -- protected [type] Prot is + -- pragma Prag; + + elsif Nkind (N) = N_Protected_Type_Declaration then + Def := Protected_Definition (N); + + if No (Def) then + Def := + Make_Protected_Definition (Sloc (N), + Visible_Declarations => New_List, + End_Label => Empty); + + Set_Protected_Definition (N, Def); + end if; + + Decls := Visible_Declarations (Def); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (Def, Decls); end if; + Prepend_To (Decls, Prag); + + -- When the aspect is associated with a task unit declaration, insert + -- insert the generated pragma at the top of the visible declarations + -- the emulate the behavior of a source pragma. + + -- task [type] Prot with Aspect is + + -- task [type] Prot is + -- pragma Prag; + + elsif Nkind (N) = N_Task_Type_Declaration then + Def := Task_Definition (N); + + if No (Def) then + Def := + Make_Task_Definition (Sloc (N), + Visible_Declarations => New_List, + End_Label => Empty); + + Set_Task_Definition (N, Def); + end if; + + Decls := Visible_Declarations (Def); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (Def, Decls); + end if; + + Prepend_To (Decls, Prag); + -- When the context is a library unit, the pragma is added to the -- Pragmas_After list. @@ -1329,7 +1433,7 @@ package body Sem_Ch13 is Prepend (Prag, Pragmas_After (Aux)); - -- Default + -- Default, the pragma is inserted after the context else Insert_After (N, Prag); @@ -1444,35 +1548,56 @@ package body Sem_Ch13 is ----------------------------------------- procedure Analyze_Aspect_Implicit_Dereference is + Disc : Entity_Id; + Parent_Disc : Entity_Id; + begin if not Is_Type (E) or else not Has_Discriminants (E) then Error_Msg_N - ("aspect must apply to a type with discriminants", N); + ("aspect must apply to a type with discriminants", Expr); - else - declare - Disc : Entity_Id; + elsif not Is_Entity_Name (Expr) then + Error_Msg_N + ("aspect must name a discriminant of current type", Expr); - begin - Disc := First_Discriminant (E); - while Present (Disc) loop - if Chars (Expr) = Chars (Disc) - and then Ekind (Etype (Disc)) = - E_Anonymous_Access_Type - then - Set_Has_Implicit_Dereference (E); - Set_Has_Implicit_Dereference (Disc); - return; - end if; + else + Disc := First_Discriminant (E); + while Present (Disc) loop + if Chars (Expr) = Chars (Disc) + and then Ekind (Etype (Disc)) = + E_Anonymous_Access_Type + then + Set_Has_Implicit_Dereference (E); + Set_Has_Implicit_Dereference (Disc); + exit; + end if; - Next_Discriminant (Disc); - end loop; + Next_Discriminant (Disc); + end loop; - -- Error if no proper access discriminant. + -- Error if no proper access discriminant + if No (Disc) then Error_Msg_NE ("not an access discriminant of&", Expr, E); - end; + return; + end if; + end if; + + -- For a type extension, check whether parent has a + -- reference discriminant, to verify that use is proper. + + if Is_Derived_Type (E) + and then Has_Discriminants (Etype (E)) + then + Parent_Disc := Get_Reference_Discriminant (Etype (E)); + + if Present (Parent_Disc) + and then Corresponding_Discriminant (Disc) /= Parent_Disc + then + Error_Msg_N ("reference discriminant does not match " & + "discriminant of parent type", Expr); + end if; end if; end Analyze_Aspect_Implicit_Dereference; @@ -1517,7 +1642,7 @@ package body Sem_Ch13 is end if; Set_Corresponding_Aspect (Aitem, Aspect); - Set_From_Aspect_Specification (Aitem, True); + Set_From_Aspect_Specification (Aitem); end Make_Aitem_Pragma; -- Start of processing for Analyze_One_Aspect @@ -1854,7 +1979,7 @@ package body Sem_Ch13 is Expression => Ent), Make_Pragma_Argument_Association (Sloc (Expr), Expression => Relocate_Node (Expr))), - Pragma_Name => Name_Predicate); + Pragma_Name => Name_Predicate); -- Mark type has predicates, and remember what kind of -- aspect lead to this predicate (we need this to access @@ -1885,6 +2010,46 @@ package body Sem_Ch13 is Ensure_Freeze_Node (Full_View (E)); end if; + -- Predicate_Failure + + when Aspect_Predicate_Failure => + + -- This aspect applies only to subtypes + + if not Is_Type (E) then + Error_Msg_N + ("predicate can only be specified for a subtype", + Aspect); + goto Continue; + + elsif Is_Incomplete_Type (E) then + Error_Msg_N + ("predicate cannot apply to incomplete view", Aspect); + goto Continue; + end if; + + -- Construct the pragma + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Predicate_Failure); + + Set_Has_Predicates (E); + + -- If the type is private, indicate that its completion + -- has a freeze node, because that is the one that will + -- be visible at freeze time. + + if Is_Private_Type (E) and then Present (Full_View (E)) then + Set_Has_Predicates (Full_View (E)); + Set_Has_Delayed_Aspects (Full_View (E)); + Ensure_Freeze_Node (Full_View (E)); + end if; + -- Case 2b: Aspects corresponding to pragmas with two -- arguments, where the second argument is a local name -- referring to the entity, and the first argument is the @@ -2015,8 +2180,8 @@ package body Sem_Ch13 is Analyze_And_Resolve (Expr, Standard_Integer); -- Interrupt_Priority aspect not allowed for main - -- subprograms. ARM D.1 does not forbid this explicitly, - -- but ARM J.15.11 (6/3) does not permit pragma + -- subprograms. RM D.1 does not forbid this explicitly, + -- but RM J.15.11(6/3) does not permit pragma -- Interrupt_Priority for subprograms. if A_Id = Aspect_Interrupt_Priority then @@ -2039,7 +2204,7 @@ package body Sem_Ch13 is (Specification (N))) or else not Is_Compilation_Unit (Defining_Entity (N)) then - -- See ARM D.1 (14/3) and D.16 (12/3) + -- See RM D.1(14/3) and D.16(12/3) Error_Msg_N ("aspect applied to subprogram other than the " @@ -2107,11 +2272,9 @@ package body Sem_Ch13 is goto Continue; - -- For tasks + -- For tasks pass the aspect as an attribute else - -- Pass the aspect as an attribute - Aitem := Make_Attribute_Definition_Clause (Loc, Name => Ent, @@ -2130,6 +2293,10 @@ package body Sem_Ch13 is Expression => New_Occurrence_Of (E, Loc))), Pragma_Name => Chars (Id)); + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + -- Case 2c: Aspects corresponding to pragmas with three -- arguments. @@ -2185,8 +2352,6 @@ package body Sem_Ch13 is when Aspect_Abstract_State => Abstract_State : declare Context : Node_Id := N; - Decl : Node_Id; - Decls : List_Id; begin -- When aspect Abstract_State appears on a generic package, @@ -2205,63 +2370,67 @@ package body Sem_Ch13 is Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), Pragma_Name => Name_Abstract_State); - Decorate (Aspect, Aitem); - - Decls := Visible_Declarations (Specification (Context)); - -- In general pragma Abstract_State must be at the top - -- of the existing visible declarations to emulate its - -- source counterpart. The only exception to this is a - -- generic instance in which case the pragma must be - -- inserted after the association renamings. + Decorate (Aspect, Aitem); + Insert_Pragma + (Prag => Aitem, + Is_Instance => + Is_Generic_Instance (Defining_Entity (Context))); - if Present (Decls) then - Decl := First (Decls); + else + Error_Msg_NE + ("aspect & must apply to a package declaration", + Aspect, Id); + end if; - -- The visible declarations of a generic instance have - -- the following structure: + goto Continue; + end Abstract_State; - -- <renamings of generic formals> - -- <renamings of internally-generated spec and body> - -- <first source declaration> + -- Aspect Async_Readers is never delayed because it is + -- equivalent to a source pragma which appears after the + -- related object declaration. - -- The pragma must be inserted before the first source - -- declaration, skip the instance "header". + when Aspect_Async_Readers => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Async_Readers); - if Is_Generic_Instance (Defining_Entity (Context)) then - while Present (Decl) - and then not Comes_From_Source (Decl) - loop - Decl := Next (Decl); - end loop; - end if; + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; - -- When aspects Abstract_State, Ghost, - -- Initial_Condition and Initializes are out of order, - -- ensure that pragma SPARK_Mode is always at the top - -- of the declarations to properly enabled/suppress - -- errors. + -- Aspect Async_Writers is never delayed because it is + -- equivalent to a source pragma which appears after the + -- related object declaration. - Insert_After_SPARK_Mode - (Prag => Aitem, - Ins_Nod => Decl, - Decls => Decls); + when Aspect_Async_Writers => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Async_Writers); - -- Otherwise the pragma forms a new declarative list + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; - else - Set_Visible_Declarations - (Specification (Context), New_List (Aitem)); - end if; + -- Aspect Constant_After_Elaboration is never delayed because + -- it is equivalent to a source pragma which appears after the + -- related object declaration. - else - Error_Msg_NE - ("aspect & must apply to a package declaration", - Aspect, Id); - end if; + when Aspect_Constant_After_Elaboration => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => + Name_Constant_After_Elaboration); + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); goto Continue; - end Abstract_State; -- Aspect Default_Internal_Condition is never delayed because -- it is equivalent to a source pragma which appears after the @@ -2317,6 +2486,36 @@ package body Sem_Ch13 is Insert_Pragma (Aitem); goto Continue; + -- Aspect Effecitve_Reads is never delayed because it is + -- equivalent to a source pragma which appears after the + -- related object declaration. + + when Aspect_Effective_Reads => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Effective_Reads); + + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + + -- Aspect Effective_Writes is never delayed because it is + -- equivalent to a source pragma which appears after the + -- related object declaration. + + when Aspect_Effective_Writes => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Effective_Writes); + + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + -- Aspect Extensions_Visible is never delayed because it is -- equivalent to a source pragma which appears after the -- related subprogram. @@ -2337,10 +2536,7 @@ package body Sem_Ch13 is -- declarations or after an object, a [generic] subprogram, or -- a type declaration. - when Aspect_Ghost => Ghost : declare - Decls : List_Id; - - begin + when Aspect_Ghost => Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, @@ -2348,40 +2544,8 @@ package body Sem_Ch13 is Pragma_Name => Name_Ghost); Decorate (Aspect, Aitem); - - -- When the aspect applies to a [generic] package, insert - -- the pragma at the top of the visible declarations. This - -- emulates the placement of a source pragma. - - if Nkind_In (N, N_Generic_Package_Declaration, - N_Package_Declaration) - then - Decls := Visible_Declarations (Specification (N)); - - if No (Decls) then - Decls := New_List; - Set_Visible_Declarations (N, Decls); - end if; - - -- When aspects Abstract_State, Ghost, Initial_Condition - -- and Initializes are out of order, ensure that pragma - -- SPARK_Mode is always at the top of the declarations to - -- properly enabled/suppress errors. - - Insert_After_SPARK_Mode - (Prag => Aitem, - Ins_Nod => First (Decls), - Decls => Decls); - - -- Otherwise the context is an object, [generic] subprogram - -- or type declaration. - - else - Insert_Pragma (Aitem); - end if; - + Insert_Pragma (Aitem); goto Continue; - end Ghost; -- Global @@ -2415,7 +2579,6 @@ package body Sem_Ch13 is when Aspect_Initial_Condition => Initial_Condition : declare Context : Node_Id := N; - Decls : List_Id; begin -- When aspect Initial_Condition appears on a generic @@ -2429,30 +2592,20 @@ package body Sem_Ch13 is if Nkind_In (Context, N_Generic_Package_Declaration, N_Package_Declaration) then - Decls := Visible_Declarations (Specification (Context)); - Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), Pragma_Name => Name_Initial_Condition); - Decorate (Aspect, Aitem); - - if No (Decls) then - Decls := New_List; - Set_Visible_Declarations (Context, Decls); - end if; - -- When aspects Abstract_State, Ghost, Initial_Condition - -- and Initializes are out of order, ensure that pragma - -- SPARK_Mode is always at the top of the declarations to - -- properly enabled/suppress errors. + Decorate (Aspect, Aitem); + Insert_Pragma + (Prag => Aitem, + Is_Instance => + Is_Generic_Instance (Defining_Entity (Context))); - Insert_After_SPARK_Mode - (Prag => Aitem, - Ins_Nod => First (Decls), - Decls => Decls); + -- Otherwise the context is illegal else Error_Msg_NE @@ -2474,7 +2627,6 @@ package body Sem_Ch13 is when Aspect_Initializes => Initializes : declare Context : Node_Id := N; - Decls : List_Id; begin -- When aspect Initializes appears on a generic package, @@ -2488,29 +2640,19 @@ package body Sem_Ch13 is if Nkind_In (Context, N_Generic_Package_Declaration, N_Package_Declaration) then - Decls := Visible_Declarations (Specification (Context)); - Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), Pragma_Name => Name_Initializes); - Decorate (Aspect, Aitem); - - if No (Decls) then - Decls := New_List; - Set_Visible_Declarations (Context, Decls); - end if; - -- When aspects Abstract_State, Ghost, Initial_Condition - -- and Initializes are out of order, ensure that pragma - -- SPARK_Mode is always at the top of the declarations to - -- properly enabled/suppress errors. + Decorate (Aspect, Aitem); + Insert_Pragma + (Prag => Aitem, + Is_Instance => + Is_Generic_Instance (Defining_Entity (Context))); - Insert_After_SPARK_Mode - (Prag => Aitem, - Ins_Nod => First (Decls), - Decls => Decls); + -- Otherwise the context is illegal else Error_Msg_NE @@ -2545,6 +2687,7 @@ package body Sem_Ch13 is when Aspect_Part_Of => if Nkind_In (N, N_Object_Declaration, N_Package_Instantiation) + or else Is_Single_Concurrent_Type_Declaration (N) then Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( @@ -2552,62 +2695,29 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Part_Of); + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + else Error_Msg_NE - ("aspect & must apply to a variable or package " - & "instantiation", Aspect, Id); + ("aspect & must apply to package instantiation, " + & "object, single protected type or single task type", + Aspect, Id); end if; -- SPARK_Mode - when Aspect_SPARK_Mode => SPARK_Mode : declare - Decls : List_Id; - - begin + when Aspect_SPARK_Mode => Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), Pragma_Name => Name_SPARK_Mode); - -- When the aspect appears on a package or a subprogram - -- body, insert the generated pragma at the top of the body - -- declarations to emulate the behavior of a source pragma. - - if Nkind_In (N, N_Package_Body, N_Subprogram_Body) then - Decorate (Aspect, Aitem); - - Decls := Declarations (N); - - if No (Decls) then - Decls := New_List; - Set_Declarations (N, Decls); - end if; - - Prepend_To (Decls, Aitem); - goto Continue; - - -- When the aspect is associated with a [generic] package - -- declaration, insert the generated pragma at the top of - -- the visible declarations to emulate the behavior of a - -- source pragma. - - elsif Nkind_In (N, N_Generic_Package_Declaration, - N_Package_Declaration) - then - Decorate (Aspect, Aitem); - - Decls := Visible_Declarations (Specification (N)); - - if No (Decls) then - Decls := New_List; - Set_Visible_Declarations (Specification (N), Decls); - end if; - - Prepend_To (Decls, Aitem); - goto Continue; - end if; - end SPARK_Mode; + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; -- Refined_Depends @@ -2662,39 +2772,24 @@ package body Sem_Ch13 is -- Refined_State - when Aspect_Refined_State => Refined_State : declare - Decls : List_Id; + when Aspect_Refined_State => - begin -- The corresponding pragma for Refined_State is inserted in -- the declarations of the related package body. This action -- synchronizes both the source and from-aspect versions of -- the pragma. if Nkind (N) = N_Package_Body then - Decls := Declarations (N); - Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), Pragma_Name => Name_Refined_State); - Decorate (Aspect, Aitem); - - if No (Decls) then - Decls := New_List; - Set_Declarations (N, Decls); - end if; - -- Pragma Refined_State must be inserted after pragma - -- SPARK_Mode in the tree. This ensures that any error - -- messages dependent on SPARK_Mode will be properly - -- enabled/suppressed. + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); - Insert_After_SPARK_Mode - (Prag => Aitem, - Ins_Nod => First (Decls), - Decls => Decls); + -- Otherwise the context is illegal else Error_Msg_NE @@ -2702,7 +2797,6 @@ package body Sem_Ch13 is end if; goto Continue; - end Refined_State; -- Relative_Deadline @@ -2742,6 +2836,21 @@ package body Sem_Ch13 is end; end if; + -- Aspect Volatile_Function is never delayed because it is + -- equivalent to a source pragma which appears after the + -- related subprogram. + + when Aspect_Volatile_Function => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Volatile_Function); + + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + -- Case 2e: Annotate aspect when Aspect_Annotate => @@ -3157,20 +3266,24 @@ package body Sem_Ch13 is goto Continue; end if; - Analyze_And_Resolve (Expr, Standard_Boolean); - -- If we're in a generic template, we don't want to try -- to disable controlled types, because typical usage is -- "Disable_Controlled => not <some_check>'Enabled", and -- the value of Enabled is not known until we see a - -- particular instance. + -- particular instance. In such a context, we just need + -- to preanalyze the expression for legality. if Expander_Active then + Analyze_And_Resolve (Expr, Standard_Boolean); + if not Present (Expr) or else Is_True (Static_Boolean (Expr)) then Set_Disable_Controlled (E); end if; + + elsif Serious_Errors_Detected = 0 then + Preanalyze_And_Resolve (Expr, Standard_Boolean); end if; goto Continue; @@ -3197,47 +3310,10 @@ package body Sem_Ch13 is goto Continue; end if; - -- External property aspects are Boolean by nature, but - -- their pragmas must contain two arguments, the second - -- being the optional Boolean expression. - - if A_Id = Aspect_Async_Readers or else - A_Id = Aspect_Async_Writers or else - A_Id = Aspect_Effective_Reads or else - A_Id = Aspect_Effective_Writes - then - declare - Args : List_Id; - - begin - -- The first argument of the external property pragma - -- is the related object. - - Args := - New_List ( - Make_Pragma_Argument_Association (Sloc (Ent), - Expression => Ent)); - - -- The second argument is the optional Boolean - -- expression which must be propagated even if it - -- evaluates to False as this has special semantic - -- meaning. - - if Present (Expr) then - Append_To (Args, - Make_Pragma_Argument_Association (Loc, - Expression => Relocate_Node (Expr))); - end if; - - Make_Aitem_Pragma - (Pragma_Argument_Associations => Args, - Pragma_Name => Nam); - end; - -- Cases where we do not delay, includes all cases where the -- expression is missing other than the above cases. - elsif not Delay_Required or else No (Expr) then + if not Delay_Required or else No (Expr) then Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent), @@ -3465,9 +3541,9 @@ package body Sem_Ch13 is Body_Id : constant Entity_Id := Defining_Entity (N); procedure Diagnose_Misplaced_Aspects (Spec_Id : Entity_Id); - -- Subprogram body [stub] N has aspects, but they are not properly - -- placed. Emit an error message depending on the aspects involved. - -- Spec_Id is the entity of the corresponding spec. + -- Body [stub] N has aspects, but they are not properly placed. Emit an + -- error message depending on the aspects involved. Spec_Id denotes the + -- entity of the corresponding spec. -------------------------------- -- Diagnose_Misplaced_Aspects -- @@ -3523,7 +3599,7 @@ package body Sem_Ch13 is else Error_Msg_N - ("aspect specification must appear in subprogram declaration", + ("aspect specification must appear on initial declaration", Asp); end if; end Misplaced_Aspect_Error; @@ -3565,7 +3641,7 @@ package body Sem_Ch13 is else Error_Msg_N - ("aspect specification must appear in subprogram declaration", + ("aspect specification must appear on initial declaration", Asp); end if; @@ -3575,23 +3651,17 @@ package body Sem_Ch13 is -- Local variables - Spec_Id : Entity_Id; + Spec_Id : constant Entity_Id := Unique_Defining_Entity (N); -- Start of processing for Analyze_Aspects_On_Body_Or_Stub begin - if Nkind (N) = N_Subprogram_Body_Stub then - Spec_Id := Corresponding_Spec_Of_Stub (N); - else - Spec_Id := Corresponding_Spec (N); - end if; - -- Language-defined aspects cannot be associated with a subprogram body -- [stub] if the subprogram has a spec. Certain implementation defined -- aspects are allowed to break this rule (for all applicable cases, see -- table Aspects.Aspect_On_Body_Or_Stub_OK). - if Present (Spec_Id) and then not Aspects_On_Body_Or_Stub_OK (N) then + if Spec_Id /= Body_Id and then not Aspects_On_Body_Or_Stub_OK (N) then Diagnose_Misplaced_Aspects (Spec_Id); else Analyze_Aspect_Specifications (N, Body_Id); @@ -3767,7 +3837,7 @@ package body Sem_Ch13 is -- the type of the formal match, or one is the class-wide of the -- other, in the case of a class-wide stream operation. - if Base_Type (Typ) = Base_Type (Ent) + if Base_Type (Typ) = Base_Type (Ent) or else (Is_Class_Wide_Type (Typ) and then Typ = Class_Wide_Type (Base_Type (Ent))) or else (Is_Class_Wide_Type (Ent) @@ -3892,6 +3962,10 @@ package body Sem_Ch13 is procedure Check_Indexing_Functions is Indexing_Found : Boolean := False; + procedure Check_Inherited_Indexing; + -- For a derived type, check that no indexing aspect is specified + -- for the type if it is also inherited + procedure Check_One_Function (Subp : Entity_Id); -- Check one possible interpretation. Sets Indexing_Found True if a -- legal indexing function is found. @@ -3900,6 +3974,45 @@ package body Sem_Ch13 is -- Diagnose illegal indexing function if not overloaded. In the -- overloaded case indicate that no legal interpretation exists. + ------------------------------ + -- Check_Inherited_Indexing -- + ------------------------------ + + procedure Check_Inherited_Indexing is + Inherited : Node_Id; + + begin + if Attr = Name_Constant_Indexing then + Inherited := + Find_Aspect (Etype (Ent), Aspect_Constant_Indexing); + else pragma Assert (Attr = Name_Variable_Indexing); + Inherited := + Find_Aspect (Etype (Ent), Aspect_Variable_Indexing); + end if; + + if Present (Inherited) then + if Debug_Flag_Dot_XX then + null; + + -- OK if current attribute_definition_clause is expansion of + -- inherited aspect. + + elsif Aspect_Rep_Item (Inherited) = N then + null; + + -- Indicate the operation that must be overridden, rather than + -- redefining the indexing aspect. + + else + Illegal_Indexing + ("indexing function already inherited from parent type"); + Error_Msg_NE + ("!override & instead", + N, Entity (Expression (Inherited))); + end if; + end if; + end Check_Inherited_Indexing; + ------------------------ -- Check_One_Function -- ------------------------ @@ -3934,40 +4047,8 @@ package body Sem_Ch13 is ("indexing function must have at least two parameters"); return; - -- For a derived type, check that no indexing aspect is specified - -- for the type if it is also inherited - elsif Is_Derived_Type (Ent) then - declare - Inherited : Node_Id; - - begin - if Attr = Name_Constant_Indexing then - Inherited := - Find_Aspect (Etype (Ent), Aspect_Constant_Indexing); - else pragma Assert (Attr = Name_Variable_Indexing); - Inherited := - Find_Aspect (Etype (Ent), Aspect_Variable_Indexing); - end if; - - if Present (Inherited) then - if Debug_Flag_Dot_XX then - null; - - -- Indicate the operation that must be overridden, rather - -- than redefining the indexing aspect - - else - Illegal_Indexing - ("indexing function already inherited " - & "from parent type"); - Error_Msg_NE - ("!override & instead", - N, Entity (Expression (Inherited))); - return; - end if; - end if; - end; + Check_Inherited_Indexing; end if; if not Check_Primitive_Function (Subp) then @@ -4086,7 +4167,7 @@ package body Sem_Ch13 is begin if In_Instance then - return; + Check_Inherited_Indexing; end if; Analyze (Expr); @@ -4129,8 +4210,6 @@ package body Sem_Ch13 is ------------------------------ procedure Check_Iterator_Functions is - Default : Entity_Id; - function Valid_Default_Iterator (Subp : Entity_Id) return Boolean; -- Check one possible interpretation for validity @@ -4187,10 +4266,10 @@ package body Sem_Ch13 is end if; else - Default := Empty; declare - I : Interp_Index; - It : Interp; + Default : Entity_Id := Empty; + I : Interp_Index; + It : Interp; begin Get_First_Interp (Expr, I, It); @@ -4201,20 +4280,33 @@ package body Sem_Ch13 is Remove_Interp (I); elsif Present (Default) then - Error_Msg_N ("default iterator must be unique", Expr); + -- An explicit one should override an implicit one + + if Comes_From_Source (Default) = + Comes_From_Source (It.Nam) + then + Error_Msg_N ("default iterator must be unique", Expr); + Error_Msg_Sloc := Sloc (Default); + Error_Msg_N ("\\possible interpretation#", Expr); + Error_Msg_Sloc := Sloc (It.Nam); + Error_Msg_N ("\\possible interpretation#", Expr); + + elsif Comes_From_Source (It.Nam) then + Default := It.Nam; + end if; else Default := It.Nam; end if; Get_Next_Interp (I, It); end loop; - end; - if Present (Default) then - Set_Entity (Expr, Default); - Set_Is_Overloaded (Expr, False); - end if; + if Present (Default) then + Set_Entity (Expr, Default); + Set_Is_Overloaded (Expr, False); + end if; + end; end if; end Check_Iterator_Functions; @@ -4632,22 +4724,29 @@ package body Sem_Ch13 is Find_Overlaid_Entity (N, O_Ent, Off); - -- Overlaying controlled objects is erroneous + -- Overlaying controlled objects is erroneous. + -- Emit warning but continue analysis because program is + -- itself legal, and back-end must see address clause. if Present (O_Ent) and then (Has_Controlled_Component (Etype (O_Ent)) or else Is_Controlled (Etype (O_Ent))) + and then not Inside_A_Generic then Error_Msg_N - ("??cannot overlay with controlled object", Expr); + ("??cannot use overlays with controlled objects", Expr); Error_Msg_N ("\??Program_Error will be raised at run time", Expr); Insert_Action (Declaration_Node (U_Ent), Make_Raise_Program_Error (Loc, Reason => PE_Overlaid_Controlled_Object)); - return; - elsif Present (O_Ent) + -- Issue an unconditional warning for a constant overlaying + -- a variable. For the reverse case, we will issue it only + -- if the variable is modified, see below. + + elsif Address_Clause_Overlay_Warnings + and then Present (O_Ent) and then Ekind (U_Ent) = E_Constant and then not Is_Constant_Object (O_Ent) then @@ -4727,15 +4826,6 @@ package body Sem_Ch13 is end if; end; - if Is_Exported (U_Ent) then - Error_Msg_N - ("& cannot be exported if an address clause is given", - Nam); - Error_Msg_N - ("\define and export a variable " - & "that holds its address instead", Nam); - end if; - -- Entity has delayed freeze, so we will generate an -- alignment check at the freeze point unless suppressed. @@ -4787,13 +4877,28 @@ package body Sem_Ch13 is -- If variable overlays a constant view, and we are -- warning on overlays, then mark the variable as - -- overlaying a constant (we will give warnings later - -- if this variable is assigned). + -- overlaying a constant and warn immediately if it + -- is initialized. We will give other warnings later + -- if the variable is assigned. if Is_Constant_Object (O_Ent) and then Ekind (U_Ent) = E_Variable then - Set_Overlays_Constant (U_Ent); + declare + Init : constant Node_Id := + Expression (Declaration_Node (U_Ent)); + begin + Set_Overlays_Constant (U_Ent); + + if Present (Init) + and then Comes_From_Source (Init) + then + Error_Msg_Sloc := Sloc (N); + Error_Msg_NE + ("??constant& may be modified via address " + & "clause#", Declaration_Node (U_Ent), O_Ent); + end if; + end; end if; end if; end; @@ -4924,49 +5029,36 @@ package body Sem_Ch13 is -- will be used to represent the biased subtype that reflects -- the biased representation of components. We need the subtype -- to get proper conversions on referencing elements of the - -- array. Note: component size clauses are ignored in VM mode. - - if VM_Target = No_VM then - if Biased then - New_Ctyp := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name (Chars (U_Ent), 'C', 0, 'T')); - - Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => New_Ctyp, - Subtype_Indication => - New_Occurrence_Of (Component_Type (Btype), Loc)); - - Set_Parent (Decl, N); - Analyze (Decl, Suppress => All_Checks); - - Set_Has_Delayed_Freeze (New_Ctyp, False); - Set_Esize (New_Ctyp, Csize); - Set_RM_Size (New_Ctyp, Csize); - Init_Alignment (New_Ctyp); - Set_Is_Itype (New_Ctyp, True); - Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); - - Set_Component_Type (Btype, New_Ctyp); - Set_Biased (New_Ctyp, N, "component size clause"); - end if; + -- array. + + if Biased then + New_Ctyp := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (U_Ent), 'C', 0, 'T')); - Set_Component_Size (Btype, Csize); + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => New_Ctyp, + Subtype_Indication => + New_Occurrence_Of (Component_Type (Btype), Loc)); - -- For VM case, we ignore component size clauses + Set_Parent (Decl, N); + Analyze (Decl, Suppress => All_Checks); - else - -- Give a warning unless we are in GNAT mode, in which case - -- the warning is suppressed since it is not useful. + Set_Has_Delayed_Freeze (New_Ctyp, False); + Set_Esize (New_Ctyp, Csize); + Set_RM_Size (New_Ctyp, Csize); + Init_Alignment (New_Ctyp); + Set_Is_Itype (New_Ctyp, True); + Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); - if not GNAT_Mode then - Error_Msg_N - ("component size ignored in this configuration??", N); - end if; + Set_Component_Type (Btype, New_Ctyp); + Set_Biased (New_Ctyp, N, "component size clause"); end if; + Set_Component_Size (Btype, Csize); + -- Deal with warning on overridden size if Warn_On_Overridden_Size @@ -5142,12 +5234,6 @@ package body Sem_Ch13 is ("static string required for tag name!", Nam); end if; - if VM_Target /= No_VM then - Error_Msg_Name_1 := Attr; - Error_Msg_N - ("% attribute unsupported in this configuration", Nam); - end if; - if not Is_Library_Level_Entity (U_Ent) then Error_Msg_NE ("??non-unique external tag supplied for &", N, U_Ent); @@ -5210,6 +5296,12 @@ package body Sem_Ch13 is (Expr, RTE (RE_Interrupt_Priority)); Uninstall_Discriminants_And_Pop_Scope (U_Ent); + + -- Check the No_Task_At_Interrupt_Priority restriction + + if Is_Task_Type (U_Ent) then + Check_Restriction (No_Task_At_Interrupt_Priority, N); + end if; end if; else @@ -5463,16 +5555,6 @@ package body Sem_Ch13 is ("size cannot be given for unconstrained array", Nam); elsif Size /= No_Uint then - if VM_Target /= No_VM and then not GNAT_Mode then - - -- Size clause is not handled properly on VM targets. - -- Display a warning unless we are in GNAT mode, in which - -- case this is useless. - - Error_Msg_N - ("size clauses are ignored in this configuration??", N); - end if; - if Is_Type (U_Ent) then Etyp := U_Ent; else @@ -7628,7 +7710,7 @@ package body Sem_Ch13 is -- Start of processing for Build_Discrete_Static_Predicate begin - -- Establish bounds for the predicate + -- Establish bounds for the predicate if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then TLo := Expr_Value (Type_Low_Bound (Typ)); @@ -7763,12 +7845,13 @@ package body Sem_Ch13 is function Build_Invariant_Procedure_Declaration (Typ : Entity_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Typ); - GM : constant Ghost_Mode_Type := Ghost_Mode; + Loc : constant Source_Ptr := Sloc (Typ); Decl : Node_Id; Obj_Id : Entity_Id; SId : Entity_Id; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + begin -- Check for duplicate definitions @@ -7776,9 +7859,8 @@ package body Sem_Ch13 is return Empty; end if; - -- The related type may be subject to pragma Ghost with policy Ignore. - -- Set the mode now to ensure that the predicate functions are properly - -- flagged as ignored Ghost. + -- The related type may be subject to pragma Ghost. Set the mode now to + -- ensure that the invariant procedure is properly marked as Ghost. Set_Ghost_Mode_From_Entity (Typ); @@ -7810,10 +7892,7 @@ package body Sem_Ch13 is Defining_Identifier => Obj_Id, Parameter_Type => New_Occurrence_Of (Typ, Loc))))); - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; return Decl; end Build_Invariant_Procedure_Declaration; @@ -7834,23 +7913,11 @@ package body Sem_Ch13 is -- end typInvariant; procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is - Priv_Decls : constant List_Id := Private_Declarations (N); - Vis_Decls : constant List_Id := Visible_Declarations (N); - - Loc : constant Source_Ptr := Sloc (Typ); - Stmts : List_Id; - Spec : Node_Id; - SId : Entity_Id; - PDecl : Node_Id; - PBody : Node_Id; - - Object_Entity : Node_Id; - -- The entity of the formal for the procedure - - Object_Name : Name_Id; - -- Name for argument of invariant procedure - - procedure Add_Invariants (T : Entity_Id; Inherit : Boolean); + procedure Add_Invariants + (T : Entity_Id; + Obj_Id : Entity_Id; + Stmts : in out List_Id; + Inherit : Boolean); -- Appends statements to Stmts for any invariants in the rep item chain -- of the given type. If Inherit is False, then we only process entries -- on the chain for the type Typ. If Inherit is True, then we ignore any @@ -7862,7 +7929,12 @@ package body Sem_Ch13 is -- Add_Invariants -- -------------------- - procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is + procedure Add_Invariants + (T : Entity_Id; + Obj_Id : Entity_Id; + Stmts : in out List_Id; + Inherit : Boolean) + is procedure Add_Invariant (Prag : Node_Id); -- Create a runtime check to verify the exression of invariant pragma -- Prag. All generated code is added to list Stmts. @@ -7933,17 +8005,18 @@ package body Sem_Ch13 is Make_Attribute_Reference (Nloc, Prefix => New_Occurrence_Of (T, Nloc), Attribute_Name => Name_Class), - Expression => Make_Identifier (Nloc, Object_Name))); + Expression => + Make_Identifier (Nloc, Chars (Obj_Id)))); - Set_Entity (Expression (N), Object_Entity); + Set_Entity (Expression (N), Obj_Id); Set_Etype (Expression (N), Typ); end if; -- Invariant, replace with obj else - Rewrite (N, Make_Identifier (Nloc, Object_Name)); - Set_Entity (N, Object_Entity); + Rewrite (N, Make_Identifier (Nloc, Chars (Obj_Id))); + Set_Entity (N, Obj_Id); Set_Etype (N, Typ); end if; @@ -8135,9 +8208,31 @@ package body Sem_Ch13 is end loop; end Add_Invariants; + -- Local variables + + Loc : constant Source_Ptr := Sloc (Typ); + Priv_Decls : constant List_Id := Private_Declarations (N); + Vis_Decls : constant List_Id := Visible_Declarations (N); + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + + PBody : Node_Id; + PDecl : Node_Id; + SId : Entity_Id; + Spec : Node_Id; + Stmts : List_Id; + + Obj_Id : Node_Id; + -- The entity of the formal for the procedure + -- Start of processing for Build_Invariant_Procedure begin + -- The related type may be subject to pragma Ghost. Set the mode now to + -- ensure that the invariant procedure is properly marked as Ghost. + + Set_Ghost_Mode_From_Entity (Typ); + Stmts := No_List; PDecl := Empty; PBody := Empty; @@ -8164,6 +8259,7 @@ package body Sem_Ch13 is and then Nkind (PDecl) = N_Subprogram_Declaration and then Present (Corresponding_Body (PDecl)) then + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -8174,14 +8270,17 @@ package body Sem_Ch13 is -- Recover formal of procedure, for use in the calls to invariant -- functions (including inherited ones). - Object_Entity := + Obj_Id := Defining_Identifier (First (Parameter_Specifications (Specification (PDecl)))); - Object_Name := Chars (Object_Entity); -- Add invariants for the current type - Add_Invariants (Typ, Inherit => False); + Add_Invariants + (T => Typ, + Obj_Id => Obj_Id, + Stmts => Stmts, + Inherit => False); -- Add invariants for parent types @@ -8203,7 +8302,11 @@ package body Sem_Ch13 is exit when Parent_Typ = Current_Typ; Current_Typ := Parent_Typ; - Add_Invariants (Current_Typ, Inherit => True); + Add_Invariants + (T => Current_Typ, + Obj_Id => Obj_Id, + Stmts => Stmts, + Inherit => True); end loop; end; @@ -8223,7 +8326,11 @@ package body Sem_Ch13 is Iface := Node (AI); if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then - Add_Invariants (Iface, Inherit => True); + Add_Invariants + (T => Iface, + Obj_Id => Obj_Id, + Stmts => Stmts, + Inherit => True); end if; Next_Elmt (AI); @@ -8234,7 +8341,7 @@ package body Sem_Ch13 is -- Build the procedure if we generated at least one Check pragma if Stmts /= No_List then - Spec := Copy_Separate_Tree (Specification (PDecl)); + Spec := Copy_Separate_Tree (Specification (PDecl)); PBody := Make_Subprogram_Body (Loc, @@ -8287,6 +8394,8 @@ package body Sem_Ch13 is Analyze (PBody); end if; end if; + + Ghost_Mode := Save_Ghost_Mode; end Build_Invariant_Procedure; ------------------------------- @@ -8298,10 +8407,10 @@ package body Sem_Ch13 is -- function typPredicate (Ixxx : typ) return Boolean is -- begin -- return - -- exp1 and then exp2 and then ... - -- and then typ1Predicate (typ1 (Ixxx)) + -- typ1Predicate (typ1 (Ixxx)) -- and then typ2Predicate (typ2 (Ixxx)) -- and then ...; + -- exp1 and then exp2 and then ... -- end typPredicate; -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that @@ -8310,6 +8419,12 @@ package body Sem_Ch13 is -- inherited. Note that we do NOT generate Check pragmas, that's because we -- use this function even if checks are off, e.g. for membership tests. + -- Note that the inherited predicates are evaluated first, as required by + -- AI12-0071-1. + + -- Note that Sem_Eval.Real_Or_String_Static_Predicate_Matches depends on + -- the form of this return expression. + -- If the expression has at least one Raise_Expression, then we also build -- the typPredicateM version of the function, in which any occurrence of a -- Raise_Expression is converted to "return False". @@ -8342,9 +8457,9 @@ package body Sem_Ch13 is Raise_Expression_Present : Boolean := False; -- Set True if Expr has at least one Raise_Expression - procedure Add_Call (T : Entity_Id); - -- Includes a call to the predicate function for type T in Expr if T - -- has predicates and Predicate_Function (T) is non-empty. + procedure Add_Condition (Cond : Node_Id); + -- Append Cond to Expr using "and then" (or just copy Cond to Expr if + -- Expr is empty). procedure Add_Predicates; -- Appends expressions for any Predicate pragmas in the rep item chain @@ -8352,6 +8467,10 @@ package body Sem_Ch13 is -- Inheritance of predicates for the parent type is done by calling the -- Predicate_Function of the parent type, using Add_Call above. + procedure Add_Call (T : Entity_Id); + -- Includes a call to the predicate function for type T in Expr if T + -- has predicates and Predicate_Function (T) is non-empty. + function Process_RE (N : Node_Id) return Traverse_Result; -- Used in Process REs, tests if node N is a raise expression, and if -- so, marks it to be converted to return False. @@ -8383,17 +8502,9 @@ package body Sem_Ch13 is Make_Predicate_Call (T, Convert_To (T, Make_Identifier (Loc, Object_Name))); - -- Add call to evolving expression, using AND THEN if needed + -- "and"-in the call to evolving expression - if No (Expr) then - Expr := Exp; - - else - Expr := - Make_And_Then (Sloc (Expr), - Left_Opnd => Relocate_Node (Expr), - Right_Opnd => Exp); - end if; + Add_Condition (Exp); -- Output info message on inheritance if required. Note we do not -- give this information for generic actual types, since it is @@ -8414,6 +8525,28 @@ package body Sem_Ch13 is end if; end Add_Call; + ------------------- + -- Add_Condition -- + ------------------- + + procedure Add_Condition (Cond : Node_Id) is + begin + -- This is the first predicate expression + + if No (Expr) then + Expr := Cond; + + -- Otherwise concatenate to the existing predicate expressions by + -- using "and then". + + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Cond); + end if; + end Add_Condition; + -------------------- -- Add_Predicates -- -------------------- @@ -8493,24 +8626,12 @@ package body Sem_Ch13 is -- Check_Aspect_At_xxx routines. if Present (Asp) then - Set_Entity (Identifier (Asp), New_Copy_Tree (Arg2)); end if; - -- Concatenate to the existing predicate expressions by using - -- "and then". - - if Present (Expr) then - Expr := - Make_And_Then (Loc, - Left_Opnd => Relocate_Node (Expr), - Right_Opnd => Relocate_Node (Arg2)); + -- "and"-in the Arg2 condition to evolving expression - -- Otherwise this is the first predicate expression - - else - Expr := Relocate_Node (Arg2); - end if; + Add_Condition (Relocate_Node (Arg2)); end if; end Add_Predicate; @@ -8563,7 +8684,7 @@ package body Sem_Ch13 is -- Local variables - GM : constant Ghost_Mode_Type := Ghost_Mode; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; -- Start of processing for Build_Predicate_Functions @@ -8576,9 +8697,8 @@ package body Sem_Ch13 is return; end if; - -- The related type may be subject to pragma Ghost with policy Ignore. - -- Set the mode now to ensure that the predicate functions are properly - -- flagged as ignored Ghost. + -- The related type may be subject to pragma Ghost. Set the mode now to + -- ensure that the predicate functions are properly marked as Ghost. Set_Ghost_Mode_From_Entity (Typ); @@ -8586,11 +8706,8 @@ package body Sem_Ch13 is Expr := Empty; - -- Add Predicates for the current type - - Add_Predicates; - - -- Add predicates for ancestor if present + -- Add predicates for ancestor if present. These must come before the + -- ones for the current type, as required by AI12-0071-1. declare Atyp : constant Entity_Id := Nearest_Ancestor (Typ); @@ -8600,6 +8717,10 @@ package body Sem_Ch13 is end if; end; + -- Add Predicates for the current type + + Add_Predicates; + -- Case where predicates are present if Present (Expr) then @@ -8735,6 +8856,18 @@ package body Sem_Ch13 is Insert_Before_And_Analyze (N, FDecl); Insert_After_And_Analyze (N, FBody); + + -- Static predicate functions are always side-effect free, and + -- in most cases dynamic predicate functions are as well. Mark + -- them as such whenever possible, so redundant predicate checks + -- can be optimized. If there is a variable reference within the + -- expression, the function is not pure. + + if Expander_Active then + Set_Is_Pure (SId, + Side_Effect_Free (Expr, Variable_Ref => True)); + Set_Is_Inlined (SId); + end if; end; -- Test for raise expressions present and if so build M version @@ -8902,13 +9035,18 @@ package body Sem_Ch13 is -- First a little fiddling to get a nice location for the -- message. If the expression is of the form (A and then B), - -- then use the left operand for the Sloc. This avoids getting - -- confused by a call to a higher-level predicate with a less - -- convenient source location. + -- where A is an inherited predicate, then use the right + -- operand for the Sloc. This avoids getting confused by a call + -- to an inherited predicate with a less convenient source + -- location. EN := Expr; - while Nkind (EN) = N_And_Then loop - EN := Left_Opnd (EN); + while Nkind (EN) = N_And_Then + and then Nkind (Left_Opnd (EN)) = N_Function_Call + and then Is_Predicate_Function + (Entity (Name (Left_Opnd (EN)))) + loop + EN := Right_Opnd (EN); end loop; -- Now post appropriate message @@ -8927,10 +9065,7 @@ package body Sem_Ch13 is end; end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Build_Predicate_Functions; ----------------------------------------- @@ -8999,9 +9134,19 @@ package body Sem_Ch13 is -- Start of processing for Check_Aspect_At_End_Of_Declarations begin + -- In an instance we do not perform the consistency check between freeze + -- point and end of declarations, because it was done already in the + -- analysis of the generic. Furthermore, the delayed analysis of an + -- aspect of the instance may produce spurious errors when the generic + -- is a child unit that references entities in the parent (which might + -- not be in scope at the freeze point of the instance). + + if In_Instance then + return; + -- Case of aspects Dimension, Dimension_System and Synchronization - if A_Id = Aspect_Synchronization then + elsif A_Id = Aspect_Synchronization then return; -- Case of stream attributes, just have to compare entities. However, @@ -9268,34 +9413,43 @@ package body Sem_Ch13 is Aspect_Type_Invariant => T := Standard_Boolean; + when Aspect_Predicate_Failure => + T := Standard_String; + -- Here is the list of aspects that don't require delay analysis - when Aspect_Abstract_State | - Aspect_Annotate | - Aspect_Contract_Cases | - Aspect_Default_Initial_Condition | - Aspect_Depends | - Aspect_Dimension | - Aspect_Dimension_System | - Aspect_Extensions_Visible | - Aspect_Ghost | - Aspect_Global | - Aspect_Implicit_Dereference | - Aspect_Initial_Condition | - Aspect_Initializes | - Aspect_Obsolescent | - Aspect_Part_Of | - Aspect_Post | - Aspect_Postcondition | - Aspect_Pre | - Aspect_Precondition | - Aspect_Refined_Depends | - Aspect_Refined_Global | - Aspect_Refined_Post | - Aspect_Refined_State | - Aspect_SPARK_Mode | - Aspect_Test_Case | - Aspect_Unimplemented => + when Aspect_Abstract_State | + Aspect_Annotate | + Aspect_Async_Readers | + Aspect_Async_Writers | + Aspect_Constant_After_Elaboration | + Aspect_Contract_Cases | + Aspect_Default_Initial_Condition | + Aspect_Depends | + Aspect_Dimension | + Aspect_Dimension_System | + Aspect_Effective_Reads | + Aspect_Effective_Writes | + Aspect_Extensions_Visible | + Aspect_Ghost | + Aspect_Global | + Aspect_Implicit_Dereference | + Aspect_Initial_Condition | + Aspect_Initializes | + Aspect_Obsolescent | + Aspect_Part_Of | + Aspect_Post | + Aspect_Postcondition | + Aspect_Pre | + Aspect_Precondition | + Aspect_Refined_Depends | + Aspect_Refined_Global | + Aspect_Refined_Post | + Aspect_Refined_State | + Aspect_SPARK_Mode | + Aspect_Test_Case | + Aspect_Unimplemented | + Aspect_Volatile_Function => raise Program_Error; end case; @@ -9864,9 +10018,15 @@ package body Sem_Ch13 is (Parent_Last_Bit, Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); end if; + else + + -- Skip anonymous types generated for constrained array + -- or record components. - Next_Entity (Pcomp); + null; end if; + + Next_Entity (Pcomp); end loop; end if; end; @@ -11363,7 +11523,7 @@ package body Sem_Ch13 is Address_Clause_Checks.Init; Unchecked_Conversions.Init; - if VM_Target /= No_VM or else AAMP_On_Target then + if AAMP_On_Target then Independence_Checks.Init; end if; end Initialize; @@ -11399,9 +11559,20 @@ package body Sem_Ch13 is declare Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); begin - return Id = Attribute_Input + + -- List of operational items is given in AARM 13.1(8.mm/1). + -- It is clearly incomplete, as it does not include iterator + -- aspects, among others. + + return Id = Attribute_Constant_Indexing + or else Id = Attribute_Default_Iterator + or else Id = Attribute_Implicit_Dereference + or else Id = Attribute_Input + or else Id = Attribute_Iterator_Element + or else Id = Attribute_Iterable or else Id = Attribute_Output or else Id = Attribute_Read + or else Id = Attribute_Variable_Indexing or else Id = Attribute_Write or else Id = Attribute_External_Tag; end; @@ -11605,7 +11776,7 @@ package body Sem_Ch13 is -- references to inherited predicates, so that the expression we are -- processing looks like: - -- expression and then xxPredicate (typ (Inns)) + -- xxPredicate (typ (Inns)) and then expression -- Where the call is to a Predicate function for an inherited predicate. -- We simply ignore such a call, which could be to either a dynamic or @@ -12362,6 +12533,76 @@ package body Sem_Ch13 is Replace_Type_Refs (N); end Replace_Type_References_Generic; + -------------------------------- + -- Resolve_Aspect_Expressions -- + -------------------------------- + + procedure Resolve_Aspect_Expressions (E : Entity_Id) is + ASN : Node_Id; + A_Id : Aspect_Id; + Expr : Node_Id; + + begin + ASN := First_Rep_Item (E); + while Present (ASN) loop + if Nkind (ASN) = N_Aspect_Specification and then Entity (ASN) = E then + A_Id := Get_Aspect_Id (ASN); + Expr := Expression (ASN); + + case A_Id is + -- For now we only deal with aspects that do not generate + -- subprograms, or that may mention current instances of + -- types. These will require special handling (???TBD). + + when Aspect_Predicate | + Aspect_Predicate_Failure | + Aspect_Invariant | + Aspect_Static_Predicate | + Aspect_Dynamic_Predicate => + null; + + when Pre_Post_Aspects => + null; + + when Aspect_Iterable => + if Nkind (Expr) = N_Aggregate then + declare + Assoc : Node_Id; + + begin + Assoc := First (Component_Associations (Expr)); + while Present (Assoc) loop + Find_Direct_Name (Expression (Assoc)); + Next (Assoc); + end loop; + end; + end if; + + when others => + if Present (Expr) then + case Aspect_Argument (A_Id) is + when Expression | Optional_Expression => + Analyze_And_Resolve (Expression (ASN)); + + when Name | Optional_Name => + if Nkind (Expr) = N_Identifier then + Find_Direct_Name (Expr); + + elsif Nkind (Expr) = N_Selected_Component then + Find_Selected_Component (Expr); + + else + null; + end if; + end case; + end if; + end case; + end if; + + ASN := Next_Rep_Item (ASN); + end loop; + end Resolve_Aspect_Expressions; + ------------------------- -- Same_Representation -- ------------------------- @@ -12419,17 +12660,7 @@ package body Sem_Ch13 is and then Known_Component_Size (T2) and then Component_Size (T1) = Component_Size (T2) then - if VM_Target = No_VM then - return True; - - -- In VM targets the representation of arrays with aliased - -- components differs from arrays with non-aliased components - - else - return Has_Aliased_Components (Base_Type (T1)) - = - Has_Aliased_Components (Base_Type (T2)); - end if; + return True; end if; end if; diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index df779086065..8ae92941099 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -347,6 +347,13 @@ package Sem_Ch13 is -- Given an entity Typ that denotes a derived type or a subtype, this -- routine performs the inheritance of aspects at the freeze point. + procedure Resolve_Aspect_Expressions (E : Entity_Id); + -- Name resolution of an aspect expression happens at the end of the + -- current declarative part or at the freeze point for the entity, + -- whichever comes first. For declarations in the visible part of a + -- package, name resolution takes place before analysis of the private + -- part even though the freeze point of the entity may appear later. + procedure Validate_Iterable_Aspect (Typ : Entity_Id; ASN : Node_Id); -- For SPARK 2014 formal containers. The expression has the form of an -- aggregate, and each entry must denote a function with the proper syntax diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f163b1581b2..881921d5d69 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -23,64 +23,62 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; -with Atree; use Atree; -with Checks; use Checks; -with Debug; use Debug; -with Elists; use Elists; -with Einfo; use Einfo; -with Errout; use Errout; -with Eval_Fat; use Eval_Fat; -with Exp_Ch3; use Exp_Ch3; -with Exp_Ch9; use Exp_Ch9; -with Exp_Disp; use Exp_Disp; -with Exp_Dist; use Exp_Dist; -with Exp_Tss; use Exp_Tss; -with Exp_Util; use Exp_Util; -with Fname; use Fname; -with Freeze; use Freeze; -with Ghost; use Ghost; -with Itypes; use Itypes; -with Layout; use Layout; -with Lib; use Lib; -with Lib.Xref; use Lib.Xref; -with Namet; use Namet; -with Nmake; use Nmake; -with Opt; use Opt; -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_Ch6; use Sem_Ch6; -with Sem_Ch7; use Sem_Ch7; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch10; use Sem_Ch10; -with Sem_Ch12; use Sem_Ch12; -with Sem_Ch13; use Sem_Ch13; -with Sem_Dim; use Sem_Dim; -with Sem_Disp; use Sem_Disp; -with Sem_Dist; use Sem_Dist; -with Sem_Elim; use Sem_Elim; -with Sem_Eval; use Sem_Eval; -with Sem_Mech; use Sem_Mech; -with Sem_Prag; use Sem_Prag; -with Sem_Res; use Sem_Res; -with Sem_Smem; use Sem_Smem; -with Sem_Type; use Sem_Type; -with Sem_Util; use Sem_Util; -with Sem_Warn; use Sem_Warn; -with Stand; use Stand; -with Sinfo; use Sinfo; -with Sinput; use Sinput; -with Snames; use Snames; -with Targparm; use Targparm; -with Tbuild; use Tbuild; -with Ttypes; use Ttypes; -with Uintp; use Uintp; -with Urealp; use Urealp; +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Contracts; use Contracts; +with Debug; use Debug; +with Elists; use Elists; +with Einfo; use Einfo; +with Errout; use Errout; +with Eval_Fat; use Eval_Fat; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch9; use Exp_Ch9; +with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Freeze; use Freeze; +with Ghost; use Ghost; +with Itypes; use Itypes; +with Layout; use Layout; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nmake; use Nmake; +with Opt; use Opt; +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_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_Smem; use Sem_Smem; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Urealp; use Urealp; package body Sem_Ch3 is @@ -93,16 +91,6 @@ package body Sem_Ch3 is -- abstract interface types implemented by a record type or a derived -- record type. - procedure Analyze_Object_Contract (Obj_Id : Entity_Id); - -- Analyze all delayed pragmas chained on the contract of object Obj_Id as - -- if they appeared at the end of the declarative region. The pragmas to be - -- considered are: - -- Async_Readers - -- Async_Writers - -- Effective_Reads - -- Effective_Writes - -- Part_Of - procedure Build_Derived_Type (N : Node_Id; Parent_Type : Entity_Id; @@ -2306,7 +2294,6 @@ package body Sem_Ch3 is Context : Node_Id := Empty; Freeze_From : Entity_Id := Empty; Next_Decl : Node_Id; - Pack_Decl : Node_Id := Empty; Body_Seen : Boolean := False; -- Flag set when the first body [stub] is encountered @@ -2391,6 +2378,29 @@ package body Sem_Ch3 is Adjust_Decl; Freeze_All (First_Entity (Current_Scope), Decl); Freeze_From := Last_Entity (Current_Scope); + + -- At the end of the visible declarations the expressions in + -- aspects of all entities declared so far must be resolved. + -- The entities themselves might be frozen later, and the + -- generated pragmas and attribute definition clauses analyzed + -- in full at that point, but name resolution must take place + -- now. + -- In addition to being the proper semantics, this is mandatory + -- within generic units, because global name capture requires + -- those expressions to be analyzed, given that the generated + -- pragmas do not appear in the original generic tree. + + elsif Serious_Errors_Detected = 0 then + declare + E : Entity_Id; + + begin + E := First_Entity (Current_Scope); + while Present (E) loop + Resolve_Aspect_Expressions (E); + Next_Entity (E); + end loop; + end; end if; -- If next node is a body then freeze all types before the body. @@ -2454,7 +2464,6 @@ package body Sem_Ch3 is Context := Parent (L); if Nkind (Context) = N_Package_Specification then - Pack_Decl := Parent (Context); -- When a package has private declarations, its contract must be -- analyzed at the end of the said declarations. This way both the @@ -2483,70 +2492,70 @@ package body Sem_Ch3 is end if; elsif Nkind (Context) = N_Package_Body then - Pack_Decl := Context; Analyze_Package_Body_Contract (Defining_Entity (Context)); end if; - -- Analyze the contracts of all subprogram declarations, subprogram - -- bodies and variables now due to the delayed visibility needs of - -- of their aspects and pragmas. Capture global references in generic - -- subprograms or bodies. + -- Analyze the contracts of eligible constructs (see below) due to + -- the delayed visibility needs of their aspects and pragmas. Decl := First (L); while Present (Decl) loop - if Nkind (Decl) = N_Object_Declaration then + + -- Entry or subprogram declarations + + if Nkind_In (Decl, N_Abstract_Subprogram_Declaration, + N_Entry_Declaration, + N_Generic_Subprogram_Declaration, + N_Subprogram_Declaration) + then + Analyze_Entry_Or_Subprogram_Contract (Defining_Entity (Decl)); + + -- Entry or subprogram bodies + + elsif Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then + Analyze_Entry_Or_Subprogram_Body_Contract + (Defining_Entity (Decl)); + + -- Objects + + elsif Nkind (Decl) = N_Object_Declaration then Analyze_Object_Contract (Defining_Entity (Decl)); - elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration, - N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) + -- Protected untis + + elsif Nkind_In (Decl, N_Protected_Type_Declaration, + N_Single_Protected_Declaration) then - Analyze_Subprogram_Contract (Defining_Entity (Decl)); + Analyze_Protected_Contract (Defining_Entity (Decl)); - elsif Nkind (Decl) = N_Subprogram_Body then - Analyze_Subprogram_Body_Contract (Defining_Entity (Decl)); + -- Subprogram body stubs elsif Nkind (Decl) = N_Subprogram_Body_Stub then Analyze_Subprogram_Body_Stub_Contract (Defining_Entity (Decl)); - end if; - -- Capture all global references in a generic subprogram or a body - -- [stub] now that the contract has been analyzed. + -- Task units - if Nkind_In (Decl, N_Generic_Subprogram_Declaration, - N_Subprogram_Body, - N_Subprogram_Body_Stub) - and then Is_Generic_Declaration_Or_Body (Decl) + elsif Nkind_In (Decl, N_Single_Task_Declaration, + N_Task_Type_Declaration) then - Save_Global_References_In_Contract - (Templ => Original_Node (Decl), - Gen_Id => Corresponding_Spec_Of (Decl)); + Analyze_Task_Contract (Defining_Entity (Decl)); end if; Next (Decl); end loop; - -- The owner of the declarations is a package [body] + if Nkind (Context) = N_Package_Body then - if Present (Pack_Decl) then + -- Ensure that all abstract states and objects declared in the + -- state space of a package body are utilized as constituents. - -- Capture all global references in a generic package or a body - -- after all nested generic subprograms and bodies were subjected - -- to the same processing. - - if Is_Generic_Declaration_Or_Body (Pack_Decl) then - Save_Global_References_In_Contract - (Templ => Original_Node (Pack_Decl), - Gen_Id => Corresponding_Spec_Of (Pack_Decl)); - end if; + Check_Unused_Body_States (Defining_Entity (Context)); -- State refinements are visible upto the end the of the package -- body declarations. Hide the state refinements from visibility -- to restore the original state conditions. - if Nkind (Pack_Decl) = N_Package_Body then - Remove_Visible_Refinements (Corresponding_Spec (Pack_Decl)); - end if; + Remove_Visible_Refinements (Corresponding_Spec (Context)); end if; end if; end Analyze_Declarations; @@ -2556,9 +2565,8 @@ package body Sem_Ch3 is ----------------------------------- procedure Analyze_Full_Type_Declaration (N : Node_Id) is - Def : constant Node_Id := Type_Definition (N); - Def_Id : constant Entity_Id := Defining_Identifier (N); - GM : constant Ghost_Mode_Type := Ghost_Mode; + Def : constant Node_Id := Type_Definition (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); T : Entity_Id; Prev : Entity_Id; @@ -2568,6 +2576,10 @@ package body Sem_Ch3 is and then not (In_Private_Part (Current_Scope) or else In_Package_Body (Current_Scope)); + procedure Check_Nonoverridable_Aspects; + -- Apply the rule in RM 13.1.1(18.4/4) on iterator aspects that cannot + -- be overridden, and can only be confirmed on derivation. + procedure Check_Ops_From_Incomplete_Type; -- If there is a tagged incomplete partial view of the type, traverse -- the primitives of the incomplete view and change the type of any @@ -2576,8 +2588,89 @@ package body Sem_Ch3 is -- list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which -- is called from Process_Incomplete_Dependents). - procedure Restore_Globals; - -- Restore the values of all saved global variables + ---------------------------------- + -- Check_Nonoverridable_Aspects -- + ---------------------------------- + + procedure Check_Nonoverridable_Aspects is + Prev_Aspects : constant List_Id := + Aspect_Specifications (Parent (Def_Id)); + Par_Type : Entity_Id; + + function Has_Aspect_Spec + (Specs : List_Id; + Aspect_Name : Name_Id) return Boolean; + -- Check whether a list of aspect specifications includes an entry + -- for a specific aspect. The list is either that of a partial or + -- a full view. + + --------------------- + -- Has_Aspect_Spec -- + --------------------- + + function Has_Aspect_Spec + (Specs : List_Id; + Aspect_Name : Name_Id) return Boolean + is + Spec : Node_Id; + begin + Spec := First (Specs); + while Present (Spec) loop + if Chars (Identifier (Spec)) = Aspect_Name then + return True; + end if; + Next (Spec); + end loop; + return False; + end Has_Aspect_Spec; + + -- Start of processing for Check_Nonoverridable_Aspects + + begin + + -- Get parent type of derived type. Note that Prev is the entity + -- in the partial declaration, but its contents are now those of + -- full view, while Def_Id reflects the partial view. + + if Is_Private_Type (Def_Id) then + Par_Type := Etype (Full_View (Def_Id)); + else + Par_Type := Etype (Def_Id); + end if; + + -- If there is an inherited Implicit_Dereference, verify that it is + -- made explicit in the partial view. + + if Has_Discriminants (Base_Type (Par_Type)) + and then Nkind (Parent (Prev)) = N_Full_Type_Declaration + and then Present (Discriminant_Specifications (Parent (Prev))) + and then Present (Get_Reference_Discriminant (Par_Type)) + then + if + not Has_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference) + then + Error_Msg_N + ("type does not inherit implicit dereference", Prev); + + else + -- If one of the views has the aspect specified, verify that it + -- is consistent with that of the parent. + + declare + Par_Discr : constant Entity_Id := + Get_Reference_Discriminant (Par_Type); + Cur_Discr : constant Entity_Id := + Get_Reference_Discriminant (Prev); + begin + if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then + Error_Msg_N ("aspect incosistent with that of parent", N); + end if; + end; + end if; + end if; + + -- TBD : other nonoverridable aspects. + end Check_Nonoverridable_Aspects; ------------------------------------ -- Check_Ops_From_Incomplete_Type -- @@ -2616,26 +2709,11 @@ package body Sem_Ch3 is end if; end Check_Ops_From_Incomplete_Type; - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - -- Start of processing for Analyze_Full_Type_Declaration begin Prev := Find_Type_Name (N); - -- The type declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N, Prev); - -- The full view, if present, now points to the current type. If there -- is an incomplete partial view, set a link to it, to simplify the -- retrieval of primitive operations of the type. @@ -2773,7 +2851,6 @@ package body Sem_Ch3 is end if; if Etype (T) = Any_Type then - Restore_Globals; return; end if; @@ -2915,7 +2992,11 @@ package body Sem_Ch3 is end if; end if; - Restore_Globals; + if Is_Derived_Type (Prev) + and then Def_Id /= Prev + then + Check_Nonoverridable_Aspects; + end if; end Analyze_Full_Type_Declaration; ---------------------------------- @@ -2923,18 +3004,12 @@ package body Sem_Ch3 is ---------------------------------- procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is - F : constant Boolean := Is_Pure (Current_Scope); - GM : constant Ghost_Mode_Type := Ghost_Mode; - T : Entity_Id; + F : constant Boolean := Is_Pure (Current_Scope); + T : Entity_Id; begin Check_SPARK_05_Restriction ("incomplete type is not allowed", N); - -- The incomplete type declaration may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes generated - -- during analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); Generate_Definition (Defining_Identifier (N)); -- Process an incomplete declaration. The identifier must not have been @@ -2984,11 +3059,6 @@ package body Sem_Ch3 is Set_Private_Dependents (T, New_Elmt_List); Set_Is_Pure (T, F); - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Analyze_Incomplete_Type_Decl; ----------------------------------- @@ -3035,10 +3105,9 @@ package body Sem_Ch3 is -- Check runtime support for synchronized interfaces - if VM_Target = No_VM - and then (Is_Task_Interface (T) - or else Is_Protected_Interface (T) - or else Is_Synchronized_Interface (T)) + if (Is_Task_Interface (T) + or else Is_Protected_Interface (T) + or else Is_Synchronized_Interface (T)) and then not RTE_Available (RE_Select_Specific_Data) then Error_Msg_CRT ("synchronized interfaces", T); @@ -3063,37 +3132,13 @@ package body Sem_Ch3 is -------------------------------- procedure Analyze_Number_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - - procedure Restore_Globals; - -- Restore the values of all saved global variables - - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - - -- Local variables - E : constant Node_Id := Expression (N); Id : constant Entity_Id := Defining_Identifier (N); Index : Interp_Index; It : Interp; T : Entity_Id; - -- Start of processing for Analyze_Number_Declaration - begin - -- The number declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - Generate_Definition (Id); Enter_Name (Id); @@ -3113,8 +3158,6 @@ package body Sem_Ch3 is Set_Etype (Id, Universal_Integer); Set_Ekind (Id, E_Named_Integer); Set_Is_Frozen (Id, True); - - Restore_Globals; return; end if; @@ -3216,8 +3259,6 @@ package body Sem_Ch3 is Set_Ekind (Id, E_Constant); Set_Never_Set_In_Source (Id, True); Set_Is_True_Constant (Id, True); - - Restore_Globals; return; end if; @@ -3231,184 +3272,15 @@ package body Sem_Ch3 is Rewrite (E, Make_Integer_Literal (Sloc (N), 1)); Set_Etype (E, Any_Type); end if; - - Restore_Globals; end Analyze_Number_Declaration; - ----------------------------- - -- Analyze_Object_Contract -- - ----------------------------- - - procedure Analyze_Object_Contract (Obj_Id : Entity_Id) is - Obj_Typ : constant Entity_Id := Etype (Obj_Id); - AR_Val : Boolean := False; - AW_Val : Boolean := False; - ER_Val : Boolean := False; - EW_Val : Boolean := False; - Prag : Node_Id; - Seen : Boolean := False; - - begin - -- The loop parameter in an element iterator over a formal container - -- is declared with an object declaration but no contracts apply. - - if Ekind (Obj_Id) = E_Loop_Parameter then - return; - end if; - - -- Constant related checks - - if Ekind (Obj_Id) = E_Constant then - - -- A constant cannot be effectively volatile. This check is only - -- relevant with SPARK_Mode on as it is not a standard Ada legality - -- rule. Do not flag internally-generated constants that map generic - -- formals to actuals in instantiations (SPARK RM 7.1.3(6)). - - if SPARK_Mode = On - and then Is_Effectively_Volatile (Obj_Id) - and then No (Corresponding_Generic_Association (Parent (Obj_Id))) - - -- Don't give this for internally generated entities (such as the - -- FIRST and LAST temporaries generated for bounds). - - and then Comes_From_Source (Obj_Id) - then - Error_Msg_N ("constant cannot be volatile", Obj_Id); - end if; - - -- Variable related checks - - else pragma Assert (Ekind (Obj_Id) = E_Variable); - - -- The following checks are only relevant when SPARK_Mode is on as - -- they are not standard Ada legality rules. Internally generated - -- temporaries are ignored. - - if SPARK_Mode = On and then Comes_From_Source (Obj_Id) then - if Is_Effectively_Volatile (Obj_Id) then - - -- The declaration of an effectively volatile object must - -- appear at the library level (SPARK RM 7.1.3(7), C.6(6)). - - if not Is_Library_Level_Entity (Obj_Id) then - Error_Msg_N - ("volatile variable & must be declared at library level", - Obj_Id); - - -- An object of a discriminated type cannot be effectively - -- volatile (SPARK RM C.6(4)). - - elsif Has_Discriminants (Obj_Typ) then - Error_Msg_N - ("discriminated object & cannot be volatile", Obj_Id); - - -- An object of a tagged type cannot be effectively volatile - -- (SPARK RM C.6(5)). - - elsif Is_Tagged_Type (Obj_Typ) then - Error_Msg_N ("tagged object & cannot be volatile", Obj_Id); - end if; - - -- The object is not effectively volatile - - else - -- A non-effectively volatile object cannot have effectively - -- volatile components (SPARK RM 7.1.3(7)). - - if not Is_Effectively_Volatile (Obj_Id) - and then Has_Volatile_Component (Obj_Typ) - then - Error_Msg_N - ("non-volatile object & cannot have volatile components", - Obj_Id); - end if; - end if; - end if; - - if Is_Ghost_Entity (Obj_Id) then - - -- A Ghost object cannot be effectively volatile (SPARK RM 6.9(8)) - - if Is_Effectively_Volatile (Obj_Id) then - Error_Msg_N ("ghost variable & cannot be volatile", Obj_Id); - - -- A Ghost object cannot be imported or exported (SPARK RM 6.9(8)) - - elsif Is_Imported (Obj_Id) then - Error_Msg_N ("ghost object & cannot be imported", Obj_Id); - - elsif Is_Exported (Obj_Id) then - Error_Msg_N ("ghost object & cannot be exported", Obj_Id); - end if; - end if; - - -- Analyze all external properties - - Prag := Get_Pragma (Obj_Id, Pragma_Async_Readers); - - if Present (Prag) then - Analyze_External_Property_In_Decl_Part (Prag, AR_Val); - Seen := True; - end if; - - Prag := Get_Pragma (Obj_Id, Pragma_Async_Writers); - - if Present (Prag) then - Analyze_External_Property_In_Decl_Part (Prag, AW_Val); - Seen := True; - end if; - - Prag := Get_Pragma (Obj_Id, Pragma_Effective_Reads); - - if Present (Prag) then - Analyze_External_Property_In_Decl_Part (Prag, ER_Val); - Seen := True; - end if; - - Prag := Get_Pragma (Obj_Id, Pragma_Effective_Writes); - - if Present (Prag) then - Analyze_External_Property_In_Decl_Part (Prag, EW_Val); - Seen := True; - end if; - - -- Verify the mutual interaction of the various external properties - - if Seen then - Check_External_Properties (Obj_Id, AR_Val, AW_Val, ER_Val, EW_Val); - end if; - end if; - - -- Check whether the lack of indicator Part_Of agrees with the placement - -- of the object with respect to the state space. - - Prag := Get_Pragma (Obj_Id, Pragma_Part_Of); - - if No (Prag) then - Check_Missing_Part_Of (Obj_Id); - end if; - - -- A ghost object cannot be imported or exported (SPARK RM 6.9(8)) - - if Is_Ghost_Entity (Obj_Id) then - if Is_Exported (Obj_Id) then - Error_Msg_N ("ghost object & cannot be exported", Obj_Id); - - elsif Is_Imported (Obj_Id) then - Error_Msg_N ("ghost object & cannot be imported", Obj_Id); - end if; - end if; - end Analyze_Object_Contract; - -------------------------------- -- Analyze_Object_Declaration -- -------------------------------- procedure Analyze_Object_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - GM : constant Ghost_Mode_Type := Ghost_Mode; - Id : constant Entity_Id := Defining_Identifier (N); + Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Identifier (N); Act_T : Entity_Id; T : Entity_Id; @@ -3421,9 +3293,9 @@ package body Sem_Ch3 is function Count_Tasks (T : Entity_Id) return Uint; -- This function is called when a non-generic library level object of a -- task type is declared. Its function is to count the static number of - -- tasks declared within the type (it is only called if Has_Tasks is set + -- tasks declared within the type (it is only called if Has_Task is set -- for T). As a side effect, if an array of tasks with non-static bounds - -- or a variant record type is encountered, Check_Restrictions is called + -- or a variant record type is encountered, Check_Restriction is called -- indicating the count is unknown. function Delayed_Aspect_Present return Boolean; @@ -3437,9 +3309,6 @@ package body Sem_Ch3 is -- Any other relevant delayed aspects on object declarations ??? - procedure Restore_Globals; - -- Restore the values of all saved global variables - ----------------- -- Count_Tasks -- ----------------- @@ -3518,14 +3387,9 @@ package body Sem_Ch3 is return False; end Delayed_Aspect_Present; - --------------------- - -- Restore_Globals -- - --------------------- + -- Local variables - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; -- Start of processing for Analyze_Object_Declaration @@ -3580,9 +3444,10 @@ package body Sem_Ch3 is end if; end if; - -- The object declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- analysis and expansion are properly flagged as ignored Ghost. + -- The object declaration is Ghost when it is subject to pragma Ghost or + -- completes a deferred Ghost constant. Set the mode now to ensure that + -- any nodes generated during analysis and expansion are properly marked + -- as Ghost. Set_Ghost_Mode (N, Prev_Entity); @@ -3839,11 +3704,18 @@ package body Sem_Ch3 is -- the possible presence of an address clause, and defer resolution -- and expansion of the aggregate to the freeze point of the entity. + -- This is not always legal because the aggregate may contain other + -- references that need freezing, e.g. references to other entities + -- with address clauses. In any case, when compiling with -gnatI the + -- presence of the address clause must be ignored. + if Comes_From_Source (N) and then Expander_Active and then Nkind (E) = N_Aggregate - and then (Present (Following_Address_Clause (N)) - or else Delayed_Aspect_Present) + and then + ((Present (Following_Address_Clause (N)) + and then not Ignore_Rep_Clauses) + or else Delayed_Aspect_Present) then Set_Etype (E, T); @@ -3866,7 +3738,7 @@ package body Sem_Ch3 is and then Analyzed (N) and then No (Expression (N)) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -4115,7 +3987,7 @@ package body Sem_Ch3 is -- An object declared within a Ghost region is automatically -- Ghost (SPARK RM 6.9(2)). - if Comes_From_Source (Id) and then Ghost_Mode > None then + if Ghost_Mode > None then Set_Is_Ghost_Entity (Id); -- The Ghost policy in effect at the point of declaration @@ -4139,7 +4011,7 @@ package body Sem_Ch3 is Freeze_Before (N, T); Set_Is_Frozen (Id); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; else @@ -4296,10 +4168,8 @@ package body Sem_Ch3 is -- An object declared within a Ghost region is automatically Ghost -- (SPARK RM 6.9(2)). - if Comes_From_Source (Id) - and then (Ghost_Mode > None - or else (Present (Prev_Entity) - and then Is_Ghost_Entity (Prev_Entity))) + if Ghost_Mode > None + or else (Present (Prev_Entity) and then Is_Ghost_Entity (Prev_Entity)) then Set_Is_Ghost_Entity (Id); @@ -4522,7 +4392,7 @@ package body Sem_Ch3 is Check_No_Hidden_State (Id); end if; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; end Analyze_Object_Declaration; --------------------------- @@ -4543,19 +4413,12 @@ package body Sem_Ch3 is ------------------------------------------- procedure Analyze_Private_Extension_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - Indic : constant Node_Id := Subtype_Indication (N); - T : constant Entity_Id := Defining_Identifier (N); + Indic : constant Node_Id := Subtype_Indication (N); + T : constant Entity_Id := Defining_Identifier (N); Parent_Base : Entity_Id; Parent_Type : Entity_Id; begin - -- The private extension declaration may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes generated - -- during analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces if Is_Non_Empty_List (Interface_List (N)) then @@ -4769,11 +4632,6 @@ package body Sem_Ch3 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, T); end if; - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Analyze_Private_Extension_Declaration; --------------------------------- @@ -4784,18 +4642,11 @@ package body Sem_Ch3 is (N : Node_Id; Skip : Boolean := False) is - GM : constant Ghost_Mode_Type := Ghost_Mode; Id : constant Entity_Id := Defining_Identifier (N); R_Checks : Check_Result; T : Entity_Id; begin - -- The subtype declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - Generate_Definition (Id); Set_Is_Pure (Id, Is_Pure (Current_Scope)); Init_Size_Align (Id); @@ -5394,10 +5245,29 @@ package body Sem_Ch3 is Analyze_Dimension (N); - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. + -- Check No_Dynamic_Sized_Objects restriction, which disallows subtype + -- indications on composite types where the constraints are dynamic. + -- Note that object declarations and aggregates generate implicit + -- subtype declarations, which this covers. One special case is that the + -- implicitly generated "=" for discriminated types includes an + -- offending subtype declaration, which is harmless, so we ignore it + -- here. - Ghost_Mode := GM; + if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then + declare + Cstr : constant Node_Id := Constraint (Subtype_Indication (N)); + begin + if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint + and then not (Is_Internal (Id) + and then Is_TSS (Scope (Id), + TSS_Composite_Equality)) + and then not Within_Init_Proc + and then not All_Composite_Constraints_Static (Cstr) + then + Check_Restriction (No_Dynamic_Sized_Objects, Cstr); + end if; + end; + end if; end Analyze_Subtype_Declaration; -------------------------------- @@ -5703,7 +5573,7 @@ package body Sem_Ch3 is -- Inherit the "ghostness" from the constrained array type - if Is_Ghost_Entity (T) or else Ghost_Mode > None then + if Ghost_Mode > None or else Is_Ghost_Entity (T) then Set_Is_Ghost_Entity (Implicit_Base); end if; @@ -5908,7 +5778,7 @@ package body Sem_Ch3 is if ASIS_Mode then declare - Typ : constant Entity_Id := Make_Temporary (Loc, 'S'); + Typ : constant Entity_Id := Make_Temporary (Loc, 'S'); begin if Nkind (Spec) = N_Access_Function_Definition then @@ -6009,16 +5879,24 @@ package body Sem_Ch3 is Mark_Rewrite_Insertion (Comp); - if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then + if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) + or else (Nkind (Parent (N)) = N_Full_Type_Declaration + and then not Is_Type (Current_Scope)) + then + + -- Declaration can be analyzed in the current scope. + Analyze (Decl); else -- Temporarily remove the current scope (record or subprogram) from -- the stack to add the new declarations to the enclosing scope. + -- The anonymous entity is an Itype with the proper attributes. Scope_Stack.Decrement_Last; Analyze (Decl); Set_Is_Itype (Anon); + Set_Associated_Node_For_Itype (Anon, N); Scope_Stack.Append (Curr_Scope); end if; @@ -6179,7 +6057,7 @@ package body Sem_Ch3 is -- Inherit the "ghostness" from the parent base type - if Is_Ghost_Entity (Parent_Base) or else Ghost_Mode > None then + if Ghost_Mode > None or else Is_Ghost_Entity (Parent_Base) then Set_Is_Ghost_Entity (Implicit_Base); end if; end Make_Implicit_Base; @@ -10120,9 +9998,6 @@ package body Sem_Ch3 is -- operations used in dispatching selects since we always provide -- automatic overridings for these subprograms. - -- Also ignore this rule for convention CIL since .NET libraries - -- do bizarre things with interfaces??? - -- The partial view of T may have been a private extension, for -- which inherited functions dispatching on result are abstract. -- If the full view is a null extension, there is no need for @@ -10156,7 +10031,6 @@ package body Sem_Ch3 is and then not Is_TSS (Subp, TSS_Stream_Input) and then not Is_TSS (Subp, TSS_Stream_Output) and then not Is_Abstract_Type (T) - and then Convention (T) /= Convention_CIL and then not Is_Predefined_Interface_Primitive (Subp) -- Ada 2005 (AI-251): Do not consider hidden entities associated @@ -15186,11 +15060,27 @@ package body Sem_Ch3 is -- Given that this new interface entity corresponds with a primitive -- of the parent that was not overridden we must leave it associated -- with its parent primitive to ensure that it will share the same - -- dispatch table slot when overridden. + -- dispatch table slot when overridden. We must set the Alias to Subp + -- (instead of Iface_Subp), and we must fix Is_Abstract_Subprogram + -- (in case we inherited Subp from Iface_Type via a nonabstract + -- generic formal type). if No (Actual_Subp) then Set_Alias (New_Subp, Subp); + declare + T : Entity_Id := Find_Dispatching_Type (Subp); + begin + while Etype (T) /= T loop + if Is_Generic_Type (T) and then not Is_Abstract_Type (T) then + Set_Is_Abstract_Subprogram (New_Subp, False); + exit; + end if; + + T := Etype (T); + end loop; + end; + -- For instantiations this is not needed since the previous call to -- Derive_Subprogram leaves the entity well decorated. @@ -15784,25 +15674,23 @@ package body Sem_Ch3 is elsif Protected_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared" - & " as a protected interface", - N, Parent_Type); + ("descendant of & must be declared as a protected " + & "interface", N, Parent_Type); elsif Synchronized_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared" - & " as a synchronized interface", - N, Parent_Type); + ("descendant of & must be declared as a synchronized " + & "interface", N, Parent_Type); elsif Task_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared as a task interface", + ("descendant of & must be declared as a task interface", N, Parent_Type); else Error_Msg_N - ("(Ada 2005) limited interface cannot " - & "inherit from non-limited interface", Indic); + ("(Ada 2005) limited interface cannot inherit from " + & "non-limited interface", Indic); end if; -- Ada 2005 (AI-345): Non-limited interfaces can only inherit @@ -15817,19 +15705,17 @@ package body Sem_Ch3 is elsif Protected_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared" - & " as a protected interface", - N, Parent_Type); + ("descendant of & must be declared as a protected " + & "interface", N, Parent_Type); elsif Synchronized_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared" - & " as a synchronized interface", - N, Parent_Type); + ("descendant of & must be declared as a synchronized " + & "interface", N, Parent_Type); elsif Task_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared as a task interface", + ("descendant of & must be declared as a task interface", N, Parent_Type); else null; @@ -15843,8 +15729,8 @@ package body Sem_Ch3 is and then not Is_Interface (Parent_Type) then Error_Msg_N - ("parent type of a record extension cannot be " - & "a synchronized tagged type (RM 3.9.1 (3/1))", N); + ("parent type of a record extension cannot be a synchronized " + & "tagged type (RM 3.9.1 (3/1))", N); Set_Etype (T, Any_Type); return; end if; @@ -16458,28 +16344,41 @@ package body Sem_Ch3 is ----------------------------- -- Check_Duplicate_Aspects -- ----------------------------- + procedure Check_Duplicate_Aspects is Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par); Full_Aspects : constant List_Id := Aspect_Specifications (N); F_Spec, P_Spec : Node_Id; begin - if Present (Prev_Aspects) and then Present (Full_Aspects) then + if Present (Full_Aspects) then F_Spec := First (Full_Aspects); while Present (F_Spec) loop - P_Spec := First (Prev_Aspects); - while Present (P_Spec) loop - if Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec)) - then - Error_Msg_N - ("aspect already specified in private declaration", - F_Spec); - Remove (F_Spec); - return; - end if; + if Present (Prev_Aspects) then + P_Spec := First (Prev_Aspects); + while Present (P_Spec) loop + if Chars (Identifier (P_Spec)) = + Chars (Identifier (F_Spec)) + then + Error_Msg_N + ("aspect already specified in private declaration", + F_Spec); + Remove (F_Spec); + return; + end if; - Next (P_Spec); - end loop; + Next (P_Spec); + end loop; + end if; + + if Has_Discriminants (Prev) + and then not Has_Unknown_Discriminants (Prev) + and then Chars (Identifier (F_Spec)) = + Name_Implicit_Dereference + then + Error_Msg_N ("cannot specify aspect " & + "if partial view has known discriminants", F_Spec); + end if; Next (F_Spec); end loop; @@ -17945,9 +17844,9 @@ package body Sem_Ch3 is (C : Entity_Id; N : Node_Id := Empty) return Boolean is - Original_Comp : Entity_Id := Empty; + Original_Comp : Entity_Id := Empty; Original_Type : Entity_Id; - Type_Scope : Entity_Id; + Type_Scope : Entity_Id; function Is_Local_Type (Typ : Entity_Id) return Boolean; -- Check whether parent type of inherited component is declared locally, @@ -17991,7 +17890,7 @@ package body Sem_Ch3 is else Original_Type := Scope (Original_Comp); - Type_Scope := Scope (Base_Type (Scope (C))); + Type_Scope := Scope (Base_Type (Scope (C))); end if; -- This test only concerns tagged types @@ -18088,9 +17987,9 @@ package body Sem_Ch3 is if Ancestor = Original_Type then return True; - -- The ancestor may have a partial view of the original - -- type, but if the full view is in scope, as in a child - -- body, the component is visible. + -- The ancestor may have a partial view of the original type, + -- but if the full view is in scope, as in a child body, the + -- component is visible. elsif In_Private_Part (Scope (Original_Type)) and then Full_View (Ancestor) = Original_Type @@ -18099,7 +17998,7 @@ package body Sem_Ch3 is elsif Ancestor = Etype (Ancestor) then - -- No further ancestors to examine. + -- No further ancestors to examine return False; end if; @@ -18196,6 +18095,12 @@ package body Sem_Ch3 is -- The class-wide type of a class-wide type is itself (RM 3.9(14)) Set_Class_Wide_Type (CW_Type, CW_Type); + + -- Inherit the "ghostness" from the root tagged type + + if Ghost_Mode > None or else Is_Ghost_Entity (T) then + Set_Is_Ghost_Entity (CW_Type); + end if; end Make_Class_Wide_Type; ---------------- @@ -18325,7 +18230,7 @@ package body Sem_Ch3 is -- The index is given by a subtype with a range constraint - T := Base_Type (Entity (Subtype_Mark (N))); + T := Base_Type (Entity (Subtype_Mark (N))); if not Is_Discrete_Type (T) then Error_Msg_N ("discrete type required for range", N); @@ -19244,9 +19149,9 @@ package body Sem_Ch3 is end if; end if; - -- A discriminant cannot be effectively volatile. This check is only - -- relevant when SPARK_Mode is on as it is not standard Ada legality - -- rule (SPARK RM 7.1.3(6)). + -- A discriminant cannot be effectively volatile (SPARK RM 7.1.3(6)). + -- This check is relevant only when SPARK_Mode is on as it is not a + -- standard Ada legality rule. if SPARK_Mode = On and then Is_Effectively_Volatile (Defining_Identifier (Discr)) @@ -21503,7 +21408,7 @@ package body Sem_Ch3 is R : Node_Id; Subt : Entity_Id) is - Kind : constant Entity_Kind := Ekind (Def_Id); + Kind : constant Entity_Kind := Ekind (Def_Id); begin -- Defend against previous error diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 473d65ef725..394029cc87b 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -549,22 +549,6 @@ package body Sem_Ch4 is Type_Id := Etype (E); Set_Directly_Designated_Type (Acc_Type, Type_Id); - -- Allocators generated by the build-in-place expansion mechanism - -- are explicitly marked as coming from source but do not need to be - -- checked for limited initialization. To exclude this case, ensure - -- that the parent of the allocator is a source node. - - if Is_Limited_Type (Type_Id) - and then Comes_From_Source (N) - and then Comes_From_Source (Parent (N)) - and then not In_Instance_Body - then - if not OK_For_Limited_Init (Type_Id, Expression (E)) then - Error_Msg_N ("initialization not allowed for limited types", N); - Explain_Limited_Type (Type_Id, N); - end if; - end if; - -- A qualified expression requires an exact match of the type, -- class-wide matching is not allowed. @@ -1802,7 +1786,7 @@ package body Sem_Ch4 is -- call to a user-defined equality operator. -- For the predefined case, the result is Boolean, regardless of the - -- type of the operands. The operands may even be limited, if they are + -- type of the operands. The operands may even be limited, if they are -- generic actuals. If they are overloaded, label the left argument with -- the common type that must be present, or with the type of the formal -- of the user-defined function. @@ -3196,7 +3180,7 @@ package body Sem_Ch4 is -- Try_Indexed_Call and there is nothing else to do. if Is_Indexed - and then Nkind (N) = N_Slice + and then Nkind (N) = N_Slice then return; end if; @@ -3695,7 +3679,7 @@ package body Sem_Ch4 is if Is_Class_Wide_Type (T) then if not Is_Overloaded (Expr) then - if Base_Type (Etype (Expr)) /= Base_Type (T) then + if Base_Type (Etype (Expr)) /= Base_Type (T) then if Nkind (Expr) = N_Aggregate then Error_Msg_N ("type of aggregate cannot be class-wide", Expr); else @@ -5422,7 +5406,7 @@ package body Sem_Ch4 is -- and no further processing is required (this is the case of an -- operator constructed by Exp_Fixd for a fixed point operation) -- Otherwise add one interpretation with universal fixed result - -- If the operator is given in functional notation, it comes + -- If the operator is given in functional notation, it comes -- from source and Fixed_As_Integer cannot apply. if (Nkind (N) not in N_Op @@ -7161,18 +7145,147 @@ package body Sem_Ch4 is Prefix : Node_Id; Exprs : List_Id) return Boolean is + function Constant_Indexing_OK return Boolean; + -- Constant_Indexing is legal if there is no Variable_Indexing defined + -- for the type, or else node not a target of assignment, or an actual + -- for an IN OUT or OUT formal (RM 4.1.6 (11)). + + -------------------------- + -- Constant_Indexing_OK -- + -------------------------- + + function Constant_Indexing_OK return Boolean is + Par : Node_Id; + + begin + if No (Find_Value_Of_Aspect + (Etype (Prefix), Aspect_Variable_Indexing)) + then + return True; + + elsif not Is_Variable (Prefix) then + return True; + end if; + + Par := N; + while Present (Par) loop + if Nkind (Parent (Par)) = N_Assignment_Statement + and then Par = Name (Parent (Par)) + then + return False; + + -- The call may be overloaded, in which case we assume that its + -- resolution does not depend on the type of the parameter that + -- includes the indexing operation. + + elsif Nkind_In (Parent (Par), N_Function_Call, + N_Procedure_Call_Statement) + and then Is_Entity_Name (Name (Parent (Par))) + then + declare + Actual : Node_Id; + Formal : Entity_Id; + Proc : Entity_Id; + + begin + -- We should look for an interpretation with the proper + -- number of formals, and determine whether it is an + -- In_Parameter, but for now assume that in the overloaded + -- case constant indexing is legal. To be improved ??? + + if Is_Overloaded (Name (Parent (Par))) then + return True; + + else + Proc := Entity (Name (Parent (Par))); + + -- If this is an indirect call, get formals from + -- designated type. + + if Is_Access_Subprogram_Type (Etype (Proc)) then + Proc := Designated_Type (Etype (Proc)); + end if; + end if; + + Formal := First_Formal (Proc); + Actual := First_Actual (Parent (Par)); + + -- Find corresponding actual + + while Present (Actual) loop + exit when Actual = Par; + Next_Actual (Actual); + + if Present (Formal) then + Next_Formal (Formal); + + -- Otherwise this is a parameter mismatch, the error is + -- reported elsewhere. + + else + return False; + end if; + end loop; + + return Ekind (Formal) = E_In_Parameter; + end; + + elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then + return False; + + -- If the indexed component is a prefix it may be the first actual + -- of a prefixed call. Retrieve the called entity, if any, and + -- check its first formal. + + elsif Nkind (Parent (Par)) = N_Selected_Component then + declare + Sel : constant Node_Id := Selector_Name (Parent (Par)); + Nam : constant Entity_Id := Current_Entity (Sel); + + begin + if Present (Nam) + and then Is_Overloadable (Nam) + and then Present (First_Formal (Nam)) + then + return Ekind (First_Formal (Nam)) = E_In_Parameter; + end if; + end; + + elsif Nkind ((Par)) in N_Op then + return True; + end if; + + Par := Parent (Par); + end loop; + + -- In all other cases, constant indexing is legal + + return True; + end Constant_Indexing_OK; + + -- Local variables + Loc : constant Source_Ptr := Sloc (N); - C_Type : Entity_Id; Assoc : List_Id; + C_Type : Entity_Id; Func : Entity_Id; Func_Name : Node_Id; Indexing : Node_Id; + -- Start of processing for Try_Container_Indexing + begin + -- Node may have been analyzed already when testing for a prefixed + -- call, in which case do not redo analysis. + + if Present (Generalized_Indexing (N)) then + return True; + end if; + C_Type := Etype (Prefix); - -- If indexing a class-wide container, obtain indexing primitive - -- from specific type. + -- If indexing a class-wide container, obtain indexing primitive from + -- specific type. if Is_Class_Wide_Type (C_Type) then C_Type := Etype (Base_Type (C_Type)); @@ -7182,14 +7295,14 @@ package body Sem_Ch4 is Func_Name := Empty; - if Is_Variable (Prefix) then + if Constant_Indexing_OK then Func_Name := - Find_Value_Of_Aspect (Etype (Prefix), Aspect_Variable_Indexing); + Find_Value_Of_Aspect (Etype (Prefix), Aspect_Constant_Indexing); end if; if No (Func_Name) then Func_Name := - Find_Value_Of_Aspect (Etype (Prefix), Aspect_Constant_Indexing); + Find_Value_Of_Aspect (Etype (Prefix), Aspect_Variable_Indexing); end if; -- If aspect does not exist the expression is illegal. Error is @@ -7197,8 +7310,8 @@ package body Sem_Ch4 is if No (Func_Name) then - -- The prefix itself may be an indexing of a container: rewrite - -- as such and re-analyze. + -- The prefix itself may be an indexing of a container: rewrite as + -- such and re-analyze. if Has_Implicit_Dereference (Etype (Prefix)) then Build_Explicit_Dereference @@ -7213,22 +7326,19 @@ package body Sem_Ch4 is -- value of the inherited aspect is the Reference operation declared -- for the parent type. - -- However, Reference is also a primitive operation of the type, and - -- the inherited operation has a different signature. We retrieve the - -- right one from the list of primitive operations of the derived type. - - -- Note that predefined containers are typically all derived from one - -- of the Controlled types. The code below is motivated by containers - -- that are derived from other types with a Reference aspect. + -- However, Reference is also a primitive operation of the type, and the + -- inherited operation has a different signature. We retrieve the right + -- ones (the function may be overloaded) from the list of primitive + -- operations of the derived type. - -- Additional machinery may be needed for types that have several user- - -- defined Reference operations with different signatures ??? + -- Note that predefined containers are typically all derived from one of + -- the Controlled types. The code below is motivated by containers that + -- are derived from other types with a Reference aspect. elsif Is_Derived_Type (C_Type) and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix) then - Func := Find_Prim_Op (C_Type, Chars (Func_Name)); - Func_Name := New_Occurrence_Of (Func, Loc); + Func_Name := Find_Primitive_Operations (C_Type, Chars (Func_Name)); end if; Assoc := New_List (Relocate_Node (Prefix)); @@ -7241,8 +7351,8 @@ package body Sem_Ch4 is -- The generalized indexing node is the one on which analysis and -- resolution take place. Before expansion the original node is replaced - -- with the generalized indexing node, which is a call, possibly with - -- a dereference operation. + -- with the generalized indexing node, which is a call, possibly with a + -- dereference operation. if Comes_From_Source (N) then Check_Compiler_Unit ("generalized indexing", N); @@ -7282,7 +7392,8 @@ package body Sem_Ch4 is else Indexing := Make_Function_Call (Loc, - Name => Make_Identifier (Loc, Chars (Func_Name)), + Name => + Make_Identifier (Loc, Chars (Func_Name)), Parameter_Associations => Assoc); Set_Parent (Indexing, Parent (N)); @@ -7300,7 +7411,7 @@ package body Sem_Ch4 is Analyze_One_Call (Indexing, It.Nam, False, Success); if Success then - Set_Etype (Name (Indexing), It.Typ); + Set_Etype (Name (Indexing), It.Typ); Set_Entity (Name (Indexing), It.Nam); Set_Etype (N, Etype (Indexing)); @@ -7878,7 +7989,7 @@ package body Sem_Ch4 is -- Before analysis, a function call appears as an indexed component -- if there are no named associations. - elsif Nkind (Parent_Node) = N_Indexed_Component + elsif Nkind (Parent_Node) = N_Indexed_Component and then N = Prefix (Parent_Node) then Node_To_Replace := Parent_Node; @@ -8135,6 +8246,12 @@ package body Sem_Ch4 is ----------------------------------- procedure Try_One_Prefix_Interpretation (T : Entity_Id) is + + -- If the interpretation does not have a valid candidate type, + -- preserve current value of Obj_Type for subsequent errors. + + Prev_Obj_Type : constant Entity_Id := Obj_Type; + begin Obj_Type := T; @@ -8167,6 +8284,10 @@ package body Sem_Ch4 is if not Is_Tagged_Type (Obj_Type) or else Is_Incomplete_Type (Obj_Type) then + + -- Restore previous type if current one is not legal candidate + + Obj_Type := Prev_Obj_Type; return; end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 2b2e918da36..418ff13edbb 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -30,6 +30,7 @@ with Einfo; use Einfo; with Errout; use Errout; with Expander; use Expander; with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Ghost; use Ghost; @@ -90,9 +91,8 @@ package body Sem_Ch5 is ------------------------ procedure Analyze_Assignment (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - Lhs : constant Node_Id := Name (N); - Rhs : constant Node_Id := Expression (N); + Lhs : constant Node_Id := Name (N); + Rhs : constant Node_Id := Expression (N); T1 : Entity_Id; T2 : Entity_Id; Decl : Node_Id; @@ -107,9 +107,6 @@ package body Sem_Ch5 is -- the assignment, and at the end of processing before setting any new -- current values in place. - procedure Restore_Globals; - -- Restore the values of all saved global variables - procedure Set_Assignment_Type (Opnd : Node_Id; Opnd_Type : in out Entity_Id); @@ -215,15 +212,6 @@ package body Sem_Ch5 is end if; end Kill_Lhs; - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - ------------------------- -- Set_Assignment_Type -- ------------------------- @@ -282,6 +270,10 @@ package body Sem_Ch5 is end if; end Set_Assignment_Type; + -- Local variables + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + -- Start of processing for Analyze_Assignment begin @@ -293,10 +285,9 @@ package body Sem_Ch5 is Analyze (Lhs); - -- The left hand side of an assignment may reference an entity subject - -- to pragma Ghost with policy Ignore. Set the mode now to ensure that - -- any nodes generated during analysis and expansion are properly - -- flagged as ignored Ghost. + -- An assignment statement is Ghost when the left hand side denotes a + -- Ghost entity. Set the mode now to ensure that any nodes generated + -- during analysis and expansion are properly marked as Ghost. Set_Ghost_Mode (N); Analyze (Rhs); @@ -325,7 +316,19 @@ package body Sem_Ch5 is Get_First_Interp (Lhs, I, It); while Present (It.Typ) loop - if Has_Compatible_Type (Rhs, It.Typ) then + + -- An indexed component with generalized indexing is always + -- overloaded with the corresponding dereference. Discard the + -- interpretation that yields a reference type, which is not + -- assignable. + + if Nkind (Lhs) = N_Indexed_Component + and then Present (Generalized_Indexing (Lhs)) + and then Has_Implicit_Dereference (It.Typ) + then + null; + + elsif Has_Compatible_Type (Rhs, It.Typ) then if T1 /= Any_Type then -- An explicit dereference is overloaded if the prefix @@ -391,7 +394,7 @@ package body Sem_Ch5 is Error_Msg_N ("no valid types for left-hand side for assignment", Lhs); Kill_Lhs; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; end if; @@ -403,7 +406,13 @@ package body Sem_Ch5 is -- Cases where Lhs is not a variable - if not Is_Variable (Lhs) then + -- Cases where Lhs is not a variable. In an instance or an inlined body + -- no need for further check because assignment was legal in template. + + if In_Inlined_Body then + null; + + elsif not Is_Variable (Lhs) then -- Ada 2005 (AI-327): Check assignment to the attribute Priority of a -- protected object. @@ -467,14 +476,14 @@ package body Sem_Ch5 is "specified??", Lhs); end if; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; end if; end; Diagnose_Non_Variable_Lhs (Lhs); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; -- Error of assigning to limited type. We do however allow this in @@ -483,7 +492,6 @@ package body Sem_Ch5 is elsif Is_Limited_Type (T1) and then not Assignment_OK (Lhs) and then not Assignment_OK (Original_Node (Lhs)) - and then not Is_Value_Type (T1) then -- CPP constructors can only be called in declarations @@ -495,7 +503,7 @@ package body Sem_Ch5 is Explain_Limited_Type (T1, Lhs); end if; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; -- Enforce RM 3.9.3 (8): the target of an assignment operation cannot be @@ -534,7 +542,7 @@ package body Sem_Ch5 is then Error_Msg_N ("invalid use of incomplete type", Lhs); Kill_Lhs; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -552,7 +560,7 @@ package body Sem_Ch5 is if Rhs = Error then Kill_Lhs; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -561,7 +569,7 @@ package body Sem_Ch5 is if not Covers (T1, T2) then Wrong_Type (Rhs, Etype (Lhs)); Kill_Lhs; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -589,7 +597,7 @@ package body Sem_Ch5 is if T1 = Any_Type or else T2 = Any_Type then Kill_Lhs; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -682,7 +690,7 @@ package body Sem_Ch5 is -- to reset Is_True_Constant, and desirable for xref purposes. Note_Possible_Modification (Lhs, Sure => True); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; -- If we know the right hand side is non-null, then we convert to the @@ -889,7 +897,7 @@ package body Sem_Ch5 is end; Analyze_Dimension (N); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; end Analyze_Assignment; ----------------------------- @@ -1581,7 +1589,7 @@ package body Sem_Ch5 is end if; end Analyze_Cond_Then; - -- Start of Analyze_If_Statement + -- Start of processing for Analyze_If_Statement begin -- Initialize exit count for else statements. If there is no else part, @@ -1798,7 +1806,7 @@ package body Sem_Ch5 is return Etype (Ent); end Get_Cursor_Type; - -- Start of processing for Analyze_iterator_Specification + -- Start of processing for Analyze_iterator_Specification begin Enter_Name (Def_Id); @@ -1970,6 +1978,16 @@ package body Sem_Ch5 is Name => New_Copy_Tree (Iter_Name, New_Sloc => Loc)); + -- Create a transient scope to ensure that all the temporaries + -- generated by Remove_Side_Effects as part of processing this + -- renaming declaration (if any) are attached by Insert_Actions + -- to it. It has no effect on the generated code if no actions + -- are added to it (see Wrap_Transient_Declaration). + + if Expander_Active then + Establish_Transient_Scope (Name (Decl), Sec_Stack => True); + end if; + Insert_Actions (Parent (Parent (N)), New_List (Decl)); Rewrite (Name (N), New_Occurrence_Of (Id, Loc)); Set_Etype (Id, Typ); @@ -2279,9 +2297,9 @@ package body Sem_Ch5 is end if; end if; - -- A loop parameter cannot be effectively volatile. This check is - -- peformed only when SPARK_Mode is on as it is not a standard Ada - -- legality check (SPARK RM 7.1.3(6)). + -- A loop parameter cannot be effectively volatile (SPARK RM 7.1.3(4)). + -- This check is relevant only when SPARK_Mode is on as it is not a + -- standard Ada legality check. -- Not clear whether this applies to element iterators, where the -- cursor is not an explicit entity ??? @@ -3037,9 +3055,9 @@ package body Sem_Ch5 is end; end if; - -- A loop parameter cannot be effectively volatile. This check is - -- peformed only when SPARK_Mode is on as it is not a standard Ada - -- legality check (SPARK RM 7.1.3(6)). + -- A loop parameter cannot be effectively volatile (SPARK RM 7.1.3(4)). + -- This check is relevant only when SPARK_Mode is on as it is not a + -- standard Ada legality check. if SPARK_Mode = On and then Is_Effectively_Volatile (Id) then Error_Msg_N ("loop parameter cannot be volatile", Id); @@ -3215,12 +3233,18 @@ package body Sem_Ch5 is end if; end if; - -- Case of no identifier present + -- Case of no identifier present. Create one and attach it to the + -- loop statement for use as a scope and as a reference for later + -- expansions. Indicate that the label does not come from source, + -- and attach it to the loop statement so it is part of the tree, + -- even without a full declaration. else Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); Set_Etype (Ent, Standard_Void_Type); + Set_Identifier (N, New_Occurrence_Of (Ent, Loc)); Set_Parent (Ent, N); + Set_Has_Created_Identifier (N); end if; -- Iteration over a container in Ada 2012 involves the creation of a @@ -3336,16 +3360,33 @@ package body Sem_Ch5 is -- types the actual subtype of the components will only be determined -- when the cursor declaration is analyzed. - -- If the expander is not active, or in SPARK mode, then we want to - -- analyze the loop body now even in the Ada 2012 iterator case, since - -- the rewriting will not be done. Insert the loop variable in the - -- current scope, if not done when analysing the iteration scheme. - -- Set its kind properly to detect improper uses in the loop body. + -- If the expander is not active then we want to analyze the loop body + -- now even in the Ada 2012 iterator case, since the rewriting will not + -- be done. Insert the loop variable in the current scope, if not done + -- when analysing the iteration scheme. Set its kind properly to detect + -- improper uses in the loop body. + + -- In GNATprove mode, we do one of the above depending on the kind of + -- loop. If it is an iterator over an array, then we do not analyze the + -- loop now. We will analyze it after it has been rewritten by the + -- special SPARK expansion which is activated in GNATprove mode. We need + -- to do this so that other expansions that should occur in GNATprove + -- mode take into account the specificities of the rewritten loop, in + -- particular the introduction of a renaming (which needs to be + -- expanded). + + -- In other cases in GNATprove mode then we want to analyze the loop + -- body now, since no rewriting will occur. if Present (Iter) and then Present (Iterator_Specification (Iter)) then - if not Expander_Active then + if GNATprove_Mode + and then Is_Iterator_Over_Array (Iterator_Specification (Iter)) + then + null; + + elsif not Expander_Active then declare I_Spec : constant Node_Id := Iterator_Specification (Iter); Id : constant Entity_Id := Defining_Identifier (I_Spec); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 4f6038e2d30..e1fe3bb73b7 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -23,71 +23,71 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; -with Atree; use Atree; -with Checks; use Checks; -with Debug; use Debug; -with Einfo; use Einfo; -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_Ch9; use Exp_Ch9; -with Exp_Dbug; use Exp_Dbug; -with Exp_Disp; use Exp_Disp; -with Exp_Tss; use Exp_Tss; -with Exp_Util; use Exp_Util; -with Fname; use Fname; -with Freeze; use Freeze; -with Ghost; use Ghost; -with Inline; use Inline; -with Itypes; use Itypes; -with Lib.Xref; use Lib.Xref; -with Layout; use Layout; -with Namet; use Namet; -with Lib; use Lib; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Output; use Output; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -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_Ch8; use Sem_Ch8; -with Sem_Ch10; use Sem_Ch10; -with Sem_Ch12; use Sem_Ch12; -with Sem_Ch13; use Sem_Ch13; -with Sem_Dim; use Sem_Dim; -with Sem_Disp; use Sem_Disp; -with Sem_Dist; use Sem_Dist; -with Sem_Elim; use Sem_Elim; -with Sem_Eval; use Sem_Eval; -with Sem_Mech; use Sem_Mech; -with Sem_Prag; use Sem_Prag; -with Sem_Res; use Sem_Res; -with Sem_Util; use Sem_Util; -with Sem_Type; use Sem_Type; -with Sem_Warn; use Sem_Warn; -with Sinput; use Sinput; -with Stand; use Stand; -with Sinfo; use Sinfo; -with Sinfo.CN; use Sinfo.CN; -with Snames; use Snames; -with Stringt; use Stringt; +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 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_Ch9; use Exp_Ch9; +with Exp_Dbug; use Exp_Dbug; +with Exp_Disp; use Exp_Disp; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Freeze; use Freeze; +with Ghost; use Ghost; +with Inline; use Inline; +with Itypes; use Itypes; +with Lib.Xref; use Lib.Xref; +with Layout; use Layout; +with Namet; use Namet; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +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_Ch8; use Sem_Ch8; +with Sem_Ch10; use Sem_Ch10; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Prag; use Sem_Prag; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Type; use Sem_Type; +with Sem_Warn; use Sem_Warn; +with Sinput; use Sinput; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Snames; use Snames; +with Stringt; use Stringt; with Style; -with Stylesw; use Stylesw; -with Targparm; use Targparm; -with Tbuild; use Tbuild; -with Uintp; use Uintp; -with Urealp; use Urealp; -with Validsw; use Validsw; +with Stylesw; use Stylesw; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Urealp; use Urealp; +with Validsw; use Validsw; package body Sem_Ch6 is @@ -209,18 +209,11 @@ package body Sem_Ch6 is --------------------------------------------- procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - Scop : constant Entity_Id := Current_Scope; - Subp_Id : constant Entity_Id := + Scop : constant Entity_Id := Current_Scope; + Subp_Id : constant Entity_Id := Analyze_Subprogram_Specification (Specification (N)); begin - -- The abstract subprogram declaration may be subject to pragma Ghost - -- with policy Ignore. Set the mode now to ensure that any nodes - -- generated during analysis and expansion are properly flagged as - -- ignored Ghost. - - Set_Ghost_Mode (N); Check_SPARK_05_Restriction ("abstract subprogram is not allowed", N); Generate_Definition (Subp_Id); @@ -261,11 +254,6 @@ package body Sem_Ch6 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Subp_Id); end if; - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Analyze_Abstract_Subprogram_Declaration; --------------------------------- @@ -278,15 +266,16 @@ package body Sem_Ch6 is LocX : constant Source_Ptr := Sloc (Expr); Spec : constant Node_Id := Specification (N); - Def_Id : Entity_Id; + Def_Id : Entity_Id; - Prev : Entity_Id; + Prev : Entity_Id; -- If the expression is a completion, Prev is the entity whose -- declaration is completed. Def_Id is needed to analyze the spec. New_Body : Node_Id; New_Spec : Node_Id; Ret : Node_Id; + Asp : Node_Id; begin -- This is one of the occasions on which we transform the tree during @@ -462,6 +451,17 @@ package body Sem_Ch6 is Analyze (N); + -- If aspect SPARK_Mode was specified on the body, it needs to be + -- repeated both on the generated spec and the body. + + Asp := Find_Aspect (Defining_Unit_Name (Spec), Aspect_SPARK_Mode); + + if Present (Asp) then + Asp := New_Copy_Tree (Asp); + Set_Analyzed (Asp, False); + Set_Aspect_Specifications (New_Body, New_List (Asp)); + end if; + -- Within a generic pre-analyze the original expression for name -- capture. The body is also generated but plays no role in -- this because it is not part of the original source. @@ -620,6 +620,10 @@ package body Sem_Ch6 is R_Type : constant Entity_Id := Etype (Scope_Id); -- Function result subtype + procedure Check_Aggregate_Accessibility (Aggr : Node_Id); + -- Apply legality rule of 6.5 (8.2) to the access discriminants of an + -- aggregate in a return statement. + procedure Check_Limited_Return (Expr : Node_Id); -- Check the appropriate (Ada 95 or Ada 2005) rules for returning -- limited types. Used only for simple return statements. @@ -629,6 +633,58 @@ package body Sem_Ch6 is -- Check that the return_subtype_indication properly matches the result -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2). + ----------------------------------- + -- Check_Aggregate_Accessibility -- + ----------------------------------- + + procedure Check_Aggregate_Accessibility (Aggr : Node_Id) is + Typ : constant Entity_Id := Etype (Aggr); + Assoc : Node_Id; + Discr : Entity_Id; + Expr : Node_Id; + Obj : Node_Id; + + begin + if Is_Record_Type (Typ) and then Has_Discriminants (Typ) then + Discr := First_Discriminant (Typ); + Assoc := First (Component_Associations (Aggr)); + while Present (Discr) loop + if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then + Expr := Expression (Assoc); + if Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) /= Name_Unrestricted_Access + then + Obj := Prefix (Expr); + while Nkind_In (Obj, N_Indexed_Component, + N_Selected_Component) + loop + Obj := Prefix (Obj); + end loop; + + -- No check needed for an aliased formal. + -- A run-time check may still be needed ??? + + if Is_Entity_Name (Obj) + and then Is_Formal (Entity (Obj)) + and then Is_Aliased (Entity (Obj)) + then + null; + + elsif Object_Access_Level (Obj) > + Scope_Depth (Scope (Scope_Id)) + then + Error_Msg_N + ("access discriminant in return aggregate would be " + & "a dangling reference", Obj); + end if; + end if; + end if; + + Next_Discriminant (Discr); + end loop; + end if; + end Check_Aggregate_Accessibility; + -------------------------- -- Check_Limited_Return -- -------------------------- @@ -932,6 +988,10 @@ package body Sem_Ch6 is Resolve (Expr, R_Type); Check_Limited_Return (Expr); + + if Present (Expr) and then Nkind (Expr) = N_Aggregate then + Check_Aggregate_Accessibility (Expr); + end if; end if; -- RETURN only allowed in SPARK as the last statement in function @@ -1039,7 +1099,7 @@ package body Sem_Ch6 is -- inside of the subprogram (except if it is the subtype indication -- of an extended return statement). - elsif Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type then + elsif Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type then if not Comes_From_Source (Current_Scope) or else Ekind (Current_Scope) = E_Return_Statement then @@ -1268,7 +1328,7 @@ package body Sem_Ch6 is -- property is not directly inherited as the body may be subject -- to a different Ghost assertion policy. - if Is_Ghost_Entity (Gen_Id) or else Ghost_Mode > None then + if Ghost_Mode > None or else Is_Ghost_Entity (Gen_Id) then Set_Is_Ghost_Entity (Body_Id); -- The Ghost policy in effect at the point of declaration and at @@ -1309,7 +1369,7 @@ package body Sem_Ch6 is Set_Actual_Subtypes (N, Current_Scope); Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); - Set_SPARK_Pragma_Inherited (Body_Id, True); + Set_SPARK_Pragma_Inherited (Body_Id); -- Analyze any aspect specifications that appear on the generic -- subprogram body. @@ -1318,26 +1378,23 @@ package body Sem_Ch6 is Analyze_Aspect_Specifications_On_Body_Or_Stub (N); end if; + -- A generic subprogram body "freezes" the contract of its initial + -- declaration. This analysis depends on attribute Corresponding_Spec + -- being set. Only bodies coming from source should cause this type + -- of "freezing". + + if Comes_From_Source (N) then + Analyze_Initial_Declaration_Contract (N); + end if; + Analyze_Declarations (Declarations (N)); Check_Completion; - -- When a generic subprogram body appears inside a package, its - -- contract is analyzed at the end of the package body declarations. - -- This is due to the delay with respect of the package contract upon - -- which the body contract may depend. When the generic subprogram - -- body is a compilation unit, this delay is not necessary. + -- Process the contract of the subprogram body after all declarations + -- have been analyzed. This ensures that any contract-related pragmas + -- are available through the N_Contract node of the body. - if Nkind (Parent (N)) = N_Compilation_Unit then - Analyze_Subprogram_Body_Contract (Body_Id); - - -- Capture all global references in a generic subprogram body - -- that acts as a compilation unit now that the contract has - -- been analyzed. - - Save_Global_References_In_Contract - (Templ => Original_Node (N), - Gen_Id => Gen_Id); - end if; + Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id); Analyze (Handled_Statement_Sequence (N)); Save_Global_References (Original_Node (N)); @@ -1547,15 +1604,10 @@ package body Sem_Ch6 is ---------------------------- procedure Analyze_Procedure_Call (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - procedure Analyze_Call_And_Resolve; -- Do Analyze and Resolve calls for procedure call -- At end, check illegal order dependence. - procedure Restore_Globals; - -- Restore the values of all saved global variables - ------------------------------ -- Analyze_Call_And_Resolve -- ------------------------------ @@ -1570,15 +1622,6 @@ package body Sem_Ch6 is end if; end Analyze_Call_And_Resolve; - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - -- Local variables Actuals : constant List_Id := Parameter_Associations (N); @@ -1587,6 +1630,8 @@ package body Sem_Ch6 is Actual : Node_Id; New_N : Node_Id; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + -- Start of processing for Analyze_Procedure_Call begin @@ -1618,10 +1663,9 @@ package body Sem_Ch6 is return; end if; - -- The name of the procedure call may reference an entity subject to - -- pragma Ghost with policy Ignore. Set the mode now to ensure that any - -- nodes generated during analysis and expansion are properly flagged as - -- ignored Ghost. + -- A procedure call is Ghost when its name denotes a Ghost procedure. + -- Set the mode now to ensure that any nodes generated during analysis + -- and expansion are properly marked as Ghost. Set_Ghost_Mode (N); @@ -1657,7 +1701,7 @@ package body Sem_Ch6 is and then Is_Record_Type (Etype (Entity (P))) and then Remote_AST_I_Dereference (P) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; elsif Is_Entity_Name (P) @@ -1794,7 +1838,7 @@ package body Sem_Ch6 is Error_Msg_N ("invalid procedure or entry call", N); end if; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; end Analyze_Procedure_Call; ------------------------------ @@ -2061,11 +2105,6 @@ package body Sem_Ch6 is end if; if Ekind (Typ) = E_Incomplete_Type - and then Is_Value_Type (Typ) - then - null; - - elsif Ekind (Typ) = E_Incomplete_Type or else (Is_Class_Wide_Type (Typ) and then Ekind (Root_Type (Typ)) = E_Incomplete_Type) then @@ -2182,89 +2221,6 @@ package body Sem_Ch6 is end if; end Analyze_Subprogram_Body; - -------------------------------------- - -- Analyze_Subprogram_Body_Contract -- - -------------------------------------- - - procedure Analyze_Subprogram_Body_Contract (Body_Id : Entity_Id) is - Items : constant Node_Id := Contract (Body_Id); - Mode : SPARK_Mode_Type; - Prag : Node_Id; - Prag_Nam : Name_Id; - Ref_Depends : Node_Id := Empty; - Ref_Global : Node_Id := Empty; - - begin - -- When a subprogram body declaration is illegal, its defining entity is - -- left unanalyzed. There is nothing left to do in this case because the - -- body lacks a contract, or even a proper Ekind. - - if Ekind (Body_Id) = E_Void then - return; - end if; - - -- Due to the timing of contract analysis, delayed pragmas may be - -- subject to the wrong SPARK_Mode, usually that of the enclosing - -- context. To remedy this, restore the original SPARK_Mode of the - -- related subprogram body. - - Save_SPARK_Mode_And_Set (Body_Id, Mode); - - -- All subprograms carry a contract, but for some it is not significant - -- and should not be processed. - - if not Has_Significant_Contract (Body_Id) then - null; - - -- The subprogram body is a completion, analyze all delayed pragmas that - -- apply. Note that when the body is stand alone, the pragmas are always - -- analyzed on the spot. - - elsif Present (Items) then - - -- Locate and store pragmas Refined_Depends and Refined_Global since - -- their order of analysis matters. - - Prag := Classifications (Items); - while Present (Prag) loop - Prag_Nam := Pragma_Name (Prag); - - if Prag_Nam = Name_Refined_Depends then - Ref_Depends := Prag; - - elsif Prag_Nam = Name_Refined_Global then - Ref_Global := Prag; - end if; - - Prag := Next_Pragma (Prag); - end loop; - - -- Analyze Refined_Global first as Refined_Depends may mention items - -- classified in the global refinement. - - if Present (Ref_Global) then - Analyze_Refined_Global_In_Decl_Part (Ref_Global); - end if; - - -- Refined_Depends must be analyzed after Refined_Global in order to - -- see the modes of all global refinements. - - if Present (Ref_Depends) then - Analyze_Refined_Depends_In_Decl_Part (Ref_Depends); - end if; - end if; - - -- Ensure that the contract cases or postconditions mention 'Result or - -- define a post-state. - - Check_Result_And_Post_State (Body_Id); - - -- Restore the SPARK_Mode of the enclosing context after all delayed - -- pragmas have been analyzed. - - Restore_SPARK_Mode (Mode); - end Analyze_Subprogram_Body_Contract; - ------------------------------------ -- Analyze_Subprogram_Body_Helper -- ------------------------------------ @@ -2275,7 +2231,6 @@ package body Sem_Ch6 is -- the subprogram, or to perform conformance checks. procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; Loc : constant Source_Ptr := Sloc (N); Body_Spec : Node_Id := Specification (N); Body_Id : Entity_Id := Defining_Entity (Body_Spec); @@ -2351,9 +2306,6 @@ package body Sem_Ch6 is -- Determine whether subprogram Subp_Id is a primitive of a concurrent -- type that implements an interface and has a private view. - procedure Restore_Globals; - -- Restore the values of all saved global variables - procedure Set_Trivial_Subprogram (N : Node_Id); -- Sets the Is_Trivial_Subprogram flag in both spec and body of the -- subprogram whose body is being analyzed. N is the statement node @@ -2376,13 +2328,12 @@ package body Sem_Ch6 is Item : Node_Id; begin - -- Check for unanalyzed aspects in the body that will generate a - -- contract. + -- Check for aspects that may generate a contract if Present (Aspect_Specifications (N)) then Item := First (Aspect_Specifications (N)); while Present (Item) loop - if Is_Contract_Annotation (Item) then + if Is_Subprogram_Contract_Annotation (Item) then return True; end if; @@ -2396,7 +2347,7 @@ package body Sem_Ch6 is Item := First (Decls); while Present (Item) loop if Nkind (Item) = N_Pragma - and then Is_Contract_Annotation (Item) + and then Is_Subprogram_Contract_Annotation (Item) then return True; end if; @@ -2413,10 +2364,57 @@ package body Sem_Ch6 is ---------------------------------- procedure Build_Subprogram_Declaration is - Asp : Node_Id; + procedure Move_Pragmas (From : Node_Id; To : Node_Id); + -- Relocate certain categorization pragmas from the declarative list + -- of subprogram body From and insert them after node To. The pragmas + -- in question are: + -- Ghost + -- SPARK_Mode + -- Volatile_Function + + ------------------ + -- Move_Pragmas -- + ------------------ + + procedure Move_Pragmas (From : Node_Id; To : Node_Id) is + Decl : Node_Id; + Next_Decl : Node_Id; + + begin + pragma Assert (Nkind (From) = N_Subprogram_Body); + + -- The destination node must be part of a list, as the pragmas are + -- inserted after it. + + pragma Assert (Is_List_Member (To)); + + -- Inspect the declarations of the subprogram body looking for + -- specific pragmas. + + Decl := First (Declarations (N)); + while Present (Decl) loop + Next_Decl := Next (Decl); + + if Nkind (Decl) = N_Pragma + and then Nam_In (Pragma_Name (Decl), Name_Ghost, + Name_SPARK_Mode, + Name_Volatile_Function) + then + Remove (Decl); + Insert_After (To, Decl); + end if; + + Decl := Next_Decl; + end loop; + end Move_Pragmas; + + -- Local variables + Decl : Node_Id; Subp_Decl : Node_Id; + -- Start of processing for Build_Subprogram_Declaration + begin -- Create a matching subprogram spec using the profile of the body. -- The structure of the tree is identical, but has new entities for @@ -2425,16 +2423,19 @@ package body Sem_Ch6 is Subp_Decl := Make_Subprogram_Declaration (Loc, Specification => Copy_Subprogram_Spec (Body_Spec)); + Set_Comes_From_Source (Subp_Decl, True); - -- Relocate the aspects of the subprogram body to the new subprogram - -- spec because it acts as the initial declaration. - -- ??? what about pragmas + -- Relocate the aspects and relevant pragmas from the subprogram body + -- to the generated spec because it acts as the initial declaration. + Insert_Before (N, Subp_Decl); Move_Aspects (N, To => Subp_Decl); - Insert_Before_And_Analyze (N, Subp_Decl); + Move_Pragmas (N, To => Subp_Decl); - -- The analysis of the subprogram spec aspects may introduce pragmas - -- that need to be analyzed. + Analyze (Subp_Decl); + + -- Analyze any relocated source pragmas or pragmas created for aspect + -- specifications. Decl := Next (Subp_Decl); while Present (Decl) loop @@ -2460,17 +2461,6 @@ package body Sem_Ch6 is Set_Comes_From_Source (Spec_Id, True); - -- If aspect SPARK_Mode was specified on the body, it needs to be - -- repeated both on the generated spec and the body. - - Asp := Find_Aspect (Spec_Id, Aspect_SPARK_Mode); - - if Present (Asp) then - Asp := New_Copy_Tree (Asp); - Set_Analyzed (Asp, False); - Set_Aspect_Specifications (N, New_List (Asp)); - end if; - -- Ensure that the specs of the subprogram declaration and its body -- are identical, otherwise they will appear non-conformant due to -- rewritings in the default values of formal parameters. @@ -2478,6 +2468,18 @@ package body Sem_Ch6 is Body_Spec := Copy_Subprogram_Spec (Body_Spec); Set_Specification (N, Body_Spec); Body_Id := Analyze_Subprogram_Specification (Body_Spec); + + -- Ensure that the generated corresponding spec and original body + -- share the same Ghost and SPARK_Mode attributes. + + Set_Is_Checked_Ghost_Entity + (Body_Id, Is_Checked_Ghost_Entity (Spec_Id)); + Set_Is_Ignored_Ghost_Entity + (Body_Id, Is_Ignored_Ghost_Entity (Spec_Id)); + + Set_SPARK_Pragma (Body_Id, SPARK_Pragma (Spec_Id)); + Set_SPARK_Pragma_Inherited + (Body_Id, SPARK_Pragma_Inherited (Spec_Id)); end Build_Subprogram_Declaration; ---------------------------- @@ -2686,6 +2688,18 @@ package body Sem_Ch6 is Set_Has_Missing_Return (Id); end if; + -- Within a premature instantiation of a package with no body, we + -- build completions of the functions therein, with a Raise + -- statement. No point in complaining about a missing return in + -- this case. + + elsif Ekind (Id) = E_Function + and then In_Instance + and then Present (Statements (HSS)) + and then Nkind (First (Statements (HSS))) = N_Raise_Program_Error + then + null; + elsif Is_Generic_Subprogram (Id) or else not Is_Machine_Code_Subprogram (Id) then @@ -2930,15 +2944,6 @@ package body Sem_Ch6 is return False; end Is_Private_Concurrent_Primitive; - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - ---------------------------- -- Set_Trivial_Subprogram -- ---------------------------- @@ -3046,9 +3051,39 @@ package body Sem_Ch6 is end if; end Verify_Overriding_Indicator; + -- Local variables + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + Cloned_Body_For_C : Node_Id := Empty; + -- Start of processing for Analyze_Subprogram_Body_Helper begin + -- A [generic] subprogram body "freezes" the contract of the nearest + -- enclosing package body: + + -- package body Nearest_Enclosing_Package + -- with Refined_State => (State => Constit) + -- is + -- Constit : ...; + + -- procedure Freezes_Enclosing_Package_Body + -- with Refined_Depends => (Input => Constit) ... + + -- This ensures that any annotations referenced by the contract of the + -- [generic] subprogram body are available. This form of "freezing" is + -- decoupled from the usual Freeze_xxx mechanism because it must also + -- work in the context of generics where normal freezing is disabled. + + -- Only bodies coming from source should cause this type of "freezing". + -- Expression functions that act as bodies and complete an initial + -- declaration must be included in this category, hence the use of + -- Original_Node. + + if Comes_From_Source (Original_Node (N)) then + Analyze_Enclosing_Package_Body_Contract (N); + end if; + -- Generic subprograms are handled separately. They always have a -- generic specification. Determine whether current scope has a -- previous declaration. @@ -3065,10 +3100,10 @@ package body Sem_Ch6 is if Is_Generic_Subprogram (Prev_Id) then Spec_Id := Prev_Id; - -- The corresponding spec may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes - -- generated during analysis and expansion are properly flagged - -- as ignored Ghost. + -- A subprogram body is Ghost when it is stand alone and subject + -- to pragma Ghost or when the corresponding spec is Ghost. Set + -- the mode now to ensure that any nodes generated during analysis + -- and expansion are properly marked as Ghost. Set_Ghost_Mode (N, Spec_Id); Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); @@ -3081,7 +3116,7 @@ package body Sem_Ch6 is Check_Missing_Return; end if; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; else @@ -3089,7 +3124,7 @@ package body Sem_Ch6 is -- enter name will post error. Enter_Name (Body_Id); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -3100,7 +3135,7 @@ package body Sem_Ch6 is -- analysis. elsif Prev_Id = Body_Id and then Has_Completion (Body_Id) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; else @@ -3112,20 +3147,20 @@ package body Sem_Ch6 is if Is_Private_Concurrent_Primitive (Body_Id) then Spec_Id := Disambiguate_Spec; - -- The corresponding spec may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes - -- generated during analysis and expansion are properly flagged - -- as ignored Ghost. + -- A subprogram body is Ghost when it is stand alone and + -- subject to pragma Ghost or when the corresponding spec is + -- Ghost. Set the mode now to ensure that any nodes generated + -- during analysis and expansion are properly marked as Ghost. Set_Ghost_Mode (N, Spec_Id); else Spec_Id := Find_Corresponding_Spec (N); - -- The corresponding spec may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes - -- generated during analysis and expansion are properly flagged - -- as ignored Ghost. + -- A subprogram body is Ghost when it is stand alone and + -- subject to pragma Ghost or when the corresponding spec is + -- Ghost. Set the mode now to ensure that any nodes generated + -- during analysis and expansion are properly marked as Ghost. Set_Ghost_Mode (N, Spec_Id); @@ -3173,13 +3208,25 @@ package body Sem_Ch6 is and then not Inside_A_Generic then Build_Subprogram_Declaration; + + -- If this is a function that returns a constrained array, and + -- we are generating SPARK_For_C, create subprogram declaration + -- to simplify subsequent C generation. + + elsif No (Spec_Id) + and then Modify_Tree_For_C + and then Nkind (Body_Spec) = N_Function_Specification + and then Is_Array_Type (Etype (Body_Id)) + and then Is_Constrained (Etype (Body_Id)) + then + Build_Subprogram_Declaration; end if; end if; -- If this is a duplicate body, no point in analyzing it if Error_Posted (N) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -3212,10 +3259,10 @@ package body Sem_Ch6 is else Spec_Id := Corresponding_Spec (N); - -- The corresponding spec may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes - -- generated during analysis and expansion are properly flagged - -- as ignored Ghost. + -- A subprogram body is Ghost when it is stand alone and subject + -- to pragma Ghost or when the corresponding spec is Ghost. Set + -- the mode now to ensure that any nodes generated during analysis + -- and expansion are properly marked as Ghost. Set_Ghost_Mode (N, Spec_Id); end if; @@ -3256,18 +3303,17 @@ package body Sem_Ch6 is -- the freeze actions that include the bodies. In particular, extra -- formals for accessibility or for return-in-place may need to be -- generated. Freeze nodes, if any, are inserted before the current - -- body. These freeze actions are also needed in ASIS mode to enable - -- the proper back-annotations. + -- body. These freeze actions are also needed in ASIS mode and in + -- Compile_Only mode to enable the proper back-end type annotations. + -- They are necessary in any case to insure order of elaboration + -- in gigi. if not Is_Frozen (Spec_Id) - and then (Expander_Active or ASIS_Mode) + and then (Expander_Active + or else ASIS_Mode + or else (Operating_Mode = Check_Semantics + and then Serious_Errors_Detected = 0)) then - -- Force the generation of its freezing node to ensure proper - -- management of access types in the backend. - - -- This is definitely needed for some cases, but it is not clear - -- why, to be investigated further??? - Set_Has_Delayed_Freeze (Spec_Id); Freeze_Before (N, Spec_Id); end if; @@ -3292,7 +3338,7 @@ package body Sem_Ch6 is if Is_Abstract_Subprogram (Spec_Id) then Error_Msg_N ("an abstract subprogram cannot have a body", N); - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; else @@ -3303,7 +3349,7 @@ package body Sem_Ch6 is -- property is not directly inherited as the body may be subject -- to a different Ghost assertion policy. - if Is_Ghost_Entity (Spec_Id) or else Ghost_Mode > None then + if Ghost_Mode > None or else Is_Ghost_Entity (Spec_Id) then Set_Is_Ghost_Entity (Body_Id); -- The Ghost policy in effect at the point of declaration and @@ -3362,7 +3408,7 @@ package body Sem_Ch6 is if not Conformant and then not Mode_Conformant (Body_Id, Spec_Id) then - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; end if; @@ -3474,6 +3520,13 @@ package body Sem_Ch6 is New_Overloaded_Entity (Body_Id); + -- A subprogram body declared within a Ghost region is automatically + -- Ghost (SPARK RM 6.9(2)). + + if Ghost_Mode > None then + Set_Is_Ghost_Entity (Body_Id); + end if; + if Nkind (N) /= N_Subprogram_Body_Stub then Set_Acts_As_Spec (N); Generate_Definition (Body_Id); @@ -3490,10 +3543,47 @@ package body Sem_Ch6 is Generate_Reference_To_Formals (Body_Id); end if; - -- Set SPARK_Mode from context + -- Entry barrier functions are generated outside the protected type and + -- should not carry the SPARK_Mode of the enclosing context. + + if Nkind (N) = N_Subprogram_Body + and then Is_Entry_Barrier_Function (N) + then + null; - Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); - Set_SPARK_Pragma_Inherited (Body_Id, True); + -- The body is generated as part of expression function expansion. When + -- the expression function appears in the visible declarations of a + -- package, the body is added to the private declarations. Since both + -- declarative lists may be subject to a different SPARK_Mode, inherit + -- the mode of the spec. + + -- package P with SPARK_Mode is + -- function Expr_Func ... is (...); -- original + -- [function Expr_Func ...;] -- generated spec + -- -- mode is ON + -- private + -- pragma SPARK_Mode (Off); + -- [function Expr_Func ... is return ...;] -- generated body + -- end P; -- mode is ON + + elsif not Comes_From_Source (N) + and then Present (Prev_Id) + and then Is_Expression_Function (Prev_Id) + then + Set_SPARK_Pragma (Body_Id, SPARK_Pragma (Prev_Id)); + Set_SPARK_Pragma_Inherited + (Body_Id, SPARK_Pragma_Inherited (Prev_Id)); + + -- Set the SPARK_Mode from the current context (may be overwritten later + -- with explicit pragma). Exclude the case where the SPARK_Mode appears + -- initially on a stand-alone subprogram body, but is then relocated to + -- a generated corresponding spec. In this scenario the mode is shared + -- between the spec and body. + + elsif No (SPARK_Pragma (Body_Id)) then + Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Body_Id); + end if; -- If the return type is an anonymous access type whose designated type -- is the limited view of a class-wide type and the non-limited view is @@ -3569,10 +3659,25 @@ package body Sem_Ch6 is Analyze_Aspect_Specifications_On_Body_Or_Stub (N); end if; - Restore_Globals; + Ghost_Mode := Save_Ghost_Mode; return; end if; + -- If we are generating C and this is a function returning a constrained + -- array type for which we must create a procedure with an extra out + -- parameter then clone the body before it is analyzed. Needed to ensure + -- that the body of the built procedure does not have any reference to + -- the body of the function. + + if Expander_Active + and then Modify_Tree_For_C + and then Present (Spec_Id) + and then Ekind (Spec_Id) = E_Function + and then Rewritten_For_C (Spec_Id) + then + Cloned_Body_For_C := Copy_Separate_Tree (N); + end if; + -- Handle frontend inlining -- Note: Normally we don't do any inlining if expansion is off, since @@ -3661,8 +3766,8 @@ package body Sem_Ch6 is -- declaration for now, as inlining of subprogram bodies acting as -- declarations, or subprogram stubs, are not supported by frontend -- inlining. This inlining should occur after analysis of the body, so - -- that it is known whether the value of SPARK_Mode applicable to the - -- body, which can be defined by a pragma inside the body. + -- that it is known whether the value of SPARK_Mode, which can be + -- defined by a pragma inside the body, is applicable to the body. elsif GNATprove_Mode and then Full_Analysis @@ -3754,6 +3859,14 @@ package body Sem_Ch6 is Analyze_Aspect_Specifications_On_Body_Or_Stub (N); end if; + -- A subprogram body "freezes" the contract of its initial declaration. + -- This analysis depends on attribute Corresponding_Spec being set. Only + -- bodies coming from source should cause this type of "freezing". + + if Comes_From_Source (N) then + Analyze_Initial_Declaration_Contract (N); + end if; + Analyze_Declarations (Declarations (N)); -- Verify that the SPARK_Mode of the body agrees with that of its spec @@ -3783,23 +3896,11 @@ package body Sem_Ch6 is end if; end if; - -- When a subprogram body appears inside a package, its contract is - -- analyzed at the end of the package body declarations. This is due - -- to the delay with respect of the package contract upon which the - -- body contract may depend. When the subprogram body is stand alone - -- and acts as a compilation unit, this delay is not necessary. + -- A subprogram body "freezes" its own contract. Analyze the contract + -- after the declarations of the body have been processed as pragmas + -- are now chained on the contract of the subprogram body. - if Nkind (Parent (N)) = N_Compilation_Unit then - Analyze_Subprogram_Body_Contract (Body_Id); - end if; - - -- Deal with preconditions, [refined] postconditions, Contract_Cases, - -- invariants and predicates associated with body and its spec. Since - -- there is no routine Expand_Declarations which would otherwise deal - -- with the contract expansion, generate all necessary mechanisms to - -- verify the contract assertions now. - - Expand_Subprogram_Contract (N); + Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id); -- If SPARK_Mode for body is not On, disable frontend inlining for this -- subprogram in GNATprove mode, as its body should not be analyzed. @@ -4034,142 +4135,31 @@ package body Sem_Ch6 is end if; end; - Restore_Globals; - end Analyze_Subprogram_Body_Helper; - - --------------------------------- - -- Analyze_Subprogram_Contract -- - --------------------------------- - - procedure Analyze_Subprogram_Contract (Subp_Id : Entity_Id) is - Items : constant Node_Id := Contract (Subp_Id); - Depends : Node_Id := Empty; - Global : Node_Id := Empty; - Mode : SPARK_Mode_Type; - Prag : Node_Id; - Prag_Nam : Name_Id; - - begin - -- Due to the timing of contract analysis, delayed pragmas may be - -- subject to the wrong SPARK_Mode, usually that of the enclosing - -- context. To remedy this, restore the original SPARK_Mode of the - -- related subprogram body. - - Save_SPARK_Mode_And_Set (Subp_Id, Mode); - - -- All subprograms carry a contract, but for some it is not significant - -- and should not be processed. - - if not Has_Significant_Contract (Subp_Id) then - null; - - elsif Present (Items) then - - -- Analyze pre- and postconditions - - Prag := Pre_Post_Conditions (Items); - while Present (Prag) loop - Analyze_Pre_Post_Condition_In_Decl_Part (Prag); - Prag := Next_Pragma (Prag); - end loop; - - -- Analyze contract-cases and test-cases - - Prag := Contract_Test_Cases (Items); - while Present (Prag) loop - Prag_Nam := Pragma_Name (Prag); - - if Prag_Nam = Name_Contract_Cases then - Analyze_Contract_Cases_In_Decl_Part (Prag); - else - pragma Assert (Prag_Nam = Name_Test_Case); - Analyze_Test_Case_In_Decl_Part (Prag); - end if; - - Prag := Next_Pragma (Prag); - end loop; - - -- Analyze classification pragmas - - Prag := Classifications (Items); - while Present (Prag) loop - Prag_Nam := Pragma_Name (Prag); - - if Prag_Nam = Name_Depends then - Depends := Prag; - - elsif Prag_Nam = Name_Global then - Global := Prag; - - -- Note that pragma Extensions_Visible has already been analyzed - - end if; - - Prag := Next_Pragma (Prag); - end loop; - - -- Analyze Global first as Depends may mention items classified in - -- the global categorization. - - if Present (Global) then - Analyze_Global_In_Decl_Part (Global); - end if; - - -- Depends must be analyzed after Global in order to see the modes of - -- all global items. + -- When generating C code, transform a function that returns a + -- constrained array type into a procedure with an out parameter + -- that carries the return value. - if Present (Depends) then - Analyze_Depends_In_Decl_Part (Depends); - end if; - - -- Ensure that the contract cases or postconditions mention 'Result - -- or define a post-state. - - Check_Result_And_Post_State (Subp_Id); + if Present (Cloned_Body_For_C) then + Rewrite (N, + Build_Procedure_Body_Form (Spec_Id, Cloned_Body_For_C)); + Analyze (N); end if; - -- Restore the SPARK_Mode of the enclosing context after all delayed - -- pragmas have been analyzed. - - Restore_SPARK_Mode (Mode); - end Analyze_Subprogram_Contract; + Ghost_Mode := Save_Ghost_Mode; + end Analyze_Subprogram_Body_Helper; ------------------------------------ -- Analyze_Subprogram_Declaration -- ------------------------------------ procedure Analyze_Subprogram_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - - procedure Restore_Globals; - -- Restore the values of all saved global variables - - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - - -- Local variables - Scop : constant Entity_Id := Current_Scope; Designator : Entity_Id; Is_Completion : Boolean; -- Indicates whether a null procedure declaration is a completion - -- Start of processing for Analyze_Subprogram_Declaration - begin - -- The subprogram declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - -- Null procedures are not allowed in SPARK if Nkind (Specification (N)) = N_Procedure_Specification @@ -4191,7 +4181,6 @@ package body Sem_Ch6 is -- The null procedure acts as a body, nothing further is needed if Is_Completion then - Restore_Globals; return; end if; end if; @@ -4204,16 +4193,24 @@ package body Sem_Ch6 is Generate_Definition (Designator); - -- Set SPARK mode from current context (may be overwritten later with - -- explicit pragma). + -- Set the SPARK mode from the current context (may be overwritten later + -- with explicit pragma). This is not done for entry barrier functions + -- because they are generated outside the protected type and should not + -- carry the mode of the enclosing context. - Set_SPARK_Pragma (Designator, SPARK_Mode_Pragma); - Set_SPARK_Pragma_Inherited (Designator); + if Nkind (N) = N_Subprogram_Declaration + and then Is_Entry_Barrier_Function (N) + then + null; + else + Set_SPARK_Pragma (Designator, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Designator); + end if; -- A subprogram declared within a Ghost region is automatically Ghost -- (SPARK RM 6.9(2)). - if Comes_From_Source (Designator) and then Ghost_Mode > None then + if Ghost_Mode > None then Set_Is_Ghost_Entity (Designator); end if; @@ -4372,8 +4369,6 @@ package body Sem_Ch6 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Designator); end if; - - Restore_Globals; end Analyze_Subprogram_Declaration; -------------------------------------- @@ -4419,7 +4414,7 @@ package body Sem_Ch6 is -- Flag Is_Inlined_Always is True by default, and reversed to False for -- those subprograms which could be inlined in GNATprove mode (because - -- Body_To_Inline is non-Empty) but cannot be inlined. + -- Body_To_Inline is non-Empty) but should not be inlined. if GNATprove_Mode then Set_Is_Inlined_Always (Designator); @@ -4520,9 +4515,9 @@ package body Sem_Ch6 is -- the check is applied later (see Analyze_Subprogram_Declaration). if not Nkind_In (Original_Node (Parent (N)), - N_Subprogram_Renaming_Declaration, N_Abstract_Subprogram_Declaration, - N_Formal_Abstract_Subprogram_Declaration) + N_Formal_Abstract_Subprogram_Declaration, + N_Subprogram_Renaming_Declaration) then if Is_Abstract_Type (Etype (Designator)) and then not Is_Interface (Etype (Designator)) @@ -4533,14 +4528,15 @@ package body Sem_Ch6 is -- Ada 2012 (AI-0073): Extend this test to subprograms with an -- access result whose designated type is abstract. - elsif Nkind (Result_Definition (N)) = N_Access_Definition + elsif Ada_Version >= Ada_2012 + and then Nkind (Result_Definition (N)) = N_Access_Definition and then not Is_Class_Wide_Type (Designated_Type (Etype (Designator))) and then Is_Abstract_Type (Designated_Type (Etype (Designator))) - and then Ada_Version >= Ada_2012 then - Error_Msg_N ("function whose access result designates " - & "abstract type must be abstract", N); + Error_Msg_N + ("function whose access result designates abstract type " + & "must be abstract", N); end if; end if; end if; @@ -4958,7 +4954,7 @@ package body Sem_Ch6 is else declare - T : constant Entity_Id := Find_Dispatching_Type (New_Id); + T : constant Entity_Id := Find_Dispatching_Type (New_Id); begin if Is_Protected_Type (Corresponding_Concurrent_Type (T)) then @@ -6828,7 +6824,7 @@ package body Sem_Ch6 is Next_Formal (Formal); end loop; - -- If Extra_formals were already created, don't do it again. This + -- If Extra_Formals were already created, don't do it again. This -- situation may arise for subprogram types created as part of -- dispatching calls (see Expand_Dispatching_Call) @@ -6992,11 +6988,9 @@ package body Sem_Ch6 is -- Add BIP_Storage_Pool, in case BIP_Alloc_Form indicates to -- use a user-defined pool. This formal is not added on - -- .NET/JVM/ZFP as those targets do not support pools. + -- ZFP as those targets do not support pools. - if VM_Target = No_VM - and then RTE_Available (RE_Root_Storage_Pool_Ptr) - then + if RTE_Available (RE_Root_Storage_Pool_Ptr) then Discard := Add_Extra_Formal (E, RTE (RE_Root_Storage_Pool_Ptr), @@ -7470,6 +7464,19 @@ package body Sem_Ch6 is then return E; + -- Expression functions can be completions, but cannot be + -- completed by an explicit body. + + elsif Comes_From_Source (E) + and then Comes_From_Source (N) + and then Nkind (N) = N_Subprogram_Body + and then Nkind (Original_Node (Unit_Declaration_Node (E))) = + N_Expression_Function + then + Error_Msg_Sloc := Sloc (E); + Error_Msg_N ("body conflicts with expression function#", N); + return Empty; + elsif not Has_Completion (E) then if Nkind (N) /= N_Subprogram_Body_Stub then Set_Corresponding_Spec (N, E); @@ -10004,17 +10011,6 @@ package body Sem_Ch6 is (T : List_Id; Related_Nod : Node_Id) is - Context : constant Node_Id := Parent (Parent (T)); - Param_Spec : Node_Id; - Formal : Entity_Id; - Formal_Type : Entity_Id; - Default : Node_Id; - Ptype : Entity_Id; - - Num_Out_Params : Nat := 0; - First_Out_Param : Entity_Id := Empty; - -- Used for setting Is_Only_Out_Parameter - function Designates_From_Limited_With (Typ : Entity_Id) return Boolean; -- Determine whether an access type designates a type coming from a -- limited view. @@ -10052,11 +10048,24 @@ package body Sem_Ch6 is function Is_Class_Wide_Default (D : Node_Id) return Boolean is begin return Is_Class_Wide_Type (Designated_Type (Etype (D))) - or else (Nkind (D) = N_Attribute_Reference + or else (Nkind (D) = N_Attribute_Reference and then Attribute_Name (D) = Name_Access and then Is_Class_Wide_Type (Etype (Prefix (D)))); end Is_Class_Wide_Default; + -- Local variables + + Context : constant Node_Id := Parent (Parent (T)); + Default : Node_Id; + Formal : Entity_Id; + Formal_Type : Entity_Id; + Param_Spec : Node_Id; + Ptype : Entity_Id; + + Num_Out_Params : Nat := 0; + First_Out_Param : Entity_Id := Empty; + -- Used for setting Is_Only_Out_Parameter + -- Start of processing for Process_Formals begin @@ -10138,11 +10147,6 @@ package body Sem_Ch6 is end if; end if; - -- Special handling of Value_Type for CIL case - - elsif Is_Value_Type (Formal_Type) then - null; - elsif not Nkind_In (Parent (T), N_Access_Function_Definition, N_Access_Procedure_Definition) then @@ -10345,8 +10349,8 @@ package body Sem_Ch6 is Null_Exclusion_Static_Checks (Param_Spec); end if; - -- The following checks are relevant when SPARK_Mode is on as these - -- are not standard Ada legality rules. + -- The following checks are relevant only when SPARK_Mode is on as + -- these are not standard Ada legality rules. if SPARK_Mode = On then if Ekind_In (Scope (Formal), E_Function, E_Generic_Function) then @@ -10358,14 +10362,6 @@ package body Sem_Ch6 is Error_Msg_N ("function cannot have parameter of mode `OUT` or " & "`IN OUT`", Formal); - - -- A function cannot have an effectively volatile formal - -- parameter (SPARK RM 7.1.3(10)). - - elsif Is_Effectively_Volatile (Formal) then - Error_Msg_N - ("function cannot have a volatile formal parameter", - Formal); end if; -- A procedure cannot have an effectively volatile formal @@ -10404,7 +10400,7 @@ package body Sem_Ch6 is Set_Default_Value (Formal, Expression (Param_Spec)); if Present (Expression (Param_Spec)) then - Default := Expression (Param_Spec); + Default := Expression (Param_Spec); if Is_Scalar_Type (Etype (Default)) then if Nkind (Parameter_Type (Param_Spec)) /= diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index 427559e527b..ff24ed83acc 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -45,31 +45,6 @@ package Sem_Ch6 is procedure Analyze_Subprogram_Declaration (N : Node_Id); procedure Analyze_Subprogram_Body (N : Node_Id); - procedure Analyze_Subprogram_Body_Contract (Body_Id : Entity_Id); - -- Analyze all delayed aspects chained on the contract of subprogram body - -- Body_Id as if they appeared at the end of a declarative region. Aspects - -- in question are: - -- Contract_Cases (stand alone body) - -- Depends (stand alone body) - -- Global (stand alone body) - -- Postcondition (stand alone body) - -- Precondition (stand alone body) - -- Refined_Depends - -- Refined_Global - -- Refined_Post - -- Test_Case (stand alone body) - - procedure Analyze_Subprogram_Contract (Subp_Id : Entity_Id); - -- Analyze all delayed aspects chained on the contract of subprogram - -- Subp_Id as if they appeared at the end of a declarative region. The - -- aspects in question are: - -- Contract_Cases - -- Depends - -- Global - -- Postcondition - -- Precondition - -- Test_Case - function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id; -- Analyze subprogram specification in both subprogram declarations -- and body declarations. Returns the defining entity for the diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index f39da2c0066..229d29dbe3a 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -28,44 +28,45 @@ -- handling of private and full declarations, and the construction of dispatch -- tables for tagged types. -with Aspects; use Aspects; -with Atree; use Atree; -with Debug; use Debug; -with Einfo; use Einfo; -with Elists; use Elists; -with Errout; use Errout; -with Exp_Disp; use Exp_Disp; -with Exp_Dist; use Exp_Dist; -with Exp_Dbug; use Exp_Dbug; -with Ghost; use Ghost; -with Lib; use Lib; -with Lib.Xref; use Lib.Xref; -with Namet; use Namet; -with Nmake; use Nmake; -with Nlists; use Nlists; -with Opt; use Opt; -with Output; use Output; -with Restrict; use Restrict; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Cat; use Sem_Cat; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch10; use Sem_Ch10; -with Sem_Ch12; use Sem_Ch12; -with Sem_Ch13; use Sem_Ch13; -with Sem_Disp; use Sem_Disp; -with Sem_Eval; use Sem_Eval; -with Sem_Prag; use Sem_Prag; -with Sem_Util; use Sem_Util; -with Sem_Warn; use Sem_Warn; -with Snames; use Snames; -with Stand; use Stand; -with Sinfo; use Sinfo; -with Sinput; use Sinput; +with Aspects; use Aspects; +with Atree; use Atree; +with Contracts; use Contracts; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; +with Exp_Dbug; use Exp_Dbug; +with Ghost; use Ghost; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Output; use Output; +with Restrict; use Restrict; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch10; use Sem_Ch10; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Snames; use Snames; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinput; use Sinput; with Style; -with Uintp; use Uintp; +with Uintp; use Uintp; package body Sem_Ch7 is @@ -182,47 +183,6 @@ package body Sem_Ch7 is end if; end Analyze_Package_Body; - ----------------------------------- - -- Analyze_Package_Body_Contract -- - ----------------------------------- - - procedure Analyze_Package_Body_Contract (Body_Id : Entity_Id) is - Spec_Id : constant Entity_Id := Spec_Entity (Body_Id); - Mode : SPARK_Mode_Type; - Ref_State : Node_Id; - - begin - -- Due to the timing of contract analysis, delayed pragmas may be - -- subject to the wrong SPARK_Mode, usually that of the enclosing - -- context. To remedy this, restore the original SPARK_Mode of the - -- related package body. - - Save_SPARK_Mode_And_Set (Body_Id, Mode); - - Ref_State := Get_Pragma (Body_Id, Pragma_Refined_State); - - -- The analysis of pragma Refined_State detects whether the spec has - -- abstract states available for refinement. - - if Present (Ref_State) then - Analyze_Refined_State_In_Decl_Part (Ref_State); - - -- State refinement is required when the package declaration defines at - -- least one abstract state. Null states are not considered. Refinement - -- is not envorced when SPARK checks are turned off. - - elsif SPARK_Mode /= Off - and then Requires_State_Refinement (Spec_Id, Body_Id) - then - Error_Msg_N ("package & requires state refinement", Spec_Id); - end if; - - -- Restore the SPARK_Mode of the enclosing context after all delayed - -- pragmas have been analyzed. - - Restore_SPARK_Mode (Mode); - end Analyze_Package_Body_Contract; - --------------------------------- -- Analyze_Package_Body_Helper -- --------------------------------- @@ -571,7 +531,7 @@ package body Sem_Ch7 is -- Local variables - GM : constant Ghost_Mode_Type := Ghost_Mode; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; Body_Id : Entity_Id; HSS : Node_Id; Last_Spec_Entity : Entity_Id; @@ -582,6 +542,34 @@ package body Sem_Ch7 is -- Start of processing for Analyze_Package_Body_Helper begin + -- A [generic] package body "freezes" the contract of the nearest + -- enclosing package body: + + -- package body Nearest_Enclosing_Package + -- with Refined_State => (State => Constit) + -- is + -- Constit : ...; + + -- package body Freezes_Enclosing_Package_Body + -- with Refined_State => (State_2 => Constit_2) + -- is + -- Constit_2 : ...; + + -- procedure Proc + -- with Refined_Depends => (Input => (Constit, Constit_2)) ... + + -- This ensures that any annotations referenced by the contract of a + -- [generic] subprogram body declared within the current package body + -- are available. This form of "freezing" is decoupled from the usual + -- Freeze_xxx mechanism because it must also work in the context of + -- generics where normal freezing is disabled. + + -- Only bodies coming from source should cause this type of "freezing" + + if Comes_From_Source (N) then + Analyze_Enclosing_Package_Body_Contract (N); + end if; + -- Find corresponding package specification, and establish the current -- scope. The visible defining entity for the package is the defining -- occurrence in the spec. On exit from the package body, all body @@ -637,10 +625,9 @@ package body Sem_Ch7 is end if; end if; - -- The corresponding spec of the package body may be subject to pragma - -- Ghost with policy Ignore. Set the mode now to ensure that any nodes - -- generated during analysis and expansion are properly flagged as - -- ignored Ghost. + -- A package body is Ghost when the corresponding spec is Ghost. Set + -- the mode now to ensure that any nodes generated during analysis and + -- expansion are properly flagged as ignored Ghost. Set_Ghost_Mode (N, Spec_Id); @@ -731,23 +718,17 @@ package body Sem_Ch7 is -- Set SPARK_Mode only for non-generic package if Ekind (Spec_Id) = E_Package then - - -- Set SPARK_Mode from context - - Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); - Set_SPARK_Pragma_Inherited (Body_Id, True); - - -- Set elaboration code SPARK mode the same for now - - Set_SPARK_Aux_Pragma (Body_Id, SPARK_Pragma (Body_Id)); - Set_SPARK_Aux_Pragma_Inherited (Body_Id, True); + Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); + Set_SPARK_Aux_Pragma (Body_Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Body_Id); + Set_SPARK_Aux_Pragma_Inherited (Body_Id); end if; - -- Inherit the "ghostness" of the subprogram spec. Note that this - -- property is not directly inherited as the body may be subject to a - -- different Ghost assertion policy. + -- Inherit the "ghostness" of the package spec. Note that this property + -- is not directly inherited as the body may be subject to a different + -- Ghost assertion policy. - if Is_Ghost_Entity (Spec_Id) or else Ghost_Mode > None then + if Ghost_Mode > None or else Is_Ghost_Entity (Spec_Id) then Set_Is_Ghost_Entity (Body_Id); -- The Ghost policy in effect at the point of declaration and at the @@ -782,6 +763,14 @@ package body Sem_Ch7 is Declare_Inherited_Private_Subprograms (Spec_Id); end if; + -- A package body "freezes" the contract of its initial declaration. + -- This analysis depends on attribute Corresponding_Spec being set. Only + -- bodies coming from source shuld cause this type of "freezing". + + if Comes_From_Source (N) then + Analyze_Initial_Declaration_Contract (N); + end if; + if Present (Declarations (N)) then Analyze_Declarations (Declarations (N)); Inspect_Deferred_Constant_Completion (Declarations (N)); @@ -942,101 +931,14 @@ package body Sem_Ch7 is end if; end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Analyze_Package_Body_Helper; - ------------------------------ - -- Analyze_Package_Contract -- - ------------------------------ - - procedure Analyze_Package_Contract (Pack_Id : Entity_Id) is - Items : constant Node_Id := Contract (Pack_Id); - Init : Node_Id := Empty; - Init_Cond : Node_Id := Empty; - Mode : SPARK_Mode_Type; - Prag : Node_Id; - Prag_Nam : Name_Id; - - begin - -- Due to the timing of contract analysis, delayed pragmas may be - -- subject to the wrong SPARK_Mode, usually that of the enclosing - -- context. To remedy this, restore the original SPARK_Mode of the - -- related package. - - Save_SPARK_Mode_And_Set (Pack_Id, Mode); - - if Present (Items) then - - -- Locate and store pragmas Initial_Condition and Initializes since - -- their order of analysis matters. - - Prag := Classifications (Items); - while Present (Prag) loop - Prag_Nam := Pragma_Name (Prag); - - if Prag_Nam = Name_Initial_Condition then - Init_Cond := Prag; - - elsif Prag_Nam = Name_Initializes then - Init := Prag; - end if; - - Prag := Next_Pragma (Prag); - end loop; - - -- Analyze the initialization related pragmas. Initializes must come - -- before Initial_Condition due to item dependencies. - - if Present (Init) then - Analyze_Initializes_In_Decl_Part (Init); - end if; - - if Present (Init_Cond) then - Analyze_Initial_Condition_In_Decl_Part (Init_Cond); - end if; - end if; - - -- Check whether the lack of indicator Part_Of agrees with the placement - -- of the package instantiation with respect to the state space. - - if Is_Generic_Instance (Pack_Id) then - Prag := Get_Pragma (Pack_Id, Pragma_Part_Of); - - if No (Prag) then - Check_Missing_Part_Of (Pack_Id); - end if; - end if; - - -- Restore the SPARK_Mode of the enclosing context after all delayed - -- pragmas have been analyzed. - - Restore_SPARK_Mode (Mode); - end Analyze_Package_Contract; - --------------------------------- -- Analyze_Package_Declaration -- --------------------------------- procedure Analyze_Package_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - - procedure Restore_Globals; - -- Restore the values of all saved global variables - - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - - -- Local variables - Id : constant Node_Id := Defining_Entity (N); Body_Required : Boolean; @@ -1048,8 +950,6 @@ package body Sem_Ch7 is PF : Boolean; -- True when in the context of a declared pure library unit - -- Start of processing for Analyze_Package_Declaration - begin if Debug_Flag_C then Write_Str ("==> package spec "); @@ -1060,12 +960,6 @@ package body Sem_Ch7 is Indent; end if; - -- The package declaration may be subject to pragma Ghost with policy - -- Ignore. Set the mode now to ensure that any nodes generated during - -- analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - Generate_Definition (Id); Enter_Name (Id); Set_Ekind (Id, E_Package); @@ -1076,8 +970,8 @@ package body Sem_Ch7 is if Ekind (Id) = E_Package then Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); Set_SPARK_Aux_Pragma (Id, SPARK_Mode_Pragma); - Set_SPARK_Pragma_Inherited (Id, True); - Set_SPARK_Aux_Pragma_Inherited (Id, True); + Set_SPARK_Pragma_Inherited (Id); + Set_SPARK_Aux_Pragma_Inherited (Id); end if; -- A package declared within a Ghost refion is automatically Ghost @@ -1102,7 +996,6 @@ package body Sem_Ch7 is -- package Pkg is ... if From_Limited_With (Id) then - Restore_Globals; return; end if; @@ -1163,8 +1056,6 @@ package body Sem_Ch7 is Write_Location (Sloc (N)); Write_Eol; end if; - - Restore_Globals; end Analyze_Package_Declaration; ----------------------------------- @@ -1851,17 +1742,10 @@ package body Sem_Ch7 is -------------------------------------- procedure Analyze_Private_Type_Declaration (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; Id : constant Entity_Id := Defining_Identifier (N); PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity); begin - -- The private type declaration may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes generated - -- during analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - Generate_Definition (Id); Set_Is_Pure (Id, PF); Init_Size_Align (Id); @@ -1885,11 +1769,6 @@ package body Sem_Ch7 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Id); end if; - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Analyze_Private_Type_Declaration; ---------------------------------- diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads index a243ac5f3dc..59f27b086bb 100644 --- a/gcc/ada/sem_ch7.ads +++ b/gcc/ada/sem_ch7.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,20 +32,6 @@ package Sem_Ch7 is procedure Analyze_Package_Specification (N : Node_Id); procedure Analyze_Private_Type_Declaration (N : Node_Id); - procedure Analyze_Package_Body_Contract (Body_Id : Entity_Id); - -- Analyze all delayed aspects chained on the contract of package body - -- Body_Id as if they appeared at the end of a declarative region. The - -- aspects that are considered are: - -- Refined_State - - procedure Analyze_Package_Contract (Pack_Id : Entity_Id); - -- Analyze all delayed aspects chained on the contract of package Pack_Id - -- as if they appeared at the end of a declarative region. The aspects - -- that are considered are: - -- Initial_Condition - -- Initializes - -- Part_Of - procedure End_Package_Scope (P : Entity_Id); -- Calls Uninstall_Declarations, and then pops the scope stack diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index ee76eda0fce..d4487124e6b 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -68,7 +68,6 @@ with Sinfo.CN; use Sinfo.CN; with Snames; use Snames; with Style; use Style; with Table; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -108,7 +107,7 @@ package body Sem_Ch8 is -- Open scopes, that is to say scopes currently being compiled, have their -- corresponding rows of entities in order, innermost scope first. - -- The scopes of packages that are mentioned in context clauses appear in + -- The scopes of packages that are mentioned in context clauses appear in -- no particular order, interspersed among open scopes. This is because -- in the course of analyzing the context of a compilation, a package -- declaration is first an open scope, and subsequently an element of the @@ -192,7 +191,7 @@ package body Sem_Ch8 is -- removed from visibility chains on exit from the corresponding scope. -- From the outside, these entities are always accessed by selected -- notation, and the entity chain for the record type, protected type, - -- etc. is traversed sequentially in order to find the designated entity. + -- etc. is traversed sequentially in order to find the designated entity. -- The discriminants of a type and the operations of a protected type or -- task are unchained on exit from the first view of the type, (such as @@ -225,7 +224,7 @@ package body Sem_Ch8 is -- The Rtsfind mechanism can force a call to Semantics while another -- compilation is in progress. The unit retrieved by Rtsfind must be - -- compiled in its own context, and has no access to the visibility of + -- compiled in its own context, and has no access to the visibility of -- the unit currently being compiled. The procedures Save_Scope_Stack and -- Restore_Scope_Stack make entities in current open scopes invisible -- before compiling the retrieved unit, and restore the compilation @@ -550,17 +549,10 @@ package body Sem_Ch8 is -- there is more than one element in the list. procedure Analyze_Exception_Renaming (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - Id : constant Entity_Id := Defining_Entity (N); - Nam : constant Node_Id := Name (N); + Id : constant Entity_Id := Defining_Entity (N); + Nam : constant Node_Id := Name (N); begin - -- The exception renaming declaration may be subject to pragma Ghost - -- with policy Ignore. Set the mode now to ensure that any nodes - -- generated during analysis and expansion are properly flagged as - -- ignored Ghost. - - Set_Ghost_Mode (N); Check_SPARK_05_Restriction ("exception renaming is not allowed", N); Enter_Name (Id); @@ -595,11 +587,6 @@ package body Sem_Ch8 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Id); end if; - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Analyze_Exception_Renaming; --------------------------- @@ -610,8 +597,10 @@ package body Sem_Ch8 is begin -- If the entity pointer is already set, this is an internal node, or a -- node that is analyzed more than once, after a tree modification. In - -- such a case there is no resolution to perform, just set the type. For - -- completeness, analyze prefix as well. + -- such a case there is no resolution to perform, just set the type. In + -- either case, start by analyzing the prefix. + + Analyze (Prefix (N)); if Present (Entity (N)) then if Is_Type (Entity (N)) then @@ -620,7 +609,6 @@ package body Sem_Ch8 is Set_Etype (N, Etype (Entity (N))); end if; - Analyze (Prefix (N)); return; else Find_Expanded_Name (N); @@ -669,8 +657,7 @@ package body Sem_Ch8 is (N : Node_Id; K : Entity_Kind) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - New_P : constant Entity_Id := Defining_Entity (N); + New_P : constant Entity_Id := Defining_Entity (N); Old_P : Entity_Id; Inst : Boolean := False; @@ -681,11 +668,6 @@ package body Sem_Ch8 is return; end if; - -- The generic renaming declaration may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes generated - -- during analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); Check_SPARK_05_Restriction ("generic renaming is not allowed", N); Generate_Definition (New_P); @@ -756,11 +738,6 @@ package body Sem_Ch8 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, New_P); end if; - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Analyze_Generic_Renaming; ----------------------------- @@ -867,10 +844,6 @@ package body Sem_Ch8 is return False; end In_Generic_Scope; - -- Local variables - - GM : constant Ghost_Mode_Type := Ghost_Mode; - -- Start of processing for Analyze_Object_Renaming begin @@ -878,11 +851,6 @@ package body Sem_Ch8 is return; end if; - -- The object renaming declaration may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes generated - -- during analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); Check_SPARK_05_Restriction ("object renaming is not allowed", N); Set_Is_Pure (Id, Is_Pure (Current_Scope)); @@ -1394,11 +1362,6 @@ package body Sem_Ch8 is -- Deal with dimensions Analyze_Dimension (N); - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Analyze_Object_Renaming; ------------------------------ @@ -1406,39 +1369,15 @@ package body Sem_Ch8 is ------------------------------ procedure Analyze_Package_Renaming (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - - procedure Restore_Globals; - -- Restore the values of all saved global variables - - --------------------- - -- Restore_Globals -- - --------------------- - - procedure Restore_Globals is - begin - Ghost_Mode := GM; - end Restore_Globals; - - -- Local variables - New_P : constant Entity_Id := Defining_Entity (N); Old_P : Entity_Id; Spec : Node_Id; - -- Start of processing for Analyze_Package_Renaming - begin if Name (N) = Error then return; end if; - -- The package renaming declaration may be subject to pragma Ghost with - -- policy Ignore. Set the mode now to ensure that any nodes generated - -- during analysis and expansion are properly flagged as ignored Ghost. - - Set_Ghost_Mode (N); - -- Check for Text_IO special unit (we may be renaming a Text_IO child) Check_Text_IO_Special_Unit (Name (N)); @@ -1538,7 +1477,6 @@ package body Sem_Ch8 is -- subtypes again, so they are compatible with types in their class. if not Is_Generic_Instance (Old_P) then - Restore_Globals; return; else Spec := Specification (Unit_Declaration_Node (Old_P)); @@ -1580,8 +1518,6 @@ package body Sem_Ch8 is if Has_Aspects (N) then Analyze_Aspect_Specifications (N, New_P); end if; - - Restore_Globals; end Analyze_Package_Renaming; ------------------------------- @@ -2628,20 +2564,12 @@ package body Sem_Ch8 is -- defaulted formal subprogram when the actual for a related formal -- type is class-wide. - GM : constant Ghost_Mode_Type := Ghost_Mode; - Inst_Node : Node_Id := Empty; + Inst_Node : Node_Id := Empty; New_S : Entity_Id; -- Start of processing for Analyze_Subprogram_Renaming begin - -- The subprogram renaming declaration may be subject to pragma Ghost - -- with policy Ignore. Set the mode now to ensure that any nodes - -- generated during analysis and expansion are properly flagged as - -- ignored Ghost. - - Set_Ghost_Mode (N); - -- We must test for the attribute renaming case before the Analyze -- call because otherwise Sem_Attr will complain that the attribute -- is missing an argument when it is analyzed. @@ -2849,7 +2777,7 @@ package body Sem_Ch8 is -- Set SPARK mode from current context Set_SPARK_Pragma (New_S, SPARK_Mode_Pragma); - Set_SPARK_Pragma_Inherited (New_S, True); + Set_SPARK_Pragma_Inherited (New_S); Rename_Spec := Find_Corresponding_Spec (N); @@ -3294,7 +3222,13 @@ package body Sem_Ch8 is Find_Dispatching_Type (Old_S); begin - if Old_S_Ctrl_Type /= New_S_Ctrl_Type then + + -- The actual must match the (instance of the) formal, + -- and must be a controlling type. + + if Old_S_Ctrl_Type /= New_S_Ctrl_Type + or else No (New_S_Ctrl_Type) + then Error_Msg_NE ("actual must be dispatching subprogram for type&", Nam, New_S_Ctrl_Type); @@ -3559,11 +3493,6 @@ package body Sem_Ch8 is Analyze (N); end if; end if; - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; end Analyze_Subprogram_Renaming; ------------------------- @@ -3986,15 +3915,14 @@ package body Sem_Ch8 is -- type is still not frozen). We exclude from this processing generic -- formal subprograms found in instantiations. - -- We must exclude VM targets and restricted run-time libraries because + -- We must exclude restricted run-time libraries because -- entity AST_Handler is defined in package System.Aux_Dec which is not -- available in those platforms. Note that we cannot use the function -- Restricted_Profile (instead of Configurable_Run_Time_Mode) because -- the ZFP run-time library is not defined as a profile, and we do not -- want to deal with AST_Handler in ZFP mode. - if VM_Target = No_VM - and then not Configurable_Run_Time_Mode + if not Configurable_Run_Time_Mode and then not Present (Corresponding_Formal_Spec (N)) and then Etype (Nam) /= RTE (RE_AST_Handler) then @@ -5683,20 +5611,20 @@ package body Sem_Ch8 is end case; end if; end if; - - Check_Nested_Access (E); end if; Set_Entity_Or_Discriminal (N, E); -- The name may designate a generalized reference, in which case - -- the dereference interpretation will be included. + -- the dereference interpretation will be included. Context is + -- one in which a name is legal. if Ada_Version >= Ada_2012 and then (Nkind (Parent (N)) in N_Subexpr - or else Nkind_In (Parent (N), N_Object_Declaration, - N_Assignment_Statement)) + or else Nkind_In (Parent (N), N_Assignment_Statement, + N_Object_Declaration, + N_Parameter_Association)) then Check_Implicit_Dereference (N, Etype (E)); end if; @@ -5719,41 +5647,61 @@ package body Sem_Ch8 is -- the scope of its declaration. procedure Find_Expanded_Name (N : Node_Id) is - function In_Pragmas_Depends_Or_Global (N : Node_Id) return Boolean; - -- Determine whether an arbitrary node N appears in pragmas [Refined_] - -- Depends or [Refined_]Global. + function In_Abstract_View_Pragma (Nod : Node_Id) return Boolean; + -- Determine whether expanded name Nod appears within a pragma which is + -- a suitable context for an abstract view of a state or variable. The + -- following pragmas fall in this category: + -- Depends + -- Global + -- Initializes + -- Refined_Depends + -- Refined_Global + -- + -- In addition, pragma Abstract_State is also considered suitable even + -- though it is an illegal context for an abstract view as this allows + -- for proper resolution of abstract views of variables. This illegal + -- context is later flagged in the analysis of indicator Part_Of. - ---------------------------------- - -- In_Pragmas_Depends_Or_Global -- - ---------------------------------- + ----------------------------- + -- In_Abstract_View_Pragma -- + ----------------------------- - function In_Pragmas_Depends_Or_Global (N : Node_Id) return Boolean is + function In_Abstract_View_Pragma (Nod : Node_Id) return Boolean is Par : Node_Id; begin -- Climb the parent chain looking for a pragma - Par := N; + Par := Nod; while Present (Par) loop - if Nkind (Par) = N_Pragma - and then Nam_In (Pragma_Name (Par), Name_Depends, - Name_Global, - Name_Refined_Depends, - Name_Refined_Global) - then - return True; + if Nkind (Par) = N_Pragma then + if Nam_In (Pragma_Name (Par), Name_Abstract_State, + Name_Depends, + Name_Global, + Name_Initializes, + Name_Refined_Depends, + Name_Refined_Global) + then + return True; + + -- Otherwise the pragma is not a legal context for an abstract + -- view. + + else + exit; + end if; -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then - return False; + exit; end if; Par := Parent (Par); end loop; return False; - end In_Pragmas_Depends_Or_Global; + end In_Abstract_View_Pragma; -- Local variables @@ -5799,18 +5747,19 @@ package body Sem_Ch8 is Is_New_Candidate := True; -- Handle abstract views of states and variables. These are - -- acceptable only when the reference to the view appears in - -- pragmas [Refined_]Depends and [Refined_]Global. + -- acceptable candidates only when the reference to the view + -- appears in certain pragmas. if Ekind (Id) = E_Abstract_State and then From_Limited_With (Id) and then Present (Non_Limited_View (Id)) then - if In_Pragmas_Depends_Or_Global (N) then + if In_Abstract_View_Pragma (N) then Candidate := Non_Limited_View (Id); Is_New_Candidate := True; - -- Hide candidate because it is not used in a proper context + -- Hide the candidate because it is not used in a proper + -- context. else Candidate := Empty; @@ -5902,22 +5851,22 @@ package body Sem_Ch8 is Find_Expanded_Name (N); return; + -- There is an implicit instance of the predefined operator in + -- the given scope. The operator entity is defined in Standard. + -- Has_Implicit_Operator makes the node into an Expanded_Name. + elsif Nkind (Selector) = N_Operator_Symbol and then Has_Implicit_Operator (N) then - -- There is an implicit instance of the predefined operator in - -- the given scope. The operator entity is defined in Standard. - -- Has_Implicit_Operator makes the node into an Expanded_Name. - return; + -- If there is no literal defined in the scope denoted by the + -- prefix, the literal may belong to (a type derived from) + -- Standard_Character, for which we have no explicit literals. + elsif Nkind (Selector) = N_Character_Literal and then Has_Implicit_Character_Literal (N) then - -- If there is no literal defined in the scope denoted by the - -- prefix, the literal may belong to (a type derived from) - -- Standard_Character, for which we have no explicit literals. - return; else @@ -5954,8 +5903,8 @@ package body Sem_Ch8 is and then not In_Private_Part (Current_Scope) and then not Is_Private_Descendant (Current_Scope) then - Error_Msg_N ("private child unit& is not visible here", - Selector); + Error_Msg_N + ("private child unit& is not visible here", Selector); -- Normal case where we have a missing with for a child unit @@ -6004,8 +5953,9 @@ package body Sem_Ch8 is E_Package, E_Procedure) then - P := Generic_Parent (Specification - (Unit_Declaration_Node (S))); + P := + Generic_Parent (Specification + (Unit_Declaration_Node (S))); -- Check that P is a generic child of the generic -- parent of the prefix. @@ -6043,7 +5993,6 @@ package body Sem_Ch8 is -- Here we have the case of an undefined component else - -- The prefix may hide a homonym in the context that -- declares the desired entity. This error can use a -- specialized message. @@ -6679,13 +6628,9 @@ package body Sem_Ch8 is -- Do not build the subtype when referencing components of -- dispatch table wrappers. Required to avoid generating - -- elaboration code with HI runtimes. JVM and .NET use a - -- modified version of Ada.Tags which does not contain RE_ - -- Dispatch_Table_Wrapper and RE_No_Dispatch_Table_Wrapper. - -- Avoid raising RE_Not_Available exception in those cases. + -- elaboration code with HI runtimes. - elsif VM_Target = No_VM - and then RTU_Loaded (Ada_Tags) + elsif RTU_Loaded (Ada_Tags) and then ((RTE_Available (RE_Dispatch_Table_Wrapper) and then Scope (Selector) = @@ -9093,7 +9038,7 @@ package body Sem_Ch8 is function Entity_Of_Unit (U : Node_Id) return Entity_Id is begin - if Nkind (U) = N_Package_Instantiation + if Nkind (U) = N_Package_Instantiation and then Analyzed (U) then return Defining_Entity (Instance_Spec (U)); @@ -9293,7 +9238,7 @@ package body Sem_Ch8 is S : Entity_Id; begin for J in reverse 1 .. Scope_Stack.Last loop - S := Scope_Stack.Table (J).Entity; + S := Scope_Stack.Table (J).Entity; Write_Int (Int (S)); Write_Str (" === "); Write_Name (Chars (S)); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index ff112317080..47cd3c663bb 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -23,43 +23,44 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; -with Atree; use Atree; -with Checks; use Checks; -with Debug; use Debug; -with Einfo; use Einfo; -with Errout; use Errout; -with Exp_Ch9; use Exp_Ch9; -with Elists; use Elists; -with Freeze; use Freeze; -with Layout; use Layout; -with Lib.Xref; use Lib.Xref; -with Namet; use Namet; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch5; use Sem_Ch5; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch13; use Sem_Ch13; -with Sem_Eval; use Sem_Eval; -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 Snames; use Snames; -with Stand; use Stand; -with Sinfo; use Sinfo; +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 Errout; use Errout; +with Exp_Ch9; use Exp_Ch9; +with Elists; use Elists; +with Freeze; use Freeze; +with Layout; use Layout; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch5; use Sem_Ch5; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +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 Snames; use Snames; +with Stand; use Stand; +with Sinfo; use Sinfo; with Style; -with Targparm; use Targparm; -with Tbuild; use Tbuild; -with Uintp; use Uintp; +with Tbuild; use Tbuild; +with Uintp; use Uintp; package body Sem_Ch9 is @@ -782,7 +783,7 @@ package body Sem_Ch9 is for J in reverse 0 .. Scope_Stack.Last loop Task_Nam := Scope_Stack.Table (J).Entity; exit when Ekind (Etype (Task_Nam)) = E_Task_Type; - Kind := Ekind (Task_Nam); + Kind := Ekind (Task_Nam); if Kind /= E_Block and then Kind /= E_Loop and then not Is_Entry (Task_Nam) @@ -1191,10 +1192,17 @@ package body Sem_Ch9 is Entry_Name : Entity_Id; begin + -- An entry body "freezes" the contract of the nearest enclosing + -- package body. This ensures that any annotations referenced by the + -- contract of an entry or subprogram body declared within the current + -- protected body are available. + + Analyze_Enclosing_Package_Body_Contract (N); + Tasking_Used := True; -- Entry_Name is initialized to Any_Id. It should get reset to the - -- matching entry entity. An error is signalled if it is not reset + -- matching entry entity. An error is signalled if it is not reset. Entry_Name := Any_Id; @@ -1206,10 +1214,22 @@ package body Sem_Ch9 is Set_Ekind (Id, E_Entry); end if; - Set_Scope (Id, Current_Scope); Set_Etype (Id, Standard_Void_Type); + Set_Scope (Id, Current_Scope); Set_Accept_Address (Id, New_Elmt_List); + -- Set the SPARK_Mode from the current context (may be overwritten later + -- with an explicit pragma). + + Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Id); + + -- Analyze any aspect specifications that appear on the entry body + + if Has_Aspects (N) then + Analyze_Aspect_Specifications_On_Body_Or_Stub (N); + end if; + E := First_Entity (P_Type); while Present (E) loop if Chars (E) = Chars (Id) @@ -1218,7 +1238,7 @@ package body Sem_Ch9 is then Entry_Name := E; Set_Convention (Id, Convention (E)); - Set_Corresponding_Body (Parent (Entry_Name), Id); + Set_Corresponding_Body (Parent (E), Id); Check_Fully_Conformant (Id, E, N); if Ekind (Id) = E_Entry_Family then @@ -1312,7 +1332,7 @@ package body Sem_Ch9 is -- The entity for the protected subprogram corresponding to the entry -- has been created. We retain the name of this entity in the entry -- body, for use when the corresponding subprogram body is created. - -- Note that entry bodies have no corresponding_spec, and there is no + -- Note that entry bodies have no Corresponding_Spec, and there is no -- easy link back in the tree between the entry body and the entity for -- the entry itself, which is why we must propagate some attributes -- explicitly from spec to body. @@ -1334,11 +1354,22 @@ package body Sem_Ch9 is (Sloc (N), Entry_Name, P_Type, N, Decls); end if; + -- An entry body "freezes" the contract of its initial declaration. This + -- analysis depends on attribute Corresponding_Body being set. + + Analyze_Initial_Declaration_Contract (N); + if Present (Decls) then Analyze_Declarations (Decls); Inspect_Deferred_Constant_Completion (Decls); end if; + -- Process the contract of the subprogram body after all declarations + -- have been analyzed. This ensures that any contract-related pragmas + -- are available through the N_Contract node of the body. + + Analyze_Entry_Or_Subprogram_Body_Contract (Id); + if Present (Stats) then Analyze (Stats); end if; @@ -1602,6 +1633,15 @@ package body Sem_Ch9 is Set_Convention (Def_Id, Convention_Entry); Set_Accept_Address (Def_Id, New_Elmt_List); + -- Set the SPARK_Mode from the current context (may be overwritten later + -- with an explicit pragma). Task entries are excluded because they are + -- not completed by entry bodies. + + if Ekind (Current_Scope) = E_Protected_Type then + Set_SPARK_Pragma (Def_Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Def_Id); + end if; + -- Process formals if Present (Formals) then @@ -1731,29 +1771,19 @@ package body Sem_Ch9 is -- Start of processing for Analyze_Protected_Body begin + -- A protected body "freezes" the contract of the nearest enclosing + -- package body. This ensures that any annotations referenced by the + -- contract of an entry or subprogram body declared within the current + -- protected body are available. + + Analyze_Enclosing_Package_Body_Contract (N); + Tasking_Used := True; Set_Ekind (Body_Id, E_Protected_Body); + Set_Etype (Body_Id, Standard_Void_Type); Spec_Id := Find_Concurrent_Spec (Body_Id); - -- Protected bodies are currently removed by the expander. Since there - -- are no language-defined aspects that apply to a protected body, it is - -- not worth changing the whole expansion to accomodate implementation- - -- defined aspects. Plus we cannot possibly known the semantics of such - -- future implementation defined aspects in order to plan ahead. - - if Has_Aspects (N) then - Error_Msg_N - ("aspects on protected bodies are not allowed", - First (Aspect_Specifications (N))); - - -- Remove illegal aspects to prevent cascaded errors later on - - Remove_Aspects (N); - end if; - - if Present (Spec_Id) - and then Ekind (Spec_Id) = E_Protected_Type - then + if Present (Spec_Id) and then Ekind (Spec_Id) = E_Protected_Type then null; elsif Present (Spec_Id) @@ -1777,16 +1807,23 @@ package body Sem_Ch9 is Spec_Id := Etype (Spec_Id); end if; + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Body_Id); + end if; + Push_Scope (Spec_Id); Set_Corresponding_Spec (N, Spec_Id); Set_Corresponding_Body (Parent (Spec_Id), Body_Id); Set_Has_Completion (Spec_Id); Install_Declarations (Spec_Id); - Expand_Protected_Body_Declarations (N, Spec_Id); - Last_E := Last_Entity (Spec_Id); + -- A protected body "freezes" the contract of its initial declaration. + -- This analysis depends on attribute Corresponding_Spec being set. + + Analyze_Initial_Declaration_Contract (N); + Analyze_Declarations (Declarations (N)); -- For visibility purposes, all entities in the body are private. Set @@ -1968,6 +2005,15 @@ package body Sem_Ch9 is Set_Etype (T, T); Set_Has_Delayed_Freeze (T, True); Set_Stored_Constraint (T, No_Elist); + + -- Set the SPARK_Mode from the current context (may be overwritten later + -- with an explicit pragma). + + Set_SPARK_Pragma (T, SPARK_Mode_Pragma); + Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (T); + Set_SPARK_Aux_Pragma_Inherited (T); + Push_Scope (T); if Ada_Version >= Ada_2005 then @@ -2075,20 +2121,23 @@ package body Sem_Ch9 is or else From_Aspect_Specification (Prio_Item) then Error_Msg_Name_1 := Chars (Identifier (Prio_Item)); - Error_Msg_NE ("aspect% for & has no effect when Lock_Free" & - " given??", Prio_Item, Id); + Error_Msg_NE + ("aspect% for & has no effect when Lock_Free given??", + Prio_Item, Id); -- Pragma case else Error_Msg_Name_1 := Pragma_Name (Prio_Item); - Error_Msg_NE ("pragma% for & has no effect when Lock_Free" & - " given??", Prio_Item, Id); + Error_Msg_NE + ("pragma% for & has no effect when Lock_Free given??", + Prio_Item, Id); end if; end if; end; - if not Allows_Lock_Free_Implementation (N, True) then + if not Allows_Lock_Free_Implementation (N, Lock_Free_Given => True) + then return; end if; end if; @@ -2112,16 +2161,18 @@ package body Sem_Ch9 is or else From_Aspect_Specification (Prio_Item)) and then Chars (Identifier (Prio_Item)) = Name_Priority then - Error_Msg_N ("aspect Interrupt_Priority is preferred " - & "in presence of handlers??", Prio_Item); + Error_Msg_N + ("aspect Interrupt_Priority is preferred in presence of " + & "handlers??", Prio_Item); -- Pragma case elsif Nkind (Prio_Item) = N_Pragma and then Pragma_Name (Prio_Item) = Name_Priority then - Error_Msg_N ("pragma Interrupt_Priority is preferred " - & "in presence of handlers??", Prio_Item); + Error_Msg_N + ("pragma Interrupt_Priority is preferred in presence of " + & "handlers??", Prio_Item); end if; end if; end; @@ -2367,12 +2418,6 @@ package body Sem_Ch9 is Generate_Reference (Entry_Id, Entry_Name); if Present (First_Formal (Entry_Id)) then - if VM_Target = JVM_Target then - Error_Msg_N - ("arguments unsupported in requeue statement", - First_Formal (Entry_Id)); - return; - end if; -- Ada 2012 (AI05-0030): Perform type conformance after skipping -- the first parameter of Entry_Id since it is the interface @@ -2581,49 +2626,75 @@ package body Sem_Ch9 is ------------------------------------------ procedure Analyze_Single_Protected_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Id : constant Node_Id := Defining_Identifier (N); - T : Entity_Id; - T_Decl : Node_Id; - O_Decl : Node_Id; - O_Name : constant Entity_Id := Id; + Loc : constant Source_Ptr := Sloc (N); + Obj_Id : constant Node_Id := Defining_Identifier (N); + Obj_Decl : Node_Id; + Typ : Entity_Id; begin - Generate_Definition (Id); + Generate_Definition (Obj_Id); Tasking_Used := True; - -- The node is rewritten as a protected type declaration, in exact - -- analogy with what is done with single tasks. + -- A single protected declaration is transformed into a pair of an + -- anonymous protected type and an object of that type. Generate: + + -- protected type Typ is ...; - T := - Make_Defining_Identifier (Sloc (Id), - New_External_Name (Chars (Id), 'T')); + Typ := + Make_Defining_Identifier (Sloc (Obj_Id), + Chars => New_External_Name (Chars (Obj_Id), 'T')); - T_Decl := + Rewrite (N, Make_Protected_Type_Declaration (Loc, - Defining_Identifier => T, + Defining_Identifier => Typ, Protected_Definition => Relocate_Node (Protected_Definition (N)), - Interface_List => Interface_List (N)); + Interface_List => Interface_List (N))); + + -- Use the original defining identifier of the single protected + -- declaration in the generated object declaration to allow for debug + -- information to be attached to it when compiling with -gnatD. The + -- parent of the entity is the new object declaration. The single + -- protected declaration is not used in semantics or code generation, + -- but is scanned when generating debug information, and therefore needs + -- the updated Sloc information from the entity (see Sprint). Generate: - O_Decl := + -- Obj : Typ; + + Obj_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => O_Name, - Object_Definition => Make_Identifier (Loc, Chars (T))); + Defining_Identifier => Obj_Id, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Insert_After (N, Obj_Decl); + Mark_Rewrite_Insertion (Obj_Decl); + + -- Relocate aspect Part_Of from the the original single protected + -- declaration to the anonymous object declaration. This emulates the + -- placement of an equivalent source pragma. + + Move_Or_Merge_Aspects (N, To => Obj_Decl); + + -- Relocate pragma Part_Of from the visible declarations of the original + -- single protected declaration to the anonymous object declaration. The + -- new placement better reflects the role of the pragma. - Rewrite (N, T_Decl); - Insert_After (N, O_Decl); - Mark_Rewrite_Insertion (O_Decl); + Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); - -- Enter names of type and object before analysis, because the name of - -- the object may be used in its own body. + -- Enter the names of the anonymous protected type and the object before + -- analysis takes places, because the name of the object may be used in + -- its own body. - Enter_Name (T); - Set_Ekind (T, E_Protected_Type); - Set_Etype (T, T); + Enter_Name (Typ); + Set_Ekind (Typ, E_Protected_Type); + Set_Etype (Typ, Typ); + Set_Anonymous_Object (Typ, Obj_Id); - Enter_Name (O_Name); - Set_Ekind (O_Name, E_Variable); - Set_Etype (O_Name, T); + Enter_Name (Obj_Id); + Set_Ekind (Obj_Id, E_Variable); + Set_Etype (Obj_Id, Typ); + Set_Part_Of_Constituents (Obj_Id, New_Elmt_List); + Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Obj_Id); -- Instead of calling Analyze on the new node, call the proper analysis -- procedure directly. Otherwise the node would be expanded twice, with @@ -2632,7 +2703,7 @@ package body Sem_Ch9 is Analyze_Protected_Type_Declaration (N); if Has_Aspects (N) then - Analyze_Aspect_Specifications (N, Id); + Analyze_Aspect_Specifications (N, Obj_Id); end if; end Analyze_Single_Protected_Declaration; @@ -2641,58 +2712,76 @@ package body Sem_Ch9 is ------------------------------------- procedure Analyze_Single_Task_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Id : constant Node_Id := Defining_Identifier (N); - T : Entity_Id; - T_Decl : Node_Id; - O_Decl : Node_Id; - O_Name : constant Entity_Id := Id; + Loc : constant Source_Ptr := Sloc (N); + Obj_Id : constant Node_Id := Defining_Identifier (N); + Obj_Decl : Node_Id; + Typ : Entity_Id; begin - Generate_Definition (Id); + Generate_Definition (Obj_Id); Tasking_Used := True; - -- The node is rewritten as a task type declaration, followed by an - -- object declaration of that anonymous task type. + -- A single task declaration is transformed into a pait of an anonymous + -- task type and an object of that type. Generate: + + -- task type Typ is ...; - T := - Make_Defining_Identifier (Sloc (Id), - New_External_Name (Chars (Id), Suffix => "TK")); + Typ := + Make_Defining_Identifier (Sloc (Obj_Id), + Chars => New_External_Name (Chars (Obj_Id), Suffix => "TK")); - T_Decl := + Rewrite (N, Make_Task_Type_Declaration (Loc, - Defining_Identifier => T, + Defining_Identifier => Typ, Task_Definition => Relocate_Node (Task_Definition (N)), - Interface_List => Interface_List (N)); - - -- We use the original defining identifier of the single task in the - -- generated object declaration, so that debugging information can - -- be attached to it when compiling with -gnatD. The parent of the - -- entity is the new object declaration. The single_task_declaration - -- is not used further in semantics or code generation, but is scanned - -- when generating debug information, and therefore needs the updated - -- Sloc information for the entity (see Sprint). Aspect specifications - -- are moved from the single task node to the object declaration node. - - O_Decl := + Interface_List => Interface_List (N))); + + -- Use the original defining identifier of the single task declaration + -- in the generated object declaration to allow for debug information + -- to be attached to it when compiling with -gnatD. The parent of the + -- entity is the new object declaration. The single task declaration + -- is not used in semantics or code generation, but is scanned when + -- generating debug information, and therefore needs the updated Sloc + -- information from the entity (see Sprint). Generate: + + -- Obj : Typ; + + Obj_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => O_Name, - Object_Definition => Make_Identifier (Loc, Chars (T))); + Defining_Identifier => Obj_Id, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Insert_After (N, Obj_Decl); + Mark_Rewrite_Insertion (Obj_Decl); - Rewrite (N, T_Decl); - Insert_After (N, O_Decl); - Mark_Rewrite_Insertion (O_Decl); + -- Relocate aspects Depends, Global and Part_Of from the original single + -- task declaration to the anonymous object declaration. This emulates + -- the placement of an equivalent source pragma. - -- Enter names of type and object before analysis, because the name of - -- the object may be used in its own body. + Move_Or_Merge_Aspects (N, To => Obj_Decl); - Enter_Name (T); - Set_Ekind (T, E_Task_Type); - Set_Etype (T, T); + -- Relocate pragmas Depends, Global and Part_Of from the visible + -- declarations of the original single protected declaration to the + -- anonymous object declaration. The new placement better reflects the + -- role of the pragmas. - Enter_Name (O_Name); - Set_Ekind (O_Name, E_Variable); - Set_Etype (O_Name, T); + Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); + + -- Enter the names of the anonymous task type and the object before + -- analysis takes places, because the name of the object may be used + -- in its own body. + + Enter_Name (Typ); + Set_Ekind (Typ, E_Task_Type); + Set_Etype (Typ, Typ); + Set_Anonymous_Object (Typ, Obj_Id); + + Enter_Name (Obj_Id); + Set_Ekind (Obj_Id, E_Variable); + Set_Etype (Obj_Id, Typ); + Set_Part_Of_Constituents (Obj_Id, New_Elmt_List); + Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Obj_Id); -- Instead of calling Analyze on the new node, call the proper analysis -- procedure directly. Otherwise the node would be expanded twice, with @@ -2701,7 +2790,7 @@ package body Sem_Ch9 is Analyze_Task_Type_Declaration (N); if Has_Aspects (N) then - Analyze_Aspect_Specifications (N, Id); + Analyze_Aspect_Specifications (N, Obj_Id); end if; end Analyze_Single_Task_Declaration; @@ -2726,33 +2815,23 @@ package body Sem_Ch9 is -- a single task, since Spec_Id is set to the task type). begin + -- A task body "freezes" the contract of the nearest enclosing package + -- body. This ensures that annotations referenced by the contract of an + -- entry or subprogram body declared within the current protected body + -- are available. + + Analyze_Enclosing_Package_Body_Contract (N); + Tasking_Used := True; - Set_Ekind (Body_Id, E_Task_Body); Set_Scope (Body_Id, Current_Scope); + Set_Ekind (Body_Id, E_Task_Body); + Set_Etype (Body_Id, Standard_Void_Type); Spec_Id := Find_Concurrent_Spec (Body_Id); - -- Task bodies are transformed into a subprogram spec and body pair by - -- the expander. Since there are no language-defined aspects that apply - -- to a task body, it is not worth changing the whole expansion to - -- accomodate implementation-defined aspects. Plus we cannot possibly - -- know semantics of such aspects in order to plan ahead. - - if Has_Aspects (N) then - Error_Msg_N - ("aspects on task bodies are not allowed", - First (Aspect_Specifications (N))); - - -- Remove illegal aspects to prevent cascaded errors later on - - Remove_Aspects (N); - end if; - -- The spec is either a task type declaration, or a single task -- declaration for which we have created an anonymous type. - if Present (Spec_Id) - and then Ekind (Spec_Id) = E_Task_Type - then + if Present (Spec_Id) and then Ekind (Spec_Id) = E_Task_Type then null; elsif Present (Spec_Id) @@ -2786,6 +2865,16 @@ package body Sem_Ch9 is Spec_Id := Etype (Spec_Id); end if; + -- Set the SPARK_Mode from the current context (may be overwritten later + -- with an explicit pragma). + + Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Body_Id); + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Body_Id); + end if; + Push_Scope (Spec_Id); Set_Corresponding_Spec (N, Spec_Id); Set_Corresponding_Body (Parent (Spec_Id), Body_Id); @@ -2793,6 +2882,11 @@ package body Sem_Ch9 is Install_Declarations (Spec_Id); Last_E := Last_Entity (Spec_Id); + -- A task body "freezes" the contract of its initial declaration. This + -- analysis depends on attribute Corresponding_Spec being set. + + Analyze_Initial_Declaration_Contract (N); + Analyze_Declarations (Decls); Inspect_Deferred_Constant_Completion (Decls); @@ -2946,6 +3040,15 @@ package body Sem_Ch9 is Set_Etype (T, T); Set_Has_Delayed_Freeze (T, True); Set_Stored_Constraint (T, No_Elist); + + -- Set the SPARK_Mode from the current context (may be overwritten later + -- with an explicit pragma). + + Set_SPARK_Pragma (T, SPARK_Mode_Pragma); + Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (T); + Set_SPARK_Aux_Pragma_Inherited (T); + Push_Scope (T); if Ada_Version >= Ada_2005 then @@ -3459,4 +3562,5 @@ package body Sem_Ch9 is Next_Entity (E); end loop; end Install_Declarations; + end Sem_Ch9; diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index ebacba9f965..1706f5e96cc 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -194,6 +194,7 @@ package body Sem_Dim is OK_For_Dimension : constant array (Node_Kind) of Boolean := (N_Attribute_Reference => True, N_Expanded_Name => True, + N_Explicit_Dereference => True, N_Defining_Identifier => True, N_Function_Call => True, N_Identifier => True, @@ -1135,6 +1136,7 @@ package body Sem_Dim is when N_Attribute_Reference | N_Expanded_Name | + N_Explicit_Dereference | N_Function_Call | N_Identifier | N_Indexed_Component | @@ -1815,10 +1817,15 @@ package body Sem_Dim is if Has_Dimension_System (Base_Type (Comp_Typ)) then Expr := Expression (Comp); + -- A box-initialized component needs no checking. + + if No (Expr) and then Box_Present (Comp) then + null; + -- Issue an error if the dimensions of the component type and the -- dimensions of the component mismatch. - if Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then + elsif Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then -- Check if an error has already been encountered so far @@ -2093,7 +2100,6 @@ package body Sem_Dim is procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is Expr : constant Node_Id := Expression (N); - Dims_Of_Expr : constant Dimension_Type := Dimensions_Of (Expr); Return_Ent : constant Entity_Id := Return_Statement_Entity (N); Return_Etyp : constant Entity_Id := Etype (Return_Applies_To (Return_Ent)); @@ -2126,7 +2132,7 @@ package body Sem_Dim is -- Start of processing for Analyze_Dimension_Simple_Return_Statement begin - if Dims_Of_Return_Etyp /= Dims_Of_Expr then + if Dims_Of_Return_Etyp /= Dimensions_Of (Expr) then Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr); Remove_Dimensions (Expr); end if; @@ -2657,11 +2663,12 @@ package body Sem_Dim is -- Expand_Put_Call_With_Symbol -- --------------------------------- - -- For procedure Put (resp. Put_Dim_Of) defined in System.Dim.Float_IO - -- (System.Dim.Integer_IO), the default string parameter must be rewritten - -- to include the unit symbols (resp. dimension symbols) in the output - -- of a dimensioned object. Note that if a value is already supplied for - -- parameter Symbol, this routine doesn't do anything. + -- For procedure Put (resp. Put_Dim_Of) and function Image, defined in + -- System.Dim.Float_IO or System.Dim.Integer_IO, the default string + -- parameter is rewritten to include the unit symbol (or the dimension + -- symbols if not a defined quantity) in the output of a dimensioned + -- object. If a value is already supplied by the user for the parameter + -- Symbol, it is used as is. -- Case 1. Item is dimensionless @@ -2707,6 +2714,9 @@ package body Sem_Dim is -- $5.0 m**3.cd**(-1) -- $[l**3.J**(-1)] + -- The function Image returns the string identical to that produced by + -- a call to Put whose first parameter is a string. + procedure Expand_Put_Call_With_Symbol (N : Node_Id) is Actuals : constant List_Id := Parameter_Associations (N); Loc : constant Source_Ptr := Sloc (N); @@ -2772,22 +2782,12 @@ package body Sem_Dim is if Present (Actual_Str) then -- Return True if the actual comes from source or if the string - -- of symbols doesn't have the default value (i.e. it is ""). + -- of symbols doesn't have the default value (i.e. it is ""), + -- in which case it is used as suffix of the generated string. if Comes_From_Source (Actual) or else String_Length (Strval (Actual_Str)) /= 0 then - -- Complain only if the actual comes from source or if it - -- hasn't been fully analyzed yet. - - if Comes_From_Source (Actual) - or else not Analyzed (Actual) - then - Error_Msg_N ("Symbol parameter should not be provided", - Actual); - Error_Msg_N ("\reserved for compiler use only", Actual); - end if; - return True; else @@ -2840,7 +2840,9 @@ package body Sem_Dim is Is_Put_Dim_Of := True; return True; - elsif Chars (Ent) = Name_Put then + elsif Chars (Ent) = Name_Put + or else Chars (Ent) = Name_Image + then return True; end if; end if; @@ -2975,12 +2977,20 @@ package body Sem_Dim is -- Rewrite and analyze the procedure call - Rewrite (N, - Make_Procedure_Call_Statement (Loc, - Name => New_Copy (Name_Call), - Parameter_Associations => New_Actuals)); + if Chars (Name_Call) = Name_Image then + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Copy (Name_Call), + Parameter_Associations => New_Actuals)); + Analyze_And_Resolve (N); + else + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Copy (Name_Call), + Parameter_Associations => New_Actuals)); + Analyze (N); + end if; - Analyze (N); end if; end if; end Expand_Put_Call_With_Symbol; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index d61976e7cbe..d2396a37465 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -50,7 +50,6 @@ with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Snames; use Snames; with Sinfo; use Sinfo; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -317,6 +316,18 @@ package body Sem_Disp is Tagged_Type := Base_Type (T); end if; + -- If the type is incomplete, it may have been declared without a + -- Tagged indication, but the full view may be tagged, in which case + -- that is the controlling type of the subprogram. This is one of the + -- approx. 579 places in the language where a lookahead would help. + + elsif Ekind (T) = E_Incomplete_Type + and then Present (Full_View (T)) + and then Is_Tagged_Type (Full_View (T)) + then + Set_Is_Tagged_Type (T); + Tagged_Type := Full_View (T); + elsif Ekind (T) = E_Anonymous_Access_Type and then Is_Tagged_Type (Designated_Type (T)) then @@ -596,14 +607,17 @@ package body Sem_Disp is and then Is_Entity_Name (Name (Par)) then declare + Enc_Subp : constant Entity_Id := Entity (Name (Par)); A : Node_Id; F : Entity_Id; begin - -- Find formal for which call is the actual. + -- Find formal for which call is the actual, and is + -- a controlling argument. - F := First_Formal (Entity (Name (Par))); + F := First_Formal (Enc_Subp); A := First_Actual (Par); + while Present (F) loop if Is_Controlling_Formal (F) and then (N = A or else Parent (N) = A) @@ -698,11 +712,11 @@ package body Sem_Disp is -- If the call doesn't have a controlling actual but does have an -- indeterminate actual that requires dispatching treatment, then an -- object is needed that will serve as the controlling argument for - -- a dispatching call on the indeterminate actual. This can only - -- occur in the unusual situation of a default actual given by - -- a tag-indeterminate call and where the type of the call is an - -- ancestor of the type associated with a containing call to an - -- inherited operation (see AI-239). + -- a dispatching call on the indeterminate actual. This can occur + -- in the unusual situation of a default actual given by a tag- + -- indeterminate call and where the type of the call is an ancestor + -- of the type associated with a containing call to an inherited + -- operation (see AI-239). -- Rather than create an object of the tagged type, which would -- be problematic for various reasons (default initialization, @@ -850,6 +864,7 @@ package body Sem_Disp is end if; else + -- If dispatching on result, the enclosing call, if any, will -- determine the controlling argument. Otherwise this is the -- primitive operation of the root type. @@ -1148,7 +1163,7 @@ package body Sem_Disp is -- No code required to register primitives in VM -- targets - elsif VM_Target /= No_VM then + elsif not Tagged_Type_Expansion then null; else @@ -1309,7 +1324,7 @@ package body Sem_Disp is and then Present (Interface_Alias (Prim)) and then Alias (Prim) = Subp and then not Building_Static_DT (Tagged_Type) - and then VM_Target = No_VM + and then Tagged_Type_Expansion then Insert_Actions_After (Subp_Body, Register_Primitive (Sloc (Subp_Body), Prim => Prim)); @@ -2546,7 +2561,7 @@ package body Sem_Disp is Next_Actual (Arg); end loop; - -- Expansion of dispatching calls is suppressed when VM_Target, because + -- Expansion of dispatching calls is suppressed on VM targets, because -- the VM back-ends directly handle the generation of dispatching calls -- and would have to undo any expansion to an indirect call. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 01fd0cd969e..7f3b42a8530 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -548,6 +548,12 @@ package body Sem_Elab is if Msg_D /= "" and then Elab_Warnings then Error_Msg_NE (Msg_D, N, Ent); end if; + + -- In the access case emit first warning message as well, + -- otherwise list of calls will appear as errors. + + elsif Elab_Warnings then + Error_Msg_NE (Msg_S, N, Ent); end if; -- Static elaboration checks, info message @@ -561,9 +567,29 @@ package body Sem_Elab is -- Local variables - Loc : constant Source_Ptr := Sloc (N); - Ent : Entity_Id; - Decl : Node_Id; + Loc : constant Source_Ptr := Sloc (N); + + Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; + -- Indicates if we have instantiation case + + Ent : Entity_Id; + Callee_Unit_Internal : Boolean; + Caller_Unit_Internal : Boolean; + Decl : Node_Id; + Inst_Callee : Source_Ptr; + Inst_Caller : Source_Ptr; + Unit_Callee : Unit_Number_Type; + Unit_Caller : Unit_Number_Type; + + Body_Acts_As_Spec : Boolean; + -- Set to true if call is to body acting as spec (no separate spec) + + Cunit_SC : Boolean := False; + -- Set to suppress dynamic elaboration checks where one of the + -- enclosing scopes has Elaboration_Checks_Suppressed set, or else + -- if a pragma Elaborate[_All] applies to that scope, in which case + -- warnings on the scope are also suppressed. For the internal case, + -- we ignore this flag. E_Scope : Entity_Id; -- Top level scope of entity for called subprogram. This value includes @@ -571,6 +597,9 @@ package body Sem_Elab is -- non-visible unit. This is the scope that is to be investigated to -- see whether an elaboration check is required. + Issue_In_SPARK : Boolean; + -- Flag set when a source entity is called during elaboration in SPARK + W_Scope : Entity_Id; -- Top level scope of directly called entity for subprogram. This -- differs from E_Scope in the case where renamings or derivations @@ -583,28 +612,6 @@ package body Sem_Elab is -- on this intermediate package. These special cases are handled in -- Set_Elaboration_Constraint. - Body_Acts_As_Spec : Boolean; - -- Set to true if call is to body acting as spec (no separate spec) - - Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; - -- Indicates if we have instantiation case - - Caller_Unit_Internal : Boolean; - Callee_Unit_Internal : Boolean; - - Inst_Caller : Source_Ptr; - Inst_Callee : Source_Ptr; - - Unit_Caller : Unit_Number_Type; - Unit_Callee : Unit_Number_Type; - - Cunit_SC : Boolean := False; - -- Set to suppress dynamic elaboration checks where one of the - -- enclosing scopes has Elaboration_Checks_Suppressed set, or else - -- if a pragma Elaborate[_All] applies to that scope, in which case - -- warnings on the scope are also suppressed. For the internal case, - -- we ignore this flag. - -- Start of processing for Check_A_Call begin @@ -746,9 +753,7 @@ package body Sem_Elab is declare Ent : constant Entity_Id := Get_Referenced_Ent (N); begin - if Is_Init_Proc (Ent) - and then not In_Same_Extended_Unit (N, Ent) - then + if Is_Init_Proc (Ent) and then not In_Same_Extended_Unit (N, Ent) then W_Scope := Scope (Ent); else W_Scope := E; @@ -961,6 +966,8 @@ package body Sem_Elab is return; end if; + Issue_In_SPARK := SPARK_Mode = On and Comes_From_Source (Ent); + -- Now check if an Elaborate_All (or dynamic check) is needed if not Suppress_Elaboration_Warnings (Ent) @@ -974,10 +981,9 @@ package body Sem_Elab is -- Instantiation case if Inst_Case then - if SPARK_Mode = On then + if Issue_In_SPARK then Error_Msg_NE ("instantiation of & during elaboration in SPARK", N, Ent); - else Elab_Warning ("instantiation of & may raise Program_Error?l?", @@ -993,7 +999,7 @@ package body Sem_Elab is -- Variable reference in SPARK mode - elsif Variable_Case then + elsif Variable_Case and Issue_In_SPARK then Error_Msg_NE ("reference to & during elaboration in SPARK", N, Ent); @@ -1009,7 +1015,7 @@ package body Sem_Elab is "info: implicit call to & during elaboration?$?", Ent); - elsif SPARK_Mode = On then + elsif Issue_In_SPARK then Error_Msg_NE ("call to & during elaboration in SPARK", N, Ent); else @@ -1025,7 +1031,7 @@ package body Sem_Elab is -- Case of Elaborate_All not present and required, for SPARK this -- is an error, so give an error message. - if SPARK_Mode = On then + if Issue_In_SPARK then Error_Msg_NE ("\Elaborate_All pragma required for&", N, W_Scope); -- Otherwise we generate an implicit pragma. For a subprogram @@ -1506,7 +1512,9 @@ package body Sem_Elab is or else Elaboration_Checks_Suppressed (Ent) or else Elaboration_Checks_Suppressed (Scope (Ent)) then - Set_No_Elaboration_Check (N); + if Nkind (N) in N_Subprogram_Call then + Set_No_Elaboration_Check (N); + end if; end if; return; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index d8a4f3e4cca..3f7e97b1ef1 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -52,7 +52,6 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with Targparm; use Targparm; with Tbuild; use Tbuild; package body Sem_Eval is @@ -815,7 +814,7 @@ package body Sem_Eval is V := UI_Negate (Intval (Right_Opnd (N))); return; - elsif Nkind (N) = N_Attribute_Reference then + elsif Nkind (N) = N_Attribute_Reference then if Attribute_Name (N) = Name_Succ then R := First (Expressions (N)); V := Uint_1; @@ -2221,7 +2220,7 @@ package body Sem_Eval is -- case of a concatenation of a series of string literals. if Nkind (Left_Str) = N_String_Literal then - Left_Len := String_Length (Strval (Left_Str)); + Left_Len := String_Length (Strval (Left_Str)); -- If the left operand is the empty string, and the right operand -- is a string literal (the case of "" & "..."), the result is the @@ -2910,7 +2909,7 @@ package body Sem_Eval is -- Eval_Op_Not -- ----------------- - -- The not operation is a static functions, so the result is potentially + -- The not operation is a static functions, so the result is potentially -- static if the operand is potentially static (RM 4.9(7), 4.9(20)). procedure Eval_Op_Not (N : Node_Id) is @@ -3762,9 +3761,6 @@ package body Sem_Eval is Source_Type : constant Entity_Id := Etype (Operand); Target_Type : constant Entity_Id := Etype (N); - Stat : Boolean; - Fold : Boolean; - function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean; -- Returns true if type T is an integer type, or if it is a fixed-point -- type to be treated as an integer (i.e. the flag Conversion_OK is set @@ -3797,6 +3793,11 @@ package body Sem_Eval is or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N)); end To_Be_Treated_As_Real; + -- Local variables + + Fold : Boolean; + Stat : Boolean; + -- Start of processing for Eval_Type_Conversion begin @@ -5409,13 +5410,14 @@ package body Sem_Eval is -- First deal with special case of inherited predicate, where the -- predicate expression looks like: - -- Expr and then xxPredicate (typ (Ent)) + -- xxPredicate (typ (Ent)) and then Expr -- where Expr is the predicate expression for this level, and the - -- right operand is the call to evaluate the inherited predicate. + -- left operand is the call to evaluate the inherited predicate. if Nkind (Expr) = N_And_Then - and then Nkind (Right_Opnd (Expr)) = N_Function_Call + and then Nkind (Left_Opnd (Expr)) = N_Function_Call + and then Is_Predicate_Function (Entity (Name (Left_Opnd (Expr)))) then -- OK we have the inherited case, so make a call to evaluate the -- inherited predicate. If that fails, so do we! @@ -5423,19 +5425,19 @@ package body Sem_Eval is if not Real_Or_String_Static_Predicate_Matches (Val => Val, - Typ => Etype (First_Formal (Entity (Name (Right_Opnd (Expr)))))) + Typ => Etype (First_Formal (Entity (Name (Left_Opnd (Expr)))))) then return False; end if; - -- Use the left operand for the continued processing + -- Use the right operand for the continued processing - Copy := Copy_Separate_Tree (Left_Opnd (Expr)); + Copy := Copy_Separate_Tree (Right_Opnd (Expr)); -- Case where call to predicate function appears on its own (this means -- that the predicate at this level is just inherited from the parent). - elsif Nkind (Expr) = N_Function_Call then + elsif Nkind (Expr) = N_Function_Call then declare Typ : constant Entity_Id := Etype (First_Formal (Entity (Name (Expr)))); @@ -6238,12 +6240,6 @@ package body Sem_Eval is and then Is_Known_Valid (Typ) and then Esize (Etype (N)) <= Esize (Typ) and then not Has_Biased_Representation (Etype (N)) - - -- This check cannot be disabled under VM targets because in some - -- unusual cases the backend of the native compiler raises a run-time - -- exception but the virtual machines do not raise any exception. - - and then VM_Target = No_VM then return In_Range; diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb index 2347bff46a0..cfe9f9536c1 100644 --- a/gcc/ada/sem_mech.adb +++ b/gcc/ada/sem_mech.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -181,13 +181,11 @@ package body Sem_Mech is -- C -- ------- - -- Note: Assembler, C++, Java, Stdcall also use C conventions + -- Note: Assembler, C++, Stdcall also use C conventions when Convention_Assembler | Convention_C | - Convention_CIL | Convention_CPP | - Convention_Java | Convention_Stdcall => -- The following values are passed by copy diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c3f7618bb9b..0e4d30d2509 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -29,62 +29,63 @@ -- to complete the syntax checks. Certain pragmas are handled partially or -- completely by the parser (see Par.Prag for further details). -with Aspects; use Aspects; -with Atree; use Atree; -with Casing; use Casing; -with Checks; use Checks; -with Csets; use Csets; -with Debug; use Debug; -with Einfo; use Einfo; -with Elists; use Elists; -with Errout; use Errout; -with Exp_Dist; use Exp_Dist; -with Exp_Util; use Exp_Util; -with Freeze; use Freeze; -with Ghost; use Ghost; -with Lib; use Lib; -with Lib.Writ; use Lib.Writ; -with Lib.Xref; use Lib.Xref; -with Namet.Sp; use Namet.Sp; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Output; use Output; -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_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch12; use Sem_Ch12; -with Sem_Ch13; use Sem_Ch13; -with Sem_Disp; use Sem_Disp; -with Sem_Dist; use Sem_Dist; -with Sem_Elim; use Sem_Elim; -with Sem_Eval; use Sem_Eval; -with Sem_Intr; use Sem_Intr; -with Sem_Mech; use Sem_Mech; -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 Stand; use Stand; -with Sinfo; use Sinfo; -with Sinfo.CN; use Sinfo.CN; -with Sinput; use Sinput; -with Stringt; use Stringt; -with Stylesw; use Stylesw; +with Aspects; use Aspects; +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Contracts; use Contracts; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Dist; use Exp_Dist; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Ghost; use Ghost; +with Lib; use Lib; +with Lib.Writ; use Lib.Writ; +with Lib.Xref; use Lib.Xref; +with Namet.Sp; use Namet.Sp; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Output; use Output; +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_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Intr; use Sem_Intr; +with Sem_Mech; use Sem_Mech; +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 Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Sinput; use Sinput; +with Stringt; use Stringt; +with Stylesw; use Stylesw; with Table; -with Targparm; use Targparm; -with Tbuild; use Tbuild; +with Targparm; use Targparm; +with Tbuild; use Tbuild; with Ttypes; -with Uintp; use Uintp; -with Uname; use Uname; -with Urealp; use Urealp; -with Validsw; use Validsw; -with Warnsw; use Warnsw; +with Uintp; use Uintp; +with Uname; use Uname; +with Urealp; use Urealp; +with Validsw; use Validsw; +with Warnsw; use Warnsw; package body Sem_Prag is @@ -165,11 +166,6 @@ package body Sem_Prag is -- Local Subprograms and Variables -- ------------------------------------- - procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id); - -- Subsidiary routine to the analysis of pragmas Depends, Global and - -- Refined_State. Append an entity to a list. If the list is empty, create - -- a new list. - function Adjust_External_Name_Case (N : Node_Id) return Node_Id; -- This routine is used for possible casing adjustment of an explicit -- external name supplied as a string literal (the node N), according to @@ -178,6 +174,19 @@ package body Sem_Prag is -- to Uppercase or Lowercase, then a new string literal with appropriate -- casing is constructed. + procedure Analyze_Part_Of + (Indic : Node_Id; + Item_Id : Entity_Id; + Encap : Node_Id; + Encap_Id : out Entity_Id; + Legal : out Boolean); + -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and + -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the + -- Part_Of indicator. Item_Id is the entity of an abstract state, object or + -- package instantiation. Encap denotes the encapsulating state or single + -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when + -- the indicator is legal. + function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean; -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends. -- Query whether a particular item appears in a mixed list of nodes and @@ -200,9 +209,18 @@ package body Sem_Prag is -- context denoted by Context. If this is the case, emit an error. procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id); - -- Subsidiary to routines Find_Related_Package_Or_Body and - -- Find_Related_Subprogram_Or_Body. Emit an error on pragma Prag that - -- duplicates previous pragma Prev. + -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma + -- Prag that duplicates previous pragma Prev. + + function Find_Related_Context + (Prag : Node_Id; + Do_Checks : Boolean := False) return Node_Id; + -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers, + -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and + -- Part_Of. Find the first source declaration or statement found while + -- traversing the previous node chain starting from pragma Prag. If flag + -- Do_Checks is set, the routine reports duplicate pragmas. The routine + -- returns Empty when reaching the start of the node chain. function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; -- If Def_Id refers to a renamed subprogram, then the base subprogram (the @@ -219,6 +237,11 @@ package body Sem_Prag is -- Determine whether dependency clause Clause is surrounded by extra -- parentheses. If this is the case, issue an error message. + function Is_CCT_Instance (Ref : Node_Id) return Boolean; + -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_] + -- Global. Determine whether reference Ref denotes the current instance of + -- a concurrent type. + function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean; -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of -- pragma Depends. Determine whether the type of dependency item Item is @@ -268,15 +291,6 @@ package body Sem_Prag is -- pragma in the source program, a breakpoint on rv catches this place in -- the source, allowing convenient stepping to the point of interest. - -------------- - -- Add_Item -- - -------------- - - procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is - begin - Append_New_Elmt (Item, To => To_List); - end Add_Item; - ------------------------------- -- Adjust_External_Name_Case -- ------------------------------- @@ -390,25 +404,30 @@ package body Sem_Prag is -- Local variables - GM : constant Ghost_Mode_Type := Ghost_Mode; - - Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N); - Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl); + Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + CCase : Node_Id; Restore_Scope : Boolean := False; -- Start of processing for Analyze_Contract_Cases_In_Decl_Part begin + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; + -- Set the Ghost mode in effect from the pragma. Due to the delayed -- analysis of the pragma, the Ghost mode at point of declaration and -- point of analysis may not necessarely be the same. Use the mode in -- effect at the point of declaration. Set_Ghost_Mode (N); - Set_Analyzed (N); -- Single and multiple contract cases must appear in aggregate form. If -- this is not the case, then either the parser of the analysis of the @@ -454,10 +473,8 @@ package body Sem_Prag is Error_Msg_N ("wrong syntax for constract cases", N); end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; + Set_Is_Analyzed_Pragma (N); end Analyze_Contract_Cases_In_Decl_Part; ---------------------------------- @@ -466,8 +483,8 @@ package body Sem_Prag is procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N); - Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl); + Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); All_Inputs_Seen : Elist_Id := No_Elist; -- A list containing the entities of all the inputs processed so far. @@ -508,11 +525,15 @@ package body Sem_Prag is -- to the name buffer. The individual kinds are as follows: -- E_Abstract_State - "state" -- E_Constant - "constant" + -- E_Discriminant - "discriminant" -- E_Generic_In_Out_Parameter - "generic parameter" - -- E_Generic_Out_Parameter - "generic parameter" + -- E_Generic_In_Parameter - "generic parameter" -- E_In_Parameter - "parameter" -- E_In_Out_Parameter - "parameter" + -- E_Loop_Parameter - "loop parameter" -- E_Out_Parameter - "parameter" + -- E_Protected_Type - "current instance of protected type" + -- E_Task_Type - "current instance of task type" -- E_Variable - "global" procedure Analyze_Dependency_Clause @@ -559,6 +580,9 @@ package body Sem_Prag is elsif Ekind (Item_Id) = E_Constant then Add_Str_To_Name_Buffer ("constant"); + elsif Ekind (Item_Id) = E_Discriminant then + Add_Str_To_Name_Buffer ("discriminant"); + elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter, E_Generic_In_Parameter) then @@ -567,6 +591,15 @@ package body Sem_Prag is elsif Is_Formal (Item_Id) then Add_Str_To_Name_Buffer ("parameter"); + elsif Ekind (Item_Id) = E_Loop_Parameter then + Add_Str_To_Name_Buffer ("loop parameter"); + + elsif Ekind (Item_Id) = E_Protected_Type then + Add_Str_To_Name_Buffer ("current instance of protected type"); + + elsif Ekind (Item_Id) = E_Task_Type then + Add_Str_To_Name_Buffer ("current instance of task type"); + elsif Ekind (Item_Id) = E_Variable then Add_Str_To_Name_Buffer ("global"); @@ -797,15 +830,43 @@ package body Sem_Prag is Item_Id := Entity_Of (Item); if Present (Item_Id) then - if Ekind_In (Item_Id, E_Abstract_State, - E_Constant, - E_Generic_In_Out_Parameter, - E_Generic_In_Parameter, - E_In_Parameter, - E_In_Out_Parameter, - E_Out_Parameter, - E_Variable) + + -- Constants + + if Ekind_In (Item_Id, E_Constant, + E_Discriminant, + E_Loop_Parameter) + or else + + -- Current instances of concurrent types + + Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) + or else + + -- Formal parameters + + Ekind_In (Item_Id, E_Generic_In_Out_Parameter, + E_Generic_In_Parameter, + E_In_Parameter, + E_In_Out_Parameter, + E_Out_Parameter) + or else + + -- States, variables + + Ekind_In (Item_Id, E_Abstract_State, E_Variable) then + -- The item denotes a concurrent type, but it is not the + -- current instance of an enclosing concurrent type. + + if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) + and then not Is_CCT_Instance (Item) + then + SPARK_Msg_N + ("invalid use of subtype mark in dependency " + & "relation", Item); + end if; + -- Ensure that the item fulfils its role as input and/or -- output as specified by pragma Global or the enclosing -- context. @@ -820,7 +881,7 @@ package body Sem_Prag is SPARK_Msg_NE ("duplicate use of item &", Item, Item_Id); else - Add_Item (Item_Id, Seen); + Append_New_Elmt (Item_Id, Seen); end if; -- Detect illegal use of an input related to a null @@ -840,7 +901,7 @@ package body Sem_Prag is -- of all processed inputs. if Is_Input or else Self_Ref then - Add_Item (Item_Id, All_Inputs_Seen); + Append_New_Elmt (Item_Id, All_Inputs_Seen); end if; -- State related checks (SPARK RM 6.1.5(3)) @@ -895,7 +956,7 @@ package body Sem_Prag is -- processed items. if Ekind (Item_Id) = E_Abstract_State then - Add_Item (Item_Id, States_Seen); + Append_New_Elmt (Item_Id, States_Seen); end if; if Ekind_In (Item_Id, E_Abstract_State, @@ -903,7 +964,7 @@ package body Sem_Prag is E_Variable) and then Present (Encapsulating_State (Item_Id)) then - Add_Item (Item_Id, Constits_Seen); + Append_New_Elmt (Item_Id, Constits_Seen); end if; -- All other input/output items are illegal @@ -911,8 +972,8 @@ package body Sem_Prag is else SPARK_Msg_N - ("item must denote parameter, variable, or state", - Item); + ("item must denote parameter, variable, state or " + & "current instance of concurren type", Item); end if; -- All other input/output items are illegal @@ -920,7 +981,8 @@ package body Sem_Prag is else Error_Msg_N - ("item must denote parameter, variable, or state", Item); + ("item must denote parameter, variable, state or current " + & "instance of concurrent type", Item); end if; end if; end Analyze_Input_Output; @@ -1019,7 +1081,7 @@ package body Sem_Prag is Item_Is_Input := False; Item_Is_Output := False; - -- Abstract state cases + -- Abstract states if Ekind (Item_Id) = E_Abstract_State then @@ -1042,26 +1104,24 @@ package body Sem_Prag is Item_Is_Output := True; end if; - -- Constant case - - elsif Ekind (Item_Id) = E_Constant then - Item_Is_Input := True; - - -- Generic parameter cases + -- Constants - elsif Ekind (Item_Id) = E_Generic_In_Parameter then + elsif Ekind_In (Item_Id, E_Constant, + E_Discriminant, + E_Loop_Parameter) + then Item_Is_Input := True; - elsif Ekind (Item_Id) = E_Generic_In_Out_Parameter then - Item_Is_Input := True; - Item_Is_Output := True; - - -- Parameter cases + -- Parameters - elsif Ekind (Item_Id) = E_In_Parameter then + elsif Ekind_In (Item_Id, E_Generic_In_Parameter, + E_In_Parameter) + then Item_Is_Input := True; - elsif Ekind (Item_Id) = E_In_Out_Parameter then + elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter, + E_In_Out_Parameter) + then Item_Is_Input := True; Item_Is_Output := True; @@ -1086,6 +1146,29 @@ package body Sem_Prag is Item_Is_Output := True; end if; + -- Protected types + + elsif Ekind (Item_Id) = E_Protected_Type then + + -- A protected type acts as a formal parameter of mode IN when + -- it applies to a protected function. + + if Ekind (Spec_Id) = E_Function then + Item_Is_Input := True; + + -- Otherwise the protected type acts as a formal of mode IN OUT + + else + Item_Is_Input := True; + Item_Is_Output := True; + end if; + + -- Task types + + elsif Ekind (Item_Id) = E_Task_Type then + Item_Is_Input := True; + Item_Is_Output := True; + -- Variable case else pragma Assert (Ekind (Item_Id) = E_Variable); @@ -1145,8 +1228,8 @@ package body Sem_Prag is Error_Msg_Name_1 := Chars (Spec_Id); SPARK_Msg_NE - ("\& is not part of the input or output set of subprogram %", - Item, Item_Id); + (Fix_Msg (Spec_Id, "\& is not part of the input or output " + & "set of subprogram %"), Item, Item_Id); -- The mode of the item and its role in pragma [Refined_]Depends -- are in conflict. Construct a detailed message explaining the @@ -1215,14 +1298,14 @@ package body Sem_Prag is Used_Items : Elist_Id; Is_Input : Boolean) is - procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id); + procedure Usage_Error (Item_Id : Entity_Id); -- Emit an error concerning the illegal usage of an item ----------------- -- Usage_Error -- ----------------- - procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is + procedure Usage_Error (Item_Id : Entity_Id) is Error_Msg : Name_Id; begin @@ -1240,10 +1323,10 @@ package body Sem_Prag is Add_Item_To_Name_Buffer (Item_Id); Add_Str_To_Name_Buffer - (" & must appear in at least one input dependence list"); + (" & is missing from input dependence list"); Error_Msg := Name_Find; - SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); + SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id); end if; -- Output case (SPARK RM 6.1.5(10)) @@ -1253,10 +1336,10 @@ package body Sem_Prag is Add_Item_To_Name_Buffer (Item_Id); Add_Str_To_Name_Buffer - (" & must appear in exactly one output dependence list"); + (" & is missing from output dependence list"); Error_Msg := Name_Find; - SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); + SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id); end if; end Usage_Error; @@ -1291,14 +1374,19 @@ package body Sem_Prag is if Present (Item_Id) and then not Contains (Used_Items, Item_Id) then - if Is_Formal (Item_Id) then - Usage_Error (Item, Item_Id); + -- The current instance of a concurrent type behaves as a + -- formal parameter (SPARK RM 6.1.4). + + if Is_Formal (Item_Id) + or else Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) + then + Usage_Error (Item_Id); -- States and global objects are not used properly only when -- the subprogram is subject to pragma Global. elsif Global_Seen then - Usage_Error (Item, Item_Id); + Usage_Error (Item_Id); end if; end if; @@ -1580,7 +1668,11 @@ package body Sem_Prag is -- Start of processing for Analyze_Depends_In_Decl_Part begin - Set_Analyzed (N); + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; -- Empty dependency list @@ -1627,16 +1719,28 @@ package body Sem_Prag is Subp_Outputs => Subp_Outputs, Global_Seen => Global_Seen); + -- When pragma [Refined_]Depends appears on a single concurrent + -- type, it is relocated to the anonymous object. + + if Is_Single_Concurrent_Object (Spec_Id) then + null; + -- Ensure that the formal parameters are visible when analyzing -- all clauses. This falls out of the general rule of aspects -- pertaining to subprogram declarations. - if not In_Open_Scopes (Spec_Id) then + elsif not In_Open_Scopes (Spec_Id) then Restore_Scope := True; Push_Scope (Spec_Id); - if Is_Generic_Subprogram (Spec_Id) then + if Ekind (Spec_Id) = E_Task_Type then + if Has_Discriminants (Spec_Id) then + Install_Discriminants (Spec_Id); + end if; + + elsif Is_Generic_Subprogram (Spec_Id) then Install_Generic_Formals (Spec_Id); + else Install_Formals (Spec_Id); end if; @@ -1695,7 +1799,7 @@ package body Sem_Prag is else Error_Msg_N ("malformed dependency relation", Deps); - return; + goto Leave; end if; -- Ensure that a state and a corresponding constituent do not appear @@ -1705,6 +1809,9 @@ package body Sem_Prag is (States => States_Seen, Constits => Constits_Seen, Context => N); + + <<Leave>> + Set_Is_Analyzed_Pragma (N); end Analyze_Depends_In_Decl_Part; -------------------------------------------- @@ -1715,18 +1822,20 @@ package body Sem_Prag is (N : Node_Id; Expr_Val : out Boolean) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); - Obj_Id : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1)); - Expr : constant Node_Id := Get_Pragma_Arg (Next (Arg1)); + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + Obj_Decl : constant Node_Id := Find_Related_Context (N); + Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); + Expr : Node_Id; begin - -- Set the Ghost mode in effect from the pragma. Due to the delayed - -- analysis of the pragma, the Ghost mode at point of declaration and - -- point of analysis may not necessarely be the same. Use the mode in - -- effect at the point of declaration. + Expr_Val := False; + + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; - Set_Ghost_Mode (N); Error_Msg_Name_1 := Pragma_Name (N); -- An external property pragma must apply to an effectively volatile @@ -1748,20 +1857,15 @@ package body Sem_Prag is Expr_Val := True; - if Present (Expr) then - Analyze_And_Resolve (Expr, Standard_Boolean); + if Present (Arg1) then + Expr := Get_Pragma_Arg (Arg1); if Is_OK_Static_Expression (Expr) then Expr_Val := Is_True (Expr_Value (Expr)); - else - SPARK_Msg_N ("expression of % must be static", Expr); end if; end if; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Set_Is_Analyzed_Pragma (N); end Analyze_External_Property_In_Decl_Part; --------------------------------- @@ -1769,8 +1873,8 @@ package body Sem_Prag is --------------------------------- procedure Analyze_Global_In_Decl_Part (N : Node_Id) is - Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N); - Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl); + Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); Constits_Seen : Elist_Id := No_Elist; @@ -1873,8 +1977,54 @@ package body Sem_Prag is if Is_Formal (Item_Id) then if Scope (Item_Id) = Spec_Id then SPARK_Msg_NE - ("global item cannot reference parameter of " - & "subprogram &", Item, Spec_Id); + (Fix_Msg (Spec_Id, "global item cannot reference " + & "parameter of subprogram &"), Item, Spec_Id); + return; + end if; + + -- A global item may denote a concurrent type as long as it is + -- the current instance of an enclosing concurrent type + -- (SPARK RM 6.1.4). + + elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then + if Is_CCT_Instance (Item) then + + -- Pragma [Refined_]Global associated with a protected + -- subprogram cannot mention the current instance of a + -- protected type because the instance behaves as a + -- formal parameter. + + if Ekind (Item_Id) = E_Protected_Type + and then Scope (Spec_Id) = Item_Id + then + Error_Msg_Name_1 := Chars (Item_Id); + SPARK_Msg_NE + (Fix_Msg (Spec_Id, "global item of subprogram & " + & "cannot reference current instance of protected " + & "type %"), Item, Spec_Id); + return; + + -- Pragma [Refined_]Global associated with a task type + -- cannot mention the current instance of a task type + -- because the instance behaves as a formal parameter. + + elsif Ekind (Item_Id) = E_Task_Type + and then Spec_Id = Item_Id + then + Error_Msg_Name_1 := Chars (Item_Id); + SPARK_Msg_NE + (Fix_Msg (Spec_Id, "global item of subprogram & " + & "cannot reference current instance of task type " + & "%"), Item, Spec_Id); + return; + end if; + + -- Otherwise the global item denotes a subtype mark that is + -- not a current instance. + + else + SPARK_Msg_N + ("invalid use of subtype mark in global list", Item); return; end if; @@ -1883,15 +2033,18 @@ package body Sem_Prag is elsif Is_Formal_Object (Item_Id) then null; - -- The only legal references are those to abstract states and - -- objects (SPARK RM 6.1.4(4)). + -- The only legal references are those to abstract states, + -- objects and various kinds of constants (SPARK RM 6.1.4(4)). elsif not Ekind_In (Item_Id, E_Abstract_State, E_Constant, + E_Discriminant, + E_Loop_Parameter, E_Variable) then SPARK_Msg_N - ("global item must denote object or state", Item); + ("global item must denote object, state or current " + & "instance of concurrent type", Item); return; end if; @@ -1921,6 +2074,18 @@ package body Sem_Prag is SPARK_Msg_N ("\use its constituents instead", Item); return; + -- An external state cannot appear as a global item of a + -- nonvolatile function (SPARK RM 7.1.3(8)). + + elsif Is_External_State (Item_Id) + and then Ekind_In (Spec_Id, E_Function, E_Generic_Function) + and then not Is_Volatile_Function (Spec_Id) + then + SPARK_Msg_NE + ("external state & cannot act as global item of " + & "nonvolatile function", Item, Item_Id); + return; + -- If the reference to the abstract state appears in an -- enclosing package body that will eventually refine the -- state, record the reference for future checks. @@ -1935,8 +2100,8 @@ package body Sem_Prag is elsif Ekind (Item_Id) = E_Constant then - -- A constant is read-only item, therefore it cannot act as - -- an output. + -- A constant is a read-only item, therefore it cannot act + -- as an output. if Nam_In (Global_Mode, Name_In_Out, Name_Output) then SPARK_Msg_NE @@ -1944,6 +2109,33 @@ package body Sem_Prag is return; end if; + -- Discriminant related checks + + elsif Ekind (Item_Id) = E_Discriminant then + + -- A discriminant is a read-only item, therefore it cannot + -- act as an output. + + if Nam_In (Global_Mode, Name_In_Out, Name_Output) then + SPARK_Msg_NE + ("discriminant & cannot act as output", Item, Item_Id); + return; + end if; + + -- Loop parameter related checks + + elsif Ekind (Item_Id) = E_Loop_Parameter then + + -- A loop parameter is a read-only item, therefore it cannot + -- act as an output. + + if Nam_In (Global_Mode, Name_In_Out, Name_Output) then + SPARK_Msg_NE + ("loop parameter & cannot act as output", + Item, Item_Id); + return; + end if; + -- Variable related checks. These are only relevant when -- SPARK_Mode is on as they are not standard Ada legality -- rules. @@ -1953,9 +2145,11 @@ package body Sem_Prag is and then Is_Effectively_Volatile (Item_Id) then -- An effectively volatile object cannot appear as a global - -- item of a function (SPARK RM 7.1.3(9)). + -- item of a nonvolatile function (SPARK RM 7.1.3(8)). - if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then + if Ekind_In (Spec_Id, E_Function, E_Generic_Function) + and then not Is_Volatile_Function (Spec_Id) + then Error_Msg_NE ("volatile object & cannot act as global item of a " & "function", Item, Item_Id); @@ -1987,7 +2181,9 @@ package body Sem_Prag is -- (SPARK RM 6.1.4(4)). else - Error_Msg_N ("global item must denote object or state", Item); + Error_Msg_N + ("global item must denote object, state or current instance " + & "of concurrent type", Item); return; end if; @@ -2009,16 +2205,16 @@ package body Sem_Prag is -- items. else - Add_Item (Item_Id, Seen); + Append_New_Elmt (Item_Id, Seen); if Ekind (Item_Id) = E_Abstract_State then - Add_Item (Item_Id, States_Seen); + Append_New_Elmt (Item_Id, States_Seen); end if; if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable) and then Present (Encapsulating_State (Item_Id)) then - Add_Item (Item_Id, Constits_Seen); + Append_New_Elmt (Item_Id, Constits_Seen); end if; end if; end Analyze_Global_Item; @@ -2079,9 +2275,10 @@ package body Sem_Prag is SPARK_Msg_NE ("global item & cannot have mode In_Out or Output", Item, Item_Id); + SPARK_Msg_NE - ("\item already appears as input of subprogram &", - Item, Context); + (Fix_Msg (Subp_Id, "\item already appears as input of " + & "subprogram &"), Item, Context); -- Stop the traversal once an error has been detected @@ -2216,7 +2413,11 @@ package body Sem_Prag is -- Start of processing for Analyze_Global_In_Decl_Part begin - Set_Analyzed (N); + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; -- There is nothing to be done for a null global list @@ -2228,16 +2429,28 @@ package body Sem_Prag is -- messages. else + -- When pragma [Refined_]Global appears on a single concurrent type, + -- it is relocated to the anonymous object. + + if Is_Single_Concurrent_Object (Spec_Id) then + null; + -- Ensure that the formal parameters are visible when processing an -- item. This falls out of the general rule of aspects pertaining to -- subprogram declarations. - if not In_Open_Scopes (Spec_Id) then + elsif not In_Open_Scopes (Spec_Id) then Restore_Scope := True; Push_Scope (Spec_Id); - if Is_Generic_Subprogram (Spec_Id) then + if Ekind (Spec_Id) = E_Task_Type then + if Has_Discriminants (Spec_Id) then + Install_Discriminants (Spec_Id); + end if; + + elsif Is_Generic_Subprogram (Spec_Id) then Install_Generic_Formals (Spec_Id); + else Install_Formals (Spec_Id); end if; @@ -2257,6 +2470,8 @@ package body Sem_Prag is (States => States_Seen, Constits => Constits_Seen, Context => N); + + Set_Is_Analyzed_Pragma (N); end Analyze_Global_In_Decl_Part; -------------------------------------------- @@ -2264,30 +2479,34 @@ package body Sem_Prag is -------------------------------------------- procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N); Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id)); + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + begin + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; + -- Set the Ghost mode in effect from the pragma. Due to the delayed -- analysis of the pragma, the Ghost mode at point of declaration and -- point of analysis may not necessarely be the same. Use the mode in -- effect at the point of declaration. Set_Ghost_Mode (N); - Set_Analyzed (N); -- The expression is preanalyzed because it has not been moved to its -- final place yet. A direct analysis may generate side effects and this -- is not desired at this point. Preanalyze_Assert_Expression (Expr, Standard_Boolean); + Ghost_Mode := Save_Ghost_Mode; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Set_Is_Analyzed_Pragma (N); end Analyze_Initial_Condition_In_Decl_Part; -------------------------------------- @@ -2392,14 +2611,14 @@ package body Sem_Prag is -- and variables. else - Add_Item (Item_Id, Items_Seen); + Append_New_Elmt (Item_Id, Items_Seen); if Ekind (Item_Id) = E_Abstract_State then - Add_Item (Item_Id, States_Seen); + Append_New_Elmt (Item_Id, States_Seen); end if; if Present (Encapsulating_State (Item_Id)) then - Add_Item (Item_Id, Constits_Seen); + Append_New_Elmt (Item_Id, Constits_Seen); end if; end if; @@ -2500,10 +2719,10 @@ package body Sem_Prag is -- Input is legal, add it to the list of processed inputs else - Add_Item (Input_Id, Inputs_Seen); + Append_New_Elmt (Input_Id, Inputs_Seen); if Ekind (Input_Id) = E_Abstract_State then - Add_Item (Input_Id, States_Seen); + Append_New_Elmt (Input_Id, States_Seen); end if; if Ekind_In (Input_Id, E_Abstract_State, @@ -2511,7 +2730,7 @@ package body Sem_Prag is E_Variable) and then Present (Encapsulating_State (Input_Id)) then - Add_Item (Input_Id, Constits_Seen); + Append_New_Elmt (Input_Id, Constits_Seen); end if; end if; @@ -2606,7 +2825,7 @@ package body Sem_Prag is if Comes_From_Source (Decl) and then Nkind (Decl) = N_Object_Declaration then - Add_Item (Defining_Entity (Decl), States_And_Objs); + Append_New_Elmt (Defining_Entity (Decl), States_And_Objs); end if; Next (Decl); @@ -2622,7 +2841,11 @@ package body Sem_Prag is -- Start of processing for Analyze_Initializes_In_Decl_Part begin - Set_Analyzed (N); + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; -- Nothing to do when the initialization list is empty @@ -2663,8 +2886,291 @@ package body Sem_Prag is (States => States_Seen, Constits => Constits_Seen, Context => N); + + Set_Is_Analyzed_Pragma (N); end Analyze_Initializes_In_Decl_Part; + --------------------- + -- Analyze_Part_Of -- + --------------------- + + procedure Analyze_Part_Of + (Indic : Node_Id; + Item_Id : Entity_Id; + Encap : Node_Id; + Encap_Id : out Entity_Id; + Legal : out Boolean) + is + Encap_Typ : Entity_Id; + Item_Decl : Node_Id; + Pack_Id : Entity_Id; + Placement : State_Space_Kind; + Parent_Unit : Entity_Id; + + begin + -- Assume that the indicator is illegal + + Encap_Id := Empty; + Legal := False; + + if Nkind_In (Encap, N_Expanded_Name, + N_Identifier, + N_Selected_Component) + then + Analyze (Encap); + Resolve_State (Encap); + + Encap_Id := Entity (Encap); + + -- The encapsulator is an abstract state + + if Ekind (Encap_Id) = E_Abstract_State then + null; + + -- The encapsulator is a single concurrent type (SPARK RM 9.3) + + elsif Is_Single_Concurrent_Object (Encap_Id) then + null; + + -- Otherwise the encapsulator is not a legal choice + + else + SPARK_Msg_N + ("indicator Part_Of must denote abstract state, single " + & "protected type or single task type", Encap); + return; + end if; + + -- This is a syntax error, always report + + else + Error_Msg_N + ("indicator Part_Of must denote abstract state, single protected " + & "type or single task type", Encap); + return; + end if; + + -- Catch a case where indicator Part_Of denotes the abstract view of a + -- variable which appears as an abstract state (SPARK RM 10.1.2 2). + + if From_Limited_With (Encap_Id) + and then Present (Non_Limited_View (Encap_Id)) + and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable + then + SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap); + SPARK_Msg_N ("\& denotes abstract view of object", Encap); + return; + end if; + + -- The encapsulator is an abstract state + + if Ekind (Encap_Id) = E_Abstract_State then + + -- Determine where the object, package instantiation or state lives + -- with respect to the enclosing packages or package bodies. + + Find_Placement_In_State_Space + (Item_Id => Item_Id, + Placement => Placement, + Pack_Id => Pack_Id); + + -- The item appears in a non-package construct with a declarative + -- part (subprogram, block, etc). As such, the item is not allowed + -- to be a part of an encapsulating state because the item is not + -- visible. + + if Placement = Not_In_Package then + SPARK_Msg_N + ("indicator Part_Of cannot appear in this context " + & "(SPARK RM 7.2.6(5))", Indic); + Error_Msg_Name_1 := Chars (Scope (Encap_Id)); + SPARK_Msg_NE + ("\& is not part of the hidden state of package %", + Indic, Item_Id); + + -- The item appears in the visible state space of some package. In + -- general this scenario does not warrant Part_Of except when the + -- package is a private child unit and the encapsulating state is + -- declared in a parent unit or a public descendant of that parent + -- unit. + + elsif Placement = Visible_State_Space then + if Is_Child_Unit (Pack_Id) + and then Is_Private_Descendant (Pack_Id) + then + -- A variable or state abstraction which is part of the visible + -- state of a private child unit (or one of its public + -- descendants) must have its Part_Of indicator specified. The + -- Part_Of indicator must denote a state abstraction declared + -- by either the parent unit of the private unit or by a public + -- descendant of that parent unit. + + -- Find nearest private ancestor (which can be the current unit + -- itself). + + Parent_Unit := Pack_Id; + while Present (Parent_Unit) loop + exit when + Private_Present + (Parent (Unit_Declaration_Node (Parent_Unit))); + Parent_Unit := Scope (Parent_Unit); + end loop; + + Parent_Unit := Scope (Parent_Unit); + + if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then + SPARK_Msg_NE + ("indicator Part_Of must denote abstract state or public " + & "descendant of & (SPARK RM 7.2.6(3))", + Indic, Parent_Unit); + + elsif Scope (Encap_Id) = Parent_Unit + or else + (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id)) + and then not Is_Private_Descendant (Scope (Encap_Id))) + then + null; + + else + SPARK_Msg_NE + ("indicator Part_Of must denote abstract state or public " + & "descendant of & (SPARK RM 7.2.6(3))", + Indic, Parent_Unit); + end if; + + -- Indicator Part_Of is not needed when the related package is not + -- a private child unit or a public descendant thereof. + + else + SPARK_Msg_N + ("indicator Part_Of cannot appear in this context " + & "(SPARK RM 7.2.6(5))", Indic); + Error_Msg_Name_1 := Chars (Pack_Id); + SPARK_Msg_NE + ("\& is declared in the visible part of package %", + Indic, Item_Id); + end if; + + -- When the item appears in the private state space of a package, the + -- encapsulating state must be declared in the same package. + + elsif Placement = Private_State_Space then + if Scope (Encap_Id) /= Pack_Id then + SPARK_Msg_NE + ("indicator Part_Of must designate an abstract state of " + & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id); + Error_Msg_Name_1 := Chars (Pack_Id); + SPARK_Msg_NE + ("\& is declared in the private part of package %", + Indic, Item_Id); + end if; + + -- Items declared in the body state space of a package do not need + -- Part_Of indicators as the refinement has already been seen. + + else + SPARK_Msg_N + ("indicator Part_Of cannot appear in this context " + & "(SPARK RM 7.2.6(5))", Indic); + + if Scope (Encap_Id) = Pack_Id then + Error_Msg_Name_1 := Chars (Pack_Id); + SPARK_Msg_NE + ("\& is declared in the body of package %", Indic, Item_Id); + end if; + end if; + + -- The encapsulator is a single concurrent type + + else + Encap_Typ := Etype (Encap_Id); + + -- Only abstract states and variables can act as constituents of an + -- encapsulating single concurrent type. + + if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then + null; + + -- The constituent is a constant + + elsif Ekind (Item_Id) = E_Constant then + Error_Msg_Name_1 := Chars (Encap_Id); + SPARK_Msg_NE + (Fix_Msg (Encap_Typ, "consant & cannot act as constituent of " + & "single protected type %"), Indic, Item_Id); + + -- The constituent is a package instantiation + + else + Error_Msg_Name_1 := Chars (Encap_Id); + SPARK_Msg_NE + (Fix_Msg (Encap_Typ, "package instantiation & cannot act as " + & "constituent of single protected type %"), Indic, Item_Id); + end if; + + -- When the item denotes an abstract state of a nested package, use + -- the declaration of the package to detect proper placement. + + -- package Pack is + -- task T; + -- package Nested + -- with Abstract_State => (State with Part_Of => T) + + if Ekind (Item_Id) = E_Abstract_State then + Item_Decl := Unit_Declaration_Node (Scope (Item_Id)); + else + Item_Decl := Declaration_Node (Item_Id); + end if; + + -- Both the item and its encapsulating single concurrent type must + -- appear in the same declarative region (SPARK RM 9.3). Note that + -- privacy is ignored. + + if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then + Error_Msg_Name_1 := Chars (Encap_Id); + SPARK_Msg_NE + (Fix_Msg (Encap_Typ, "constituent & must be declared " + & "immediately within the same region as single protected " + & "type %"), Indic, Item_Id); + end if; + end if; + + Legal := True; + end Analyze_Part_Of; + + ---------------------------------- + -- Analyze_Part_Of_In_Decl_Part -- + ---------------------------------- + + procedure Analyze_Part_Of_In_Decl_Part (N : Node_Id) is + Var_Decl : constant Node_Id := Find_Related_Context (N); + Var_Id : constant Entity_Id := Defining_Entity (Var_Decl); + Encap_Id : Entity_Id; + Legal : Boolean; + + begin + -- Detect any discrepancies between the placement of the variable with + -- respect to general state space and the encapsulating state or single + -- concurrent type. + + Analyze_Part_Of + (Indic => N, + Item_Id => Var_Id, + Encap => Get_Pragma_Arg (First (Pragma_Argument_Associations (N))), + Encap_Id => Encap_Id, + Legal => Legal); + + -- The Part_Of indicator turns the variable into a constituent of the + -- encapsulating state or single concurrent type. + + if Legal then + pragma Assert (Present (Encap_Id)); + + Append_Elmt (Var_Id, Part_Of_Constituents (Encap_Id)); + Set_Encapsulating_State (Var_Id, Encap_Id); + end if; + end Analyze_Part_Of_In_Decl_Part; + -------------------- -- Analyze_Pragma -- -------------------- @@ -2718,19 +3224,18 @@ package body Sem_Prag is -- In Ada 95 or 05 mode, these are implementation defined pragmas, so -- should be caught by the No_Implementation_Pragmas restriction. - procedure Analyze_Depends_Global; - -- Subsidiary to the analysis of pragma Depends and Global + procedure Analyze_Depends_Global + (Spec_Id : out Entity_Id; + Subp_Decl : out Node_Id; + Legal : out Boolean); + -- Subsidiary to the analysis of pragmas Depends and Global. Verify the + -- legality of the placement and related context of the pragma. Spec_Id + -- is the entity of the related subprogram. Subp_Decl is the declaration + -- of the related subprogram. Sets flag Legal when the pragma is legal. - procedure Analyze_Part_Of - (Item_Id : Entity_Id; - State : Node_Id; - Indic : Node_Id; - Legal : out Boolean); - -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of. - -- Perform full analysis of indicator Part_Of. Item_Id is the entity of - -- an abstract state, object, or package instantiation. State is the - -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is - -- set when the indicator is legal. + procedure Analyze_If_Present (Id : Pragma_Id); + -- Inspect the remainder of the list containing pragma N and look for + -- a pragma that matches Id. If found, analyze the pragma. procedure Analyze_Pre_Post_Condition; -- Subsidiary to the analysis of pragmas Precondition and Postcondition @@ -2740,10 +3245,10 @@ package body Sem_Prag is Body_Id : out Entity_Id; Legal : out Boolean); -- Subsidiary routine to the analysis of body pragmas Refined_Depends, - -- Refined_Global and Refined_Post. Check the placement and related - -- context of the pragma. Spec_Id is the entity of the related - -- subprogram. Body_Id is the entity of the subprogram body. Flag - -- Legal is set when the pragma is properly placed. + -- Refined_Global and Refined_Post. Verify the legality of the placement + -- and related context of the pragma. Spec_Id is the entity of the + -- related subprogram. Body_Id is the entity of the subprogram body. + -- Flag Legal is set when the pragma is legal. procedure Check_Ada_83_Warning; -- Issues a warning message for the current pragma if operating in Ada @@ -2849,11 +3354,6 @@ package body Sem_Prag is -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part -- should be set when Comp comes from a record variant. - procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id); - -- Subsidiary routine to the analysis of pragmas Abstract_State, - -- Initial_Condition and Initializes. Determine whether pragma First - -- appears before pragma Second. If this is not the case, emit an error. - procedure Check_Duplicate_Pragma (E : Entity_Id); -- Check if a rep item of the same name as the current pragma is already -- chained as a rep pragma to the given entity. If so give a message @@ -2936,6 +3436,13 @@ package body Sem_Prag is -- In this version of the procedure, the identifier name is given as -- a string with lower case letters. + procedure Check_Static_Boolean_Expression (Expr : Node_Id); + -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers, + -- Constant_After_Elaboration, Effective_Reads, Effective_Writes, + -- Extensions_Visible and Volatile_Function. Ensure that expression Expr + -- is an OK static boolean expression. Emit an error if this is not the + -- case. + procedure Check_Static_Constraint (Constr : Node_Id); -- Constr is a constraint from an N_Subtype_Indication node from a -- component constraint in an Unchecked_Union type. This routine checks @@ -3287,11 +3794,18 @@ package body Sem_Prag is -- Analyze_Depends_Global -- ---------------------------- - procedure Analyze_Depends_Global is - Spec_Id : Entity_Id; - Subp_Decl : Node_Id; - + procedure Analyze_Depends_Global + (Spec_Id : out Entity_Id; + Subp_Decl : out Node_Id; + Legal : out Boolean) + is begin + -- Assume that the pragma is illegal + + Spec_Id := Empty; + Subp_Decl := Empty; + Legal := False; + GNAT_Pragma; Check_Arg_Count (1); @@ -3299,21 +3813,36 @@ package body Sem_Prag is -- associated with a subprogram declaration or a body that acts as a -- spec. - Subp_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True); + Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True); + + -- Entry + + if Nkind (Subp_Decl) = N_Entry_Declaration then + null; -- Generic subprogram - if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then + elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then + null; + + -- Object declaration of a single concurrent type + + elsif Nkind (Subp_Decl) = N_Object_Declaration then + null; + + -- Single task type + + elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then null; - -- Body acts as spec + -- Subprogram body acts as spec elsif Nkind (Subp_Decl) = N_Subprogram_Body and then No (Corresponding_Spec (Subp_Decl)) then null; - -- Body stub acts as spec + -- Subprogram body stub acts as spec elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) @@ -3325,200 +3854,78 @@ package body Sem_Prag is elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then null; + -- Task type + + elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then + null; + else Pragma_Misplaced; return; end if; - Spec_Id := Corresponding_Spec_Of (Subp_Decl); - - -- A pragma that applies to a Ghost entity becomes Ghost for the - -- purposes of legality checks and removal of ignored Ghost code. - - Mark_Pragma_As_Ghost (N, Spec_Id); - Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); - - -- Fully analyze the pragma when it appears inside a subprogram body - -- because it cannot benefit from forward references. - - if Nkind (Subp_Decl) = N_Subprogram_Body then - if Pragma_Name (N) = Name_Depends then - Analyze_Depends_In_Decl_Part (N); - - else pragma Assert (Pname = Name_Global); - Analyze_Global_In_Decl_Part (N); - end if; - end if; - - -- Chain the pragma on the contract for further processing by - -- Analyze_Depends_In_Decl_Part/Analyze_Global_In_Decl_Part. - - Add_Contract_Item (N, Defining_Entity (Subp_Decl)); - end Analyze_Depends_Global; - - --------------------- - -- Analyze_Part_Of -- - --------------------- - - procedure Analyze_Part_Of - (Item_Id : Entity_Id; - State : Node_Id; - Indic : Node_Id; - Legal : out Boolean) - is - Pack_Id : Entity_Id; - Placement : State_Space_Kind; - Parent_Unit : Entity_Id; - State_Id : Entity_Id; + -- If we get here, then the pragma is legal - begin - -- Assume that the pragma/option is illegal + Legal := True; + Spec_Id := Unique_Defining_Entity (Subp_Decl); - Legal := False; + -- When the related context is an entry, the entry must belong to a + -- protected unit (SPARK RM 6.1.4(6)). - if Nkind_In (State, N_Expanded_Name, - N_Identifier, - N_Selected_Component) + if Is_Entry_Declaration (Spec_Id) + and then Ekind (Scope (Spec_Id)) /= E_Protected_Type then - Analyze (State); - Resolve_State (State); - - if Is_Entity_Name (State) - and then Ekind (Entity (State)) = E_Abstract_State - then - State_Id := Entity (State); - - else - SPARK_Msg_N - ("indicator Part_Of must denote an abstract state", State); - return; - end if; + Pragma_Misplaced; + return; - -- This is a syntax error, always report + -- When the related context is an anonymous object created for a + -- simple concurrent type, the type must be a task + -- (SPARK RM 6.1.4(6)). - else - Error_Msg_N - ("indicator Part_Of must denote an abstract state", State); + elsif Is_Single_Concurrent_Object (Spec_Id) + and then Ekind (Etype (Spec_Id)) /= E_Task_Type + then + Pragma_Misplaced; return; end if; - -- Determine where the state, object or the package instantiation - -- lives with respect to the enclosing packages or package bodies (if - -- any). This placement dictates the legality of the encapsulating - -- state. - - Find_Placement_In_State_Space - (Item_Id => Item_Id, - Placement => Placement, - Pack_Id => Pack_Id); - - -- The item appears in a non-package construct with a declarative - -- part (subprogram, block, etc). As such, the item is not allowed - -- to be a part of an encapsulating state because the item is not - -- visible. - - if Placement = Not_In_Package then - SPARK_Msg_N - ("indicator Part_Of cannot appear in this context " - & "(SPARK RM 7.2.6(5))", Indic); - Error_Msg_Name_1 := Chars (Scope (State_Id)); - SPARK_Msg_NE - ("\& is not part of the hidden state of package %", - Indic, Item_Id); - - -- The item appears in the visible state space of some package. In - -- general this scenario does not warrant Part_Of except when the - -- package is a private child unit and the encapsulating state is - -- declared in a parent unit or a public descendant of that parent - -- unit. - - elsif Placement = Visible_State_Space then - if Is_Child_Unit (Pack_Id) - and then Is_Private_Descendant (Pack_Id) - then - -- A variable or state abstraction which is part of the - -- visible state of a private child unit (or one of its public - -- descendants) must have its Part_Of indicator specified. The - -- Part_Of indicator must denote a state abstraction declared - -- by either the parent unit of the private unit or by a public - -- descendant of that parent unit. - - -- Find nearest private ancestor (which can be the current unit - -- itself). - - Parent_Unit := Pack_Id; - while Present (Parent_Unit) loop - exit when Private_Present - (Parent (Unit_Declaration_Node (Parent_Unit))); - Parent_Unit := Scope (Parent_Unit); - end loop; - - Parent_Unit := Scope (Parent_Unit); - - if not Is_Child_Or_Sibling (Pack_Id, Scope (State_Id)) then - SPARK_Msg_NE - ("indicator Part_Of must denote an abstract state of& " - & "or public descendant (SPARK RM 7.2.6(3))", - Indic, Parent_Unit); - - elsif Scope (State_Id) = Parent_Unit - or else (Is_Ancestor_Package (Parent_Unit, Scope (State_Id)) - and then - not Is_Private_Descendant (Scope (State_Id))) - then - null; + -- A pragma that applies to a Ghost entity becomes Ghost for the + -- purposes of legality checks and removal of ignored Ghost code. - else - SPARK_Msg_NE - ("indicator Part_Of must denote an abstract state of& " - & "or public descendant (SPARK RM 7.2.6(3))", - Indic, Parent_Unit); - end if; + Mark_Pragma_As_Ghost (N, Spec_Id); + Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); + end Analyze_Depends_Global; - -- Indicator Part_Of is not needed when the related package is not - -- a private child unit or a public descendant thereof. + ------------------------ + -- Analyze_If_Present -- + ------------------------ - else - SPARK_Msg_N - ("indicator Part_Of cannot appear in this context " - & "(SPARK RM 7.2.6(5))", Indic); - Error_Msg_Name_1 := Chars (Pack_Id); - SPARK_Msg_NE - ("\& is declared in the visible part of package %", - Indic, Item_Id); - end if; + procedure Analyze_If_Present (Id : Pragma_Id) is + Stmt : Node_Id; - -- When the item appears in the private state space of a package, the - -- encapsulating state must be declared in the same package. + begin + pragma Assert (Is_List_Member (N)); - elsif Placement = Private_State_Space then - if Scope (State_Id) /= Pack_Id then - SPARK_Msg_NE - ("indicator Part_Of must designate an abstract state of " - & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id); - Error_Msg_Name_1 := Chars (Pack_Id); - SPARK_Msg_NE - ("\& is declared in the private part of package %", - Indic, Item_Id); - end if; + -- Inspect the declarations or statements following pragma N looking + -- for another pragma whose Id matches the caller's request. If it is + -- available, analyze it. - -- Items declared in the body state space of a package do not need - -- Part_Of indicators as the refinement has already been seen. + Stmt := Next (N); + while Present (Stmt) loop + if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then + Analyze_Pragma (Stmt); + exit; - else - SPARK_Msg_N - ("indicator Part_Of cannot appear in this context " - & "(SPARK RM 7.2.6(5))", Indic); + -- The first source declaration or statement immediately following + -- N ends the region where a pragma may appear. - if Scope (State_Id) = Pack_Id then - Error_Msg_Name_1 := Chars (Pack_Id); - SPARK_Msg_NE - ("\& is declared in the body of package %", Indic, Item_Id); + elsif Comes_From_Source (Stmt) then + exit; end if; - end if; - Legal := True; - end Analyze_Part_Of; + Next (Stmt); + end loop; + end Analyze_If_Present; -------------------------------- -- Analyze_Pre_Post_Condition -- @@ -3604,7 +4011,8 @@ package body Sem_Prag is -- Ensure the proper placement of the pragma Subp_Decl := - Find_Related_Subprogram_Or_Body (N, Do_Checks => not Duplicates_OK); + Find_Related_Declaration_Or_Body + (N, Do_Checks => not Duplicates_OK); -- When a pre/postcondition pragma applies to an abstract subprogram, -- its original form must be an aspect with 'Class. @@ -3667,24 +4075,31 @@ package body Sem_Prag is Subp_Id := Defining_Entity (Subp_Decl); + -- Chain the pragma on the contract for further processing by + -- Analyze_Pre_Post_Condition_In_Decl_Part. + + Add_Contract_Item (N, Defining_Entity (Subp_Decl)); + -- A pragma that applies to a Ghost entity becomes Ghost for the -- purposes of legality checks and removal of ignored Ghost code. Mark_Pragma_As_Ghost (N, Subp_Id); - -- Fully analyze the pragma when it appears inside a subprogram - -- body because it cannot benefit from forward references. + -- Fully analyze the pragma when it appears inside an entry or + -- subprogram body because it cannot benefit from forward references. - if Nkind_In (Subp_Decl, N_Subprogram_Body, + if Nkind_In (Subp_Decl, N_Entry_Body, + N_Subprogram_Body, N_Subprogram_Body_Stub) then + -- The legality checks of pragmas Precondition and Postcondition + -- are affected by the SPARK mode in effect and the volatility of + -- the context. Analyze all pragmas in a specific order. + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); Analyze_Pre_Post_Condition_In_Decl_Part (N); end if; - - -- Chain the pragma on the contract for further processing by - -- Analyze_Pre_Post_Condition_In_Decl_Part. - - Add_Contract_Item (N, Defining_Entity (Subp_Decl)); end Analyze_Pre_Post_Condition; ----------------------------------------- @@ -3713,23 +4128,36 @@ package body Sem_Prag is -- Verify the placement of the pragma and check for duplicates. The -- pragma must apply to a subprogram body [stub]. - Body_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True); + Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True); + + -- Entry body - -- Extract the entities of the spec and body + if Nkind (Body_Decl) = N_Entry_Body then + null; + + -- Subprogram body - if Nkind (Body_Decl) = N_Subprogram_Body then - Body_Id := Defining_Entity (Body_Decl); - Spec_Id := Corresponding_Spec (Body_Decl); + elsif Nkind (Body_Decl) = N_Subprogram_Body then + null; + + -- Subprogram body stub elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then - Body_Id := Defining_Entity (Body_Decl); - Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl); + null; + + -- Task body + + elsif Nkind (Body_Decl) = N_Task_Body then + null; else Pragma_Misplaced; return; end if; + Body_Id := Defining_Entity (Body_Decl); + Spec_Id := Unique_Defining_Entity (Body_Decl); + -- The pragma must apply to the second declaration of a subprogram. -- In other words, the body [stub] cannot acts as a spec. @@ -3745,34 +4173,43 @@ package body Sem_Prag is return; end if; - -- The pragma can only apply to the body [stub] of a subprogram + -- A refined pragma can only apply to the body [stub] of a subprogram -- declared in the visible part of a package. Retrieve the context of -- the subprogram declaration. Spec_Decl := Unit_Declaration_Node (Spec_Id); + -- When dealing with protected entries or protected subprograms, use + -- the enclosing protected type as the proper context. + + if Ekind_In (Spec_Id, E_Entry, + E_Entry_Family, + E_Function, + E_Procedure) + and then Ekind (Scope (Spec_Id)) = E_Protected_Type + then + Spec_Decl := Declaration_Node (Scope (Spec_Id)); + end if; + if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then Error_Pragma - ("pragma % must apply to the body of a subprogram declared in a " - & "package specification"); + (Fix_Msg (Spec_Id, "pragma % must apply to the body of " + & "subprogram declared in a package specification")); return; end if; + -- If we get here, then the pragma is legal + + Legal := True; + -- A pragma that applies to a Ghost entity becomes Ghost for the -- purposes of legality checks and removal of ignored Ghost code. Mark_Pragma_As_Ghost (N, Spec_Id); - -- If we get here, then the pragma is legal - - if Nam_In (Pname, Name_Refined_Depends, - Name_Refined_Global, - Name_Refined_State) - then + if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); end if; - - Legal := True; end Analyze_Refined_Depends_Global_Post; -------------------------- @@ -4260,107 +4697,6 @@ package body Sem_Prag is end if; end Check_Component; - ----------------------------- - -- Check_Declaration_Order -- - ----------------------------- - - procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id) is - procedure Check_Aspect_Specification_Order; - -- Inspect the aspect specifications of the context to determine the - -- proper order. - - -------------------------------------- - -- Check_Aspect_Specification_Order -- - -------------------------------------- - - procedure Check_Aspect_Specification_Order is - Asp_First : constant Node_Id := Corresponding_Aspect (First); - Asp_Second : constant Node_Id := Corresponding_Aspect (Second); - Asp : Node_Id; - - begin - -- Both aspects must be part of the same aspect specification list - - pragma Assert - (List_Containing (Asp_First) = List_Containing (Asp_Second)); - - -- Try to reach Second starting from First in a left to right - -- traversal of the aspect specifications. - - Asp := Next (Asp_First); - while Present (Asp) loop - - -- The order is ok, First is followed by Second - - if Asp = Asp_Second then - return; - end if; - - Next (Asp); - end loop; - - -- If we get here, then the aspects are out of order - - SPARK_Msg_N ("aspect % cannot come after aspect %", First); - end Check_Aspect_Specification_Order; - - -- Local variables - - Stmt : Node_Id; - - -- Start of processing for Check_Declaration_Order - - begin - -- Cannot check the order if one of the pragmas is missing - - if No (First) or else No (Second) then - return; - end if; - - -- Set up the error names in case the order is incorrect - - Error_Msg_Name_1 := Pragma_Name (First); - Error_Msg_Name_2 := Pragma_Name (Second); - - if From_Aspect_Specification (First) then - - -- Both pragmas are actually aspects, check their declaration - -- order in the associated aspect specification list. Otherwise - -- First is an aspect and Second a source pragma. - - if From_Aspect_Specification (Second) then - Check_Aspect_Specification_Order; - end if; - - -- Abstract_States is a source pragma - - else - if From_Aspect_Specification (Second) then - SPARK_Msg_N ("pragma % cannot come after aspect %", First); - - -- Both pragmas are source constructs. Try to reach First from - -- Second by traversing the declarations backwards. - - else - Stmt := Prev (Second); - while Present (Stmt) loop - - -- The order is ok, First is followed by Second - - if Stmt = First then - return; - end if; - - Prev (Stmt); - end loop; - - -- If we get here, then the pragmas are out of order - - SPARK_Msg_N ("pragma % cannot come after pragma %", First); - end if; - end if; - end Check_Declaration_Order; - ---------------------------- -- Check_Duplicate_Pragma -- ---------------------------- @@ -4595,7 +4931,7 @@ package body Sem_Prag is P : constant Node_Id := Parent (N); begin - -- Must be at in subprogram body + -- Must be in subprogram body if Nkind (P) /= N_Subprogram_Body then Error_Pragma ("% pragma allowed only in subprogram"); @@ -4793,6 +5129,12 @@ package body Sem_Prag is elsif Is_Loop_Pragma (Stmt) then Prag := Stmt; + -- Skip declarations and statements generated by + -- the compiler during expansion. + + elsif not Comes_From_Source (Stmt) then + null; + -- A non-pragma is separating the group from the -- current pragma, the placement is illegal. @@ -5070,6 +5412,22 @@ package body Sem_Prag is Check_Optional_Identifier (Arg, Name_Find); end Check_Optional_Identifier; + ------------------------------------- + -- Check_Static_Boolean_Expression -- + ------------------------------------- + + procedure Check_Static_Boolean_Expression (Expr : Node_Id) is + begin + if Present (Expr) then + Analyze_And_Resolve (Expr, Standard_Boolean); + + if not Is_OK_Static_Expression (Expr) then + Error_Pragma_Arg + ("expression of pragma % must be static", Expr); + end if; + end if; + end Check_Static_Boolean_Expression; + ----------------------------- -- Check_Static_Constraint -- ----------------------------- @@ -7746,21 +8104,6 @@ package body Sem_Prag is end if; end loop; - -- When the convention is Java or CIL, we also allow Import to - -- be given for packages, generic packages, exceptions, record - -- components, and access to subprograms. - - elsif (C = Convention_Java or else C = Convention_CIL) - and then - (Is_Package_Or_Generic_Package (Def_Id) - or else Ekind (Def_Id) = E_Exception - or else Ekind (Def_Id) = E_Access_Subprogram_Type - or else Nkind (Parent (Def_Id)) = N_Component_Declaration) - then - Set_Imported (Def_Id); - Set_Is_Public (Def_Id); - Process_Interface_Name (Def_Id, Arg3, Arg4); - -- Import a CPP class elsif C = Convention_CPP @@ -8262,23 +8605,17 @@ package body Sem_Prag is Link_Nam : Node_Id; String_Val : String_Id; - procedure Check_Form_Of_Interface_Name - (SN : Node_Id; - Ext_Name_Case : Boolean); + procedure Check_Form_Of_Interface_Name (SN : Node_Id); -- SN is a string literal node for an interface name. This routine -- performs some minimal checks that the name is reasonable. In -- particular that no spaces or other obviously incorrect characters -- appear. This is only a warning, since any characters are allowed. - -- Ext_Name_Case is True for an External_Name, False for a Link_Name. ---------------------------------- -- Check_Form_Of_Interface_Name -- ---------------------------------- - procedure Check_Form_Of_Interface_Name - (SN : Node_Id; - Ext_Name_Case : Boolean) - is + procedure Check_Form_Of_Interface_Name (SN : Node_Id) is S : constant String_Id := Strval (Expr_Value_S (SN)); SL : constant Nat := String_Length (S); C : Char_Code; @@ -8296,21 +8633,12 @@ package body Sem_Prag is if not In_Character_Range (C) - -- For all cases except CLI target, - -- commas, spaces and slashes are dubious (in CLI, we use - -- commas and backslashes in external names to specify - -- assembly version and public key, while slashes and spaces - -- can be used in names to mark nested classes and - -- valuetypes). - - or else ((not Ext_Name_Case or else VM_Target /= CLI_Target) - and then (Get_Character (C) = ',' - or else - Get_Character (C) = '\')) - or else (VM_Target /= CLI_Target - and then (Get_Character (C) = ' ' - or else - Get_Character (C) = '/')) + -- Commas, spaces and (back)slashes are dubious + + or else Get_Character (C) = ',' + or else Get_Character (C) = '\' + or else Get_Character (C) = ' ' + or else Get_Character (C) = '/' then Error_Msg ("??interface name contains illegal character", @@ -8324,18 +8652,6 @@ package body Sem_Prag is begin if No (Link_Arg) then if No (Ext_Arg) then - if VM_Target = CLI_Target - and then Ekind (Subprogram_Def) = E_Package - and then Nkind (Parent (Subprogram_Def)) = - N_Package_Specification - and then Present (Generic_Parent (Parent (Subprogram_Def))) - then - Set_Interface_Name - (Subprogram_Def, - Interface_Name - (Generic_Parent (Parent (Subprogram_Def)))); - end if; - return; elsif Chars (Ext_Arg) = Name_Link_Name then @@ -8359,7 +8675,7 @@ package body Sem_Prag is if Present (Ext_Nam) then Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String); - Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True); + Check_Form_Of_Interface_Name (Ext_Nam); -- Verify that external name is not the name of a local entity, -- which would hide the imported one and could lead to run-time @@ -8404,7 +8720,7 @@ package body Sem_Prag is if Present (Link_Nam) then Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String); - Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False); + Check_Form_Of_Interface_Name (Link_Nam); end if; -- If there is no link name, just set the external name @@ -8420,11 +8736,7 @@ package body Sem_Prag is else Start_String; - - if VM_Target = No_VM then - Store_String_Char (Get_Char_Code ('*')); - end if; - + Store_String_Char (Get_Char_Code ('*')); String_Val := Strval (Expr_Value_S (Link_Nam)); Store_String_Chars (String_Val); Link_Nam := @@ -8443,16 +8755,7 @@ package body Sem_Prag is (Get_Base_Subprogram (Subprogram_Def), Link_Nam); end if; - -- We allow duplicated export names in CIL/Java, as they are always - -- enclosed in a namespace that differentiates them, and overloaded - -- entities are supported by the VM. - - if Convention (Subprogram_Def) /= Convention_CIL - and then - Convention (Subprogram_Def) /= Convention_Java - then - Check_Duplicated_Export_Name (Link_Nam); - end if; + Check_Duplicated_Export_Name (Link_Nam); end Process_Interface_Name; ----------------------------------------- @@ -9020,7 +9323,7 @@ package body Sem_Prag is begin -- For GCC back ends the validation is done a priori - if VM_Target = No_VM and then not AAMP_On_Target then + if not AAMP_On_Target then return; end if; @@ -9319,7 +9622,7 @@ package body Sem_Prag is -------------------------- -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and - -- and extension to the semantics of renaming declarations. + -- extension to the semantics of renaming declarations. procedure Set_Rational_Profile is begin @@ -9468,7 +9771,7 @@ package body Sem_Prag is Profile => Ravenscar); end if; - -- Set the following restrictions which was added to Ada 2012 (see + -- Set the following restriction which was added to Ada 2012 (see -- AI-0171): -- No_Dependence => System.Multiprocessors.Dispatching_Domains @@ -9511,13 +9814,13 @@ package body Sem_Prag is begin -- The following code is a defense against recursion. Not clear that - -- this can happen legitimately, but perhaps some error situations - -- can cause it, and we did see this recursion during testing. + -- this can happen legitimately, but perhaps some error situations can + -- cause it, and we did see this recursion during testing. if Analyzed (N) then return; else - Set_Analyzed (N, True); + Set_Analyzed (N); end if; -- Deal with unrecognized pragma @@ -9672,7 +9975,7 @@ package body Sem_Prag is -- SIMPLE_OPTION -- | NAME_VALUE_OPTION - -- SIMPLE_OPTION ::= Ghost + -- SIMPLE_OPTION ::= Ghost | Synchronous -- NAME_VALUE_OPTION ::= -- Part_Of => ABSTRACT_STATE @@ -9742,13 +10045,15 @@ package body Sem_Prag is is -- Flags used to verify the consistency of options - AR_Seen : Boolean := False; - AW_Seen : Boolean := False; - ER_Seen : Boolean := False; - EW_Seen : Boolean := False; - External_Seen : Boolean := False; - Others_Seen : Boolean := False; - Part_Of_Seen : Boolean := False; + AR_Seen : Boolean := False; + AW_Seen : Boolean := False; + ER_Seen : Boolean := False; + EW_Seen : Boolean := False; + External_Seen : Boolean := False; + Ghost_Seen : Boolean := False; + Others_Seen : Boolean := False; + Part_Of_Seen : Boolean := False; + Synchronous_Seen : Boolean := False; -- Flags used to store the static value of all external states' -- expressions. @@ -9791,6 +10096,11 @@ package body Sem_Prag is -- Opt is not a duplicate property and sets the flag Status. -- (SPARK RM 7.1.4(2)) + procedure Check_Ghost_Synchronous; + -- Ensure that the abstract state is not subject to both Ghost + -- and Synchronous simple options. Emit an error if this is the + -- case. + procedure Create_Abstract_State (Nam : Name_Id; Decl : Node_Id; @@ -9813,8 +10123,6 @@ package body Sem_Prag is Props : Node_Id := Empty; begin - Check_Duplicate_Option (Opt, External_Seen); - if Nkind (Opt) = N_Component_Association then Props := Expression (Opt); end if; @@ -9987,27 +10295,29 @@ package body Sem_Prag is ---------------------------- procedure Analyze_Part_Of_Option (Opt : Node_Id) is - Encaps : constant Node_Id := Expression (Opt); - Encaps_Id : Entity_Id; - Legal : Boolean; + Encap : constant Node_Id := Expression (Opt); + Encap_Id : Entity_Id; + Legal : Boolean; begin Check_Duplicate_Option (Opt, Part_Of_Seen); Analyze_Part_Of - (Item_Id => State_Id, - State => Encaps, - Indic => First (Choices (Opt)), - Legal => Legal); + (Indic => First (Choices (Opt)), + Item_Id => State_Id, + Encap => Encap, + Encap_Id => Encap_Id, + Legal => Legal); - -- The Part_Of indicator turns an abstract state into a - -- constituent of the encapsulating state. + -- The Part_Of indicator transforms the abstract state into + -- a constituent of the encapsulating state or single + -- concurrent type. if Legal then - Encaps_Id := Entity (Encaps); + pragma Assert (Present (Encap_Id)); - Append_Elmt (State_Id, Part_Of_Constituents (Encaps_Id)); - Set_Encapsulating_State (State_Id, Encaps_Id); + Append_Elmt (State_Id, Part_Of_Constituents (Encap_Id)); + Set_Encapsulating_State (State_Id, Encap_Id); end if; end Analyze_Part_Of_Option; @@ -10043,6 +10353,20 @@ package body Sem_Prag is Status := True; end Check_Duplicate_Property; + ----------------------------- + -- Check_Ghost_Synchronous -- + ----------------------------- + + procedure Check_Ghost_Synchronous is + begin + -- A synchronized abstract state cannot be Ghost and vice + -- versa (SPARK RM 6.9(19)). + + if Ghost_Seen and Synchronous_Seen then + SPARK_Msg_N ("synchronized state cannot be ghost", State); + end if; + end Check_Ghost_Synchronous; + --------------------------- -- Create_Abstract_State -- --------------------------- @@ -10170,26 +10494,43 @@ package body Sem_Prag is Ancestor_Part (State)); end if; - -- Options External and Ghost appear as expressions + -- Options External, Ghost and Synchronous appear as + -- expressions. Opt := First (Expressions (State)); while Present (Opt) loop if Nkind (Opt) = N_Identifier then + + -- External + if Chars (Opt) = Name_External then + Check_Duplicate_Option (Opt, External_Seen); Analyze_External_Option (Opt); + -- Ghost + elsif Chars (Opt) = Name_Ghost then + Check_Duplicate_Option (Opt, Ghost_Seen); + Check_Ghost_Synchronous; + if Present (State_Id) then Set_Is_Ghost_Entity (State_Id); end if; + -- Synchronous + + elsif Chars (Opt) = Name_Synchronous then + Check_Duplicate_Option (Opt, Synchronous_Seen); + Check_Ghost_Synchronous; + -- Option Part_Of without an encapsulating state is - -- illegal. (SPARK RM 7.1.4(9)). + -- illegal (SPARK RM 7.1.4(9)). elsif Chars (Opt) = Name_Part_Of then SPARK_Msg_N - ("indicator Part_Of must denote an abstract " - & "state", Opt); + ("indicator Part_Of must denote abstract state, " + & "single protected type or single task type", + Opt); -- Do not emit an error message when a previous state -- declaration with options was not parenthesized as @@ -10351,6 +10692,22 @@ package body Sem_Prag is Pack_Id := Defining_Entity (Pack_Decl); + -- Chain the pragma on the contract for completeness + + Add_Contract_Item (N, Pack_Id); + + -- The legality checks of pragmas Abstract_State, Initializes, and + -- Initial_Condition are affected by the SPARK mode in effect. In + -- addition, these three pragmas are subject to an inherent order: + + -- 1) Abstract_State + -- 2) Initializes + -- 3) Initial_Condition + + -- Analyze all these pragmas in the order outlined above + + Analyze_If_Present (Pragma_SPARK_Mode); + -- A pragma that applies to a Ghost entity becomes Ghost for the -- purposes of legality checks and removal of ignored Ghost code. @@ -10387,16 +10744,8 @@ package body Sem_Prag is Analyze_Abstract_State (States, Pack_Id); end if; - -- Verify the declaration order of pragmas Abstract_State and - -- Initializes. - - Check_Declaration_Order - (First => N, - Second => Get_Pragma (Pack_Id, Pragma_Initializes)); - - -- Chain the pragma on the contract for completeness - - Add_Contract_Item (N, Pack_Id); + Analyze_If_Present (Pragma_Initializes); + Analyze_If_Present (Pragma_Initial_Condition); end Abstract_State; ------------ @@ -10808,18 +11157,12 @@ package body Sem_Prag is -- Local variables - GM : constant Ghost_Mode_Type := Ghost_Mode; Expr : Node_Id; New_Args : List_Id; -- Start of processing for Assert begin - -- Ensure that analysis and expansion produce Ghost nodes if the - -- pragma itself is Ghost. - - Set_Ghost_Mode (N); - -- Assert is an Ada 2005 RM-defined pragma if Prag_Id = Pragma_Assert then @@ -10892,11 +11235,6 @@ package body Sem_Prag is Pragma_Argument_Associations => New_Args)); Analyze (N); - - -- Restore the original Ghost mode once analysis and expansion - -- have taken place. - - Ghost_Mode := GM; end Assert; ---------------------- @@ -10947,7 +11285,7 @@ package body Sem_Prag is -- POLICY_IDENTIFIER ::= Check | Disable | Ignore -- Note: Check and Ignore are language-defined. Disable is a GNAT - -- implementation defined addition that results in totally ignoring + -- implementation-defined addition that results in totally ignoring -- the corresponding assertion. If Disable is specified, then the -- argument of the assertion is not even analyzed. This is useful -- when the aspect/pragma argument references entities in a with'ed @@ -11145,43 +11483,50 @@ package body Sem_Prag is -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes -- ------------------------------------------------------------------ - -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] ); - -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] ); - -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] ); - -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] ); - - -- FLAG ::= boolean_EXPRESSION + -- pragma Asynch_Readers [ (boolean_EXPRESSION) ]; + -- pragma Asynch_Writers [ (boolean_EXPRESSION) ]; + -- pragma Effective_Reads [ (boolean_EXPRESSION) ]; + -- pragma Effective_Writes [ (boolean_EXPRESSION) ]; when Pragma_Async_Readers | Pragma_Async_Writers | Pragma_Effective_Reads | Pragma_Effective_Writes => Async_Effective : declare - Duplic : Node_Id; - Expr : Node_Id; - Obj : Node_Id; - Obj_Id : Entity_Id; + Obj_Decl : Node_Id; + Obj_Id : Entity_Id; begin GNAT_Pragma; Check_No_Identifiers; - Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (2); - Check_Arg_Is_Local_Name (Arg1); - Error_Msg_Name_1 := Pname; + Check_At_Most_N_Arguments (1); - Obj := Get_Pragma_Arg (Arg1); - Expr := Get_Pragma_Arg (Arg2); + Obj_Decl := Find_Related_Context (N, Do_Checks => True); + + -- Object declaration + + if Nkind (Obj_Decl) = N_Object_Declaration then + null; + + -- Otherwise the pragma is associated with an illegal construact + + else + Pragma_Misplaced; + return; + end if; + + Obj_Id := Defining_Entity (Obj_Decl); -- Perform minimal verification to ensure that the argument is at -- least a variable. Subsequent finer grained checks will be done -- at the end of the declarative region the contains the pragma. - if Is_Entity_Name (Obj) - and then Present (Entity (Obj)) - and then Ekind (Entity (Obj)) = E_Variable - then - Obj_Id := Entity (Obj); + if Ekind (Obj_Id) = E_Variable then + + -- Chain the pragma on the contract for further processing by + -- Analyze_External_Property_In_Decl_Part. + + Add_Contract_Item (N, Obj_Id); -- A pragma that applies to a Ghost entity becomes Ghost for -- the purposes of legality checks and removal of ignored Ghost @@ -11189,30 +11534,14 @@ package body Sem_Prag is Mark_Pragma_As_Ghost (N, Obj_Id); - -- Detect a duplicate pragma. Note that it is not efficient to - -- examine preceding statements as Boolean aspects may appear - -- anywhere between the related object declaration and its - -- freeze point. As an alternative, inspect the contents of the - -- variable contract. - - Duplic := Get_Pragma (Obj_Id, Prag_Id); + -- Analyze the Boolean expression (if any) - if Present (Duplic) then - Error_Msg_Sloc := Sloc (Duplic); - Error_Msg_N ("pragma % duplicates pragma declared #", N); - - -- No duplicate detected - - else - if Present (Expr) then - Preanalyze_And_Resolve (Expr, Standard_Boolean); - end if; + if Present (Arg1) then + Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); + end if; - -- Chain the pragma on the contract for further processing - -- by Analyze_External_Property_In_Decl_Part. + -- Otherwise the external property applies to a constant - Add_Contract_Item (N, Obj_Id); - end if; else Error_Pragma ("pragma % must apply to a volatile object"); end if; @@ -11551,15 +11880,17 @@ package body Sem_Prag is -- allowed, since they have special meaning for Check_Policy. when Pragma_Check => Check : declare - GM : constant Ghost_Mode_Type := Ghost_Mode; Cname : Name_Id; Eloc : Source_Ptr; Expr : Node_Id; Str : Node_Id; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + begin - -- Ensure that analysis and expansion produce Ghost nodes if the - -- pragma itself is Ghost. + -- Pragma Check is Ghost when it applies to a Ghost entity. Set + -- the mode now to ensure that any nodes generated during analysis + -- and expansion are marked as Ghost. Set_Ghost_Mode (N); @@ -11739,7 +12070,7 @@ package body Sem_Prag is Scope_Suppress.Overflow_Mode_Assertions := Eliminated; end; - -- Not that special case! + -- Not that special case else Analyze (N); @@ -11758,10 +12089,7 @@ package body Sem_Prag is In_Assertion_Expr := In_Assertion_Expr - 1; end if; - -- Restore the original Ghost mode once analysis and expansion - -- have taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Check; -------------------------- @@ -11956,14 +12284,6 @@ package body Sem_Prag is end if; end Check_Policy; - --------------------- - -- CIL_Constructor -- - --------------------- - - -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME); - - -- Processing for this pragma is shared with Java_Constructor - ------------- -- Comment -- ------------- @@ -12217,6 +12537,79 @@ package body Sem_Prag is end if; end Component_AlignmentP; + -------------------------------- + -- Constant_After_Elaboration -- + -------------------------------- + + -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ]; + + when Pragma_Constant_After_Elaboration => Constant_After_Elaboration : + declare + Obj_Decl : Node_Id; + Obj_Id : Entity_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_At_Most_N_Arguments (1); + + Obj_Decl := Find_Related_Context (N, Do_Checks => True); + + -- Object declaration + + if Nkind (Obj_Decl) = N_Object_Declaration then + null; + + -- Otherwise the pragma is associated with an illegal construct + + else + Pragma_Misplaced; + return; + end if; + + Obj_Id := Defining_Entity (Obj_Decl); + + -- The object declaration must be a library-level variable with + -- an initialization expression. The expression must depend on + -- a variable, parameter, or another constant_after_elaboration, + -- but the compiler cannot detect this property, as this requires + -- full flow analysis (SPARK RM 3.3.1). + + if Ekind (Obj_Id) = E_Variable then + if not Is_Library_Level_Entity (Obj_Id) then + Error_Pragma + ("pragma % must apply to a library level variable"); + return; + + elsif not Has_Init_Expression (Obj_Decl) then + Error_Pragma + ("pragma % must apply to a variable with initialization " + & "expression"); + end if; + + -- Otherwise the pragma applies to a constant, which is illegal + + else + Error_Pragma ("pragma % must apply to a variable declaration"); + return; + end if; + + -- Chain the pragma on the contract for completeness + + Add_Contract_Item (N, Obj_Id); + + -- A pragma that applies to a Ghost entity becomes Ghost for the + -- purposes of legality checks and removal of ignored Ghost code. + + Mark_Pragma_As_Ghost (N, Obj_Id); + + -- Analyze the Boolean expression (if any) + + if Present (Arg1) then + Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); + end if; + end Constant_After_Elaboration; + -------------------- -- Contract_Cases -- -------------------- @@ -12270,17 +12663,12 @@ package body Sem_Prag is Check_No_Identifiers; Check_Arg_Count (1); - -- The pragma is analyzed at the end of the declarative part which - -- contains the related subprogram. Reset the analyzed flag. - - Set_Analyzed (N, False); - -- Ensure the proper placement of the pragma. Contract_Cases must -- be associated with a subprogram declaration or a body that acts -- as a spec. Subp_Decl := - Find_Related_Subprogram_Or_Body (N, Do_Checks => True); + Find_Related_Declaration_Or_Body (N, Do_Checks => True); -- Generic subprogram @@ -12311,7 +12699,12 @@ package body Sem_Prag is return; end if; - Spec_Id := Corresponding_Spec_Of (Subp_Decl); + Spec_Id := Unique_Defining_Entity (Subp_Decl); + + -- Chain the pragma on the contract for further processing by + -- Analyze_Contract_Cases_In_Decl_Part. + + Add_Contract_Item (N, Defining_Entity (Subp_Decl)); -- A pragma that applies to a Ghost entity becomes Ghost for the -- purposes of legality checks and removal of ignored Ghost code. @@ -12319,17 +12712,22 @@ package body Sem_Prag is Mark_Pragma_As_Ghost (N, Spec_Id); Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); - -- Fully analyze the pragma when it appears inside a subprogram - -- body because it cannot benefit from forward references. + -- Fully analyze the pragma when it appears inside an entry + -- or subprogram body because it cannot benefit from forward + -- references. + + if Nkind_In (Subp_Decl, N_Entry_Body, + N_Subprogram_Body, + N_Subprogram_Body_Stub) + then + -- The legality checks of pragma Contract_Cases are affected by + -- the SPARK mode in effect and the volatility of the context. + -- Analyze all pragmas in a specific order. - if Nkind (Subp_Decl) = N_Subprogram_Body then + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); Analyze_Contract_Cases_In_Decl_Part (N); end if; - - -- Chain the pragma on the contract for further processing by - -- Analyze_Contract_Cases_In_Decl_Part. - - Add_Contract_Item (N, Defining_Entity (Subp_Decl)); end Contract_Cases; ---------------- @@ -13028,8 +13426,46 @@ package body Sem_Prag is -- the "pragma on subprogram declaration" case. In that scenario -- the annotation must instantiate itself. - when Pragma_Depends => - Analyze_Depends_Global; + when Pragma_Depends => Depends : declare + Legal : Boolean; + Spec_Id : Entity_Id; + Subp_Decl : Node_Id; + + begin + Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal); + + if Legal then + + -- Chain the pragma on the contract for further processing by + -- Analyze_Depends_In_Decl_Part. + + Add_Contract_Item (N, Spec_Id); + + -- Fully analyze the pragma when it appears inside an entry + -- or subprogram body because it cannot benefit from forward + -- references. + + if Nkind_In (Subp_Decl, N_Entry_Body, + N_Subprogram_Body, + N_Subprogram_Body_Stub) + then + -- The legality checks of pragmas Depends and Global are + -- affected by the SPARK mode in effect and the volatility + -- of the context. In addition these two pragmas are subject + -- to an inherent order: + + -- 1) Global + -- 2) Depends + + -- Analyze all these pragmas in the order outlined above + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); + Analyze_If_Present (Pragma_Global); + Analyze_Depends_In_Decl_Part (N); + end if; + end if; + end Depends; --------------------- -- Detect_Blocking -- @@ -13943,7 +14379,6 @@ package body Sem_Prag is -- the annotation must instantiate itself. when Pragma_Extensions_Visible => Extensions_Visible : declare - Expr : Node_Id; Formal : Entity_Id; Has_OK_Formal : Boolean := False; Spec_Id : Entity_Id; @@ -13955,11 +14390,16 @@ package body Sem_Prag is Check_At_Most_N_Arguments (1); Subp_Decl := - Find_Related_Subprogram_Or_Body (N, Do_Checks => True); + Find_Related_Declaration_Or_Body (N, Do_Checks => True); + + -- Abstract subprogram declaration + + if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then + null; -- Generic subprogram declaration - if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then + elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then null; -- Body acts as spec @@ -13988,12 +14428,21 @@ package body Sem_Prag is return; end if; - Spec_Id := Corresponding_Spec_Of (Subp_Decl); + -- Chain the pragma on the contract for completeness + + Add_Contract_Item (N, Defining_Entity (Subp_Decl)); + + -- The legality checks of pragma Extension_Visible are affected + -- by the SPARK mode in effect. Analyze all pragmas in specific + -- order. + + Analyze_If_Present (Pragma_SPARK_Mode); -- Mark the pragma as Ghost if the related subprogram is also -- Ghost. This also ensures that any expansion performed further -- below will produce Ghost nodes. + Spec_Id := Unique_Defining_Entity (Subp_Decl); Mark_Pragma_As_Ghost (N, Spec_Id); -- Examine the formals of the related subprogram @@ -14036,20 +14485,9 @@ package body Sem_Prag is -- Analyze the Boolean expression (if any) if Present (Arg1) then - Expr := Expression (Get_Argument (N, Spec_Id)); - - Analyze_And_Resolve (Expr, Standard_Boolean); - - if not Is_OK_Static_Expression (Expr) then - Error_Pragma_Arg - ("expression of pragma % must be static", Expr); - return; - end if; + Check_Static_Boolean_Expression + (Expression (Get_Argument (N, Spec_Id))); end if; - - -- Chain the pragma on the contract for completeness - - Add_Contract_Item (N, Defining_Entity (Subp_Decl)); end Extensions_Visible; -------------- @@ -14247,14 +14685,6 @@ package body Sem_Prag is Check_No_Identifiers; Check_At_Most_N_Arguments (1); - Context := Parent (N); - - -- Handle compilation units - - if Nkind (Context) = N_Compilation_Unit_Aux then - Context := Unit (Parent (Context)); - end if; - Id := Empty; Stmt := Prev (N); while Present (Stmt) loop @@ -14268,14 +14698,12 @@ package body Sem_Prag is Error_Msg_N ("pragma % duplicates pragma declared#", N); end if; - -- Protected and task types cannot be subject to pragma Ghost - -- (SPARK RM 6.9(19)). - - elsif Nkind (Stmt) = N_Protected_Type_Declaration then - Error_Pragma ("pragma % cannot apply to a protected type"); - return; + -- Task unit declared without a definition cannot be subject to + -- pragma Ghost (SPARK RM 6.9(19)). - elsif Nkind (Stmt) = N_Task_Type_Declaration then + elsif Nkind_In (Stmt, N_Single_Task_Declaration, + N_Task_Type_Declaration) + then Error_Pragma ("pragma % cannot apply to a task type"); return; @@ -14335,6 +14763,27 @@ package body Sem_Prag is Stmt := Prev (Stmt); end loop; + Context := Parent (N); + + -- Handle compilation units + + if Nkind (Context) = N_Compilation_Unit_Aux then + Context := Unit (Parent (Context)); + end if; + + -- Protected and task types cannot be subject to pragma Ghost + -- (SPARK RM 6.9(19)). + + if Nkind_In (Context, N_Protected_Body, N_Protected_Definition) + then + Error_Pragma ("pragma % cannot apply to a protected type"); + return; + + elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then + Error_Pragma ("pragma % cannot apply to a task type"); + return; + end if; + if No (Id) then -- When pragma Ghost is associated with a [generic] package, it @@ -14502,8 +14951,46 @@ package body Sem_Prag is -- the "pragma on subprogram declaration" case. In that scenario -- the annotation must instantiate itself. - when Pragma_Global => - Analyze_Depends_Global; + when Pragma_Global => Global : declare + Legal : Boolean; + Spec_Id : Entity_Id; + Subp_Decl : Node_Id; + + begin + Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal); + + if Legal then + + -- Chain the pragma on the contract for further processing by + -- Analyze_Global_In_Decl_Part. + + Add_Contract_Item (N, Spec_Id); + + -- Fully analyze the pragma when it appears inside an entry + -- or subprogram body because it cannot benefit from forward + -- references. + + if Nkind_In (Subp_Decl, N_Entry_Body, + N_Subprogram_Body, + N_Subprogram_Body_Stub) + then + -- The legality checks of pragmas Depends and Global are + -- affected by the SPARK mode in effect and the volatility + -- of the context. In addition these two pragmas are subject + -- to an inherent order: + + -- 1) Global + -- 2) Depends + + -- Analyze all these pragmas in the order outlined above + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); + Analyze_Global_In_Decl_Part (N); + Analyze_If_Present (Pragma_Depends); + end if; + end if; + end Global; ----------- -- Ident -- @@ -15115,36 +15602,31 @@ package body Sem_Prag is return; end if; - -- The pragma must be analyzed at the end of the visible - -- declarations of the related package. Save the pragma for later - -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to - -- the contract of the package. - Pack_Id := Defining_Entity (Pack_Decl); - -- A pragma that applies to a Ghost entity becomes Ghost for the - -- purposes of legality checks and removal of ignored Ghost code. + -- Chain the pragma on the contract for further processing by + -- Analyze_Initial_Condition_In_Decl_Part. - Mark_Pragma_As_Ghost (N, Pack_Id); + Add_Contract_Item (N, Pack_Id); - -- Verify the declaration order of pragma Initial_Condition with - -- respect to pragmas Abstract_State and Initializes when SPARK - -- checks are enabled. + -- The legality checks of pragmas Abstract_State, Initializes, and + -- Initial_Condition are affected by the SPARK mode in effect. In + -- addition, these three pragmas are subject to an inherent order: - if SPARK_Mode /= Off then - Check_Declaration_Order - (First => Get_Pragma (Pack_Id, Pragma_Abstract_State), - Second => N); + -- 1) Abstract_State + -- 2) Initializes + -- 3) Initial_Condition - Check_Declaration_Order - (First => Get_Pragma (Pack_Id, Pragma_Initializes), - Second => N); - end if; + -- Analyze all these pragmas in the order outlined above - -- Chain the pragma on the contract for further processing by - -- Analyze_Initial_Condition_In_Decl_Part. + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Abstract_State); + Analyze_If_Present (Pragma_Initializes); - Add_Contract_Item (N, Pack_Id); + -- A pragma that applies to a Ghost entity becomes Ghost for the + -- purposes of legality checks and removal of ignored Ghost code. + + Mark_Pragma_As_Ghost (N, Pack_Id); end Initial_Condition; ------------------------ @@ -15238,25 +15720,31 @@ package body Sem_Prag is Pack_Id := Defining_Entity (Pack_Decl); + -- Chain the pragma on the contract for further processing by + -- Analyze_Initializes_In_Decl_Part. + + Add_Contract_Item (N, Pack_Id); + + -- The legality checks of pragmas Abstract_State, Initializes, and + -- Initial_Condition are affected by the SPARK mode in effect. In + -- addition, these three pragmas are subject to an inherent order: + + -- 1) Abstract_State + -- 2) Initializes + -- 3) Initial_Condition + + -- Analyze all these pragmas in the order outlined above + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Abstract_State); + -- A pragma that applies to a Ghost entity becomes Ghost for the -- purposes of legality checks and removal of ignored Ghost code. Mark_Pragma_As_Ghost (N, Pack_Id); Ensure_Aggregate_Form (Get_Argument (N, Pack_Id)); - -- Verify the declaration order of pragmas Abstract_State and - -- Initializes when SPARK checks are enabled. - - if SPARK_Mode /= Off then - Check_Declaration_Order - (First => Get_Pragma (Pack_Id, Pragma_Abstract_State), - Second => N); - end if; - - -- Chain the pragma on the contract for further processing by - -- Analyze_Initializes_In_Decl_Part. - - Add_Contract_Item (N, Pack_Id); + Analyze_If_Present (Pragma_Initial_Condition); end Initializes; ------------ @@ -15558,6 +16046,12 @@ package body Sem_Prag is Check_Duplicate_Pragma (Ent); Record_Rep_Item (Ent, N); + + -- Check the No_Task_At_Interrupt_Priority restriction + + if Nkind (P) = N_Task_Definition then + Check_Restriction (No_Task_At_Interrupt_Priority, N); + end if; end if; end Interrupt_Priority; @@ -15699,7 +16193,6 @@ package body Sem_Prag is -- [,[Message =>] String_Expression]); when Pragma_Invariant => Invariant : declare - GM : constant Ghost_Mode_Type := Ghost_Mode; Discard : Boolean; Typ : Entity_Id; Type_Id : Node_Id; @@ -15793,335 +16286,8 @@ package body Sem_Prag is if Class_Present (N) then Set_Has_Inheritable_Invariants (Typ); end if; - - -- Restore the original Ghost mode once analysis and expansion - -- have taken place. - - Ghost_Mode := GM; end Invariant; - ---------------------- - -- Java_Constructor -- - ---------------------- - - -- pragma Java_Constructor ([Entity =>] LOCAL_NAME); - - -- Also handles pragma CIL_Constructor - - when Pragma_CIL_Constructor | Pragma_Java_Constructor => - Java_Constructor : declare - Convention : Convention_Id; - Def_Id : Entity_Id; - Hom_Id : Entity_Id; - Id : Entity_Id; - This_Formal : Entity_Id; - - begin - GNAT_Pragma; - Check_Arg_Count (1); - Check_Optional_Identifier (Arg1, Name_Entity); - Check_Arg_Is_Local_Name (Arg1); - - Id := Get_Pragma_Arg (Arg1); - Find_Program_Unit_Name (Id); - - -- If we did not find the name, we are done - - if Etype (Id) = Any_Type then - return; - end if; - - -- Check wrong use of pragma in wrong VM target - - if VM_Target = No_VM then - return; - - elsif VM_Target = CLI_Target - and then Prag_Id = Pragma_Java_Constructor - then - Error_Pragma ("must use pragma 'C'I'L_'Constructor"); - - elsif VM_Target = JVM_Target - and then Prag_Id = Pragma_CIL_Constructor - then - Error_Pragma ("must use pragma 'Java_'Constructor"); - end if; - - case Prag_Id is - when Pragma_CIL_Constructor => Convention := Convention_CIL; - when Pragma_Java_Constructor => Convention := Convention_Java; - when others => null; - end case; - - Hom_Id := Entity (Id); - - -- Loop through homonyms - - loop - Def_Id := Get_Base_Subprogram (Hom_Id); - - -- The constructor is required to be a function - - if Ekind (Def_Id) /= E_Function then - if VM_Target = JVM_Target then - Error_Pragma_Arg - ("pragma% requires function returning a 'Java access " - & "type", Def_Id); - else - Error_Pragma_Arg - ("pragma% requires function returning a 'C'I'L access " - & "type", Def_Id); - end if; - end if; - - -- Check arguments: For tagged type the first formal must be - -- named "this" and its type must be a named access type - -- designating a class-wide tagged type that has convention - -- CIL/Java. The first formal must also have a null default - -- value. For example: - - -- type Typ is tagged ... - -- type Ref is access all Typ; - -- pragma Convention (CIL, Typ); - - -- function New_Typ (This : Ref) return Ref; - -- function New_Typ (This : Ref; I : Integer) return Ref; - -- pragma Cil_Constructor (New_Typ); - - -- Reason: The first formal must NOT be a primitive of the - -- tagged type. - - -- This rule also applies to constructors of delegates used - -- to interface with standard target libraries. For example: - - -- type Delegate is access procedure ... - -- pragma Import (CIL, Delegate, ...); - - -- function new_Delegate - -- (This : Delegate := null; ... ) return Delegate; - - -- For value-types this rule does not apply. - - if not Is_Value_Type (Etype (Def_Id)) then - if No (First_Formal (Def_Id)) then - Error_Msg_Name_1 := Pname; - Error_Msg_N ("% function must have parameters", Def_Id); - return; - end if; - - -- In the JRE library we have several occurrences in which - -- the "this" parameter is not the first formal. - - This_Formal := First_Formal (Def_Id); - - -- In the JRE library we have several occurrences in which - -- the "this" parameter is not the first formal. Search for - -- it. - - if VM_Target = JVM_Target then - while Present (This_Formal) - and then Get_Name_String (Chars (This_Formal)) /= "this" - loop - Next_Formal (This_Formal); - end loop; - - if No (This_Formal) then - This_Formal := First_Formal (Def_Id); - end if; - end if; - - -- Warning: The first parameter should be named "this". - -- We temporarily allow it because we have the following - -- case in the Java runtime (file s-osinte.ads) ??? - - -- function new_Thread - -- (Self_Id : System.Address) return Thread_Id; - -- pragma Java_Constructor (new_Thread); - - if VM_Target = JVM_Target - and then Get_Name_String (Chars (First_Formal (Def_Id))) - = "self_id" - and then Etype (First_Formal (Def_Id)) = RTE (RE_Address) - then - null; - - elsif Get_Name_String (Chars (This_Formal)) /= "this" then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("first formal of % function must be named `this`", - Parent (This_Formal)); - - elsif not Is_Access_Type (Etype (This_Formal)) then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("first formal of % function must be an access type", - Parameter_Type (Parent (This_Formal))); - - -- For delegates the type of the first formal must be a - -- named access-to-subprogram type (see previous example) - - elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type - and then Ekind (Etype (This_Formal)) - /= E_Access_Subprogram_Type - then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("first formal of % function must be a named access " - & "to subprogram type", - Parameter_Type (Parent (This_Formal))); - - -- Warning: We should reject anonymous access types because - -- the constructor must not be handled as a primitive of the - -- tagged type. We temporarily allow it because this profile - -- is currently generated by cil2ada??? - - elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type - and then not Ekind_In (Etype (This_Formal), - E_Access_Type, - E_General_Access_Type, - E_Anonymous_Access_Type) - then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("first formal of % function must be a named access " - & "type", Parameter_Type (Parent (This_Formal))); - - elsif Atree.Convention - (Designated_Type (Etype (This_Formal))) /= Convention - then - Error_Msg_Name_1 := Pname; - - if Convention = Convention_Java then - Error_Msg_N - ("pragma% requires convention 'Cil in designated " - & "type", Parameter_Type (Parent (This_Formal))); - else - Error_Msg_N - ("pragma% requires convention 'Java in designated " - & "type", Parameter_Type (Parent (This_Formal))); - end if; - - elsif No (Expression (Parent (This_Formal))) - or else Nkind (Expression (Parent (This_Formal))) /= N_Null - then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("pragma% requires first formal with default `null`", - Parameter_Type (Parent (This_Formal))); - end if; - end if; - - -- Check result type: the constructor must be a function - -- returning: - -- * a value type (only allowed in the CIL compiler) - -- * an access-to-subprogram type with convention Java/CIL - -- * an access-type designating a type that has convention - -- Java/CIL. - - if Is_Value_Type (Etype (Def_Id)) then - null; - - -- Access-to-subprogram type with convention Java/CIL - - elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then - if Atree.Convention (Etype (Def_Id)) /= Convention then - if Convention = Convention_Java then - Error_Pragma_Arg - ("pragma% requires function returning a 'Java " - & "access type", Arg1); - else - pragma Assert (Convention = Convention_CIL); - Error_Pragma_Arg - ("pragma% requires function returning a 'C'I'L " - & "access type", Arg1); - end if; - end if; - - elsif Is_Access_Type (Etype (Def_Id)) then - if not Ekind_In (Etype (Def_Id), E_Access_Type, - E_General_Access_Type) - or else - Atree.Convention - (Designated_Type (Etype (Def_Id))) /= Convention - then - Error_Msg_Name_1 := Pname; - - if Convention = Convention_Java then - Error_Pragma_Arg - ("pragma% requires function returning a named " - & "'Java access type", Arg1); - else - Error_Pragma_Arg - ("pragma% requires function returning a named " - & "'C'I'L access type", Arg1); - end if; - end if; - end if; - - Set_Is_Constructor (Def_Id); - Set_Convention (Def_Id, Convention); - Set_Is_Imported (Def_Id); - - exit when From_Aspect_Specification (N); - Hom_Id := Homonym (Hom_Id); - - exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope; - end loop; - end Java_Constructor; - - ---------------------- - -- Java_Interface -- - ---------------------- - - -- pragma Java_Interface ([Entity =>] LOCAL_NAME); - - when Pragma_Java_Interface => Java_Interface : declare - Arg : Node_Id; - Typ : Entity_Id; - - begin - GNAT_Pragma; - Check_Arg_Count (1); - Check_Optional_Identifier (Arg1, Name_Entity); - Check_Arg_Is_Local_Name (Arg1); - - Arg := Get_Pragma_Arg (Arg1); - Analyze (Arg); - - if Etype (Arg) = Any_Type then - return; - end if; - - if not Is_Entity_Name (Arg) - or else not Is_Type (Entity (Arg)) - then - Error_Pragma_Arg ("pragma% requires a type mark", Arg1); - end if; - - Typ := Underlying_Type (Entity (Arg)); - - -- For now simply check some of the semantic constraints on the - -- type. This currently leaves out some restrictions on interface - -- types, namely that the parent type must be java.lang.Object.Typ - -- and that all primitives of the type should be declared - -- abstract. ??? - - if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then - Error_Pragma_Arg - ("pragma% requires an abstract tagged type", Arg1); - - elsif not Has_Discriminants (Typ) - or else Ekind (Etype (First_Discriminant (Typ))) - /= E_Anonymous_Access_Type - or else - not Is_Class_Wide_Type - (Designated_Type (Etype (First_Discriminant (Typ)))) - then - Error_Pragma_Arg - ("type must have a class-wide access discriminant", Arg1); - end if; - end Java_Interface; - ---------------- -- Keep_Names -- ---------------- @@ -17660,18 +17826,6 @@ package body Sem_Prag is if CodePeer_Mode then null; - -- Don't attempt any packing for VM targets. We possibly - -- could deal with some cases of array bit-packing, but we - -- don't bother, since this is not a typical kind of - -- representation in the VM context anyway (and would not - -- for example work nicely with the debugger). - - elsif VM_Target /= No_VM then - if not GNAT_Mode then - Error_Pragma - ("??pragma% ignored in this configuration"); - end if; - -- Normal case where we do the pack action else @@ -17688,23 +17842,9 @@ package body Sem_Prag is else pragma Assert (Is_Record_Type (Typ)); if not Rep_Item_Too_Late (Typ, N) then - - -- Ignore pack request with warning in VM mode (skip warning - -- if we are compiling GNAT run time library). - - if VM_Target /= No_VM then - if not GNAT_Mode then - Error_Pragma - ("??pragma% ignored in this configuration"); - end if; - - -- Normal case of pack request active - - else - Set_Is_Packed (Base_Type (Typ)); - Set_Has_Pragma_Pack (Base_Type (Typ)); - Set_Has_Non_Standard_Rep (Base_Type (Typ)); - end if; + Set_Is_Packed (Base_Type (Typ)); + Set_Has_Pragma_Pack (Base_Type (Typ)); + Set_Has_Non_Standard_Rep (Base_Type (Typ)); end if; end if; end Pack; @@ -17818,10 +17958,10 @@ package body Sem_Prag is -- Local variables + Encap : Node_Id; + Encap_Id : Entity_Id; Item_Id : Entity_Id; Legal : Boolean; - State : Node_Id; - State_Id : Entity_Id; Stmt : Node_Id; -- Start of processing for Part_Of @@ -17831,45 +17971,29 @@ package body Sem_Prag is Check_No_Identifiers; Check_Arg_Count (1); - -- Ensure the proper placement of the pragma. Part_Of must appear - -- on an object declaration or a package instantiation. - - Stmt := Prev (N); - while Present (Stmt) loop + Stmt := Find_Related_Context (N, Do_Checks => True); - -- Skip prior pragmas, but check for duplicates + -- Object declaration - if Nkind (Stmt) = N_Pragma then - if Pragma_Name (Stmt) = Pname then - Error_Msg_Name_1 := Pname; - Error_Msg_Sloc := Sloc (Stmt); - Error_Msg_N ("pragma% duplicates pragma declared#", N); - end if; - - -- Skip internally generated code + if Nkind (Stmt) = N_Object_Declaration then + null; - elsif not Comes_From_Source (Stmt) then - null; + -- Package instantiation - -- The pragma applies to an object declaration (possibly a - -- variable) or a package instantiation. Stop the traversal - -- and continue the analysis. + elsif Nkind (Stmt) = N_Package_Instantiation then + null; - elsif Nkind_In (Stmt, N_Object_Declaration, - N_Package_Instantiation) - then - exit; + -- Single concurrent type declaration - -- The pragma does not apply to a legal construct, issue an - -- error and stop the analysis. + elsif Is_Single_Concurrent_Type_Declaration (Stmt) then + null; - else - Pragma_Misplaced; - return; - end if; + -- Otherwise the pragma is associated with an illegal construct - Stmt := Prev (Stmt); - end loop; + else + Pragma_Misplaced; + return; + end if; -- Extract the entity of the related object declaration or package -- instantiation. In the case of the instantiation, use the entity @@ -17880,47 +18004,59 @@ package body Sem_Prag is end if; Item_Id := Defining_Entity (Stmt); - State := Get_Pragma_Arg (Arg1); + Encap := Get_Pragma_Arg (Arg1); -- A pragma that applies to a Ghost entity becomes Ghost for the -- purposes of legality checks and removal of ignored Ghost code. Mark_Pragma_As_Ghost (N, Item_Id); - -- Detect any discrepancies between the placement of the object - -- or package instantiation with respect to state space and the - -- encapsulating state. + -- Chain the pragma on the contract for further processing by + -- Analyze_Part_Of_In_Decl_Part or for completeness. - Analyze_Part_Of - (Item_Id => Item_Id, - State => State, - Indic => N, - Legal => Legal); + Add_Contract_Item (N, Item_Id); - if Legal then - State_Id := Entity (State); + -- A variable may act as consituent of a single concurrent type + -- which in turn could be declared after the variable. Due to this + -- discrepancy, the full analysis of indicator Part_Of is delayed + -- until the end of the enclosing declarative region (see routine + -- Analyze_Part_Of_In_Decl_Part). - -- The Part_Of indicator turns an object into a constituent of - -- the encapsulating state. + if Ekind (Item_Id) = E_Variable then + null; - if Ekind_In (Item_Id, E_Constant, E_Variable) then - Append_Elmt (Item_Id, Part_Of_Constituents (State_Id)); - Set_Encapsulating_State (Item_Id, State_Id); + -- Otherwise indicator Part_Of applies to a constant or a package + -- instantiation. - -- Propagate the Part_Of indicator to the visible state space - -- of the package instantiation. + else + -- Detect any discrepancies between the placement of the + -- constant or package instantiation with respect to state + -- space and the encapsulating state. - else - Propagate_Part_Of - (Pack_Id => Item_Id, - State_Id => State_Id, - Instance => Stmt); - end if; + Analyze_Part_Of + (Indic => N, + Item_Id => Item_Id, + Encap => Encap, + Encap_Id => Encap_Id, + Legal => Legal); + + if Legal then + pragma Assert (Present (Encap_Id)); - -- Add the pragma to the contract of the item. This aids with - -- the detection of a missing but required Part_Of indicator. + if Ekind (Item_Id) = E_Constant then + Append_Elmt (Item_Id, Part_Of_Constituents (Encap_Id)); + Set_Encapsulating_State (Item_Id, Encap_Id); - Add_Contract_Item (N, Item_Id); + -- Propagate the Part_Of indicator to the visible state + -- space of the package instantiation. + + else + Propagate_Part_Of + (Pack_Id => Item_Id, + State_Id => Encap_Id, + Instance => Stmt); + end if; + end if; end if; end Part_Of; @@ -18290,6 +18426,47 @@ package body Sem_Prag is Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); end Predicate; + ----------------------- + -- Predicate_Failure -- + ----------------------- + + -- pragma Predicate_Failure + -- ([Entity =>] type_LOCAL_NAME, + -- [Message =>] string_EXPRESSION); + + when Pragma_Predicate_Failure => Predicate_Failure : declare + Discard : Boolean; + Typ : Entity_Id; + Type_Id : Node_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Optional_Identifier (Arg2, Name_Message); + + Check_Arg_Is_Local_Name (Arg1); + + Type_Id := Get_Pragma_Arg (Arg1); + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type then + return; + end if; + + -- A pragma that applies to a Ghost entity becomes Ghost for the + -- purposes of legality checks and removal of ignored Ghost code. + + Mark_Pragma_As_Ghost (N, Typ); + + -- The remaining processing is simply to link the pragma on to + -- the rep item chain, for processing when the type is frozen. + -- This is accomplished by a call to Rep_Item_Too_Late. + + Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); + end Predicate_Failure; + ------------------ -- Preelaborate -- ------------------ @@ -18948,9 +19125,12 @@ package body Sem_Prag is -- purposes of legality checks and removal of ignored Ghost code. Mark_Pragma_As_Ghost (N, Ent); - Set_Is_Pure (Ent); - Set_Has_Pragma_Pure (Ent); - Set_Suppress_Elaboration_Warnings (Ent); + + if not Debug_Flag_U then + Set_Is_Pure (Ent); + Set_Has_Pragma_Pure (Ent); + Set_Suppress_Elaboration_Warnings (Ent); + end if; end Pure; ------------------- @@ -19064,9 +19244,9 @@ package body Sem_Prag is when Pragma_Rational => Set_Rational_Profile; - ------------------------------------ - -- Refined_Depends/Refined_Global -- - ------------------------------------ + --------------------- + -- Refined_Depends -- + --------------------- -- pragma Refined_Depends (DEPENDENCY_RELATION); @@ -19089,6 +19269,61 @@ package body Sem_Prag is -- where FUNCTION_RESULT is a function Result attribute_reference + -- Characteristics: + + -- * Analysis - The annotation undergoes initial checks to verify + -- the legal placement and context. Secondary checks fully analyze + -- the dependency clauses/global list in: + + -- Analyze_Refined_Depends_In_Decl_Part + + -- * Expansion - None. + + -- * Template - The annotation utilizes the generic template of the + -- related subprogram body. + + -- * Globals - Capture of global references must occur after full + -- analysis. + + -- * Instance - The annotation is instantiated automatically when + -- the related generic subprogram body is instantiated. + + when Pragma_Refined_Depends => Refined_Depends : declare + Body_Id : Entity_Id; + Legal : Boolean; + Spec_Id : Entity_Id; + + begin + Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal); + + if Legal then + + -- Chain the pragma on the contract for further processing by + -- Analyze_Refined_Depends_In_Decl_Part. + + Add_Contract_Item (N, Body_Id); + + -- The legality checks of pragmas Refined_Depends and + -- Refined_Global are affected by the SPARK mode in effect and + -- the volatility of the context. In addition these two pragmas + -- are subject to an inherent order: + + -- 1) Refined_Global + -- 2) Refined_Depends + + -- Analyze all these pragmas in the order outlined above + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); + Analyze_If_Present (Pragma_Refined_Global); + Analyze_Refined_Depends_In_Decl_Part (N); + end if; + end Refined_Depends; + + -------------------- + -- Refined_Global -- + -------------------- + -- pragma Refined_Global (GLOBAL_SPECIFICATION); -- GLOBAL_SPECIFICATION ::= @@ -19108,7 +19343,6 @@ package body Sem_Prag is -- the legal placement and context. Secondary checks fully analyze -- the dependency clauses/global list in: - -- Analyze_Refined_Depends_In_Decl_Part -- Analyze_Refined_Global_In_Decl_Part -- * Expansion - None. @@ -19122,9 +19356,7 @@ package body Sem_Prag is -- * Instance - The annotation is instantiated automatically when -- the related generic subprogram body is instantiated. - when Pragma_Refined_Depends | - Pragma_Refined_Global => Refined_Depends_Global : - declare + when Pragma_Refined_Global => Refined_Global : declare Body_Id : Entity_Id; Legal : Boolean; Spec_Id : Entity_Id; @@ -19132,13 +19364,29 @@ package body Sem_Prag is begin Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal); - -- Chain the pragma on the contract for further processing by - -- Analyze_Refined_[Depends|Global]_In_Decl_Part. - if Legal then + + -- Chain the pragma on the contract for further processing by + -- Analyze_Refined_Global_In_Decl_Part. + Add_Contract_Item (N, Body_Id); + + -- The legality checks of pragmas Refined_Depends and + -- Refined_Global are affected by the SPARK mode in effect and + -- the volatility of the context. In addition these two pragmas + -- are subject to an inherent order: + + -- 1) Refined_Global + -- 2) Refined_Depends + + -- Analyze all these pragmas in the order outlined above + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); + Analyze_Refined_Global_In_Decl_Part (N); + Analyze_If_Present (Pragma_Refined_Depends); end if; - end Refined_Depends_Global; + end Refined_Global; ------------------ -- Refined_Post -- @@ -19177,16 +19425,23 @@ package body Sem_Prag is -- body because it cannot benefit from forward references. if Legal then + + -- Chain the pragma on the contract for completeness + + Add_Contract_Item (N, Body_Id); + + -- The legality checks of pragma Refined_Post are affected by + -- the SPARK mode in effect and the volatility of the context. + -- Analyze all pragmas in a specific order. + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); Analyze_Pre_Post_Condition_In_Decl_Part (N); -- Currently it is not possible to inline pre/postconditions on -- a subprogram subject to pragma Inline_Always. Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); - - -- Chain the pragma on the contract for completeness - - Add_Contract_Item (N, Body_Id); end if; end Refined_Post; @@ -19254,6 +19509,16 @@ package body Sem_Prag is Spec_Id := Corresponding_Spec (Pack_Decl); + -- Chain the pragma on the contract for further processing by + -- Analyze_Refined_State_In_Decl_Part. + + Add_Contract_Item (N, Defining_Entity (Pack_Decl)); + + -- The legality checks of pragma Refined_State are affected by the + -- SPARK mode in effect. Analyze all pragmas in a specific order. + + Analyze_If_Present (Pragma_SPARK_Mode); + -- A pragma that applies to a Ghost entity becomes Ghost for the -- purposes of legality checks and removal of ignored Ghost code. @@ -19273,11 +19538,6 @@ package body Sem_Prag is & "states", N, Spec_Id); return; end if; - - -- Chain the pragma on the contract for further processing by - -- Analyze_Refined_State_In_Decl_Part. - - Add_Contract_Item (N, Defining_Entity (Pack_Decl)); end Refined_State; ----------------------- @@ -19786,32 +20046,62 @@ package body Sem_Prag is procedure Check_Pragma_Conformance (Context_Pragma : Node_Id; - Entity_Pragma : Node_Id; - Entity : Entity_Id); - -- If Context_Pragma is not Empty, verify that the new pragma N - -- is compatible with the pragma Context_Pragma that was inherited + Entity : Entity_Id; + Entity_Pragma : Node_Id); + -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode + -- conformance of pragma N depending the following scenarios: + -- + -- If pragma Context_Pragma is not Empty, verify that pragma N is + -- compatible with the pragma Context_Pragma that was inherited -- from the context: - -- . if Context_Pragma is ON, then the new mode can be anything - -- . if Context_Pragma is OFF, then the only allowed new mode is - -- also OFF. + -- * If the mode of Context_Pragma is ON, then the new mode can + -- be anything. + -- * If the mode of Context_Pragma is OFF, then the only allowed + -- new mode is also OFF. Emit error if this is not the case. -- - -- If Entity is not Empty, verify that the new pragma N is - -- compatible with Entity_Pragma, the SPARK_Mode previously set - -- for Entity (which may be Empty): - -- . if Entity_Pragma is ON, then the new mode can be anything - -- . if Entity_Pragma is OFF, then the only allowed new mode is - -- also OFF. - -- . if Entity_Pragma is Empty, we always issue an error, as this - -- corresponds to a case where a previous section of Entity - -- had no SPARK_Mode set. + -- If Entity is not Empty, verify that pragma N is compatible with + -- pragma Entity_Pragma that belongs to Entity. + -- * If Entity_Pragma is Empty, always issue an error as this + -- corresponds to the case where a previous section of Entity + -- has no SPARK_Mode set. + -- * If the mode of Entity_Pragma is ON, then the new mode can + -- be anything. + -- * If the mode of Entity_Pragma is OFF, then the only allowed + -- new mode is also OFF. Emit error if this is not the case. procedure Check_Library_Level_Entity (E : Entity_Id); - -- Verify that pragma is applied to library-level entity E - - procedure Set_SPARK_Flags; - -- Sets SPARK_Mode from Mode_Id and SPARK_Mode_Pragma from N, - -- and ensures that Dynamic_Elaboration_Checks are off if the - -- call sets SPARK_Mode On. + -- Subsidiary to routines Process_xxx. Verify that the related + -- entity E subject to pragma SPARK_Mode is library-level. + + procedure Process_Body (Decl : Node_Id); + -- Verify the legality of pragma SPARK_Mode when it appears as the + -- top of the body declarations of entry, package, protected unit, + -- subprogram or task unit body denoted by Decl. + + procedure Process_Overloadable (Decl : Node_Id); + -- Verify the legality of pragma SPARK_Mode when it applies to an + -- entry or [generic] subprogram declaration denoted by Decl. + + procedure Process_Private_Part (Decl : Node_Id); + -- Verify the legality of pragma SPARK_Mode when it appears at the + -- top of the private declarations of a package spec, protected or + -- task unit declaration denoted by Decl. + + procedure Process_Statement_Part (Decl : Node_Id); + -- Verify the legality of pragma SPARK_Mode when it appears at the + -- top of the statement sequence of a package body denoted by node + -- Decl. + + procedure Process_Visible_Part (Decl : Node_Id); + -- Verify the legality of pragma SPARK_Mode when it appears at the + -- top of the visible declarations of a package spec, protected or + -- task unit declaration denoted by Decl. The routine is also used + -- on protected or task units declared without a definition. + + procedure Set_SPARK_Context; + -- Subsidiary to routines Process_xxx. Set the global variables + -- which represent the mode of the context from pragma N. Ensure + -- that Dynamic_Elaboration_Checks are off if the new mode is On. ------------------------------ -- Check_Pragma_Conformance -- @@ -19819,18 +20109,21 @@ package body Sem_Prag is procedure Check_Pragma_Conformance (Context_Pragma : Node_Id; - Entity_Pragma : Node_Id; - Entity : Entity_Id) + Entity : Entity_Id; + Entity_Pragma : Node_Id) is - Arg : Node_Id := Arg1; + Err_Id : Entity_Id; + Err_N : Node_Id; begin -- The current pragma may appear without an argument. If this -- is the case, associate all error messages with the pragma -- itself. - if No (Arg) then - Arg := N; + if Present (Arg1) then + Err_N := Arg1; + else + Err_N := N; end if; -- The mode of the current pragma is compared against that of @@ -19846,18 +20139,31 @@ package body Sem_Prag is and then Get_SPARK_Mode_From_Pragma (N) = On then Error_Msg_N - ("cannot change SPARK_Mode from Off to On", Arg); + ("cannot change SPARK_Mode from Off to On", Err_N); Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma); - Error_Msg_N ("\SPARK_Mode was set to Off#", Arg); + Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N); raise Pragma_Exit; end if; end if; -- The mode of the current pragma is compared against that of - -- an initial package/subprogram declaration. + -- an initial package, protected type, subprogram or task type + -- declaration. if Present (Entity) then + -- A simple protected or task type is transformed into an + -- anonymous type whose name cannot be used to issue error + -- messages. Recover the original entity of the type. + + if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then + Err_Id := + Defining_Entity + (Original_Node (Unit_Declaration_Node (Entity))); + else + Err_Id := Entity; + end if; + -- Both the initial declaration and the completion carry -- SPARK_Mode pragmas. @@ -19870,11 +20176,11 @@ package body Sem_Prag is if Get_SPARK_Mode_From_Pragma (Entity_Pragma) = Off and then Get_SPARK_Mode_From_Pragma (N) = On then - Error_Msg_N ("incorrect use of SPARK_Mode", Arg); + Error_Msg_N ("incorrect use of SPARK_Mode", Err_N); Error_Msg_Sloc := Sloc (Entity_Pragma); Error_Msg_NE ("\value Off was set for SPARK_Mode on&#", - Arg, Entity); + Err_N, Err_Id); raise Pragma_Exit; end if; @@ -19883,11 +20189,11 @@ package body Sem_Prag is -- it cannot "complete". else - Error_Msg_N ("incorrect use of SPARK_Mode", Arg); - Error_Msg_Sloc := Sloc (Entity); + Error_Msg_N ("incorrect use of SPARK_Mode", Err_N); + Error_Msg_Sloc := Sloc (Err_Id); Error_Msg_NE ("\no value was set for SPARK_Mode on&#", - Arg, Entity); + Err_N, Err_Id); raise Pragma_Exit; end if; end if; @@ -19898,33 +20204,294 @@ package body Sem_Prag is -------------------------------- procedure Check_Library_Level_Entity (E : Entity_Id) is - MsgF : constant String := "incorrect placement of pragma%"; + procedure Add_Entity_To_Name_Buffer; + -- Add the E_Kind of entity E to the name buffer - begin - if not Is_Library_Level_Entity (E) then - Error_Msg_Name_1 := Pname; - Error_Msg_N (Fix_Error (MsgF), N); + ------------------------------- + -- Add_Entity_To_Name_Buffer -- + ------------------------------- + + procedure Add_Entity_To_Name_Buffer is + begin + if Ekind_In (E, E_Entry, E_Entry_Family) then + Add_Str_To_Name_Buffer ("entry"); - if Ekind_In (E, E_Generic_Package, - E_Package, - E_Package_Body) + elsif Ekind_In (E, E_Generic_Package, + E_Package, + E_Package_Body) then - Error_Msg_NE - ("\& is not a library-level package", N, E); + Add_Str_To_Name_Buffer ("package"); + + elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then + Add_Str_To_Name_Buffer ("protected type"); + + elsif Ekind_In (E, E_Function, + E_Generic_Function, + E_Generic_Procedure, + E_Procedure, + E_Subprogram_Body) + then + Add_Str_To_Name_Buffer ("subprogram"); + else - Error_Msg_NE - ("\& is not a library-level subprogram", N, E); + pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type)); + Add_Str_To_Name_Buffer ("task type"); end if; + end Add_Entity_To_Name_Buffer; + + -- Local variables + + Msg_1 : constant String := "incorrect placement of pragma%"; + Msg_2 : Name_Id; + + -- Start of processing for Check_Library_Level_Entity + + begin + if not Is_Library_Level_Entity (E) then + Error_Msg_Name_1 := Pname; + Error_Msg_N (Fix_Error (Msg_1), N); + + Name_Len := 0; + Add_Str_To_Name_Buffer ("\& is not a library-level "); + Add_Entity_To_Name_Buffer; + + Msg_2 := Name_Find; + Error_Msg_NE (Get_Name_String (Msg_2), N, E); raise Pragma_Exit; end if; end Check_Library_Level_Entity; - --------------------- - -- Set_SPARK_Flags -- - --------------------- + ------------------ + -- Process_Body -- + ------------------ + + procedure Process_Body (Decl : Node_Id) is + Body_Id : constant Entity_Id := Defining_Entity (Decl); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl); + + begin + -- Ignore pragma when applied to the special body created for + -- inlining, recognized by its internal name _Parent. + + if Chars (Body_Id) = Name_uParent then + return; + end if; + + Check_Library_Level_Entity (Body_Id); - procedure Set_SPARK_Flags is + -- For entry bodies, verify the legality against: + -- * The mode of the context + -- * The mode of the spec (if any) + + if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then + + -- A stand alone subprogram body + + if Body_Id = Spec_Id then + Check_Pragma_Conformance + (Context_Pragma => SPARK_Pragma (Body_Id), + Entity => Empty, + Entity_Pragma => Empty); + + -- An entry or subprogram body that completes a previous + -- declaration. + + else + Check_Pragma_Conformance + (Context_Pragma => SPARK_Pragma (Body_Id), + Entity => Spec_Id, + Entity_Pragma => SPARK_Pragma (Spec_Id)); + end if; + + Set_SPARK_Context; + Set_SPARK_Pragma (Body_Id, N); + Set_SPARK_Pragma_Inherited (Body_Id, False); + + -- For package bodies, verify the legality against: + -- * The mode of the context + -- * The mode of the private part + + -- This case is separated from protected and task bodies + -- because the statement part of the package body inherits + -- the mode of the body declarations. + + elsif Nkind (Decl) = N_Package_Body then + Check_Pragma_Conformance + (Context_Pragma => SPARK_Pragma (Body_Id), + Entity => Spec_Id, + Entity_Pragma => SPARK_Aux_Pragma (Spec_Id)); + + Set_SPARK_Context; + Set_SPARK_Pragma (Body_Id, N); + Set_SPARK_Pragma_Inherited (Body_Id, False); + Set_SPARK_Aux_Pragma (Body_Id, N); + Set_SPARK_Aux_Pragma_Inherited (Body_Id, True); + + -- For protected and task bodies, verify the legality against: + -- * The mode of the context + -- * The mode of the private part + + else + pragma Assert + (Nkind_In (Decl, N_Protected_Body, N_Task_Body)); + + Check_Pragma_Conformance + (Context_Pragma => SPARK_Pragma (Body_Id), + Entity => Spec_Id, + Entity_Pragma => SPARK_Aux_Pragma (Spec_Id)); + + Set_SPARK_Context; + Set_SPARK_Pragma (Body_Id, N); + Set_SPARK_Pragma_Inherited (Body_Id, False); + end if; + end Process_Body; + + -------------------------- + -- Process_Overloadable -- + -------------------------- + + procedure Process_Overloadable (Decl : Node_Id) is + Spec_Id : constant Entity_Id := Defining_Entity (Decl); + Spec_Typ : constant Entity_Id := Etype (Spec_Id); + + begin + Check_Library_Level_Entity (Spec_Id); + + -- Verify the legality against: + -- * The mode of the context + + Check_Pragma_Conformance + (Context_Pragma => SPARK_Pragma (Spec_Id), + Entity => Empty, + Entity_Pragma => Empty); + + Set_SPARK_Pragma (Spec_Id, N); + Set_SPARK_Pragma_Inherited (Spec_Id, False); + + -- When the pragma applies to the anonymous object created for + -- a single task type, decorate the type as well. This scenario + -- arises when the single task type lacks a task definition, + -- therefore there is no issue with respect to a potential + -- pragma SPARK_Mode in the private part. + + -- task type Anon_Task_Typ; + -- Obj : Anon_Task_Typ; + -- pragma SPARK_Mode ...; + + if Is_Single_Concurrent_Object (Spec_Id) + and then Ekind (Spec_Typ) = E_Task_Type + then + Set_SPARK_Pragma (Spec_Typ, N); + Set_SPARK_Pragma_Inherited (Spec_Typ, False); + Set_SPARK_Aux_Pragma (Spec_Typ, N); + Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True); + end if; + end Process_Overloadable; + + -------------------------- + -- Process_Private_Part -- + -------------------------- + + procedure Process_Private_Part (Decl : Node_Id) is + Spec_Id : constant Entity_Id := Defining_Entity (Decl); + + begin + Check_Library_Level_Entity (Spec_Id); + + -- Verify the legality against: + -- * The mode of the visible declarations + + Check_Pragma_Conformance + (Context_Pragma => Empty, + Entity => Spec_Id, + Entity_Pragma => SPARK_Pragma (Spec_Id)); + + Set_SPARK_Context; + Set_SPARK_Aux_Pragma (Spec_Id, N); + Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False); + end Process_Private_Part; + + ---------------------------- + -- Process_Statement_Part -- + ---------------------------- + + procedure Process_Statement_Part (Decl : Node_Id) is + Body_Id : constant Entity_Id := Defining_Entity (Decl); + + begin + Check_Library_Level_Entity (Body_Id); + + -- Verify the legality against: + -- * The mode of the body declarations + + Check_Pragma_Conformance + (Context_Pragma => Empty, + Entity => Body_Id, + Entity_Pragma => SPARK_Pragma (Body_Id)); + + Set_SPARK_Context; + Set_SPARK_Aux_Pragma (Body_Id, N); + Set_SPARK_Aux_Pragma_Inherited (Body_Id, False); + end Process_Statement_Part; + + -------------------------- + -- Process_Visible_Part -- + -------------------------- + + procedure Process_Visible_Part (Decl : Node_Id) is + Spec_Id : constant Entity_Id := Defining_Entity (Decl); + Obj_Id : Entity_Id; + + begin + Check_Library_Level_Entity (Spec_Id); + + -- Verify the legality against: + -- * The mode of the context + + Check_Pragma_Conformance + (Context_Pragma => SPARK_Pragma (Spec_Id), + Entity => Empty, + Entity_Pragma => Empty); + + -- A task unit declared without a definition does not set the + -- SPARK_Mode of the context because the task does not have any + -- entries that could inherit the mode. + + if not Nkind_In (Decl, N_Single_Task_Declaration, + N_Task_Type_Declaration) + then + Set_SPARK_Context; + end if; + + Set_SPARK_Pragma (Spec_Id, N); + Set_SPARK_Pragma_Inherited (Spec_Id, False); + Set_SPARK_Aux_Pragma (Spec_Id, N); + Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True); + + -- When the pragma applies to a single protected or task type, + -- decorate the corresponding anonymous object as well. + + -- protected Anon_Prot_Typ is + -- pragma SPARK_Mode ...; + -- ... + -- end Anon_Prot_Typ; + + -- Obj : Anon_Prot_Typ; + + if Is_Single_Concurrent_Type (Spec_Id) then + Obj_Id := Anonymous_Object (Spec_Id); + + Set_SPARK_Pragma (Obj_Id, N); + Set_SPARK_Pragma_Inherited (Obj_Id, False); + end if; + end Process_Visible_Part; + + ----------------------- + -- Set_SPARK_Context -- + ----------------------- + + procedure Set_SPARK_Context is begin SPARK_Mode := Mode_Id; SPARK_Mode_Pragma := N; @@ -19932,14 +20499,12 @@ package body Sem_Prag is if SPARK_Mode = On then Dynamic_Elaboration_Checks := False; end if; - end Set_SPARK_Flags; + end Set_SPARK_Context; -- Local variables - Body_Id : Entity_Id; Context : Node_Id; Mode : Name_Id; - Spec_Id : Entity_Id; Stmt : Node_Id; -- Start of processing for Do_SPARK_Mode @@ -19982,7 +20547,7 @@ package body Sem_Prag is raise Pragma_Exit; end if; - Set_SPARK_Flags; + Set_SPARK_Context; -- The pragma acts as a configuration pragma in a compilation unit @@ -19993,7 +20558,7 @@ package body Sem_Prag is and then List_Containing (N) = Context_Items (Context) then Check_Valid_Configuration_Pragma; - Set_SPARK_Flags; + Set_SPARK_Context; -- Otherwise the placement of the pragma within the tree dictates -- its associated construct. Inspect the declarative list where @@ -20003,7 +20568,8 @@ package body Sem_Prag is Stmt := Prev (N); while Present (Stmt) loop - -- Skip prior pragmas, but check for duplicates + -- Skip prior pragmas, but check for duplicates. Note that + -- this also takes care of pragmas generated for aspects. if Nkind (Stmt) = N_Pragma then if Pragma_Name (Stmt) = Pname then @@ -20013,26 +20579,31 @@ package body Sem_Prag is raise Pragma_Exit; end if; - -- The pragma applies to a [generic] subprogram declaration. - -- Note that this case covers an internally generated spec - -- for a stand alone body. + -- The pragma applies to an expression function that has + -- already been rewritten into a subprogram declaration. - -- [generic] - -- procedure Proc ...; - -- pragma SPARK_Mode ..; + -- function Expr_Func return ... is (...); + -- pragma SPARK_Mode ...; - elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) + elsif Nkind (Stmt) = N_Subprogram_Declaration + and then Nkind (Original_Node (Stmt)) = + N_Expression_Function then - Spec_Id := Defining_Entity (Stmt); - Check_Library_Level_Entity (Spec_Id); - Check_Pragma_Conformance - (Context_Pragma => SPARK_Pragma (Spec_Id), - Entity_Pragma => Empty, - Entity => Empty); + Process_Overloadable (Stmt); + return; + + -- The pragma applies to the anonymous object created for a + -- single concurrent type. + + -- protected type Anon_Prot_Typ ...; + -- Obj : Anon_Prot_Typ; + -- pragma SPARK_Mode ...; - Set_SPARK_Pragma (Spec_Id, N); - Set_SPARK_Pragma_Inherited (Spec_Id, False); + elsif Nkind (Stmt) = N_Object_Declaration + and then Is_Single_Concurrent_Object + (Defining_Entity (Stmt)) + then + Process_Overloadable (Stmt); return; -- Skip internally generated code @@ -20040,6 +20611,25 @@ package body Sem_Prag is elsif not Comes_From_Source (Stmt) then null; + -- The pragma applies to an entry or [generic] subprogram + -- declaration. + + -- entry Ent ...; + -- pragma SPARK_Mode ...; + + -- [generic] + -- procedure Proc ...; + -- pragma SPARK_Mode ...; + + elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration, + N_Subprogram_Declaration) + or else (Nkind (Stmt) = N_Entry_Declaration + and then Is_Protected_Type + (Scope (Defining_Entity (Stmt)))) + then + Process_Overloadable (Stmt); + return; + -- Otherwise the pragma does not apply to a legal construct -- or it does not appear at the top of a declarative or a -- statement list. Issue an error and stop the analysis. @@ -20062,65 +20652,51 @@ package body Sem_Prag is Context := Unit (Parent (Context)); end if; - -- The pragma appears within package declarations + -- The pragma appears at the top of entry, package, protected + -- unit, subprogram or task unit body declarations. - if Nkind (Context) = N_Package_Specification then - Spec_Id := Defining_Entity (Context); - Check_Library_Level_Entity (Spec_Id); - - -- The pragma is at the top of the visible declarations - - -- package Pack is - -- pragma SPARK_Mode ...; - - if List_Containing (N) = Visible_Declarations (Context) then - Check_Pragma_Conformance - (Context_Pragma => SPARK_Pragma (Spec_Id), - Entity_Pragma => Empty, - Entity => Empty); - Set_SPARK_Flags; - - Set_SPARK_Pragma (Spec_Id, N); - Set_SPARK_Pragma_Inherited (Spec_Id, False); - Set_SPARK_Aux_Pragma (Spec_Id, N); - Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True); + -- entry Ent when ... is + -- pragma SPARK_Mode ...; - -- The pragma is at the top of the private declarations + -- package body Pack is + -- pragma SPARK_Mode ...; - -- package Pack is - -- private - -- pragma SPARK_Mode ...; + -- procedure Proc ... is + -- pragma SPARK_Mode; - else - Check_Pragma_Conformance - (Context_Pragma => Empty, - Entity_Pragma => SPARK_Pragma (Spec_Id), - Entity => Spec_Id); - Set_SPARK_Flags; + -- protected body Prot is + -- pragma SPARK_Mode ...; - Set_SPARK_Aux_Pragma (Spec_Id, N); - Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False); - end if; + if Nkind_In (Context, N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body) + then + Process_Body (Context); - -- The pragma appears at the top of package body declarations + -- The pragma appears at the top of the visible or private + -- declaration of a package spec, protected or task unit. - -- package body Pack is + -- package Pack is + -- pragma SPARK_Mode ...; + -- private -- pragma SPARK_Mode ...; - elsif Nkind (Context) = N_Package_Body then - Spec_Id := Corresponding_Spec (Context); - Body_Id := Defining_Entity (Context); - Check_Library_Level_Entity (Body_Id); - Check_Pragma_Conformance - (Context_Pragma => SPARK_Pragma (Body_Id), - Entity_Pragma => SPARK_Aux_Pragma (Spec_Id), - Entity => Spec_Id); - Set_SPARK_Flags; + -- protected [type] Prot is + -- pragma SPARK_Mode ...; + -- private + -- pragma SPARK_Mode ...; - Set_SPARK_Pragma (Body_Id, N); - Set_SPARK_Pragma_Inherited (Body_Id, False); - Set_SPARK_Aux_Pragma (Body_Id, N); - Set_SPARK_Aux_Pragma_Inherited (Body_Id, True); + elsif Nkind_In (Context, N_Package_Specification, + N_Protected_Definition, + N_Task_Definition) + then + if List_Containing (N) = Visible_Declarations (Context) then + Process_Visible_Part (Parent (Context)); + else + Process_Private_Part (Parent (Context)); + end if; -- The pragma appears at the top of package body statements @@ -20131,18 +20707,7 @@ package body Sem_Prag is elsif Nkind (Context) = N_Handled_Sequence_Of_Statements and then Nkind (Parent (Context)) = N_Package_Body then - Context := Parent (Context); - Spec_Id := Corresponding_Spec (Context); - Body_Id := Defining_Entity (Context); - Check_Library_Level_Entity (Body_Id); - Check_Pragma_Conformance - (Context_Pragma => Empty, - Entity_Pragma => SPARK_Pragma (Body_Id), - Entity => Body_Id); - Set_SPARK_Flags; - - Set_SPARK_Aux_Pragma (Body_Id, N); - Set_SPARK_Aux_Pragma_Inherited (Body_Id, False); + Process_Statement_Part (Parent (Context)); -- The pragma appeared as an aspect of a [generic] subprogram -- declaration that acts as a compilation unit. @@ -20154,57 +20719,7 @@ package body Sem_Prag is elsif Nkind_In (Context, N_Generic_Subprogram_Declaration, N_Subprogram_Declaration) then - Spec_Id := Defining_Entity (Context); - Check_Library_Level_Entity (Spec_Id); - Check_Pragma_Conformance - (Context_Pragma => SPARK_Pragma (Spec_Id), - Entity_Pragma => Empty, - Entity => Empty); - - Set_SPARK_Pragma (Spec_Id, N); - Set_SPARK_Pragma_Inherited (Spec_Id, False); - - -- The pragma appears at the top of subprogram body - -- declarations. - - -- procedure Proc ... is - -- pragma SPARK_Mode; - - elsif Nkind (Context) = N_Subprogram_Body then - Spec_Id := Corresponding_Spec (Context); - Context := Specification (Context); - Body_Id := Defining_Entity (Context); - - -- Ignore pragma when applied to the special body created - -- for inlining, recognized by its internal name _Parent. - - if Chars (Body_Id) = Name_uParent then - return; - end if; - - Check_Library_Level_Entity (Body_Id); - - -- The body is a completion of a previous declaration - - if Present (Spec_Id) then - Check_Pragma_Conformance - (Context_Pragma => SPARK_Pragma (Body_Id), - Entity_Pragma => SPARK_Pragma (Spec_Id), - Entity => Spec_Id); - - -- The body acts as spec - - else - Check_Pragma_Conformance - (Context_Pragma => SPARK_Pragma (Body_Id), - Entity_Pragma => Empty, - Entity => Empty); - end if; - - Set_SPARK_Flags; - - Set_SPARK_Pragma (Body_Id, N); - Set_SPARK_Pragma_Inherited (Body_Id, False); + Process_Overloadable (Context); -- The pragma does not apply to a legal construct, issue error @@ -20908,6 +21423,7 @@ package body Sem_Prag is Prag := Contract_Test_Cases (Items); while Present (Prag) loop if Pragma_Name (Prag) = Name_Test_Case + and then Prag /= N and then String_Equal (Name, Get_Name_From_CTC_Pragma (Prag)) then @@ -20975,7 +21491,7 @@ package body Sem_Prag is return; end if; - Subp_Decl := Find_Related_Subprogram_Or_Body (N); + Subp_Decl := Find_Related_Declaration_Or_Body (N); -- Find the enclosing context @@ -21005,7 +21521,7 @@ package body Sem_Prag is and then Nkind_In (Context, N_Generic_Package_Declaration, N_Package_Declaration) then - Subp_Id := Defining_Entity (Subp_Decl); + null; -- Otherwise the placement is illegal @@ -21014,6 +21530,13 @@ package body Sem_Prag is return; end if; + Subp_Id := Defining_Entity (Subp_Decl); + + -- Chain the pragma on the contract for further processing by + -- Analyze_Test_Case_In_Decl_Part. + + Add_Contract_Item (N, Subp_Id); + -- A pragma that applies to a Ghost entity becomes Ghost for the -- purposes of legality checks and removal of ignored Ghost code. @@ -21044,19 +21567,22 @@ package body Sem_Prag is Check_Distinct_Name (Subp_Id); - -- Fully analyze the pragma when it appears inside a subprogram - -- body because it cannot benefit from forward references. + -- Fully analyze the pragma when it appears inside an entry + -- or subprogram body because it cannot benefit from forward + -- references. - if Nkind_In (Subp_Decl, N_Subprogram_Body, + if Nkind_In (Subp_Decl, N_Entry_Body, + N_Subprogram_Body, N_Subprogram_Body_Stub) then + -- The legality checks of pragma Test_Case are affected by the + -- SPARK mode in effect and the volatility of the context. + -- Analyze all pragmas in a specific order. + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); Analyze_Test_Case_In_Decl_Part (N); end if; - - -- Chain the pragma on the contract for further processing by - -- Analyze_Test_Case_In_Decl_Part. - - Add_Contract_Item (N, Subp_Id); end Test_Case; -------------------------- @@ -21851,6 +22377,14 @@ package body Sem_Prag is when Pragma_Volatile => Process_Atomic_Independent_Shared_Volatile; + ------------------------- + -- Volatile_Components -- + ------------------------- + + -- pragma Volatile_Components (array_LOCAL_NAME); + + -- Volatile is handled by the same circuit as Atomic_Components + -------------------------- -- Volatile_Full_Access -- -------------------------- @@ -21861,13 +22395,106 @@ package body Sem_Prag is GNAT_Pragma; Process_Atomic_Independent_Shared_Volatile; - ------------------------- - -- Volatile_Components -- - ------------------------- + ----------------------- + -- Volatile_Function -- + ----------------------- - -- pragma Volatile_Components (array_LOCAL_NAME); + -- pragma Volatile_Function [ (boolean_EXPRESSION) ]; - -- Volatile is handled by the same circuit as Atomic_Components + when Pragma_Volatile_Function => Volatile_Function : declare + Over_Id : Entity_Id; + Spec_Id : Entity_Id; + Subp_Decl : Node_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_At_Most_N_Arguments (1); + + Subp_Decl := + Find_Related_Declaration_Or_Body (N, Do_Checks => True); + + -- Generic subprogram + + if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then + null; + + -- Body acts as spec + + elsif Nkind (Subp_Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Subp_Decl)) + then + null; + + -- Body stub acts as spec + + elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub + and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) + then + null; + + -- Subprogram + + elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then + null; + + else + Pragma_Misplaced; + return; + end if; + + Spec_Id := Unique_Defining_Entity (Subp_Decl); + + if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then + Pragma_Misplaced; + return; + end if; + + -- Chain the pragma on the contract for completeness + + Add_Contract_Item (N, Spec_Id); + + -- The legality checks of pragma Volatile_Function are affected by + -- the SPARK mode in effect. Analyze all pragmas in a specific + -- order. + + Analyze_If_Present (Pragma_SPARK_Mode); + + -- A pragma that applies to a Ghost entity becomes Ghost for the + -- purposes of legality checks and removal of ignored Ghost code. + + Mark_Pragma_As_Ghost (N, Spec_Id); + + -- A volatile function cannot override a non-volatile function + -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed + -- in New_Overloaded_Entity, however at that point the pragma has + -- not been processed yet. + + Over_Id := Overridden_Operation (Spec_Id); + + if Present (Over_Id) + and then not Is_Volatile_Function (Over_Id) + then + Error_Msg_N + ("incompatible volatile function values in effect", Spec_Id); + + Error_Msg_Sloc := Sloc (Over_Id); + Error_Msg_N + ("\& declared # with Volatile_Function value `False`", + Spec_Id); + + Error_Msg_Sloc := Sloc (Spec_Id); + Error_Msg_N + ("\overridden # with Volatile_Function value `True`", + Spec_Id); + end if; + + -- Analyze the Boolean expression (if any) + + if Present (Arg1) then + Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); + end if; + end Volatile_Function; ---------------------- -- Warning_As_Error -- @@ -22450,16 +23077,23 @@ package body Sem_Prag is -- Local variables - GM : constant Ghost_Mode_Type := Ghost_Mode; - Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N); - Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl); + Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + Restore_Scope : Boolean := False; -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part begin + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; + -- Set the Ghost mode in effect from the pragma. Due to the delayed -- analysis of the pragma, the Ghost mode at point of declaration and -- point of analysis may not necessarely be the same. Use the mode in @@ -22500,11 +23134,9 @@ package body Sem_Prag is -- subprogram subject to pragma Inline_Always. Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); + Ghost_Mode := Save_Ghost_Mode; - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Set_Is_Analyzed_Pragma (N); end Analyze_Pre_Post_Condition_In_Decl_Part; ------------------------------------------ @@ -22581,17 +23213,19 @@ package body Sem_Prag is -- 1) Both items denote null -- 2) Dep_Item denotes null and Ref_Item is Empty (special case) -- 3) Both items denote attribute 'Result - -- 4) Both items denote the same formal parameter - -- 5) Both items denote the same object - -- 6) Dep_Item is an abstract state with visible null refinement + -- 4) Both items denote the same object + -- 5) Both items denote the same formal parameter + -- 6) Both items denote the same current instance of a type + -- 7) Both items denote the same discriminant + -- 8) Dep_Item is an abstract state with visible null refinement -- and Ref_Item denotes null. - -- 7) Dep_Item is an abstract state with visible null refinement + -- 9) Dep_Item is an abstract state with visible null refinement -- and Ref_Item is Empty (special case). - -- 8) Dep_Item is an abstract state with visible non-null + -- 10) Dep_Item is an abstract state with visible non-null -- refinement and Ref_Item denotes one of its constituents. - -- 9) Dep_Item is an abstract state without a visible refinement + -- 11) Dep_Item is an abstract state without a visible refinement -- and Ref_Item denotes the same state. - -- When scenario 8 is in effect, the entity of the abstract state + -- When scenario 10 is in effect, the entity of the abstract state -- denoted by Dep_Item is added to list Refined_States. procedure Record_Item (Item_Id : Entity_Id); @@ -22639,9 +23273,9 @@ package body Sem_Prag is Item_Id := Available_View (Entity_Of (Item)); - return Ekind (Item_Id) = E_Abstract_State - and then Has_Null_Refinement (Item_Id); - + return + Ekind (Item_Id) = E_Abstract_State + and then Has_Null_Refinement (Item_Id); else return False; end if; @@ -22678,7 +23312,8 @@ package body Sem_Prag is then Matched := True; - -- Abstract states, formal parameters and objects + -- Abstract states, current instances of concurrent types, + -- discriminants, formal parameters and objects. elsif Is_Entity_Name (Dep_Item) then @@ -22726,7 +23361,8 @@ package body Sem_Prag is Matched := True; end if; - -- A formal parameter or an object matches itself + -- A current instance of a concurrent type, discriminant, + -- formal parameter or an object matches itself. elsif Is_Entity_Name (Ref_Item) and then Entity_Of (Ref_Item) = Dep_Item_Id @@ -22744,7 +23380,7 @@ package body Sem_Prag is procedure Record_Item (Item_Id : Entity_Id) is begin if not Contains (Matched_Items, Item_Id) then - Add_Item (Item_Id, Matched_Items); + Append_New_Elmt (Item_Id, Matched_Items); end if; end Record_Item; @@ -22925,8 +23561,8 @@ package body Sem_Prag is if not Clause_Matched then SPARK_Msg_NE - ("dependence clause of subprogram & has no matching refinement " - & "in body", Dep_Clause, Spec_Id); + (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no " + & "matching refinement in body"), Dep_Clause, Spec_Id); end if; end Check_Dependency_Clause; @@ -23243,7 +23879,7 @@ package body Sem_Prag is -- Local variables - Body_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N); + Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); Errors : constant Nat := Serious_Errors_Detected; Clause : Node_Id; @@ -23254,10 +23890,20 @@ package body Sem_Prag is -- Start of processing for Analyze_Refined_Depends_In_Decl_Part begin - if Nkind (Body_Decl) = N_Subprogram_Body_Stub then - Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl); - else - Spec_Id := Corresponding_Spec (Body_Decl); + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; + + Spec_Id := Unique_Defining_Entity (Body_Decl); + + -- Use the anonymous object as the proper spec when Refined_Depends + -- applies to the body of a single task type. The object carries the + -- proper Chars as well as all non-refined versions of pragmas. + + if Is_Single_Concurrent_Type (Spec_Id) then + Spec_Id := Anonymous_Object (Spec_Id); end if; Depends := Get_Pragma (Spec_Id, Pragma_Depends); @@ -23267,9 +23913,9 @@ package body Sem_Prag is if No (Depends) then SPARK_Msg_NE - ("useless refinement, declaration of subprogram & lacks aspect or " - & "pragma Depends", N, Spec_Id); - return; + (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram " + & "& lacks aspect or pragma Depends"), N, Spec_Id); + goto Leave; end if; Deps := Expression (Get_Argument (Depends, Spec_Id)); @@ -23281,9 +23927,9 @@ package body Sem_Prag is if Nkind (Deps) = N_Null then SPARK_Msg_NE - ("useless refinement, subprogram & does not depend on abstract " - & "state with visible refinement", N, Spec_Id); - return; + (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not " + & "depend on abstract state with visible refinement"), N, Spec_Id); + goto Leave; end if; -- Analyze Refined_Depends as if it behaved as a regular pragma Depends. @@ -23328,7 +23974,7 @@ package body Sem_Prag is -- this is a tree altering activity similar to expansion. if ASIS_Mode then - return; + goto Leave; end if; -- Multiple dependency clauses appear as component associations of an @@ -23368,6 +24014,9 @@ package body Sem_Prag is Report_Extra_Clauses; end if; end if; + + <<Leave>> + Set_Is_Analyzed_Pragma (N); end Analyze_Refined_Depends_In_Decl_Part; ----------------------------------------- @@ -23408,6 +24057,9 @@ package body Sem_Prag is Spec_Id : Entity_Id; -- The entity of the subprogram subject to pragma Refined_Global + States : Elist_Id := No_Elist; + -- A list of all states with visible refinement found in pragma Global + procedure Check_In_Out_States; -- Determine whether the corresponding Global pragma mentions In_Out -- states with visible refinement and if so, ensure that one of the @@ -23535,15 +24187,24 @@ package body Sem_Prag is -- A pair of one Input and one Output constituent is a valid -- completion. - elsif In_Seen and then Out_Seen then + elsif In_Seen and Out_Seen then null; -- A single Output constituent is a valid completion only when -- some of the other constituents are missing (SPARK RM 7.2.4(5)). - elsif Has_Missing and then Out_Seen then + elsif Out_Seen and Has_Missing then null; + -- The state lacks a completion + + elsif not In_Seen and not In_Out_Seen and not Out_Seen then + SPARK_Msg_NE + ("missing global refinement of state &", N, State_Id); + + -- Otherwise the state has a malformed completion where at least + -- one of the constituents has a different mode. + else SPARK_Msg_NE ("global refinement of state & redefines the mode of its " @@ -23908,23 +24569,26 @@ package body Sem_Prag is begin -- When the state or object acts as a constituent of another -- state with a visible refinement, collect it for the state - -- completeness checks performed later on. + -- completeness checks performed later on. Note that the item + -- acts as a constituent only when the encapsulating state is + -- present in pragma Global. if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable) and then Present (Encapsulating_State (Item_Id)) and then Has_Visible_Refinement (Encapsulating_State (Item_Id)) + and then Contains (States, Encapsulating_State (Item_Id)) then if Global_Mode = Name_Input then - Add_Item (Item_Id, In_Constits); + Append_New_Elmt (Item_Id, In_Constits); elsif Global_Mode = Name_In_Out then - Add_Item (Item_Id, In_Out_Constits); + Append_New_Elmt (Item_Id, In_Out_Constits); elsif Global_Mode = Name_Output then - Add_Item (Item_Id, Out_Constits); + Append_New_Elmt (Item_Id, Out_Constits); elsif Global_Mode = Name_Proof_In then - Add_Item (Item_Id, Proof_In_Constits); + Append_New_Elmt (Item_Id, Proof_In_Constits); end if; -- When not a constituent, ensure that both occurrences of the @@ -24057,6 +24721,8 @@ package body Sem_Prag is Has_Null_State := True; elsif Has_Non_Null_Refinement (Item_Id) then + Append_New_Elmt (Item_Id, States); + if Item_Mode = Name_Input then Has_In_State := True; elsif Item_Mode = Name_In_Out then @@ -24072,13 +24738,13 @@ package body Sem_Prag is -- Add the item to the proper list if Item_Mode = Name_Input then - Add_Item (Item_Id, In_Items); + Append_New_Elmt (Item_Id, In_Items); elsif Item_Mode = Name_In_Out then - Add_Item (Item_Id, In_Out_Items); + Append_New_Elmt (Item_Id, In_Out_Items); elsif Item_Mode = Name_Output then - Add_Item (Item_Id, Out_Items); + Append_New_Elmt (Item_Id, Out_Items); elsif Item_Mode = Name_Proof_In then - Add_Item (Item_Id, Proof_In_Items); + Append_New_Elmt (Item_Id, Proof_In_Items); end if; end Collect_Global_Item; @@ -24212,17 +24878,27 @@ package body Sem_Prag is -- Local variables - Body_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N); + Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); Errors : constant Nat := Serious_Errors_Detected; Items : Node_Id; -- Start of processing for Analyze_Refined_Global_In_Decl_Part begin - if Nkind (Body_Decl) = N_Subprogram_Body_Stub then - Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl); - else - Spec_Id := Corresponding_Spec (Body_Decl); + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; + + Spec_Id := Unique_Defining_Entity (Body_Decl); + + -- Use the anonymous object as the proper spec when Refined_Global + -- applies to the body of a single task type. The object carries the + -- proper Chars as well as all non-refined versions of pragmas. + + if Is_Single_Concurrent_Type (Spec_Id) then + Spec_Id := Anonymous_Object (Spec_Id); end if; Global := Get_Pragma (Spec_Id, Pragma_Global); @@ -24233,9 +24909,9 @@ package body Sem_Prag is if No (Global) then SPARK_Msg_NE - ("useless refinement, declaration of subprogram & lacks aspect or " - & "pragma Global", N, Spec_Id); - return; + (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram " + & "& lacks aspect or pragma Global"), N, Spec_Id); + goto Leave; end if; -- Extract all relevant items from the corresponding Global pragma @@ -24266,9 +24942,10 @@ package body Sem_Prag is and then not Has_Null_State then SPARK_Msg_NE - ("useless refinement, subprogram & does not depend on abstract " - & "state with visible refinement", N, Spec_Id); - return; + (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not " + & "depend on abstract state with visible refinement"), + N, Spec_Id); + goto Leave; -- The global refinement of inputs and outputs cannot be null when -- the corresponding Global pragma contains at least one item except @@ -24283,9 +24960,9 @@ package body Sem_Prag is and then not Has_Null_State then SPARK_Msg_NE - ("refinement cannot be null, subprogram & has global items", - N, Spec_Id); - return; + (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has " + & "global items"), N, Spec_Id); + goto Leave; end if; end if; @@ -24336,13 +25013,19 @@ package body Sem_Prag is if Serious_Errors_Detected = Errors then Report_Extra_Constituents; end if; + + <<Leave>> + Set_Is_Analyzed_Pragma (N); end Analyze_Refined_Global_In_Decl_Part; ---------------------------------------- -- Analyze_Refined_State_In_Decl_Part -- ---------------------------------------- - procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id) is + procedure Analyze_Refined_State_In_Decl_Part + (N : Node_Id; + Freeze_Id : Entity_Id := Empty) + is Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N); Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl); @@ -24360,6 +25043,10 @@ package body Sem_Prag is -- A list that contains all constituents processed so far. The list is -- used to detect multiple uses of the same constituent. + Freeze_Posted : Boolean := False; + -- A flag that controls the output of a freezing-related error (see use + -- below). + Refined_States_Seen : Elist_Id := No_Elist; -- A list that contains all refined states processed so far. The list is -- used to detect duplicate refinements. @@ -24367,16 +25054,9 @@ package body Sem_Prag is procedure Analyze_Refinement_Clause (Clause : Node_Id); -- Perform full analysis of a single refinement clause - function Collect_Body_States (Pack_Id : Entity_Id) return Elist_Id; - -- Gather the entities of all abstract states and objects declared in - -- the body state space of package Pack_Id. - procedure Report_Unrefined_States (States : Elist_Id); -- Emit errors for all unrefined abstract states found in list States - procedure Report_Unused_States (States : Elist_Id); - -- Emit errors for all unused states found in list States - ------------------------------- -- Analyze_Refinement_Clause -- ------------------------------- @@ -24419,7 +25099,7 @@ package body Sem_Prag is -- should be set when the property applies to the refined state. If -- this is not the case, emit an error message. - procedure Check_Matching_State; + procedure Match_State; -- Determine whether the state being refined appears in list -- Available_States. Emit an error when attempting to re-refine the -- state or when the state is not defined in the package declaration, @@ -24433,26 +25113,21 @@ package body Sem_Prag is ------------------------- procedure Analyze_Constituent (Constit : Node_Id) is - procedure Check_Ghost_Constituent (Constit_Id : Entity_Id); - -- Verify that the constituent Constit_Id is a Ghost entity if the - -- abstract state being refined is also Ghost. If this is the case - -- verify that the Ghost policy in effect at the point of state - -- and constituent declaration is the same. - - procedure Check_Matching_Constituent (Constit_Id : Entity_Id); + procedure Match_Constituent (Constit_Id : Entity_Id); -- Determine whether constituent Constit denoted by its entity - -- Constit_Id appears in Hidden_States. Emit an error when the + -- Constit_Id appears in Body_States. Emit an error when the -- constituent is not a valid hidden state of the related package -- or when it is used more than once. Otherwise remove the - -- constituent from Hidden_States. + -- constituent from Body_States. - -------------------------------- - -- Check_Matching_Constituent -- - -------------------------------- + ----------------------- + -- Match_Constituent -- + ----------------------- - procedure Check_Matching_Constituent (Constit_Id : Entity_Id) is + procedure Match_Constituent (Constit_Id : Entity_Id) is procedure Collect_Constituent; - -- Add constituent Constit_Id to the refinements of State_Id + -- Verify the legality of constituent Constit_Id and add it to + -- the refinements of State_Id. ------------------------- -- Collect_Constituent -- @@ -24460,10 +25135,68 @@ package body Sem_Prag is procedure Collect_Constituent is begin + if Is_Ghost_Entity (State_Id) then + if Is_Ghost_Entity (Constit_Id) then + + -- The Ghost policy in effect at the point of abstract + -- state declaration and constituent must match + -- (SPARK RM 6.9(16)). + + if Is_Checked_Ghost_Entity (State_Id) + and then Is_Ignored_Ghost_Entity (Constit_Id) + then + Error_Msg_Sloc := Sloc (Constit); + + SPARK_Msg_N + ("incompatible ghost policies in effect", State); + SPARK_Msg_NE + ("\abstract state & declared with ghost policy " + & "Check", State, State_Id); + SPARK_Msg_NE + ("\constituent & declared # with ghost policy " + & "Ignore", State, Constit_Id); + + elsif Is_Ignored_Ghost_Entity (State_Id) + and then Is_Checked_Ghost_Entity (Constit_Id) + then + Error_Msg_Sloc := Sloc (Constit); + + SPARK_Msg_N + ("incompatible ghost policies in effect", State); + SPARK_Msg_NE + ("\abstract state & declared with ghost policy " + & "Ignore", State, State_Id); + SPARK_Msg_NE + ("\constituent & declared # with ghost policy " + & "Check", State, Constit_Id); + end if; + + -- A constituent of a Ghost abstract state must be a + -- Ghost entity (SPARK RM 7.2.2(12)). + + else + SPARK_Msg_NE + ("constituent of ghost state & must be ghost", + Constit, State_Id); + end if; + end if; + + -- A synchronized state must be refined by a synchronized + -- object or another synchronized state (SPARK RM 9.6). + + if Is_Synchronized_State (State_Id) + and then not Is_Synchronized_Object (Constit_Id) + and then not Is_Synchronized_State (Constit_Id) + then + SPARK_Msg_NE + ("constituent of synchronized state & must be " + & "synchronized", Constit, State_Id); + end if; + -- Add the constituent to the list of processed items to aid -- with the detection of duplicates. - Add_Item (Constit_Id, Constituents_Seen); + Append_New_Elmt (Constit_Id, Constituents_Seen); -- Collect the constituent in the list of refinement items -- and establish a relation between the refined state and @@ -24506,7 +25239,7 @@ package body Sem_Prag is State_Elmt : Elmt_Id; - -- Start of processing for Check_Matching_Constituent + -- Start of processing for Match_Constituent begin -- Detect a duplicate use of a constituent @@ -24521,7 +25254,6 @@ package body Sem_Prag is if Present (Encapsulating_State (Constit_Id)) then if Encapsulating_State (Constit_Id) = State_Id then - Check_Ghost_Constituent (Constit_Id); Remove (Part_Of_Constits, Constit_Id); Collect_Constituent; @@ -24534,8 +25266,8 @@ package body Sem_Prag is ("& cannot act as constituent of state %", Constit, Constit_Id); SPARK_Msg_NE - ("\Part_Of indicator specifies & as encapsulating " - & "state", Constit, Encapsulating_State (Constit_Id)); + ("\Part_Of indicator specifies encapsulator &", + Constit, Encapsulating_State (Constit_Id)); end if; -- The only other source of legal constituents is the body @@ -24550,7 +25282,6 @@ package body Sem_Prag is -- been encountered. if Node (State_Elmt) = Constit_Id then - Check_Ghost_Constituent (Constit_Id); Remove_Elmt (Body_States, State_Elmt); Collect_Constituent; return; @@ -24580,60 +25311,7 @@ package body Sem_Prag is & "hidden state of package %", Constit, Constit_Id); end if; end if; - end Check_Matching_Constituent; - - ----------------------------- - -- Check_Ghost_Constituent -- - ----------------------------- - - procedure Check_Ghost_Constituent (Constit_Id : Entity_Id) is - begin - if Is_Ghost_Entity (State_Id) then - if Is_Ghost_Entity (Constit_Id) then - - -- The Ghost policy in effect at the point of abstract - -- state declaration and constituent must match - -- (SPARK RM 6.9(16)). - - if Is_Checked_Ghost_Entity (State_Id) - and then Is_Ignored_Ghost_Entity (Constit_Id) - then - Error_Msg_Sloc := Sloc (Constit); - - SPARK_Msg_N - ("incompatible ghost policies in effect", State); - SPARK_Msg_NE - ("\abstract state & declared with ghost policy " - & "Check", State, State_Id); - SPARK_Msg_NE - ("\constituent & declared # with ghost policy " - & "Ignore", State, Constit_Id); - - elsif Is_Ignored_Ghost_Entity (State_Id) - and then Is_Checked_Ghost_Entity (Constit_Id) - then - Error_Msg_Sloc := Sloc (Constit); - - SPARK_Msg_N - ("incompatible ghost policies in effect", State); - SPARK_Msg_NE - ("\abstract state & declared with ghost policy " - & "Ignore", State, State_Id); - SPARK_Msg_NE - ("\constituent & declared # with ghost policy " - & "Check", State, Constit_Id); - end if; - - -- A constituent of a Ghost abstract state must be a Ghost - -- entity (SPARK RM 7.2.2(12)). - - else - SPARK_Msg_NE - ("constituent of ghost state & must be ghost", - Constit, State_Id); - end if; - end if; - end Check_Ghost_Constituent; + end Match_Constituent; -- Local variables @@ -24687,11 +25365,55 @@ package body Sem_Prag is if Is_Entity_Name (Constit) then Constit_Id := Entity_Of (Constit); - if Ekind_In (Constit_Id, E_Abstract_State, - E_Constant, - E_Variable) + -- When a constituent is declared after a subprogram body + -- that caused "freezing" of the related contract where + -- pragma Refined_State resides, the constituent appears + -- undefined and carries Any_Id as its entity. + + -- package body Pack + -- with Refined_State => (State => Constit) + -- is + -- procedure Proc + -- with Refined_Global => (Input => Constit) + -- is + -- ... + -- end Proc; + + -- Constit : ...; + -- end Pack; + + if Constit_Id = Any_Id then + SPARK_Msg_NE ("& is undefined", Constit, Constit_Id); + + -- Emit a specialized info message when the contract of + -- the related package body was "frozen" by another body. + -- Note that it is not possible to precisely identify why + -- the constituent is undefined because it is not visible + -- when pragma Refined_State is analyzed. This message is + -- a reasonable approximation. + + if Present (Freeze_Id) and then not Freeze_Posted then + Freeze_Posted := True; + + Error_Msg_Name_1 := Chars (Body_Id); + Error_Msg_Sloc := Sloc (Freeze_Id); + SPARK_Msg_NE + ("body & declared # freezes the contract of %", + N, Freeze_Id); + SPARK_Msg_N + ("\all constituents must be declared before body #", + N); + end if; + + -- The constituent is a valid state or object + + elsif Ekind_In (Constit_Id, E_Abstract_State, + E_Constant, + E_Variable) then - Check_Matching_Constituent (Constit_Id); + Match_Constituent (Constit_Id); + + -- Otherwise the constituent is illegal else SPARK_Msg_NE @@ -24741,11 +25463,11 @@ package body Sem_Prag is end if; end Check_External_Property; - -------------------------- - -- Check_Matching_State -- - -------------------------- + ----------------- + -- Match_State -- + ----------------- - procedure Check_Matching_State is + procedure Match_State is State_Elmt : Elmt_Id; begin @@ -24770,7 +25492,7 @@ package body Sem_Prag is -- been refined. if Node (State_Elmt) = State_Id then - Add_Item (State_Id, Refined_States_Seen); + Append_New_Elmt (State_Id, Refined_States_Seen); Remove_Elmt (Available_States, State_Elmt); return; end if; @@ -24785,7 +25507,7 @@ package body Sem_Prag is SPARK_Msg_NE ("cannot refine state, & is not defined in package %", State, State_Id); - end Check_Matching_State; + end Match_State; -------------------------------- -- Report_Unused_Constituents -- @@ -24868,14 +25590,20 @@ package body Sem_Prag is if Is_Entity_Name (State) then State_Id := Entity_Of (State); + -- When the abstract state is undefined, it appears as Any_Id. Do + -- not continue with the analysis of the clause. + + if State_Id = Any_Id then + return; + -- Catch any attempts to re-refine a state or refine a state that -- is not defined in the package declaration. - if Ekind (State_Id) = E_Abstract_State then - Check_Matching_State; + elsif Ekind (State_Id) = E_Abstract_State then + Match_State; + else - SPARK_Msg_NE - ("& must denote an abstract state", State, State_Id); + SPARK_Msg_NE ("& must denote abstract state", State, State_Id); return; end if; @@ -25005,104 +25733,6 @@ package body Sem_Prag is Report_Unused_Constituents (Part_Of_Constits); end Analyze_Refinement_Clause; - ------------------------- - -- Collect_Body_States -- - ------------------------- - - function Collect_Body_States (Pack_Id : Entity_Id) return Elist_Id is - Result : Elist_Id := No_Elist; - -- A list containing all body states of Pack_Id - - procedure Collect_Visible_States (Pack_Id : Entity_Id); - -- Gather the entities of all abstract states and objects declared in - -- the visible state space of package Pack_Id. - - ---------------------------- - -- Collect_Visible_States -- - ---------------------------- - - procedure Collect_Visible_States (Pack_Id : Entity_Id) is - Item_Id : Entity_Id; - - begin - -- Traverse the entity chain of the package and inspect all - -- visible items. - - Item_Id := First_Entity (Pack_Id); - while Present (Item_Id) and then not In_Private_Part (Item_Id) loop - - -- Do not consider internally generated items as those cannot - -- be named and participate in refinement. - - if not Comes_From_Source (Item_Id) then - null; - - elsif Ekind (Item_Id) = E_Abstract_State then - Add_Item (Item_Id, Result); - - -- Do not consider constants or variables that map generic - -- formals to their actuals, as the formals cannot be named - -- from the outside and participate in refinement. - - elsif Ekind_In (Item_Id, E_Constant, E_Variable) - and then No (Corresponding_Generic_Association - (Declaration_Node (Item_Id))) - then - Add_Item (Item_Id, Result); - - -- Recursively gather the visible states of a nested package - - elsif Ekind (Item_Id) = E_Package then - Collect_Visible_States (Item_Id); - end if; - - Next_Entity (Item_Id); - end loop; - end Collect_Visible_States; - - -- Local variables - - Pack_Body : constant Node_Id := - Declaration_Node (Body_Entity (Pack_Id)); - Decl : Node_Id; - Item_Id : Entity_Id; - - -- Start of processing for Collect_Body_States - - begin - -- Inspect the declarations of the body looking for source objects, - -- packages and package instantiations. - - Decl := First (Declarations (Pack_Body)); - while Present (Decl) loop - - -- Capture source objects as internally generated temporaries - -- cannot be named and participate in refinement. - - if Nkind (Decl) = N_Object_Declaration then - Item_Id := Defining_Entity (Decl); - - if Comes_From_Source (Item_Id) then - Add_Item (Item_Id, Result); - end if; - - -- Capture the visible abstract states and objects of a source - -- package [instantiation]. - - elsif Nkind (Decl) = N_Package_Declaration then - Item_Id := Defining_Entity (Decl); - - if Comes_From_Source (Item_Id) then - Collect_Visible_States (Item_Id); - end if; - end if; - - Next (Decl); - end loop; - - return Result; - end Collect_Body_States; - ----------------------------- -- Report_Unrefined_States -- ----------------------------- @@ -25122,61 +25752,6 @@ package body Sem_Prag is end if; end Report_Unrefined_States; - -------------------------- - -- Report_Unused_States -- - -------------------------- - - procedure Report_Unused_States (States : Elist_Id) is - Posted : Boolean := False; - State_Elmt : Elmt_Id; - State_Id : Entity_Id; - - begin - if Present (States) then - State_Elmt := First_Elmt (States); - while Present (State_Elmt) loop - State_Id := Node (State_Elmt); - - -- Constants are part of the hidden state of a package, but the - -- compiler cannot determine whether they have variable input - -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a - -- hidden state. Do not emit an error when a constant does not - -- participate in a state refinement, even though it acts as a - -- hidden state. - - if Ekind (State_Id) = E_Constant then - null; - - -- Generate an error message of the form: - - -- body of package ... has unused hidden states - -- abstract state ... defined at ... - -- variable ... defined at ... - - else - if not Posted then - Posted := True; - SPARK_Msg_N - ("body of package & has unused hidden states", Body_Id); - end if; - - Error_Msg_Sloc := Sloc (State_Id); - - if Ekind (State_Id) = E_Abstract_State then - SPARK_Msg_NE - ("\abstract state & defined #", Body_Id, State_Id); - - else - pragma Assert (Ekind (State_Id) = E_Variable); - SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id); - end if; - end if; - - Next_Elmt (State_Elmt); - end loop; - end if; - end Report_Unused_States; - -- Local declarations Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); @@ -25185,7 +25760,11 @@ package body Sem_Prag is -- Start of processing for Analyze_Refined_State_In_Decl_Part begin - Set_Analyzed (N); + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; -- Replicate the abstract states declared by the package because the -- matching algorithm will consume states. @@ -25196,7 +25775,7 @@ package body Sem_Prag is -- state space of the package body. These items must be utilized as -- constituents in a state refinement. - Body_States := Collect_Body_States (Spec_Id); + Body_States := Collect_Body_States (Body_Id); -- Multiple non-null state refinements appear as an aggregate @@ -25228,7 +25807,9 @@ package body Sem_Prag is -- Ensure that all abstract states and objects declared in the body -- state space of the related package are utilized as constituents. - Report_Unused_States (Body_States); + Report_Unused_Body_States (Body_Id, Body_States); + + Set_Is_Analyzed_Pragma (N); end Analyze_Refined_State_In_Decl_Part; ------------------------------------ @@ -25236,8 +25817,8 @@ package body Sem_Prag is ------------------------------------ procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is - Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N); - Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl); + Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id); -- Preanalyze one of the optional arguments "Requires" or "Ensures" @@ -25281,6 +25862,12 @@ package body Sem_Prag is -- Start of processing for Analyze_Test_Case_In_Decl_Part begin + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; + -- Ensure that the formal parameters are visible when analyzing all -- clauses. This falls out of the general rule of aspects pertaining -- to subprogram declarations. @@ -25307,6 +25894,8 @@ package body Sem_Prag is -- subprogram subject to pragma Inline_Always. Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); + + Set_Is_Analyzed_Pragma (N); end Analyze_Test_Case_In_Decl_Part; ---------------- @@ -25745,7 +26334,7 @@ package body Sem_Prag is begin -- Since a constituent may be part of a larger constituent set, climb - -- the encapsulated state chain looking for a state that appears in + -- the encapsulating state chain looking for a state that appears in -- the same context. State_Id := Encapsulating_State (Constit_Id); @@ -25863,9 +26452,9 @@ package body Sem_Prag is else if Is_Input then - Add_Item (Item, Subp_Inputs); + Append_New_Elmt (Item, Subp_Inputs); else - Add_Item (Item, Subp_Outputs); + Append_New_Elmt (Item, Subp_Outputs); end if; end if; end Collect_Dependency_Item; @@ -25914,11 +26503,11 @@ package body Sem_Prag is procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is begin if Nam_In (Mode, Name_In_Out, Name_Input) then - Add_Item (Item, Subp_Inputs); + Append_New_Elmt (Item, Subp_Inputs); end if; if Nam_In (Mode, Name_In_Out, Name_Output) then - Add_Item (Item, Subp_Outputs); + Append_New_Elmt (Item, Subp_Outputs); end if; end Collect_Global_Item; @@ -25973,13 +26562,13 @@ package body Sem_Prag is -- Local variables Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); - Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); Clause : Node_Id; Clauses : Node_Id; Depends : Node_Id; Formal : Entity_Id; Global : Node_Id; - List : Node_Id; + Typ : Entity_Id; -- Start of processing for Collect_Subprogram_Inputs_Outputs @@ -25994,14 +26583,14 @@ package body Sem_Prag is E_In_Out_Parameter, E_In_Parameter) then - Add_Item (Formal, Subp_Inputs); + Append_New_Elmt (Formal, Subp_Inputs); end if; if Ekind_In (Formal, E_Generic_In_Out_Parameter, E_In_Out_Parameter, E_Out_Parameter) then - Add_Item (Formal, Subp_Outputs); + Append_New_Elmt (Formal, Subp_Outputs); -- Out parameters can act as inputs when the related type is -- tagged, unconstrained array, unconstrained record or record @@ -26010,17 +26599,20 @@ package body Sem_Prag is if Ekind (Formal) = E_Out_Parameter and then Is_Unconstrained_Or_Tagged_Item (Formal) then - Add_Item (Formal, Subp_Inputs); + Append_New_Elmt (Formal, Subp_Inputs); end if; end if; Next_Entity (Formal); end loop; - -- When processing a subprogram body, look for pragmas Refined_Depends - -- and Refined_Global as they specify the inputs and outputs. + -- When processing an entry, subprogram or task body, look for pragmas + -- Refined_Depends and Refined_Global as they specify the inputs and + -- outputs. - if Ekind (Subp_Id) = E_Subprogram_Body then + if Is_Entry_Body (Subp_Id) + or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body) + then Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends); Global := Get_Pragma (Subp_Id, Pragma_Refined_Global); @@ -26037,21 +26629,7 @@ package body Sem_Prag is if Present (Global) then Global_Seen := True; - List := Expression (Get_Argument (Global, Spec_Id)); - - -- The pragma may not have been analyzed because of the arbitrary - -- declaration order of aspects. Make sure that it is analyzed for - -- the purposes of item extraction. - - if not Analyzed (List) then - if Pragma_Name (Global) = Name_Refined_Global then - Analyze_Refined_Global_In_Decl_Part (Global); - else - Analyze_Global_In_Decl_Part (Global); - end if; - end if; - - Collect_Global_List (List); + Collect_Global_List (Expression (Get_Argument (Global, Spec_Id))); -- When the related subprogram lacks pragma [Refined_]Global, fall back -- to [Refined_]Depends if the caller requests this behavior. Synthesize @@ -26075,6 +26653,45 @@ package body Sem_Prag is Collect_Dependency_Clause (Clauses); end if; end if; + + if Ekind (Scope (Spec_Id)) = E_Protected_Type then + Typ := Scope (Spec_Id); + + -- A single protected type declaration does not have a current + -- instance because the type is technically an object. + + if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then + null; + + -- Otherwise the current instance of the protected type acts as a + -- formal parameter of mode IN for functions and IN OUT for entries + -- and procedures (SPARK RM 6.1.4). + + else + Append_New_Elmt (Typ, Subp_Inputs); + + if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then + Append_New_Elmt (Typ, Subp_Outputs); + end if; + end if; + + elsif Ekind (Spec_Id) = E_Task_Type then + Typ := Spec_Id; + + -- A single task type declaration does not have a current instance + -- because the type is technically an object. + + if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then + null; + + -- Otherwise the current instance of the task type acts as a formal + -- parameter of mode IN OUT (SPARK RM 6.1.4). + + else + Append_New_Elmt (Typ, Subp_Inputs); + Append_New_Elmt (Typ, Subp_Outputs); + end if; + end if; end Collect_Subprogram_Inputs_Outputs; --------------------------------- @@ -26120,17 +26737,15 @@ package body Sem_Prag is end if; end Duplication_Error; - ---------------------------------- - -- Find_Related_Package_Or_Body -- - ---------------------------------- + -------------------------- + -- Find_Related_Context -- + -------------------------- - function Find_Related_Package_Or_Body + function Find_Related_Context (Prag : Node_Id; Do_Checks : Boolean := False) return Node_Id is - Context : constant Node_Id := Parent (Prag); - Prag_Nam : constant Name_Id := Pragma_Name (Prag); - Stmt : Node_Id; + Stmt : Node_Id; begin Stmt := Prev (Prag); @@ -26139,7 +26754,7 @@ package body Sem_Prag is -- Skip prior pragmas, but check for duplicates if Nkind (Stmt) = N_Pragma then - if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then + if Do_Checks and then Pragma_Name (Stmt) = Pragma_Name (Prag) then Duplication_Error (Prag => Prag, Prev => Stmt); @@ -26148,23 +26763,17 @@ package body Sem_Prag is -- Skip internally generated code elsif not Comes_From_Source (Stmt) then - if Nkind (Stmt) = N_Subprogram_Declaration then - - -- The subprogram declaration is an internally generated spec - -- for an expression function. - if Nkind (Original_Node (Stmt)) = N_Expression_Function then - return Stmt; + -- The anonymous object created for a single concurrent type is a + -- suitable context. - -- The subprogram is actually an instance housed within an - -- anonymous wrapper package. - - elsif Present (Generic_Parent (Specification (Stmt))) then - return Stmt; - end if; + if Nkind (Stmt) = N_Object_Declaration + and then Is_Single_Concurrent_Object (Defining_Entity (Stmt)) + then + return Stmt; end if; - -- Return the current source construct which is illegal + -- Return the current source construct else return Stmt; @@ -26173,46 +26782,14 @@ package body Sem_Prag is Prev (Stmt); end loop; - -- If we fall through, then the pragma was either the first declaration - -- or it was preceded by other pragmas and no source constructs. - - -- The pragma is associated with a package. The immediate context in - -- this case is the specification of the package. - - if Nkind (Context) = N_Package_Specification then - return Parent (Context); - - -- The pragma appears in the declarations of a package body - - elsif Nkind (Context) = N_Package_Body then - return Context; - - -- The pragma appears in the statements of a package body - - elsif Nkind (Context) = N_Handled_Sequence_Of_Statements - and then Nkind (Parent (Context)) = N_Package_Body - then - return Parent (Context); - - -- The pragma is a byproduct of aspect expansion, return the related - -- context of the original aspect. This case has a lower priority as - -- the above circuitry pinpoints precisely the related context. - - elsif Present (Corresponding_Aspect (Prag)) then - return Parent (Corresponding_Aspect (Prag)); - - -- No candidate packge [body] found - - else - return Empty; - end if; - end Find_Related_Package_Or_Body; + return Empty; + end Find_Related_Context; - ------------------------------------- - -- Find_Related_Subprogram_Or_Body -- - ------------------------------------- + -------------------------------------- + -- Find_Related_Declaration_Or_Body -- + -------------------------------------- - function Find_Related_Subprogram_Or_Body + function Find_Related_Declaration_Or_Body (Prag : Node_Id; Do_Checks : Boolean := False) return Node_Id is @@ -26255,7 +26832,7 @@ package body Sem_Prag is Name_Refined_Post); -- Refinement pragmas must be associated with a subprogram body [stub] - -- Start of processing for Find_Related_Subprogram_Or_Body + -- Start of processing for Find_Related_Declaration_Or_Body begin Stmt := Prev (Prag); @@ -26297,7 +26874,16 @@ package body Sem_Prag is -- Skip internally generated code elsif not Comes_From_Source (Stmt) then - if Nkind (Stmt) = N_Subprogram_Declaration then + + -- The anonymous object created for a single concurrent type is a + -- suitable context. + + if Nkind (Stmt) = N_Object_Declaration + and then Is_Single_Concurrent_Object (Defining_Entity (Stmt)) + then + return Stmt; + + elsif Nkind (Stmt) = N_Subprogram_Declaration then -- The subprogram declaration is an internally generated spec -- for an expression function. @@ -26331,6 +26917,11 @@ package body Sem_Prag is if Nkind (Context) = N_Compilation_Unit_Aux then return Unit (Parent (Context)); + -- The pragma appears inside the declarations of an entry body + + elsif Nkind (Context) = N_Entry_Body then + return Context; + -- The pragma appears inside the statements of a subprogram body. This -- placement is the result of subprogram contract expansion. @@ -26342,6 +26933,11 @@ package body Sem_Prag is elsif Nkind (Context) = N_Subprogram_Body then return Context; + -- The pragma appears inside the declarative part of a task body + + elsif Nkind (Context) = N_Task_Body then + return Context; + -- The pragma is a byproduct of aspect expansion, return the related -- context of the original aspect. This case has a lower priority as -- the above circuitry pinpoints precisely the related context. @@ -26354,7 +26950,95 @@ package body Sem_Prag is else return Empty; end if; - end Find_Related_Subprogram_Or_Body; + end Find_Related_Declaration_Or_Body; + + ---------------------------------- + -- Find_Related_Package_Or_Body -- + ---------------------------------- + + function Find_Related_Package_Or_Body + (Prag : Node_Id; + Do_Checks : Boolean := False) return Node_Id + is + Context : constant Node_Id := Parent (Prag); + Prag_Nam : constant Name_Id := Pragma_Name (Prag); + Stmt : Node_Id; + + begin + Stmt := Prev (Prag); + while Present (Stmt) loop + + -- Skip prior pragmas, but check for duplicates + + if Nkind (Stmt) = N_Pragma then + if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then + Duplication_Error + (Prag => Prag, + Prev => Stmt); + end if; + + -- Skip internally generated code + + elsif not Comes_From_Source (Stmt) then + if Nkind (Stmt) = N_Subprogram_Declaration then + + -- The subprogram declaration is an internally generated spec + -- for an expression function. + + if Nkind (Original_Node (Stmt)) = N_Expression_Function then + return Stmt; + + -- The subprogram is actually an instance housed within an + -- anonymous wrapper package. + + elsif Present (Generic_Parent (Specification (Stmt))) then + return Stmt; + end if; + end if; + + -- Return the current source construct which is illegal + + else + return Stmt; + end if; + + Prev (Stmt); + end loop; + + -- If we fall through, then the pragma was either the first declaration + -- or it was preceded by other pragmas and no source constructs. + + -- The pragma is associated with a package. The immediate context in + -- this case is the specification of the package. + + if Nkind (Context) = N_Package_Specification then + return Parent (Context); + + -- The pragma appears in the declarations of a package body + + elsif Nkind (Context) = N_Package_Body then + return Context; + + -- The pragma appears in the statements of a package body + + elsif Nkind (Context) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (Context)) = N_Package_Body + then + return Parent (Context); + + -- The pragma is a byproduct of aspect expansion, return the related + -- context of the original aspect. This case has a lower priority as + -- the above circuitry pinpoints precisely the related context. + + elsif Present (Corresponding_Aspect (Prag)) then + return Parent (Corresponding_Aspect (Prag)); + + -- No candidate packge [body] found + + else + return Empty; + end if; + end Find_Related_Package_Or_Body; ------------------ -- Get_Argument -- @@ -26584,6 +27268,31 @@ package body Sem_Prag is return Add_Config_Static_String (Arg); end Is_Config_Static_String; + --------------------- + -- Is_CCT_Instance -- + --------------------- + + function Is_CCT_Instance (Ref : Node_Id) return Boolean is + Ref_Id : constant Entity_Id := Entity (Ref); + S : Entity_Id; + + begin + -- Climb the scope chain looking for an enclosing concurrent type that + -- matches the referenced entity. + + S := Current_Scope; + while Present (S) and then S /= Standard_Standard loop + if Ekind_In (S, E_Protected_Type, E_Task_Type) and then S = Ref_Id + then + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end Is_CCT_Instance; + ------------------------------- -- Is_Elaboration_SPARK_Mode -- ------------------------------- @@ -26606,6 +27315,33 @@ package body Sem_Prag is and then Nkind (Parent (Parent (N))) = N_Package_Body; end Is_Elaboration_SPARK_Mode; + ----------------------- + -- Is_Enabled_Pragma -- + ----------------------- + + function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is + Arg : Node_Id; + + begin + if Present (Prag) then + Arg := First (Pragma_Argument_Associations (Prag)); + + if Present (Arg) then + return Is_True (Expr_Value (Get_Pragma_Arg (Arg))); + + -- The lack of a Boolean argument automatically enables the pragma + + else + return True; + end if; + + -- The pragma is missing, therefore it is not enabled + + else + return False; + end if; + end Is_Enabled_Pragma; + ----------------------------------------- -- Is_Non_Significant_Pragma_Reference -- ----------------------------------------- @@ -26618,7 +27354,7 @@ package body Sem_Prag is -- 0 indicates that appearance in any argument is not significant -- +n indicates that appearance as argument n is significant, but all -- other arguments are not significant - -- 9n arguments from n on are significant, before n inisignificant + -- 9n arguments from n on are significant, before n insignificant Sig_Flags : constant array (Pragma_Id) of Int := (Pragma_Abort_Defer => -1, @@ -26648,7 +27384,6 @@ package body Sem_Prag is Pragma_Check_Float_Overflow => 0, Pragma_Check_Name => 0, Pragma_Check_Policy => 0, - Pragma_CIL_Constructor => 0, Pragma_CPP_Class => 0, Pragma_CPP_Constructor => 0, Pragma_CPP_Virtual => 0, @@ -26664,6 +27399,7 @@ package body Sem_Prag is Pragma_Complete_Representation => 0, Pragma_Complex_Representation => 0, Pragma_Component_Alignment => 0, + Pragma_Constant_After_Elaboration => 0, Pragma_Contract_Cases => -1, Pragma_Controlled => 0, Pragma_Convention => 0, @@ -26727,8 +27463,6 @@ package body Sem_Prag is Pragma_Interrupt_Priority => -1, Pragma_Interrupt_State => -1, Pragma_Invariant => -1, - Pragma_Java_Constructor => -1, - Pragma_Java_Interface => -1, Pragma_Keep_Names => 0, Pragma_License => 0, Pragma_Link_With => -1, @@ -26775,6 +27509,7 @@ package body Sem_Prag is Pragma_Pre => -1, Pragma_Precondition => -1, Pragma_Predicate => -1, + Pragma_Predicate_Failure => -1, Pragma_Preelaborable_Initialization => -1, Pragma_Preelaborate => 0, Pragma_Pre_Class => -1, @@ -26849,6 +27584,7 @@ package body Sem_Prag is Pragma_Volatile => 0, Pragma_Volatile_Components => 0, Pragma_Volatile_Full_Access => 0, + Pragma_Volatile_Function => 0, Pragma_Warning_As_Error => 0, Pragma_Warnings => 0, Pragma_Weak_External => 0, @@ -27181,6 +27917,60 @@ package body Sem_Prag is end loop; end Record_Possible_Body_Reference; + ------------------------------------------ + -- Relocate_Pragmas_To_Anonymous_Object -- + ------------------------------------------ + + procedure Relocate_Pragmas_To_Anonymous_Object + (Typ_Decl : Node_Id; + Obj_Decl : Node_Id) + is + Decl : Node_Id; + Def : Node_Id; + Next_Decl : Node_Id; + + begin + if Nkind (Typ_Decl) = N_Protected_Type_Declaration then + Def := Protected_Definition (Typ_Decl); + else + pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration); + Def := Task_Definition (Typ_Decl); + end if; + + -- The concurrent definition has a visible declaration list. Inspect it + -- and relocate all canidate pragmas. + + if Present (Def) and then Present (Visible_Declarations (Def)) then + Decl := First (Visible_Declarations (Def)); + while Present (Decl) loop + + -- Preserve the following declaration for iteration purposes due + -- to possible relocation of a pragma. + + Next_Decl := Next (Decl); + + if Nkind (Decl) = N_Pragma + and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl)) + then + Remove (Decl); + Insert_After (Obj_Decl, Decl); + + -- Skip internally generated code + + elsif not Comes_From_Source (Decl) then + null; + + -- No candidate pragmas are available for relocation + + else + exit; + end if; + + Decl := Next_Decl; + end loop; + end if; + end Relocate_Pragmas_To_Anonymous_Object; + ------------------------------ -- Relocate_Pragmas_To_Body -- ------------------------------ @@ -27409,12 +28199,11 @@ package body Sem_Prag is begin -- If first character is asterisk, this is a link name, and we leave it -- completely unmodified. We also ignore null strings (the latter case - -- happens only in error cases) and no encoding should occur for Java or - -- AAMP interface names. + -- happens only in error cases) and no encoding should occur for AAMP + -- interface names. if Len = 0 or else Get_String_Char (Str, 1) = Get_Char_Code ('*') - or else VM_Target /= No_VM or else AAMP_On_Target then Set_Interface_Name (E, S); diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index 52f6935f8e6..a4e0bd843c0 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -45,6 +45,7 @@ package Sem_Prag is Pragma_Atomic => True, Pragma_Atomic_Components => True, Pragma_Attach_Handler => True, + Pragma_Constant_After_Elaboration => True, Pragma_Contract_Cases => True, Pragma_Convention => True, Pragma_CPU => True, @@ -151,9 +152,19 @@ package Sem_Prag is others => False); -- The following table lists all the implementation-defined pragmas that + -- should apply to the anonymous object produced by the analysis of a + -- single protected or task type. The table should be synchronized with + -- Aspect_On_Anonymous_Object_OK in unit Aspects. + + Pragma_On_Anonymous_Object_OK : constant array (Pragma_Id) of Boolean := + (Pragma_Depends => True, + Pragma_Global => True, + Pragma_Part_Of => True, + others => False); + + -- The following table lists all the implementation-defined pragmas that -- may apply to a body stub (no language defined pragmas apply). The table - -- should be synchronized with Aspect_On_Body_Or_Stub_OK in unit Aspects if - -- the pragmas below implement an aspect. + -- should be synchronized with Aspect_On_Body_Or_Stub_OK in unit Aspects. Pragma_On_Body_Or_Stub_OK : constant array (Pragma_Id) of Boolean := (Pragma_Refined_Depends => True, @@ -171,7 +182,7 @@ package Sem_Prag is -- Analyze procedure for pragma reference node N procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id); - -- Perform full analysis and expansion of delayed pragma Contract_Cases + -- Perform full analysis of delayed pragma Contract_Cases procedure Analyze_Depends_In_Decl_Part (N : Node_Id); -- Perform full analysis of delayed pragma Depends. This routine is also @@ -194,9 +205,11 @@ package Sem_Prag is procedure Analyze_Initializes_In_Decl_Part (N : Node_Id); -- Perform full analysis of delayed pragma Initializes + procedure Analyze_Part_Of_In_Decl_Part (N : Node_Id); + -- Perform full analysis of delayed pragma Part_Of + procedure Analyze_Pre_Post_Condition_In_Decl_Part (N : Node_Id); - -- Perform preanalysis of [refined] precondition or postcondition pragma - -- N that appears on a subprogram declaration or body [stub]. + -- Perform full analysis of pragmas Precondition and Postcondition procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id); -- Preform full analysis of delayed pragma Refined_Depends. This routine @@ -208,8 +221,12 @@ package Sem_Prag is -- uses Analyze_Global_In_Decl_Part as a starting point, then performs -- various consistency checks between Global and Refined_Global. - procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id); - -- Perform full analysis of delayed pragma Refined_State + procedure Analyze_Refined_State_In_Decl_Part + (N : Node_Id; + Freeze_Id : Entity_Id := Empty); + -- Perform full analysis of delayed pragma Refined_State. Freeze_Id denotes + -- the entity of [generic] package body or [generic] subprogram body which + -- caused "freezing" of the related contract where the pragma resides. procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id); -- Perform preanalysis of pragma Test_Case @@ -283,9 +300,10 @@ package Sem_Prag is -- and Subp_Outputs (outputs). The inputs and outputs are gathered from: -- 1) The formal parameters of the subprogram -- 2) The generic formal parameters of the generic subprogram - -- 3) The items of pragma [Refined_]Global + -- 3) The current instance of a concurrent type + -- 4) The items of pragma [Refined_]Global -- or - -- 4) The items of pragma [Refined_]Depends if there is no pragma + -- 5) The items of pragma [Refined_]Depends if there is no pragma -- [Refined_]Global present and flag Synthesize is set to True. -- If the subprogram has no inputs and/or outputs, then the returned list -- is No_Elist. Flag Global_Seen is set when the related subprogram has @@ -311,22 +329,29 @@ package Sem_Prag is -- the pragma is illegal. If flag Do_Checks is set, the routine reports -- duplicate pragmas. - function Find_Related_Subprogram_Or_Body + function Find_Related_Declaration_Or_Body (Prag : Node_Id; Do_Checks : Boolean := False) return Node_Id; - -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global, - -- Refined_Depends, Refined_Global and Refined_Post and attribute 'Result. - -- Find the declaration of the related subprogram [body or stub] subject - -- to pragma Prag. If flag Do_Checks is set, the routine reports duplicate - -- pragmas and detects improper use of refinement pragmas in stand alone - -- expression functions. The returned value depends on the related pragma - -- as follows: - -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding - -- N_Subprogram_Declaration node or if the pragma applies to a stand - -- alone body, the N_Subprogram_Body node or Empty if illegal. - -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield - -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if - -- illegal. + -- Subsidiary to the analysis of pragmas + -- Contract_Cases + -- Depends + -- Extensions_Visible + -- Global + -- Post + -- Post_Class + -- Postcondition + -- Pre + -- Pre_Class + -- Precondition + -- Refined_Depends + -- Refined_Global + -- Refined_Post + -- Test_Case + -- as well as attributes 'Old and 'Result. Find the declaration of the + -- related entry, subprogram or task type [body] subject to pragma Prag. + -- If flag Do_Checks is set, the routine reports duplicate pragmas and + -- detects improper use of refinement pragmas in stand alone expression + -- functions. function Get_Argument (Prag : Node_Id; @@ -363,6 +388,23 @@ package Sem_Prag is -- Determine whether pragma SPARK_Mode appears in the statement part of a -- package body. + function Is_Enabled_Pragma (Prag : Node_Id) return Boolean; + -- Determine whether a Boolean-like SPARK pragma Prag is enabled. To be + -- considered enabled, the pragma must either: + -- * Appear without its Boolean expression + -- * The Boolean expression evaluates to "True" + -- + -- Boolean-like SPARK pragmas differ from pure Boolean Ada pragmas in that + -- their optional Boolean expression must be static and cannot benefit from + -- forward references. The following are Boolean-like SPARK pragmas: + -- Async_Readers + -- Async_Writers + -- Constant_After_Elaboration + -- Effective_Reads + -- Effective_Writes + -- Extensions_Visible + -- Volatile_Function + function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean; -- The node N is a node for an entity and the issue is whether the -- occurrence is a reference for the purposes of giving warnings about @@ -396,6 +438,14 @@ package Sem_Prag is -- Suppress_All at this stage, since it can appear after the unit instead -- of before (actually we allow it to appear anywhere). + procedure Relocate_Pragmas_To_Anonymous_Object + (Typ_Decl : Node_Id; + Obj_Decl : Node_Id); + -- Relocate all pragmas that appear in the visible declarations of task or + -- protected type declaration Typ_Decl after the declaration of anonymous + -- object Obj_Decl. Table Pragmas_On_Anonymous_Object_OK contains the list + -- of candidate pragmas. + procedure Relocate_Pragmas_To_Body (Subp_Body : Node_Id; Target_Body : Node_Id := Empty); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 9492fff6b0d..5ee73a938df 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -57,6 +57,7 @@ with Sem_Aggr; use Sem_Aggr; with Sem_Attr; use Sem_Attr; with Sem_Cat; use Sem_Cat; with Sem_Ch4; use Sem_Ch4; +with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; @@ -251,7 +252,7 @@ package body Sem_Res is (N : Node_Id; Op : Entity_Id; Typ : Entity_Id); - -- An operator can rename another, e.g. in an instantiation. In that + -- An operator can rename another, e.g. in an instantiation. In that -- case, the proper operator node must be constructed and resolved. procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id); @@ -1676,39 +1677,39 @@ package body Sem_Res is -- Use CASE statement or array??? if Is_Binary then - if Op_Name = Name_Op_And then + if Op_Name = Name_Op_And then Kind := N_Op_And; - elsif Op_Name = Name_Op_Or then + elsif Op_Name = Name_Op_Or then Kind := N_Op_Or; - elsif Op_Name = Name_Op_Xor then + elsif Op_Name = Name_Op_Xor then Kind := N_Op_Xor; - elsif Op_Name = Name_Op_Eq then + elsif Op_Name = Name_Op_Eq then Kind := N_Op_Eq; - elsif Op_Name = Name_Op_Ne then + elsif Op_Name = Name_Op_Ne then Kind := N_Op_Ne; - elsif Op_Name = Name_Op_Lt then + elsif Op_Name = Name_Op_Lt then Kind := N_Op_Lt; - elsif Op_Name = Name_Op_Le then + elsif Op_Name = Name_Op_Le then Kind := N_Op_Le; - elsif Op_Name = Name_Op_Gt then + elsif Op_Name = Name_Op_Gt then Kind := N_Op_Gt; - elsif Op_Name = Name_Op_Ge then + elsif Op_Name = Name_Op_Ge then Kind := N_Op_Ge; - elsif Op_Name = Name_Op_Add then + elsif Op_Name = Name_Op_Add then Kind := N_Op_Add; - elsif Op_Name = Name_Op_Subtract then + elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Subtract; - elsif Op_Name = Name_Op_Concat then + elsif Op_Name = Name_Op_Concat then Kind := N_Op_Concat; - elsif Op_Name = Name_Op_Multiply then + elsif Op_Name = Name_Op_Multiply then Kind := N_Op_Multiply; - elsif Op_Name = Name_Op_Divide then + elsif Op_Name = Name_Op_Divide then Kind := N_Op_Divide; - elsif Op_Name = Name_Op_Mod then + elsif Op_Name = Name_Op_Mod then Kind := N_Op_Mod; - elsif Op_Name = Name_Op_Rem then + elsif Op_Name = Name_Op_Rem then Kind := N_Op_Rem; - elsif Op_Name = Name_Op_Expon then + elsif Op_Name = Name_Op_Expon then Kind := N_Op_Expon; else raise Program_Error; @@ -1717,13 +1718,13 @@ package body Sem_Res is -- Unary operators else - if Op_Name = Name_Op_Add then + if Op_Name = Name_Op_Add then Kind := N_Op_Plus; - elsif Op_Name = Name_Op_Subtract then + elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Minus; - elsif Op_Name = Name_Op_Abs then + elsif Op_Name = Name_Op_Abs then Kind := N_Op_Abs; - elsif Op_Name = Name_Op_Not then + elsif Op_Name = Name_Op_Not then Kind := N_Op_Not; else raise Program_Error; @@ -1990,6 +1991,10 @@ package body Sem_Res is return; end Resolution_Failed; + -- Local variables + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + -- Start of processing for Resolve begin @@ -1997,6 +2002,14 @@ package body Sem_Res is return; end if; + -- A declaration may be subject to pragma Ghost. Set the mode now to + -- ensure that any nodes generated during analysis and expansion are + -- marked as Ghost. + + if Is_Declaration (N) then + Set_Ghost_Mode (N); + end if; + -- Access attribute on remote subprogram cannot be used for a non-remote -- access-to-subprogram type. @@ -2112,6 +2125,7 @@ package body Sem_Res is if Analyzed (N) then Debug_A_Exit ("resolving ", N, " (done, already analyzed)"); Analyze_Dimension (N); + Ghost_Mode := Save_Ghost_Mode; return; -- Any case of Any_Type as the Etype value means that we had a @@ -2119,6 +2133,7 @@ package body Sem_Res is elsif Etype (N) = Any_Type then Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)"); + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -2271,7 +2286,7 @@ package body Sem_Res is then exit Interp_Loop; - elsif Nkind (N) in N_Unary_Op + elsif Nkind (N) in N_Unary_Op and then Etype (Right_Opnd (N)) = Any_Type then exit Interp_Loop; @@ -2371,7 +2386,7 @@ package body Sem_Res is -- operators, which are not declared with the type -- of the operand, but appear forever in Standard. - if It.Typ = Universal_Fixed + if It.Typ = Universal_Fixed and then Scope (It.Nam) = Standard_Standard then Error_Msg_N @@ -2550,6 +2565,7 @@ package body Sem_Res is then Resolve (N, Full_View (Typ)); Set_Etype (N, Typ); + Ghost_Mode := Save_Ghost_Mode; return; -- Check for an aggregate. Sometimes we can get bogus aggregates @@ -2658,6 +2674,7 @@ package body Sem_Res is if Address_Integer_Convert_OK (Typ, Etype (N)) then Rewrite (N, Unchecked_Convert_To (Typ, Relocate_Node (N))); Analyze_And_Resolve (N, Typ); + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -2720,12 +2737,14 @@ package body Sem_Res is end if; Resolution_Failed; + Ghost_Mode := Save_Ghost_Mode; return; -- Test if we have more than one interpretation for the context elsif Ambiguous then Resolution_Failed; + Ghost_Mode := Save_Ghost_Mode; return; -- Only one intepretation @@ -2813,6 +2832,7 @@ package body Sem_Res is -- Rewrite_Renamed_Operator. if Analyzed (N) then + Ghost_Mode := Save_Ghost_Mode; return; end if; end if; @@ -2962,6 +2982,7 @@ package body Sem_Res is if Nkind (N) not in N_Subexpr then Debug_A_Exit ("resolving ", N, " (done)"); Expand (N); + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -2996,6 +3017,8 @@ package body Sem_Res is Expand (N); end if; + + Ghost_Mode := Save_Ghost_Mode; end Resolve; ------------- @@ -4083,22 +4106,11 @@ package body Sem_Res is -- actual to a nested call, since this constitutes a reading of -- the parameter, which is not allowed. - if Is_Entity_Name (A) + if Ada_Version = Ada_83 + and then Is_Entity_Name (A) and then Ekind (Entity (A)) = E_Out_Parameter then - if Ada_Version = Ada_83 then - Error_Msg_N - ("(Ada 83) illegal reading of out parameter", A); - - -- An effectively volatile OUT parameter cannot act as IN or - -- IN OUT actual in a call (SPARK RM 7.1.3(11)). - - elsif SPARK_Mode = On - and then Is_Effectively_Volatile (Entity (A)) - then - Error_Msg_N - ("illegal reading of volatile OUT parameter", A); - end if; + Error_Msg_N ("(Ada 83) illegal reading of out parameter", A); end if; end if; @@ -4450,20 +4462,21 @@ package body Sem_Res is -- temporaries are ignored. if SPARK_Mode = On - and then Is_Effectively_Volatile_Object (A) and then Comes_From_Source (A) + and then Is_Effectively_Volatile_Object (A) then - -- An effectively volatile object may act as an actual - -- parameter when the corresponding formal is of a non-scalar - -- volatile type. + -- An effectively volatile object may act as an actual when the + -- corresponding formal is of a non-scalar effectively volatile + -- type (SPARK RM 7.1.3(12)). - if Is_Volatile (Etype (F)) - and then not Is_Scalar_Type (Etype (F)) + if not Is_Scalar_Type (Etype (F)) + and then Is_Effectively_Volatile (Etype (F)) then null; - -- An effectively volatile object may act as an actual - -- parameter in a call to an instance of Unchecked_Conversion. + -- An effectively volatile object may act as an actual in a + -- call to an instance of Unchecked_Conversion. + -- (SPARK RM 7.1.3(12)). elsif Is_Unchecked_Conversion_Instance (Nam) then null; @@ -4517,7 +4530,8 @@ package body Sem_Res is -- The actual parameter of a Ghost subprogram whose formal is of -- mode IN OUT or OUT must be a Ghost variable (SPARK RM 6.9(13)). - if Is_Ghost_Entity (Nam) + if Comes_From_Source (Nam) + and then Is_Ghost_Entity (Nam) and then Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter) and then Is_Entity_Name (A) and then Present (Entity (A)) @@ -4667,6 +4681,22 @@ package body Sem_Res is Check_Non_Static_Context (Expression (E)); Check_Unset_Reference (Expression (E)); + -- Allocators generated by the build-in-place expansion mechanism + -- are explicitly marked as coming from source but do not need to be + -- checked for limited initialization. To exclude this case, ensure + -- that the parent of the allocator is a source node. + + if Is_Limited_Type (Etype (E)) + and then Comes_From_Source (N) + and then Comes_From_Source (Parent (N)) + and then not In_Instance_Body + then + if not OK_For_Limited_Init (Etype (E), Expression (E)) then + Error_Msg_N ("initialization not allowed for limited types", N); + Explain_Limited_Type (Etype (E), N); + end if; + end if; + -- A qualified expression requires an exact match of the type. -- Class-wide matching is not allowed. @@ -5780,10 +5810,11 @@ package body Sem_Res is -- is frozen in the usual fashion, by the appearance of a real body, -- or at the end of a declarative part. - if Is_Entity_Name (Subp) and then not In_Spec_Expression - and then not Is_Expression_Function (Current_Scope) + if Is_Entity_Name (Subp) + and then not In_Spec_Expression + and then not Is_Expression_Function_Or_Completion (Current_Scope) and then - (not Is_Expression_Function (Entity (Subp)) + (not Is_Expression_Function_Or_Completion (Entity (Subp)) or else Scope (Entity (Subp)) = Current_Scope) then Freeze_Expression (Subp); @@ -6397,14 +6428,14 @@ package body Sem_Res is -- assertions as logic expressions. elsif In_Assertion_Expr /= 0 then - Error_Msg_NE ("?no contextual analysis of &", N, Nam); + Error_Msg_NE ("info: no contextual analysis of &?", N, Nam); Error_Msg_N ("\call appears in assertion expression", N); Set_Is_Inlined_Always (Nam_UA, False); -- Calls cannot be inlined inside default expressions elsif In_Default_Expr then - Error_Msg_NE ("?no contextual analysis of &", N, Nam); + Error_Msg_NE ("info: no contextual analysis of &?", N, Nam); Error_Msg_N ("\call appears in default expression", N); Set_Is_Inlined_Always (Nam_UA, False); @@ -6417,7 +6448,7 @@ package body Sem_Res is if No (Body_Id) then Error_Msg_NE - ("?no contextual analysis of & (body not seen yet)", + ("info: no contextual analysis of & (body not seen yet)?", N, Nam); Set_Is_Inlined_Always (Nam_UA, False); @@ -6433,7 +6464,7 @@ package body Sem_Res is -- expressions, that are not handled by GNATprove. elsif Is_Potentially_Unevaluated (N) then - Error_Msg_NE ("?no contextual analysis of &", N, Nam); + Error_Msg_NE ("info: no contextual analysis of &?", N, Nam); Error_Msg_N ("\call appears in potentially unevaluated context", N); Set_Is_Inlined_Always (Nam_UA, False); @@ -6770,7 +6801,7 @@ package body Sem_Res is (Context : Node_Id; Obj_Ref : Node_Id) return Boolean; -- Determine whether node Context denotes a "non-interfering context" - -- (as defined in SPARK RM 7.1.3(13)) where volatile reference Obj_Ref + -- (as defined in SPARK RM 7.1.3(12)) where volatile reference Obj_Ref -- can safely reside. ---------------------------------------- @@ -6823,12 +6854,51 @@ package body Sem_Res is (Context : Node_Id; Obj_Ref : Node_Id) return Boolean is + function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean; + -- Determine whether an arbitrary node denotes a call to a protected + -- entry, function or procedure in prefixed form where the prefix is + -- Obj_Ref. + function Within_Check (Nod : Node_Id) return Boolean; -- Determine whether an arbitrary node appears in a check node - function Within_Procedure_Call (Nod : Node_Id) return Boolean; + function Within_Subprogram_Call (Nod : Node_Id) return Boolean; -- Determine whether an arbitrary node appears in a procedure call + function Within_Volatile_Function (Id : Entity_Id) return Boolean; + -- Determine whether an arbitrary entity appears in a volatile + -- function. + + --------------------------------- + -- Is_Protected_Operation_Call -- + --------------------------------- + + function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is + Pref : Node_Id; + Subp : Node_Id; + + begin + -- A call to a protected operations retains its selected component + -- form as opposed to other prefixed calls that are transformed in + -- expanded names. + + if Nkind (Nod) = N_Selected_Component then + Pref := Prefix (Nod); + Subp := Selector_Name (Nod); + + return + Pref = Obj_Ref + and then Is_Protected_Type (Etype (Pref)) + and then Is_Entity_Name (Subp) + and then Ekind_In (Entity (Subp), E_Entry, + E_Entry_Family, + E_Function, + E_Procedure); + else + return False; + end if; + end Is_Protected_Operation_Call; + ------------------ -- Within_Check -- ------------------ @@ -6856,19 +6926,21 @@ package body Sem_Res is return False; end Within_Check; - --------------------------- - -- Within_Procedure_Call -- - --------------------------- + ---------------------------- + -- Within_Subprogram_Call -- + ---------------------------- - function Within_Procedure_Call (Nod : Node_Id) return Boolean is + function Within_Subprogram_Call (Nod : Node_Id) return Boolean is Par : Node_Id; begin - -- Climb the parent chain looking for a procedure call + -- Climb the parent chain looking for a function or procedure call Par := Nod; while Present (Par) loop - if Nkind (Par) = N_Procedure_Call_Statement then + if Nkind_In (Par, N_Function_Call, + N_Procedure_Call_Statement) + then return True; -- Prevent the search from going too far @@ -6881,7 +6953,33 @@ package body Sem_Res is end loop; return False; - end Within_Procedure_Call; + end Within_Subprogram_Call; + + ------------------------------ + -- Within_Volatile_Function -- + ------------------------------ + + function Within_Volatile_Function (Id : Entity_Id) return Boolean is + Func_Id : Entity_Id; + + begin + -- Traverse the scope stack looking for a [generic] function + + Func_Id := Id; + while Present (Func_Id) and then Func_Id /= Standard_Standard loop + if Ekind_In (Func_Id, E_Function, E_Generic_Function) then + return Is_Volatile_Function (Func_Id); + end if; + + Func_Id := Scope (Func_Id); + end loop; + + return False; + end Within_Volatile_Function; + + -- Local variables + + Obj_Id : Entity_Id; -- Start of processing for Is_OK_Volatile_Context @@ -6892,24 +6990,59 @@ package body Sem_Res is return True; -- The volatile object is part of the initialization expression of - -- another object. Ensure that the climb of the parent chain came - -- from the expression side and not from the name side. + -- another object. elsif Nkind (Context) = N_Object_Declaration and then Present (Expression (Context)) and then Expression (Context) = Obj_Ref then + Obj_Id := Defining_Entity (Context); + + -- The volatile object acts as the initialization expression of an + -- extended return statement. This is valid context as long as the + -- function is volatile. + + if Is_Return_Object (Obj_Id) then + return Within_Volatile_Function (Obj_Id); + + -- Otherwise this is a normal object initialization + + else + return True; + end if; + + -- The volatile object acts as the name of a renaming declaration + + elsif Nkind (Context) = N_Object_Renaming_Declaration + and then Name (Context) = Obj_Ref + then return True; -- The volatile object appears as an actual parameter in a call to an -- instance of Unchecked_Conversion whose result is renamed. elsif Nkind (Context) = N_Function_Call + and then Is_Entity_Name (Name (Context)) and then Is_Unchecked_Conversion_Instance (Entity (Name (Context))) and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration then return True; + -- The volatile object is actually the prefix in a protected entry, + -- function, or procedure call. + + elsif Is_Protected_Operation_Call (Context) then + return True; + + -- The volatile object appears as the expression of a simple return + -- statement that applies to a volatile function. + + elsif Nkind (Context) = N_Simple_Return_Statement + and then Expression (Context) = Obj_Ref + then + return + Within_Volatile_Function (Return_Statement_Entity (Context)); + -- The volatile object appears as the prefix of a name occurring -- in a non-interfering context. @@ -6944,10 +7077,10 @@ package body Sem_Res is return True; -- Assume that references to effectively volatile objects that appear - -- as actual parameters in a procedure call are always legal. A full + -- as actual parameters in a subprogram call are always legal. A full -- legality check is done when the actuals are resolved. - elsif Within_Procedure_Call (Context) then + elsif Within_Subprogram_Call (Context) then return True; -- Otherwise the context is not suitable for an effectively volatile @@ -7035,14 +7168,6 @@ package body Sem_Res is then if Ada_Version = Ada_83 then Error_Msg_N ("(Ada 83) illegal reading of out parameter", N); - - -- An effectively volatile OUT parameter cannot be read - -- (SPARK RM 7.1.3(11)). - - elsif SPARK_Mode = On - and then Is_Effectively_Volatile (E) - then - Error_Msg_N ("illegal reading of volatile OUT parameter", N); end if; -- In all other cases, just do the possible static evaluation @@ -7050,7 +7175,8 @@ package body Sem_Res is else -- A deferred constant that appears in an expression must have a -- completion, unless it has been removed by in-place expansion of - -- an aggregate. + -- an aggregate. A constant that is a renaming does not need + -- initialization. if Ekind (E) = E_Constant and then Comes_From_Source (E) @@ -7058,6 +7184,7 @@ package body Sem_Res is and then Is_Frozen (Etype (E)) and then not In_Spec_Expression and then not Is_Imported (E) + and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration then if No_Initialization (Parent (E)) or else (Present (Full_View (E)) @@ -7082,44 +7209,40 @@ package body Sem_Res is Par := Parent (Par); end if; - -- The following checks are only relevant when SPARK_Mode is on as they - -- are not standard Ada legality rules. An effectively volatile object - -- subject to enabled properties Async_Writers or Effective_Reads must - -- appear in a specific context. + if Comes_From_Source (N) then - if SPARK_Mode = On - and then Is_Object (E) - and then Is_Effectively_Volatile (E) - and then (Async_Writers_Enabled (E) - or else Effective_Reads_Enabled (E)) - and then Comes_From_Source (N) - then - -- The effectively volatile objects appears in a "non-interfering - -- context" as defined in SPARK RM 7.1.3(13). + -- The following checks are only relevant when SPARK_Mode is on as + -- they are not standard Ada legality rules. - if Is_OK_Volatile_Context (Par, N) then - null; + if SPARK_Mode = On then - -- Otherwise the context causes a side effect with respect to the - -- effectively volatile object. + -- An effectively volatile object subject to enabled properties + -- Async_Writers or Effective_Reads must appear in non-interfering + -- context (SPARK RM 7.1.3(12)). - else - SPARK_Msg_N - ("volatile object cannot appear in this context " - & "(SPARK RM 7.1.3(13))", N); - end if; - end if; + if Is_Object (E) + and then Is_Effectively_Volatile (E) + and then (Async_Writers_Enabled (E) + or else Effective_Reads_Enabled (E)) + and then not Is_OK_Volatile_Context (Par, N) + then + SPARK_Msg_N + ("volatile object cannot appear in this context " + & "(SPARK RM 7.1.3(12))", N); + end if; - -- A Ghost entity must appear in a specific context + -- Check possible elaboration issues with respect to variables - if Is_Ghost_Entity (E) and then Comes_From_Source (N) then - Check_Ghost_Context (E, N); - end if; + if Ekind (E) = E_Variable then + Check_Elab_Call (N); + end if; + end if; - -- In SPARK mode, need to check possible elaboration issues + -- A Ghost entity must appear in a specific context - if SPARK_Mode = On and then Ekind (E) = E_Variable then - Check_Elab_Call (N); + if Is_Ghost_Entity (E) then + Check_Ghost_Context (E, N); + end if; end if; end Resolve_Entity_Name; @@ -7223,7 +7346,7 @@ package body Sem_Res is end if; end Actual_Index_Type; - -- Start of processing of Resolve_Entry + -- Start of processing for Resolve_Entry begin -- Find name of entry being called, and resolve prefix of name with its @@ -7299,7 +7422,7 @@ package body Sem_Res is declare Pref : constant Node_Id := Prefix (Entry_Name); - Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name)); + Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name)); I : Interp_Index; It : Interp; @@ -7322,7 +7445,7 @@ package body Sem_Res is else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); Nam := Entity (Selector_Name (Prefix (Entry_Name))); Resolve (Prefix (Prefix (Entry_Name))); - Index := First (Expressions (Entry_Name)); + Index := First (Expressions (Entry_Name)); Resolve (Index, Entry_Index_Type (Nam)); -- Up to this point the expression could have been the actual in a @@ -7468,7 +7591,7 @@ package body Sem_Res is begin New_Actuals := New_List (Obj); - if Nkind (Entry_Name) = N_Indexed_Component then + if Nkind (Entry_Name) = N_Indexed_Component then Append_To (New_Actuals, New_Copy_Tree (First (Expressions (Entry_Name)))); end if; @@ -8013,6 +8136,8 @@ package body Sem_Res is Set_Etype (N, Get_Actual_Subtype (N)); end if; + Analyze_Dimension (N); + -- Note: No Eval processing is required for an explicit dereference, -- because such a name can never be static. @@ -8069,6 +8194,15 @@ package body Sem_Res is Indexes := Parameter_Associations (Call); Pref := Remove_Head (Indexes); Set_Expressions (N, Indexes); + + -- If expression is to be reanalyzed, reset Generalized_Indexing + -- to recreate call node, as is the case when the expression is + -- part of an expression function. + + if In_Spec_Expression then + Set_Generalized_Indexing (N, Empty); + end if; + Set_Prefix (N, Pref); end if; @@ -9780,12 +9914,15 @@ package body Sem_Res is T := Etype (P); end if; - -- Set flag for expander if discriminant check required + -- Set flag for expander if discriminant check required on a component + -- appearing within a variant. if Has_Discriminants (T) - and then Ekind_In (Entity (S), E_Component, E_Discriminant) + and then Ekind (Entity (S)) = E_Component and then Present (Original_Record_Component (Entity (S))) and then Ekind (Original_Record_Component (Entity (S))) = E_Component + and then + Is_Declared_Within_Variant (Original_Record_Component (Entity (S))) and then not Discriminant_Checks_Suppressed (T) and then not Init_Component then @@ -11134,7 +11271,7 @@ package body Sem_Res is New_N : Node_Id; begin - if Nkind (N) in N_Binary_Op then + if Nkind (N) in N_Binary_Op then Append (Left_Opnd (N), Actuals); end if; @@ -11949,7 +12086,7 @@ package body Sem_Res is if Present (It.Typ) then N1 := It1.Nam; T1 := It1.Typ; - It1 := Disambiguate (Operand, I1, I, Any_Type); + It1 := Disambiguate (Operand, I1, I, Any_Type); if It1 = No_Interp then Conversion_Error_N diff --git a/gcc/ada/sem_smem.adb b/gcc/ada/sem_smem.adb index bca184ef658..6a25501479e 100644 --- a/gcc/ada/sem_smem.adb +++ b/gcc/ada/sem_smem.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -92,6 +92,8 @@ package body Sem_Smem is elsif Is_Record_Type (T) and then not Is_Constrained (T) + and then (Nkind (N) /= N_Object_Declaration + or else No (Expression (N))) then Error_Msg_N ("unconstrained variant records " & @@ -116,9 +118,12 @@ package body Sem_Smem is elsif Is_Record_Type (T) then if Has_Discriminants (T) then + + -- Check for access discriminants. + C := First_Discriminant (T); while Present (C) loop - if Comes_From_Source (C) then + if Is_Access_Type (Etype (C)) then return True; else C := Next_Discriminant (C); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 785121adf24..d5be94ec90e 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -1728,18 +1728,6 @@ package body Sem_Type is end if; end if; - -- Check for overloaded CIL convention stuff because the CIL libraries - -- do sick things like Console.Write_Line where it matches two different - -- overloads, so just pick the first ??? - - if Convention (Nam1) = Convention_CIL - and then Convention (Nam2) = Convention_CIL - and then Ekind (Nam1) = Ekind (Nam2) - and then Ekind_In (Nam1, E_Procedure, E_Function) - then - return It2; - end if; - -- If the context is universal, the predefined operator is preferred. -- This includes bounds in numeric type declarations, and expressions -- in type conversions. If no interpretation yields a universal type, @@ -1989,7 +1977,7 @@ package body Sem_Type is return It2; end if; - elsif Nkind (N) in N_Unary_Op then + elsif Nkind (N) in N_Unary_Op then if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then return It1; else @@ -2723,6 +2711,17 @@ package body Sem_Type is then Error_Msg_NE ("(Ada 2005) does not implement interface }", L, Etype (Class_Wide_Type (Etype (R)))); + + -- Specialize message if one operand is a limited view, a priori + -- unrelated to all other types. + + elsif From_Limited_With (Etype (R)) then + Error_Msg_NE ("limited view of& not compatible with context", + R, Etype (R)); + + elsif From_Limited_With (Etype (L)) then + Error_Msg_NE ("limited view of& not compatible with context", + L, Etype (L)); else Error_Msg_N ("incompatible types", Parent (L)); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a29b286f717..89332c44b8c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -23,6 +23,8 @@ -- -- ------------------------------------------------------------------------------ +with Treepr; -- ???For debugging code below + with Aspects; use Aspects; with Atree; use Atree; with Casing; use Casing; @@ -50,7 +52,6 @@ with Sem_Aux; use Sem_Aux; with Sem_Attr; use Sem_Attr; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; -with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; @@ -248,201 +249,6 @@ package body Sem_Util is end if; end Add_Block_Identifier; - ----------------------- - -- Add_Contract_Item -- - ----------------------- - - procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id) is - Items : Node_Id := Contract (Id); - - procedure Add_Classification; - -- Prepend Prag to the list of classifications - - procedure Add_Contract_Test_Case; - -- Prepend Prag to the list of contract and test cases - - procedure Add_Pre_Post_Condition; - -- Prepend Prag to the list of pre- and postconditions - - ------------------------ - -- Add_Classification -- - ------------------------ - - procedure Add_Classification is - begin - Set_Next_Pragma (Prag, Classifications (Items)); - Set_Classifications (Items, Prag); - end Add_Classification; - - ---------------------------- - -- Add_Contract_Test_Case -- - ---------------------------- - - procedure Add_Contract_Test_Case is - begin - Set_Next_Pragma (Prag, Contract_Test_Cases (Items)); - Set_Contract_Test_Cases (Items, Prag); - end Add_Contract_Test_Case; - - ---------------------------- - -- Add_Pre_Post_Condition -- - ---------------------------- - - procedure Add_Pre_Post_Condition is - begin - Set_Next_Pragma (Prag, Pre_Post_Conditions (Items)); - Set_Pre_Post_Conditions (Items, Prag); - end Add_Pre_Post_Condition; - - -- Local variables - - Prag_Nam : Name_Id; - - -- Start of processing for Add_Contract_Item - - begin - -- A contract must contain only pragmas - - pragma Assert (Nkind (Prag) = N_Pragma); - Prag_Nam := Pragma_Name (Prag); - - -- Create a new contract when adding the first item - - if No (Items) then - Items := Make_Contract (Sloc (Id)); - Set_Contract (Id, Items); - end if; - - -- Contract items related to constants. Applicable pragmas are: - -- Part_Of - - if Ekind (Id) = E_Constant then - if Prag_Nam = Name_Part_Of then - Add_Classification; - - -- The pragma is not a proper contract item - - else - raise Program_Error; - end if; - - -- Contract items related to [generic] packages or instantiations. The - -- applicable pragmas are: - -- Abstract_States - -- Initial_Condition - -- Initializes - -- Part_Of (instantiation only) - - elsif Ekind_In (Id, E_Generic_Package, E_Package) then - if Nam_In (Prag_Nam, Name_Abstract_State, - Name_Initial_Condition, - Name_Initializes) - then - Add_Classification; - - -- Indicator Part_Of must be associated with a package instantiation - - elsif Prag_Nam = Name_Part_Of and then Is_Generic_Instance (Id) then - Add_Classification; - - -- The pragma is not a proper contract item - - else - raise Program_Error; - end if; - - -- Contract items related to package bodies. The applicable pragmas are: - -- Refined_States - - elsif Ekind (Id) = E_Package_Body then - if Prag_Nam = Name_Refined_State then - Add_Classification; - - -- The pragma is not a proper contract item - - else - raise Program_Error; - end if; - - -- Contract items related to subprogram or entry declarations. The - -- applicable pragmas are: - -- Contract_Cases - -- Depends - -- Extensions_Visible - -- Global - -- Postcondition - -- Precondition - -- Test_Case - - elsif Ekind_In (Id, E_Entry, E_Entry_Family) - or else Is_Generic_Subprogram (Id) - or else Is_Subprogram (Id) - then - if Nam_In (Prag_Nam, Name_Postcondition, Name_Precondition) then - Add_Pre_Post_Condition; - - elsif Nam_In (Prag_Nam, Name_Contract_Cases, Name_Test_Case) then - Add_Contract_Test_Case; - - elsif Nam_In (Prag_Nam, Name_Depends, - Name_Extensions_Visible, - Name_Global) - then - Add_Classification; - - -- The pragma is not a proper contract item - - else - raise Program_Error; - end if; - - -- Contract items related to subprogram bodies. Applicable pragmas are: - -- Postcondition - -- Precondition - -- Refined_Depends - -- Refined_Global - -- Refined_Post - - elsif Ekind (Id) = E_Subprogram_Body then - if Nam_In (Prag_Nam, Name_Refined_Depends, Name_Refined_Global) then - Add_Classification; - - elsif Nam_In (Prag_Nam, Name_Postcondition, - Name_Precondition, - Name_Refined_Post) - then - Add_Pre_Post_Condition; - - -- The pragma is not a proper contract item - - else - raise Program_Error; - end if; - - -- Contract items related to variables. Applicable pragmas are: - -- Async_Readers - -- Async_Writers - -- Effective_Reads - -- Effective_Writes - -- Part_Of - - elsif Ekind (Id) = E_Variable then - if Nam_In (Prag_Nam, Name_Async_Readers, - Name_Async_Writers, - Name_Effective_Reads, - Name_Effective_Writes, - Name_Part_Of) - then - Add_Classification; - - -- The pragma is not a proper contract item - - else - raise Program_Error; - end if; - end if; - end Add_Contract_Item; - ---------------------------- -- Add_Global_Declaration -- ---------------------------- @@ -628,6 +434,85 @@ package body Sem_Util is return Alignment (E) * System_Storage_Unit; end Alignment_In_Bits; + -------------------------------------- + -- All_Composite_Constraints_Static -- + -------------------------------------- + + function All_Composite_Constraints_Static + (Constr : Node_Id) return Boolean + is + begin + if No (Constr) or else Error_Posted (Constr) then + return True; + end if; + + case Nkind (Constr) is + when N_Subexpr => + if Nkind (Constr) in N_Has_Entity + and then Present (Entity (Constr)) + then + if Is_Type (Entity (Constr)) then + return + not Is_Discrete_Type (Entity (Constr)) + or else Is_OK_Static_Subtype (Entity (Constr)); + end if; + + elsif Nkind (Constr) = N_Range then + return + Is_OK_Static_Expression (Low_Bound (Constr)) + and then + Is_OK_Static_Expression (High_Bound (Constr)); + + elsif Nkind (Constr) = N_Attribute_Reference + and then Attribute_Name (Constr) = Name_Range + then + return + Is_OK_Static_Expression + (Type_Low_Bound (Etype (Prefix (Constr)))) + and then + Is_OK_Static_Expression + (Type_High_Bound (Etype (Prefix (Constr)))); + end if; + + return + not Present (Etype (Constr)) -- previous error + or else not Is_Discrete_Type (Etype (Constr)) + or else Is_OK_Static_Expression (Constr); + + when N_Discriminant_Association => + return All_Composite_Constraints_Static (Expression (Constr)); + + when N_Range_Constraint => + return + All_Composite_Constraints_Static (Range_Expression (Constr)); + + when N_Index_Or_Discriminant_Constraint => + declare + One_Cstr : Entity_Id; + begin + One_Cstr := First (Constraints (Constr)); + while Present (One_Cstr) loop + if not All_Composite_Constraints_Static (One_Cstr) then + return False; + end if; + + Next (One_Cstr); + end loop; + end; + + return True; + + when N_Subtype_Indication => + return + All_Composite_Constraints_Static (Subtype_Mark (Constr)) + and then + All_Composite_Constraints_Static (Constraint (Constr)); + + when others => + raise Program_Error; + end case; + end All_Composite_Constraints_Static; + --------------------------------- -- Append_Inherited_Subprogram -- --------------------------------- @@ -1119,7 +1004,7 @@ package body Sem_Util is D := First_Elmt (Discriminant_Constraint (Desig_Typ)); while Present (D) loop if Denotes_Discriminant (Node (D)) then - D_Val := Make_Selected_Component (Loc, + D_Val := Make_Selected_Component (Loc, Prefix => New_Copy_Tree (P), Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); @@ -1314,7 +1199,6 @@ package body Sem_Util is -- Local variables - GM : constant Ghost_Mode_Type := Ghost_Mode; Loc : constant Source_Ptr := Sloc (Typ); Prag : constant Node_Id := Get_Pragma (Typ, Pragma_Default_Initial_Condition); @@ -1324,6 +1208,8 @@ package body Sem_Util is Expr : Node_Id; Stmt : Node_Id; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + -- Start of processing for Build_Default_Init_Cond_Procedure_Body begin @@ -1341,8 +1227,8 @@ package body Sem_Util is return; end if; - -- Ensure that the analysis and expansion produce Ghost nodes if the - -- type itself is Ghost. + -- The related type may be subject to pragma Ghost. Set the mode now + -- to ensure that the analysis and expansion produce Ghost nodes. Set_Ghost_Mode_From_Entity (Typ); @@ -1412,11 +1298,7 @@ package body Sem_Util is Set_Corresponding_Spec (Body_Decl, Proc_Id); Insert_After_And_Analyze (Declaration_Node (Typ), Body_Decl); - - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Build_Default_Init_Cond_Procedure_Body; -- Local variables @@ -1465,10 +1347,12 @@ package body Sem_Util is --------------------------------------------------- procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id) is - GM : constant Ghost_Mode_Type := Ghost_Mode; - Loc : constant Source_Ptr := Sloc (Typ); - Prag : constant Node_Id := + Loc : constant Source_Ptr := Sloc (Typ); + Prag : constant Node_Id := Get_Pragma (Typ, Pragma_Default_Initial_Condition); + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + Proc_Id : Entity_Id; begin @@ -1485,8 +1369,8 @@ package body Sem_Util is return; end if; - -- Ensure that the analysis and expansion produce Ghost nodes if the - -- type itself is Ghost. + -- The related type may be subject to pragma Ghost. Set the mode now to + -- ensure that the analysis and expansion produce Ghost nodes. Set_Ghost_Mode_From_Entity (Typ); @@ -1520,10 +1404,7 @@ package body Sem_Util is Defining_Identifier => Make_Temporary (Loc, 'I'), Parameter_Type => New_Occurrence_Of (Typ, Loc)))))); - -- Restore the original Ghost mode once analysis and expansion have - -- taken place. - - Ghost_Mode := GM; + Ghost_Mode := Save_Ghost_Mode; end Build_Default_Init_Cond_Procedure_Declaration; --------------------------- @@ -2085,6 +1966,32 @@ package body Sem_Util is end if; end Check_Fully_Declared; + ------------------------------------------- + -- Check_Function_With_Address_Parameter -- + ------------------------------------------- + + procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is + F : Entity_Id; + T : Entity_Id; + + begin + F := First_Formal (Subp_Id); + while Present (F) loop + T := Etype (F); + + if Is_Private_Type (T) and then Present (Full_View (T)) then + T := Full_View (T); + end if; + + if Is_Descendent_Of_Address (T) or else Is_Limited_Type (T) then + Set_Is_Pure (Subp_Id, False); + exit; + end if; + + Next_Formal (F); + end loop; + end Check_Function_With_Address_Parameter; + ------------------------------------- -- Check_Function_Writable_Actuals -- ------------------------------------- @@ -2226,11 +2133,26 @@ package body Sem_Util is end if; if Is_Writable_Actual then - if Contains (Writable_Actuals_List, N) then + + -- Skip checking the error in non-elementary types since + -- RM 6.4.1(6.15/3) is restricted to elementary types, but + -- store this actual in Writable_Actuals_List since it is + -- needed to perform checks on other constructs that have + -- arbitrary order of evaluation (for example, aggregates). + + if not Is_Elementary_Type (Etype (N)) then + if not Contains (Writable_Actuals_List, N) then + Append_New_Elmt (N, To => Writable_Actuals_List); + end if; + + -- Second occurrence of an elementary type writable actual + + elsif Contains (Writable_Actuals_List, N) then -- Report the error on the second occurrence of the -- identifier. We cannot assume that N is the second - -- occurrence, since Traverse_Func walks through Field2 + -- occurrence (according to their location in the + -- sources), since Traverse_Func walks through Field2 -- last (see comment in the body of Traverse_Func). declare @@ -2256,9 +2178,12 @@ package body Sem_Util is Error_Node, Id); return Abandon; end; - end if; - Append_New_Elmt (N, To => Writable_Actuals_List); + -- First occurrence of a elementary type writable actual + + else + Append_New_Elmt (N, To => Writable_Actuals_List); + end if; else if Identifiers_List = No_Elist then @@ -2348,9 +2273,9 @@ package body Sem_Util is return Id; end Get_Function_Id; - --------------------------- - -- Preanalyze_Expression -- - --------------------------- + ------------------------------- + -- Preanalyze_Without_Errors -- + ------------------------------- procedure Preanalyze_Without_Errors (N : Node_Id) is Status : constant Boolean := Get_Ignore_Errors; @@ -3015,7 +2940,7 @@ package body Sem_Util is end if; end Is_Later_Declarative_Item; - -- Start of Check_Later_Vs_Basic_Declarations + -- Start of processing for Check_Later_Vs_Basic_Declarations begin Decl := First (Decls); @@ -3055,48 +2980,6 @@ package body Sem_Util is end loop Outer; end Check_Later_Vs_Basic_Declarations; - ------------------------- - -- Check_Nested_Access -- - ------------------------- - - procedure Check_Nested_Access (Ent : Entity_Id) is - Scop : constant Entity_Id := Current_Scope; - Current_Subp : Entity_Id; - Enclosing : Entity_Id; - - begin - -- Currently only enabled for VM back-ends for efficiency - - if VM_Target /= No_VM - and then Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter) - and then Scope (Ent) /= Empty - and then not Is_Library_Level_Entity (Ent) - - -- Comment the exclusion of imported entities ??? - - and then not Is_Imported (Ent) - then - -- Get current subprogram that is relevant - - if Is_Subprogram (Scop) - or else Is_Generic_Subprogram (Scop) - or else Is_Entry (Scop) - then - Current_Subp := Scop; - else - Current_Subp := Current_Subprogram; - end if; - - Enclosing := Enclosing_Subprogram (Ent); - - -- Set flag if uplevel reference - - if Enclosing /= Empty and then Enclosing /= Current_Subp then - Set_Has_Uplevel_Reference (Ent, True); - end if; - end if; - end Check_Nested_Access; - --------------------------- -- Check_No_Hidden_State -- --------------------------- @@ -3188,6 +3071,36 @@ package body Sem_Util is end if; end Check_No_Hidden_State; + ---------------------------------------- + -- Check_Nonvolatile_Function_Profile -- + ---------------------------------------- + + procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is + Formal : Entity_Id; + + begin + -- Inspect all formal parameters + + Formal := First_Formal (Func_Id); + while Present (Formal) loop + if Is_Effectively_Volatile (Etype (Formal)) then + Error_Msg_NE + ("nonvolatile function & cannot have a volatile parameter", + Formal, Func_Id); + end if; + + Next_Formal (Formal); + end loop; + + -- Inspect the return type + + if Is_Effectively_Volatile (Etype (Func_Id)) then + Error_Msg_N + ("nonvolatile function & cannot have a volatile return type", + Func_Id); + end if; + end Check_Nonvolatile_Function_Profile; + ------------------------------------------ -- Check_Potentially_Blocking_Operation -- ------------------------------------------ @@ -3654,6 +3567,231 @@ package body Sem_Util is end if; end Check_Unprotected_Access; + ------------------------------ + -- Check_Unused_Body_States -- + ------------------------------ + + procedure Check_Unused_Body_States (Body_Id : Entity_Id) is + Legal_Constits : Boolean := True; + -- This flag designates whether all constituents of pragma Refined_State + -- are legal. The flag is used to suppress the generation of potentially + -- misleading error messages due to a malformed pragma. + + procedure Process_Refinement_Clause + (Clause : Node_Id; + States : Elist_Id); + -- Inspect all constituents of refinement clause Clause and remove any + -- matches from body state list States. + + ------------------------------- + -- Process_Refinement_Clause -- + ------------------------------- + + procedure Process_Refinement_Clause + (Clause : Node_Id; + States : Elist_Id) + is + procedure Process_Constituent (Constit : Node_Id); + -- Remove constituent Constit from body state list States + + ------------------------- + -- Process_Constituent -- + ------------------------- + + procedure Process_Constituent (Constit : Node_Id) is + Constit_Id : Entity_Id; + + begin + if Error_Posted (Constit) then + Legal_Constits := False; + end if; + + -- Guard against illegal constituents. Only abstract states and + -- objects can appear on the right hand side of a refinement. + + if Is_Entity_Name (Constit) then + Constit_Id := Entity_Of (Constit); + + if Present (Constit_Id) + and then Ekind_In (Constit_Id, E_Abstract_State, + E_Constant, + E_Variable) + then + Remove (States, Constit_Id); + end if; + end if; + end Process_Constituent; + + -- Local variables + + Constit : Node_Id; + + -- Start of processing for Process_Refinement_Clause + + begin + if Nkind (Clause) = N_Component_Association then + Constit := Expression (Clause); + + -- Multiple constituents appear as an aggregate + + if Nkind (Constit) = N_Aggregate then + Constit := First (Expressions (Constit)); + while Present (Constit) loop + Process_Constituent (Constit); + Next (Constit); + end loop; + + -- Various forms of a single constituent + + else + Process_Constituent (Constit); + end if; + end if; + end Process_Refinement_Clause; + + -- Local variables + + Prag : constant Node_Id := + Get_Pragma (Body_Id, Pragma_Refined_State); + Spec_Id : constant Entity_Id := Spec_Entity (Body_Id); + Clause : Node_Id; + States : Elist_Id; + + -- Start of processing for Check_Unused_Body_States + + begin + -- Inspect the clauses of pragma Refined_State and determine whether all + -- visible states declared within the body of the package participate in + -- the refinement. + + if Present (Prag) then + Clause := Expression (Get_Argument (Prag, Spec_Id)); + States := Collect_Body_States (Body_Id); + + -- Multiple non-null state refinements appear as an aggregate + + if Nkind (Clause) = N_Aggregate then + Clause := First (Component_Associations (Clause)); + while Present (Clause) loop + Process_Refinement_Clause (Clause, States); + Next (Clause); + end loop; + + -- Various forms of a single state refinement + + else + Process_Refinement_Clause (Clause, States); + end if; + + -- Ensure that all abstract states and objects declared in the body + -- state space of the related package are utilized as constituents. + + if Legal_Constits then + Report_Unused_Body_States (Body_Id, States); + end if; + end if; + end Check_Unused_Body_States; + + ------------------------- + -- Collect_Body_States -- + ------------------------- + + function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is + procedure Collect_Visible_States + (Pack_Id : Entity_Id; + States : in out Elist_Id); + -- Gather the entities of all abstract states and objects declared in + -- the visible state space of package Pack_Id. + + ---------------------------- + -- Collect_Visible_States -- + ---------------------------- + + procedure Collect_Visible_States + (Pack_Id : Entity_Id; + States : in out Elist_Id) + is + Item_Id : Entity_Id; + + begin + -- Traverse the entity chain of the package and inspect all visible + -- items. + + Item_Id := First_Entity (Pack_Id); + while Present (Item_Id) and then not In_Private_Part (Item_Id) loop + + -- Do not consider internally generated items as those cannot be + -- named and participate in refinement. + + if not Comes_From_Source (Item_Id) then + null; + + elsif Ekind (Item_Id) = E_Abstract_State then + Append_New_Elmt (Item_Id, States); + + -- Do not consider objects that map generic formals to their + -- actuals, as the formals cannot be named from the outside and + -- participate in refinement. + + elsif Ekind_In (Item_Id, E_Constant, E_Variable) + and then No (Corresponding_Generic_Association + (Declaration_Node (Item_Id))) + then + Append_New_Elmt (Item_Id, States); + + -- Recursively gather the visible states of a nested package + + elsif Ekind (Item_Id) = E_Package then + Collect_Visible_States (Item_Id, States); + end if; + + Next_Entity (Item_Id); + end loop; + end Collect_Visible_States; + + -- Local variables + + Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id); + Decl : Node_Id; + Item_Id : Entity_Id; + States : Elist_Id := No_Elist; + + -- Start of processing for Collect_Body_States + + begin + -- Inspect the declarations of the body looking for source objects, + -- packages and package instantiations. + + Decl := First (Declarations (Body_Decl)); + while Present (Decl) loop + + -- Capture source objects as internally generated temporaries cannot + -- be named and participate in refinement. + + if Nkind (Decl) = N_Object_Declaration then + Item_Id := Defining_Entity (Decl); + + if Comes_From_Source (Item_Id) then + Append_New_Elmt (Item_Id, States); + end if; + + -- Capture the visible abstract states and objects of a source + -- package [instantiation]. + + elsif Nkind (Decl) = N_Package_Declaration then + Item_Id := Defining_Entity (Decl); + + if Comes_From_Source (Item_Id) then + Collect_Visible_States (Item_Id, States); + end if; + end if; + + Next (Decl); + end loop; + + return States; + end Collect_Body_States; + ------------------------ -- Collect_Interfaces -- ------------------------ @@ -4707,168 +4845,6 @@ package body Sem_Util is end if; end Corresponding_Generic_Type; - --------------------------- - -- Corresponding_Spec_Of -- - --------------------------- - - function Corresponding_Spec_Of (Decl : Node_Id) return Entity_Id is - begin - if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body) - and then Present (Corresponding_Spec (Decl)) - then - return Corresponding_Spec (Decl); - - elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub) - and then Present (Corresponding_Spec_Of_Stub (Decl)) - then - return Corresponding_Spec_Of_Stub (Decl); - - else - return Defining_Entity (Decl); - end if; - end Corresponding_Spec_Of; - - ----------------------------- - -- Create_Generic_Contract -- - ----------------------------- - - procedure Create_Generic_Contract (Unit : Node_Id) is - Templ : constant Node_Id := Original_Node (Unit); - Templ_Id : constant Entity_Id := Defining_Entity (Templ); - - procedure Add_Generic_Contract_Pragma (Prag : Node_Id); - -- Add a single contract-related source pragma Prag to the contract of - -- generic template Templ_Id. - - --------------------------------- - -- Add_Generic_Contract_Pragma -- - --------------------------------- - - procedure Add_Generic_Contract_Pragma (Prag : Node_Id) is - Prag_Templ : Node_Id; - - begin - -- Mark the pragma to prevent the premature capture of global - -- references when capturing global references of the context - -- (see Save_References_In_Pragma). - - Set_Is_Generic_Contract_Pragma (Prag); - - -- Pragmas that apply to a generic subprogram declaration are not - -- part of the semantic structure of the generic template: - - -- generic - -- procedure Example (Formal : Integer); - -- pragma Precondition (Formal > 0); - - -- Create a generic template for such pragmas and link the template - -- of the pragma with the generic template. - - if Nkind (Templ) = N_Generic_Subprogram_Declaration then - Rewrite - (Prag, Copy_Generic_Node (Prag, Empty, Instantiating => False)); - Prag_Templ := Original_Node (Prag); - - Set_Is_Generic_Contract_Pragma (Prag_Templ); - Add_Contract_Item (Prag_Templ, Templ_Id); - - -- Otherwise link the pragma with the generic template - - else - Add_Contract_Item (Prag, Templ_Id); - end if; - end Add_Generic_Contract_Pragma; - - -- Local variables - - Context : constant Node_Id := Parent (Unit); - Decl : Node_Id := Empty; - - -- Start of processing for Create_Generic_Contract - - begin - -- A generic package declaration carries contract-related source pragmas - -- in its visible declarations. - - if Nkind (Templ) = N_Generic_Package_Declaration then - Set_Ekind (Templ_Id, E_Generic_Package); - - if Present (Visible_Declarations (Specification (Templ))) then - Decl := First (Visible_Declarations (Specification (Templ))); - end if; - - -- A generic package body carries contract-related source pragmas in its - -- declarations. - - elsif Nkind (Templ) = N_Package_Body then - Set_Ekind (Templ_Id, E_Package_Body); - - if Present (Declarations (Templ)) then - Decl := First (Declarations (Templ)); - end if; - - -- Generic subprogram declaration - - elsif Nkind (Templ) = N_Generic_Subprogram_Declaration then - if Nkind (Specification (Templ)) = N_Function_Specification then - Set_Ekind (Templ_Id, E_Generic_Function); - else - Set_Ekind (Templ_Id, E_Generic_Procedure); - end if; - - -- When the generic subprogram acts as a compilation unit, inspect - -- the Pragmas_After list for contract-related source pragmas. - - if Nkind (Context) = N_Compilation_Unit then - if Present (Aux_Decls_Node (Context)) - and then Present (Pragmas_After (Aux_Decls_Node (Context))) - then - Decl := First (Pragmas_After (Aux_Decls_Node (Context))); - end if; - - -- Otherwise inspect the successive declarations for contract-related - -- source pragmas. - - else - Decl := Next (Unit); - end if; - - -- A generic subprogram body carries contract-related source pragmas in - -- its declarations. - - elsif Nkind (Templ) = N_Subprogram_Body then - Set_Ekind (Templ_Id, E_Subprogram_Body); - - if Present (Declarations (Templ)) then - Decl := First (Declarations (Templ)); - end if; - end if; - - -- Inspect the relevant declarations looking for contract-related source - -- pragmas and add them to the contract of the generic unit. - - while Present (Decl) loop - if Comes_From_Source (Decl) then - if Nkind (Decl) = N_Pragma then - - -- The source pragma is a contract annotation - - if Is_Contract_Annotation (Decl) then - Add_Generic_Contract_Pragma (Decl); - end if; - - -- The region where a contract-related source pragma may appear - -- ends with the first source non-pragma declaration or statement. - - else - exit; - end if; - end if; - - Next (Decl); - end loop; - end Create_Generic_Contract; - -------------------- -- Current_Entity -- -------------------- @@ -4974,76 +4950,75 @@ package body Sem_Util is -- Defining_Entity -- --------------------- - function Defining_Entity (N : Node_Id) return Entity_Id is - K : constant Node_Kind := Nkind (N); + function Defining_Entity + (N : Node_Id; + Empty_On_Errors : Boolean := False) return Entity_Id + is Err : Entity_Id := Empty; begin - case K is - when - N_Subprogram_Declaration | - N_Abstract_Subprogram_Declaration | - N_Subprogram_Body | - N_Package_Declaration | - N_Subprogram_Renaming_Declaration | - N_Subprogram_Body_Stub | - N_Generic_Subprogram_Declaration | - N_Generic_Package_Declaration | - N_Formal_Subprogram_Declaration | - N_Expression_Function + case Nkind (N) is + when N_Abstract_Subprogram_Declaration | + N_Expression_Function | + N_Formal_Subprogram_Declaration | + N_Generic_Package_Declaration | + N_Generic_Subprogram_Declaration | + N_Package_Declaration | + N_Subprogram_Body | + N_Subprogram_Body_Stub | + N_Subprogram_Declaration | + N_Subprogram_Renaming_Declaration => return Defining_Entity (Specification (N)); - when - N_Component_Declaration | - N_Defining_Program_Unit_Name | - N_Discriminant_Specification | - N_Entry_Body | - N_Entry_Declaration | - N_Entry_Index_Specification | - N_Exception_Declaration | - N_Exception_Renaming_Declaration | - N_Formal_Object_Declaration | - N_Formal_Package_Declaration | - N_Formal_Type_Declaration | - N_Full_Type_Declaration | - N_Implicit_Label_Declaration | - N_Incomplete_Type_Declaration | - N_Loop_Parameter_Specification | - N_Number_Declaration | - N_Object_Declaration | - N_Object_Renaming_Declaration | - N_Package_Body_Stub | - N_Parameter_Specification | - N_Private_Extension_Declaration | - N_Private_Type_Declaration | - N_Protected_Body | - N_Protected_Body_Stub | - N_Protected_Type_Declaration | - N_Single_Protected_Declaration | - N_Single_Task_Declaration | - N_Subtype_Declaration | - N_Task_Body | - N_Task_Body_Stub | - N_Task_Type_Declaration + when N_Component_Declaration | + N_Defining_Program_Unit_Name | + N_Discriminant_Specification | + N_Entry_Body | + N_Entry_Declaration | + N_Entry_Index_Specification | + N_Exception_Declaration | + N_Exception_Renaming_Declaration | + N_Formal_Object_Declaration | + N_Formal_Package_Declaration | + N_Formal_Type_Declaration | + N_Full_Type_Declaration | + N_Implicit_Label_Declaration | + N_Incomplete_Type_Declaration | + N_Loop_Parameter_Specification | + N_Number_Declaration | + N_Object_Declaration | + N_Object_Renaming_Declaration | + N_Package_Body_Stub | + N_Parameter_Specification | + N_Private_Extension_Declaration | + N_Private_Type_Declaration | + N_Protected_Body | + N_Protected_Body_Stub | + N_Protected_Type_Declaration | + N_Single_Protected_Declaration | + N_Single_Task_Declaration | + N_Subtype_Declaration | + N_Task_Body | + N_Task_Body_Stub | + N_Task_Type_Declaration => return Defining_Identifier (N); when N_Subunit => return Defining_Entity (Proper_Body (N)); - when - N_Function_Instantiation | - N_Function_Specification | - N_Generic_Function_Renaming_Declaration | - N_Generic_Package_Renaming_Declaration | - N_Generic_Procedure_Renaming_Declaration | - N_Package_Body | - N_Package_Instantiation | - N_Package_Renaming_Declaration | - N_Package_Specification | - N_Procedure_Instantiation | - N_Procedure_Specification + when N_Function_Instantiation | + N_Function_Specification | + N_Generic_Function_Renaming_Declaration | + N_Generic_Package_Renaming_Declaration | + N_Generic_Procedure_Renaming_Declaration | + N_Package_Body | + N_Package_Instantiation | + N_Package_Renaming_Declaration | + N_Package_Specification | + N_Procedure_Instantiation | + N_Procedure_Specification => declare Nam : constant Node_Id := Defining_Unit_Name (N); @@ -5052,14 +5027,18 @@ package body Sem_Util is if Nkind (Nam) in N_Entity then return Nam; - -- For Error, make up a name and attach to declaration - -- so we can continue semantic analysis + -- For Error, make up a name and attach to declaration so we + -- can continue semantic analysis. elsif Nam = Error then - Err := Make_Temporary (Sloc (N), 'T'); - Set_Defining_Unit_Name (N, Err); + if Empty_On_Errors then + return Empty; + else + Err := Make_Temporary (Sloc (N), 'T'); + Set_Defining_Unit_Name (N, Err); - return Err; + return Err; + end if; -- If not an entity, get defining identifier @@ -5068,14 +5047,16 @@ package body Sem_Util is end if; end; - when - N_Block_Statement | - N_Loop_Statement - => + when N_Block_Statement | + N_Loop_Statement => return Entity (Identifier (N)); when others => - raise Program_Error; + if Empty_On_Errors then + return Empty; + else + raise Program_Error; + end if; end case; end Defining_Entity; @@ -5111,7 +5092,6 @@ package body Sem_Util is (Is_Concurrent_Type (Scope (Discriminal_Link (E))) or else Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); - end Denotes_Discriminant; ------------------------- @@ -5375,7 +5355,6 @@ package body Sem_Util is ------------------------- function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is - begin if Is_Entity_Name (A1) then if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) @@ -6378,7 +6357,10 @@ package body Sem_Util is -- Follow a possible chain of renamings to reach the root renamed -- object. - while Present (Id) and then Present (Renamed_Object (Id)) loop + while Present (Id) + and then Is_Object (Id) + and then Present (Renamed_Object (Id)) + loop if Is_Entity_Name (Renamed_Object (Id)) then Id := Entity (Renamed_Object (Id)); else @@ -6563,23 +6545,27 @@ package body Sem_Util is Formal : out Entity_Id; Call : out Node_Id) is - Parnt : constant Node_Id := Parent (N); - Actual : Node_Id; + Context : constant Node_Id := Parent (N); + Actual : Node_Id; + Call_Nam : Node_Id; begin - if Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component) - and then N = Prefix (Parnt) + if Nkind_In (Context, N_Indexed_Component, N_Selected_Component) + and then N = Prefix (Context) then - Find_Actual (Parnt, Formal, Call); + Find_Actual (Context, Formal, Call); return; - elsif Nkind (Parnt) = N_Parameter_Association - and then N = Explicit_Actual_Parameter (Parnt) + elsif Nkind (Context) = N_Parameter_Association + and then N = Explicit_Actual_Parameter (Context) then - Call := Parent (Parnt); + Call := Parent (Context); - elsif Nkind (Parnt) in N_Subprogram_Call then - Call := Parnt; + elsif Nkind_In (Context, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) + then + Call := Context; else Formal := Empty; @@ -6591,44 +6577,57 @@ package body Sem_Util is -- we exclude overloaded calls, since we don't know enough to be sure -- of giving the right answer in this case. - if Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement) - and then Is_Entity_Name (Name (Call)) - and then Present (Entity (Name (Call))) - and then Is_Overloadable (Entity (Name (Call))) - and then not Is_Overloaded (Name (Call)) + if Nkind_In (Call, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) then - -- If node is name in call it is not an actual + Call_Nam := Name (Call); - if N = Name (Call) then - Call := Empty; - Formal := Empty; - return; + -- A call to a protected or task entry appears as a selected + -- component rather than an expanded name. + + if Nkind (Call_Nam) = N_Selected_Component then + Call_Nam := Selector_Name (Call_Nam); end if; - -- Fall here if we are definitely a parameter + if Is_Entity_Name (Call_Nam) + and then Present (Entity (Call_Nam)) + and then Is_Overloadable (Entity (Call_Nam)) + and then not Is_Overloaded (Call_Nam) + then + -- If node is name in call it is not an actual - Actual := First_Actual (Call); - Formal := First_Formal (Entity (Name (Call))); - while Present (Formal) and then Present (Actual) loop - if Actual = N then + if N = Call_Nam then + Formal := Empty; + Call := Empty; return; + end if; - -- An actual that is the prefix in a prefixed call may have - -- been rewritten in the call, after the deferred reference - -- was collected. Check if sloc and kinds and names match. + -- Fall here if we are definitely a parameter - elsif Sloc (Actual) = Sloc (N) - and then Nkind (Actual) = N_Identifier - and then Nkind (Actual) = Nkind (N) - and then Chars (Actual) = Chars (N) - then - return; + Actual := First_Actual (Call); + Formal := First_Formal (Entity (Call_Nam)); + while Present (Formal) and then Present (Actual) loop + if Actual = N then + return; - else - Actual := Next_Actual (Actual); - Formal := Next_Formal (Formal); - end if; - end loop; + -- An actual that is the prefix in a prefixed call may have + -- been rewritten in the call, after the deferred reference + -- was collected. Check if sloc and kinds and names match. + + elsif Sloc (Actual) = Sloc (N) + and then Nkind (Actual) = N_Identifier + and then Nkind (Actual) = Nkind (N) + and then Chars (Actual) = Chars (N) + then + return; + + else + Actual := Next_Actual (Actual); + Formal := Next_Formal (Formal); + end if; + end loop; + end if; end if; -- Fall through here if we did not find matching actual @@ -7095,6 +7094,70 @@ package body Sem_Util is end if; end First_Actual; + ------------- + -- Fix_Msg -- + ------------- + + function Fix_Msg (Id : Entity_Id; Msg : String) return String is + Is_Task : constant Boolean := + Ekind_In (Id, E_Task_Body, E_Task_Type) + or else (Is_Single_Concurrent_Object (Id) + and then Ekind (Etype (Id)) = E_Task_Type); + Msg_Last : constant Natural := Msg'Last; + Msg_Index : Natural; + Res : String (Msg'Range) := (others => ' '); + Res_Index : Natural; + + begin + -- Copy all characters from the input message Msg to result Res with + -- suitable replacements. + + Msg_Index := Msg'First; + Res_Index := Res'First; + while Msg_Index <= Msg_Last loop + + -- Replace "subprogram" with a different word + + if Msg_Index <= Msg_Last - 10 + and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram" + then + if Ekind_In (Id, E_Entry, E_Entry_Family) then + Res (Res_Index .. Res_Index + 4) := "entry"; + Res_Index := Res_Index + 5; + + elsif Is_Task then + Res (Res_Index .. Res_Index + 8) := "task type"; + Res_Index := Res_Index + 9; + + else + Res (Res_Index .. Res_Index + 9) := "subprogram"; + Res_Index := Res_Index + 10; + end if; + + Msg_Index := Msg_Index + 10; + + -- Replace "protected" with a different word + + elsif Msg_Index <= Msg_Last - 9 + and then Msg (Msg_Index .. Msg_Index + 8) = "protected" + and then Is_Task + then + Res (Res_Index .. Res_Index + 3) := "task"; + Res_Index := Res_Index + 4; + Msg_Index := Msg_Index + 9; + + -- Otherwise copy the character + + else + Res (Res_Index) := Msg (Msg_Index); + Msg_Index := Msg_Index + 1; + Res_Index := Res_Index + 1; + end if; + end loop; + + return Res (Res'First .. Res_Index - 1); + end Fix_Msg; + ----------------------- -- Gather_Components -- ----------------------- @@ -7292,10 +7355,11 @@ package body Sem_Util is end if; -- If we have found the corresponding choice, recursively add its - -- components to the Into list. + -- components to the Into list. The nested components are part of + -- the same record type. Gather_Components - (Empty, Component_List (Variant), Governed_By, Into, Report_Errors); + (Typ, Component_List (Variant), Governed_By, Into, Report_Errors); end Gather_Components; ------------------------ @@ -7495,7 +7559,7 @@ package body Sem_Util is ("Operation First for iterable type must be unique", Aspect); return Any_Type; else - Cursor := Etype (Func); + Cursor := Etype (Func); end if; end if; @@ -7804,6 +7868,7 @@ package body Sem_Util is return Defining_Entity (Unit); end if; end Get_Parent_Entity; + ------------------- -- Get_Pragma_Id -- ------------------- @@ -7837,6 +7902,25 @@ package body Sem_Util is end if; end Get_Reason_String; + -------------------------------- + -- Get_Reference_Discriminant -- + -------------------------------- + + function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is + D : Entity_Id; + + begin + D := First_Discriminant (Typ); + while Present (D) loop + if Has_Implicit_Dereference (D) then + return D; + end if; + Next_Discriminant (D); + end loop; + + return Empty; + end Get_Reference_Discriminant; + --------------------------- -- Get_Referenced_Object -- --------------------------- @@ -8475,6 +8559,39 @@ package body Sem_Util is return False; end Has_Discriminant_Dependent_Constraint; + -------------------------------------- + -- Has_Effectively_Volatile_Profile -- + -------------------------------------- + + function Has_Effectively_Volatile_Profile + (Subp_Id : Entity_Id) return Boolean + is + Formal : Entity_Id; + + begin + -- Inspect the formal parameters looking for an effectively volatile + -- type. + + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + if Is_Effectively_Volatile (Etype (Formal)) then + return True; + end if; + + Next_Formal (Formal); + end loop; + + -- Inspect the return type of functions + + if Ekind_In (Subp_Id, E_Function, E_Generic_Function) + and then Is_Effectively_Volatile (Etype (Subp_Id)) + then + return True; + end if; + + return False; + end Has_Effectively_Volatile_Profile; + -------------------------- -- Has_Enabled_Property -- -------------------------- @@ -8599,18 +8716,18 @@ package body Sem_Util is ---------------- function Is_Enabled (Prag : Node_Id) return Boolean is - Arg2 : Node_Id; + Arg1 : Node_Id; begin if Present (Prag) then - Arg2 := Next (First (Pragma_Argument_Associations (Prag))); + Arg1 := First (Pragma_Argument_Associations (Prag)); -- The pragma has an optional Boolean expression, the related -- property is enabled only when the expression evaluates to -- True. - if Present (Arg2) then - return Is_True (Expr_Value (Get_Pragma_Arg (Arg2))); + if Present (Arg1) then + return Is_True (Expr_Value (Get_Pragma_Arg (Arg1))); -- Otherwise the lack of expression enables the property by -- default. @@ -8694,6 +8811,92 @@ package body Sem_Util is end if; end Has_Enabled_Property; + ------------------------------------- + -- Has_Full_Default_Initialization -- + ------------------------------------- + + function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is + Comp : Entity_Id; + + begin + -- A scalar type is fully default initialized if it is subject to aspect + -- Default_Value. + + if Is_Scalar_Type (Typ) then + return Has_Default_Aspect (Typ); + + -- An array type is fully default initialized if its element type is + -- scalar and the array type carries aspect Default_Component_Value or + -- the element type is fully default initialized. + + elsif Is_Array_Type (Typ) then + return + Has_Default_Aspect (Typ) + or else Has_Full_Default_Initialization (Component_Type (Typ)); + + -- A protected type, record type or type extension is fully default + -- initialized if all its components either carry an initialization + -- expression or have a type that is fully default initialized. The + -- parent type of a type extension must be fully default initialized. + + elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then + + -- Inspect all entities defined in the scope of the type, looking for + -- uninitialized components. + + Comp := First_Entity (Typ); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Comes_From_Source (Comp) + and then No (Expression (Parent (Comp))) + and then not Has_Full_Default_Initialization (Etype (Comp)) + then + return False; + end if; + + Next_Entity (Comp); + end loop; + + -- Ensure that the parent type of a type extension is fully default + -- initialized. + + if Etype (Typ) /= Typ + and then not Has_Full_Default_Initialization (Etype (Typ)) + then + return False; + end if; + + -- If we get here, then all components and parent portion are fully + -- default initialized. + + return True; + + -- A task type is fully default initialized by default + + elsif Is_Task_Type (Typ) then + return True; + end if; + + -- A private type and by extension its full view is fully default + -- initialized if it is subject to pragma Default_Initial_Condition + -- with a non-null argument or inherits the pragma from a parent type. + -- Since any type can act as the full view of a private type, this check + -- is separated from the circuitry above. + + if Has_Default_Init_Cond (Typ) + or else Has_Inherited_Default_Init_Cond (Typ) + then + return + Nkind (First (Pragma_Argument_Associations (Get_Pragma + (Typ, Pragma_Default_Initial_Condition)))) /= N_Null; + + -- Otherwise the type is not fully default initialized + + else + return False; + end if; + end Has_Full_Default_Initialization; + -------------------- -- Has_Infinities -- -------------------- @@ -10127,6 +10330,25 @@ package body Sem_Util is Item := Next_Rep_Item (Item); end loop; + Item := First_Rep_Item (From_Typ); + + -- Additional check when both parent and current type have rep. + -- items, to prevent circularities when the derivation completes + -- a private declaration and inherits from both views of the parent. + -- There may be a remaining problem with the proper ordering of + -- attribute specifications and aspects on the chains of the four + -- entities involved. ??? + + if Present (Item) and then Present (From_Item) then + while Present (Item) loop + if Item = First_Rep_Item (Typ) then + return; + end if; + + Item := Next_Rep_Item (Item); + end loop; + end if; + -- When the destination type has a rep item chain, the chain of the -- source type is appended to it. @@ -10142,53 +10364,6 @@ package body Sem_Util is end Inherit_Rep_Item_Chain; --------------------------------- - -- Inherit_Subprogram_Contract -- - --------------------------------- - - procedure Inherit_Subprogram_Contract - (Subp : Entity_Id; - From_Subp : Entity_Id) - is - procedure Inherit_Pragma (Prag_Id : Pragma_Id); - -- Propagate a pragma denoted by Prag_Id from From_Subp's contract to - -- Subp's contract. - - -------------------- - -- Inherit_Pragma -- - -------------------- - - procedure Inherit_Pragma (Prag_Id : Pragma_Id) is - Prag : constant Node_Id := Get_Pragma (From_Subp, Prag_Id); - New_Prag : Node_Id; - - begin - -- A pragma cannot be part of more than one First_Pragma/Next_Pragma - -- chains, therefore the node must be replicated. The new pragma is - -- flagged is inherited for distrinction purposes. - - if Present (Prag) then - New_Prag := New_Copy_Tree (Prag); - Set_Is_Inherited (New_Prag); - - Add_Contract_Item (New_Prag, Subp); - end if; - end Inherit_Pragma; - - -- Start of processing for Inherit_Subprogram_Contract - - begin - -- Inheritance is carried out only when both entities are subprograms - -- with contracts. - - if Is_Subprogram_Or_Generic_Subprogram (Subp) - and then Is_Subprogram_Or_Generic_Subprogram (From_Subp) - and then Present (Contract (From_Subp)) - then - Inherit_Pragma (Pragma_Extensions_Visible); - end if; - end Inherit_Subprogram_Contract; - - --------------------------------- -- Insert_Explicit_Dereference -- --------------------------------- @@ -11111,53 +11286,16 @@ package body Sem_Util is end case; end Is_Declaration; - ----------------- - -- Is_Delegate -- - ----------------- - - function Is_Delegate (T : Entity_Id) return Boolean is - Desig_Type : Entity_Id; + -------------------------------- + -- Is_Declared_Within_Variant -- + -------------------------------- + function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is + Comp_Decl : constant Node_Id := Parent (Comp); + Comp_List : constant Node_Id := Parent (Comp_Decl); begin - if VM_Target /= CLI_Target then - return False; - end if; - - -- Access-to-subprograms are delegates in CIL - - if Ekind (T) = E_Access_Subprogram_Type then - return True; - end if; - - if not Is_Access_Type (T) then - - -- A delegate is a managed pointer. If no designated type is defined - -- it means that it's not a delegate. - - return False; - end if; - - Desig_Type := Etype (Directly_Designated_Type (T)); - - if not Is_Tagged_Type (Desig_Type) then - return False; - end if; - - -- Test if the type is inherited from [mscorlib]System.Delegate - - while Etype (Desig_Type) /= Desig_Type loop - if Chars (Scope (Desig_Type)) /= No_Name - and then Is_Imported (Scope (Desig_Type)) - and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" - then - return True; - end if; - - Desig_Type := Etype (Desig_Type); - end loop; - - return False; - end Is_Delegate; + return Nkind (Parent (Comp_List)) = N_Variant; + end Is_Declared_Within_Variant; ---------------------------------------------- -- Is_Dependent_Component_Of_Mutable_Object -- @@ -11166,20 +11304,6 @@ package body Sem_Util is function Is_Dependent_Component_Of_Mutable_Object (Object : Node_Id) return Boolean is - function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean; - -- Returns True if and only if Comp is declared within a variant part - - -------------------------------- - -- Is_Declared_Within_Variant -- - -------------------------------- - - function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is - Comp_Decl : constant Node_Id := Parent (Comp); - Comp_List : constant Node_Id := Parent (Comp_Decl); - begin - return Nkind (Parent (Comp_List)) = N_Variant; - end Is_Declared_Within_Variant; - P : Node_Id; Prefix_Type : Entity_Id; P_Aliased : Boolean := False; @@ -11409,6 +11533,42 @@ package body Sem_Util is end if; end Is_Descendent_Of; + ---------------------------------------- + -- Is_Descendant_Of_Suspension_Object -- + ---------------------------------------- + + function Is_Descendant_Of_Suspension_Object + (Typ : Entity_Id) return Boolean + is + Cur_Typ : Entity_Id; + Par_Typ : Entity_Id; + + begin + -- Climb the type derivation chain checking each parent type against + -- Suspension_Object. + + Cur_Typ := Base_Type (Typ); + while Present (Cur_Typ) loop + Par_Typ := Etype (Cur_Typ); + + -- The current type is a match + + if Is_Suspension_Object (Cur_Typ) then + return True; + + -- Stop the traversal once the root of the derivation chain has been + -- reached. In that case the current type is its own base type. + + elsif Cur_Typ = Par_Typ then + exit; + end if; + + Cur_Typ := Base_Type (Par_Typ); + end loop; + + return False; + end Is_Descendant_Of_Suspension_Object; + --------------------------------------------- -- Is_Double_Precision_Floating_Point_Type -- --------------------------------------------- @@ -11447,6 +11607,19 @@ package body Sem_Util is or else Is_Effectively_Volatile (Component_Type (Base_Type (Id))); + -- A protected type is always volatile + + elsif Is_Protected_Type (Id) then + return True; + + -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is + -- automatically volatile. + + elsif Is_Descendant_Of_Suspension_Object (Id) then + return True; + + -- Otherwise the type is not effectively volatile + else return False; end if; @@ -11487,31 +11660,73 @@ package body Sem_Util is end if; end Is_Effectively_Volatile_Object; + ------------------- + -- Is_Entry_Body -- + ------------------- + + function Is_Entry_Body (Id : Entity_Id) return Boolean is + begin + return + Ekind_In (Id, E_Entry, E_Entry_Family) + and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body; + end Is_Entry_Body; + + -------------------------- + -- Is_Entry_Declaration -- + -------------------------- + + function Is_Entry_Declaration (Id : Entity_Id) return Boolean is + begin + return + Ekind_In (Id, E_Entry, E_Entry_Family) + and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration; + end Is_Entry_Declaration; + ---------------------------- -- Is_Expression_Function -- ---------------------------- function Is_Expression_Function (Subp : Entity_Id) return Boolean is - Decl : Node_Id; - begin - if Ekind (Subp) /= E_Function then + if Ekind_In (Subp, E_Function, E_Subprogram_Body) then + return + Nkind (Original_Node (Unit_Declaration_Node (Subp))) = + N_Expression_Function; + else return False; + end if; + end Is_Expression_Function; + + ------------------------------------------ + -- Is_Expression_Function_Or_Completion -- + ------------------------------------------ + + function Is_Expression_Function_Or_Completion + (Subp : Entity_Id) return Boolean + is + Subp_Decl : Node_Id; + + begin + if Ekind (Subp) = E_Function then + Subp_Decl := Unit_Declaration_Node (Subp); + + -- The function declaration is either an expression function or is + -- completed by an expression function body. + + return + Is_Expression_Function (Subp) + or else (Nkind (Subp_Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Subp_Decl)) + and then Is_Expression_Function + (Corresponding_Body (Subp_Decl))); + + elsif Ekind (Subp) = E_Subprogram_Body then + return Is_Expression_Function (Subp); else - Decl := Unit_Declaration_Node (Subp); - return Nkind (Decl) = N_Subprogram_Declaration - and then - (Nkind (Original_Node (Decl)) = N_Expression_Function - or else - (Present (Corresponding_Body (Decl)) - and then - Nkind (Original_Node - (Unit_Declaration_Node - (Corresponding_Body (Decl)))) = - N_Expression_Function)); + return False; end if; - end Is_Expression_Function; + end Is_Expression_Function_Or_Completion; ----------------------- -- Is_EVF_Expression -- @@ -11574,7 +11789,7 @@ package body Sem_Util is then return Is_EVF_Expression (Expression (N)); - -- Attributes 'Loop_Entry, 'Old and 'Update are an EVF expression when + -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when -- their prefix denotes an EVF expression. elsif Nkind (N) = N_Attribute_Reference @@ -11971,17 +12186,37 @@ package body Sem_Util is ----------------- function Is_Iterator (Typ : Entity_Id) return Boolean is - Ifaces_List : Elist_Id; - Iface_Elmt : Elmt_Id; - Iface : Entity_Id; + function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean; + -- Determine whether type Iter_Typ is a predefined forward or reversible + -- iterator. + + ---------------------- + -- Denotes_Iterator -- + ---------------------- + + function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is + begin + return + Nam_In (Chars (Iter_Typ), Name_Forward_Iterator, + Name_Reversible_Iterator) + and then Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Iter_Typ))); + end Denotes_Iterator; + + -- Local variables + + Iface_Elmt : Elmt_Id; + Ifaces : Elist_Id; + + -- Start of processing for Is_Iterator begin + -- The type may be a subtype of a descendant of the proper instance of + -- the predefined interface type, so we must use the root type of the + -- given type. The same is done for Is_Reversible_Iterator. + if Is_Class_Wide_Type (Typ) - and then Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator, - Name_Reversible_Iterator) - and then - Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) + and then Denotes_Iterator (Root_Type (Typ)) then return True; @@ -11992,16 +12227,11 @@ package body Sem_Util is return True; else - Collect_Interfaces (Typ, Ifaces_List); + Collect_Interfaces (Typ, Ifaces); - Iface_Elmt := First_Elmt (Ifaces_List); + Iface_Elmt := First_Elmt (Ifaces); while Present (Iface_Elmt) loop - Iface := Node (Iface_Elmt); - if Chars (Iface) = Name_Forward_Iterator - and then - Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Iface))) - then + if Denotes_Iterator (Node (Iface_Elmt)) then return True; end if; @@ -12012,6 +12242,17 @@ package body Sem_Util is end if; end Is_Iterator; + ---------------------------- + -- Is_Iterator_Over_Array -- + ---------------------------- + + function Is_Iterator_Over_Array (N : Node_Id) return Boolean is + Container : constant Node_Id := Name (N); + Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); + begin + return Is_Array_Type (Container_Typ); + end Is_Iterator_Over_Array; + ------------ -- Is_LHS -- ------------ @@ -12171,12 +12412,15 @@ package body Sem_Util is when N_Function_Call => return Etype (N) /= Standard_Void_Type; - -- Attributes 'Input, 'Old and 'Result produce objects + -- Attributes 'Input, 'Loop_Entry, 'Old and 'Result produce + -- objects. when N_Attribute_Reference => return - Nam_In - (Attribute_Name (N), Name_Input, Name_Old, Name_Result); + Nam_In (Attribute_Name (N), Name_Input, + Name_Loop_Entry, + Name_Old, + Name_Result); when N_Selected_Component => return @@ -12324,7 +12568,15 @@ package body Sem_Util is and then Has_Implicit_Dereference (Etype (Name (Original_Node (AV)))) then - return True; + + -- Check that this is not a constant reference. + + return not Is_Access_Constant (Etype (Prefix (AV))); + + elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then + return + not Is_Access_Constant (Etype + (Get_Reference_Discriminant (Etype (Original_Node (AV))))); else return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); @@ -12567,7 +12819,7 @@ package body Sem_Util is -- occurrence of 'Old in that operand is potentially unevaluated. -- See Sem_ch13.adb for details of this transformation. - if Nkind (Original_Node (Par)) = N_And_Then then + if Nkind (Original_Node (Par)) = N_And_Then then return True; end if; @@ -12642,9 +12894,9 @@ package body Sem_Util is begin -- Verify that prefix is analyzed and has the proper form. Note that - -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address, - -- which also produce the address of an entity, do not analyze their - -- prefix because they denote entities that are not necessarily visible. + -- the attributes Elab_Spec, Elab_Body and Elab_Subp_Body which also + -- produce the address of an entity, do not analyze their prefix + -- because they denote entities that are not necessarily visible. -- Neither of them can apply to a protected type. return Ada_Version >= Ada_2005 @@ -12844,9 +13096,9 @@ package body Sem_Util is begin if Is_Class_Wide_Type (Typ) - and then Chars (Etype (Typ)) = Name_Reversible_Iterator + and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator and then Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) + (Unit_File_Name (Get_Source_Unit (Root_Type (Typ)))) then return True; @@ -12905,6 +13157,41 @@ package body Sem_Util is end if; end Is_Selector_Name; + --------------------------------- + -- Is_Single_Concurrent_Object -- + --------------------------------- + + function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean is + begin + return + Ekind (Id) = E_Variable + and then Is_Single_Concurrent_Type (Etype (Id)); + end Is_Single_Concurrent_Object; + + ------------------------------- + -- Is_Single_Concurrent_Type -- + ------------------------------- + + function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is + begin + return + Ekind_In (Id, E_Protected_Type, E_Task_Type) + and then Is_Single_Concurrent_Type_Declaration + (Declaration_Node (Id)); + end Is_Single_Concurrent_Type; + + ------------------------------------------- + -- Is_Single_Concurrent_Type_Declaration -- + ------------------------------------------- + + function Is_Single_Concurrent_Type_Declaration + (N : Node_Id) return Boolean + is + begin + return Nkind_In (Original_Node (N), N_Single_Protected_Declaration, + N_Single_Task_Declaration); + end Is_Single_Concurrent_Type_Declaration; + --------------------------------------------- -- Is_Single_Precision_Floating_Point_Type -- --------------------------------------------- @@ -13145,6 +13432,71 @@ package body Sem_Util is and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body; end Is_Subprogram_Stub_Without_Prior_Declaration; + -------------------------- + -- Is_Suspension_Object -- + -------------------------- + + function Is_Suspension_Object (Id : Entity_Id) return Boolean is + begin + -- This approach does an exact name match rather than to rely on + -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the + -- front end at point where all auxiliary tables are locked and any + -- modifications to them are treated as violations. Do not tamper with + -- the tables, instead examine the Chars fields of all the scopes of Id. + + return + Chars (Id) = Name_Suspension_Object + and then Present (Scope (Id)) + and then Chars (Scope (Id)) = Name_Synchronous_Task_Control + and then Present (Scope (Scope (Id))) + and then Chars (Scope (Scope (Id))) = Name_Ada + and then Present (Scope (Scope (Scope (Id)))) + and then Scope (Scope (Scope (Id))) = Standard_Standard; + end Is_Suspension_Object; + + ---------------------------- + -- Is_Synchronized_Object -- + ---------------------------- + + function Is_Synchronized_Object (Id : Entity_Id) return Boolean is + Prag : Node_Id; + + begin + if Is_Object (Id) then + + -- The object is synchronized if it is of a type that yields a + -- synchronized object. + + if Yields_Synchronized_Object (Etype (Id)) then + return True; + + -- The object is synchronized if it is atomic and Async_Writers is + -- enabled. + + elsif Is_Atomic (Id) and then Async_Writers_Enabled (Id) then + return True; + + -- A constant is a synchronized object by default + + elsif Ekind (Id) = E_Constant then + return True; + + -- A variable is a synchronized object if it is subject to pragma + -- Constant_After_Elaboration. + + elsif Ekind (Id) = E_Variable then + Prag := Get_Pragma (Id, Pragma_Constant_After_Elaboration); + + return Present (Prag) and then Is_Enabled_Pragma (Prag); + end if; + end if; + + -- Otherwise the input is not an object or it does not qualify as a + -- synchronized object. + + return False; + end Is_Synchronized_Object; + --------------------------------- -- Is_Synchronized_Tagged_Type -- --------------------------------- @@ -13255,18 +13607,6 @@ package body Sem_Util is return T = Universal_Integer or else T = Universal_Real; end Is_Universal_Numeric_Type; - ------------------- - -- Is_Value_Type -- - ------------------- - - function Is_Value_Type (T : Entity_Id) return Boolean is - begin - return VM_Target = CLI_Target - and then Nkind (T) in N_Has_Chars - and then Chars (T) /= No_Name - and then Get_Name_String (Chars (T)) = "valuetype"; - end Is_Value_Type; - ---------------------------- -- Is_Variable_Size_Array -- ---------------------------- @@ -13581,6 +13921,41 @@ package body Sem_Util is and then Scope (Scope (Scope (Root))) = Standard_Standard; end Is_Visibly_Controlled; + -------------------------- + -- Is_Volatile_Function -- + -------------------------- + + function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is + begin + -- The caller must ensure that Func_Id denotes a function + + pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function)); + + -- A protected function is automatically volatile + + if Is_Primitive (Func_Id) + and then Present (First_Formal (Func_Id)) + and then Is_Protected_Type (Etype (First_Formal (Func_Id))) + then + return True; + + -- An instance of Ada.Unchecked_Conversion is a volatile function if + -- either the source or the target are effectively volatile. + + elsif Is_Unchecked_Conversion_Instance (Func_Id) + and then Has_Effectively_Volatile_Profile (Func_Id) + then + return True; + + -- Otherwise the function is treated as volatile if it is subject to + -- enabled pragma Volatile_Function. + + else + return + Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function)); + end if; + end Is_Volatile_Function; + ------------------------ -- Is_Volatile_Object -- ------------------------ @@ -14282,44 +14657,58 @@ package body Sem_Util is procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); - -- Start of processing Mark_Coextensions + -- Start of processing for Mark_Coextensions begin - case Nkind (Context_Nod) is + -- An allocator that appears on the right-hand side of an assignment is + -- treated as a potentially dynamic coextension when the right-hand side + -- is an allocator or a qualified expression. - -- Comment here ??? + -- Obj := new ...'(new Coextension ...); - when N_Assignment_Statement => - Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator; + if Nkind (Context_Nod) = N_Assignment_Statement then + Is_Dynamic := + Nkind_In (Expression (Context_Nod), N_Allocator, + N_Qualified_Expression); - -- An allocator that is a component of a returned aggregate - -- must be dynamic. + -- An allocator that appears within the expression of a simple return + -- statement is treated as a potentially dynamic coextension when the + -- expression is either aggregate, allocator, or qualified expression. - when N_Simple_Return_Statement => - declare - Expr : constant Node_Id := Expression (Context_Nod); - begin - Is_Dynamic := - Nkind (Expr) = N_Allocator - or else - (Nkind (Expr) = N_Qualified_Expression - and then Nkind (Expression (Expr)) = N_Aggregate); - end; + -- return (new Coextension ...); + -- return new ...'(new Coextension ...); - -- An alloctor within an object declaration in an extended return - -- statement is of necessity dynamic. + elsif Nkind (Context_Nod) = N_Simple_Return_Statement then + Is_Dynamic := + Nkind_In (Expression (Context_Nod), N_Aggregate, + N_Allocator, + N_Qualified_Expression); - when N_Object_Declaration => - Is_Dynamic := Nkind (Root_Nod) = N_Allocator - or else - Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; + -- An alloctor that appears within the initialization expression of an + -- object declaration is considered a potentially dynamic coextension + -- when the initialization expression is an allocator or a qualified + -- expression. - -- This routine should not be called for constructs which may not - -- contain coextensions. + -- Obj : ... := new ...'(new Coextension ...); - when others => - raise Program_Error; - end case; + -- A similar case arises when the object declaration is part of an + -- extended return statement. + + -- return Obj : ... := new ...'(new Coextension ...); + -- return Obj : ... := (new Coextension ...); + + elsif Nkind (Context_Nod) = N_Object_Declaration then + Is_Dynamic := + Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression) + or else + Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; + + -- This routine should not be called with constructs that cannot contain + -- coextensions. + + else + raise Program_Error; + end if; Mark_Allocators (Root_Nod); end Mark_Coextensions; @@ -14734,7 +15123,7 @@ package body Sem_Util is and then Present (Next_Named_Actual (Old_E)) then if First_Named_Actual (Old_Node) - = Explicit_Actual_Parameter (Old_E) + = Explicit_Actual_Parameter (Old_E) then Set_First_Named_Actual (New_Node, Explicit_Actual_Parameter (New_E)); @@ -15286,7 +15675,10 @@ package body Sem_Util is while Present (Elmt) loop Next_Elmt (Elmt); New_Itype := Node (Elmt); - Copy_Itype_With_Replacement (New_Itype); + + if Is_Itype (New_Itype) then + Copy_Itype_With_Replacement (New_Itype); + end if; Next_Elmt (Elmt); end loop; end; @@ -15859,8 +16251,6 @@ package body Sem_Util is end; end if; end if; - - Check_Nested_Access (Ent); end if; Kill_Checks (Ent); @@ -15999,10 +16389,15 @@ package body Sem_Util is return Type_Access_Level (Scope (E)) + 1; else - -- Aliased formals take their access level from the point of call. - -- This is smaller than the level of the subprogram itself. - - if Is_Formal (E) and then Is_Aliased (E) then + -- Aliased formals of functions take their access level from the + -- point of call, i.e. require a dynamic check. For static check + -- purposes, this is smaller than the level of the subprogram + -- itself. For procedures the aliased makes no difference. + + if Is_Formal (E) + and then Is_Aliased (E) + and then Ekind (Scope (E)) = E_Function + then return Type_Access_Level (Etype (E)); else @@ -16846,6 +17241,106 @@ package body Sem_Util is end if; end Remove_Homonym; + ------------------------------ + -- Remove_Overloaded_Entity -- + ------------------------------ + + procedure Remove_Overloaded_Entity (Id : Entity_Id) is + procedure Remove_Primitive_Of (Typ : Entity_Id); + -- Remove primitive subprogram Id from the list of primitives that + -- belong to type Typ. + + ------------------------- + -- Remove_Primitive_Of -- + ------------------------- + + procedure Remove_Primitive_Of (Typ : Entity_Id) is + Prims : Elist_Id; + + begin + if Is_Tagged_Type (Typ) then + Prims := Direct_Primitive_Operations (Typ); + + if Present (Prims) then + Remove (Prims, Id); + end if; + end if; + end Remove_Primitive_Of; + + -- Local variables + + Scop : constant Entity_Id := Scope (Id); + Formal : Entity_Id; + Prev_Id : Entity_Id; + + -- Start of processing for Remove_Overloaded_Entity + + begin + -- Remove the entity from the homonym chain. When the entity is the + -- head of the chain, associate the entry in the name table with its + -- homonym effectively making it the new head of the chain. + + if Current_Entity (Id) = Id then + Set_Name_Entity_Id (Chars (Id), Homonym (Id)); + + -- Otherwise link the previous and next homonyms + + else + Prev_Id := Current_Entity (Id); + while Present (Prev_Id) and then Homonym (Prev_Id) /= Id loop + Prev_Id := Homonym (Prev_Id); + end loop; + + Set_Homonym (Prev_Id, Homonym (Id)); + end if; + + -- Remove the entity from the scope entity chain. When the entity is + -- the head of the chain, set the next entity as the new head of the + -- chain. + + if First_Entity (Scop) = Id then + Prev_Id := Empty; + Set_First_Entity (Scop, Next_Entity (Id)); + + -- Otherwise the entity is either in the middle of the chain or it acts + -- as its tail. Traverse and link the previous and next entities. + + else + Prev_Id := First_Entity (Scop); + while Present (Prev_Id) and then Next_Entity (Prev_Id) /= Id loop + Next_Entity (Prev_Id); + end loop; + + Set_Next_Entity (Prev_Id, Next_Entity (Id)); + end if; + + -- Handle the case where the entity acts as the tail of the scope entity + -- chain. + + if Last_Entity (Scop) = Id then + Set_Last_Entity (Scop, Prev_Id); + end if; + + -- The entity denotes a primitive subprogram. Remove it from the list of + -- primitives of the associated controlling type. + + if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then + Formal := First_Formal (Id); + while Present (Formal) loop + if Is_Controlling_Formal (Formal) then + Remove_Primitive_Of (Etype (Formal)); + exit; + end if; + + Next_Formal (Formal); + end loop; + + if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then + Remove_Primitive_Of (Etype (Id)); + end if; + end if; + end Remove_Overloaded_Entity; + --------------------- -- Rep_To_Pos_Flag -- --------------------- @@ -16856,6 +17351,63 @@ package body Sem_Util is (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); end Rep_To_Pos_Flag; + ------------------------------- + -- Report_Unused_Body_States -- + ------------------------------- + + procedure Report_Unused_Body_States + (Body_Id : Entity_Id; + States : Elist_Id) + is + Posted : Boolean := False; + State_Elmt : Elmt_Id; + State_Id : Entity_Id; + + begin + if Present (States) then + State_Elmt := First_Elmt (States); + while Present (State_Elmt) loop + State_Id := Node (State_Elmt); + + -- Constants are part of the hidden state of a package, but the + -- compiler cannot determine whether they have variable input + -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a + -- hidden state. Do not emit an error when a constant does not + -- participate in a state refinement, even though it acts as a + -- hidden state. + + if Ekind (State_Id) = E_Constant then + null; + + -- Generate an error message of the form: + + -- body of package ... has unused hidden states + -- abstract state ... defined at ... + -- variable ... defined at ... + + else + if not Posted then + Posted := True; + SPARK_Msg_N + ("body of package & has unused hidden states", Body_Id); + end if; + + Error_Msg_Sloc := Sloc (State_Id); + + if Ekind (State_Id) = E_Abstract_State then + SPARK_Msg_NE + ("\abstract state & defined #", Body_Id, State_Id); + + else + SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id); + end if; + end if; + + Next_Elmt (State_Elmt); + end loop; + end if; + end Report_Unused_Body_States; + -------------------- -- Require_Entity -- -------------------- @@ -16963,6 +17515,24 @@ package body Sem_Util is -- efficiency. Note: when this temporary code is removed, the documentation -- of dQ in debug.adb should be removed. + procedure Results_Differ (Id : Entity_Id); + -- ???Debugging code. Called when the Old_ and New_ results differ. Will be + -- removed when New_Requires_Transient_Scope becomes + -- Requires_Transient_Scope and Old_Requires_Transient_Scope is eliminated. + + procedure Results_Differ (Id : Entity_Id) is + begin + if False then -- False to disable; True for debugging + Treepr.Print_Tree_Node (Id); + + if Old_Requires_Transient_Scope (Id) = + New_Requires_Transient_Scope (Id) + then + raise Program_Error; + end if; + end if; + end Results_Differ; + function Requires_Transient_Scope (Id : Entity_Id) return Boolean is Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id); @@ -16984,6 +17554,10 @@ package body Sem_Util is null; end if; + if New_Result /= Old_Result then + Results_Differ (Id); + end if; + return New_Result; end; end Requires_Transient_Scope; @@ -16998,7 +17572,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). Do not expand transient scope in this case. if No (Typ) then return False; @@ -17026,7 +17600,7 @@ package body Sem_Util is -- type temporaries need finalization. elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then - return not Is_Value_Type (Typ); + return True; -- Record type @@ -17103,10 +17677,14 @@ package body Sem_Util is -- could be nested inside some other record that is constrained by -- nondiscriminants). That is, the recursive calls are too conservative. - function Has_Discrim_Dep_Array (Typ : Entity_Id) return Boolean; - -- True if we find certain discriminant-dependent array - -- subcomponents. This shouldn't be necessary, but without this check, - -- we crash in gimplify. ??? + function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean; + -- Returns True if Typ is a nonlimited record with defaulted + -- discriminants whose max size makes it unsuitable for allocating on + -- the primary stack. + + ------------------------------ + -- Caller_Known_Size_Record -- + ------------------------------ function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is pragma Assert (Typ = Underlying_Type (Typ)); @@ -17117,9 +17695,10 @@ package body Sem_Util is end if; declare - Comp : Entity_Id := First_Entity (Typ); + Comp : Entity_Id; begin + Comp := First_Entity (Typ); while Present (Comp) loop -- Only look at E_Component entities. No need to look at @@ -17155,36 +17734,73 @@ package body Sem_Util is return True; end Caller_Known_Size_Record; - function Has_Discrim_Dep_Array (Typ : Entity_Id) return Boolean is + ------------------------------ + -- Large_Max_Size_Mutable -- + ------------------------------ + + function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is pragma Assert (Typ = Underlying_Type (Typ)); - begin - if Is_Array_Type (Typ) then - return Size_Depends_On_Discriminant (Typ); - end if; + function Is_Large_Discrete_Type (T : Entity_Id) return Boolean; + -- Returns true if the discrete type T has a large range + + ---------------------------- + -- Is_Large_Discrete_Type -- + ---------------------------- + + function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is + Threshold : constant Int := 16; + -- Arbitrary threshold above which we consider it "large". We want + -- a fairly large threshold, because these large types really + -- shouldn't have default discriminants in the first place, in + -- most cases. + + begin + return UI_To_Int (RM_Size (T)) > Threshold; + end Is_Large_Discrete_Type; + begin if Is_Record_Type (Typ) - or else - Is_Protected_Type (Typ) + and then not Is_Limited_View (Typ) + and then Has_Defaulted_Discriminants (Typ) then + -- Loop through the components, looking for an array whose upper + -- bound(s) depends on discriminants, where both the subtype of + -- the discriminant and the index subtype are too large. + declare - Comp : Entity_Id := First_Entity (Typ); + Comp : Entity_Id; begin + Comp := First_Entity (Typ); while Present (Comp) loop - - -- Only look at E_Component entities. No need to look at - -- E_Discriminant entities, and we must ignore internal - -- subtypes generated for constrained components. - if Ekind (Comp) = E_Component then declare Comp_Type : constant Entity_Id := Underlying_Type (Etype (Comp)); + Indx : Node_Id; + Ityp : Entity_Id; + Hi : Node_Id; begin - if Has_Discrim_Dep_Array (Comp_Type) then - return True; + if Is_Array_Type (Comp_Type) then + Indx := First_Index (Comp_Type); + + while Present (Indx) loop + Ityp := Etype (Indx); + Hi := Type_High_Bound (Ityp); + + if Nkind (Hi) = N_Identifier + and then Ekind (Entity (Hi)) = E_Discriminant + and then Is_Large_Discrete_Type (Ityp) + and then Is_Large_Discrete_Type + (Etype (Entity (Hi))) + then + return True; + end if; + + Next_Index (Indx); + end loop; end if; end; end if; @@ -17195,7 +17811,7 @@ package body Sem_Util is end if; return False; - end Has_Discrim_Dep_Array; + end Large_Max_Size_Mutable; -- Local declarations @@ -17206,7 +17822,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). Do not expand transient scope in this case. if No (Typ) then return False; @@ -17219,32 +17835,42 @@ package body Sem_Util is then return False; - -- Functions returning tagged types may dispatch on result so their - -- returned value is allocated on the secondary stack, even in the - -- definite case. Is_Tagged_Type includes controlled types and - -- class-wide types. Controlled type temporaries need finalization. + -- If Typ is a generic formal incomplete type, then we want to look at + -- the actual type. + + elsif Ekind (Typ) = E_Record_Subtype + and then Present (Cloned_Subtype (Typ)) + then + return New_Requires_Transient_Scope (Cloned_Subtype (Typ)); + + -- Functions returning specific tagged types may dispatch on result, so + -- their returned value is allocated on the secondary stack, even in the + -- definite case. We must treat nondispatching functions the same way, + -- because access-to-function types can point at both, so the calling + -- conventions must be compatible. Is_Tagged_Type includes controlled + -- types and class-wide types. Controlled type temporaries need + -- finalization. + -- ???It's not clear why we need to return noncontrolled types with - -- controlled components on the secondary stack. Also, it's not clear - -- why nonprimitive tagged type functions need the secondary stack, - -- since they can't be called via dispatching. + -- controlled components on the secondary stack. elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then - return not Is_Value_Type (Typ); + return True; -- Untagged definite subtypes are known size. This includes all -- elementary [sub]types. Tasks are known size even if they have - -- discriminants. + -- discriminants. So we return False here, with one exception: + -- For a type like: + -- type T (Last : Natural := 0) is + -- X : String (1 .. Last); + -- end record; + -- we return True. That's because for "P(F(...));", where F returns T, + -- we don't know the size of the result at the call site, so if we + -- allocated it on the primary stack, we would have to allocate the + -- maximum size, which is way too big. elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then - if Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then - if not Has_Discriminants (Typ) then - if Has_Discrim_Dep_Array (Typ) then - return True; -- ???Shouldn't be necessary - end if; - end if; - end if; - - return False; + return Large_Max_Size_Mutable (Typ); -- Indefinite (discriminated) untagged record or protected type @@ -18752,9 +19378,31 @@ package body Sem_Util is U := Full_View (E); end if; - when Type_Kind => - if Present (Full_View (E)) then - U := Full_View (E); + when Entry_Kind => + if Nkind (Parent (E)) = N_Entry_Body then + declare + Prot_Item : Entity_Id; + begin + -- Traverse the entity list of the protected type and locate + -- an entry declaration which matches the entry body. + + Prot_Item := First_Entity (Scope (E)); + while Present (Prot_Item) loop + if Ekind (Prot_Item) = E_Entry + and then Corresponding_Body (Parent (Prot_Item)) = E + then + U := Prot_Item; + exit; + end if; + + Next_Entity (Prot_Item); + end loop; + end; + end if; + + when Formal_Kind => + if Present (Spec_Entity (E)) then + U := Spec_Entity (E); end if; when E_Package_Body => @@ -18764,7 +19412,30 @@ package body Sem_Util is P := Parent (P); end if; - U := Corresponding_Spec (P); + if Nkind (P) = N_Package_Body + and then Present (Corresponding_Spec (P)) + then + U := Corresponding_Spec (P); + + elsif Nkind (P) = N_Package_Body_Stub + and then Present (Corresponding_Spec_Of_Stub (P)) + then + U := Corresponding_Spec_Of_Stub (P); + end if; + + when E_Protected_Body => + P := Parent (E); + + if Nkind (P) = N_Protected_Body + and then Present (Corresponding_Spec (P)) + then + U := Corresponding_Spec (P); + + elsif Nkind (P) = N_Protected_Body_Stub + and then Present (Corresponding_Spec_Of_Stub (P)) + then + U := Corresponding_Spec_Of_Stub (P); + end if; when E_Subprogram_Body => P := Parent (E); @@ -18775,22 +19446,34 @@ package body Sem_Util is P := Parent (P); - if Nkind (P) = N_Subprogram_Body_Stub then - if Present (Library_Unit (P)) then + if Nkind (P) = N_Subprogram_Body + and then Present (Corresponding_Spec (P)) + then + U := Corresponding_Spec (P); - -- Get to the function or procedure (generic) entity through - -- the body entity. + elsif Nkind (P) = N_Subprogram_Body_Stub + and then Present (Corresponding_Spec_Of_Stub (P)) + then + U := Corresponding_Spec_Of_Stub (P); + end if; - U := - Unique_Entity (Defining_Entity (Get_Body_From_Stub (P))); - end if; - else + when E_Task_Body => + P := Parent (E); + + if Nkind (P) = N_Task_Body + and then Present (Corresponding_Spec (P)) + then U := Corresponding_Spec (P); + + elsif Nkind (P) = N_Task_Body_Stub + and then Present (Corresponding_Spec_Of_Stub (P)) + then + U := Corresponding_Spec_Of_Stub (P); end if; - when Formal_Kind => - if Present (Spec_Entity (E)) then - U := Spec_Entity (E); + when Type_Kind => + if Present (Full_View (E)) then + U := Full_View (E); end if; when others => @@ -19352,7 +20035,7 @@ package body Sem_Util is Expec_Scope := Expec_Type; Found_Scope := Found_Type; - for Levels in Int range 0 .. 3 loop + for Levels in Nat range 0 .. 3 loop if Chars (Expec_Scope) /= Chars (Found_Scope) then Error_Msg_Qual_Level := Levels; exit; @@ -19463,4 +20146,94 @@ package body Sem_Util is end if; end Wrong_Type; + -------------------------------- + -- Yields_Synchronized_Object -- + -------------------------------- + + function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean is + Has_Sync_Comp : Boolean := False; + Id : Entity_Id; + + begin + -- An array type yields a synchronized object if its component type + -- yields a synchronized object. + + if Is_Array_Type (Typ) then + return Yields_Synchronized_Object (Component_Type (Typ)); + + -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object + -- yields a synchronized object by default. + + elsif Is_Descendant_Of_Suspension_Object (Typ) then + return True; + + -- A protected type yields a synchronized object by default + + elsif Is_Protected_Type (Typ) then + return True; + + -- A record type or type extension yields a synchronized object when its + -- discriminants (if any) lack default values and all components are of + -- a type that yelds a synchronized object. + + elsif Is_Record_Type (Typ) then + + -- Inspect all entities defined in the scope of the type, looking for + -- components of a type that does not yeld a synchronized object or + -- for discriminants with default values. + + Id := First_Entity (Typ); + while Present (Id) loop + if Comes_From_Source (Id) then + if Ekind (Id) = E_Component then + if Yields_Synchronized_Object (Etype (Id)) then + Has_Sync_Comp := True; + + -- The component does not yield a synchronized object + + else + return False; + end if; + + elsif Ekind (Id) = E_Discriminant + and then Present (Expression (Parent (Id))) + then + return False; + end if; + end if; + + Next_Entity (Id); + end loop; + + -- Ensure that the parent type of a type extension yields a + -- synchronized object. + + if Etype (Typ) /= Typ + and then not Yields_Synchronized_Object (Etype (Typ)) + then + return False; + end if; + + -- If we get here, then all discriminants lack default values and all + -- components are of a type that yields a synchronized object. + + return Has_Sync_Comp; + + -- A synchronized interface type yields a synchronized object by default + + elsif Is_Synchronized_Interface (Typ) then + return True; + + -- A task type yelds a synchronized object by default + + elsif Is_Task_Type (Typ) then + return True; + + -- Otherwise the type does not yield a synchronized object + + else + return False; + end if; + end Yields_Synchronized_Object; + end Sem_Util; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 650731746bf..0f6dd7ceaa4 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -49,30 +49,6 @@ package Sem_Util is -- it the identifier of the block. Id denotes the generated entity. If the -- block already has an identifier, Id returns the entity of its label. - procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id); - -- Add pragma Prag to the contract of a constant, entry, package [body], - -- subprogram [body] or variable denoted by Id. The following are valid - -- pragmas: - -- Abstract_State - -- Async_Readers - -- Async_Writers - -- Contract_Cases - -- Depends - -- Effective_Reads - -- Effective_Writes - -- Extensions_Visible - -- Global - -- Initial_Condition - -- Initializes - -- Part_Of - -- Postcondition - -- Precondition - -- Refined_Depends - -- Refined_Global - -- Refined_Post - -- Refined_States - -- Test_Case - procedure Add_Global_Declaration (N : Node_Id); -- These procedures adds a declaration N at the library level, to be -- elaborated before any other code in the unit. It is used for example @@ -109,6 +85,19 @@ package Sem_Util is -- Otherwise Uint_0 is returned, indicating that the alignment of the -- entity is not yet known to the compiler. + function All_Composite_Constraints_Static (Constr : Node_Id) return Boolean; + -- Used to implement pragma Restrictions (No_Dynamic_Sized_Objects). + -- Given a constraint or subtree of a constraint on a composite + -- subtype/object, returns True if there are no nonstatic constraints, + -- which might cause objects to be created with dynamic size. + -- Called for subtype declarations (including implicit ones created for + -- subtype indications in object declarations, as well as discriminated + -- record aggregate cases). For record aggregates, only records containing + -- discriminant-dependent arrays matter, because the discriminants must be + -- static when governing a variant part. Access discriminants are + -- irrelevant. Also called for array aggregates, but only named notation, + -- because those are the only dynamic cases. + procedure Append_Inherited_Subprogram (S : Entity_Id); -- If the parent of the operation is declared in the visible part of -- the current scope, the inherited operation is visible even though the @@ -274,6 +263,14 @@ package Sem_Util is -- error message on node N. Used in object declarations, type conversions -- and qualified expressions. + procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id); + -- A subprogram that has an Address parameter and is declared in a Pure + -- package is not considered Pure, because the parameter may be used as a + -- pointer and the referenced data may change even if the address value + -- itself does not. + -- If the programmer gave an explicit Pure_Function pragma, then we respect + -- the pragma and leave the subprogram Pure. + procedure Check_Function_Writable_Actuals (N : Node_Id); -- (Ada 2012): If the construct N has two or more direct constituents that -- are names or expressions whose evaluation may occur in an arbitrary @@ -308,15 +305,14 @@ package Sem_Util is -- remains in the Examiner (JB01-005). Note that the Examiner does not -- count package declarations in later declarative items. - procedure Check_Nested_Access (Ent : Entity_Id); - -- Check whether Ent denotes an entity declared in an uplevel scope, which - -- is accessed inside a nested procedure, and set Has_Uplevel_Reference - -- flag accordingly. This is currently only enabled for if on a VM target. - procedure Check_No_Hidden_State (Id : Entity_Id); -- Determine whether object or state Id introduces a hidden state. If this -- is the case, emit an error. + procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id); + -- Verify that the profile of nonvolatile function Func_Id does not contain + -- effectively volatile parameters or return type. + procedure Check_Potentially_Blocking_Operation (N : Node_Id); -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. @@ -326,6 +322,15 @@ package Sem_Util is -- 'Result and it contains an expression that evaluates differently in pre- -- and post-state. + procedure Check_Unused_Body_States (Body_Id : Entity_Id); + -- Verify that all abstract states and object declared in the state space + -- of a package body denoted by entity Body_Id are used as constituents. + -- Emit an error if this is not the case. + + function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id; + -- Gather the entities of all abstract states and objects declared in the + -- body state space of package body Body_Id. + procedure Check_Unprotected_Access (Context : Node_Id; Expr : Node_Id); @@ -421,15 +426,6 @@ package Sem_Util is -- attribute, except in the case of formal private and derived types. -- Possible optimization??? - function Corresponding_Spec_Of (Decl : Node_Id) return Entity_Id; - -- Return the corresponding spec of Decl when it denotes a package or a - -- subprogram [stub], or the defining entity of Decl. - - procedure Create_Generic_Contract (Unit : Node_Id); - -- Create a contract node for a generic package, generic subprogram or a - -- generic body denoted by Unit by collecting all source contract-related - -- pragmas in the contract of the unit. - function Current_Entity (N : Node_Id) return Entity_Id; pragma Inline (Current_Entity); -- Find the currently visible definition for a given identifier, that is to @@ -460,7 +456,9 @@ package Sem_Util is -- in the case of a descendant of a generic formal type (returns Int'Last -- instead of 0). - function Defining_Entity (N : Node_Id) return Entity_Id; + function Defining_Entity + (N : Node_Id; + Empty_On_Errors : Boolean := False) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- declaration has a specification, the entity is obtained from the -- specification. If the declaration has a defining unit name, then the @@ -471,6 +469,19 @@ package Sem_Util is -- local entities declared during loop expansion. These entities need -- debugging information, generated through Qualify_Entity_Names, and -- the loop declaration must be placed in the table Name_Qualify_Units. + -- + -- Set flag Empty_On_Error to change the behavior of this routine as + -- follows: + -- + -- * True - A declaration that lacks a defining entity returns Empty. + -- A node that does not allow for a defining entity returns Empty. + -- + -- * False - A declaration that lacks a defining entity is given a new + -- internally generated entity which is subsequently returned. A node + -- that does not allow for a defining entity raises Program_Error. + -- + -- The former semantics is appropriate for the back end; the latter + -- semantics is appropriate for the front end. function Denotes_Discriminant (N : Node_Id; @@ -536,7 +547,8 @@ package Sem_Util is -- Returns the closest ancestor of Typ that is a CPP type. function Enclosing_Declaration (N : Node_Id) return Node_Id; - -- Returns the declaration node enclosing N, if any, or Empty otherwise + -- Returns the declaration node enclosing N (including possibly N itself), + -- if any, or Empty otherwise. function Enclosing_Generic_Body (N : Node_Id) return Node_Id; @@ -550,10 +562,9 @@ package Sem_Util is function Enclosing_Lib_Unit_Entity (E : Entity_Id := Current_Scope) return Entity_Id; - -- Returns the entity of enclosing library unit node which is the - -- root of the current scope (which must not be Standard_Standard, and the - -- caller is responsible for ensuring this condition) or other specified - -- entity. + -- Returns the entity of enclosing library unit node which is the root of + -- the current scope (which must not be Standard_Standard, and the caller + -- is responsible for ensuring this condition) or other specified entity. function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id; -- Returns the N_Compilation_Unit node of the library unit that is directly @@ -618,7 +629,7 @@ package Sem_Util is (N : Node_Id; Formal : out Entity_Id; Call : out Node_Id); - -- Determines if the node N is an actual parameter of a function of a + -- Determines if the node N is an actual parameter of a function or a -- procedure call. If so, then Formal points to the entity for the formal -- (Ekind is E_In_Parameter, E_Out_Parameter, or E_In_Out_Parameter) and -- Call is set to the node for the corresponding call. If the node N is not @@ -758,16 +769,27 @@ package Sem_Util is -- alternatives, and the warnings that may apply to them, are removed. function First_Actual (Node : Node_Id) return Node_Id; - -- Node is an N_Function_Call or N_Procedure_Call_Statement node. The - -- result returned is the first actual parameter in declaration order - -- (not the order of parameters as they appeared in the source, which - -- can be quite different as a result of the use of named parameters). - -- Empty is returned for a call with no parameters. The procedure for - -- iterating through the actuals in declaration order is to use this - -- function to find the first actual, and then use Next_Actual to obtain - -- the next actual in declaration order. Note that the value returned - -- is always the expression (not the N_Parameter_Association nodes, - -- even if named association is used). + -- Node is an N_Function_Call, N_Procedure_Call_Statement or + -- N_Entry_Call_Statement node. The result returned is the first actual + -- parameter in declaration order (not the order of parameters as they + -- appeared in the source, which can be quite different as a result of the + -- use of named parameters). Empty is returned for a call with no + -- parameters. The procedure for iterating through the actuals in + -- declaration order is to use this function to find the first actual, and + -- then use Next_Actual to obtain the next actual in declaration order. + -- Note that the value returned is always the expression (not the + -- N_Parameter_Association nodes, even if named association is used). + + function Fix_Msg (Id : Entity_Id; Msg : String) return String; + -- Replace all occurrences of a particular word in string Msg depending on + -- the Ekind of Id as follows: + -- * Replace "subprogram" with + -- - "entry" when Id is an entry [family] + -- - "task type" when Id is a single task object, task type or task + -- body. + -- * Replace "protected" with + -- - "task" when Id is a single task object, task type or task body + -- All other non-matching words remain as is procedure Gather_Components (Typ : Entity_Id; @@ -823,7 +845,7 @@ package Sem_Util is -- returned. Otherwise the Etype of the node is returned. function Get_Body_From_Stub (N : Node_Id) return Node_Id; - -- Return the body node for a stub. + -- Return the body node for a stub function Get_Cursor_Type (Aspect : Node_Id; @@ -914,6 +936,10 @@ package Sem_Util is -- literal or concatenation of string literals. An error is given for -- any other form. + function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id; + -- If Typ has Implicit_Dereference, return discriminant specified in the + -- corresponding aspect. + function Get_Referenced_Object (N : Node_Id) return Node_Id; -- Given a node, return the renamed object if the node represents a renamed -- object, otherwise return the node unchanged. The node may represent an @@ -953,9 +979,6 @@ package Sem_Util is -- as an access type internally, this function tests only for access types -- known to the programmer. See also Has_Tagged_Component. - function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; - -- Simple predicate to test for defaulted discriminants - type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); -- Result of Has_Compatible_Alignment test, description found below. Note -- that the values are arranged in increasing order of problematicness. @@ -983,6 +1006,9 @@ package Sem_Util is function Has_Declarations (N : Node_Id) return Boolean; -- Determines if the node can have declarations + function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; + -- Simple predicate to test for defaulted discriminants + function Has_Denormals (E : Entity_Id) return Boolean; -- Determines if the floating-point type E supports denormal numbers. -- Returns False if E is not a floating-point type. @@ -992,6 +1018,24 @@ package Sem_Util is -- Returns True if and only if Comp has a constrained subtype that depends -- on a discriminant. + function Has_Effectively_Volatile_Profile + (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id has an effectively volatile formal + -- parameter or returns an effectively volatile value. + + function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ defines "full default initialization" as + -- specified by SPARK RM 3.1. To qualify as such, the type must be + -- * A scalar type with specified Default_Value + -- * An array-of-scalar type with specified Default_Component_Value + -- * An array type whose element type defines full default initialization + -- * A protected type, record type or type extension whose components + -- either include a default expression or have a type which defines + -- full default initialization. In the case of type extensions, the + -- parent type defines full default initialization. + -- * A task type + -- * A private type whose Default_Initial_Condition is non-null + function Has_Infinities (E : Entity_Id) return Boolean; -- Determines if the range of the floating-point type E includes -- infinities. Returns False if E is not a floating-point type. @@ -1140,14 +1184,6 @@ package Sem_Util is -- Inherit the rep item chain of type From_Typ without clobbering any -- existing rep items on Typ's chain. Typ is the destination type. - procedure Inherit_Subprogram_Contract - (Subp : Entity_Id; - From_Subp : Entity_Id); - -- Inherit relevant contract items from source subprogram From_Subp. Subp - -- denotes the destination subprogram. The inherited items are: - -- Extensions_Visible - -- ??? it would be nice if this routine handles Pre'Class and Post'Class - procedure Insert_Explicit_Dereference (N : Node_Id); -- In a context that requires a composite or subprogram type and where a -- prefix is an access type, rewrite the access type node N (which is the @@ -1256,10 +1292,8 @@ package Sem_Util is function Is_Declaration (N : Node_Id) return Boolean; -- Determine whether arbitrary node N denotes a declaration - function Is_Delegate (T : Entity_Id) return Boolean; - -- Returns true if type T represents a delegate. A Delegate is the CIL - -- object used to represent access-to-subprogram types. This is only - -- relevant to CIL, will always return false for other targets. + function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean; + -- Returns True iff component Comp is declared within a variant part function Is_Dependent_Component_Of_Mutable_Object (Object : Node_Id) return Boolean; @@ -1279,6 +1313,13 @@ package Sem_Util is -- This is the RM definition, a type is a descendent of another type if it -- is the same type or is derived from a descendent of the other type. + function Is_Descendant_Of_Suspension_Object + (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ is a descendant of type Suspension_Object + -- defined in Ada.Synchronous_Task_Control. This version is different from + -- Is_Descendent_Of as the detection of Suspension_Object does not involve + -- an entity and by extension a call to RTSfind. + function Is_Double_Precision_Floating_Point_Type (E : Entity_Id) return Boolean; -- Return whether E is a double precision floating point type, @@ -1289,24 +1330,37 @@ package Sem_Util is -- . machine_emin = 3 - machine_emax function Is_Effectively_Volatile (Id : Entity_Id) return Boolean; - -- The SPARK property "effectively volatile" applies to both types and - -- objects. To qualify as such, an entity must be either volatile or be - -- (of) an array type subject to aspect Volatile_Components. + -- Determine whether a type or object denoted by entity Id is effectively + -- volatile (SPARK RM 7.1.2). To qualify as such, the entity must be either + -- * Volatile + -- * An array type subject to aspect Volatile_Components + -- * An array type whose component type is effectively volatile + -- * A protected type + -- * Descendant of type Ada.Synchronous_Task_Control.Suspension_Object function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean; -- Determine whether an arbitrary node denotes an effectively volatile - -- object. + -- object (SPARK RM 7.1.2). + + function Is_Entry_Body (Id : Entity_Id) return Boolean; + -- Determine whether entity Id is the body entity of an entry [family] + + function Is_Entry_Declaration (Id : Entity_Id) return Boolean; + -- Determine whether entity Id is the spec entity of an entry [family] function Is_Expression_Function (Subp : Entity_Id) return Boolean; - -- Predicate to determine whether a scope entity comes from a rewritten - -- expression function call, and should be inlined unconditionally. Also - -- used to determine that such a call does not constitute a freeze point. + -- Determine whether subprogram [body] Subp denotes an expression function + + function Is_Expression_Function_Or_Completion + (Subp : Entity_Id) return Boolean; + -- Determine whether subprogram [body] Subp denotes an expression function + -- or is completed by an expression function body. function Is_EVF_Expression (N : Node_Id) return Boolean; -- Determine whether node N denotes a reference to a formal parameter of -- a specific tagged type whose related subprogram is subject to pragma - -- Extensions_Visible with value "False". Several other constructs fall - -- under this category: + -- Extensions_Visible with value "False" (SPARK RM 6.1.7). Several other + -- constructs fall under this category: -- 1) A qualified expression whose operand is EVF -- 2) A type conversion whose operand is EVF -- 3) An if expression with at least one EVF dependent_expression @@ -1325,7 +1379,7 @@ package Sem_Util is function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean; -- Typ is a type entity. This function returns true if this type is fully -- initialized, meaning that an object of the type is fully initialized. - -- Note that initialization resulting from use of pragma Normalized_Scalars + -- Note that initialization resulting from use of pragma Normalize_Scalars -- does not count. Note that this is only used for the purpose of issuing -- warnings for objects that are potentially referenced uninitialized. This -- means that the result returned is not crucial, but should err on the @@ -1349,6 +1403,11 @@ package Sem_Util is -- AI05-0139-2: Check whether Typ is one of the predefined interfaces in -- Ada.Iterator_Interfaces, or it is derived from one. + function Is_Iterator_Over_Array (N : Node_Id) return Boolean; + -- N is an iterator specification. Returns True iff N is an iterator over + -- an array, either inside a loop of the form 'for X of A' or a quantified + -- expression of the form 'for all/some X of A' where A is of array type. + type Is_LHS_Result is (Yes, No, Unknown); function Is_LHS (N : Node_Id) return Is_LHS_Result; -- Returns Yes if N is definitely used as Name in an assignment statement. @@ -1400,7 +1459,7 @@ package Sem_Util is -- initialized, meaning that an object of the type is at least partly -- initialized (in particular in the record case, that at least one -- component has an initialization expression). Note that initialization - -- resulting from the use of pragma Normalized_Scalars does not count. + -- resulting from the use of pragma Normalize_Scalars does not count. -- Include_Implicit controls whether implicit initialization of access -- values to null, and of discriminant values, is counted as making the -- type be partially initialized. For the default setting of True, these @@ -1453,6 +1512,18 @@ package Sem_Util is -- represent use of the N_Identifier node for a true identifier, when -- normally such nodes represent a direct name. + function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean; + -- Determine whether arbitrary entity Id denotes the anonymous object + -- created for a single protected or single task type. + + function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean; + -- Determine whether arbitrary entity Id denotes a single protected or + -- single task type. + + function Is_Single_Concurrent_Type_Declaration (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N denotes the declaration of a single + -- protected type or single task type. + function Is_Single_Precision_Floating_Point_Type (E : Entity_Id) return Boolean; -- Return whether E is a single precision floating point type, @@ -1506,6 +1577,19 @@ package Sem_Util is -- Return True if N is a subprogram stub with no prior subprogram -- declaration. + function Is_Suspension_Object (Id : Entity_Id) return Boolean; + -- Determine whether arbitrary entity Id denotes Suspension_Object defined + -- in Ada.Synchronous_Task_Control. + + function Is_Synchronized_Object (Id : Entity_Id) return Boolean; + -- Determine whether entity Id denotes an object and if it does, whether + -- this object is synchronized as specified in SPARK RM 9.1. To qualify as + -- such, the object must be + -- * Of a type that yields a synchronized object + -- * An atomic object with enabled Async_Writers + -- * A constant + -- * A variable subject to pragma Constant_After_Elaboration + function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean; -- Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2)) @@ -1528,12 +1612,6 @@ package Sem_Util is pragma Inline (Is_Universal_Numeric_Type); -- True if T is Universal_Integer or Universal_Real - function Is_Value_Type (T : Entity_Id) return Boolean; - -- Returns true if type T represents a value type. This is only relevant to - -- CIL, will always return false for other targets. A value type is a CIL - -- object that is accessed directly, as opposed to the other CIL objects - -- that are accessed through managed pointers. - function Is_Variable_Size_Array (E : Entity_Id) return Boolean; -- Returns true if E has variable size components @@ -1560,6 +1638,11 @@ package Sem_Util is -- Initialize/Adjust/Finalize subprogram does not override the inherited -- one. + function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean; + -- Determine whether [generic] function Func_Id is subject to enabled + -- pragma Volatile_Function. Protected functions are treated as volatile + -- (SPARK RM 7.1.2). + function Is_Volatile_Object (N : Node_Id) return Boolean; -- Determines if the given node denotes an volatile object in the sense of -- the legality checks described in RM C.6(12). Note that the test here is @@ -1769,12 +1852,6 @@ package Sem_Util is -- convenience, qualified expressions applied to object names are also -- allowed as actuals for this function. - function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id; - -- [Ada 2012: AI05-0125-1]: If S is an inherited dispatching primitive S2, - -- or overrides an inherited dispatching primitive S2, the original - -- corresponding operation of S is the original corresponding operation of - -- S2. Otherwise, it is S itself. - function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id; -- Retrieve the name of aspect or pragma N taking into account a possible -- rewrite and whether the pragma is generated from an aspect as the names @@ -1787,6 +1864,12 @@ package Sem_Util is -- Type_Invariant -> Name_uType_Invariant -- Type_Invariant'Class -> Name_uType_Invariant + function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id; + -- [Ada 2012: AI05-0125-1]: If S is an inherited dispatching primitive S2, + -- or overrides an inherited dispatching primitive S2, the original + -- corresponding operation of S is the original corresponding operation of + -- S2. Otherwise, it is S itself. + function Policy_In_Effect (Policy : Name_Id) return Name_Id; -- Given a policy, return the policy identifier associated with it. If no -- such policy is in effect, the value returned is No_Name. @@ -1833,6 +1916,12 @@ package Sem_Util is procedure Remove_Homonym (E : Entity_Id); -- Removes E from the homonym chain + procedure Remove_Overloaded_Entity (Id : Entity_Id); + -- Remove arbitrary entity Id from the homonym chain, the scope chain and + -- the primitive operations list of the associated controlling type. NOTE: + -- the removal performed by this routine does not affect the visibility of + -- existing homonyms. + function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id; -- This is used to construct the second argument in a call to Rep_To_Pos -- which is Standard_True if range checks are enabled (E is an entity to @@ -1846,6 +1935,13 @@ package Sem_Util is -- more there is at least one case in the generated code (the code for -- array assignment in a loop) that depends on this suppression. + procedure Report_Unused_Body_States + (Body_Id : Entity_Id; + States : Elist_Id); + -- Emit errors for each abstract state or object found in list States that + -- is declared in package body Body_Id, but is not used as constituent in a + -- state refinement. + procedure Require_Entity (N : Node_Id); -- N is a node which should have an entity value if it is an entity name. -- If not, then check if there were previous errors. If so, just fill @@ -2085,10 +2181,13 @@ package Sem_Util is function Unique_Defining_Entity (N : Node_Id) return Entity_Id; -- Return the entity which represents declaration N, so that different -- views of the same entity have the same unique defining entity: - -- * package spec and body; - -- * subprogram declaration, subprogram stub and subprogram body; - -- * private view and full view of a type; - -- * private view and full view of a deferred constant. + -- * entry declaration and entry body + -- * package spec and body + -- * protected type declaration, protected body stub and protected body + -- * private view and full view of a deferred constant + -- * private view and full view of a type + -- * subprogram declaration, subprogram stub and subprogram body + -- * task type declaration, task body stub and task body -- In other cases, return the defining entity for N. function Unique_Entity (E : Entity_Id) return Entity_Id; @@ -2123,7 +2222,7 @@ package Sem_Util is -- Determines if Current_Scope is within an init proc function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean; - -- Returns True if entity Id is declared within scope S + -- Returns True if entity E is declared within scope S procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id); -- Output error message for incorrectly typed expression. Expr is the node @@ -2132,4 +2231,15 @@ package Sem_Util is -- does not have to be a subexpression, anything with an Etype field may -- be used. + function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ "yields synchronized object" as specified by + -- SPARK RM 9.1. To qualify as such, a type must be + -- * An array type whose element type yields a synchronized object + -- * A descendant of type Ada.Synchronous_Task_Control.Suspension_Object + -- * A protected type + -- * A record type or type extension without defaulted discriminants + -- whose components are of a type that yields a synchronized object. + -- * A synchronized interface type + -- * A task type + end Sem_Util; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 9140a0899f6..3af69c9fbd0 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1697,6 +1697,18 @@ package body Sem_Warn is begin if Is_Access_Type (Typ) and then Is_Dereferenced (N) then return False; + + -- If a type has Default_Initial_Condition set, or it inherits it, + -- DIC might be specified with a boolean value, meaning that the type + -- is considered to be fully default initialized (SPARK RM 3.1 and + -- SPARK RM 7.3.3). To avoid generating spurious warnings in this + -- case, consider all types with DIC as fully initialized. + + elsif Has_Default_Init_Cond (Typ) + or else Has_Inherited_Default_Init_Cond (Typ) + then + return True; + else return Is_Fully_Initialized_Type (Typ); end if; diff --git a/gcc/ada/sigtramp.h b/gcc/ada/sigtramp.h index bf872f5da02..7af6be3466c 100644 --- a/gcc/ada/sigtramp.h +++ b/gcc/ada/sigtramp.h @@ -43,19 +43,7 @@ extern "C" { #ifdef __ANDROID__ #include <stdlib.h> -#include <asm/signal.h> -#include <asm/sigcontext.h> - -/* Android SDK doesn't define these structs */ -typedef struct sigcontext mcontext_t; - -typedef struct ucontext - { - unsigned long uc_flags; - struct ucontext *uc_link; - stack_t uc_stack; - mcontext_t uc_mcontext; -} ucontext_t; +#include <sys/ucontext.h> #endif /* This typedef signature sometimes conflicts with the sighandler_t from diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 824acd51ca1..5f57e8c2f75 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1760,6 +1760,14 @@ package body Sinfo is return Flag13 (N); end Is_Accessibility_Actual; + function Is_Analyzed_Pragma + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag5 (N); + end Is_Analyzed_Pragma; + function Is_Asynchronous_Call_Block (N : Node_Id) return Boolean is begin @@ -1848,7 +1856,8 @@ package body Sinfo is (N : Node_Id) return Boolean is begin pragma Assert (False - or else NT (N).Nkind = N_Subprogram_Body); + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Subprogram_Declaration); return Flag8 (N); end Is_Entry_Barrier_Function; @@ -1860,6 +1869,14 @@ package body Sinfo is return Flag11 (N); end Is_Expanded_Build_In_Place_Call; + function Is_Expanded_Contract + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + return Flag1 (N); + end Is_Expanded_Contract; + function Is_Finalization_Wrapper (N : Node_Id) return Boolean is begin @@ -1909,13 +1926,13 @@ package body Sinfo is return Flag11 (N); end Is_In_Discriminant_Check; - function Is_Inherited + function Is_Inherited_Pragma (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Pragma); return Flag4 (N); - end Is_Inherited; + end Is_Inherited_Pragma; function Is_Machine_Number (N : Node_Id) return Boolean is @@ -1997,6 +2014,15 @@ package body Sinfo is return Flag6 (N); end Is_Task_Allocation_Block; + function Is_Task_Body_Procedure + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Subprogram_Declaration); + return Flag1 (N); + end Is_Task_Body_Procedure; + function Is_Task_Master (N : Node_Id) return Boolean is begin @@ -4973,6 +4999,14 @@ package body Sinfo is Set_Flag13 (N, Val); end Set_Is_Accessibility_Actual; + procedure Set_Is_Analyzed_Pragma + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag5 (N, Val); + end Set_Is_Analyzed_Pragma; + procedure Set_Is_Asynchronous_Call_Block (N : Node_Id; Val : Boolean := True) is begin @@ -5061,7 +5095,8 @@ package body Sinfo is (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False - or else NT (N).Nkind = N_Subprogram_Body); + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Subprogram_Declaration); Set_Flag8 (N, Val); end Set_Is_Entry_Barrier_Function; @@ -5073,6 +5108,14 @@ package body Sinfo is Set_Flag11 (N, Val); end Set_Is_Expanded_Build_In_Place_Call; + procedure Set_Is_Expanded_Contract + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + Set_Flag1 (N, Val); + end Set_Is_Expanded_Contract; + procedure Set_Is_Finalization_Wrapper (N : Node_Id; Val : Boolean := True) is begin @@ -5122,13 +5165,13 @@ package body Sinfo is Set_Flag11 (N, Val); end Set_Is_In_Discriminant_Check; - procedure Set_Is_Inherited + procedure Set_Is_Inherited_Pragma (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False or else NT (N).Nkind = N_Pragma); Set_Flag4 (N, Val); - end Set_Is_Inherited; + end Set_Is_Inherited_Pragma; procedure Set_Is_Machine_Number (N : Node_Id; Val : Boolean := True) is @@ -5210,6 +5253,15 @@ package body Sinfo is Set_Flag6 (N, Val); end Set_Is_Task_Allocation_Block; + procedure Set_Is_Task_Body_Procedure + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Subprogram_Declaration); + Set_Flag1 (N, Val); + end Set_Is_Task_Body_Procedure; + procedure Set_Is_Task_Master (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 203313d11e6..ab76d2c80ab 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -728,8 +728,12 @@ package Sinfo is -- Mod for signed integer types is expanded into equivalent expressions -- using Rem (which is % in C) and other C-available operators. - -- The Actions list of an Expression_With_Actions node does not contain - -- any declarations,(so that DO X, .. Y IN Z becomes (X, .. Y, Z) in C). + -- Functions returning bounded arrays are transformed into procedures + -- with an extra out parameter, and the calls updated accordingly. + + -- Aggregates are only kept unexpanded for object declarations, otherwise + -- they are systematically expanded into loops (for arrays) and + -- individual assignments (for records). ------------------------------------ -- Description of Semantic Fields -- @@ -1538,6 +1542,17 @@ package Sinfo is -- is called in a dispatching context. Used to prevent a formal/actual -- mismatch when the call is rewritten as a dispatching call. + -- Is_Analyzed_Pragma (Flag5-Sem) + -- Present in N_Pragma nodes. Set for delayed pragmas that require a two + -- step analysis. The initial step is peformed by routine Analyze_Pragma + -- and verifies the overall legality of the pragma. The second step takes + -- place in the various Analyze_xxx_In_Decl_Part routines which perform + -- full analysis. The flag prevents the reanalysis of a delayed pragma. + + -- Is_Expanded_Contract (Flag1-Sem) + -- Present in N_Contract nodes. Set if the contract has already undergone + -- expansion activities. + -- Is_Asynchronous_Call_Block (Flag7-Sem) -- A flag set in a Block_Statement node to indicate that it is the -- expansion of an asynchronous entry call. Such a block needs cleanup @@ -1563,7 +1578,7 @@ package Sinfo is -- concatenation nodes in instances. -- Is_Controlling_Actual (Flag16-Sem) - -- This flag is set on in an expression that is a controlling argument in + -- This flag is set on an expression that is a controlling argument in -- a dispatching call. It is off in all other cases. See Sem_Disp for -- details of its use. @@ -1588,9 +1603,9 @@ package Sinfo is -- the enclosing object. -- Is_Entry_Barrier_Function (Flag8-Sem) - -- This flag is set in an N_Subprogram_Body node which is the expansion - -- of an entry barrier from a protected entry body. It is used for the - -- circuitry checking for incorrect use of Current_Task. + -- This flag is set on N_Subprogram_Declaration and N_Subprogram_Body + -- nodes which emulate the barrier function of a protected entry body. + -- The flag is used when checking for incorrect use of Current_Task. -- Is_Expanded_Build_In_Place_Call (Flag11-Sem) -- This flag is set in an N_Function_Call node to indicate that the extra @@ -1652,7 +1667,7 @@ package Sinfo is -- discriminant check has a correct value cannot be performed in this -- case (or the discriminant check may be optimized away). - -- Is_Inherited (Flag4-Sem) + -- Is_Inherited_Pragma (Flag4-Sem) -- This flag is set in an N_Pragma node that appears in a N_Contract node -- to indicate that the pragma has been inherited from a parent context. @@ -1720,6 +1735,10 @@ package Sinfo is -- Expunge_Unactivated_Tasks to complete any tasks that have been -- allocated but not activated when the allocator completes abnormally. + -- Is_Task_Body_Procedure (Flag1-Sem) + -- This flag is set on N_Subprogram_Declaration and N_Subprogram_Body + -- nodes which emulate the body of a task unit. + -- Is_Task_Master (Flag5-Sem) -- A flag set in a Subprogram_Body, Block_Statement or Task_Body node to -- indicate that the construct is a task master (i.e. has declared tasks @@ -1905,7 +1924,7 @@ package Sinfo is -- body, and no entities of the with'ed unit are referenced by the spec -- (an entity may still be referenced in the body, so this flag is used -- to generate the proper message (see Sem_Util.Check_Unused_Withs for - -- full details) + -- full details). -- No_Initialization (Flag13-Sem) -- Present in N_Object_Declaration and N_Allocator to indicate that the @@ -2468,13 +2487,14 @@ package Sinfo is -- Class_Present (Flag6) set if from Aspect with 'Class -- From_Aspect_Specification (Flag13-Sem) -- Import_Interface_Present (Flag16-Sem) + -- Is_Analyzed_Pragma (Flag5-Sem) -- Is_Checked (Flag11-Sem) -- Is_Delayed_Aspect (Flag14-Sem) -- Is_Disabled (Flag15-Sem) -- Is_Generic_Contract_Pragma (Flag2-Sem) - -- Is_Ghost_Pragma (Flag3-Sem); + -- Is_Ghost_Pragma (Flag3-Sem) -- Is_Ignored (Flag9-Sem) - -- Is_Inherited (Flag4-Sem) + -- Is_Inherited_Pragma (Flag4-Sem) -- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set -- Uneval_Old_Accept (Flag7-Sem) -- Uneval_Old_Warn (Flag18-Sem) @@ -3634,7 +3654,7 @@ package Sinfo is -- INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION}) -- Note: the parser may generate this node in some situations where it - -- should be a function call. The semantic pass must correct this + -- should be a function call. The semantic pass must correct this -- misidentification (which is inevitable at the parser level). -- N_Indexed_Component @@ -3680,7 +3700,7 @@ package Sinfo is -- node. See description of this node in the section on semantic nodes. -- N_Selected_Component - -- Sloc points to period + -- Sloc points to the period -- Prefix (Node3) -- Selector_Name (Node2) -- Associated_Node (Node4-Sem) @@ -4571,7 +4591,7 @@ package Sinfo is -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT -- There is no explicit node in the tree for a statement. Instead, the - -- individual statement appears directly. Labels are treated as a + -- individual statement appears directly. Labels are treated as a -- kind of statement, i.e. they are linked into a statement list at -- the point they appear, so the labeled statement appears following -- the label or labels in the statement list. @@ -4945,6 +4965,8 @@ package Sinfo is -- Body_To_Inline (Node3-Sem) -- Corresponding_Body (Node5-Sem) -- Parent_Spec (Node4-Sem) + -- Is_Entry_Barrier_Function (Flag8-Sem) + -- Is_Task_Body_Procedure (Flag1-Sem) ------------------------------------------ -- 6.1 Abstract Subprogram Declaration -- @@ -5184,8 +5206,9 @@ package Sinfo is -- Acts_As_Spec (Flag4-Sem) -- Bad_Is_Detected (Flag15) used only by parser -- Do_Storage_Check (Flag17-Sem) - -- Is_Protected_Subprogram_Body (Flag7-Sem) -- Is_Entry_Barrier_Function (Flag8-Sem) + -- Is_Protected_Subprogram_Body (Flag7-Sem) + -- Is_Task_Body_Procedure (Flag1-Sem) -- Is_Task_Master (Flag5-Sem) -- Was_Originally_Stub (Flag13-Sem) -- Has_Relative_Deadline_Pragma (Flag9-Sem) @@ -6539,7 +6562,7 @@ package Sinfo is -- For some back ends, such as gcc with ZCX, "at end" is implemented -- entirely in the back end. In this case, a handled sequence of -- statements with an "at end" cannot also have exception handlers. - -- For other back ends, such as gcc with SJLJ and .NET, the + -- For other back ends, such as gcc with front-end SJLJ, the -- implementation is split between the front end and back end; the front -- end implements 3, and the back end implements 1 and 2. In this case, -- if there is an "at end", the front end inserts the appropriate @@ -7560,6 +7583,7 @@ package Sinfo is -- Pre_Post_Conditions (Node1-Sem) (set to Empty if none) -- Contract_Test_Cases (Node2-Sem) (set to Empty if none) -- Classifications (Node3-Sem) (set to Empty if none) + -- Is_Expanded_Contract (Flag1-Sem) -- Pre_Post_Conditions contains a collection of pragmas that correspond -- to pre- and postconditions associated with an entry or a subprogram @@ -7588,9 +7612,11 @@ package Sinfo is -- Abstract_States -- Async_Readers -- Async_Writers + -- Constant_After_Elaboration -- Depends -- Effective_Reads -- Effective_Writes + -- Extensions_Visible -- Global -- Initial_Condition -- Initializes @@ -7598,6 +7624,7 @@ package Sinfo is -- Refined_Depends -- Refined_Global -- Refined_States + -- Volatile_Function -- The ordering is in LIFO fashion. ------------------- @@ -8021,8 +8048,8 @@ package Sinfo is -- SCIL_Controlling_Tag (Node5-Sem) -- -- An N_Scil_Dispatching call node may be associated (via Get_SCIL_Node) - -- with the N_Procedure_Call or N_Function_Call node (or a rewriting - -- thereof) corresponding to a dispatching call. + -- with the N_Procedure_Call_Statement or N_Function_Call node (or a + -- rewriting thereof) corresponding to a dispatching call. -- N_SCIL_Membership_Test -- Sloc references the node of a membership test @@ -8098,10 +8125,10 @@ package Sinfo is -- For the case of the standard gigi backend, this means that all -- checks are done in the front end. - -- However, in the case of specialized back-ends, notably the JVM - -- backend for JGNAT, additional requirements and restrictions apply - -- to unchecked conversion, and these are most conveniently performed - -- in the specialized back-end. + -- However, in the case of specialized back-ends, in particular the JVM + -- backend in the past, additional requirements and restrictions may + -- apply to unchecked conversion, and these are most conveniently + -- performed in the specialized back-end. -- To accommodate this requirement, for such back ends, the following -- special node is generated recording an unchecked conversion that @@ -9282,6 +9309,9 @@ package Sinfo is function Is_Accessibility_Actual (N : Node_Id) return Boolean; -- Flag13 + function Is_Analyzed_Pragma + (N : Node_Id) return Boolean; -- Flag5 + function Is_Asynchronous_Call_Block (N : Node_Id) return Boolean; -- Flag7 @@ -9318,6 +9348,9 @@ package Sinfo is function Is_Expanded_Build_In_Place_Call (N : Node_Id) return Boolean; -- Flag11 + function Is_Expanded_Contract + (N : Node_Id) return Boolean; -- Flag1 + function Is_Finalization_Wrapper (N : Node_Id) return Boolean; -- Flag9 @@ -9336,7 +9369,7 @@ package Sinfo is function Is_In_Discriminant_Check (N : Node_Id) return Boolean; -- Flag11 - function Is_Inherited + function Is_Inherited_Pragma (N : Node_Id) return Boolean; -- Flag4 function Is_Machine_Number @@ -9369,6 +9402,9 @@ package Sinfo is function Is_Task_Allocation_Block (N : Node_Id) return Boolean; -- Flag6 + function Is_Task_Body_Procedure + (N : Node_Id) return Boolean; -- Flag1 + function Is_Task_Master (N : Node_Id) return Boolean; -- Flag5 @@ -10308,6 +10344,9 @@ package Sinfo is procedure Set_Is_Accessibility_Actual (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Is_Analyzed_Pragma + (N : Node_Id; Val : Boolean := True); -- Flag5 + procedure Set_Is_Asynchronous_Call_Block (N : Node_Id; Val : Boolean := True); -- Flag7 @@ -10344,6 +10383,9 @@ package Sinfo is procedure Set_Is_Expanded_Build_In_Place_Call (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Is_Expanded_Contract + (N : Node_Id; Val : Boolean := True); -- Flag1 + procedure Set_Is_Finalization_Wrapper (N : Node_Id; Val : Boolean := True); -- Flag9 @@ -10362,7 +10404,7 @@ package Sinfo is procedure Set_Is_In_Discriminant_Check (N : Node_Id; Val : Boolean := True); -- Flag11 - procedure Set_Is_Inherited + procedure Set_Is_Inherited_Pragma (N : Node_Id; Val : Boolean := True); -- Flag4 procedure Set_Is_Machine_Number @@ -10395,6 +10437,9 @@ package Sinfo is procedure Set_Is_Task_Allocation_Block (N : Node_Id; Val : Boolean := True); -- Flag6 + procedure Set_Is_Task_Body_Procedure + (N : Node_Id; Val : Boolean := True); -- Flag1 + procedure Set_Is_Task_Master (N : Node_Id; Val : Boolean := True); -- Flag5 @@ -12732,6 +12777,7 @@ package Sinfo is pragma Inline (Intval); pragma Inline (Iterator_Specification); pragma Inline (Is_Accessibility_Actual); + pragma Inline (Is_Analyzed_Pragma); pragma Inline (Is_Asynchronous_Call_Block); pragma Inline (Is_Boolean_Aspect); pragma Inline (Is_Checked); @@ -12744,13 +12790,14 @@ package Sinfo is pragma Inline (Is_Elsif); pragma Inline (Is_Entry_Barrier_Function); pragma Inline (Is_Expanded_Build_In_Place_Call); + pragma Inline (Is_Expanded_Contract); pragma Inline (Is_Finalization_Wrapper); pragma Inline (Is_Folded_In_Parser); pragma Inline (Is_Generic_Contract_Pragma); pragma Inline (Is_Ghost_Pragma); pragma Inline (Is_Ignored); pragma Inline (Is_In_Discriminant_Check); - pragma Inline (Is_Inherited); + pragma Inline (Is_Inherited_Pragma); pragma Inline (Is_Machine_Number); pragma Inline (Is_Null_Loop); pragma Inline (Is_Overloaded); @@ -12761,6 +12808,7 @@ package Sinfo is pragma Inline (Is_Static_Expression); pragma Inline (Is_Subprogram_Descriptor); pragma Inline (Is_Task_Allocation_Block); + pragma Inline (Is_Task_Body_Procedure); pragma Inline (Is_Task_Master); pragma Inline (Iteration_Scheme); pragma Inline (Itype); @@ -13069,6 +13117,7 @@ package Sinfo is pragma Inline (Set_Interface_Present); pragma Inline (Set_Intval); pragma Inline (Set_Is_Accessibility_Actual); + pragma Inline (Set_Is_Analyzed_Pragma); pragma Inline (Set_Is_Asynchronous_Call_Block); pragma Inline (Set_Is_Boolean_Aspect); pragma Inline (Set_Is_Checked); @@ -13081,13 +13130,14 @@ package Sinfo is pragma Inline (Set_Is_Elsif); pragma Inline (Set_Is_Entry_Barrier_Function); pragma Inline (Set_Is_Expanded_Build_In_Place_Call); + pragma Inline (Set_Is_Expanded_Contract); pragma Inline (Set_Is_Finalization_Wrapper); pragma Inline (Set_Is_Folded_In_Parser); pragma Inline (Set_Is_Generic_Contract_Pragma); pragma Inline (Set_Is_Ghost_Pragma); pragma Inline (Set_Is_Ignored); pragma Inline (Set_Is_In_Discriminant_Check); - pragma Inline (Set_Is_Inherited); + pragma Inline (Set_Is_Inherited_Pragma); pragma Inline (Set_Is_Machine_Number); pragma Inline (Set_Is_Null_Loop); pragma Inline (Set_Is_Overloaded); @@ -13098,6 +13148,7 @@ package Sinfo is pragma Inline (Set_Is_Static_Expression); pragma Inline (Set_Is_Subprogram_Descriptor); pragma Inline (Set_Is_Task_Allocation_Block); + pragma Inline (Set_Is_Task_Body_Procedure); pragma Inline (Set_Is_Task_Master); pragma Inline (Set_Iteration_Scheme); pragma Inline (Set_Iterator_Specification); diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index 3d36903bb05..76ff65193e4 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -136,7 +136,7 @@ package Sinput is -- The licensing status is determined either by the presence of a -- specific pragma License, or by scanning the header for a predefined - -- file, or any file if compiling in -gnatg mode. + -- statement, or any file if compiling in -gnatg mode. ----------------------- -- Source File Table -- @@ -431,7 +431,7 @@ package Sinput is Current_Source_File : Source_File_Index := No_Source_File; -- Source_File table index of source file currently being scanned. -- Initialized so that some tools (such as gprbuild) can be built with - -- -gnatVa and pragma Initialized_Scalars without problems. + -- -gnatVa and pragma Initialize_Scalars without problems. Current_Source_Unit : Unit_Number_Type; -- Unit number of source file currently being scanned. The special value diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index 6e1acd9c22a..3de2b82cc6b 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -152,12 +152,10 @@ package body Snames is Convention_Ada_Pass_By_Reference; when Name_Assembler => return Convention_Assembler; when Name_C => return Convention_C; - when Name_CIL => return Convention_CIL; when Name_COBOL => return Convention_COBOL; when Name_CPP => return Convention_CPP; when Name_Fortran => return Convention_Fortran; when Name_Intrinsic => return Convention_Intrinsic; - when Name_Java => return Convention_Java; when Name_Stdcall => return Convention_Stdcall; when Name_Stubbed => return Convention_Stubbed; @@ -188,13 +186,11 @@ package body Snames is return Name_Ada_Pass_By_Reference; when Convention_Assembler => return Name_Assembler; when Convention_C => return Name_C; - when Convention_CIL => return Name_CIL; when Convention_COBOL => return Name_COBOL; when Convention_CPP => return Name_CPP; when Convention_Entry => return Name_Entry; when Convention_Fortran => return Name_Fortran; when Convention_Intrinsic => return Name_Intrinsic; - when Convention_Java => return Name_Java; when Convention_Protected => return Name_Protected; when Convention_Stdcall => return Name_Stdcall; when Convention_Stubbed => return Name_Stubbed; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index b76e6295059..ba4053dab51 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -261,6 +261,29 @@ package Snames is Name_Wide_Text_IO : constant Name_Id := N + $; Name_Wide_Wide_Text_IO : constant Name_Id := N + $; + -- Names for detecting predefined potentially blocking subprograms + + Name_Abort_Task : constant Name_Id := N + $; + Name_Bounded_IO : constant Name_Id := N + $; + Name_C_Streams : constant Name_Id := N + $; + Name_Complex_IO : constant Name_Id := N + $; + Name_Directories : constant Name_Id := N + $; + Name_Direct_IO : constant Name_Id := N + $; + Name_Dispatching : constant Name_Id := N + $; + Name_Editing : constant Name_Id := N + $; + Name_EDF : constant Name_Id := N + $; + Name_Reset_Standard_Files : constant Name_Id := N + $; + Name_Sequential_IO : constant Name_Id := N + $; + Name_Streams : constant Name_Id := N + $; + Name_Suspend_Until_True : constant Name_Id := N + $; + Name_Suspend_Until_True_And_Set_Deadline : constant Name_Id := N + $; + Name_Synchronous_Barriers : constant Name_Id := N + $; + Name_Task_Identification : constant Name_Id := N + $; + Name_Text_Streams : constant Name_Id := N + $; + Name_Unbounded_IO : constant Name_Id := N + $; + Name_Wait_For_Release : constant Name_Id := N + $; + Name_Yield : constant Name_Id := N + $; + -- Names of implementations of the distributed systems annex First_PCS_Name : constant Name_Id := N + $; @@ -464,11 +487,11 @@ package Snames is Name_Atomic_Components : constant Name_Id := N + $; Name_Attach_Handler : constant Name_Id := N + $; Name_Check : constant Name_Id := N + $; -- GNAT - Name_CIL_Constructor : constant Name_Id := N + $; -- GNAT Name_Comment : constant Name_Id := N + $; -- GNAT Name_Common_Object : constant Name_Id := N + $; -- GNAT Name_Complete_Representation : constant Name_Id := N + $; -- GNAT Name_Complex_Representation : constant Name_Id := N + $; -- GNAT + Name_Constant_After_Elaboration : constant Name_Id := N + $; -- GNAT Name_Contract_Cases : constant Name_Id := N + $; -- GNAT Name_Controlled : constant Name_Id := N + $; Name_Convention : constant Name_Id := N + $; @@ -533,8 +556,6 @@ package Snames is -- Is_Pragma_Id correctly recognize and process Interrupt_Priority. Name_Invariant : constant Name_Id := N + $; -- GNAT - Name_Java_Constructor : constant Name_Id := N + $; -- GNAT - Name_Java_Interface : constant Name_Id := N + $; -- GNAT Name_Keep_Names : constant Name_Id := N + $; -- GNAT Name_Link_With : constant Name_Id := N + $; -- GNAT Name_Linker_Alias : constant Name_Id := N + $; -- GNAT @@ -572,6 +593,7 @@ package Snames is Name_Pre : constant Name_Id := N + $; -- GNAT Name_Precondition : constant Name_Id := N + $; -- GNAT Name_Predicate : constant Name_Id := N + $; -- GNAT + Name_Predicate_Failure : constant Name_Id := N + $; -- Ada 12 Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 05 Name_Preelaborate : constant Name_Id := N + $; Name_Pre_Class : constant Name_Id := N + $; -- GNAT @@ -634,6 +656,7 @@ package Snames is Name_Volatile : constant Name_Id := N + $; Name_Volatile_Components : constant Name_Id := N + $; Name_Volatile_Full_Access : constant Name_Id := N + $; -- GNAT + Name_Volatile_Function : constant Name_Id := N + $; -- GNAT Name_Weak_External : constant Name_Id := N + $; -- GNAT Last_Pragma_Name : constant Name_Id := N + $; @@ -651,12 +674,10 @@ package Snames is Name_Ada_Pass_By_Copy : constant Name_Id := N + $; Name_Ada_Pass_By_Reference : constant Name_Id := N + $; Name_Assembler : constant Name_Id := N + $; - Name_CIL : constant Name_Id := N + $; Name_COBOL : constant Name_Id := N + $; Name_CPP : constant Name_Id := N + $; Name_Fortran : constant Name_Id := N + $; Name_Intrinsic : constant Name_Id := N + $; - Name_Java : constant Name_Id := N + $; Name_Stdcall : constant Name_Id := N + $; Name_Stubbed : constant Name_Id := N + $; Last_Convention_Name : constant Name_Id := N + $; @@ -791,6 +812,7 @@ package Snames is Name_Strict : constant Name_Id := N + $; Name_Subunit_File_Name : constant Name_Id := N + $; Name_Suppressed : constant Name_Id := N + $; + Name_Synchronous : constant Name_Id := N + $; Name_Task_Stack_Size_Default : constant Name_Id := N + $; Name_Task_Type : constant Name_Id := N + $; Name_Time_Slicing_Enabled : constant Name_Id := N + $; @@ -941,7 +963,6 @@ package Snames is Name_To_Address : constant Name_Id := N + $; -- GNAT Name_Type_Class : constant Name_Id := N + $; -- GNAT Name_Type_Key : constant Name_Id := N + $; -- GNAT - Name_UET_Address : constant Name_Id := N + $; -- GNAT Name_Unbiased_Rounding : constant Name_Id := N + $; Name_Unchecked_Access : constant Name_Id := N + $; Name_Unconstrained_Array : constant Name_Id := N + $; -- GNAT @@ -1109,6 +1130,8 @@ package Snames is Name_Storage_Check : constant Name_Id := N + $; Name_Tag_Check : constant Name_Id := N + $; Name_Validity_Check : constant Name_Id := N + $; -- GNAT + Name_Container_Checks : constant Name_Id := N + $; -- GNAT + Name_Tampering_Check : constant Name_Id := N + $; -- GNAT Name_All_Checks : constant Name_Id := N + $; Last_Check_Name : constant Name_Id := N + $; @@ -1401,6 +1424,8 @@ package Snames is -- Other miscellaneous names used in front end Name_Unaligned_Valid : constant Name_Id := N + $; + Name_Suspension_Object : constant Name_Id := N + $; + Name_Synchronous_Task_Control : constant Name_Id := N + $; -- Names used to implement iterators over predefined containers @@ -1576,7 +1601,6 @@ package Snames is Attribute_To_Address, Attribute_Type_Class, Attribute_Type_Key, - Attribute_UET_Address, Attribute_Unbiased_Rounding, Attribute_Unchecked_Access, Attribute_Unconstrained_Array, @@ -1682,11 +1706,9 @@ package Snames is Convention_Assembler, -- also Asm, Assembly Convention_C, -- also Default, External - Convention_CIL, Convention_COBOL, Convention_CPP, Convention_Fortran, - Convention_Java, Convention_Stdcall); -- also DLL, Win32 -- Note: Convention C_Pass_By_Copy is allowed only for record types @@ -1816,11 +1838,11 @@ package Snames is Pragma_Atomic_Components, Pragma_Attach_Handler, Pragma_Check, - Pragma_CIL_Constructor, Pragma_Comment, Pragma_Common_Object, Pragma_Complete_Representation, Pragma_Complex_Representation, + Pragma_Constant_After_Elaboration, Pragma_Contract_Cases, Pragma_Controlled, Pragma_Convention, @@ -1866,8 +1888,6 @@ package Snames is Pragma_Interface_Name, Pragma_Interrupt_Handler, Pragma_Invariant, - Pragma_Java_Constructor, - Pragma_Java_Interface, Pragma_Keep_Names, Pragma_Link_With, Pragma_Linker_Alias, @@ -1899,6 +1919,7 @@ package Snames is Pragma_Pre, Pragma_Precondition, Pragma_Predicate, + Pragma_Predicate_Failure, Pragma_Preelaborable_Initialization, Pragma_Preelaborate, Pragma_Pre_Class, @@ -1945,6 +1966,7 @@ package Snames is Pragma_Volatile, Pragma_Volatile_Components, Pragma_Volatile_Full_Access, + Pragma_Volatile_Function, Pragma_Weak_External, -- The following pragmas are on their own, out of order, because of the diff --git a/gcc/ada/spark_xrefs.ads b/gcc/ada/spark_xrefs.ads index 41719ea3aec..f6cc7c3de92 100644 --- a/gcc/ada/spark_xrefs.ads +++ b/gcc/ada/spark_xrefs.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,11 +34,11 @@ with GNAT.Table; package SPARK_Xrefs is - -- SPARK cross-reference information can exist in one of two forms. In the - -- ALI file, it is represented using a text format that is described in - -- this specification. Internally it is stored using three tables - -- SPARK_Xref_Table, SPARK_Scope_Table and SPARK_File_Table, which are also - -- defined in this unit. + -- SPARK cross-reference information can exist in one of two forms. In + -- the ALI file, it is represented using a text format that is described + -- in this specification. Internally it is stored using three tables + -- SPARK_Xref_Table, SPARK_Scope_Table and SPARK_File_Table, which are + -- also defined in this unit. -- Lib.Xref.SPARK_Specific is part of the compiler. It extracts SPARK -- cross-reference information from the complete set of cross-references @@ -111,9 +111,10 @@ package SPARK_Xrefs is -- type is a single letter identifying the type of the entity, using -- the same code as in cross-references: - -- K = package - -- V = function - -- U = procedure + -- K = package (k = generic package) + -- V = function (v = generic function) + -- U = procedure (u = generic procedure) + -- Y = entry -- col is the column number of the scope entity @@ -137,7 +138,7 @@ package SPARK_Xrefs is -- entity-number and identity identify a scope entity in FS lines for -- the file previously identified. - -- line typ col entity ref* + -- F line typ col entity ref* -- line is the line number of the referenced entity diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads index e93e9b4b89b..c2e8bc7aba3 100644 --- a/gcc/ada/stand.ads +++ b/gcc/ada/stand.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -330,13 +330,13 @@ package Stand is -- situations. They have names that are suitable for use in such -- error messages (see body for actual names used). - Standard_Void_Type : Entity_Id; + Standard_Void_Type : Entity_Id; -- This is a type used to represent the return type of procedures - Standard_Exception_Type : Entity_Id; + Standard_Exception_Type : Entity_Id; -- This is a type used to represent the Etype of exceptions - Standard_A_String : Entity_Id; + Standard_A_String : Entity_Id; -- An access to String type used for building elements of tables -- carrying the enumeration literal names. @@ -446,8 +446,8 @@ package Stand is -- this type is always IEEE format. Universal_Fixed : Entity_Id; - -- Entity for universal fixed type. This is a type with arbitrary - -- precision that can only appear in a context with a specific type. + -- Entity for universal fixed type. This is a type with arbitrary + -- precision that can only appear in a context with a specific type. -- Universal_Fixed labels the result of multiplication or division of -- two fixed point numbers, and has no specified bounds (since, unlike -- universal integer and universal real, it is never used for runtime diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb index 880540eca3e..b26c583ea93 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Bindgen; with Debug; use Debug; with Osint; use Osint; with Opt; use Opt; @@ -126,7 +127,7 @@ package body Switch.B is -- A little check, "gnat" at the start of a switch is not allowed except -- for the compiler - if Switch_Chars'Last >= Ptr + 3 + if Max >= Ptr + 3 and then Switch_Chars (Ptr .. Ptr + 3) = "gnat" then Osint.Fail ("invalid switch: """ & Switch_Chars & """" @@ -228,8 +229,28 @@ package body Switch.B is -- Processing for E switch when 'E' => - Ptr := Ptr + 1; + + -- -E is equivalent to -Ea (see below) + Exception_Tracebacks := True; + Ptr := Ptr + 1; + + if Ptr <= Max then + case Switch_Chars (Ptr) is + + -- -Ea sets Exception_Tracebacks + + when 'a' => null; + + -- -Es sets both Exception_Tracebacks and + -- Exception_Tracebacks_Symbolic. + + when 's' => Exception_Tracebacks_Symbolic := True; + when others => Bad_Switch (Switch_Chars); + end case; + + Ptr := Ptr + 1; + end if; -- Processing for F switch @@ -417,6 +438,26 @@ package body Switch.B is Ptr := Ptr + 1; Verbose_Mode := True; + -- Processing for V switch + + when 'V' => + declare + Eq : Integer; + begin + Ptr := Ptr + 1; + Eq := Ptr; + while Eq <= Max and then Switch_Chars (Eq) /= '=' loop + Eq := Eq + 1; + end loop; + if Eq = Ptr or else Eq = Max then + Bad_Switch (Switch_Chars); + end if; + Bindgen.Set_Bind_Env + (Key => Switch_Chars (Ptr .. Eq - 1), + Value => Switch_Chars (Eq + 1 .. Max)); + Ptr := Max + 1; + end; + -- Processing for w switch when 'w' => @@ -521,13 +562,11 @@ package body Switch.B is declare Src_Path_Name : constant String_Ptr := Get_RTS_Search_Dir - (Switch_Chars - (Ptr + 1 .. Switch_Chars'Last), + (Switch_Chars (Ptr + 1 .. Max), Include); Lib_Path_Name : constant String_Ptr := Get_RTS_Search_Dir - (Switch_Chars - (Ptr + 1 .. Switch_Chars'Last), + (Switch_Chars (Ptr + 1 .. Max), Objects); begin @@ -543,17 +582,18 @@ package body Switch.B is Ptr := Max + 1; - elsif Src_Path_Name = null + elsif Src_Path_Name = null and then Lib_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adainclude and adalib directories"); + Osint.Fail + ("RTS path not valid: missing adainclude and " + & "adalib directories"); elsif Src_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adainclude directory"); - elsif Lib_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adalib directory"); + Osint.Fail + ("RTS path not valid: missing adainclude directory"); + elsif Lib_Path_Name = null then + Osint.Fail + ("RTS path not valid: missing adalib directory"); end if; end; end if; diff --git a/gcc/ada/switch-b.ads b/gcc/ada/switch-b.ads index 9ec91896650..e22296a15b4 100644 --- a/gcc/ada/switch-b.ads +++ b/gcc/ada/switch-b.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,7 +32,7 @@ package Switch.B is procedure Scan_Binder_Switches (Switch_Chars : String); - -- Procedures to scan out binder switches stored in the given string. + -- Procedure to scan out binder switches stored in the given string. -- The first character is known to be a valid switch character, and there -- are no blanks or other switch terminator characters in the string, so -- the entire string should consist of valid switch characters, except that diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 01dae2bf1fc..1ecbd1462bc 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -865,10 +865,23 @@ __gnat_get_task_options (void) /* Mask those bits that are not under user control */ #ifdef VX_USR_TASK_OPTIONS - return options & VX_USR_TASK_OPTIONS; -#else - return options; + /* O810-007, TSR 00043679: + Workaround a bug in Vx-7 where VX_DEALLOC_TCB == VX_PRIVATE_UMASK and: + - VX_DEALLOC_TCB is an internal option not to be used by users + - VX_PRIVATE_UMASK as a user-definable option + This leads to VX_USR_TASK_OPTIONS allowing 0x8000 as VX_PRIVATE_UMASK but + taskCreate refusing this option (VX_DEALLOC_TCB is not allowed) + + Note that the same error occurs in both RTP and Kernel mode, but + VX_DEALLOC_TCB is not defined in the RTP headers, so we need to + explicitely check if VX_PRIVATE_UMASK has value 0x8000 + */ +# if defined (VX_PRIVATE_UMASK) && (0x8000 == VX_PRIVATE_UMASK) + options &= ~VX_PRIVATE_UMASK; +# endif + options &= VX_USR_TASK_OPTIONS; #endif + return options; } #endif diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads index 2b398d762cd..4788016738c 100644 --- a/gcc/ada/table.ads +++ b/gcc/ada/table.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -55,8 +55,8 @@ package Table is package Table is -- Table_Component_Type and Table_Index_Type specify the type of the - -- array, Table_Low_Bound is the lower bound. Index_type must be an - -- integer type. The effect is roughly to declare: + -- array, Table_Low_Bound is the lower bound. Table_Index_Type must be + -- an integer type. The effect is roughly to declare: -- Table : array (Table_Index_Type range Table_Low_Bound .. <>) -- of Table_Component_Type; diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 645193e2459..42696cf0ba2 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -44,14 +44,12 @@ package body Targparm is BDC, -- Backend_Divide_Checks BOC, -- Backend_Overflow_Checks CLA, -- Command_Line_Args - CLI, -- CLI (.NET) CRT, -- Configurable_Run_Times D32, -- Duration_32_Bits DEN, -- Denorm EXS, -- Exit_Status_Supported FEL, -- Frontend_Layout FFO, -- Fractional_Fixed_Ops - JVM, -- JVM MOV, -- Machine_Overflows MRN, -- Machine_Rounds PAS, -- Preallocated_Stacks @@ -79,14 +77,12 @@ package body Targparm is BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks"; BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks"; CLA_Str : aliased constant Source_Buffer := "Command_Line_Args"; - CLI_Str : aliased constant Source_Buffer := "CLI"; CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time"; D32_Str : aliased constant Source_Buffer := "Duration_32_Bits"; DEN_Str : aliased constant Source_Buffer := "Denorm"; EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported"; FEL_Str : aliased constant Source_Buffer := "Frontend_Layout"; FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops"; - JVM_Str : aliased constant Source_Buffer := "JVM"; MOV_Str : aliased constant Source_Buffer := "Machine_Overflows"; MRN_Str : aliased constant Source_Buffer := "Machine_Rounds"; PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks"; @@ -114,14 +110,12 @@ package body Targparm is BDC_Str'Access, BOC_Str'Access, CLA_Str'Access, - CLI_Str'Access, CRT_Str'Access, D32_Str'Access, DEN_Str'Access, EXS_Str'Access, FEL_Str'Access, FFO_Str'Access, - JVM_Str'Access, MOV_Str'Access, MRN_Str'Access, PAS_Str'Access, @@ -794,33 +788,12 @@ package body Targparm is when BDC => Backend_Divide_Checks_On_Target := Result; when BOC => Backend_Overflow_Checks_On_Target := Result; when CLA => Command_Line_Args_On_Target := Result; - when CLI => - if Result then - VM_Target := CLI_Target; - Tagged_Type_Expansion := False; - end if; - -- This is wrong, this processing should be done in - -- Gnat1drv.Adjust_Global_Switches. It is not the - -- right level for targparm to know about tagged - -- type extension??? - when CRT => Configurable_Run_Time_On_Target := Result; when D32 => Duration_32_Bits_On_Target := Result; when DEN => Denorm_On_Target := Result; when EXS => Exit_Status_Supported_On_Target := Result; when FEL => Frontend_Layout_On_Target := Result; when FFO => Fractional_Fixed_Ops_On_Target := Result; - - when JVM => - if Result then - VM_Target := JVM_Target; - Tagged_Type_Expansion := False; - end if; - -- This is wrong, this processing should be done in - -- Gnat1drv.Adjust_Global_Switches. It is not the - -- right level for targparm to know about tagged - -- type extension??? - when MOV => Machine_Overflows_On_Target := Result; when MRN => Machine_Rounds_On_Target := Result; when PAS => Preallocated_Stacks_On_Target := Result; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index a1b766153ee..21780d1b12c 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -203,13 +203,6 @@ package Targparm is AAMP_On_Target : Boolean := False; -- Set to True if target is AAMP - type Virtual_Machine_Kind is (No_VM, JVM_Target, CLI_Target); - VM_Target : Virtual_Machine_Kind := No_VM; - -- Kind of virtual machine targetted - -- No_VM: no virtual machine, default case of a standard processor - -- JVM_Target: Java Virtual Machine - -- CLI_Target: CLI/.NET Virtual Machine - ------------------------------- -- Backend Arithmetic Checks -- ------------------------------- diff --git a/gcc/ada/tempdir.adb b/gcc/ada/tempdir.adb index 4936c26c5aa..d7838630385 100644 --- a/gcc/ada/tempdir.adb +++ b/gcc/ada/tempdir.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -62,7 +62,7 @@ package body Tempdir is end if; end Directory; - -- Start of processing Tempdir + -- Start of processing for Create_Temp_File begin if Temp_Dir'Length /= 0 then diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index 1e53ab51b98..ff85ca5baf5 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -274,6 +274,8 @@ __gnat_backtrace (void **array, #define PC_ADJUST -4 #elif defined (__arm__) #define PC_ADJUST -2 +#elif defined (__arm64__) +#define PC_ADJUST -4 #else #error Unhandled darwin architecture. #endif @@ -413,9 +415,9 @@ struct layout window of frame N-1 (positive offset from fp), in which we retrieve the saved return address. We then end up with our caller's return address. */ -/*------------------------------- x86 ----------------------------------*/ +/*---------------------------- x86 & x86_64 ---------------------------------*/ -#elif defined (__i386__) +#elif defined (__i386__) || defined (__x86_64__) #if defined (__WIN32) #include <windows.h> @@ -426,10 +428,12 @@ struct layout #define IS_BAD_PTR(ptr) 0 #endif -/* Starting with GCC 4.6, -fomit-frame-pointer is turned on by default for - 32-bit x86/Linux as well and DWARF 2 unwind tables are emitted instead. - See the x86-64 case below for the drawbacks with this approach. */ -#if defined (__linux__) && (__GNUC__ * 10 + __GNUC_MINOR__ > 45) +/* Use the dwarf2 unwinder when we expect to have dwarf2 tables at + hand. Backtraces will reliably stop on frames missing such tables, + but our only alternative is the generic unwinder which requires + compilation forcing a frame pointer to be reliable. */ + +#if (defined (__x86_64__) || defined (__linux__)) && !defined (__USING_SJLJ_EXCEPTIONS__) #define USE_GCC_UNWINDER #else #define USE_GENERIC_UNWINDER @@ -442,9 +446,9 @@ struct layout }; #define FRAME_LEVEL 1 -/* builtin_frame_address (1) is expected to work on this target, and (0) might - return the soft stack pointer, which does not designate a location where a - backchain and a return address might be found. */ +/* builtin_frame_address (1) is expected to work on this family of targets, + and (0) might return the soft stack pointer, which does not designate a + location where a backchain and a return address might be found. */ #define FRAME_OFFSET(FP) 0 #define PC_ADJUST -2 @@ -476,23 +480,6 @@ struct layout || ((*((ptr) - 1) & 0xff) == 0xff) \ || (((*(ptr) & 0xd0ff) == 0xd0ff)))) -/*----------------------------- x86_64 ---------------------------------*/ - -#elif defined (__x86_64__) - -#define USE_GCC_UNWINDER -/* The generic unwinder is not used for this target because it is based - on frame layout assumptions that are not reliable on this target (the - rbp register is very likely used for something else than storing the - frame pointer in optimized code). Hence, we use the GCC unwinder - based on DWARF 2 call frame information, although it has the drawback - of not being able to unwind through frames compiled without DWARF 2 - information. -*/ - -#define PC_ADJUST -2 -/* The minimum size of call instructions on this architecture is 2 bytes */ - /*----------------------------- ia64 ---------------------------------*/ #elif defined (__ia64__) && (defined (__linux__) || defined (__hpux__)) diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index d11a12bbe9c..a032416587b 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -1565,13 +1565,9 @@ package body Treepr is Print_Elist_Ref (E); Print_Eol; - M := First_Elmt (E); - - if No (M) then - Print_Str ("<empty element list>"); - Print_Eol; + if Present (E) and then not Is_Empty_Elmt_List (E) then + M := First_Elmt (E); - else loop Print_Char ('|'); Print_Eol; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index ed3eac1d43c..8b21b10ca4d 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -629,7 +629,7 @@ package Types is -- copying operations during installation. We have particularly noticed -- that WinNT seems susceptible to such changes. -- - -- Note : the Empty_Time_Stamp value looks equal to itself, and less than + -- Note: the Empty_Time_Stamp value looks equal to itself, and less than -- any non-empty time stamp value. procedure Split_Time_Stamp @@ -679,11 +679,13 @@ package Types is Storage_Check : constant := 15; Tag_Check : constant := 16; Validity_Check : constant := 17; + Container_Checks : constant := 18; + Tampering_Check : constant := 19; -- Values used to represent individual predefined checks (including the -- setting of Atomic_Synchronization, which is implemented internally using -- a "check" whose name is Atomic_Synchronization). - All_Checks : constant := 18; + All_Checks : constant := 20; -- Value used to represent All_Checks value subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks; @@ -827,9 +829,8 @@ package Types is -- To add a new code, you need to do the following: -- 1. Assign a new number to the reason. Do not renumber existing codes, - -- since this causes compatibility/bootstrap issues, and problems in - -- the CIL/JVM backends. So always add the new code at the end of the - -- list. + -- since this causes compatibility/bootstrap issues, so always add the + -- new code at the end of the list. -- 2. Update the contents of the array Kind @@ -845,10 +846,7 @@ package Types is -- Note on ordering of references. For the tables in Ada.Exceptions units, -- usually the ordering does not matter, and we use the same ordering as -- is used here (note the requirement in the ordering here that CE/PE/SE - -- codes be kept together, so the subtype declarations work OK). However, - -- there is an important exception, which is in a-except-2005.adb, where - -- ordering of the Rcheck routines must correspond to the ordering of the - -- Rmsg_xx messages. This is required by the .NET scripts. + -- codes be kept together, so the subtype declarations work OK). type RT_Exception_Code is (CE_Access_Check_Failed, -- 00 diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 7a554392a79..948c521b22e 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1586,7 +1586,7 @@ package body Uintp is -- Use prior single precision steps to compute this Euclid step -- For constructs such as: - -- sqrt_2: constant := 1.41421_35623_73095_04880_16887_24209_698; + -- sqrt_2: constant := 1.41421_35623_73095_04880_16887_24209_698; -- sqrt_eps: constant long_float := long_float( 1.0 / sqrt_2) -- ** long_float'machine_mantissa; -- diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 803c44d7a51..ae0981fd05c 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -91,9 +91,9 @@ begin Write_Eol; - -- Common GCC switches not available for JVM, .NET, and AAMP targets + -- Common GCC switches not available for AAMP targets - if VM_Target = No_VM and then not AAMP_On_Target then + if not AAMP_On_Target then Write_Switch_Char ("fstack-check ", ""); Write_Line ("Generate stack checking code"); @@ -104,7 +104,7 @@ begin Write_Line ("Preserve control flow for coverage analysis"); end if; - -- Common switches available to both GCC and JGNAT + -- Common switches available everywhere Write_Switch_Char ("g ", ""); Write_Line ("Generate debugging information"); |