diff options
author | mrs <mrs@138bc75d-0d04-0410-961f-82ee72b054a4> | 2013-10-20 23:47:35 +0000 |
---|---|---|
committer | mrs <mrs@138bc75d-0d04-0410-961f-82ee72b054a4> | 2013-10-20 23:47:35 +0000 |
commit | 6b40961666f073231ed8a76e6e33deeda063cde7 (patch) | |
tree | 8247eb4232e8be98b7f61bd68bab2fd1a9f06ca3 /gcc/ada | |
parent | e6b1b76450af5f98696ecedd4bd9a0ed18cdb2a6 (diff) | |
parent | fc1ce0cf396bf638746d546a557158d87f13849b (diff) | |
download | gcc-6b40961666f073231ed8a76e6e33deeda063cde7.tar.gz |
Merge in trunk.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/wide-int@203881 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
190 files changed, 20378 insertions, 10316 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6b0ba092134..cc462e9c4a7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,2431 @@ +2013-10-19 Thomas Quinot <quinot@adacore.com> + + * gcc-interface/Makefile.in: Use canonical absolute path to refer to + the top source directory and to the libgcc subidrectories. + +2013-10-19 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (scale_by_factor_of): New function. + (rest_of_record_type_compilation): Use scale_by_factor_of in order to + scale the original offset for both rounding cases; in the second case, + take into accout the addend to compute the alignment. Tidy up. + +2013-10-19 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/cuintp.c: Remove useless include directives. + (build_cst_from_int): Use standard predicate. + (UI_To_gnu): Simplify. + (UI_From_gnu): Fix formatting. + * gcc-interface/trans.c (post_error): Likewise. + (post_error_ne): Likewise. + +2013-10-19 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (gnat_set_type_context): New function. + (gnat_pushdecl): Use it to set the context of the type. + +2013-10-17 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Check_Dependency_Clause): + Recognize the scenario where successful clause matching has + depleted the available refinement items and the clause to match + technically refines to null => null. + +2013-10-17 Tristan Gingold <gingold@adacore.com> + + * exp_prag.adb (Expand_Pragma_Import_Or_Interface): Specify + External_Name instead of Link_Name for the RTTI declaration. + +2013-10-17 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb (Record_Possible_Body_Reference): Fix test for + being in body. + (Add_Constituent): Merged into Check_Refined_Global_Item. + (Check_Matching_Constituent): A constituent that has the proper Part_Of + option and comes from a private child or a sibling is now collected. + (Check_Matching_Modes): Merged into Check_Refined_Global_Item. + (Check_Refined_Global_Item): Code cleanup. + (Collect_Constituent): New routine. + (Inconsistent_Mode_Error): Moved out from Check_Matching_Modes. + +2013-10-17 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Check_Current_Instance, Process): Add RM reference + and mention immutably limited types, when the current instance + is illegal in Ada 2012. + +2013-10-17 Ed Schonberg <schonberg@adacore.com> + + * sem_warn.adb (Check_Unused_Withs): If the main unit is a + subunit, apply the check to the units mentioned in its context + only. This provides additional warnings on with_clauses that + are superfluous. + +2013-10-17 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch3.adb (Analyze_Declarations): Emit an + error message concerning state refinement when the spec defines at + least one non-null abstract state and the body's SPARK mode is On. + (Requires_State_Refinement): New routine. + +2013-10-17 Robert Dewar <dewar@adacore.com> + + * sem_ch7.ads: Comment fixes. + +2013-10-17 Robert Dewar <dewar@adacore.com> + + * sem_ch7.adb (Analyze_Package_Specification): Remove circuit + for ensuring that a package spec requires a body for some other + reason than that it contains the declaration of an abstract state. + +2013-10-17 Tristan Gingold <gingold@adacore.com> + + * exp_ch11.adb (Expand_N_Raise_Expression): Fix call of + Possible_Local_Raise. + +2013-10-17 Thomas Quinot <quinot@adacore.com> + + * exp_pakd.adb (Expand_Bit_Packed_Element_Set): Unchecked + conversion of Or_Rhs to Etype of New_Rhs is required only when + the latter is the result of a byte swap operation. + +2013-10-17 Thomas Quinot <quinot@adacore.com> + + * exp_dist.adb (Build_To_Any_Function): For a type with opaque + representation that is not transmitted as an unconstrained value, + use 'Write, not 'Output, to generate the opaque representation. + +2013-10-17 Yannick Moy <moy@adacore.com> + + * sem_res.adb (Resolve_Short_Circuit): Only + generate expression-with-action when full expansion is set. + +2013-10-17 Yannick Moy <moy@adacore.com> + + * debug.adb Remove obsolete comment. + +2013-10-17 Thomas Quinot <quinot@adacore.com> + + * exp_ch4.adb (Process_Transient_Object.Find_Enclosing_Contexts): + Avoid late insertion when expanding an expression with action + nested within a transient block; Do not inconditionally generate + a finalization call if the generated object is from a specific + branch of a conditional expression. + +2013-10-17 Pascal Obry <obry@adacore.com> + + * g-arrspl.adb: Ensure Finalize call is idempotent. + * g-arrspl.adb (Finalize): Makes the call idempotent. + +2013-10-17 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Is_Matching_Input): Account + for the case where a state with a null refinement appears as + the last input of a refinement clause. + +2013-10-17 Robert Dewar <dewar@adacore.com> + + * sem_aux.ads, sem_aux.adb: Minor reformatting. + +2013-10-17 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb, aspects.ads, sem_prag.ads: Remove all entries + for Refined_Pre from the various tables. + * par-prag.adb: Remove the entry for Refined_Pre from the list + of pragmas not needing special processing by the parser. + * sem_ch13.adb (Analyze_Aspect_Specifications): + Remove the processing for aspect Refined_Pre. + (Check_Aspect_At_Freeze_Point): Remove the entry for aspect + Refined_Pre. + * sem_prag.adb (Analyze_Pragma): Refined_Pre is no longer a + valid assertion kind. Remove the analysis of pragma Refined_Pre. + (Analyze_Refined_Pragma): Update the comment on usage. + (Find_Related_Subprogram_Or_Body): Update the comment on + usage. Pragma Refined_Pre is no longer processed by this routine. + (Is_Valid_Assertion_Kind): Refined_Pre is no longer a valid + assertion kind. + * snames.ads-tmpl: Remove predefined name Refined_Pre. Remove + the pragma id for Refined_Pre. + +2013-10-17 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_util.adb, exp_util.ads (Entity_Of): Moved to Sem_Util. + * sem_prag.adb (Analyze_Global_In_Decl_List): Mark a null + item list as being analyzed. + (Analyze_Global_List): Mark a + null global list and multiple global items as being analyzed. + (Analyze_Input_Item): Check the unit that defines the input + variable or state, not the reference to it. + * sem_util.ads, sem_util.adb (Entity_Of): Moved from Exp_Util. Ensure + that the input has an entity. + +2013-10-17 Thomas Quinot <quinot@adacore.com> + + * exp_util.adb (Get_Current_Value_Condition, + Set_Current_Value_Condition): Handle the case of expressions + with actions * exp_util.adb (Insert_Actions): Handle the case + of an expression with actions whose Actions list is empty. + * exp_util.adb (Remove_Side_Effects.Side_Effect_Free): An + expression with actions that has no Actions and whose Expression + is side effect free is itself side effect free. + * exp_util.adb (Remove_Side_Effects): Do not set an incorrect etype on + temporary 'R' (Def_Id), which is in general an access to Exp_Type, not + an Exp_Type. + * sem_res.adb (Resolve): For an expression with + actions, resolve the expression early. * sem_res.adb + (Resolve_Expression_With_Actions): Rewrite an expression with + actions whose value is compile time known and which has no + actions into just its expression, so that its constant value is + available downstream. + * sem_res.adb (Resolve_Short_Circuit): + Wrap the left operand in an expression with actions to contain + any required finalization actions. + * exp_ch4.adb (Expand_Expression_With_Actions): For an + expression with actions returning a Boolean expression, ensure + any finalization action is kept within the Actions list. + * sem_warn.adb (Check_References, Check_Unset_Reference): add + missing circuitry to handle expressions with actions. + * checks.adb (Ensure_Valid): For an expression with actions, + insert the validity check on the Expression. + * sem_ch13.adb (Build_Static_Predicate.Get_RList): An expression + with actions that has a non-empty Actions list is not static. An + expression with actions that has an empty Actions list has the + static ranges of its Expression. + * sem_util.adb (Has_No_Obvious_Side_Effects): An expression with + actions with an empty Actions list has no obvious side effects + if its Expression itsekf has no obvious side effects. + +2013-10-17 Ed Schonberg <schonberg@adacore.com> + + * sem_aux.ads, sem_aux.adb (Is_Immutably_Limited_Type): Make + predicate compatible with Ada 2012 definition + (Is_Limited_View): New name for previous version of + Is_Immutably_Limited_Type. Predicate is true for an untagged + record type with a limited component. + * exp_ch7.adb, exp_ch6.adb, exp_ch4.adb, exp_ch3.adb, exp_aggr.adb, + sem_util.adb, sem_res.adb, sem_prag.adb, sem_attr.adb, sem_ch8.adb, + sem_ch6.adb, sem_ch3.adb, exp_util.adb: Use Is_Limited_View + * freeze.adb Use Is_Immutably_Limited_Type to check the legality + of references to the current instance, Is_Limited_View otherwise. + +2013-10-17 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Flag aspect + Refined_Pre as not supported. + * sem_prag.adb (Analyze_Pragma): Ignore pragma Refined_Pre. + +2013-10-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Validated_Access_Subprogram_Instance): According + to AI05-288, actuals for access_to_subprograms must be subtype + conformant with the generic formal. Previous to AI05-288 + only mode conformance was required, but the AI is a binding + interpretation that applies to previous versions of the language, + +2013-10-17 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: Minor text correction. + * ug_words: Add entry for -gnateu /IGNORE_UNRECOGNIZED. + * vms_data.ads: Add /IGNORE_UNRECOGNIZED for -gnateu. + +2013-10-17 Tristan Gingold <gingold@adacore.com> + + * impunit.adb (Non_Imp_File_Names_95): Add g-cppexc. + +2013-10-17 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Constituent): Move the check + concerning option Part_Of to routine Check_Matching_Constituent. + (Check_Matching_Constituent): Verify that an abstract state + that acts as a constituent has the proper Part_Of option in + its aspect/pragma Abstract_State. Account for the case when a + constituent comes from a private child or private sibling. + * sem_util.ads, sem_util.adb (Is_Child_Or_Sibling): New routine. + +2013-10-17 Tristan Gingold <gingold@adacore.com> + + * g-cppexc.adb, g-cppexc.ads: New files. + * gcc-interface/Makefile.in: Add g-cppexc when building zcx runtimes. + +2013-10-17 Thomas Quinot <quinot@adacore.com> + + * exp_ch7.adb: Minor reformatting. + +2013-10-17 Ed Schonberg <schonberg@adacore.com> + + * sem_dim.adb (Process_Minus, Process_Divide): Label dimension + expression with standard operator and type, for pretty-printing + use. + +2013-10-17 Bob Duff <duff@adacore.com> + + * gnat_ugn.texi: Document --pp-new and --pp-old switches. + +2013-10-17 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb: Flag 159 is now known as From_Limited_With. Replace + all references to attribute From_With_Type with From_Limited_With. + (From_With_Type): Renamed to From_Limited_With. + (Set_From_With_Type): Renamd to Set_From_Limited_With. + * einfo.ads: Remove attribute From_With_Type and occurrences in + nodes. Add attribute From_Limited_With along with occurrences + in nodes. + (From_With_Type): Renamed to From_Limited_With along with pragma Inline. + (Set_From_With_Type): Renamed to + Set_From_Limited_With along with pragma Inline. + * sem_ch7.adb, sem_ch8.adb, sem_ch12.adb, sem_ch13.adb, sem_disp.adb, + sem_res.adb, sem_type.adb, sem_util.adb, sem_warn.adb, + exp_attr.adb, exp_disp.adb, freeze.adb, itypes.adb, layout.adb, + lib-writ.adb, rtsfind.adb, sem_attr.adb, sem_aux.adb, sem_ch3.adb, + sem_ch4.adb: Replace all references to attribute From_With_Type + with From_Limited_With. + * sem_ch6.adb: Replace all references to attribute From_With_Type + with From_Limited_With. + (Designates_From_With_Type): Renamed to Designates_From_Limited_With. + (Process_Formals): Update the call to Designates_From_With_Type. + * sem_ch10.adb: Replace all references to attribute From_With_Type + with From_Limited_With. + (Build_Limited_Views): Reimplemented. + * gcc-interface/decl.c Replace all references to attribute + From_With_Type with From_Limited_With. + (finalize_from_with_types): Renamed to finalize_from_limited_with. + * gcc-interface/gigi.h (finalize_from_with_types): Renamed to + finalize_from_limited_with. + * gcc-interface/trans.c: Replace all references to attribute + From_With_Type with From_Limited_With. + (Compilation_Unit_to_gnu): Update the call to finalize_from_with_types. + +2013-10-17 Pascal Obry <obry@adacore.com> + + * projects.texi: Update VCS_Kind documentation. + +2013-10-17 Matthew Heaney <heaney@adacore.com> + + * a-convec.adb, a-coinve.adb, a-cobove.adb (Insert, Insert_Space): + Inspect value range before converting type. + +2013-10-17 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Flag the use of pragma Refined_Pre as + illegal. + +2013-10-17 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Remove VMS conversion of -gnatet and -gnateT, + now that they are both in ug_words. + * ug_words: Update qualifier for -gnatet Add qualifier for -gnateT + * vms_data.ads: Update qualifier for -gnatet Add qualifier + for -gnateT + * projects.texi: Continue to update the project documentation + for VMS. + +2013-10-17 Robert Dewar <dewar@adacore.com> + + * einfo.ads, einfo.adb (Has_Body_References): New flag. + (Body_References): New field. + * sem_prag.adb (Record_Possible_Body_Reference): New procedure + (Analyze_Input_Output): Call Record_Possible_Body_Reference + (Analyze_Global_Item): Call Record_Possible_Body_Reference + (Analyze_Refinement_Clause): Output messages if illegal global refs. + +2013-10-17 Thomas Quinot <quinot@adacore.com> + + * freeze.adb (Check_Component_Storage_Order): Reject a record or + array type that does not have an explicit Scalar_Storage_Order + attribute definition if a component of the record, or the + elements of the array, have one. + * gnat_rm.texi (attribute Scalar_Storage_Order): Document the above + rule. + +2013-10-17 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Add examples of switches -gnateD, including + one where the value is a string. + * projects.texi: Do not convert switches in project files to + VMS qualifiers. + +2013-10-17 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb (Report_Extra_Clauses): Don't complain about + refinements with null input since null should be considered to + always match. + +2013-10-17 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: Document -gnatw.y/-gnatw.Y. + * opt.ads (List_Body_Required_Info): New flag. + * prep.adb: Minor reformatting. + * sem_ch7.adb (Unit_Requires_Body_Info): New + procedure (Analyze_Package_Specification): Add call to + Unit_Requires_Body_Info. + * ug_words: Add entries for -gnatw.y and -gnatw.Y. + * usage.adb: Add line for new warning switch -gnatw.y/.Y. + * vms_data.ads: Add entry for [NO_]WHY_SPEC_NEEDS_BODY warning + qualifier. + * warnsw.ads, warnsw.adb: Implement new warning switch -gnatw.y/.Y. + +2013-10-17 Yannick Moy <moy@adacore.com> + + * sem_ch8.adb (Find_Direct_Name): Keep track of assignments for + renamings in SPARK mode. + +2013-10-17 Yannick Moy <moy@adacore.com> + + * exp_spark.adb (Expand_SPARK): Remove special case for NOT IN + operation. + * sinfo.ads: Add special comment section to describe SPARK mode + effect on tree. + * exp_spark.ads: Remove comments, moved to sinfo.ads. + +2013-10-17 Yannick Moy <moy@adacore.com> + + * exp_ch3.adb (Expand_Freeze_Class_Wide_Type, + Expand_Freeze_Class_Wide_Type, Expand_Freeze_Class_Wide_Type): + Remove useless special cases. + * exp_ch4.adb (Expand_Allocator_Expression, Expand_N_Allocator, + Expand_N_Op_Expon): Remove useless special cases. + * exp_ch6.adb (Is_Build_In_Place_Function_Call): Disable build-in-place + in SPARK mode by testing Full_Expander_Active instead of + Expander_Active. + (Make_Build_In_Place_Call_In_Allocator): Remove useless special case. + * exp_util.adb (Build_Allocate_Deallocate_Proc): Remove + useless special case. + * sem_eval.adb (Compile_Time_Known_Value): Remove special handling of + deferred constant. + +2013-10-17 Yannick Moy <moy@adacore.com> + + * gnat_ugn.texi: Document -gnateT and target file format. + +2013-10-17 Vincent Celier <celier@adacore.com> + + * prep.adb (Check_Command_Line_Symbol_Definition): Is_A_String is + always False, even when the value starts and ends with double quotes. + +2013-10-17 Tristan Gingold <gingold@adacore.com> + + * a-exexpr-gcc.adb: Synchronize declarations of other/all others. + +2013-10-17 Thomas Quinot <quinot@adacore.com> + + * exp_pakd.adb: Add missing guard protecting Reverse_Storage_Order + call. + * sem_res.adb: Minor code cleanup: use named parameter association + (not positional) for Boolean parameter Sec_Stack in calls to + Establish_Transient_Scope. + +2013-10-15 Thomas Quinot <quinot@adacore.com> + + * exp_pakd.adb (Expand_Packed_Element_Set, + Expand_Packed_Element_Reference): Adjust for the case of packed + arrays of reverse-storage-order types. + +2013-10-15 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb: Minor reformatting. + +2013-10-15 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Analyze_Attribute_Specification, case + To_Address): If the expression is an identifier, do not modify + its type; it will be converted when necessary, and the type of + the expression must remain consistent with that of the entity + for back-end consistency. + +2013-10-15 Robert Dewar <dewar@adacore.com> + + * sem_ch7.adb (Unit_Requires_Body): Add flag + Ignore_Abstract_State (Analyze_Package_Specification): Enforce + rule requiring Elaborate_Body if a non-null abstract state is + specified for a library-level package. + * sem_ch7.ads (Unit_Requires_Body): Add flag Ignore_Abstract_State. + +2013-10-15 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Constituent): When + a state acts as a constituent of another state, ensure that + the said state has a Part_Of dependency in its corresponding + aspect/pragma Abstract_State. + +2013-10-15 Robert Dewar <dewar@adacore.com> + + * par-ch4.adb (P_If_expression): Handle redundant ELSE cleanly. + +2013-10-15 Thomas Quinot <quinot@adacore.com> + + * atree.ads (New_Copy, Relocate_Node): Improve documentation + (note that these subprograms reset Is_Overloaded). + +2013-10-15 Thomas Quinot <quinot@adacore.com> + + * checks.adb (Check_Needed): Handle the case where the test in + the left operand of the short circuit is wrapped in a qualified + expression, type conversion, or expression with actions. + +2013-10-15 Thomas Quinot <quinot@adacore.com> + + * sem_type.adb, sem_type.ads (Save_Interps): Also propagate + Is_Overloaded to New_N, for consistency. + +2013-10-15 Ed Schonberg <schonberg@adacore.com> + + * a-tienau.adb (Put): Use file parameter to query values of + current column and line length. + +2013-10-15 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb, exp_ch11.adb, a-except-2005.adb, a-except-2005.ads: + Minor reformatting. + +2013-10-15 Eric Botcazou <ebotcazou@adacore.com> + + * targparm.ads: Fix minor typo in comment. + +2013-10-15 Ed Schonberg <schonberg@adacore.com> + + * lib-xref.adb: handle full views that are derived from private + types. + * sem_util.adb (Build_Elaboration_Entity): Do nothing in ASIS + mode: the elaboration entity is not in the source, and plays no + role in semantic analysis. Minor reformatting. + +2013-10-15 Tristan Gingold <gingold@adacore.com> + + * adaint.c (__gnat_get_executable_load_address): Remove AIX + specific code. + +2013-10-15 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Aggr_Size_OK): Refine criteria to better handle + large static aggregates with static record components, to avoid + generating a large number of asignments. Conversely, improve + handling of aggregates initialized by a single association, + which are most efficiently implemented with a loop. + +2013-10-15 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Input_Item): Emit an + error when the input item comes from the related package. + +2013-10-15 Arnaud Charlet <charlet@adacore.com> + + * exp_ch11.adb (Expand_Exception_Handlers): Restrict previous + change. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * gcc-interface/gigi.h (standard_datatypes): Add + ADT_set_exception_parameter_decl + (set_exception_parameter_decl): New macro. + * gcc-interface/trans.c (gigi): Initialize set_exception_parameter_decl. + (Exception_Handler_to_gnu_zcx): Initialize the choice parameter. + * gcc-interface/trans.c: Synchronize declarations of other/all others + between gigi and the runtime. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * exp_attr.adb (Find_Stream_Subprogram): Optimize + Storage_Array stream handling. + (Find_Stream_Subprogram): Optimize Stream_Element_Array stream handling + * rtsfind.ads: Add entry for Stream_Element_Array Add + entries for RE_Storage_Array subprograms Add entries for + RE_Stream_Element_Array subprograms + * s-ststop.ads, s-ststop.adb: Add processing for System.Storage_Array. + Add processing for Ada.Stream_Element_Array. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * a-except-2005.ads, a-except-2005.adb: + (Get_Exception_Machine_Occurrence): New function. + * raise-gcc.c (__gnat_unwind_exception_size): New constant. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * sem_res.adb: Minor fix to error message text. + * errout.ads, erroutc.ads: Minor reformatting. + * s-ststop.ads, s-stratt.ads: Clean up documentation of block IO + mode for streams. + * s-stratt-xdr.adb: Minor comment update. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * sem_aux.adb, sem_aux.ads, sem_prag.adb: Minor reformatting. + +2013-10-14 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Actuals): Add error message for a + subprogram with an in-out parameter when used in a predicate, + to clarify subsequent error at the point of call. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Is_Matching_Input): Consume a matching null input. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Freeze_Record): Don't give warning about packed + and foreign convention. + +2013-10-14 Ed Schonberg <schonberg@adacore.com> + + * sem_aux.adb, sem_aux.ads (Package_Specification): New function, to + replace the less efficient idiom Specification. + (Unit_Declaration_Node (Pack_Id)), which handles library units and + child units. + * sem_ch3.adb, sem_ch10.adb, sem_prag.adb, sem_ch12.adb, sem_ch6.adb, + exp_disp.adb, sem_cat.adb, exp_dist.adb: Use Package_Specification. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_attr.adb (Expand_Update_Attribute): Update the call to + Process_Range_Update. + (Process_Range_Update): Add new formal parameter Typ and associated + comment on usage. Add local constant Index_Typ. Add a type conversion + as part of the indexed component to ensure that the loop variable + corresponds to the index type. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * a-exexpr-gcc.adb: Adjust comment. + (Others_Value, All_Others_Value, + Unhandled_Others_Value): Declare as Character to slightly reduce + memory footprint. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Size_Known): Size is not known for packed record + with aliased components + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb: Minor fix to error message. + * a-exexpr-gcc.adb, sem_util.adb, sem_case.adb, exp_ch11.adb: Minor + reformatting. + +2013-10-14 Arnaud Charlet <charlet@adacore.com> + + * exp_ch11.adb: Fix typo. + +2013-10-14 Thomas Quinot <quinot@adacore.com> + + * exp_util.ads: Minor reformatting. + +2013-10-14 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Build_Derived_Record_Type): Reject full views + with no explicit discriminant constraints, when the parents of + the partial view and the full view are constrained subtypes with + different constraints. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Freeze_Array_Type): New procedure, abstracts out + this code from Freeze. + (Freeze_Array_Type): Detect pragma Pack overriding foreign convention + (Freeze_Record_Type): Ditto. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Dependency_Clause): Add new local variable + Non_Null_Output_Seen. Update the call to Analyze_Input_Output. + (Analyze_Input_Item): Streamline the detection mechanism of null and + non-null items. + (Analyze_Input_List): Add new local variable + Non_Null_Input_Seen. Update all calls to Analyze_Input_Output. + (Analyze_Input_Output): Add new formal parameter Non_Null_Seen + and update the related comment on usage. Update the + recursive call to itself. Attribute 'Result is now treated + as a non-null item. Detect mixes of null and non-null items. + (Analyze_Initialization_Item): Streamline the detection mechanism + of null and non-null items. + +2013-10-14 Vincent Celier <celier@adacore.com> + + * projects.texi: Add documentation for the new project level + attribute Library_Rpath_Options. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * a-exexpr-gcc.adb (Set_Exception_Parameter): New procedure. + (Set_Foreign_Occurrence): New procedure, extracted from + Setup_Current_Excep. + * exp_ch11.adb (Expand_Exception_Handlers): Do not expand choice + parameter in case of zcx. + * sem_ch11.adb (Analyze_Exception_Handlers): Need debug info + for the choice parameter. + * raise-gcc.c: Add comments. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb: Add an entry in table Canonical_Aspect for + Initial_Condition. + * aspects.ads: Add entries in tables Aspect_Id, Aspect_Argument, + Aspect_Names and Aspect_Delay for Initial_Condition. + * einfo.adb (Get_Pragma): Include pragma Initial_Condition to + categorization pragmas. + * einfo.ads (Get_Pragma): Update comment on usage. + * exp_ch7.adb (Expand_N_Package_Body): Add a runtime check to + verify the assertion introduced by pragma Initial_Condition. + (Expand_N_Package_Declaration): Add a runtime check to + verify the assertion introduced by pragma Initial_Condition. + (Expand_Pragma_Initial_Condition): New routine. + * par-prag: Include pragma Initial_Condition to the list of + pragmas that do not require special processing by the parser. + * sem_ch3.adb (Analyze_Declarations): Analyze pragma + Initial_Condition at the end of the visible declarations. + * sem_ch13.adb (Analyze_Aspect_Specifications): Add processing + for aspect Initial_Condition. + (Check_Aspect_At_Freeze_Point): + Aspect Initial_Condition does not need inspection at freezing. + * sem_prag.adb (Analyze_Initial_Condition_In_Decl_Part): + New routine. + (Analyze_Pragma): Update all calls + to Check_Declaration_Order. Add processing for pragma + Initial_Condition. Initial_Condition is now a valid assertion + kind. Add an entry in table Sig_Flags for Initial_Condition. + (Check_Declaration_Order): Reimplemented to handle arbitrary + pragmas. + (Is_Valid_Assertion_Kind): Add an entry for + Initial_Condition. + * sem_pag.ads (Analyze_Initial_Condition_In_Decl_Part): + New routine. + * sem_util.adb (Add_Contract_Item): Pragma Initial_Condition + can now be associated with a package spec. + * sem_util.ads (Add_Contract_Item): Update comment on usage. + * sinfo.ads: Update the documentation of node N_Contract + * snames.ads-tmpl: Add new predefined name Initial_Condition. Add + new pragma id for Initial_Condition. + +2013-10-14 Thomas Quinot <quinot@adacore.com> + + * exp_pakd.adb: Minor reformatting. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * exp_prag.adb: Minor reformatting. + +2013-10-14 Ed Schonberg <schonberg@adacore.com> + + * sem_case.adb (Check_Against_Predicate): Handle properly an + others clause in various cases. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Check_Matching_Constituent): Do + not inspect the hidden states if there are no hidden states. This + case arises when the constituents are states coming from a + private child. + +2013-10-14 Doug Rupp <rupp@adacore.com> + + * init.c [ARMEL and VxWorks] (__gnat_map_signal): Re-arm guard + page by clearing VALID bit vice setting page protection. + +2013-10-14 Arnaud Charlet <charlet@adacore.com> + + * gnat_rm.texi, adaint.c: Fix typo. + +2013-10-14 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Is_Variable, In_Protected_Function): In the + body of a protected function, the protected object itself is a + constant (not just its components). + +2013-10-14 Vincent Celier <celier@adacore.com> + + * snames.ads-tmpl: Add new standard name Library_Rpath_Options. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * sem_prag.adb (Process_Import_Or_Interface): Allow importing + of exception using convention Cpp. + * exp_prag.adb (Expand_Pragma_Import_Or_Interface): Expand cpp + imported exceptions. + * raise-gcc.c (is_handled_by): Filter C++ exception occurrences. + * gnat_rm.texi: Document how to import C++ exceptions. + +2013-10-14 Jose Ruiz <ruiz@adacore.com> + + * sem_ch13.adb (Sem_Ch13.Analyze_Aspect_Specification): For + Priority and CPU aspects, when checking, issue a warning only + if it is obviously not a main program. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * adaint.c: Fix condition for AIX. Minor reformatting. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb, sem_prag.adb, prj.ads: Minor reformatting. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Depends_In_Decl_Part): + Rename Outputs_Seen to All_Outputs_Seen and update all occurrences + of the variable. + (Analyze_Input_Output): Add an item to + All_Inputs_Seen when it is an input or a self-referential output. + (Check_Mode): Comment reformatting. + (Analyze_Abstract_State): Remove the restriction that an Export state + must also have mode Input_Only or Output_Only. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb: Flag 263 is now known as Has_Visible_Refinement. + (Has_Non_Null_Refinement): New routine. + (Has_Null_Refinement): The routine is now synthesized. + (Has_Visible_Refinement): New routine. + (Set_Has_Visible_Refinement): New routine. + (Write_Entity_Flags): Remove the output for + Has_Null_Refinement. Add output for Has_Visible_Refinement. + * einfo.ads: Update the occurrences of Has_Non_Null_Refinement, + Has_Null_Refinement and Has_Visible_Refinement in entities. + (Has_Non_Null_Refinement): New synthesized attribute. + (Has_Null_Refinement): This attribute is now synthesized. + (Has_Visible_Refinement): New routine with corresponding + pragma Inline. + (Set_Has_Visible_Refinement): New routine with corresponding pragma + Inline. + * sem_ch3.adb (Analyze_Declarations): Add new local + variable In_Package_Body. Remove state refinements from + visibility at the end of the package body declarations. + (Remove_Visible_Refinements): New routine. + * sem_prag.adb (Analyze_Constituent): Collect a null + constituent and mark the state as having visible refinement. + (Analyze_Global_Item): Use attribute Has_Visible_Refinement to + detect a state with visible refinement. + (Analyze_Input_Output): Use attribute Has_Visible_Refinement to detect + a state with visible refinement. + (Check_Dependency_Clause): Use attribute Has_Non_Null_Refinement rather + than checking the contents of list Refinement_Constituents. + (Check_In_Out_States): Use attribute Has_Non_Null_Refinement rather + than checking the contents of list Refinement_Constituents. + (Check_Input_States): Use attribute Has_Non_Null_Refinement rather + than checking the contents of list Refinement_Constituents. + (Check_Matching_Constituent): Mark a state as having visible refinement. + (Check_Output_States): Use attribute Has_Non_Null_Refinement rather than + checking the contents of list Refinement_Constituents. + (Check_Refined_Global_Item): Use attribute Has_Visible_Refinement + to detect a state with visible refinement. + (Is_Matching_Input): Use attribute Has_Non_Null_Refinement rather than + checking the contents of list Refinement_Constituents. + * sem_util.adb (Is_Refined_State): Use attribute + Has_Visible_Refinement to detect a state with visible refinement. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Check_Mode): Do not emit an + error when inspecting a self referencial output item of an + unconstrained type. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * exp_prag.adb (Expand_Pragma_Import_Export_Exception): Fix + target type for code of VMS imported exception. + * init.c: Replace Exception_Code by void *. + * s-vmexta.adb (Hash, Base_Code_In): Adjust code after changing + the type of Exception_Code. + +2013-10-14 Vincent Celier <celier@adacore.com> + + * prj.ads: Minor comment updates. + * prj-attr.adb: New attribute Library_Rpath_Options. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Library_Level attribute now applies to an + entity name. + * sem_attr.adb (Analyze_Attribute, case Library_Level): Prefix + is now an entity name. + +2013-10-14 Jose Ruiz <ruiz@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specification): For + Priority and CPU aspects in subprograms, the expression in the + aspect is analyzed and exported. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * s-valuti.adb, prep.adb, scng.adb, errout.adb: Minor reformatting. + +2013-10-14 Eric Botcazou <ebotcazou@adacore.com> + + * adaint.c: Further disable __gnat_get_executable_load_address + for Linux. + +2013-10-14 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Add documentation for comparing symbols to + integers in preprocessing expressions. + +2013-10-14 Jose Ruiz <ruiz@adacore.com> + + * sem_prag.adb (Analyze_Aspect_Specification): For + Priority and CPU aspects in subprograms, the expression in the + aspect is analyzed and exported. + (Analyze_Pragma): When having a Priority pragma in the + main subprogram, load a unit that will force the initialization + of the tasking run time, which is needed for setting the required + priority. + +2013-10-14 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Check_Interfaces): Put in Other_Interfaces all + non Ada interface files. + * prj.ads (Project_Data): New component Other_Interfaces. + +2013-10-14 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Makefile.in: Target pairs clean ups. + +2013-10-14 Vincent Celier <celier@adacore.com> + + * errout.adb (Write_Error_Summary): Do not output the number + of lines when Main_Source_File is unknown. + (Output_Messages): Do not write the header when Main_Source_File is + unknown. + +2013-10-14 Vincent Celier <celier@adacore.com> + + * prep.adb (Expression): Accept terms of the form 'symbol <relop> + integer", where relop is =, <, <=, > or >=. + (Parse_Def_File): Accept literal integer values. + * gcc-interface/Make-lang.in: Add s-valint.o, s-valuns.o and + s-valuti.o to the compiler object files. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * exp_prag.adb, exp_ch11.adb, s-exctab.adb: Minor reformatting. + * usage.adb: Add line for -gnateu switch. + +2013-10-14 Vincent Celier <celier@adacore.com> + + * lib-writ.ads: Add comments to indicate that a path name in + D lines may be quoted if the path name includes directories + with spaces. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * debug.adb: Document -gnatd.E. + * gnat1drv.adb (Adjust_Global_Switches): Set Error_To_Warning + if -gnatd.E set. + * opt.ads (Error_To_Warning): New switch. + * osint.adb: Minor reformatting. + * sem_warn.adb (Warn_On_Overlapping_Actuals): Overlap is error + in some cases in Ada 2012 mode (unless Error_To_Warning) is set. + * sem_warn.ads (Warn_On_Overlapping_Actuals): Document error + in Ada 2012 mode. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * cstand.adb: Add a comment for Standard_Exception_Type. + +2013-10-14 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Process_Transient_Object): If a transient scope + has already been created, use the corresponding Node_To_Be_Wrapped + as the insertion point for the controlled actions. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * cstand.adb (Create_Standard): Change Import_Code component + of Standard_Exception_Type to Foreign_Data. Its type is now + Standard_A_Char (access to character). + * exp_prag.adb (Expand_Pragma_Import_Export_Exception): Adjust + definition of Code to match the type of Foreign_Data. + * s-stalib.ads (Exception_Data): Replace Import_Code by Foreign_Data + Change the definition of standard predefined exceptions. + (Exception_Code): Remove. + * raise.h (Exception_Code): Remove (Exception_Data): Replace + Import_Code field by Foreign_Data. + * rtsfind.ads (RE_Exception_Code): Remove + (RE_Import_Address): Add. + * a-exexpr-gcc.adb (Import_Code_For): Replaced by Foreign_Data_For. + * exp_ch11.adb (Expand_N_Exception_Declaration): Associate null + to Foreign_Data component. + * raise-gcc.c (Import_Code_For): Replaced by Foreign_Data_For. + (is_handled_by): Add comments. Use replaced function. Change + condition so that an Ada occurrence is never handled by + Foreign_Exception. + * s-exctab.adb (Internal_Exception): Associate Null_Address to + Foreign_Data component. + * s-vmexta.adb, s-vmexta.ads (Exception_Code): Declare Replace + SSL.Exception_Code by Exception_Code. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: Document -gnateu switch. + * opt.ads (Ignore_Unrecognized_VWY_Switches): New switch. + * stylesw.adb: Ignore unrecognized switch if + Ignore_Unrecognized_VWY_Switches set. + * switch-c.adb: Implement -gnateu (sets + Ignore_Unrecognized_VWY_Switches). + * validsw.adb: Ignore unrecognized switch if + Ignore_Unrecognized_VWY_Switches set. + * warnsw.adb: Ignore unrecognized switch if + Ignore_Unrecognized_VWY_Switches set. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * exp_prag.adb, sem_prag.adb, a-exexda.adb, s-vmexta.ads: Minor + reformatting. + +2013-10-14 Vincent Celier <celier@adacore.com> + + * ali.adb (Get_File_Name): New Boolean parameter May_Be_Quoted, + defaulted to False. Calls Get_Name with May_Be_Quoted. + (Get_Name): New Boolean parameter May_Be_Quoted, defaulted to + False. If May_Be_Quoted is True and first non blank charater is + '"', unquote the name. + (Scan_ALI): For the file/path name on the D line, call Get_File_Name + with May_Be_Quoted = True, as it may have been quoted. + * lib-util.adb, lib-util.ads (Write_Info_Name_May_Be_Quoted): New + procedure to write file/path names that may contain spaces and if they + do are quoted. + * lib-writ.adb (Write_ALI): Use new procedure + Write_Info_Name_May_Be_Quoted to write file/path names on D lines. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Depends_In_Decl_Part, + Analyze_Global_In_Decl_Part, + Analyze_Pre_Post_Condition_In_Decl_Part): Install the subprogram + and its formals only when it is not already installed. + * sem_util.adb (Is_Refined_State): A state is refined when it + has a non-empty list of constituents. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * adaint.c: Disable __gnat_get_executable_load_address for linux. + * exp_prag.adb: Add comment in Expand_Pragma_Import_Export_Exception. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * s-vmexta.ads: Add comments. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Contract): Add processing + for pragma Refined_State. + * sem_ch13.adb (Analyze_Aspect_Specifications): Add processing + for aspect Refined_Depends. + * sem_prag.adb (Analyze_Contract_Cases_In_Decl_Part): + Use Find_Related_Subprogram_Or_Body to find the related + context. Use the current scope when determining whether to + ensure proper visibility. + (Analyze_Depends_In_Decl_Part): + Add local variable Spec_Id. Update the comment on usage of + Subp_Id. Use Find_Related_Subprogram_Or_Body to find the + related context. Extract the corresponding spec of the body + (if any). Use the current scope when determining when to + ensure proper visibility. + (Analyze_Global_In_Decl_Part): + Add local variable Spec_Id. Update the comment on usage of + Subp_Id. Use Find_Related_Subprogram_Or_Body to find the + related context. Extract the corresponding spec of the body + (if any). Use the current scope when determining when to + ensure proper visibility. + (Analyze_Global_Item): Use the + entity of the subprogram spec when performing formal parameter + checks. Perform state-related checks. + (Analyze_Input_Output): + Use Is_Attribute_Result to detect 'Result. Query the + entity of a subprogram spec when verifying the prefix of + 'Result. Perform state-related checks. (Analyze_Pragma): + Merge the analysis of Refined_Depends and Refined_Global. + (Analyze_Refined_Depends_In_Decl_Part): Provide implemenation. + (Analyze_Refined_Global_In_Decl_Part): Move state-related checks + to the body of Analyze_Global_In_Decl_Part. Rename local constant + List to Items. (Analyze_Refined_Pragma): Remove circuitry to + find the proper context, use Find_Related_Subprogram_Or_Body + instead. + (Check_Function_Return): Query the entity of + the subprogram spec when verifying the use of 'Result. + (Check_In_Out_States, Check_Input_States, Check_Output_States): + Avoid using Has_Null_Refinement to detect a state with + a non-null refinement, use the Refinement_Constituents + list instead. + (Check_Matching_Constituent): Remove initialization code. + (Check_Mode_Restriction_In_Function): Use the entity of the subprogram + spec when verifying mode usage in functions. + (Collect_Global_Items): New routine. + (Collect_Subprogram_Inputs_Outputs): Add local + variable Spec_Id. Add circuitry for bodies-as-specs. Use + pragma Refined_Global when collecting for a body. + (Create_Or_Modify_Clause): Use the location of the + clause. Rename local variable Clause to New_Clause to avoid + confusion and update all occurrences. Use Is_Attribute_Result + to detect 'Result. + (Find_Related_Subprogram): Removed. + (Find_Related_Subprogram_Or_Body): New routine. + (Is_Part_Of): Move routine to top level. + (Normalize_Clause): Update the + comment on usage. The routine can now normalize a clause with + multiple outputs by splitting it. + (Collect_Global_Items): + Rename local constant List to Items. Remove the check for + a null list. + (Requires_Profile_Installation): Removed. + (Split_Multiple_Outputs): New routine. + * sem_prag.ads: Update the comments on usage of various + pragma-related analysis routines. + * sem_util.adb (Contains_Refined_State): The routine can now + process pragma [Refined_]Depends. + (Has_Refined_State): Removed. + (Has_State_In_Dependency): New routine. + (Has_State_In_Global): New routine. + (Is_Attribute_Result): New routine. + * sem_util.ads (Is_Attribute_Result): New routine. + +2013-10-14 Emmanuel Briot <briot@adacore.com> + + * s-regpat.adb (Compile): Fix finalization of the automaton + when its size was automatically computed to be exactly 1000 bytes. + +2013-10-14 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Complete_Private_Subtype): If the full view of + the base type is constrained, the full view of the subtype is + known to be constrained as well. + +2013-10-14 Vincent Celier <celier@adacore.com> + + * projects.texi: Add documentation for new attributes of package + Clean: Artifacts_In_Object_Dir and Artifacts_In_Exec_Dir. + +2013-10-14 Tristan Gingold <gingold@adacore.com> + + * adaint.c, adaint.h (__gnat_get_executable_load_address): + New function. + * a-exexda.adb (Append_Info_Basic_Exception_Traceback): Add + executable load address (Basic_Exception_Tback_Maxlength): Adjust. + +2013-10-14 Vincent Celier <celier@adacore.com> + + * prj-attr.adb: New attributes in package Clean: + Artifacts_In_Exec_Dir, Artifacts_In_Object_Dir. + * prj-nmsc.adb (Process_Clean (Attributes)): New + procedure to process attributes Artifacts_In_Exec_Dir and + Artifacts_In_Object_Dir in package Clean. + * prj.ads (Project_Configuration): New components + Artifacts_In_Exec_Dir and Artifacts_In_Object_Dir. + * snames.ads-tmpl: New standard names Artifacts_In_Exec_Dir and + Artifacts_In_Object_Dir used only by gprclean. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Add error + entry for Library_Level attribute (which should not survive + to expansion) + * gnat_rm.texi: Document attribute Library_Level + * sem_attr.adb (Analyze_Attribute, case Library_Level): Implement + this new attribute (Set_Boolean_Result): Replaces Set_Result + (Check_Standard_Prefix): Document that Check_E0 is called + (Check_System_Prefix): New procedure + * snames.ads-tmpl: Add entry for Library_Level attribute + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * exp_ch6.adb, sinfo.ads: Minor reformatting. + * checks.adb (Overlap_Check): Use identifier casing in messages. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * einfo.ads, einfo.adb (Default_Aspect_Component_Value): Is on base type + only. + * exp_aggr.adb (Expand_Array_Aggregate): Handle proper + initialization of <> component. + * exp_ch3.adb, exp_tss.adb: Minor reformatting + * sem_ch13.adb (Default_Aspect_Component_Value, Default_Aspect_Value): + Is on base type only. + * sinfo.ads: Minor comment revision. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * g-decstr.adb (Decode_Wide_Wide_Character): Fix failure + to detect invalid sequences where longer than necessary + sequences are used for encoding. + (Validate_Wide_Character): + Call Decode_Wide_Character to get the above validations. + (Validate_Wide_Wide_Character): Same fix + * g-decstr.ads: Add documentation making it clear that the UTF-8 + implementation here recognizes all valid UTF-8 sequences, rather + than the well-formed subset corresponding to characters defined + in Unicode. + (Next_Wide_Character): Remove comment about this + being more efficient than Decode_Wide_Character (because this + no longer the case). + (Prev_Wide_Character): Add note that valid encoding is assumed. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * a-wichha.adb (Character_Set_Version): New function. + * a-wichha.ads: Remove comments for pragma Pure (final RM has + this). + (Character_Set_Version): New function. + * gnat_rm.texi: Update doc. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb: Flag263 is now known as Has_Null_Refinement. + (Has_Null_Refinement): New routine. + (Set_Has_Null_Refinement): New routine. + (Write_Entity_Flags): Output the status of flag + Has_Null_Refinement. + * einfo.ads: Add new flag Has_Null_Refinement along with + comment on usage and update all nodes subject to the flag. + (Has_Null_Refinement): New routine along with pragma Inline. + (Set_Has_Null_Refinement): New rouitine along with pragma Inline. + * sem_prag.adb (Analyze_Constituent): Mark a state as having + a null refinement when the sole constituent is "null". + (Analyze_Global_List): Handle null input/output items. + (Analyze_Refined_Global_In_Decl_Part): Add local variable + Has_Null_State. Add logic to handle combinations of states + with null refinements and null global lists and/or items. + (Check_In_Out_States, Check_Input_States, Check_Output_States): + Use attribute Has_Null_Refinement to detect states with + constituents. + (Check_Refined_Global_List): Handle null input/output items. + (Process_Global_Item): Handle states with null refinements. + (Process_Global_List): Handle null input/output items. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Freeze_Entity): Reset Is_True_Constant for + aliased object + * gnat_ugn.texi: Update doc on aliased variables and constants. + +2013-10-14 Ed Schonberg <schonberg@adacore.com> + + * exp_pakd.adb (Expand_Packed_Element_Reference): If the + reference is an actual in a call, the prefix has not been fully + expanded, to account for the additional expansion for parameter + passing. the prefix itself is a packed reference as well, + recurse to complete the transformation of the prefix. + +2013-10-14 Eric Botcazou <ebotcazou@adacore.com> + + * exp_dbug.adb (Debug_Renaming_Declaration): Do not + materialize the entity when the renamed object contains an + N_Explicit_Dereference. + * sem_ch8.adb (Analyze_Object_Renaming): + If the renaming comes from source and the renamed object is a + dereference, mark the prefix as needing debug information. + +2013-10-14 Doug Rupp <rupp@adacore.com> + + * system-vxworks-arm.ads (Stack_Check_Probes, Stack_Check_Limits): + Enable Stack Probes, Disable Stack Limit Checking. + * init.c [VxWorks] (__gnat_inum_to_ivec): Caste return value. + (__gnat_map_signal): Fix signature. + (__gnat_error_handler): Make + static, fix signature, remove prototype, fix prototype warning. + [ARMEL and VxWorks6] (__gnat_map_signal): Check and re-arm guard + page for storage_error. + * exp_pakd.adb: Minor reformatting. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Global_In_Decl_Part): Remove local + variable Contract_Seen. Add local variable Proof_Seen. + (Analyze_Global_List): Remove the processing for mode + Contract_In. Add support for mode Proof_In. + (Analyze_Pragma): Update the grammar of pragmas Global and + Refined_Global. + * snames.ads-tmpl: Remove predefined name Contract_In. Add + predefined name Proof_In. + +2013-10-14 Robert Dewar <dewar@adacore.com> + + * exp_prag.adb (Expand_Pragma_Check): Generate proper string + for invariant + * gnat_rm.texi: Add documentation for pragmas + Type_Invariant[_Class] + * par-prag.adb: Add entries for pragmas Type_Invariant[_Class] + * sem_ch13.adb: Minor reformatting + * sem_prag.adb: Implement pragmas Type_Invariant[_Class] + * snames.ads-tmpl: Add entries for pragmas Type_Invariant[_Class] + +2013-10-14 Johannes Kanig <kanig@adacore.com> + + * debug.adb: Release now unused debug switches that were only + relevant for gnat2why backend, not the frontend + * frontend.adb (Frontend) Do not stop when -gnatd.H is present, + was unused + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Global_Item): Allow + references to enclosing formal parameters. + +2013-10-14 Thomas Quinot <quinot@adacore.com> + + * einfo.adb (Equivalent_Type): Add missing case + E_Access_Subprogram_Type in guard (for remote access to + subprograms) * sem_ch8.adb (Find_Direct_Name, Find_Expanded_Name): + Add missing guards to account for the presence of RAS types + that have already been replaced with the corresponding fat + pointer type. + +2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb: Add an entry in table Canonical_Aspect for + Initializes. + * aspects.ads: Add entries in tables Aspect_Id, Aspect_Argument, + Aspect_Names and Aspect_Delay for Initializes. + * atree.ads, atree.adb (Ekind_In): New seven argument versions of the + routines. + * einfo.adb: Remove Refined_State_Pragma from the list of node + usage. Finalizer is now at position 28. + (Contract): Package + and package bodies now have a contract. + (Finalizer): Update + the assertion and node usage. + (Get_Pragma): Update the Is_CDG + flag to include Abstract_State, Initializes and Refined_State. + (Refined_State_Pragma): Removed. + (Set_Contract): Package and + package bodies now have a contract. + (Set_Finalizer): Update the + assertion and node usage. + (Set_Refined_State_Pragma): Removed. + (Write_Field8_Name): Remove the output for Refined_State_Pragma. + (Write_Field24_Name): Remove the output for Finalizer. Package + and package bodies now have a contract. + (Write_Field28_Name): + Add output for Finalizer. + * einfo.ads: Update the documentation and usage in entities + of attribute Contract. Update the node position and usage in + entities of attribute Finalizer. Remove the documentation + and usage in entities for attribute Refined_State_Pragma. + (Refined_State_Pragma): Removed along with pragma Inline. + (Set_Refined_State_Pragma): Removed along with pragma Inline. + * par-prag.adb: Add Initializes to the pragmas that do not + require special processing by the parser. + * sem_ch3.adb (Analyze_Declarations): Add local variable + Prag. Update the retrieval of pragma Refined_State. Analyze + aspect/pragma Initializes at the end of the visible declarations + of the related package. + * sem_ch6.adb (Analyze_Subprogram_Body_Contract): + Add local variables Ref_Depends and Ref_Global. Analyze + pragmas Refined_Global and Refined_Depends in that order. + (Analyze_Subprogram_Contract): Add local variables Depends and + Global. Analyze pragmas Global and Depends in that order. + * sem_ch7.adb (Analyze_Package_Body_Helper): Package + bodies now have a contract. Move the analysis of the aspect + specifications after the defining entity has been decorated. + (Analyze_Package_Declaration): Packages now have a contract. Move + the analysis of the aspect specifications after the defining + entity has been decorated. + * sem_ch12.adb (Analyze_Generic_Package_Declaration): Packages + now have contracts. + * sem_ch13.adb (Analyze_Pragma): Code cleanup for aspect + Abstract_State. Add processing for aspect Initializes. + (Check_Aspect_At_Freeze_Point): Add an entry for Initializes. + * sem_prag.adb: Use Get_Pragma_Arg to extract the expression + of a pragma argument. Add an entry in table Sig_Flags for + Initializes. + (Analyze_Initializes_In_Decl_Part): New routine. + (Analyze_Pragma): Check the declaration order of pragmas + Abstract_State and Initializes. Abstract_State is now part of + the package contract. Analyze pragma Initializes. Check for + duplicate Refined_State pragma. Refined_State is now part of + the package contract. + (Check_Declaration_Order): New routine. + (Check_Test_Case): Alphabetized. + * sem_prag.ads (Analyze_Initializes_In_Decl_Part): New routine. + * sem_util.adb (Add_Contract_Item): Rename formal Subp_Id + to Id. This routine can now support contracts on packages and + package bodies. + * sem_util.ads (Add_Contract_Item): Rename formal Subp_Id to + Id. Update comment on usage. + * sinfo.ads: Update the usage of N_Contract nodes. + * snames.ads-tmpl: Add predefined name Initializes. Add new + pragma id for Initializes. + +2013-10-13 Nicolas Roche <roche@adacore.com> + Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/Make-lang.in (ada/%.o): Replace individual rules with + generic rule and add $(POSTCOMPILE). + (ADA_DEPS): New. + (.adb.o): Add @$(ADA_DEPS). + (.ads.o): Likewise. + (ada/a-except.o): Likewise. + (ada/s-excdeb.): Likewise. + (ada/s-assert.o): Likewise. + (ada/a-tags.o): Likewise. + (ada_generated_files): New variable. + Use them as dependency order for GNAT1_ADA_OBJS and GNATBIND_OBJS. + (ADA_DEPFILES): New variable. + Include them. + (ada_OBJS): Define. + +2013-10-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <object>: Force all local + variables with aggregate types in memory if not optimizing. + +2013-10-13 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Check_Mode): Do + not emit an error when we are looking at inputs and + the item is an unconstrained or tagged out parameter. + (Check_Mode_Restriction_In_Enclosing_Context): Use Get_Pragma + to find whether the context is subject to aspect/pragma Global. + (Collect_Subprogram_Inputs_Outputs): Unconstrained or tagged + out parameters are now considered inputs. Use Get_Pragma to + find wheher the subprogram is subject to aspect/pragma Global. + (Is_Unconstrained_Or_Tagged_Item): New routine. + +2013-10-13 Thomas Quinot <quinot@adacore.com> + + * einfo.ads: Minor reformatting. + * gcc-interface/Make-lang.in: Update dependencies. + +2013-10-13 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Add documentation for pragmas Pre[_Class] + Post[_Class]. + * par-ch2.adb (Skip_Pragma_Semicolon): Handle extra semicolon nicely. + * par-prag.adb: Add entries for pragmas Pre[_Class] and + Post[_Class]. + * sem_prag.adb: Add handling of pragmas Pre[_Class] and + Post[_Class]. + * sem_util.adb (Original_Aspect_Name): Moved here from + Sem_Prag.Original_Name, and modified to handle pragmas + Pre/Post/Pre_Class/Post_Class. + * sem_util.ads (Original_Aspect_Name): Moved here from + Sem_Prag.Original_Name. + * snames.ads-tmpl: Add entries for pragmas Pre[_Class] and + Post[_Class]. + +2013-10-13 Robert Dewar <dewar@adacore.com> + + * einfo.adb, sem_ch6.adb: Minor reformatting. + +2013-10-13 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb: Add node/list usage for Refined_State + and Refinement_Constituents. + (Get_Pragma): Update the + initialization of Is_CDG to include Refined_Global and + Refined_Depends. Rename constant Delayed to In_Contract and update + all of its occurrences. + (Is_Non_Volatile_State): New routine. + (Is_Volatile_State): Removed. + (Refined_State): New routine. + (Refinement_Constituents): New routine. + (Set_Refined_State): New routine. + (Set_Refinement_Constituents): New routine. + (Write_Field8_Name): Add output for Refinement_Constituents. + (Write_Field10_Name): Add output for Refined_State. + * einfo.ads: Add new synthesized attribute Is_Non_Volatile_State. + Remove synthesized attribute Is_Volatile_State. Add new + attributes Refined_State and Refinement_Constituents along with + usage in nodes. + (Get_Pragma): Update the comment on usage. + (Is_Non_Volatile_State): New routine. + (Is_Volatile_State): Removed. + (Refined_State): New routine and pragma Inline. + (Refinement_Constituents): New routine and pragma Inline. + (Set_Refined_State): New routine and pragma Inline. + (Set_Refinement_Constituents): New routine and pragma Inline. + * elists.ads, elists.adb (Clone): Removed. + (New_Copy_Elist): New routine. + (Remove): New routine. + * sem_ch3.adb (Analyze_Declarations): Use Defining_Entity + to get the entity of the subprogram [body]. + (Analyze_Object_Declaration): Add initialization for + Refined_State. + * sem_ch6.adb (Analyze_Subprogram_Body_Contract): Add processing + for Refined_Global and Refined_Depends. Emit an error when + the body requires Refined_Global, but the aspect/pragma is + not present. + * sem_ch6.ads (Analyze_Subprogram_Body_Contract): Change + procedure signature and add comment on usage. + * sem_ch13.adb (Analyze_Aspect_Specifications): Add processing + for aspect Refined_Global. + * sem_prag.adb (Analyze_Abstract_State): Add initialization + of attributes Refined_State and Refinement_Constituents. + (Analyze_Depends_In_Decl_Part, Analyze_Global_In_Decl_Part, + Analyze_Contract_Cases_In_Decl_Part): Remove local + constant Arg1. + (Analyze_Pragma): Add processing for pragma + Refined_Global. The analysis of Refined_Post and Refined_Pre + has been merged. Update an error message in the processing of + pragma Refined_State. + (Analyze_Refined_Global_In_Decl_Part): Provide implementation. + (Analyze_Refined_Pragma): New routine. + (Analyze_Refined_Pre_Post_Condition): Removed. + (Analyze_Refined_State_In_Decl_Part): Update the call to Clone. + (Analyze_Refinement_Clause): Make State_Id visible to all + nested subprogram. + (Check_Matching_Constituent): Establish + a relation between a refined state and its constituent. + (Collect_Hidden_States_In_Decls): Remove ??? comment. Look at + the entity of the object declaration to establish its kind. + * sem_util.adb: Alphabetize with and use clauses. + (Contains_Refined_State): New routine. + * sem_util.ads (Contains_Refined_State): New routine. + +2013-10-13 Thomas Quinot <quinot@adacore.com> + + * scos.ads: Minor documentation clarification. + +2013-10-13 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c (CLOCK_RT_Ada): Set to CLOCK_MONOTONIC when + building on AIX 5.3 or later, and to CLOCK_REALTIME on older + versions of AIX. + * init.c (pthread_condattr_setclock): Remove now useless weak symbol. + * thread.c(__gnat_pthread_condattr_setup): Remove bogus AIX 5.2 + compatibility shim. + * s-osinte-aix.ads(clock_id_t): Fix C mapping (this is a 64-bit + type). + (clock_gettime): Import from C runtime library. + * s-osinte-aix.adb (clock_gettime): Remove bogus emulation body, + this routine is provided by the system in current supported + versions of AIX. + +2013-10-13 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb: Minor reformatting. + +2013-10-13 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_Entity): For a function whose return type + is incomplete, do not replace the type with the full view if the + type is a limited view. In that case the full view appears in a + different unit, and the back-end will retrieve it at the proper + elaboration point. + +2013-10-13 Yannick Moy <moy@adacore.com> + + * exp_spark.adb (Expand_SPARK_Call): Do not introduce temporaries for + actuals. + +2013-10-13 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb: in Ada 2012 access_to_function types can have + in-out parameters. + (Derived_Type_Declaration): SPARK restriction + must be flagged on the original node, since it may have been + written as a subtype declaration. + (Analyze_Subtype_Declaration): Do not enter name of + entity in declaration if it is the current entity, because it may + have been inserted in a previous analysis and it appears in the + else_part of an if-statement that is rewritten during expansion. + +2013-10-13 Yannick Moy <moy@adacore.com> + + * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Remove procedure. + (Expand_SPARK): Remove call to Expand_SPARK_N_Attribute_Reference and + Expand_SPARK_N_Simple_Return_Statement. + (Expand_SPARK_N_Simple_Return_Statement, + Expand_SPARK_Simple_Function_Return): Remove procedures. + +2013-10-13 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Minor editing. + +2013-10-13 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Check_Abstract_Overriding): If a synchronized + operation implements an interface primitive, mark the operation + as referenced, to prevent usually spurious messages about unused + entities: such operations are called in dispatching select + statements that are not visible to the compiler. + +2013-10-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_param): Remove obsolete comment. + +2013-10-11 Jakub Jelinek <jakub@redhat.com> + + * gcc-interface/utils.c (DEF_FUNCTION_TYPE_8): Define. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * par-ch6.adb (Check_Junk_Semicolon_Before_Return): Remove + junk code. + +2013-10-10 Javier Miranda <miranda@adacore.com> + + * sem_ch13.adb (Freeze_Entity_Checks): Avoid + loosing errors on CPP entities in -gnatc mode. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_ch5.adb (Analyze_If_Statement): Only diagnose redundant + if from source. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * restrict.adb (Check_SPARK_Restriction): Refine test (don't + automatically go to the original node). + * sem_ch11.adb (Analyze_Raise_Statement): Only raise + statements that come from source violate SPARK restrictions. + (Analyze_Raise_xxx_Error): Same fix. + * sem_ch3.adb (Analyze_Object_Declaration): Check OK SPARK + initialization on original node, not on possibly rewritten + expression. + * sem_ch4.adb (Analyze_If_Expression): Only if expressions that + come from source violate SPARK mode restrictions. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: Fix confusing documentation for -gnatyM. + +2013-10-10 Yannick Moy <moy@adacore.com> + + * errout.adb (Compilation_Errors): In formal verification mode, + always return False. + +2013-10-10 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Collect_Hidden_States_In_Decls): Only consider source + non-constant objects. + +2013-10-10 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb: Add an entry in table Canonical_Aspect for + Refined_State. + * aspects.ads: Add entries in tables Aspect_Id, Aspect_Argument, + Aspect_Names and Aspect_Delay for Refined_State. + * einfo.adb: Add with and use clauses for Elists. + Remove Refined_State from the list of node usage. + Add Refined_State_Pragma to the list of node usage. + (Has_Null_Abstract_State): New routine. + (Refined_State): Removed. + (Refined_State_Pragma): New routine. + (Set_Refined_State): Removed. + (Set_Refined_State_Pragma): New routine. + (Write_Field8_Name): Add output for Refined_State_Pragma. + (Write_Field9_Name): Remove the output for Refined_State. + * einfo.ads: Add new synthesized attribute Has_Null_Abstract_State + along with usage in nodes. Remove attribute Refined_State along + with usage in nodes. Add new attribute Refined_State_Pragma along + with usage in nodes. + (Has_Null_Abstract_State): New routine. + (Refined_State): Removed. + (Refined_State_Pragma): New routine. + (Set_Refined_State): Removed. + (Set_Refined_State_Pragma): New routine. + * elists.adb (Clone): New routine. + * elists.ads (Clone): New routine. + * par-prag.adb: Add Refined_State to the pragmas that do not + require special processing by the parser. + * sem_ch3.adb: Add with and use clause for Sem_Prag. + (Analyze_Declarations): Add local variables Body_Id, Context and + Spec_Id. Add processing for delayed aspect/pragma Refined_State. + * sem_ch13.adb (Analyze_Aspect_Specifications): Update the + handling of aspect Abstract_State. Add processing for aspect + Refined_State. Remove the bizzare insertion policy for aspect + Abstract_State. + (Check_Aspect_At_Freeze_Point): Add an entry for Refined_State. + * sem_prag.adb: Add an entry to table Sig_Flags + for pragma Refined_State. + (Add_Item): Update the + comment on usage. The inserted items need not be unique. + (Analyze_Contract_Cases_In_Decl_Part): Rename variable Restore to + Restore_Scope and update all its occurrences. + (Analyze_Pragma): + Update the handling of pragma Abstract_State. Add processing for + pragma Refined_State. + (Analyze_Pre_Post_Condition_In_Decl_Part): + Rename variable Restore to Restore_Scope and update all its + occurrences. + (Analyze_Refined_State_In_Decl_Part): New routine. + * sem_prag.ads (Analyze_Refined_State_In_Decl_Part): New routine. + * snames.ads-tmpl: Add new predefined name for Refined_State. Add + new Pragma_Id for Refined_State. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch10.adb (Install_Limited_Withed_Unit): handle properly the + case of a record declaration in a limited view, when the record + contains a self-referential component of an anonymous access type. + +2013-10-10 Thomas Quinot <quinot@adacore.com> + + * exp_ch4.adb (Process_Transient_Object): For any context other + than a simple return statement, insert the finalization action + after the context, not as an action on the context (which will + get evaluated before it). + +2013-10-10 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb (Write_Field19_Name): Correct the + string name of attribute Default_Aspect_Value. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sem_type.adb (Interface_Present_In_Ancestor): The progenitor + in a type declaration may be an interface subtype. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sinfo.ads (Do_Range_Check): Add special note on handling of + range checks for Succ and Pred. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * erroutc.adb (Output_Msg_Text): Remove VMS special handling. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * a-chahan.ads, a-chahan.adb (Is_Line_Terminator): New function + (Is_Mark): New function. + (Is_Other_Format): New function. + (Is_Punctuation_Connector): New function. + (Is_Space): New function. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_aggr.adb (Resolve_Array_Aggregate): Redo duplicate/missing + choice circuit. Was not quite right in some cases, which showed + up in ACATS test B43201C. + * sem_attr.adb (Address_Checks): Make sure name is set right + for some messages issued. + * mlib-prj.adb: Minor code reorganization. + * gnat_ugn.texi: Remove special VMS doc for tagging of warning msgs. + * exp_ch9.adb: Minor reformatting. + +2013-10-10 Tristan Gingold <gingold@adacore.com> + + * lib-writ.adb (Write_Unit_Information): Adjust previous patch. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_ch5.adb (Analyze_If_Statement): Warn on redundant if + statement. + * sem_util.ads, sem_util.adb (Has_No_Obvious_Side_Effects): New + function. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * exp_ch9.adb (Expand_N_Timed_Entry_Call): Simplify expansion + for the case of a dispatching trigger: there is no need to + duplicate the code or create a subprogram to encapsulate the + triggering statements. This allows exit statements in the + triggering statements, that refer to enclosing loops. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * freeze.adb: Minor reformatting. + * sem_ch13.adb (Freeze_Entity_Checks): New procedure + (Analyze_Freeze_Entity): Call Freeze_Entity_Checks + (Analyze_Freeze_Generic_Entity): Call Freeze_Entity_Checks. + * sinfo.ads: Add syntax for sprint for Freeze_Generic_Entity. + * sprint.ads: Add syntax for freeze generic entity node. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * einfo.adb, einfo.ads: Minor comment updates. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * lib-writ.adb (Write_Unit_Information): Fatal error if linker + options are detected in a predefined generic unit. + +2013-10-10 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c (CLOCK_REALTIME): Always define, possibly using + a dummy placeholder value. + (NEED_PTHREAD_CONDATTR_SETCLOCK): Remove, not needed anymore. + * thread.c: Adjust #if test accordingly. + +2013-10-10 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb (Consequence_Error): Generate an + implicit if statement. + (Expand_Contract_Cases): Generate an implicit if statement. + (Process_Contract_Cases): Do not expand Contract_Cases when no code + is being generated. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_attr.adb (Address_Checks): New procedure. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sinfo.ads, sinfo.adb: New Node Freeze_Generic_Entity, to trigger + semantic actions at the proper point for entities that previously + had no explicit freeze point. + * freeze.adb (Freeze_Generic_Entities): generate new nodes to + indicate the point at which semantic checks can be performed on + entities declared in generic packages. + * sem_ch13.ads, sem_ch13.adb: New procedure + Analyze_Freeze_Generic_Entity. + * exp_util.adb (Insert_Actions): Treat new node like Freeze_Entity. + * sem.adb (Analyze): Call Analyze_Freeze_Generic_Entity. + * sprint.adb (Sprint_Node): display Analyze_Freeze_Generic_Entity. + * gcc-interface/trans.c: Ignore Analyze_Freeze_Generic_Entity. + * gcc-interface/Make-lang.in: Update dependencies. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_aggr.adb (Resolve_Array_Aggregate): Identify duplicated + cases. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_ch9.adb (Analyze_Task_Body): Aspects are illegal + (Analyze_Protected_Body): Aspects are illegal. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb, sem_ch13.adb: Minor reformatting. + * sem_case.adb (Check_Choices): Fix bad listing of missing + values from predicated subtype case (Check_Choices): List + duplicated values. + * errout.adb (Set_Msg_Text): Process warning tags in VMS mode + * erroutc.adb (Output_Msg_Text): Handle VMS warning tags + * gnat_ugn.texi: Document /WARNINGS=TAG_WARNINGS for VMS + * ug_words: Add entries for -gnatw.d and -gnatw.D + * vms_data.ads: Add [NO]TAG_WARNINGS for -gnatw.D/-gnatw.d + * lib-writ.ads: Documentation fixes + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * a-wichha.adb, a-wichha.ads, a-zchhan.adb, a-zchhan.ads + (Is_Other_Format): New name for Is_Other. + (Is_Punctuation_Connector): New name for Is_Punctuation + +2013-10-10 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb: Add entries in table Canonical_Aspects for aspects + Refined_Depends and Refined_Global. + * aspects.ads: Add entries in tables Aspect_Id, Aspect_Argument, + Aspect_Names, Aspect_Declay, Aspect_On_Body_Or_Stub_OK for + aspects Refined_Depends and Refined_Global. + * einfo.adb (Contract): Subprogram bodies are now valid owners + of contracts. + (Set_Contract): Subprogram bodies are now valid + owners of contracts. + (Write_Field24_Name): Output the contract + attribute for subprogram bodies. + * exp_ch6.adb (Expand_Subprogram_Contract): New routine. + * exp_ch6.ads (Expand_Subprogram_Contract): New routine. + * par-prag.adb: Pragmas Refined_Depends and Refined_Global do + not require any special processing by the parser. + * sem_ch3.adb (Adjust_D): Renamed to Adjust_Decl. + (Analyze_Declarations): Code reformatting. Analyze the contract + of a subprogram body at the end of the declarative region. + * sem_ch6.adb (Analyze_Generic_Subprogram_Body): + Subprogram bodies can now have contracts. Use + Expand_Subprogram_Contract to handle the various contract + assertions. + (Analyze_Subprogram_Body_Contract): New null routine. + (Analyze_Subprogram_Body_Helper): Subprogram bodies can now have + contracts. Use Expand_Subprogram_Contract to handle the various + contract assertions. + (Analyze_Subprogram_Contract): Add local + variable Nam. Update the call to Analyze_PPC_In_Decl_Part. Capture + the pragma name in Nam. + (Process_PPCs): Removed. + * sem_ch6.ads (Analyze_Subprogram_Body_Contract): New routine. + (Analyze_Subprogram_Contract): Update the comment on usage. + * sem_ch13.adb (Analyze_Aspect_Specifications): Add null + implementations for aspects Refined_Depends and Refined_Global. + (Check_Aspect_At_Freeze_Point): Aspects Refined_Depends and + Refined_Global do not need to be checked at the freeze point. + * sem_prag.adb: Add entries in table Sig_Flags + for pragmas Refined_Depends and Refined_Global. + (Analyze_Contract_Cases_In_Decl_Part): Add local + variable Restore. Use Restore to pop the scope. + (Analyze_Depends_In_Decl_Part): Add local variable Restore. Use + Restore to pop the scope. + (Analyze_Global_In_Decl_List): Add local variable Restore. Use Restore + to pop the scope. + (Analyze_PPC_In_Decl_Part): Renamed to + Analyze_Pre_Post_Condition_In_Decl_Part. + (Analyze_Pragma): + Add null implementations for pragmas Refined_Depends and + Refined_Global. Refined_Pre and Refined_Post are now + handled by routine Analyze_Refined_Pre_Post_Condition + exclusively. + (Analyze_Refined_Depends_In_Decl_Part): New + null routine. + (Analyze_Refined_Global_In_Decl_Part): + New null routine. + (Analyze_Refined_Pre_Post): + Renamed to Analyze_Refined_Pre_Post_Condition. + (Analyze_Refined_Pre_Post_Condition): Analyze the boolean + expression. + (Check_Precondition_Postcondition): Update the call + to Analyze_PPC_In_Decl_Part. + * sem_prag.ads: Add entries in table + Pragma_On_Body_Or_Stub_OK for pragmas Refined_Depends + and Refined_Global. + (Analyze_PPC_In_Decl_Part): Renamed + to Analyze_Pre_Post_Condition_In_Decl_Part. Update the + comment on usage. + (Analyze_Refined_Depends_In_Decl_Part): New routine. + (Analyze_Refined_Global_In_Decl_Part): New routine. + (Analyze_Test_Case_In_Decl_Part): Update the comment on usage. + * sem_util.adb (Add_Contract_Item): Rename formal Item to Prag + and update all occurrences. Subprogram body contracts can now + contain pragmas Refined_Depends and Refined_Global. + * sem_util.ads (Add_Contract_Item): Rename formal Item to + Prag. Update the comment on usage. + * sinfo.ads: Update the comment on structure and usage of + N_Contract. + * snames.ads-tmpl: Add new predefined names for Refined_Depends + and Refined_Global. Add entries in table Pragma_Id for + Refined_Depends and Refined_Global. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * types.ads: Minor reformatting. + +2013-10-10 Thomas Quinot <quinot@adacore.com> + + * s-taprop-posix.adb: Add missing comment. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Freeze_Record_Type): Move choice checking to + Analyze_Freeze_Entity (Freeze_Record_Type): Make sure all choices + are properly frozen + * sem_case.adb (Check_Choices): Remove misguided attempt to + freeze choices (this is now done in Freeze_Record_Type where + it belongs). + (Check_Choices): Remove some analyze/resolve calls + that are redundant since they are done in Analyze_Choices. + * sem_ch13.adb (Analyze_Freeze_Entity): Do the error + checking for choices in variant records here (moved here from + Freeze.Freeze_Record_Type) + +2013-10-10 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c, s-taprop-posix.adb (CLOCK_REALTIME): Always define, + possibly using a dummy placeholder value. + (Compute_Deadline): For the case of an + Absolute_Calendar deadline, if the target uses another clock + than CLOCK_REALTIME as CLOCK_RT_Ada, compensate for possible + different epoch. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Find_Expanded_Name): Handle properly a fully + qualified reference to a generic child unit within itself, + in an instantiation. + +2013-10-10 Pascal Obry <obry@adacore.com> + + * prj-conf.adb: Minor typo fixes in comment. + +2013-10-10 Thomas Quinot <quinot@adacore.com> + + * s-taprop-posix.adb (Compute_Deadline): New local subprogram, + factors common code between Timed_Sleep and Timed_Delay. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Freeze_Record_Type): Don't replace others if + expander inactive. This avoids clobbering the ASIS tree in + -gnatct mode. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_res.adb (Resolve_Op_Expon): Avoid crash testing for + fixed-point case in preanalysis mode (error will be caught during + full analysis). + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Refined_Pre and Refined_Post are now allowed as + assertion identifiers for pragma Assertion_Policy. + * sem_prag.adb (Is_Valid_Assertion_Kind): Add Refined_Pre/Refined_Post + * sem_ch13.adb: Minor reformatting. + +2013-10-10 Pascal Obry <obry@adacore.com> + + * prj-conf.adb: Code refactoring. + +2013-10-10 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb: Remove Integrity_Level from the node usage list. + (Has_Option): Update the implementation to match + the new terminology. + (Has_Property): Renamed to Has_Option. + (Integrity_Level): Removed. + (Is_External_State): New routine. + (Is_Input_Only_State): Use Has_Option to determine whether a state + is Input_Only. (Is_Input_State): Renamed to Is_Input_Only_State. + (Is_Output_Only_State): Use Has_Option to determine whether + a state is Output_Only. + (Is_Output_State): Renamed to + Is_Output_Only_State. + (Is_Volatile_State): Use Has_Option to determine whether a state is + volatile. + (Set_Integrity_Level): Removed. + (Write_Field8): Remove the entry for Integrity_Level. + * einfo.ads: Remove Integrity_Level along with its documentation + and usage in nodes. Rename Is_Input_State to Is_Input_Only_State. + Rename Is_Output_State to Is_Output_Only_State. Update the + documentation of Is_Volatile_State. Update the node structure of + E_Abstract_Entity. + (Integrity_Level): Removed along with pragma Inline. + (Is_External_State): New routine. + (Is_Input_State): Renamed to Is_Input_Only_State. + (Is_Output_State): Renamed to Is_Output_Only_State. + (Set_Integrity_Level): Removed along with pragma Inline. + * sem_prag.adb (Analyze_Pragma): Update the checks regarding + global items and abstract state modes. Update the implementation + of pragma Abstract_State to reflect the new rules and terminology. + * snames.ads-tmpl: Remove the predefined name for Integrity + level. Add new predefined names for Input_Only, Non_Volatile, + Output_Only and Part_Of. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * lib-xref.adb (Generate_Reference): Do not generate a reference + within a _postcondition procedure: a proper source reference has + already been generated when pre- analyzing the original aspect + specification, and the use of a formal in a pre/postcondition + should not count as a proper use in a subprogram body. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_eval.adb (Why_Non_Static): Fix bomb for deferred constant + case + +2013-10-10 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb: Add an entry for Aspect_Refined_Post in table + Canonical_Aspect. + * aspects.ads: Add an entry for Aspect_Refined_Post in tables + Aspect_Id, Aspect_Argument, Aspect_Names, Aspect_Delay, + Aspect_On_Body_Or_Stub_OK. Update the comment on the use of + table Aspect_On_Body_Or_Stub_OK. + * par-prag.adb: Add pragma Refined_Post to the list of pragmas + that do not require special processing by the parser. + * sem_attr.adb (Analyze_Attribute): Add special analysis for + attributes 'Old and 'Result when code generation is disabled and + they appear in aspect/pragma Refined_Post. + (In_Refined_Post): New routine. + * sem_ch6.adb (Analyze_Expression_Function): Move various + aspects and/or pragmas that apply to an expression function to the + corresponding spec or body. + (Collect_Body_Postconditions): New routine. + (Process_PPCs): Use routine Collect_Body_Postconditions + to gather all postcondition pragmas. + * sem_ch10.adb (Analyze_Proper_Body): Use routine + Relocate_Pragmas_To_Body to move all source pragmas that follow + a body stub to the proper body. + (Move_Stub_Pragmas_To_Body): Removed. + * sem_ch13.adb (Analyze_Aspect_Specifications): Add processing + for aspect Refined_Post. + (Check_Aspect_At_Freeze_Point): Aspect + Refined_Post does not need delayed processing at the freeze point. + * sem_prag.adb: Add an entry for pragma Refined_Post in + table Sig_Flags. + (Analyze_Pragma): Add processing for pragma + Refined_Post. Update the processing of pragma Refined_Pre + to use common routine Analyze_Refined_Pre_Post. + (Analyze_Refined_Pre_Post): New routine. + (Relocate_Pragmas_To_Body): New routine. + * sem_prag.ads: Table Pragma_On_Stub_OK is now known as + Pragma_On_Body_Or_Stub_OK. Update the comment on usage of + table Pragma_On_Body_Or_Stub_OK. + (Relocate_Pragmas_To_Body): New routine. + * snames.ads-tmpl: Add new predefined name for Refined_Post. Add + new Pragma_Id for Refined_Post. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * exp_ch3.adb (Expand_N_Variant_Part): Now null, expansion of + last choice to others is moved to Freeze_Record_Type. + * freeze.adb (Freeze_Record_Type): Expand last variant to others + if necessary (moved here from Expand_N_Variant_Part + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * lib-xref-spark_specific.adb, par-ch13.adb, sem_prag.adb, sem_prag.ads, + sem_ch12.adb, sem_attr.adb, sem_ch6.adb, sem_ch13.adb, a-sequio.adb, + s-atocou-builtin.adb: Minor reformatting. + +2013-10-10 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c (NEED_PTHREAD_CONDATTR_SETCLOCK): This + constant needs to be output to s-oscons.h, as it is tested + by init.c. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * exp_ch3.adb (Expand_N_Variant_Part): Don't expand choices, too early + * exp_ch5.adb (Expand_N_Case_Statement): Use new Has_SP_Choice + flag to avoid expanding choices when not necessary. + * exp_util.adb: Minor reformatting + * freeze.adb (Freeze_Record_Type): Redo expansion of variants + * sem_aggr.adb: Minor reformatting + * sem_case.ads, sem_case.adb: Major rewrite, separating Analysis and + Checking of choices. + * sem_ch3.adb (Analyze_Variant_Part): Rewrite to call new + Analyze_Choices. + * sem_ch4.adb (Analyze_Case_Expression): Call Analyze_Choices + and Check_Choices + * sem_ch5.adb (Analyze_Case_Statement): Call Analyze_Choices + and Check_Choices + * sem_util.adb: Minor reformatting + * sinfo.ads, sinfo.adb (Has_SP_Choice): New flag. + +2013-10-10 Vincent Celier <celier@adacore.com> + + * mlib-prj.adb (Build_Library): Do not issue link dynamic + libraries with an Rpath, if switch -R was used. + +2013-10-10 Tristan Gingold <gingold@adacore.com> + + * s-stalib.ads (Image_Index_Table_8, Image_Index_Table_16, + Image_Index_Table_32): Remove as not used. + * s-imgint.adb (Image_Integer): Call Set_Image_Integer and + remove duplicated code. + +2013-10-10 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Provide a + more precise error message when pragma Refined_Pre applies to + an expression function that is not a completion. + +2013-10-10 Thomas Quinot <quinot@adacore.com> + + * sem_attr.adb (Analyse_Attribute, case + Attribute_Scalar_Storage_Order): a 'Scalar_Storage_Order attribute + reference for a generic type is permitted in GNAT runtime mode. + * a-sequio.adb (Read, Write): Use the endianness of the actual + type to encode length information written to the file. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * par-ch13.adb (Aspect_Specifications_Present)): In earlier than + Ada2012 mode, assume that a legal aspect name following "with" + keyword is an older gnat switch and not a misplaced with_clause. + +2013-10-10 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb: Add an entry for Aspect_Refined_Pre in + table Canonical_Aspect. + (Aspects_On_Body_OK): Renamed to + Aspects_On_Body_Or_Stub_OK. + (Aspects_On_Body_Or_Stub_OK): + Update the query in table Aspect_On_Body_OK. + * aspects.ads: Add an entry for Aspect_Refined_Pre in tables + Aspect_Id, Aspect_Argument, Aspect_Names, Aspect_Delay, + Aspect_On_Body_Or_Stub_OK. Table Aspect_On_Body_OK is now known as + Aspect_On_Body_Or_Stub_OK. Add a section of aspect specifications + that apply to body stubs. + (Aspects_On_Body_OK): Renamed to Aspects_On_Body_Or_Stub_OK. + (Aspects_On_Body_Or_Stub_OK): Update the comment on usage. + * par-prag.adb: Add pragma Refined_Pre to the list of pragmas + that do not require special processing by the parser. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Delay the + analysis of aspect specifications that apply to a body stub + until the proper body is analyzed. + * sem_ch10.adb: Add with and use clause for Sem_Ch13. + (Analyze_Package_Body_Stub): Set the corresponding spec of the stub. + (Analyze_Proper_Body): Relocate all pragmas that apply + to a subprogram body stub to the declarations of the proper + body. Analyze the aspect specifications of the stub when the + proper body is not present. + (Analyze_Protected_Body_Stub): Set the corresponding spec of the stub. + (Analyze_Task_Body_Stub): Set the corresponding spec of the stub. + (Move_Stub_Pragmas_To_Body): New routine. + * sem_ch13.adb (Analyze_Aspect_Specifications): Add processing + for aspect Refined_Pre. + (Check_Aspect_At_Freeze_Point): Aspect + Refined_Pre does not need delayed processing at the freeze point. + * sem_prag.adb: Remove with and use clause for Snames. Add + an entry for Pragma_Refined_Pre in table Sig_Flags. + (Analyze_Pragma): Add processing for pragma Refined_Pre. + * sem_prag.ads: Add with and use clause for Snames. Add table + Pragma_On_Stub_OK. + * sinfo.adb (Corresponding_Spec_Of_Stub): New routine. + (Set_Corresponding_Spec_Of_Stub): New routine. + * sinfo.ads: Add new attribute Corresponding_Spec_Of_Stub + along with comment on usage and occurrences in nodes. + (Corresponding_Spec_Of_Stub): New routine along with pragma + Inline. + (Set_Corresponding_Spec_Of_Stub): New routine along + with pragma Inline. + * snames.ads-tmpl: Add new predefined name for Refined_Pre. Add + new Pragma_Id for Refined_Pre. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Analyze_Package_Instantiation, + Analyze_Subprogram_Instantiation): Improve error message when + name in instantiation does not designate a generic unit of the + right kind. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * exp_ch3.adb (Expand_N_Variant_Part): Expand statically + predicated subtype which appears in Discrete_Choices list. + * exp_ch5.adb (Expand_N_Case_Statement): Expand statically + predicated subtype which appears in Discrete_Choices list of + case statement alternative. + * exp_util.ads, exp_util.adb (Expand_Static_Predicates_In_Choices): New + procedure. + * sem_case.adb: Minor reformatting (Analyze_Choices): Don't + expand out Discrete_Choices that are names of subtypes with + static predicates. This is now done in the analyzer so that the + -gnatct tree is properly formed for ASIS. + * sem_case.ads (Generic_Choices_Processing): Does not apply + to aggregates any more, so change doc accordingly, and remove + unneeded Get_Choices argument. + * sem_ch3.adb (Analyze_Variant_Part): Remove no + longer used Get_Choices argument in instantiation of + Generic_Choices_Processing. + * sem_ch4.adb (Analyze_Case_Expression): Remove no + longer used Get_Choices argument in instantiation of + Generic_Choices_Processing. + * sem_ch5.adb (Analyze_Case_Statement): Remove no + longer used Get_Choices argument in instantiation of + Generic_Choices_Processing. + * sinfo.ads: For N_Variant_Part, and N_Case_Statement_Alternative, + document that choices that are names of statically predicated + subtypes are expanded in the code generation tree passed to the + back end, but not in the ASIS tree generated for -gnatct. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch7.adb: Revert previous change. + +2013-10-10 Gary Dismukes <dismukes@adacore.com> + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): In the case where + the Storage_Pool aspect is specified by an aspect clause and a + renaming is used to capture the evaluation of the pool name, + insert the renaming in front of the aspect's associated entity + declaration rather than in front of the corresponding attribute + definition (which hasn't been appended to the declaration + list yet). + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Is_Interface_Conformant): The controlling type + of the interface operation is obtained from the ultimate alias + of the interface primitive parameter, because that may be in + fact an implicit inherited operation whose signature involves + the type extension and not the desired interface. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * par-ch13.adb (Aspect_Specifications_Present): In Ada 2012, + recognize an aspect specification with a misspelled name if it + is followed by a a comma or semicolon. + +2013-10-10 Vadim Godunko <godunko@adacore.com> + + * s-atocou.adb, s-atocou.ads, s-atocou-x86.adb, s-atocou-builtin.adb: + Fix copyright notice. + +2013-10-10 Yannick Moy <moy@adacore.com> + + * lib-xref-spark_specific.adb (Enclosing_Subprogram_Or_Package): Get + enclosing subprogram for precondition/postcondition/contract cases. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Minor fix. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case + Address): Remove the Comes_From_Source test for the overlap + warning. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_util.adb: Minor code reorganization (use Nkind_In). + * sem_warn.adb: Minor code reorganization (optimization in + Check_Unset_Reference). + * exp_ch9.adb, exp_ch4.adb, sinfo.ads: Minor reformatting. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch7.adb (Install_Parent_Private_Declarations): When + instantiating a child unit, do not install private declaration of + a non-generic ancestor of the generic that is also an ancestor + of the current unit: its private part will be installed when + private part of ancestor itself is analyzed. + +2013-10-10 Thomas Quinot <quinot@adacore.com> + + * freeze.adb (Check_Component_Storage_Order): Retrieve component + aliased status from type entities directly instead of going back + to original component definition. + * sem_ch7.adb: Minor reformatting. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): For Address + attribute, consider it to be set in source, because of aliasing + considerations. + (Analyze_Attribute_Definition_Clause): For the + purpose of warning on overlays, take into account the aspect case. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads, a-cforse.ads, + a-cofove.ads: Minor reformatting. + +2013-10-10 Arnaud Charlet <charlet@adacore.com> + + * gnat_ugn.texi: Remove obsolete mention to -laddr2line. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Expand_N_Case_Expression): Indicate that the + generated variable used as a target of the expression needs + no initialization. + +2013-10-10 Jose Ruiz <ruiz@adacore.com> + + * exp_util.adb (Corresponding_Runtime_Package): Remove the condition + related to No_Dynamic_Attachment which was wrong. Protected types + with interrupt handlers (when not using a restricted profile) + are always treated as protected types with entries, regardless + of the No_Dynamic_Attachment restriction. + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): Simplify the code + using the result of Corresponding_Runtime_Package. + (Install_Private_Data_Declarations): When having + static handlers and a non restricted profile, we use the + type Static_Interrupt_Protection always, so we removed an + extra wrong condition looking at the No_Dynamic_Attachment + restriction. Simplify the code using the result of + Corresponding_Runtime_Package. + (Make_Initialize_Protection): Simplify the code using + the result of Corresponding_Runtime_Package. + (Install_Private_Data_Declaration): The No_Dynamic_Attachment + restriction has nothing to do with static handlers. Remove the extra + erroneous condition that was creating the wrong data type. + +2013-10-10 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_util.adb (Is_Object_Reference): Attribute + 'Old produces an object reference. + * gnat_rm.texi: Define accessibility level of + X'Update(...) result. + +2013-10-10 Yannick Moy <moy@adacore.com> + + * gnat_rm.texi, a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads, + a-cforse.ads, a-cofove.ads: Update comment and doc of formal containers + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): For Pre/Post + conditions that apply to a subprogram body, preserve the placement + and order of the generated pragmas, which must appear before + other declarations in the body. + +2013-10-10 Bob Duff <duff@adacore.com> + + * gnat_ugn.texi: Add gnat2xml doc. + +2013-10-10 Doug Rupp <rupp@adacore.com> + + * s-vxwork-arm.ads: Fix interface to FP_CONTEXT. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specification): An aspect Import + on a variable need not have a convention specified, as long as + the implicit convention of the object, obtained from its type, + is Ada or Ada-related. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * cstand.adb (Standard_Unsigned_64): New internal type. + * gnat_rm.texi: Update documentation on To_Address. + * sem_attr.adb (Analyze_Attribute, case To_Address): Fix + problem with out of range static values given as literals or + named numbers. + * stand.ads (Standard_Unsigned_64): New internal type. + * stand.adb: Minor reformatting. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Analyze_Selected_Component, + Has_Mode_Conformant_Spec): If selected component may be an + indexing of a parameterless call to a protected function, and + expansion is disabled, this is a valid candidate interpretation. + +2013-10-10 Arnaud Charlet <charlet@adacore.com> + + * gnat_ugn.texi: Minor editing. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * gnatlink.adb: Minor reformatting. + +2013-10-10 Yannick Moy <moy@adacore.com> + + * debug.adb: Free flag d.E and change doc for flag d.K. + +2013-10-10 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Check_Precondition_Postcondition): If the + pragma comes from an aspect spec, and the subprogram is a + library unit, treat as a ppc in a declarative part in ASIS mode, + so that expression in aspect is properly analyzed. In this case + there is no later point at which the aspect specification would + be examined. + +2013-10-10 Bob Duff <duff@adacore.com> + + * opt.ads: Minor comment fix. + +2013-10-10 Vadim Godunko <godunko@adacore.com> + + * a-coinho-shared.ads, a-coinho-shared.adb: New file. + * s-atocou.ads: Add procedure to initialize counter. + * s-atocou.adb: Likewise. + * s-atocou-builtin.adb: Likewise. + * s-atocou-x86.adb: Likewise. + * gcc-interface/Makefile.in: Select special version of + Indefinite_Holders package on platforms where atomic built-ins + are supported. Update tools target pairs for PikeOS. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb: Minor reformatting. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sinput-c.adb (Load_File): Ensure Source_Align alignment. + * sinput-d.adb (Create_Debug_Source): Ensure Source_Align alignment. + * sinput-l.adb (Create_Instantiation_Source): Ensure Source_Align + alignment. + (Load_File): Ditto. + * sinput.ads, sinput.adb (Get_Source_File_Index): New optimized (single + line) version. + * types.ads (Source_Align): New definition. + (Source_Buffer): Document new alignment requirement. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb (Analyze_Pragma, case Linker_Section): Allow + this for types. + +2013-10-10 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Minor adjustment to doc for To_Address attribute. + +2013-10-10 Vadim Godunko <godunko@adacore.com> + + * s-stopoo.ads (Root_Storage_Pool): Add pragma + Preelaborable_Initialization. + +2013-09-25 Tom Tromey <tromey@redhat.com> + + * gcc-interface/Makefile.in (OUTPUT_OPTION): Define as "-o $@". + 2013-09-18 Eric Botcazou <ebotcazou@adacore.com> PR ada/58264 diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads index bfa8ffbcb90..b15b2425e4d 100644 --- a/gcc/ada/a-cfdlli.ads +++ b/gcc/ada/a-cfdlli.ads @@ -30,8 +30,10 @@ ------------------------------------------------------------------------------ -- This spec is derived from Ada.Containers.Bounded_Doubly_Linked_Lists in the --- Ada 2012 RM. The modifications are to facilitate formal proofs by making it --- easier to express properties. +-- Ada 2012 RM. The modifications are meant to facilitate formal proofs by +-- making it easier to express properties, and by making the specification of +-- this unit compatible with SPARK 2014. Note that the API of this unit may be +-- subject to incompatible changes as SPARK 2014 evolves. -- The modifications are: diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/a-cfhama.ads index 93a47c56817..dbfcb82e9dc 100644 --- a/gcc/ada/a-cfhama.ads +++ b/gcc/ada/a-cfhama.ads @@ -30,8 +30,10 @@ ------------------------------------------------------------------------------ -- This spec is derived from package Ada.Containers.Bounded_Hashed_Maps in the --- Ada 2012 RM. The modifications are to facilitate formal proofs by making it --- easier to express properties. +-- Ada 2012 RM. The modifications are meant to facilitate formal proofs by +-- making it easier to express properties, and by making the specification of +-- this unit compatible with SPARK 2014. Note that the API of this unit may be +-- subject to incompatible changes as SPARK 2014 evolves. -- The modifications are: diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads index 22bfda97e89..c0103cbe0f4 100644 --- a/gcc/ada/a-cfhase.ads +++ b/gcc/ada/a-cfhase.ads @@ -30,8 +30,10 @@ ------------------------------------------------------------------------------ -- This spec is derived from package Ada.Containers.Bounded_Hashed_Sets in the --- Ada 2012 RM. The modifications are to facilitate formal proofs by making it --- easier to express properties. +-- Ada 2012 RM. The modifications are meant to facilitate formal proofs by +-- making it easier to express properties, and by making the specification of +-- this unit compatible with SPARK 2014. Note that the API of this unit may be +-- subject to incompatible changes as SPARK 2014 evolves. -- The modifications are: diff --git a/gcc/ada/a-cforma.ads b/gcc/ada/a-cforma.ads index 8e323e19dfb..2ddbd90a1ab 100644 --- a/gcc/ada/a-cforma.ads +++ b/gcc/ada/a-cforma.ads @@ -30,8 +30,10 @@ ------------------------------------------------------------------------------ -- This spec is derived from package Ada.Containers.Bounded_Ordered_Maps in --- the Ada 2012 RM. The modifications are to facilitate formal proofs by --- making it easier to express properties. +-- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by +-- making it easier to express properties, and by making the specification of +-- this unit compatible with SPARK 2014. Note that the API of this unit may be +-- subject to incompatible changes as SPARK 2014 evolves. -- The modifications are: diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads index 35e4613b9a8..1d8cdf66786 100644 --- a/gcc/ada/a-cforse.ads +++ b/gcc/ada/a-cforse.ads @@ -30,8 +30,10 @@ ------------------------------------------------------------------------------ -- This spec is derived from package Ada.Containers.Bounded_Ordered_Sets in --- the Ada 2012 RM. The modifications are to facilitate formal proofs by --- making it easier to express properties. +-- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by +-- making it easier to express properties, and by making the specification of +-- this unit compatible with SPARK 2014. Note that the API of this unit may be +-- subject to incompatible changes as SPARK 2014 evolves. -- The modifications are: diff --git a/gcc/ada/a-chahan.adb b/gcc/ada/a-chahan.adb index c7a77ea57dc..f95a7bb0eaf 100644 --- a/gcc/ada/a-chahan.adb +++ b/gcc/ada/a-chahan.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -49,6 +49,7 @@ package body Ada.Characters.Handling is Hex_Digit : constant Character_Flags := 16; Digit : constant Character_Flags := 32; Special : constant Character_Flags := 64; + Line_Term : constant Character_Flags := 128; Letter : constant Character_Flags := Lower or Upper; Alphanum : constant Character_Flags := Letter or Digit; @@ -66,10 +67,10 @@ package body Ada.Characters.Handling is BEL => Control, BS => Control, HT => Control, - LF => Control, - VT => Control, - FF => Control, - CR => Control, + LF => Control + Line_Term, + VT => Control + Line_Term, + FF => Control + Line_Term, + CR => Control + Line_Term, SO => Control, SI => Control, @@ -141,7 +142,7 @@ package body Ada.Characters.Handling is BPH => Control, NBH => Control, Reserved_132 => Control, - NEL => Control, + NEL => Control + Line_Term, SSA => Control, ESA => Control, HTS => Control, @@ -370,6 +371,15 @@ package body Ada.Characters.Handling is return (Char_Map (Item) and Letter) /= 0; end Is_Letter; + ------------------------ + -- Is_Line_Terminator -- + ------------------------ + + function Is_Line_Terminator (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Line_Term) /= 0; + end Is_Line_Terminator; + -------------- -- Is_Lower -- -------------- @@ -379,6 +389,43 @@ package body Ada.Characters.Handling is return (Char_Map (Item) and Lower) /= 0; end Is_Lower; + ------------- + -- Is_Mark -- + ------------- + + function Is_Mark (Item : Character) return Boolean is + pragma Unreferenced (Item); + begin + return False; + end Is_Mark; + + --------------------- + -- Is_Other_Format -- + --------------------- + + function Is_Other_Format (Item : Character) return Boolean is + begin + return Item = Soft_Hyphen; + end Is_Other_Format; + + ------------------------------ + -- Is_Punctuation_Connector -- + ------------------------------ + + function Is_Punctuation_Connector (Item : Character) return Boolean is + begin + return Item = '_'; + end Is_Punctuation_Connector; + + -------------- + -- Is_Space -- + -------------- + + function Is_Space (Item : Character) return Boolean is + begin + return Item = ' ' or else Item = No_Break_Space; + end Is_Space; + ---------------- -- Is_Special -- ---------------- diff --git a/gcc/ada/a-chahan.ads b/gcc/ada/a-chahan.ads index 98f69ba29d0..ca52f94730c 100644 --- a/gcc/ada/a-chahan.ads +++ b/gcc/ada/a-chahan.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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,18 +42,23 @@ package Ada.Characters.Handling is -- Character Classification Functions -- ---------------------------------------- - function Is_Control (Item : Character) return Boolean; - function Is_Graphic (Item : Character) return Boolean; - function Is_Letter (Item : Character) return Boolean; - function Is_Lower (Item : Character) return Boolean; - function Is_Upper (Item : Character) return Boolean; - function Is_Basic (Item : Character) return Boolean; - function Is_Digit (Item : Character) return Boolean; - function Is_Decimal_Digit (Item : Character) return Boolean + function Is_Control (Item : Character) return Boolean; + function Is_Graphic (Item : Character) return Boolean; + function Is_Letter (Item : Character) return Boolean; + function Is_Lower (Item : Character) return Boolean; + function Is_Upper (Item : Character) return Boolean; + function Is_Basic (Item : Character) return Boolean; + function Is_Digit (Item : Character) return Boolean; + function Is_Decimal_Digit (Item : Character) return Boolean renames Is_Digit; - function Is_Hexadecimal_Digit (Item : Character) return Boolean; - function Is_Alphanumeric (Item : Character) return Boolean; - function Is_Special (Item : Character) return Boolean; + function Is_Hexadecimal_Digit (Item : Character) return Boolean; + function Is_Alphanumeric (Item : Character) return Boolean; + function Is_Special (Item : Character) return Boolean; + function Is_Line_Terminator (Item : Character) return Boolean; + function Is_Mark (Item : Character) return Boolean; + function Is_Other_Format (Item : Character) return Boolean; + function Is_Punctuation_Connector (Item : Character) return Boolean; + function Is_Space (Item : Character) return Boolean; --------------------------------------------------- -- Conversion Functions for Character and String -- @@ -129,22 +134,27 @@ package Ada.Characters.Handling is (Item : String) return Wide_String; private + pragma Inline (Is_Alphanumeric); + pragma Inline (Is_Basic); + pragma Inline (Is_Character); pragma Inline (Is_Control); + pragma Inline (Is_Digit); pragma Inline (Is_Graphic); + pragma Inline (Is_Hexadecimal_Digit); + pragma Inline (Is_ISO_646); pragma Inline (Is_Letter); + pragma Inline (Is_Line_Terminator); pragma Inline (Is_Lower); - pragma Inline (Is_Upper); - pragma Inline (Is_Basic); - pragma Inline (Is_Digit); - pragma Inline (Is_Hexadecimal_Digit); - pragma Inline (Is_Alphanumeric); + pragma Inline (Is_Mark); + pragma Inline (Is_Other_Format); + pragma Inline (Is_Punctuation_Connector); + pragma Inline (Is_Space); pragma Inline (Is_Special); - pragma Inline (To_Lower); - pragma Inline (To_Upper); + pragma Inline (Is_Upper); pragma Inline (To_Basic); - pragma Inline (Is_ISO_646); - pragma Inline (Is_Character); pragma Inline (To_Character); + pragma Inline (To_Lower); + pragma Inline (To_Upper); pragma Inline (To_Wide_Character); end Ada.Characters.Handling; diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb index c2790517e01..bcd6118e607 100644 --- a/gcc/ada/a-cobove.adb +++ b/gcc/ada/a-cobove.adb @@ -1227,7 +1227,22 @@ package body Ada.Containers.Bounded_Vectors is -- worry about if No_Index were less than 0, but that case is -- handled above). - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + if Index_Type'Last - No_Index >= + Count_Type'Pos (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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; end if; elsif Index_Type'First <= 0 then @@ -1685,7 +1700,22 @@ package body Ada.Containers.Bounded_Vectors is -- worry about if No_Index were less than 0, but that case is -- handled above). - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + if Index_Type'Last - No_Index >= + Count_Type'Pos (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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; end if; elsif Index_Type'First <= 0 then diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index 9ca84da460f..604ed8d356b 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -30,8 +30,10 @@ ------------------------------------------------------------------------------ -- This spec is derived from package Ada.Containers.Bounded_Vectors in the Ada --- 2012 RM. The modifications are to facilitate formal proofs by making it --- easier to express properties. +-- 2012 RM. The modifications are meant to facilitate formal proofs by making +-- it easier to express properties, and by making the specification of this +-- unit compatible with SPARK 2014. Note that the API of this unit may be +-- subject to incompatible changes as SPARK 2014 evolves. -- The modifications are: @@ -48,12 +50,7 @@ -- function Left (Container : Vector; Position : Cursor) return Vector; -- function Right (Container : Vector; Position : Cursor) return Vector; --- Left returns a container containing all elements preceding Position --- (excluded) in Container. Right returns a container containing all --- elements following Position (included) in Container. These two new --- functions are useful to express invariant properties in loops which --- iterate over containers. Left returns the part of the container already --- scanned and Right the part not scanned yet. +-- See detailed specifications for these subprograms with Ada.Containers; use Ada.Containers; @@ -350,9 +347,14 @@ package Ada.Containers.Formal_Vectors is function Left (Container : Vector; Position : Cursor) return Vector with Pre => Has_Element (Container, Position) or else Position = No_Element; - function Right (Container : Vector; Position : Cursor) return Vector with Pre => Has_Element (Container, Position) or else Position = No_Element; + -- Left returns a container containing all elements preceding Position + -- (excluded) in Container. Right returns a container containing all + -- elements following Position (included) in Container. These two new + -- functions can be used to express invariant properties in loops which + -- iterate over containers. Left returns the part of the container already + -- scanned and Right the part not scanned yet. private diff --git a/gcc/ada/a-coinho-shared.adb b/gcc/ada/a-coinho-shared.adb new file mode 100644 index 00000000000..9300c0b1dc6 --- /dev/null +++ b/gcc/ada/a-coinho-shared.adb @@ -0,0 +1,358 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013, 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.Unchecked_Deallocation; + +package body Ada.Containers.Indefinite_Holders is + + procedure Free is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Holder) return Boolean is + begin + if Left.Reference = null and Right.Reference = null then + return True; + + elsif Left.Reference /= null and Right.Reference /= null then + return Left.Reference.Element.all = Right.Reference.Element.all; + + else + return False; + end if; + end "="; + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (Container : in out Holder) is + begin + if Container.Reference /= null then + Reference (Container.Reference); + end if; + + Container.Busy := 0; + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Holder; Source : Holder) is + begin + if Target.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Target.Reference /= Source.Reference then + if Target.Reference /= null then + Unreference (Target.Reference); + end if; + + Target.Reference := Source.Reference; + + if Source.Reference /= null then + Reference (Target.Reference); + end if; + end if; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Holder) is + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + Unreference (Container.Reference); + Container.Reference := null; + end Clear; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Holder) return Holder is + begin + if Source.Reference = null then + return (AF.Controlled with null, 0); + else + Reference (Source.Reference); + + return (AF.Controlled with Source.Reference, 0); + end if; + end Copy; + + ------------- + -- Element -- + ------------- + + function Element (Container : Holder) return Element_Type is + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + else + return Container.Reference.Element.all; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Container : in out Holder) is + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Container.Reference /= null then + Unreference (Container.Reference); + Container.Reference := null; + end if; + end Finalize; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Holder) return Boolean is + begin + return Container.Reference = null; + end Is_Empty; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Holder; Source : in out Holder) is + begin + if Target.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Source.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Target.Reference /= Source.Reference then + if Target.Reference /= null then + Unreference (Target.Reference); + end if; + + Target.Reference := Source.Reference; + Source.Reference := null; + end if; + end Move; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Holder; + Process : not null access procedure (Element : Element_Type)) + is + B : Natural renames Container'Unrestricted_Access.Busy; + + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + end if; + + B := B + 1; + + begin + Process (Container.Reference.Element.all); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : out Holder) + is + begin + Clear (Container); + + if not Boolean'Input (Stream) then + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(Element_Type'Input (Stream))); + end if; + end Read; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Holder_Access) is + begin + System.Atomic_Counters.Increment (Item.Counter); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Holder; + New_Item : Element_Type) + is + -- Element allocator may need an accessibility check in case actual type + -- is class-wide or has access discriminants (RM 4.8(10.1) and + -- AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Container.Reference = null then + -- Holder is empty, allocate new Shared_Holder. + + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(New_Item)); + + elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then + -- Shared_Holder can be reused. + + Free (Container.Reference.Element); + Container.Reference.Element := new Element_Type'(New_Item); + + else + Unreference (Container.Reference); + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(New_Item)); + end if; + end Replace_Element; + + --------------- + -- To_Holder -- + --------------- + + function To_Holder (New_Item : Element_Type) return Holder is + -- The element allocator may need an accessibility check in the case the + -- actual type is class-wide or has access discriminants (RM 4.8(10.1) + -- and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + return + (AF.Controlled with + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(New_Item)), 0); + end To_Holder; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Holder_Access) is + + procedure Free is + new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access); + + Aux : Shared_Holder_Access := Item; + + begin + if System.Atomic_Counters.Decrement (Aux.Counter) then + Free (Aux.Element); + Free (Aux); + end if; + end Unreference; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : Holder; + Process : not null access procedure (Element : in out Element_Type)) + is + B : Natural renames Container'Unrestricted_Access.Busy; + + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + end if; + + B := B + 1; + + begin + Process (Container.Reference.Element.all); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : Holder) + is + begin + Boolean'Output (Stream, Container.Reference = null); + + if Container.Reference /= null then + Element_Type'Output (Stream, Container.Reference.Element.all); + end if; + end Write; + +end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/a-coinho-shared.ads b/gcc/ada/a-coinho-shared.ads new file mode 100644 index 00000000000..9abeda33a8f --- /dev/null +++ b/gcc/ada/a-coinho-shared.ads @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2013, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +------------------------------------------------------------------------------ + +private with Ada.Finalization; +private with Ada.Streams; +private with System.Atomic_Counters; + +generic + type Element_Type (<>) is private; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Holders is + pragma Preelaborate (Indefinite_Holders); + pragma Remote_Types (Indefinite_Holders); + + type Holder is tagged private; + pragma Preelaborable_Initialization (Holder); + + Empty_Holder : constant Holder; + + function "=" (Left, Right : Holder) return Boolean; + + function To_Holder (New_Item : Element_Type) return Holder; + + function Is_Empty (Container : Holder) return Boolean; + + procedure Clear (Container : in out Holder); + + function Element (Container : Holder) return Element_Type; + + procedure Replace_Element + (Container : in out Holder; + New_Item : Element_Type); + + procedure Query_Element + (Container : Holder; + Process : not null access procedure (Element : Element_Type)); + procedure Update_Element + (Container : Holder; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Assign (Target : in out Holder; Source : Holder); + + function Copy (Source : Holder) return Holder; + + procedure Move (Target : in out Holder; Source : in out Holder); + +private + + package AF renames Ada.Finalization; + + type Element_Access is access all Element_Type; + + type Shared_Holder is record + Counter : System.Atomic_Counters.Atomic_Counter; + Element : Element_Access; + end record; + + type Shared_Holder_Access is access all Shared_Holder; + + procedure Reference (Item : not null Shared_Holder_Access); + -- Increment reference counter + + procedure Unreference (Item : not null Shared_Holder_Access); + -- Decrement reference counter, deallocate Item when counter goes to zero + + procedure Read + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : out Holder); + + procedure Write + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : Holder); + + type Holder is new Ada.Finalization.Controlled with record + Reference : Shared_Holder_Access; + Busy : Natural := 0; + end record; + for Holder'Read use Read; + for Holder'Write use Write; + + overriding procedure Adjust (Container : in out Holder); + overriding procedure Finalize (Container : in out Holder); + + Empty_Holder : constant Holder := (AF.Controlled with null, 0); + +end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index cff3a286edb..677fd97e09d 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -1734,7 +1734,22 @@ package body Ada.Containers.Indefinite_Vectors is -- worry about if No_Index were less than 0, but that case is -- handled above). - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + if Index_Type'Last - No_Index >= + Count_Type'Pos (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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; end if; elsif Index_Type'First <= 0 then @@ -2504,7 +2519,22 @@ package body Ada.Containers.Indefinite_Vectors is -- worry about if No_Index were less than 0, but that case is -- handled above). - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + if Index_Type'Last - No_Index >= + Count_Type'Pos (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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; end if; elsif Index_Type'First <= 0 then diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 5b722fe8a72..0f4bc19bcba 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -1386,7 +1386,22 @@ package body Ada.Containers.Vectors is -- worry about if No_Index were less than 0, but that case is -- handled above). - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + if Index_Type'Last - No_Index >= + Count_Type'Pos (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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; end if; elsif Index_Type'First <= 0 then @@ -2033,7 +2048,22 @@ package body Ada.Containers.Vectors is -- worry about if No_Index were less than 0, but that case is -- handled above). - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + if Index_Type'Last - No_Index >= + Count_Type'Pos (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. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; end if; elsif Index_Type'First <= 0 then diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index 3453eae90ab..b47f167be77 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -861,6 +861,17 @@ package body Ada.Exceptions is -- in case we do not want any exception tracing support. This is -- why this package is separated. + -------------------------------------- + -- Get_Exception_Machine_Occurrence -- + -------------------------------------- + + function Get_Exception_Machine_Occurrence + (X : Exception_Occurrence) return System.Address + is + begin + return X.Machine_Occurrence; + end Get_Exception_Machine_Occurrence; + ----------- -- Image -- ----------- diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads index bb597ed0982..ca4ff9f9e17 100644 --- a/gcc/ada/a-except-2005.ads +++ b/gcc/ada/a-except-2005.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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 -- @@ -51,12 +51,8 @@ with System.Standard_Library; with System.Traceback_Entries; package Ada.Exceptions is - pragma Warnings (Off); pragma Preelaborate_05; - pragma Warnings (On); - -- In accordance with Ada 2005 AI-362. The warnings pragmas are so that we - -- can compile this using older compiler versions, which will ignore the - -- pragma, which is fine for the bootstrap. + -- In accordance with Ada 2005 AI-362. type Exception_Id is private; pragma Preelaborable_Initialization (Exception_Id); @@ -337,6 +333,15 @@ private -- this, and it would not work right, because of the Msg and Tracebacks -- fields which have unused entries not copied by Save_Occurrence. + function Get_Exception_Machine_Occurrence + (X : Exception_Occurrence) return System.Address; + pragma Export (Ada, Get_Exception_Machine_Occurrence, + "__gnat_get_exception_machine_occurrence"); + -- Get the machine occurrence corresponding to an exception occurrence. + -- It is Null_Address if there is no machine occurrence (in runtimes that + -- doesn't use GCC mechanism) or if it has been lost (Save_Occurrence + -- doesn't save the machine occurrence). + function EO_To_String (X : Exception_Occurrence) return String; function String_To_EO (S : String) return Exception_Occurrence; pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index 85b519a5e1e..a201551b702 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -206,6 +206,11 @@ package body Exception_Data is pragma Export (Ada, Exception_Message_Length, "__gnat_exception_msg_len"); + function Get_Executable_Load_Address return System.Address; + pragma Import (C, Get_Executable_Load_Address, + "__gnat_get_executable_load_address"); + -- Get the load address of the executable, or Null_Address if not known + ------------------------- -- Append_Info_Address -- ------------------------- @@ -377,17 +382,31 @@ package body Exception_Data is -- As for Basic_Exception_Information: BETB_Header : constant String := "Call stack traceback locations:"; + LDAD_Header : constant String := "Load address: "; procedure Append_Info_Basic_Exception_Traceback (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural) is + Load_Address : Address; + begin if X.Num_Tracebacks = 0 then return; end if; + -- The executable load address line + + Load_Address := Get_Executable_Load_Address; + + if Load_Address /= Null_Address then + Append_Info_String (LDAD_Header, Info, Ptr); + Append_Info_Address (Load_Address, Info, Ptr); + Append_Info_NL (Info, Ptr); + end if; + + -- The traceback lines Append_Info_String (BETB_Header, Info, Ptr); Append_Info_NL (Info, Ptr); @@ -407,11 +426,12 @@ package body Exception_Data is function Basic_Exception_Tback_Maxlength (X : Exception_Occurrence) return Natural is - Space_Per_Traceback : constant := 2 + 16 + 1; + Space_Per_Address : constant := 2 + 16 + 1; -- Space for "0x" + HHHHHHHHHHHHHHHH + " " begin - return BETB_Header'Length + 1 + - X.Num_Tracebacks * Space_Per_Traceback + 1; + return + LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 + + X.Num_Tracebacks * Space_Per_Address + 1; end Basic_Exception_Tback_Maxlength; --------------------------------------- diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb index 178b7e375f6..a9d9e4b7733 100644 --- a/gcc/ada/a-exexpr-gcc.adb +++ b/gcc/ada/a-exexpr-gcc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -45,11 +45,10 @@ package body Exception_Propagation is -- Entities to interface with the GCC runtime -- ------------------------------------------------ - -- These come from "C++ ABI for Itanium: Exception handling", which is - -- the reference for GCC. + -- These come from "C++ ABI for Itanium: Exception handling", which is the + -- reference for GCC. - -- Return codes from the GCC runtime functions used to propagate - -- an exception. + -- Return codes from GCC runtime functions used to propagate an exception type Unwind_Reason_Code is (URC_NO_REASON, @@ -199,13 +198,14 @@ package body Exception_Propagation is (GCC_Exception : not null GCC_Exception_Access); pragma No_Return (Reraise_GCC_Exception); pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx"); - -- Called to implement raise without exception, ie reraise. Called + -- Called to implement raise without exception, ie reraise. Called -- directly from gigi. function Setup_Current_Excep (GCC_Exception : not null GCC_Exception_Access) return EOA; pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); - -- Write Get_Current_Excep.all from GCC_Exception + -- Write Get_Current_Excep.all from GCC_Exception. Called by the + -- personality routine. procedure Unhandled_Except_Handler (GCC_Exception : not null GCC_Exception_Access); @@ -225,9 +225,8 @@ package body Exception_Propagation is UW_Argument : System.Address) return Unwind_Reason_Code; pragma Import (C, CleanupUnwind_Handler, "__gnat_cleanupunwind_handler"); - -- Hook called at each step of the forced unwinding we perform to - -- trigger cleanups found during the propagation of an unhandled - -- exception. + -- Hook called at each step of the forced unwinding we perform to trigger + -- cleanups found during the propagation of an unhandled exception. -- GCC runtime functions used. These are C non-void functions, actually, -- but we ignore the return values. See raise.c as to why we are using @@ -243,6 +242,18 @@ package body Exception_Propagation is UW_Argument : System.Address); pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind"); + procedure Set_Exception_Parameter + (Excep : EOA; + GCC_Exception : not null GCC_Exception_Access); + pragma Export + (C, Set_Exception_Parameter, "__gnat_set_exception_parameter"); + -- Called inserted by gigi to initialize the exception parameter + + procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address); + -- Utility routine to initialize occurrence Excep from a foreign exception + -- whose machine occurrence is Mo. The message is empty, the backtrace + -- is empty too and the exception identity is Foreign_Exception. + -- Hooks called when entering/leaving an exception handler for a given -- occurrence, aimed at handling the stack of active occurrences. The -- calls are generated by gigi in tree_transform/N_Exception_Handler. @@ -270,8 +281,8 @@ package body Exception_Propagation is function Language_For (E : Exception_Data_Ptr) return Character; pragma Export (C, Language_For, "__gnat_language_for"); - function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code; - pragma Export (C, Import_Code_For, "__gnat_import_code_for"); + function Foreign_Data_For (E : Exception_Data_Ptr) return Address; + pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for"); function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id; @@ -282,18 +293,17 @@ package body Exception_Propagation is --------------------------------------------------------------------------- -- Currently, these only have their address taken and compared so there is - -- no real point having whole exception data blocks allocated. In any case - -- the types should match what gigi and the personality routine expect. - -- The initial value is an arbitrary value that will not exceed the range - -- of Integer on 16-bit targets (such as AAMP). + -- no real point having whole exception data blocks allocated. Note that + -- there are corresponding declarations in gigi (trans.c) which must be + -- kept properly synchronized. - Others_Value : constant Integer := 16#7FFF#; + Others_Value : constant Character := 'O'; pragma Export (C, Others_Value, "__gnat_others_value"); - All_Others_Value : constant Integer := 16#7FFF#; + All_Others_Value : constant Character := 'A'; pragma Export (C, All_Others_Value, "__gnat_all_others_value"); - Unhandled_Others_Value : constant Integer := 16#7FFF#; + Unhandled_Others_Value : constant Character := 'U'; pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value"); -- Special choice (emitted by gigi) to catch and notify unhandled -- exceptions on targets which always handle exceptions (such as SEH). @@ -305,6 +315,7 @@ package body Exception_Propagation is function Allocate_Occurrence return EOA is Res : GNAT_GCC_Exception_Access; + begin Res := new GNAT_GCC_Exception' @@ -338,6 +349,23 @@ package body Exception_Propagation is Free (Copy); end GNAT_GCC_Exception_Cleanup; + ---------------------------- + -- Set_Foreign_Occurrence -- + ---------------------------- + + procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is + begin + Excep.all := ( + Id => Foreign_Exception'Access, + Machine_Occurrence => Mo, + Msg => <>, + Msg_Length => 0, + Exception_Raised => True, + Pid => Local_Partition_ID, + Num_Tracebacks => 0, + Tracebacks => <>); + end Set_Foreign_Occurrence; + ------------------------- -- Setup_Current_Excep -- ------------------------- @@ -356,22 +384,16 @@ package body Exception_Propagation is declare GNAT_Occurrence : constant GNAT_GCC_Exception_Access := - To_GNAT_GCC_Exception (GCC_Exception); + To_GNAT_GCC_Exception (GCC_Exception); begin Excep.all := GNAT_Occurrence.Occurrence; - return GNAT_Occurrence.Occurrence'Access; end; - else + else -- A default one - Excep.Id := Foreign_Exception'Access; - Excep.Machine_Occurrence := GCC_Exception.all'Address; - Excep.Msg_Length := 0; - Excep.Exception_Raised := True; - Excep.Pid := Local_Partition_ID; - Excep.Num_Tracebacks := 0; + Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); return Excep; end if; @@ -411,6 +433,7 @@ package body Exception_Propagation is is begin -- Simply propagate it + Propagate_GCC_Exception (GCC_Exception); end Reraise_GCC_Exception; @@ -446,9 +469,10 @@ package body Exception_Propagation is -- unwinding hook calls Unhandled_Exception_Terminate when end of -- stack is reached. - Unwind_ForcedUnwind (GCC_Exception, - CleanupUnwind_Handler'Address, - System.Null_Address); + Unwind_ForcedUnwind + (GCC_Exception, + CleanupUnwind_Handler'Address, + System.Null_Address); -- We get here in case of error. The debugger has been notified before -- the second step above. @@ -465,6 +489,35 @@ package body Exception_Propagation is Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence)); end Propagate_Exception; + ----------------------------- + -- Set_Exception_Parameter -- + ----------------------------- + + procedure Set_Exception_Parameter + (Excep : EOA; + GCC_Exception : not null GCC_Exception_Access) + is + begin + -- Setup the exception occurrence + + if GCC_Exception.Class = GNAT_Exception_Class then + + -- From the GCC exception + + declare + GNAT_Occurrence : constant GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (GCC_Exception); + begin + Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence); + end; + + else + -- A default one + + Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); + end if; + end Set_Exception_Parameter; + ------------------------------ -- Unhandled_Except_Handler -- ------------------------------ @@ -489,16 +542,16 @@ package body Exception_Propagation is return GNAT_Exception.Occurrence.Id; end EID_For; - --------------------- - -- Import_Code_For -- - --------------------- + ---------------------- + -- Foreign_Data_For -- + ---------------------- - function Import_Code_For - (E : SSL.Exception_Data_Ptr) return Exception_Code + function Foreign_Data_For + (E : SSL.Exception_Data_Ptr) return Address is begin - return E.all.Import_Code; - end Import_Code_For; + return E.Foreign_Data; + end Foreign_Data_For; -------------------------- -- Is_Handled_By_Others -- diff --git a/gcc/ada/a-sequio.adb b/gcc/ada/a-sequio.adb index 397a778f36f..b84252858bc 100644 --- a/gcc/ada/a-sequio.adb +++ b/gcc/ada/a-sequio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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,13 +34,16 @@ -- in System.File_IO (for common file functions), or in System.Sequential_IO -- (for specialized Sequential_IO functions) -with Interfaces.C_Streams; use Interfaces.C_Streams; +with Ada.Unchecked_Conversion; + with System; +with System.Byte_Swapping; with System.CRTL; with System.File_Control_Block; with System.File_IO; with System.Storage_Elements; -with Ada.Unchecked_Conversion; + +with Interfaces.C_Streams; use Interfaces.C_Streams; package body Ada.Sequential_IO is @@ -57,8 +60,26 @@ package body Ada.Sequential_IO is function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + use type System.Bit_Order; use type System.CRTL.size_t; + procedure Byte_Swap (Siz : in out size_t); + -- Byte swap Siz + + --------------- + -- Byte_Swap -- + --------------- + + procedure Byte_Swap (Siz : in out size_t) is + use System.Byte_Swapping; + begin + case Siz'Size is + when 32 => Siz := size_t (Bswap_32 (U32 (Siz))); + when 64 => Siz := size_t (Bswap_64 (U64 (Siz))); + when others => raise Program_Error; + end case; + end Byte_Swap; + ----------- -- Close -- ----------- @@ -170,6 +191,13 @@ package body Ada.Sequential_IO is FIO.Read_Buf (AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit); + -- If item read has non-default scalar storage order, then the size + -- will have been written with that same order, so byte swap it. + + if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then + Byte_Swap (Rsiz); + end if; + -- For a type with discriminants, we have to read into a temporary -- buffer if Item is constrained, to check that the discriminants -- are correct. @@ -252,6 +280,10 @@ package body Ada.Sequential_IO is procedure Write (File : File_Type; Item : Element_Type) is Siz : constant size_t := (Item'Size + SU - 1) / SU; + -- Size to be written, in native representation + + Swapped_Siz : size_t := Siz; + -- Same, possibly byte swapped to account for Element_Type endianness begin FIO.Check_Write_Status (AP (File)); @@ -261,8 +293,15 @@ package body Ada.Sequential_IO is if not Element_Type'Definite or else Element_Type'Has_Discriminants then + -- If item written has non-default scalar storage order, then the + -- size is written with that same order, so byte swap it. + + if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then + Byte_Swap (Swapped_Siz); + end if; + FIO.Write_Buf - (AP (File), Siz'Address, size_t'Size / System.Storage_Unit); + (AP (File), Swapped_Siz'Address, size_t'Size / System.Storage_Unit); end if; FIO.Write_Buf (AP (File), Item'Address, Siz); diff --git a/gcc/ada/a-tienau.adb b/gcc/ada/a-tienau.adb index 5498ca4f55d..6ee9bbadc60 100644 --- a/gcc/ada/a-tienau.adb +++ b/gcc/ada/a-tienau.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -126,19 +126,19 @@ package body Ada.Text_IO.Enumeration_Aux is Actual_Width : constant Count := Count'Max (Count (Width), Item'Length); begin - -- Deal with limited line length + -- Deal with limited line length of output file - if Line_Length /= 0 then + if Line_Length (File) /= 0 then -- If actual width exceeds line length, raise Layout_Error - if Actual_Width > Line_Length then + if Actual_Width > Line_Length (File) then raise Layout_Error; end if; -- If full width cannot fit on current line move to new line - if Actual_Width + (Col - 1) > Line_Length then + if Actual_Width + (Col (File) - 1) > Line_Length (File) then New_Line (File); end if; end if; diff --git a/gcc/ada/a-wichha.adb b/gcc/ada/a-wichha.adb index 3909fcdacc0..6692cbf445f 100644 --- a/gcc/ada/a-wichha.adb +++ b/gcc/ada/a-wichha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2013, 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,6 +33,11 @@ with Ada.Wide_Characters.Unicode; use Ada.Wide_Characters.Unicode; package body Ada.Wide_Characters.Handling is + function Character_Set_Version return String is + begin + return "Unicode 6.2"; + end Character_Set_Version; + --------------------- -- Is_Alphanumeric -- --------------------- @@ -108,18 +113,18 @@ package body Ada.Wide_Characters.Handling is function Is_Mark (Item : Wide_Character) return Boolean renames Ada.Wide_Characters.Unicode.Is_Mark; - -------------- - -- Is_Other -- - -------------- + --------------------- + -- Is_Other_Format -- + --------------------- - function Is_Other (Item : Wide_Character) return Boolean + function Is_Other_Format (Item : Wide_Character) return Boolean renames Ada.Wide_Characters.Unicode.Is_Other; - -------------------- - -- Is_Punctuation -- - -------------------- + ------------------------------ + -- Is_Punctuation_Connector -- + ------------------------------ - function Is_Punctuation (Item : Wide_Character) return Boolean + function Is_Punctuation_Connector (Item : Wide_Character) return Boolean renames Ada.Wide_Characters.Unicode.Is_Punctuation; -------------- diff --git a/gcc/ada/a-wichha.ads b/gcc/ada/a-wichha.ads index a9cff259f7a..583308ec6a0 100644 --- a/gcc/ada/a-wichha.ads +++ b/gcc/ada/a-wichha.ads @@ -15,10 +15,12 @@ package Ada.Wide_Characters.Handling is pragma Pure; - -- This package is clearly intended to be Pure, by analogy with the - -- base Ada.Characters.Handling package. The version in the RM does - -- not yet have this pragma, but that is a clear omission. This will - -- be fixed in a future version of AI05-0266-1. + + function Character_Set_Version return String; + pragma Inline (Character_Set_Version); + -- Returns an implementation-defined identifier that identifies the version + -- of the character set standard that is used for categorizing characters + -- by the implementation. For GNAT this is "Unicode v.v". function Is_Control (Item : Wide_Character) return Boolean; pragma Inline (Is_Control); @@ -78,13 +80,13 @@ package Ada.Wide_Characters.Handling is -- Returns True if the Wide_Character designated by Item is categorized as -- mark_non_spacing or mark_spacing_combining, otherwise returns false. - function Is_Other (Item : Wide_Character) return Boolean; - pragma Inline (Is_Other); + function Is_Other_Format (Item : Wide_Character) return Boolean; + pragma Inline (Is_Other_Format); -- Returns True if the Wide_Character designated by Item is categorized as -- other_format, otherwise returns false. - function Is_Punctuation (Item : Wide_Character) return Boolean; - pragma Inline (Is_Punctuation); + function Is_Punctuation_Connector (Item : Wide_Character) return Boolean; + pragma Inline (Is_Punctuation_Connector); -- Returns True if the Wide_Character designated by Item is categorized as -- punctuation_connector, otherwise returns false. diff --git a/gcc/ada/a-zchhan.adb b/gcc/ada/a-zchhan.adb index 483cfd9ec23..54db3ba8130 100644 --- a/gcc/ada/a-zchhan.adb +++ b/gcc/ada/a-zchhan.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2013, 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,18 +108,19 @@ package body Ada.Wide_Wide_Characters.Handling is function Is_Mark (Item : Wide_Wide_Character) return Boolean renames Ada.Wide_Wide_Characters.Unicode.Is_Mark; - -------------- - -- Is_Other -- - -------------- + --------------------- + -- Is_Other_Format -- + --------------------- - function Is_Other (Item : Wide_Wide_Character) return Boolean + function Is_Other_Format (Item : Wide_Wide_Character) return Boolean renames Ada.Wide_Wide_Characters.Unicode.Is_Other; - -------------------- - -- Is_Punctuation -- - -------------------- + ------------------------------ + -- Is_Punctuation_Connector -- + ------------------------------ - function Is_Punctuation (Item : Wide_Wide_Character) return Boolean + function Is_Punctuation_Connector + (Item : Wide_Wide_Character) return Boolean renames Ada.Wide_Wide_Characters.Unicode.Is_Punctuation; -------------- diff --git a/gcc/ada/a-zchhan.ads b/gcc/ada/a-zchhan.ads index 4c78dcd070c..354452b49f5 100644 --- a/gcc/ada/a-zchhan.ads +++ b/gcc/ada/a-zchhan.ads @@ -82,13 +82,14 @@ package Ada.Wide_Wide_Characters.Handling is -- categorized as mark_non_spacing or mark_spacing_combining, otherwise -- returns false. - function Is_Other (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Other); + function Is_Other_Format (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Other_Format); -- Returns True if the Wide_Wide_Character designated by Item is -- categorized as other_format, otherwise returns false. - function Is_Punctuation (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Punctuation); + function Is_Punctuation_Connector + (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Punctuation_Connector); -- Returns True if the Wide_Wide_Character designated by Item is -- categorized as punctuation_connector, otherwise returns false. diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index f76edb73995..3cabec95077 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -158,9 +158,9 @@ UINT CurrentCodePage; #define GCC_RESOURCE_H #include <sys/wait.h> #elif defined (__nucleus__) -/* No wait() or waitpid() calls available */ +/* No wait() or waitpid() calls available. */ #else -/* Default case */ +/* Default case. */ #include <sys/wait.h> #endif @@ -182,10 +182,12 @@ UINT CurrentCodePage; /* Use native 64-bit arithmetic. */ #define unix_time_to_vms(X,Y) \ - { unsigned long long reftime, tmptime = (X); \ + { \ + unsigned long long reftime, tmptime = (X); \ $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \ - SYS$BINTIM (&unixtime, &reftime); \ - Y = tmptime * 10000000 + reftime; } + SYS$BINTIM (&unixtime, &reftime); \ + Y = tmptime * 10000000 + reftime; \ + } /* descrip.h doesn't have everything ... */ typedef struct fibdef* __fibdef_ptr32 __attribute__ (( mode (SI) )); @@ -213,8 +215,8 @@ struct vstring #define SYI$_ACTIVECPU_CNT 0x111e extern int LIB$GETSYI (int *, unsigned int *); -extern unsigned int LIB$CALLG_64 - ( unsigned long long argument_list [], int (*user_procedure)(void)); +extern unsigned int LIB$CALLG_64 (unsigned long long argument_list [], + int (*user_procedure)(void)); #else #include <utime.h> @@ -266,7 +268,7 @@ extern unsigned int LIB$CALLG_64 #define DIR_SEPARATOR '/' #endif -/* Check for cross-compilation */ +/* Check for cross-compilation. */ #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE) #define IS_CROSS 1 int __gnat_is_cross_compiler = 1; @@ -382,13 +384,14 @@ to_ptr32 (char **ptr64) int argc; __char_ptr_char_ptr32 short_argv; - for (argc=0; ptr64[argc]; argc++); + for (argc = 0; ptr64[argc]; argc++) + ; - /* Reallocate argv with 32 bit pointers. */ + /* Reallocate argv with 32 bit pointers. */ short_argv = (__char_ptr_char_ptr32) decc$malloc (sizeof (__char_ptr32) * (argc + 1)); - for (argc=0; ptr64[argc]; argc++) + for (argc = 0; ptr64[argc]; argc++) short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]); short_argv[argc] = (__char_ptr32) 0; @@ -405,8 +408,7 @@ static const char ATTR_UNSET = 127; /* Reset the file attributes as if no system call had been performed */ void -__gnat_reset_attributes - (struct file_attributes* attr) +__gnat_reset_attributes (struct file_attributes* attr) { attr->exists = ATTR_UNSET; @@ -423,8 +425,7 @@ __gnat_reset_attributes } OS_Time -__gnat_current_time - (void) +__gnat_current_time (void) { time_t res = time (NULL); return (OS_Time) res; @@ -435,8 +436,7 @@ __gnat_current_time long. */ void -__gnat_current_time_string - (char *result) +__gnat_current_time_string (char *result) { const char *format = "%Y-%m-%d %H:%M:%S"; /* Format string necessary to describe the ISO 8601 format */ @@ -455,14 +455,8 @@ __gnat_current_time_string } void -__gnat_to_gm_time - (OS_Time *p_time, - int *p_year, - int *p_month, - int *p_day, - int *p_hours, - int *p_mins, - int *p_secs) +__gnat_to_gm_time (OS_Time *p_time, int *p_year, int *p_month, int *p_day, + int *p_hours, int *p_mins, int *p_secs) { struct tm *res; time_t time = (time_t) *p_time; @@ -1877,9 +1871,8 @@ __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf) int __gnat_file_exists_attr (char* name, struct file_attributes* attr) { - if (attr->exists == ATTR_UNSET) { - __gnat_stat_to_attr (-1, name, attr); - } + if (attr->exists == ATTR_UNSET) + __gnat_stat_to_attr (-1, name, attr); return attr->exists; } @@ -1934,9 +1927,8 @@ __gnat_is_absolute_path (char *name, int length) int __gnat_is_regular_file_attr (char* name, struct file_attributes* attr) { - if (attr->regular == ATTR_UNSET) { - __gnat_stat_to_attr (-1, name, attr); - } + if (attr->regular == ATTR_UNSET) + __gnat_stat_to_attr (-1, name, attr); return attr->regular; } @@ -1945,6 +1937,7 @@ int __gnat_is_regular_file (char *name) { struct file_attributes attr; + __gnat_reset_attributes (&attr); return __gnat_is_regular_file_attr (name, &attr); } @@ -1952,9 +1945,8 @@ __gnat_is_regular_file (char *name) int __gnat_is_directory_attr (char* name, struct file_attributes* attr) { - if (attr->directory == ATTR_UNSET) { - __gnat_stat_to_attr (-1, name, attr); - } + if (attr->directory == ATTR_UNSET) + __gnat_stat_to_attr (-1, name, attr); return attr->directory; } @@ -1963,6 +1955,7 @@ int __gnat_is_directory (char *name) { struct file_attributes attr; + __gnat_reset_attributes (&attr); return __gnat_is_directory_attr (name, &attr); } @@ -1994,7 +1987,8 @@ GetDriveTypeFromPath (TCHAR *wfullpath) /* Is this a relative path, if so get current drive type. */ if (wpath[0] != _T('\\') || - (_tcslen (wpath) > 2 && wpath[0] == _T('\\') && wpath[1] != _T('\\'))) + (_tcslen (wpath) > 2 && wpath[0] == _T('\\') + && wpath[1] != _T('\\'))) return GetDriveType (NULL); UINT result = GetDriveType (wpath); @@ -2012,7 +2006,8 @@ GetDriveTypeFromPath (TCHAR *wfullpath) LPTSTR b = _tcschr (p, _T('\\')); if (b != NULL) - { /* logical drive \\.\c\dir\file */ + { + /* logical drive \\.\c\dir\file */ *b++ = _T(':'); *b++ = _T('\\'); *b = _T('\0'); @@ -2027,12 +2022,11 @@ GetDriveTypeFromPath (TCHAR *wfullpath) } } -/* This MingW section contains code to work with ACL. */ +/* This MingW section contains code to work with ACL. */ static int -__gnat_check_OWNER_ACL -(TCHAR *wname, - DWORD CheckAccessDesired, - GENERIC_MAPPING CheckGenericMapping) +__gnat_check_OWNER_ACL (TCHAR *wname, + DWORD CheckAccessDesired, + GENERIC_MAPPING CheckGenericMapping) { DWORD dwAccessDesired, dwAccessAllowed; PRIVILEGE_SET PrivilegeSet; @@ -2051,7 +2045,7 @@ __gnat_check_OWNER_ACL (GetProcessHeap (), HEAP_ZERO_MEMORY, nLength)) == NULL) return 0; - /* Obtain the security descriptor. */ + /* Obtain the security descriptor. */ if (!GetFileSecurity (wname, OWNER_SECURITY_INFORMATION | @@ -2099,10 +2093,9 @@ __gnat_check_OWNER_ACL } static void -__gnat_set_OWNER_ACL -(TCHAR *wname, - DWORD AccessMode, - DWORD AccessPermissions) +__gnat_set_OWNER_ACL (TCHAR *wname, + DWORD AccessMode, + DWORD AccessPermissions) { PACL pOldDACL = NULL; PACL pNewDACL = NULL; @@ -2160,26 +2153,27 @@ __gnat_can_use_acl (TCHAR *wname) int __gnat_is_readable_file_attr (char* name, struct file_attributes* attr) { - if (attr->readable == ATTR_UNSET) { + if (attr->readable == ATTR_UNSET) + { #if defined (_WIN32) && !defined (RTX) - TCHAR wname [GNAT_MAX_PATH_LEN + 2]; - GENERIC_MAPPING GenericMapping; + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; - S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); - if (__gnat_can_use_acl (wname)) - { - ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); - GenericMapping.GenericRead = GENERIC_READ; - attr->readable = - __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping); - } - else - attr->readable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES; + if (__gnat_can_use_acl (wname)) + { + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericRead = GENERIC_READ; + attr->readable = + __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping); + } + else + attr->readable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES; #else - __gnat_stat_to_attr (-1, name, attr); + __gnat_stat_to_attr (-1, name, attr); #endif - } + } return attr->readable; } @@ -2188,6 +2182,7 @@ int __gnat_is_readable_file (char *name) { struct file_attributes attr; + __gnat_reset_attributes (&attr); return __gnat_is_readable_file_attr (name, &attr); } @@ -2195,29 +2190,31 @@ __gnat_is_readable_file (char *name) int __gnat_is_writable_file_attr (char* name, struct file_attributes* attr) { - if (attr->writable == ATTR_UNSET) { + if (attr->writable == ATTR_UNSET) + { #if defined (_WIN32) && !defined (RTX) - TCHAR wname [GNAT_MAX_PATH_LEN + 2]; - GENERIC_MAPPING GenericMapping; + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; - S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); - if (__gnat_can_use_acl (wname)) - { - ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); - GenericMapping.GenericWrite = GENERIC_WRITE; + if (__gnat_can_use_acl (wname)) + { + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericWrite = GENERIC_WRITE; - attr->writable = __gnat_check_OWNER_ACL + attr->writable = __gnat_check_OWNER_ACL (wname, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping) && !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY); - } - else - attr->writable = !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY); + } + else + attr->writable = + !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY); #else - __gnat_stat_to_attr (-1, name, attr); + __gnat_stat_to_attr (-1, name, attr); #endif - } + } return attr->writable; } @@ -2226,6 +2223,7 @@ int __gnat_is_writable_file (char *name) { struct file_attributes attr; + __gnat_reset_attributes (&attr); return __gnat_is_writable_file_attr (name, &attr); } @@ -2233,36 +2231,39 @@ __gnat_is_writable_file (char *name) int __gnat_is_executable_file_attr (char* name, struct file_attributes* attr) { - if (attr->executable == ATTR_UNSET) { + if (attr->executable == ATTR_UNSET) + { #if defined (_WIN32) && !defined (RTX) - TCHAR wname [GNAT_MAX_PATH_LEN + 2]; - GENERIC_MAPPING GenericMapping; + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + GENERIC_MAPPING GenericMapping; - S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); - if (__gnat_can_use_acl (wname)) - { - ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); - GenericMapping.GenericExecute = GENERIC_EXECUTE; + if (__gnat_can_use_acl (wname)) + { + ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING)); + GenericMapping.GenericExecute = GENERIC_EXECUTE; - attr->executable = - __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping); - } - else - { - TCHAR *l, *last = _tcsstr(wname, _T(".exe")); + attr->executable = + __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping); + } + else + { + TCHAR *l, *last = _tcsstr(wname, _T(".exe")); - /* look for last .exe */ - if (last) - while ((l = _tcsstr(last+1, _T(".exe")))) last = l; + /* look for last .exe */ + if (last) + while ((l = _tcsstr(last+1, _T(".exe")))) + last = l; - attr->executable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES - && (last - wname) == (int) (_tcslen (wname) - 4); - } + attr->executable = + GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES + && (last - wname) == (int) (_tcslen (wname) - 4); + } #else - __gnat_stat_to_attr (-1, name, attr); + __gnat_stat_to_attr (-1, name, attr); #endif - } + } return attr->regular && attr->executable; } @@ -2271,6 +2272,7 @@ int __gnat_is_executable_file (char *name) { struct file_attributes attr; + __gnat_reset_attributes (&attr); return __gnat_is_executable_file_attr (name, &attr); } @@ -2399,19 +2401,20 @@ int __gnat_is_symbolic_link_attr (char* name ATTRIBUTE_UNUSED, struct file_attributes* attr) { - if (attr->symbolic_link == ATTR_UNSET) { + if (attr->symbolic_link == ATTR_UNSET) + { #if defined (__vxworks) || defined (__nucleus__) - attr->symbolic_link = 0; + attr->symbolic_link = 0; #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__) - int ret; - GNAT_STRUCT_STAT statbuf; - ret = GNAT_LSTAT (name, &statbuf); - attr->symbolic_link = (!ret && S_ISLNK (statbuf.st_mode)); + int ret; + GNAT_STRUCT_STAT statbuf; + ret = GNAT_LSTAT (name, &statbuf); + attr->symbolic_link = (!ret && S_ISLNK (statbuf.st_mode)); #else - attr->symbolic_link = 0; + attr->symbolic_link = 0; #endif - } + } return attr->symbolic_link; } @@ -2419,9 +2422,9 @@ int __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED) { struct file_attributes attr; + __gnat_reset_attributes (&attr); return __gnat_is_symbolic_link_attr (name, &attr); - } #if defined (sun) && defined (__SVR4) @@ -2576,7 +2579,9 @@ __gnat_number_of_cpus (void) for locking and unlocking tasks since we do not support multiple threads on this configuration (Cert run time on native Windows). */ -void dummy (void) {} +static void dummy (void) +{ +} void (*Lock_Task) () = &dummy; void (*Unlock_Task) () = &dummy; @@ -2836,8 +2841,8 @@ __gnat_os_exit (int status) /* Locate file on path, that matches a predicate */ char * -__gnat_locate_file_with_predicate - (char *file_name, char *path_val, int (*predicate)(char*)) +__gnat_locate_file_with_predicate (char *file_name, char *path_val, + int (*predicate)(char *)) { char *ptr; char *file_path = (char *) alloca (strlen (file_name) + 1); @@ -3118,7 +3123,7 @@ __gnat_to_canonical_file_list_init (char *filespec, int onlydirs) /* Return the next filespec in the list. */ char * -__gnat_to_canonical_file_list_next () +__gnat_to_canonical_file_list_next (void) { return new_canonical_filelist[new_canonical_filelist_index++]; } @@ -3126,7 +3131,7 @@ __gnat_to_canonical_file_list_next () /* Free storage used in the wildcard expansion. */ void -__gnat_to_canonical_file_list_free () +__gnat_to_canonical_file_list_free (void) { int i; @@ -3144,7 +3149,7 @@ __gnat_to_canonical_file_list_free () /* The functional equivalent of decc$translate_vms routine. Designed to produce the same output, but is protected against malformed paths (original version ACCVIOs in this case) and - does not require VMS-specific DECC RTL */ + does not require VMS-specific DECC RTL. */ #define NAM$C_MAXRSS 1024 @@ -3161,13 +3166,13 @@ __gnat_translate_vms (char *src) srcendpos = strchr (src, '\0'); retpos = retbuf; - /* Look for the node and/or device in front of the path */ + /* Look for the node and/or device in front of the path. */ pos1 = src; pos2 = strchr (pos1, ':'); if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':')) { - /* There is a node name. "node_name::" becomes "node_name!" */ + /* There is a node name. "node_name::" becomes "node_name!". */ disp = pos2 - pos1; strncpy (retbuf, pos1, disp); retpos [disp] = '!'; @@ -3178,7 +3183,7 @@ __gnat_translate_vms (char *src) if (pos2) { - /* There is a device name. "dev_name:" becomes "/dev_name/" */ + /* There is a device name. "dev_name:" becomes "/dev_name/". */ *(retpos++) = '/'; disp = pos2 - pos1; strncpy (retpos, pos1, disp); @@ -3188,7 +3193,7 @@ __gnat_translate_vms (char *src) } else /* No explicit device; we must look ahead and prepend /sys$disk/ if - the path is absolute */ + the path is absolute. */ if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos) && !strchr (".-]>", *(pos1 + 1))) { @@ -3196,14 +3201,14 @@ __gnat_translate_vms (char *src) retpos += 10; } - /* Process the path part */ + /* Process the path part. */ while (*pos1 == '[' || *pos1 == '<') { path_present++; pos1++; if (*pos1 == ']' || *pos1 == '>') { - /* Special case, [] translates to '.' */ + /* Special case, [] translates to '.'. */ *(retpos++) = '.'; pos1++; } @@ -3211,7 +3216,7 @@ __gnat_translate_vms (char *src) { /* '[000000' means root dir. It can be present in the middle of the path due to expansion of logical devices, in which case - we skip it */ + we skip it. */ if (!strncmp (pos1, "000000", 6) && path_present > 1 && (*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.')) { @@ -3220,24 +3225,27 @@ __gnat_translate_vms (char *src) } else if (*pos1 == '.') { - /* Relative path */ + /* Relative path. */ *(retpos++) = '.'; } - /* There is a qualified path */ + /* There is a qualified path. */ while (*pos1 && *pos1 != ']' && *pos1 != '>') { switch (*pos1) { case '.': - /* '.' is used to separate directories. Replace it with '/' but - only if there isn't already '/' just before */ + /* '.' is used to separate directories. Replace it with '/' + but only if there isn't already '/' just before. */ if (*(retpos - 1) != '/') *(retpos++) = '/'; pos1++; - if (pos1 + 1 < srcendpos && *pos1 == '.' && *(pos1 + 1) == '.') + if (pos1 + 1 < srcendpos + && *pos1 == '.' + && *(pos1 + 1) == '.') { - /* ellipsis refers to entire subtree; replace with '**' */ + /* Ellipsis refers to entire subtree; replace + with '**'. */ *(retpos++) = '*'; *(retpos++) = '*'; *(retpos++) = '/'; @@ -3245,8 +3253,8 @@ __gnat_translate_vms (char *src) } break; case '-' : - /* When after '.' '[' '<' is equivalent to Unix ".." but there - may be several in a row */ + /* When after '.' '[' '<' is equivalent to Unix ".." but + there may be several in a row. */ if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' || *(pos1 - 1) == '<') { @@ -3260,7 +3268,7 @@ __gnat_translate_vms (char *src) retpos--; break; } - /* otherwise fall through to default */ + /* Otherwise fall through to default. */ default: *(retpos++) = *(pos1++); } @@ -3500,7 +3508,7 @@ __gnat_to_host_file_spec (char *filespec) } void -__gnat_adjust_os_resource_limits () +__gnat_adjust_os_resource_limits (void) { SYS$ADJWSL (131072, 0); } @@ -3510,8 +3518,8 @@ __gnat_adjust_os_resource_limits () /* Dummy functions for Osint import for non-VMS systems. */ int -__gnat_to_canonical_file_list_init - (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED) +__gnat_to_canonical_file_list_init (char *dirspec ATTRIBUTE_UNUSED, + int onlydirs ATTRIBUTE_UNUSED) { return 0; } @@ -3567,7 +3575,7 @@ __gnat_adjust_os_resource_limits (void) #if defined (__mips_vxworks) int -_flush_cache() +_flush_cache (void) { CACHE_USER_FLUSH (0, ENTIRE_CACHE); } @@ -3811,9 +3819,9 @@ __gnat_sals_init_using_constructors (void) we introduce an intermediate procedure to link against the corresponding one in each situation. */ -extern void GetTimeAsFileTime(LPFILETIME pTime); +extern void GetTimeAsFileTime (LPFILETIME pTime); -void GetTimeAsFileTime(LPFILETIME pTime) +void GetTimeAsFileTime (LPFILETIME pTime) { #ifdef RTSS RtGetRtssTimeAsFileTime (pTime); /* RTSS interface */ @@ -3829,15 +3837,18 @@ void GetTimeAsFileTime(LPFILETIME pTime) extern void __main (void); -void __main (void) {} -#endif -#endif +void __main (void) +{ +} +#endif /* RTSS */ +#endif /* RTX */ #if defined (__ANDROID__) #include <pthread.h> -void *__gnat_lwp_self (void) +void * +__gnat_lwp_self (void) { return (void *) pthread_self (); } @@ -3847,7 +3858,8 @@ void *__gnat_lwp_self (void) thread. We need to do a system call in order to retrieve this information. */ #include <sys/syscall.h> -void *__gnat_lwp_self (void) +void * +__gnat_lwp_self (void) { return (void *) syscall (__NR_gettid); } @@ -3862,65 +3874,103 @@ void *__gnat_lwp_self (void) /* Dynamic cpu sets */ -cpu_set_t *__gnat_cpu_alloc (size_t count) +cpu_set_t * +__gnat_cpu_alloc (size_t count) { return CPU_ALLOC (count); } -size_t __gnat_cpu_alloc_size (size_t count) +size_t +__gnat_cpu_alloc_size (size_t count) { return CPU_ALLOC_SIZE (count); } -void __gnat_cpu_free (cpu_set_t *set) +void +__gnat_cpu_free (cpu_set_t *set) { CPU_FREE (set); } -void __gnat_cpu_zero (size_t count, cpu_set_t *set) +void +__gnat_cpu_zero (size_t count, cpu_set_t *set) { CPU_ZERO_S (count, set); } -void __gnat_cpu_set (int cpu, size_t count, cpu_set_t *set) +void +__gnat_cpu_set (int cpu, size_t count, cpu_set_t *set) { /* Ada handles CPU numbers starting from 1, while C identifies the first CPU by a 0, so we need to adjust. */ CPU_SET_S (cpu - 1, count, set); } -#else +#else /* !CPU_ALLOC */ /* Static cpu sets */ -cpu_set_t *__gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED) +cpu_set_t * +__gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED) { return (cpu_set_t *) xmalloc (sizeof (cpu_set_t)); } -size_t __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED) +size_t +__gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED) { return sizeof (cpu_set_t); } -void __gnat_cpu_free (cpu_set_t *set) +void +__gnat_cpu_free (cpu_set_t *set) { free (set); } -void __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED, cpu_set_t *set) +void +__gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED, cpu_set_t *set) { CPU_ZERO (set); } -void __gnat_cpu_set (int cpu, size_t count ATTRIBUTE_UNUSED, cpu_set_t *set) +void +__gnat_cpu_set (int cpu, size_t count ATTRIBUTE_UNUSED, cpu_set_t *set) { /* Ada handles CPU numbers starting from 1, while C identifies the first CPU by a 0, so we need to adjust. */ CPU_SET (cpu - 1, set); } +#endif /* !CPU_ALLOC */ +#endif /* linux */ + +/* Return the load address of the executable, or 0 if not known. In the + specific case of error, (void *)-1 can be returned. Beware: this unit may + be in a shared library. As low-level units are needed, we allow #include + here. */ + +#if defined (__APPLE__) +#include <mach-o/dyld.h> +#elif 0 && defined (__linux__) +#include <link.h> #endif + +const void * +__gnat_get_executable_load_address (void) +{ +#if defined (__APPLE__) + return _dyld_get_image_header (0); + +#elif 0 && defined (__linux__) + /* Currently disabled as it needs at least -ldl. */ + struct link_map *map = _r_debug.r_map; + + return (const void *)map->l_addr; + +#else + return NULL; #endif +} #ifdef __cplusplus } diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 78af57c9dae..554d848f736 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -287,6 +287,8 @@ extern int get_gcc_version (void); extern int __gnat_binder_supports_auto_init (void); extern int __gnat_sals_init_using_constructors (void); +extern const void * __gnat_get_executable_load_address (void); + #ifdef __cplusplus } #endif diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 6c2f8187a92..aff6740f405 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -186,9 +186,13 @@ package body ALI is function Getc return Character; -- Get next character, bumping P past the character obtained - function Get_File_Name (Lower : Boolean := False) return File_Name_Type; + function Get_File_Name + (Lower : Boolean := False; + May_Be_Quoted : Boolean := False) return File_Name_Type; -- Skip blanks, then scan out a file name (name is left in Name_Buffer -- with length in Name_Len, as well as returning a File_Name_Type value. + -- If May_Be_Quoted is True and the first non blank character is '"', + -- then remove starting and ending quotes and undoubled internal quotes. -- If lower is false, the case is unchanged, if Lower is True then the -- result is forced to all lower case for systems where file names are -- not case sensitive. This ensures that gnatbind works correctly @@ -198,7 +202,8 @@ package body ALI is function Get_Name (Ignore_Spaces : Boolean := False; - Ignore_Special : Boolean := False) return Name_Id; + Ignore_Special : Boolean := False; + May_Be_Quoted : Boolean := False) return Name_Id; -- Skip blanks, then scan out a name (name is left in Name_Buffer with -- length in Name_Len, as well as being returned in Name_Id form). -- If Lower is set to True then the Name_Buffer will be converted to @@ -215,6 +220,10 @@ package body ALI is -- an operator name starting with a double quote which is terminated -- by another double quote. -- + -- If May_Be_Quoted is True and the first non blank character is '"' + -- the name is 'unquoted'. In this case Ignore_Special is ignored and + -- assumed to be True. + -- -- It is an error to set both Ignore_Spaces and Ignore_Special to True. -- This function handles wide characters properly. @@ -450,12 +459,14 @@ package body ALI is ------------------- function Get_File_Name - (Lower : Boolean := False) return File_Name_Type + (Lower : Boolean := False; + May_Be_Quoted : Boolean := False) return File_Name_Type is F : Name_Id; begin - F := Get_Name (Ignore_Special => True); + F := Get_Name (Ignore_Special => True, + May_Be_Quoted => May_Be_Quoted); -- Convert file name to all lower case if file names are not case -- sensitive. This ensures that we handle names in the canonical @@ -475,8 +486,11 @@ package body ALI is function Get_Name (Ignore_Spaces : Boolean := False; - Ignore_Special : Boolean := False) return Name_Id + Ignore_Special : Boolean := False; + May_Be_Quoted : Boolean := False) return Name_Id is + Char : Character; + begin Name_Len := 0; Skip_Space; @@ -489,38 +503,79 @@ package body ALI is end if; end if; - loop - Add_Char_To_Name_Buffer (Getc); + Char := Getc; - exit when At_End_Of_Field and then not Ignore_Spaces; + -- Deal with quoted characters - if not Ignore_Special then - if Name_Buffer (1) = '"' then - exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"'; + if May_Be_Quoted and then Char = '"' then + loop + if At_Eol then + if Ignore_Errors then + return Error_Name; + else + Fatal_Error; + end if; + end if; - else - -- Terminate on parens or angle brackets or equal sign + Char := Getc; - exit when Nextc = '(' or else Nextc = ')' - or else Nextc = '{' or else Nextc = '}' - or else Nextc = '<' or else Nextc = '>' - or else Nextc = '='; + if Char = '"' then + if At_Eol then + exit; - -- Terminate on comma + else + Char := Getc; - exit when Nextc = ','; + if Char /= '"' then + P := P - 1; + exit; + end if; + end if; + end if; - -- Terminate if left bracket not part of wide char sequence - -- Note that we only recognize brackets notation so far ??? + Add_Char_To_Name_Buffer (Char); + end loop; - exit when Nextc = '[' and then T (P + 1) /= '"'; + -- Other than case of quoted character - -- Terminate if right bracket not part of wide char sequence + else + P := P - 1; + loop + Add_Char_To_Name_Buffer (Getc); + + exit when At_End_Of_Field and then not Ignore_Spaces; + + if not Ignore_Special then + if Name_Buffer (1) = '"' then + exit when Name_Len > 1 + and then Name_Buffer (Name_Len) = '"'; + + else + -- Terminate on parens or angle brackets or equal sign + + exit when Nextc = '(' or else Nextc = ')' + or else Nextc = '{' or else Nextc = '}' + or else Nextc = '<' or else Nextc = '>' + or else Nextc = '='; + + -- Terminate on comma + + exit when Nextc = ','; + + -- Terminate if left bracket not part of wide char + -- sequence Note that we only recognize brackets + -- notation so far ??? - exit when Nextc = ']' and then T (P - 1) /= '"'; + exit when Nextc = '[' and then T (P + 1) /= '"'; + + -- Terminate if right bracket not part of wide char + -- sequence. + + exit when Nextc = ']' and then T (P - 1) /= '"'; + end if; end if; - end if; - end loop; + end loop; + end if; return Name_Find; end Get_Name; @@ -2224,7 +2279,10 @@ package body ALI is -- In the following call, Lower is not set to True, this is either -- a bug, or it deserves a special comment as to why this is so??? - Sdep.Table (Sdep.Last).Sfile := Get_File_Name; + -- The file/path name may be quoted + + Sdep.Table (Sdep.Last).Sfile := + Get_File_Name (May_Be_Quoted => True); Sdep.Table (Sdep.Last).Stamp := Get_Stamp; Sdep.Table (Sdep.Last).Dummy_Entry := diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 1d736467b46..091af77ef77 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -140,11 +140,11 @@ package body Aspects is end if; end Aspect_Specifications; - ------------------------ - -- Aspects_On_Body_OK -- - ------------------------ + -------------------------------- + -- Aspects_On_Body_Or_Stub_OK -- + -------------------------------- - function Aspects_On_Body_OK (N : Node_Id) return Boolean is + function Aspects_On_Body_Or_Stub_OK (N : Node_Id) return Boolean is Aspect : Node_Id; Aspects : List_Id; @@ -159,12 +159,12 @@ package body Aspects is N_Task_Body)); -- Look through all aspects and see whether they can be applied to a - -- body. + -- body [stub]. Aspects := Aspect_Specifications (N); Aspect := First (Aspects); while Present (Aspect) loop - if not Aspect_On_Body_OK (Get_Aspect_Id (Aspect)) then + if not Aspect_On_Body_Or_Stub_OK (Get_Aspect_Id (Aspect)) then return False; end if; @@ -172,7 +172,7 @@ package body Aspects is end loop; return True; - end Aspects_On_Body_OK; + end Aspects_On_Body_Or_Stub_OK; ----------------- -- Find_Aspect -- @@ -368,9 +368,9 @@ package body Aspects is N_Single_Protected_Declaration => True, N_Single_Task_Declaration => True, N_Subprogram_Body => True, + N_Subprogram_Body_Stub => True, N_Subprogram_Declaration => True, N_Subprogram_Renaming_Declaration => True, - N_Subprogram_Body_Stub => True, N_Subtype_Declaration => True, N_Task_Body => True, N_Task_Body_Stub => True, @@ -440,6 +440,8 @@ package body Aspects is Aspect_Independent_Components => Aspect_Independent_Components, Aspect_Inline => Aspect_Inline, Aspect_Inline_Always => Aspect_Inline, + Aspect_Initial_Condition => Aspect_Initial_Condition, + Aspect_Initializes => Aspect_Initializes, Aspect_Input => Aspect_Input, Aspect_Interrupt_Handler => Aspect_Interrupt_Handler, Aspect_Interrupt_Priority => Aspect_Priority, @@ -466,6 +468,10 @@ package body Aspects is Aspect_Pure_05 => Aspect_Pure_05, Aspect_Pure_12 => Aspect_Pure_12, Aspect_Pure_Function => Aspect_Pure_Function, + Aspect_Refined_Depends => Aspect_Refined_Depends, + Aspect_Refined_Global => Aspect_Refined_Global, + Aspect_Refined_Post => Aspect_Refined_Post, + Aspect_Refined_State => Aspect_Refined_State, Aspect_Remote_Access_Type => Aspect_Remote_Access_Type, Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface, Aspect_Remote_Types => Aspect_Remote_Types, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 5e8046d1ad0..2fd4b451bb0 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -96,6 +96,8 @@ package Aspects is Aspect_External_Tag, Aspect_Global, -- GNAT Aspect_Implicit_Dereference, + Aspect_Initial_Condition, -- GNAT + Aspect_Initializes, -- GNAT Aspect_Input, Aspect_Interrupt_Priority, Aspect_Invariant, -- GNAT @@ -111,6 +113,10 @@ package Aspects is Aspect_Predicate, -- GNAT Aspect_Priority, Aspect_Read, + Aspect_Refined_Depends, -- GNAT + Aspect_Refined_Global, -- GNAT + Aspect_Refined_Post, -- GNAT + Aspect_Refined_State, -- GNAT Aspect_Relative_Deadline, Aspect_Scalar_Storage_Order, -- GNAT Aspect_Simple_Storage_Pool, -- GNAT @@ -304,6 +310,8 @@ package Aspects is Aspect_External_Tag => 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, @@ -319,6 +327,10 @@ package Aspects is 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, @@ -388,6 +400,8 @@ package Aspects is Aspect_Independent_Components => Name_Independent_Components, Aspect_Inline => Name_Inline, Aspect_Inline_Always => Name_Inline_Always, + Aspect_Initial_Condition => Name_Initial_Condition, + Aspect_Initializes => Name_Initializes, Aspect_Input => Name_Input, Aspect_Interrupt_Handler => Name_Interrupt_Handler, Aspect_Interrupt_Priority => Name_Interrupt_Priority, @@ -415,6 +429,10 @@ package Aspects is Aspect_Pure_12 => Name_Pure_12, Aspect_Pure_Function => Name_Pure_Function, Aspect_Read => Name_Read, + Aspect_Refined_Depends => Name_Refined_Depends, + Aspect_Refined_Global => Name_Refined_Global, + Aspect_Refined_Post => Name_Refined_Post, + Aspect_Refined_State => Name_Refined_State, Aspect_Relative_Deadline => Name_Relative_Deadline, Aspect_Remote_Access_Type => Name_Remote_Access_Type, Aspect_Remote_Call_Interface => Name_Remote_Call_Interface, @@ -582,6 +600,8 @@ package Aspects is Aspect_Independent_Components => Always_Delay, Aspect_Inline => Always_Delay, Aspect_Inline_Always => Always_Delay, + Aspect_Initial_Condition => Always_Delay, + Aspect_Initializes => Always_Delay, Aspect_Input => Always_Delay, Aspect_Interrupt_Handler => Always_Delay, Aspect_Interrupt_Priority => Always_Delay, @@ -606,6 +626,9 @@ package Aspects is Aspect_Pure_12 => Always_Delay, Aspect_Pure_Function => Always_Delay, Aspect_Read => Always_Delay, + Aspect_Refined_Depends => Always_Delay, + Aspect_Refined_Global => Always_Delay, + Aspect_Refined_State => Always_Delay, Aspect_Relative_Deadline => Always_Delay, Aspect_Remote_Access_Type => Always_Delay, Aspect_Remote_Call_Interface => Always_Delay, @@ -636,6 +659,7 @@ package Aspects is Aspect_Convention => Never_Delay, Aspect_Dimension => Never_Delay, Aspect_Dimension_System => Never_Delay, + Aspect_Refined_Post => Never_Delay, Aspect_SPARK_Mode => Never_Delay, Aspect_Synchronization => Never_Delay, Aspect_Test_Case => Never_Delay, @@ -657,15 +681,49 @@ package Aspects is Aspect_Volatile => Rep_Aspect, Aspect_Volatile_Components => Rep_Aspect); - -- The following table indicates which aspects can apply simultaneously to - -- both subprogram/package specs and bodies. For instance, the following is - -- legal: + ------------------------------------------------ + -- Handling of Aspect Specifications on Stubs -- + ------------------------------------------------ + + -- Aspects that appear on the following stub nodes + + -- N_Package_Body_Stub + -- N_Protected_Body_Stub + -- N_Subprogram_Body_Stub + -- N_Task_Body_Stub + + -- are treated as if they apply to the corresponding proper body. Their + -- analysis is postponed until the analysis of the proper body takes place + -- (see Analyze_Proper_Body). The delay is required because the analysis + -- may generate extra code which would be harder to relocate to the body. + -- If the proper body is present, the aspect specifications are relocated + -- to the corresponding body node: + + -- N_Package_Body + -- N_Protected_Body + -- N_Subprogram_Body + -- N_Task_Body + + -- The subsequent analysis takes care of the aspect-to-pragma conversions + -- and verification of pragma legality. In the case where the proper body + -- is not available, the aspect specifications are analyzed on the spot + -- (see Analyze_Proper_Body) to catch potential errors. + + -- The following table lists all aspects that can apply to a subprogram + -- body [stub]. For instance, the following example is legal: -- package P with SPARK_Mode ...; -- package body P with SPARK_Mode is ...; - Aspect_On_Body_OK : constant array (Aspect_Id) of Boolean := - (Aspect_SPARK_Mode => True, + -- 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. + + Aspect_On_Body_Or_Stub_OK : constant array (Aspect_Id) of Boolean := + (Aspect_Refined_Depends => True, + Aspect_Refined_Global => True, + Aspect_Refined_Post => True, + Aspect_SPARK_Mode => True, + Aspect_Warnings => True, others => False); --------------------------------------------------- @@ -696,9 +754,9 @@ package Aspects is -- Replace calls, and this function may be used to retrieve the aspect -- specifications for the original rewritten node in such cases. - function Aspects_On_Body_OK (N : Node_Id) return Boolean; + function Aspects_On_Body_Or_Stub_OK (N : Node_Id) return Boolean; -- N denotes a body [stub] with aspects. Determine whether all aspects of N - -- can appear simultaneously in bodies and specs. + -- are allowed to appear on a body [stub]. function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id; -- Find the aspect specification of aspect A associated with entity I. diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index a6105e2c427..a44a247b896 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -979,6 +979,26 @@ 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) 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; + end Ekind_In; + + function Ekind_In (E : Entity_Id; V1 : Entity_Kind; V2 : Entity_Kind) return Boolean @@ -1033,6 +1053,20 @@ package body Atree is return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6); 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) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7); + end Ekind_In; + ------------------------ -- Set_Reporting_Proc -- ------------------------ diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 123beb3907e..0f47e862f45 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -462,25 +462,26 @@ package Atree is -- with copying aspect specifications where this is required. function New_Copy (Source : Node_Id) return Node_Id; - -- This function allocates a completely new node, and then initializes it - -- by copying the contents of the source node into it. The contents of the - -- source node is not affected. The target node is always marked as not - -- being in a list (even if the source is a list member). The new node will - -- have an extension if the source has an extension. New_Copy (Empty) - -- returns Empty and New_Copy (Error) returns Error. Note that, unlike - -- Copy_Separate_Tree, New_Copy does not recursively copy any descendents, - -- so in general parent pointers are not set correctly for the descendents - -- of the copied node. Both normal and extended nodes (entities) may be - -- copied using New_Copy. + -- This function allocates a completely new node, and then initializes + -- it by copying the contents of the source node into it. The contents of + -- the source node is not affected. The target node is always marked as + -- not being in a list (even if the source is a list member), and not + -- overloaded. The new node will have an extension if the source has + -- an extension. New_Copy (Empty) returns Empty, and New_Copy (Error) + -- returns Error. Note that, unlike Copy_Separate_Tree, New_Copy does not + -- recursively copy any descendents, so in general parent pointers are not + -- set correctly for the descendents of the copied node. Both normal and + -- extended nodes (entities) may be copied using New_Copy. function Relocate_Node (Source : Node_Id) return Node_Id; -- Source is a non-entity node that is to be relocated. A new node is - -- allocated and the contents of Source are copied to this node using - -- Copy_Node. The parent pointers of descendents of the node are then + -- allocated, and the contents of Source are copied to this node, using + -- New_Copy. The parent pointers of descendents of the node are then -- adjusted to point to the relocated copy. The original node is not -- modified, but the parent pointers of its descendents are no longer - -- valid. This routine is used in conjunction with the tree rewrite - -- routines (see descriptions of Replace/Rewrite). + -- valid. The new copy is always marked as not overloaded. This routine is + -- used in conjunction with the tree rewrite routines (see descriptions of + -- Replace/Rewrite). -- -- Note that the resulting node has the same parent as the source node, and -- is thus still attached to the tree. It is valid for Source to be Empty, @@ -736,6 +737,16 @@ package Atree is V6 : 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) return Boolean; + + function Ekind_In (T : Entity_Kind; V1 : Entity_Kind; V2 : Entity_Kind) return Boolean; @@ -770,6 +781,16 @@ package Atree is V5 : Entity_Kind; V6 : 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) return Boolean; + pragma Inline (Ekind_In); -- Inline all above functions diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 29a18593167..328e05e5aaf 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Casing; use Casing; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; @@ -2189,7 +2190,9 @@ package body Checks is Formal_2 : Entity_Id; Check : in out Node_Id) is - Cond : Node_Id; + Cond : Node_Id; + ID_Casing : constant Casing_Type := + Identifier_Casing (Source_Index (Current_Sem_Unit)); begin -- Generate: @@ -2220,9 +2223,17 @@ package body Checks is end if; Store_String_Chars ("aliased parameters, actuals for """); - Store_String_Chars (Get_Name_String (Chars (Formal_1))); + + Get_Name_String (Chars (Formal_1)); + Set_Casing (ID_Casing); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Store_String_Chars (""" and """); - Store_String_Chars (Get_Name_String (Chars (Formal_2))); + + Get_Name_String (Chars (Formal_2)); + Set_Casing (ID_Casing); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Store_String_Chars (""" overlap"); Insert_Action (Call, @@ -3543,6 +3554,32 @@ package body Checks is L : Node_Id; R : Node_Id; + function Left_Expression (Op : Node_Id) return Node_Id; + -- Return the relevant expression from the left operand of the given + -- short circuit form: this is LO itself, except if LO is a qualified + -- expression, a type conversion, or an expression with actions, in + -- which case this is Left_Expression (Expression (LO)). + + --------------------- + -- Left_Expression -- + --------------------- + + function Left_Expression (Op : Node_Id) return Node_Id is + LE : Node_Id := Left_Opnd (Op); + begin + while Nkind_In (LE, + N_Qualified_Expression, + N_Type_Conversion, + N_Expression_With_Actions) + loop + LE := Expression (LE); + end loop; + + return LE; + end Left_Expression; + + -- Start of processing for Check_Needed + begin -- Always check if not simple entity @@ -3576,37 +3613,40 @@ package body Checks is elsif K = N_Op_Or then exit when N = Right_Opnd (P) - and then Nkind (Left_Opnd (P)) = N_Op_Eq; + and then Nkind (Left_Expression (P)) = N_Op_Eq; elsif K = N_Or_Else then exit when (N = Right_Opnd (P) or else (Is_List_Member (N) and then List_Containing (N) = Actions (P))) - and then Nkind (Left_Opnd (P)) = N_Op_Eq; + and then Nkind (Left_Expression (P)) = N_Op_Eq; -- Similar test for the And/And then case, where the left operand -- is an inequality test. elsif K = N_Op_And then exit when N = Right_Opnd (P) - and then Nkind (Left_Opnd (P)) = N_Op_Ne; + and then Nkind (Left_Expression (P)) = N_Op_Ne; elsif K = N_And_Then then exit when (N = Right_Opnd (P) or else (Is_List_Member (N) and then List_Containing (N) = Actions (P))) - and then Nkind (Left_Opnd (P)) = N_Op_Ne; + and then Nkind (Left_Expression (P)) = N_Op_Ne; end if; N := P; end loop; -- If we fall through the loop, then we have a conditional with an - -- appropriate test as its left operand. So test further. + -- appropriate test as its left operand, so look further. + + L := Left_Expression (P); + + -- L is an "=" or "/=" operator: extract its operands - L := Left_Opnd (P); R := Right_Opnd (L); L := Left_Opnd (L); @@ -5052,6 +5092,13 @@ package body Checks is then return; + -- For an expression with actions, we want to insert the validity check + -- on the final Expression. + + elsif Nkind (Expr) = N_Expression_With_Actions then + Ensure_Valid (Expression (Expr)); + return; + -- An annoying special case. If this is an out parameter of a scalar -- type, then the value is not going to be accessed, therefore it is -- inappropriate to do any validity check at the call site. diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 09c125dfdce..ed022388049 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -1305,6 +1305,9 @@ package body CStand is Set_Scope (Standard_Integer_64, Standard_Standard); Build_Signed_Integer_Type (Standard_Integer_64, 64); + -- Standard_Unsigned is not user visible, but is used internally. It + -- is an unsigned type with the same length as Standard.Integer. + Standard_Unsigned := New_Standard_Entity; Decl := New_Node (N_Full_Type_Declaration, Stloc); Set_Defining_Identifier (Decl, Standard_Unsigned); @@ -1329,6 +1332,32 @@ package body CStand is Set_Etype (High_Bound (R_Node), Standard_Unsigned); Set_Scalar_Range (Standard_Unsigned, R_Node); + -- Standard_Unsigned_64 is not user visible, but is used internally. It + -- is an unsigned type mod 2**64, 64-bits unsigned, size is 64. + + Standard_Unsigned_64 := New_Standard_Entity; + Decl := New_Node (N_Full_Type_Declaration, Stloc); + Set_Defining_Identifier (Decl, Standard_Unsigned_64); + Make_Name (Standard_Unsigned_64, "unsigned_64"); + + Set_Ekind (Standard_Unsigned_64, E_Modular_Integer_Type); + Set_Scope (Standard_Unsigned_64, Standard_Standard); + Set_Etype (Standard_Unsigned_64, Standard_Unsigned_64); + Init_Size (Standard_Unsigned_64, 64); + Set_Elem_Alignment (Standard_Unsigned_64); + Set_Modulus (Standard_Unsigned_64, Uint_2 ** 64); + Set_Is_Unsigned_Type (Standard_Unsigned_64); + Set_Size_Known_At_Compile_Time + (Standard_Unsigned_64); + Set_Is_Known_Valid (Standard_Unsigned_64, True); + + R_Node := New_Node (N_Range, Stloc); + Set_Low_Bound (R_Node, Make_Integer (Uint_0)); + Set_High_Bound (R_Node, Make_Integer (Uint_2 ** 64 - 1)); + Set_Etype (Low_Bound (R_Node), Standard_Unsigned_64); + Set_Etype (High_Bound (R_Node), Standard_Unsigned_64); + Set_Scalar_Range (Standard_Unsigned_64, R_Node); + -- Note: universal integer and universal real are constructed as fully -- formed signed numeric types, with parameters corresponding to the -- longest runtime types (Long_Long_Integer and Long_Long_Float). This @@ -1419,9 +1448,9 @@ package body CStand is (Type_Definition (Parent (Standard_Duration)))); -- Normally it does not matter that nodes in package Standard are - -- not marked as analyzed. The Scalar_Range of the fixed-point - -- type Standard_Duration is an exception, because of the special - -- test made in Freeze.Freeze_Fixed_Point_Type. + -- not marked as analyzed. The Scalar_Range of the fixed-point type + -- Standard_Duration is an exception, because of the special test + -- made in Freeze.Freeze_Fixed_Point_Type. Set_Analyzed (Scalar_Range (Standard_Duration)); @@ -1441,14 +1470,11 @@ package body CStand is end Build_Duration; -- Build standard exception type. Note that the type name here is - -- actually used in the generated code, so it must be set correctly - - -- ??? Also note that the Import_Code component is now declared - -- as a System.Standard_Library.Exception_Code to enforce run-time - -- library implementation consistency. It's too early here to resort - -- to rtsfind to get the proper node for that type, so we use the - -- closest possible available type node at hand instead. We should - -- probably be fixing this up at some point. + -- actually used in the generated code, so it must be set correctly. + -- The type Standard_Exception_Type must be consistent with the type + -- System.Standard_Library.Exception_Data, as the latter is what is + -- known by the run-time. Components of the record are documented in + -- the declaration in System.Standard_Library. Standard_Exception_Type := New_Standard_Entity; Set_Ekind (Standard_Exception_Type, E_Record_Type); @@ -1472,7 +1498,7 @@ package body CStand is Make_Component (Standard_Exception_Type, Standard_A_Char, "HTable_Ptr"); Make_Component - (Standard_Exception_Type, Standard_Unsigned, "Import_Code"); + (Standard_Exception_Type, Standard_A_Char, "Foreign_Data"); Make_Component (Standard_Exception_Type, Standard_A_Char, "Raise_Hook"); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 01624792c61..acda7cfc691 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -122,19 +122,19 @@ package body Debug is -- d.B -- d.C Generate concatenation call, do not generate inline code -- d.D SPARK strict mode - -- d.E Force SPARK mode for gnat2why + -- d.E Turn selected errors into warnings -- d.F SPARK mode -- d.G Frame condition mode for gnat2why - -- d.H Standard package only mode for gnat2why + -- d.H -- d.I Do not ignore enum representation clauses in CodePeer mode -- d.J Disable parallel SCIL generation mode - -- d.K SPARK detection only mode for gnat2why + -- d.K -- d.L Depend on back end for limited types in if and case expressions -- d.M Relaxed RM semantics -- d.N Add node to all entities -- d.O Dump internal SCO tables -- d.P Previous (non-optimized) handling of length comparisons - -- d.Q Flow Analysis mode for gnat2why + -- d.Q -- d.R Restrictions in ali files in positional form -- d.S Force Optimize_Alignment (Space) -- d.T Force Optimize_Alignment (Time) @@ -143,7 +143,7 @@ package body Debug is -- d.W Print out debugging information for Walk_Library_Items -- d.X -- d.Y - -- d.Z Dump flow analysis graphs, for debugging purposes (gnat2why) + -- d.Z -- d1 Error msgs have node numbers where possible -- d2 Eliminate error flags in verbose form error messages @@ -581,25 +581,25 @@ package body Debug is -- d.w This flag turns off the scanning of loops to detect possible -- infinite loops. - -- 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.x No exception handlers in generated code. This causes exception -- handlers to be eliminated from the generated code. They are still -- fully compiled and analyzed, they just get eliminated from the -- code generation step. + -- 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.C Generate call to System.Concat_n.Str_Concat_n routines in cases -- where we would normally generate inline concatenation code. -- d.D SPARK strict mode. Interpret compiler permissions as strictly as -- possible in SPARK mode. - -- d.E Force SPARK mode for gnat2why. In this mode, errors are issued for - -- all violations of SPARK in user code, and warnings are issued for - -- constructs not yet implemented in gnat2why. + -- d.E Turn selected errors into warnings. This debug switch causes a + -- specific set of error messages into warnings. Setting this switch + -- causes Opt.Error_To_Warning to be set to True. -- d.F SPARK mode. Generate AST in a form suitable for formal -- verification, as well as additional cross reference information in @@ -610,10 +610,6 @@ package body Debug is -- generate Why code. Instead, it generates ALI files with an extra -- section which contains the effects of subprograms. - -- d.H Standard package only mode for gnat2why. In this mode, gnat2why - -- will only generate Why code for package Standard. Any given input - -- file will be ignored. - -- d.I Do not ignore enum representation clauses in CodePeer mode. -- The default of ignoring representation clauses for enumeration -- types in CodePeer is good for the majority of Ada code, but in some @@ -624,9 +620,6 @@ package body Debug is -- done in parallel to speed processing. This switch disables this -- behavior. - -- d.K SPARK detection only mode for gnat2why. In this mode, gnat2why - -- does not generate Why code. - -- d.L Normally the front end generates special expansion for conditional -- expressions of a limited type. This debug flag removes this special -- case expansion, leaving it up to the back end to handle conditional @@ -648,9 +641,6 @@ package body Debug is -- This is there in case we find a situation where the optimization -- malfunctions, to provide a work around. - -- d.Q Flow Analysis mode for gnat2why. When this flag is given, - -- gnat2why will do flow analysis, and no translation to Why is done. - -- d.R As documented in lib-writ.ads, restrictions in the ali file can -- have two forms, positional and named. The named notation is the -- current preferred form, but the use of this debug switch will force @@ -675,15 +665,6 @@ package body Debug is -- the order in which units are walked. This is primarily for use in -- debugging CodePeer mode. - -- d.Z In gnat2why, in Flow analysis mode (-gnatd.Q), dump the different - -- graphs (control flow, control dependence) for debugging purposes. - -- This debug flag will be removed when flow analysis is sufficiently - -- stable. - - -- d.Y Prevents the use of the N_Expression_With_Actions node even in the - -- case of the gcc back end. Provided as a back up in case the new - -- scheme has problems. - -- d1 Error messages have node numbers where possible. Normally error -- messages have only source locations. This option is useful when -- debugging errors caused by expanded code, where the source location diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 1da975d0a9e..5a8757bac40 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -33,6 +33,7 @@ pragma Style_Checks (All_Checks); -- Turn off subprogram ordering, not used for this unit with Atree; use Atree; +with Elists; use Elists; with Namet; use Namet; with Nlists; use Nlists; with Output; use Output; @@ -76,16 +77,15 @@ package body Einfo is -- Associated_Node_For_Itype Node8 -- Dependent_Instances Elist8 -- Hiding_Loop_Variable Node8 - -- Integrity_Level Uint8 -- Mechanism Uint8 (but returns Mechanism_Type) -- Normalized_First_Bit Uint8 -- Postcondition_Proc Node8 + -- Refinement_Constituents Elist8 -- Return_Applies_To Node8 -- First_Exit_Statement Node8 -- Class_Wide_Type Node9 -- Current_Value Node9 - -- Refined_State Node9 -- Renaming_Map Uint9 -- Direct_Primitive_Operations Elist10 @@ -93,6 +93,7 @@ package body Einfo is -- Float_Rep Uint10 (but returns Float_Rep_Kind) -- Handler_Records List10 -- Normalized_Position_Max Uint10 + -- Refined_State Node10 -- Component_Bit_Offset Uint11 -- Full_View Node11 @@ -131,6 +132,7 @@ package body Einfo is -- String_Literal_Low_Bound Node15 -- Access_Disp_Table Elist16 + -- Body_References Elist16 -- Cloned_Subtype Node16 -- DTC_Entity Node16 -- Entry_Formal Node16 @@ -211,7 +213,6 @@ package body Einfo is -- Protection_Object Node23 -- Stored_Constraint Elist23 - -- Finalizer Node24 -- Related_Expression Node24 -- Contract Node24 @@ -236,6 +237,7 @@ package body Einfo is -- Wrapped_Entity Node27 -- Extra_Formals Node28 + -- Finalizer Node28 -- Initialization_Statements Node28 -- Underlying_Record_View Node28 @@ -435,7 +437,7 @@ package body Einfo is -- Referenced Flag156 -- Has_Pragma_Inline Flag157 -- Finalize_Storage_Only Flag158 - -- From_With_Type Flag159 + -- From_Limited_With Flag159 -- Is_Package_Body_Entity Flag160 -- Has_Qualified_Name Flag161 @@ -550,9 +552,9 @@ package body Einfo is -- Has_Delayed_Rep_Aspects Flag261 -- May_Inherit_Delayed_Rep_Aspects Flag262 + -- Has_Visible_Refinement Flag263 + -- Has_Body_References Flag264 - -- (unused) Flag263 - -- (unused) Flag264 -- (unused) Flag265 -- (unused) Flag266 -- (unused) Flag267 @@ -584,11 +586,11 @@ package body Einfo is -- Local subprograms -- ----------------------- - function Has_Property - (State : Entity_Id; - Prop_Nam : Name_Id) return Boolean; - -- Determine whether abstract state State has a particular property denoted - -- by the name Prop_Nam. + function Has_Option + (State : Entity_Id; + Opt_Nam : Name_Id) return Boolean; + -- Determine whether abstract state State has a particular option denoted + -- by the name Opt_Nam. --------------- -- Float_Rep -- @@ -600,40 +602,40 @@ package body Einfo is return F'Val (UI_To_Int (Uint10 (Base_Type (Id)))); end Float_Rep; - ------------------ - -- Has_Property -- - ------------------ + ---------------- + -- Has_Option -- + ---------------- - function Has_Property - (State : Entity_Id; - Prop_Nam : Name_Id) return Boolean + function Has_Option + (State : Entity_Id; + Opt_Nam : Name_Id) return Boolean is - Par : constant Node_Id := Parent (State); - Prop : Node_Id; + Par : constant Node_Id := Parent (State); + Opt : Node_Id; begin pragma Assert (Ekind (State) = E_Abstract_State); - -- States with properties appear as extension aggregates in the tree + -- States with options appear as extension aggregates in the tree if Nkind (Par) = N_Extension_Aggregate then - if Prop_Nam = Name_Integrity then + if Opt_Nam = Name_Part_Of then return Present (Component_Associations (Par)); else - Prop := First (Expressions (Par)); - while Present (Prop) loop - if Chars (Prop) = Prop_Nam then + Opt := First (Expressions (Par)); + while Present (Opt) loop + if Chars (Opt) = Opt_Nam then return True; end if; - Next (Prop); + Next (Opt); end loop; end if; end if; return False; - end Has_Property; + end Has_Option; -------------------------------- -- Attribute Access Functions -- @@ -732,6 +734,12 @@ package body Einfo is return Flag40 (Id); end Body_Needed_For_SAL; + function Body_References (Id : E) return L is + begin + pragma Assert (Ekind (Id) = E_Abstract_State); + return Elist16 (Id); + end Body_References; + function C_Pass_By_Copy (Id : E) return B is begin pragma Assert (Is_Record_Type (Id)); @@ -852,13 +860,13 @@ package body Einfo is function Default_Aspect_Component_Value (Id : E) return N is begin pragma Assert (Is_Array_Type (Id)); - return Node19 (Id); + return Node19 (Base_Type (Id)); end Default_Aspect_Component_Value; function Default_Aspect_Value (Id : E) return N is begin pragma Assert (Is_Scalar_Type (Id)); - return Node19 (Id); + return Node19 (Base_Type (Id)); end Default_Aspect_Value; function Default_Expr_Function (Id : E) return E is @@ -1066,9 +1074,14 @@ package body Einfo is function Contract (Id : E) return N is begin pragma Assert - (Ekind_In (Id, E_Entry, E_Entry_Family) - or else Is_Subprogram (Id) - or else Is_Generic_Subprogram (Id)); + (Ekind_In (Id, E_Entry, + E_Entry_Family, + E_Generic_Package, + E_Package, + E_Package_Body, + E_Subprogram_Body) + or else Is_Generic_Subprogram (Id) + or else Is_Subprogram (Id)); return Node24 (Id); end Contract; @@ -1106,6 +1119,7 @@ package body Einfo is pragma Assert (Ekind_In (Id, E_Class_Wide_Type, E_Class_Wide_Subtype, + E_Access_Subprogram_Type, E_Access_Protected_Subprogram_Type, E_Anonymous_Access_Protected_Subprogram_Type, E_Access_Subprogram_Type, @@ -1178,10 +1192,8 @@ package body Einfo is function Finalizer (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Package - or else Ekind (Id) = E_Package_Body); - return Node24 (Id); + pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); + return Node28 (Id); end Finalizer; function First_Entity (Id : E) return E is @@ -1230,10 +1242,10 @@ package body Einfo is return Node7 (Id); end Freeze_Node; - function From_With_Type (Id : E) return B is + function From_Limited_With (Id : E) return B is begin return Flag159 (Id); - end From_With_Type; + end From_Limited_With; function Full_View (Id : E) return E is begin @@ -1289,6 +1301,12 @@ package body Einfo is return Flag139 (Id); end Has_Biased_Representation; + function Has_Body_References (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Abstract_State); + return Flag264 (Id); + end Has_Body_References; + function Has_Completion (Id : E) return B is begin return Flag26 (Id); @@ -1705,6 +1723,12 @@ package body Einfo is return Flag215 (Id); end Has_Up_Level_Access; + function Has_Visible_Refinement (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Abstract_State); + return Flag263 (Id); + end Has_Visible_Refinement; + function Has_Volatile_Components (Id : E) return B is begin return Flag87 (Implementation_Base_Type (Id)); @@ -1760,12 +1784,6 @@ package body Einfo is return Node28 (Id); end Initialization_Statements; - function Integrity_Level (Id : E) return U is - begin - pragma Assert (Ekind (Id) = E_Abstract_State); - return Uint8 (Id); - end Integrity_Level; - function Inner_Instances (Id : E) return L is begin return Elist23 (Id); @@ -2654,12 +2672,18 @@ package body Einfo is return Flag227 (Id); end Referenced_As_Out_Parameter; - function Refined_State (Id : E) return E is + function Refined_State (Id : E) return N is begin - pragma Assert (Ekind (Id) = E_Abstract_State); - return Node9 (Id); + pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); + return Node10 (Id); end Refined_State; + function Refinement_Constituents (Id : E) return L is + begin + pragma Assert (Ekind (Id) = E_Abstract_State); + return Elist8 (Id); + end Refinement_Constituents; + function Register_Exception_Call (Id : E) return N is begin pragma Assert (Ekind (Id) = E_Exception); @@ -3325,6 +3349,12 @@ package body Einfo is Set_Flag40 (Id, V); end Set_Body_Needed_For_SAL; + procedure Set_Body_References (Id : E; V : L) is + begin + pragma Assert (Ekind (Id) = E_Abstract_State); + Set_Elist16 (Id, V); + end Set_Body_References; + procedure Set_C_Pass_By_Copy (Id : E; V : B := True) is begin pragma Assert (Is_Record_Type (Id) and then Is_Base_Type (Id)); @@ -3445,13 +3475,13 @@ package body Einfo is procedure Set_Default_Aspect_Component_Value (Id : E; V : E) is begin - pragma Assert (Is_Array_Type (Id)); + pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id)); Set_Node19 (Id, V); end Set_Default_Aspect_Component_Value; procedure Set_Default_Aspect_Value (Id : E; V : E) is begin - pragma Assert (Is_Scalar_Type (Id)); + pragma Assert (Is_Scalar_Type (Id) and then Is_Base_Type (Id)); Set_Node19 (Id, V); end Set_Default_Aspect_Value; @@ -3658,9 +3688,15 @@ package body Einfo is procedure Set_Contract (Id : E; V : N) is begin pragma Assert - (Ekind_In (Id, E_Entry, E_Entry_Family, E_Void) - or else Is_Subprogram (Id) - or else Is_Generic_Subprogram (Id)); + (Ekind_In (Id, E_Entry, + E_Entry_Family, + E_Generic_Package, + E_Package, + E_Package_Body, + E_Subprogram_Body, + E_Void) + or else Is_Generic_Subprogram (Id) + or else Is_Subprogram (Id)); Set_Node24 (Id, V); end Set_Contract; @@ -3771,10 +3807,8 @@ package body Einfo is procedure Set_Finalizer (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Package - or else Ekind (Id) = E_Package_Body); - Set_Node24 (Id, V); + pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); + Set_Node28 (Id, V); end Set_Finalizer; procedure Set_First_Entity (Id : E; V : E) is @@ -3829,13 +3863,11 @@ package body Einfo is Set_Node7 (Id, V); end Set_Freeze_Node; - procedure Set_From_With_Type (Id : E; V : B := True) is + procedure Set_From_Limited_With (Id : E; V : B := True) is begin - pragma Assert - (Is_Type (Id) - or else Ekind (Id) = E_Package); + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Package); Set_Flag159 (Id, V); - end Set_From_With_Type; + end Set_From_Limited_With; procedure Set_Full_View (Id : E; V : E) is begin @@ -3894,6 +3926,12 @@ package body Einfo is Set_Flag139 (Id, V); end Set_Has_Biased_Representation; + procedure Set_Has_Body_References (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Abstract_State); + Set_Flag264 (Id, V); + end Set_Has_Body_References; + procedure Set_Has_Completion (Id : E; V : B := True) is begin Set_Flag26 (Id, V); @@ -4322,6 +4360,12 @@ package body Einfo is Set_Flag72 (Id, V); end Set_Has_Unknown_Discriminants; + procedure Set_Has_Visible_Refinement (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Abstract_State); + Set_Flag263 (Id, V); + end Set_Has_Visible_Refinement; + procedure Set_Has_Volatile_Components (Id : E; V : B := True) is begin pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id)); @@ -4386,12 +4430,6 @@ package body Einfo is Set_Node28 (Id, V); end Set_Initialization_Statements; - procedure Set_Integrity_Level (Id : E; V : Uint) is - begin - pragma Assert (Ekind (Id) = E_Abstract_State); - Set_Uint8 (Id, V); - end Set_Integrity_Level; - procedure Set_Inner_Instances (Id : E; V : L) is begin Set_Elist23 (Id, V); @@ -5322,10 +5360,16 @@ package body Einfo is procedure Set_Refined_State (Id : E; V : E) is begin - pragma Assert (Ekind (Id) = E_Abstract_State); - Set_Node9 (Id, V); + pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); + Set_Node10 (Id, V); end Set_Refined_State; + procedure Set_Refinement_Constituents (Id : E; V : L) is + begin + pragma Assert (Ekind (Id) = E_Abstract_State); + Set_Elist8 (Id, V); + end Set_Refinement_Constituents; + procedure Set_Register_Exception_Call (Id : E; V : N) is begin pragma Assert (Ekind (Id) = E_Exception); @@ -6279,20 +6323,31 @@ package body Einfo is function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id is Is_CDG : constant Boolean := - Id = Pragma_Depends or else Id = Pragma_Global; - Is_CTC : constant Boolean := - Id = Pragma_Contract_Cases or else Id = Pragma_Test_Case; - Is_PPC : constant Boolean := - Id = Pragma_Precondition or else Id = Pragma_Postcondition; - Delayed : constant Boolean := Is_CDG or Is_CTC or Is_PPC; - Item : Node_Id; - Items : Node_Id; - - begin - -- Handle delayed pragmas that appear in N_Contract nodes. Those have to - -- be extracted from their specialized list. - - if Delayed then + Id = Pragma_Abstract_State or else + Id = Pragma_Depends or else + Id = Pragma_Global or else + Id = Pragma_Initial_Condition or else + Id = Pragma_Initializes or else + Id = Pragma_Refined_Depends or else + Id = Pragma_Refined_Global or else + Id = Pragma_Refined_State; + Is_CTC : constant Boolean := + Id = Pragma_Contract_Cases or else + Id = Pragma_Test_Case; + Is_PPC : constant Boolean := + Id = Pragma_Precondition or else + Id = Pragma_Postcondition; + + In_Contract : constant Boolean := Is_CDG or Is_CTC or Is_PPC; + + Item : Node_Id; + Items : Node_Id; + + begin + -- Handle pragmas that appear in N_Contract nodes. Those have to be + -- extracted from their specialized list. + + if In_Contract then Items := Contract (E); if No (Items) then @@ -6322,7 +6377,7 @@ package body Einfo is -- All nodes in N_Contract are chained using Next_Pragma - elsif Delayed then + elsif In_Contract then Item := Next_Pragma (Item); -- Regular pragmas @@ -6440,6 +6495,65 @@ package body Einfo is return False; end Has_Interrupt_Handler; + ----------------------------- + -- Has_Non_Null_Refinement -- + ----------------------------- + + function Has_Non_Null_Refinement (Id : E) return B is + begin + -- "Refinement" is a concept applicable only to abstract states + + pragma Assert (Ekind (Id) = E_Abstract_State); + + if Has_Visible_Refinement (Id) then + pragma Assert (Present (Refinement_Constituents (Id))); + + -- For a refinement to be non-null, the first constituent must be + -- anything other than null. + + return + Nkind (Node (First_Elmt (Refinement_Constituents (Id)))) /= N_Null; + end if; + + return False; + end Has_Non_Null_Refinement; + + ----------------------------- + -- Has_Null_Abstract_State -- + ----------------------------- + + function Has_Null_Abstract_State (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Generic_Package, E_Package)); + + return + Present (Abstract_States (Id)) + and then Is_Null_State (Node (First_Elmt (Abstract_States (Id)))); + end Has_Null_Abstract_State; + + ------------------------- + -- Has_Null_Refinement -- + ------------------------- + + function Has_Null_Refinement (Id : E) return B is + begin + -- "Refinement" is a concept applicable only to abstract states + + pragma Assert (Ekind (Id) = E_Abstract_State); + + if Has_Visible_Refinement (Id) then + pragma Assert (Present (Refinement_Constituents (Id))); + + -- For a refinement to be null, the state's sole constituent must be + -- a null. + + return + Nkind (Node (First_Elmt (Refinement_Constituents (Id)))) = N_Null; + end if; + + return False; + end Has_Null_Refinement; + -------------------- -- Has_Unmodified -- -------------------- @@ -6655,6 +6769,16 @@ package body Einfo is and then Is_Entity_Attribute_Name (Attribute_Name (N))); end Is_Entity_Name; + ----------------------- + -- Is_External_State -- + ----------------------- + + function Is_External_State (Id : E) return B is + begin + return + Ekind (Id) = E_Abstract_State and then Has_Option (Id, Name_External); + end Is_External_State; + ------------------ -- Is_Finalizer -- ------------------ @@ -6690,15 +6814,27 @@ package body Einfo is end if; end Is_Ghost_Subprogram; - -------------------- - -- Is_Input_State -- - -------------------- + ------------------------- + -- Is_Input_Only_State -- + ------------------------- + + function Is_Input_Only_State (Id : E) return B is + begin + return + Ekind (Id) = E_Abstract_State + and then Has_Option (Id, Name_Input_Only); + end Is_Input_Only_State; - function Is_Input_State (Id : E) return B is + --------------------------- + -- Is_Non_Volatile_State -- + --------------------------- + + function Is_Non_Volatile_State (Id : E) return B is begin return - Ekind (Id) = E_Abstract_State and then Has_Property (Id, Name_Input); - end Is_Input_State; + Ekind (Id) = E_Abstract_State + and then Has_Option (Id, Name_Non_Volatile); + end Is_Non_Volatile_State; ------------------- -- Is_Null_State -- @@ -6714,11 +6850,12 @@ package body Einfo is -- Is_Output_State -- --------------------- - function Is_Output_State (Id : E) return B is + function Is_Output_Only_State (Id : E) return B is begin return - Ekind (Id) = E_Abstract_State and then Has_Property (Id, Name_Output); - end Is_Output_State; + Ekind (Id) = E_Abstract_State + and then Has_Option (Id, Name_Output_Only); + end Is_Output_Only_State; ----------------------------------- -- Is_Package_Or_Generic_Package -- @@ -6859,17 +6996,6 @@ package body Einfo is and then Is_Task_Type (Corresponding_Concurrent_Type (Id)); end Is_Task_Record_Type; - ----------------------- - -- Is_Volatile_State -- - ----------------------- - - function Is_Volatile_State (Id : E) return B is - begin - return - Ekind (Id) = E_Abstract_State - and then Has_Property (Id, Name_Volatile); - end Is_Volatile_State; - ------------------------ -- Is_Wrapper_Package -- ------------------------ @@ -7771,7 +7897,7 @@ package body Einfo is -- view then we return the Underlying_Type of its non-limited -- view. - elsif From_With_Type (Id) + elsif From_Limited_With (Id) and then Present (Non_Limited_View (Id)) then return Underlying_Type (Non_Limited_View (Id)); @@ -7874,13 +8000,14 @@ package body Einfo is W ("Entry_Accepted", Flag152 (Id)); W ("Can_Use_Internal_Rep", Flag229 (Id)); W ("Finalize_Storage_Only", Flag158 (Id)); - W ("From_With_Type", Flag159 (Id)); + W ("From_Limited_With", Flag159 (Id)); W ("Has_Aliased_Components", Flag135 (Id)); W ("Has_Alignment_Clause", Flag46 (Id)); W ("Has_All_Calls_Remote", Flag79 (Id)); W ("Has_Anonymous_Master", Flag253 (Id)); W ("Has_Atomic_Components", Flag86 (Id)); W ("Has_Biased_Representation", Flag139 (Id)); + W ("Has_Body_References", Flag264 (Id)); W ("Has_Completion", Flag26 (Id)); W ("Has_Completion_In_Body", Flag71 (Id)); W ("Has_Complex_Representation", Flag140 (Id)); @@ -7954,6 +8081,7 @@ package body Einfo is W ("Has_Unchecked_Union", Flag123 (Id)); W ("Has_Unknown_Discriminants", Flag72 (Id)); W ("Has_Up_Level_Access", Flag215 (Id)); + W ("Has_Visible_Refinement", Flag263 (Id)); W ("Has_Volatile_Components", Flag87 (Id)); W ("Has_Xref_Entry", Flag182 (Id)); W ("In_Package_Body", Flag48 (Id)); @@ -8281,9 +8409,6 @@ package body Einfo is when E_Variable => Write_Str ("Hiding_Loop_Variable"); - when E_Abstract_State => - Write_Str ("Integrity_Level"); - when Formal_Kind | E_Function | E_Subprogram_Body => @@ -8296,6 +8421,9 @@ package body Einfo is when E_Procedure => Write_Str ("Postcondition_Proc"); + when E_Abstract_State => + Write_Str ("Refinement_Constituents"); + when E_Return_Statement => Write_Str ("Return_Applies_To"); @@ -8317,9 +8445,6 @@ package body Einfo is when Object_Kind => Write_Str ("Current_Value"); - when E_Abstract_State => - Write_Str ("Refined_State"); - when E_Function | E_Generic_Function | E_Generic_Package | @@ -8348,7 +8473,7 @@ package body Einfo is Concurrent_Kind => Write_Str ("Direct_Primitive_Operations"); - when Float_Kind => + when Float_Kind => Write_Str ("Float_Rep"); when E_In_Parameter | @@ -8365,6 +8490,10 @@ package body Einfo is E_Discriminant => Write_Str ("Normalized_Position_Max"); + when E_Abstract_State | + E_Variable => + Write_Str ("Refined_State"); + when others => Write_Str ("Field10??"); end case; @@ -8571,6 +8700,9 @@ package body Einfo is E_Record_Type_With_Private => Write_Str ("Access_Disp_Table"); + when E_Abstract_State => + Write_Str ("Body_References"); + when E_Record_Subtype | E_Class_Wide_Subtype => Write_Str ("Cloned_Subtype"); @@ -8659,7 +8791,7 @@ package body Einfo is Write_Str ("Non_Limited_View"); when E_Incomplete_Subtype => - if From_With_Type (Id) then + if From_Limited_With (Id) then Write_Str ("Non_Limited_View"); end if; @@ -8745,7 +8877,7 @@ package body Einfo is Write_Str ("Corresponding_Discriminant"); when Scalar_Kind => - Write_Str ("Default_Value"); + Write_Str ("Default_Aspect_Value"); when E_Array_Type => Write_Str ("Default_Component_Value"); @@ -9005,10 +9137,6 @@ package body Einfo is procedure Write_Field24_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Package | - E_Package_Body => - Write_Str ("Finalizer"); - when E_Constant | E_Variable | Type_Kind => @@ -9016,8 +9144,12 @@ package body Einfo is when E_Entry | E_Entry_Family | - Subprogram_Kind | - Generic_Subprogram_Kind => + E_Generic_Package | + E_Package | + E_Package_Body | + E_Subprogram_Body | + Generic_Subprogram_Kind | + Subprogram_Kind => Write_Str ("Contract"); when others => @@ -9151,7 +9283,12 @@ package body Einfo is E_Subprogram_Type => Write_Str ("Extra_Formals"); - when E_Constant | E_Variable => + when E_Package | + E_Package_Body => + Write_Str ("Finalizer"); + + when E_Constant | + E_Variable => Write_Str ("Initialization_Statements"); when E_Record_Type => diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 0449674d861..0eaf13b43f1 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -493,6 +493,12 @@ package Einfo is -- units. Indicates that the source for the body must be included -- when the unit is part of a standalone library. +-- Body_References (Elist16) +-- Defined in abstract state entities. Only set if Has_Body_References +-- flag is set True, in which case it contains an element list of global +-- references (identifiers) in the current package body to this abstract +-- state that are illegal if the abstract state has a visible refinement. + -- C_Pass_By_Copy (Flag125) [implementation base type only] -- Defined in record types. Set if a pragma Convention for the record -- type specifies convention C_Pass_By_Copy. This convention name is @@ -505,10 +511,10 @@ package Einfo is -- Can_Never_Be_Null (Flag38) -- This flag is defined in all entities, but can only be set in an object --- which can never have a null value. This is set True for constant --- access values initialized to a non-null value. This is also True for --- all access parameters in Ada 83 and Ada 95 modes, and for access --- parameters that explicitly exclude null in Ada 2005. +-- which can never have a null value. Set for constant access values +-- initialized to a non-null value. This is also set for all access +-- parameters in Ada 83 and Ada 95 modes, and for access parameters +-- that explicitly exclude null in Ada 2005. -- -- This is used to avoid unnecessary resetting of the Is_Known_Non_Null -- flag for such entities. In Ada 2005 mode, this is also used when @@ -651,7 +657,7 @@ package Einfo is -- 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 --- set True). Points to the entity for the corresponding task type or +-- set). Points to the entity for the corresponding task type or the -- protected type. -- Corresponding_Discriminant (Node19) @@ -678,7 +684,7 @@ package Einfo is -- Corresponding_Remote_Type (Node22) -- Defined in record types that describe the fat pointer structure for -- Remote_Access_To_Subprogram types. References the original access --- type. +-- to subprogram type. -- CR_Discriminant (Node23) -- Defined in discriminants of concurrent types. Denotes the homologous @@ -738,13 +744,13 @@ package Einfo is -- subprograms, this returns the {function,procedure}_specification, not -- the subprogram_declaration. --- Default_Aspect_Component_Value (Node19) +-- Default_Aspect_Component_Value (Node19) [base type only] -- Defined in array types. Holds the static value specified in a --- default_component_value aspect specification for the array type. +-- Default_Component_Value aspect specification for the array type. --- Default_Aspect_Value (Node19) +-- Default_Aspect_Value (Node19) [base type only] -- Defined in scalar types. Holds the static value specified in a --- default_value aspect specification for the type. +-- Default_Value aspect specification for the type. -- Default_Expr_Function (Node21) -- Defined in parameters. It holds the entity of the parameterless @@ -1022,9 +1028,10 @@ package Einfo is -- 'COUNT when it applies to a family member. -- Contract (Node24) --- Defined in entries, and in subprogram and generic subprogram entities. --- Points to the contract of the entity, holding both pre- and --- postconditions as well as test-cases. +-- Defined in entry, entry family, package, package body, subprogram and +-- subprogram body entities as well as their respective generic forms. +-- 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 @@ -1181,7 +1188,7 @@ package Einfo is -- the Finalize_Storage_Only pragma is required at each level of -- derivation. --- Finalizer (Node24) +-- Finalizer (Node28) -- Applies to package declarations and bodies. Contains the entity of the -- library-level program which finalizes all package-level controlled -- objects. @@ -1308,19 +1315,11 @@ package Einfo is -- associated with the entity, then this field is Empty. See package -- Freeze for further details. --- From_With_Type (Flag159) --- Defined in package and type entities. Indicates that the entity --- appears in a With_Type clause in the context of some other unit, --- either as the prefix (which must be a package), or as a type name. --- The package can only be used to retrieve such a type, and the type --- can be used only in component declarations and access definitions. --- The With_Type clause is used to construct mutually recursive --- types, i.e. record types (Java classes) that hold pointers to each --- other. If such a type is an access type, it has no explicit freeze --- node, so that the back-end does not attempt to elaborate it. --- Currently this flag is also used to implement Ada 2005 (AI-50217). --- It will be renamed to From_Limited_With after removal of the current --- GNAT with_type clause??? +-- From_Limited_With (Flag159) +-- Defined in package and type entities. Set to True when the related +-- entity is generated by the expansion of a limited with clause. Such +-- an entity is said to be a "shadow" - it acts as the incomplete view +-- of a type by inheriting relevant attributes from the said type. -- Full_View (Node11) -- Defined in all type and subtype entities and in deferred constants. @@ -1360,14 +1359,14 @@ package Einfo is -- of derived type declarations). -- Has_All_Calls_Remote (Flag79) --- Defined in all library unit entities. Set true if the library unit --- has an All_Calls_Remote pragma. Note that such entities must also --- be RCI entities, so the flag Is_Remote_Call_Interface will always --- be set if this flag is set. +-- Defined in all library unit entities. Set if the library unit has an +-- All_Calls_Remote pragma. Note that such entities must also be RCI +-- entities, so the flag Is_Remote_Call_Interface will always be set if +-- this flag is set. -- Has_Anonymous_Master (Flag253) -- Defined in units (top-level functions and procedures, library-level --- packages). Set to True if the associated unit contains a heterogeneous +-- packages). Set if the associated unit contains a heterogeneous -- finalization master. The master's name is of the form <unit>AM and it -- services anonymous access-to-controlled types with an undetermined -- lifetime. @@ -1404,6 +1403,10 @@ package Einfo is -- size of the type, forcing biased representation for the object, but -- the subtype is still an unbiased type. +-- Has_Body_References (Flag264) +-- Defined in entities for abstract states. Set if Body_References has +-- at least one entry. + -- Has_Completion (Flag26) -- Defined in all entities that require a completion (functions, -- procedures, private types, limited private types, incomplete types, @@ -1437,11 +1440,11 @@ package Einfo is -- in sem_aux is used to test for this case. -- Has_Contiguous_Rep (Flag181) --- Defined in enumeration types. True if the type as a representation +-- 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. True if the function is a primitive +-- 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] @@ -1451,13 +1454,13 @@ package Einfo is -- Has_Controlled_Component is set for at least one component). -- Has_Convention_Pragma (Flag119) --- Defined in all entities. Set true for an entity for which a valid --- Convention, Import, or Export pragma has been given. Used to prevent --- more than one such pragma appearing for a given entity (RM B.1(45)). +-- Defined in all entities. Set for an entity for which a valid pragma +-- Convention, Import, or Export has been given. Used to prevent more +-- than one such pragma appearing for a given entity (RM B.1(45)). -- Has_Delayed_Aspects (Flag200) --- Defined in all entities. Set true if the Rep_Item chain for the entity --- has one or more N_Aspect_Definition nodes chained which are not to be +-- Defined in all entities. Set if the Rep_Item chain for the entity has +-- one or more N_Aspect_Definition nodes chained which are not to be -- evaluated till the freeze point. The aspect definition expression -- clause has been preanalyzed to get visibility at the point of use, -- but no other action has been taken. @@ -1530,18 +1533,18 @@ package Einfo is -- Convention_Intrinsic, Convention_Entry or Convention_Protected). -- Has_Forward_Instantiation (Flag175) --- Defined in package entities. Set true for packages that contain --- instantiations of local 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 inlining. +-- Defined in package entities. Set for packages that instantiate local +-- 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 +-- inlining. -- Has_Fully_Qualified_Name (Flag173) --- Defined in all entities. Set True if the name in the Chars field has --- been replaced by the fully qualified name, as used for debug output. --- See Exp_Dbug for a full description of the use of this flag and also --- the related flag Has_Qualified_Name. +-- Defined in all entities. Set if the name in the Chars field has been +-- replaced by the fully qualified name, as used for debug output. See +-- Exp_Dbug for a full description of the use of this flag and also the +-- related flag Has_Qualified_Name. -- Has_Gigi_Rep_Item (Flag82) -- Defined in all entities. Set if the rep item chain (referenced by @@ -1575,7 +1578,7 @@ package Einfo is -- applies (as set by coresponding pragma or aspect specification). -- Has_Inheritable_Invariants (Flag248) --- Defined in all type entities. Set True in private types from which one +-- Defined in all type entities. Set in private types from which one -- or more Invariant'Class aspects will be inherited if a another type is -- derived from the type (i.e. those types which have an Invariant'Class -- aspect, or which inherit one or more Invariant'Class aspects). Also @@ -1598,7 +1601,7 @@ package Einfo is -- Interrupt_Handler applies. -- Has_Invariants (Flag232) --- Defined in all type entities and in subprogram entities. Set True in +-- Defined in all type entities and in subprogram entities. Set in -- private types if an Invariant or Invariant'Class aspect applies to the -- type, or if the type inherits one or more Invariant'Class aspects. -- Also set in the corresponding full type. Note: if this flag is set @@ -1635,6 +1638,10 @@ package Einfo is -- optimizations to ensure that they are consistent with exceptions. -- See documentation in Gigi for further details. +-- Has_Non_Null_Refinement (synth) +-- Defined in E_Abstract_State entities. True if the state has at least +-- one variable or state constituent in aspect/pragma Refined_State. + -- Has_Non_Standard_Rep (Flag75) [implementation base type only] -- Defined in all type entities. Set when some representation clause -- or pragma causes the representation of the item to be significantly @@ -1645,15 +1652,23 @@ package Einfo is -- are not considered to be significant since they do not affect -- stored bit patterns. +-- Has_Null_Abstract_State (synth) +-- Defined in package entities. True if the package is subject to a null +-- Abstract_State aspect/pragma. + +-- Has_Null_Refinement (synth) +-- Defined in E_Abstract_State entities. True if the state has a null +-- refinement in aspect/pragma Refined_State. + -- Has_Object_Size_Clause (Flag172) -- Defined in entities for types and subtypes. Set if an Object_Size -- clause has been processed for the type Used to prevent multiple -- Object_Size clauses for a given entity. -- Has_Per_Object_Constraint (Flag154) --- Defined in E_Component entities, true if the subtype of the --- component has a per object constraint. Per object constraints result --- from the following situations: +-- Defined in E_Component entities. Set if the subtype of the component +-- has a per object constraint. Per object constraints result from the +-- following situations : -- -- 1. N_Attribute_Reference - when the prefix is the enclosing type and -- the attribute is Access. @@ -1765,27 +1780,27 @@ package Einfo is -- some ancestor is derived from a private type, making some components -- invisible and aggregates illegal. Used to check the legality of -- selected components and aggregates. The flag is set at the point of --- derivation. --- The legality of an aggregate of a type with a private ancestor must --- be checked because it also depends on the visibility at the point the --- aggregate is resolved. See sem_aggr.adb. This is part of AI05-0115. +-- derivation. The legality of an aggregate of a type with a private +-- ancestor must be checked because it also depends on the visibility +-- at the point the aggregate is resolved. See sem_aggr.adb. This is +-- part of AI05-0115. -- Has_Private_Declaration (Flag155) --- Defined in all entities. Returns True if it is the defining entity --- of a private type declaration or its corresponding full declaration. --- This flag is thus preserved when the full and the partial views are --- exchanged, to indicate if a full type declaration is a completion. --- Used for semantic checks in E.4(18) and elsewhere. +-- Defined in all entities. Set if it is the defining entity of a private +-- type declaration or its corresponding full declaration. This flag is +-- thus preserved when the full and the partial views are exchanged, to +-- indicate if a full type declaration is a completion. Used for semantic +-- checks in E.4(18) and elsewhere. -- Has_Qualified_Name (Flag161) --- Defined in all entities. Set True if the name in the Chars field --- has been replaced by its qualified name, as used for debug output. --- See Exp_Dbug for a full description of qualification requirements. --- For some entities, the name is the fully qualified name, but there --- are exceptions. In particular, for local variables in procedures, --- we do not include the procedure itself or higher scopes. See also --- the flag Has_Fully_Qualified_Name, which is set if the name does --- indeed include the fully qualified name. +-- Defined in all entities. Set if the name in the Chars field has +-- been replaced by its qualified name, as used for debug output. See +-- Exp_Dbug for a full description of qualification requirements. For +-- some entities, the name is the fully qualified name, but there are +-- exceptions. In particular, for local variables in procedures, we +-- do not include the procedure itself or higher scopes. See also the +-- flag Has_Fully_Qualified_Name, which is set if the name does indeed +-- include the fully qualified name. -- Has_RACW (Flag214) -- Defined in package spec entities. Set if the spec contains the @@ -1904,6 +1919,11 @@ package Einfo is -- VM_Target /= No_VM, for efficiency, since only the .NET back-end -- makes use of it to generate proper code for up-level references. +-- 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 +-- pragma Refined_State and the end of the package body declarations. + -- Has_Volatile_Components (Flag87) [implementation base type only] -- Defined in all types and objects. Set only for an array type or array -- object if a valid pragma Volatile_Components or a valid pragma @@ -1969,11 +1989,6 @@ package Einfo is -- instantiated within the given generic. Used to diagnose circular -- instantiations. --- Integrity_Level (Uint8) --- Defined for E_Abstract_State entities. Contains the numerical value of --- the integrity level state property. A value of Uint_0 designates a non --- existent integrity. - -- Interface_Alias (Node25) -- Defined in subprograms that cover a primitive operation of an abstract -- interface type. Can be set only if the Is_Hidden flag is also set, @@ -2168,7 +2183,7 @@ package Einfo is -- Set if the type or subtype is constrained. -- Is_Constr_Subt_For_U_Nominal (Flag80) --- Defined in all types and subtypes. Set true only for the constructed +-- Defined in all types and subtypes. Set only for the constructed -- subtype of an object whose nominal subtype is unconstrained. Note -- that the constructed subtype itself will be constrained. @@ -2225,9 +2240,9 @@ package Einfo is -- entity is associated with a dispatch table. -- Is_Dispatching_Operation (Flag6) --- Defined in all entities. Set true for procedures, functions, --- generic procedures and generic functions if the corresponding --- operation is dispatching. +-- Defined in all entities. Set for procedures, functions, generic +-- procedures, and generic functions if the corresponding operation +-- is dispatching. -- Is_Dynamic_Scope (synthesized) -- Applies to all Entities. Returns True if the entity is a dynamic @@ -2253,9 +2268,9 @@ package Einfo is -- entities and False for all other entity kinds. -- Is_Entry_Formal (Flag52) --- Defined in all entities. Set only for entry formals (which can --- only 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. +-- Defined in all entities. Set only for entry formals (which can only +-- 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_Exported (Flag99) -- Defined in all entities. Set if the entity is exported. For now we @@ -2263,6 +2278,10 @@ package Einfo is -- and variables, but that may well change later on. Exceptions can only -- be exported in the OpenVMS and Java VM implementations of GNAT. +-- Is_External_State (synthesized) +-- Applies to all entities, true for abstract states that are subject to +-- option External. + -- Is_Finalizer (synthesized) -- Applies to all entities, true for procedures containing finalization -- code to process local or library level objects. @@ -2334,7 +2353,7 @@ package Einfo is -- convention. -- Is_Hidden (Flag57) --- Defined in all entities. Set true for all entities declared in the +-- Defined in all entities. Set for all entities declared in the -- private part or body of a package. Also marks generic formals of a -- formal package declared without a box. For library level entities, -- this flag is set if the entity is not publicly visible. This flag @@ -2344,7 +2363,7 @@ package Einfo is -- Private_Declaration in sem_ch7). -- Is_Hidden_Open_Scope (Flag171) --- Defined in all entities. Set true for a scope that contains the +-- Defined in all entities. Set for a scope that contains the -- instantiation of a child unit, and whose entities are not visible -- during analysis of the instance. @@ -2380,9 +2399,9 @@ package Einfo is -- inherited by their instances. It is also set on the body entities -- of inlined subprograms. See also Has_Pragma_Inline. --- Is_Input_State (synthesized) +-- Is_Input_Only_State (synthesized) -- Applies to all entities, true for abstract states that are subject to --- property Input. +-- option Input_Only. -- Is_Instantiated (Flag126) -- Defined in generic packages and generic subprograms. Set if the unit @@ -2458,20 +2477,20 @@ package Einfo is -- to be defined) must be in the same scope as the type. -- Is_Known_Non_Null (Flag37) --- Defined in all entities. Relevant (and can be set True) only for +-- Defined in all entities. Relevant (and can be set) only for -- objects of an access type. It is set if the object is currently -- known to have a non-null value (meaning that no access checks -- are needed). The indication can for example come from assignment -- of an access parameter or an allocator whose value is known non-null. -- -- Note: this flag is set according to the sequential flow of the --- program, watching the current value of the variable. However, --- this processing can miss cases of changing the value of an aliased --- or constant object, so even if this flag is set, it should not --- be believed if the variable is aliased or volatile. It would --- be a little neater to avoid the flag being set in the first --- place in such cases, but that's trickier, and there is only --- one place that tests the value anyway. +-- program, watching the current value of the variable. However, this +-- processing can miss cases of changing the value of an aliased or +-- constant object, so even if this flag is set, it should not be +-- believed if the variable is aliased or volatile. It would be a +-- little neater to avoid the flag being set in the first place in +-- such cases, but that's trickier, and there is only one place that +-- tests the value anyway. -- -- The flag is dynamically set and reset as semantic analysis and -- expansion proceeds. Its value is meaningless once the tree is @@ -2479,7 +2498,7 @@ package Einfo is -- Thus this flag has no meaning to the back end. -- Is_Known_Null (Flag204) --- Defined in all entities. Relevant (and can be set True) only for +-- Defined in all entities. Relevant (and can be set ) only for -- objects of an access type. It is set if the object is currently known -- to have a null value (meaning that a dereference will surely raise -- constraint error exception). The indication can come from an @@ -2573,6 +2592,10 @@ package Einfo is -- set right, at which point, these comments can be removed, and the -- tests for static subtypes greatly simplified. +-- Is_Non_Volatile_State (synthesized) +-- Applies to all entities, true for abstract states that are subject to +-- option Non_Volatile. + -- Is_Null_Init_Proc (Flag178) -- Defined in procedure entities. Set for generated init proc procedures -- (used to initialize composite types), if the code for the procedure @@ -2613,9 +2636,9 @@ package Einfo is -- Applies to all entities, true for ordinary fixed point types and -- subtypes. --- Is_Output_State (synthesized) +-- Is_Output_Only_State (synthesized) -- Applies to all entities, true for abstract states that are subject to --- property Output. +-- option Output_Only. -- Is_Package_Or_Generic_Package (synthesized) -- Applies to all entities. True for packages and generic packages. @@ -2833,7 +2856,7 @@ package Einfo is -- Wide_Wide_Character). -- Is_Statically_Allocated (Flag28) --- Defined in all entities. This can only be set True for exception, +-- Defined in all entities. This can only be set for exception, -- variable, constant, and type/subtype entities. If the flag is set, -- then the variable or constant must be allocated statically rather -- than on the local stack frame. For exceptions, the meaning is that @@ -2943,7 +2966,7 @@ package Einfo is -- or Export_Valued_Procedure pragma applies to the procedure entity. -- Is_Visible_Formal (Flag206) --- Defined in all entities. Set True for instances of the formals of a +-- Defined in all entities. Set for instances of the formals of a -- formal package. Indicates that the entity must be made visible in the -- body of the instance, to reproduce the visibility of the generic. -- This simplifies visibility settings in instance bodies. @@ -2974,10 +2997,6 @@ package Einfo is -- optimizations on volatile objects should test Treat_As_Volatile -- rather than testing this flag. --- Is_Volatile_State (synthesized) --- Applies to all entities, true for abstract states that are subject to --- property Volatile. - -- Is_Wrapper_Package (synthesized) -- Defined in package entities. Indicates that the package has been -- created as a wrapper for a subprogram instantiation. @@ -3054,10 +3073,10 @@ package Einfo is -- Value attributes for the enumeration type in question. -- Low_Bound_Tested (Flag205) --- Defined in all entities. Currently this can only be set True for --- formal parameter entries of a standard unconstrained one-dimensional --- array or string type. Indicates that an explicit test of the low bound --- of the formal appeared in the code, e.g. in a pragma Assert. If this +-- Defined in all entities. Currently this can only be set for formal +-- parameter entries of a standard unconstrained one-dimensional array +-- or string type. Indicates that an explicit test of the low bound of +-- the formal appeared in the code, e.g. in a pragma Assert. If this -- flag is set, warnings about assuming the index low bound to be one -- are suppressed. @@ -3248,8 +3267,8 @@ package Einfo is -- the defining entity in the original declaration. -- Nonzero_Is_True (Flag162) [base type only] --- Defined in enumeration types. True if any non-zero value is to be --- interpreted as true. Currently this is set true for derived Boolean +-- Defined in enumeration types. Set if any non-zero value is to be +-- interpreted as true. Currently this is set for derived Boolean -- types which have a convention of C, C++ or Fortran. -- No_Pool_Assigned (Flag131) [root type only] @@ -3534,9 +3553,14 @@ package Einfo is -- we have a separate warning for variables that are only assigned and -- never read, and out parameters are a special case. --- Refined_State (Node9) --- Defined in E_Abstract_State entities. Contains the entity of the --- abstract state completion which is usually foung in package bodies. +-- Refined_State (Node10) +-- Defined in abstract states and variables. Contains the entity of an +-- ancestor state whose refinement mentions this item. + +-- Refinement_Constituents (Elist8) +-- Present in abstract state entities. Contains all the constituents that +-- refine the state, in other words, all the hidden states that appear in +-- the constituent_list of aspect/pragma Refined_State. -- Register_Exception_Call (Node20) -- Defined in exception entities. When an exception is declared, @@ -3787,8 +3811,8 @@ package Einfo is -- Static_Predicate (List25) -- Defined in discrete types/subtypes with predicates (Has_Predicates --- set True). Set if the type/subtype has a static predicate. Points to --- a list of expression and N_Range nodes that represent the predicate +-- set). Set if the type/subtype has a static predicate. Points to a +-- list of expression and N_Range nodes that represent the predicate -- in canonical form. The canonical form has entries sorted in ascending -- order, with duplicates eliminated, and adjacent ranges coalesced, so -- that there is always a gap in the values between successive entries. @@ -5017,7 +5041,7 @@ package Einfo is -- Depends_On_Private (Flag14) -- Discard_Names (Flag88) -- Finalize_Storage_Only (Flag158) (base type only) - -- From_With_Type (Flag159) + -- From_Limited_With (Flag159) -- Has_Aliased_Components (Flag135) (base type only) -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) (base type only) @@ -5093,12 +5117,18 @@ package Einfo is ------------------------------------------ -- E_Abstract_State - -- Integrity_Level (Uint8) - -- Refined_State (Node9) - -- Is_Input_State (synth) + -- Refinement_Constituents (Elist8) + -- Refined_State (Node10) + -- Body_References (Elist16) + -- Has_Body_References (Flag264) + -- Has_Visible_Refinement (Flag263) + -- Has_Non_Null_Refinement (synth) + -- Has_Null_Refinement (synth) + -- Is_External_State (synth) + -- Is_Input_Only_State (synth) -- Is_Null_State (synth) - -- Is_Output_State (synth) - -- Is_Volatile_State (synth) + -- Is_Output_Only_State (synth) + -- Is_Non_Volatile_State (synth) -- E_Access_Protected_Subprogram_Type -- Equivalent_Type (Node18) @@ -5156,7 +5186,7 @@ package Einfo is -- E_Array_Type -- E_Array_Subtype -- First_Index (Node17) - -- Default_Aspect_Component_Value (Node19) + -- Default_Aspect_Component_Value (Node19) (base type only) -- Component_Type (Node20) (base type only) -- Original_Array_Type (Node21) -- Component_Size (Uint22) (base type only) @@ -5307,7 +5337,7 @@ package Einfo is -- Accept_Address (Elist21) -- Scope_Depth_Value (Uint22) -- Protection_Object (Node23) (protected kind) - -- Contract (Node24) (for entry only) + -- Contract (Node24) -- PPC_Wrapper (Node25) -- Extra_Formals (Node28) -- Default_Expressions_Processed (Flag108) @@ -5339,7 +5369,7 @@ package Einfo is -- Lit_Indexes (Node15) (root type only) -- Lit_Strings (Node16) (root type only) -- First_Literal (Node17) - -- Default_Aspect_Value (Node19) + -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) -- Enum_Pos_To_Rep (Node23) (type only) -- Static_Predicate (List25) @@ -5371,7 +5401,7 @@ package Einfo is -- E_Floating_Point_Subtype -- Digits_Value (Uint17) -- Float_Rep (Uint10) (Float_Rep_Kind) - -- Default_Aspect_Value (Node19) + -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) -- Machine_Emax_Value (synth) -- Machine_Emin_Value (synth) @@ -5549,7 +5579,7 @@ package Einfo is -- E_Modular_Integer_Type -- E_Modular_Integer_Subtype -- Modulus (Uint17) (base type only) - -- Default_Aspect_Value (Node19) + -- Default_Aspect_Value (Node19) (base type only) -- Original_Array_Type (Node21) -- Scalar_Range (Node20) -- Static_Predicate (List25) @@ -5568,6 +5598,7 @@ package Einfo is -- Alias (Node18) -- Extra_Accessibility_Of_Result (Node19) -- Last_Entity (Node20) + -- Contract (Node24) -- Overridden_Operation (Node26) -- Subprograms_For_Type (Node29) -- Has_Invariants (Flag232) @@ -5583,7 +5614,7 @@ package Einfo is -- E_Ordinary_Fixed_Point_Type -- E_Ordinary_Fixed_Point_Subtype -- Delta_Value (Ureal18) - -- Default_Aspect_Value (Node19) + -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) -- Small_Value (Ureal21) -- Has_Small_Clause (Flag67) @@ -5612,17 +5643,18 @@ package Einfo is -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic case only) -- Limited_View (Node23) (non-generic/instance) - -- Finalizer (Node24) (non-generic case only) + -- Contract (Node24) -- Abstract_States (Elist25) -- Package_Instantiation (Node26) -- Current_Use_Clause (Node27) + -- Finalizer (Node28) (non-generic case only) -- SPARK_Mode_Pragmas (Node32) -- Delay_Subprogram_Descriptors (Flag50) -- Body_Needed_For_SAL (Flag40) -- Discard_Names (Flag88) -- Elaboration_Entity_Required (Flag174) -- Elaborate_Body_Desirable (Flag210) (non-generic case only) - -- From_With_Type (Flag159) + -- From_Limited_With (Flag159) -- Has_All_Calls_Remote (Flag79) -- Has_Anonymous_Master (Flag253) -- Has_Completion (Flag26) @@ -5636,6 +5668,7 @@ package Einfo is -- Is_Visible_Lib_Unit (Flag116) -- Renamed_In_Spec (Flag231) (non-generic case only) -- Static_Elaboration_Desired (Flag77) (non-generic case only) + -- Has_Null_Abstract_State (synth) -- Is_Wrapper_Package (synth) (non-generic case only) -- Scope_Depth (synth) @@ -5646,7 +5679,8 @@ package Einfo is -- Spec_Entity (Node19) -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) - -- Finalizer (Node24) (non-generic case only) + -- Contract (Node24) + -- Finalizer (Node28) (non-generic case only) -- SPARK_Mode_Pragmas (Node32) -- Delay_Subprogram_Descriptors (Flag50) -- Has_Anonymous_Master (Flag253) @@ -5834,7 +5868,7 @@ package Einfo is -- E_Signed_Integer_Type -- E_Signed_Integer_Subtype - -- Default_Aspect_Value (Node19) + -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) -- Static_Predicate (List25) -- Has_Biased_Representation (Flag139) @@ -5864,6 +5898,7 @@ package Einfo is -- Corresponding_Protected_Entry (Node18) -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) + -- Contract (Node24) -- Extra_Formals (Node28) -- SPARK_Mode_Pragmas (Node32) -- Scope_Depth (synth) @@ -5907,6 +5942,7 @@ package Einfo is -- E_Variable -- Hiding_Loop_Variable (Node8) -- Current_Value (Node9) + -- Refined_State (Node10) -- Esize (Uint12) -- Extra_Accessibility (Node13) -- Alignment (Uint14) @@ -6198,6 +6234,7 @@ package Einfo is function Block_Node (Id : E) return N; function Body_Entity (Id : E) return E; function Body_Needed_For_SAL (Id : E) return B; + function Body_References (Id : E) return L; function CR_Discriminant (Id : E) return E; function C_Pass_By_Copy (Id : E) return B; function Can_Never_Be_Null (Id : E) return B; @@ -6282,7 +6319,7 @@ package Einfo is function First_Rep_Item (Id : E) return N; function Float_Rep (Id : E) return F; function Freeze_Node (Id : E) return N; - function From_With_Type (Id : E) return B; + function From_Limited_With (Id : E) return B; function Full_View (Id : E) return E; function Generic_Homonym (Id : E) return E; function Generic_Renamings (Id : E) return L; @@ -6293,6 +6330,7 @@ package Einfo is function Has_Anonymous_Master (Id : E) return B; function Has_Atomic_Components (Id : E) return B; function Has_Biased_Representation (Id : E) return B; + function Has_Body_References (Id : E) return B; function Has_Completion (Id : E) return B; function Has_Completion_In_Body (Id : E) return B; function Has_Complex_Representation (Id : E) return B; @@ -6369,6 +6407,7 @@ package Einfo is function Has_Unchecked_Union (Id : E) return B; function Has_Unknown_Discriminants (Id : E) return B; function Has_Up_Level_Access (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; function Hiding_Loop_Variable (Id : E) return E; @@ -6377,7 +6416,6 @@ package Einfo is function In_Private_Part (Id : E) return B; function In_Use (Id : E) return B; function Initialization_Statements (Id : E) return N; - function Integrity_Level (Id : E) return U; function Inner_Instances (Id : E) return L; function Interface_Alias (Id : E) return E; function Interface_Name (Id : E) return N; @@ -6536,6 +6574,7 @@ package Einfo is function Referenced_As_LHS (Id : E) return B; function Referenced_As_Out_Parameter (Id : E) return B; function Refined_State (Id : E) return E; + function Refinement_Constituents (Id : E) return L; function Register_Exception_Call (Id : E) return N; function Related_Array_Object (Id : E) return E; function Related_Expression (Id : E) return N; @@ -6674,18 +6713,23 @@ package Einfo is function Has_Attach_Handler (Id : E) return B; function Has_Entries (Id : E) return B; function Has_Foreign_Convention (Id : E) return B; + function Has_Non_Null_Refinement (Id : E) return B; + function Has_Null_Abstract_State (Id : E) return B; + function Has_Null_Refinement (Id : E) return B; function Implementation_Base_Type (Id : E) return E; function Is_Base_Type (Id : E) return B; function Is_Boolean_Type (Id : E) return B; function Is_Constant_Object (Id : E) return B; function Is_Discriminal (Id : E) return B; function Is_Dynamic_Scope (Id : E) return B; + function Is_External_State (Id : E) return B; function Is_Finalizer (Id : E) return B; function Is_Ghost_Entity (Id : E) return B; function Is_Ghost_Subprogram (Id : E) return B; - function Is_Input_State (Id : E) return B; + function Is_Input_Only_State (Id : E) return B; + function Is_Non_Volatile_State (Id : E) return B; function Is_Null_State (Id : E) return B; - function Is_Output_State (Id : E) return B; + function Is_Output_Only_State (Id : E) return B; function Is_Package_Or_Generic_Package (Id : E) return B; function Is_Prival (Id : E) return B; function Is_Protected_Component (Id : E) return B; @@ -6696,7 +6740,6 @@ package Einfo is function Is_Synchronized_Interface (Id : E) return B; function Is_Task_Interface (Id : E) return B; function Is_Task_Record_Type (Id : E) return B; - function Is_Volatile_State (Id : E) return B; function Is_Wrapper_Package (Id : E) return B; function Last_Formal (Id : E) return E; function Machine_Emax_Value (Id : E) return U; @@ -6811,6 +6854,7 @@ package Einfo is procedure Set_Block_Node (Id : E; V : N); procedure Set_Body_Entity (Id : E; V : E); procedure Set_Body_Needed_For_SAL (Id : E; V : B := True); + procedure Set_Body_References (Id : E; V : L); procedure Set_CR_Discriminant (Id : E; V : E); procedure Set_C_Pass_By_Copy (Id : E; V : B := True); procedure Set_Can_Never_Be_Null (Id : E; V : B := True); @@ -6894,7 +6938,7 @@ package Einfo is procedure Set_First_Rep_Item (Id : E; V : N); procedure Set_Float_Rep (Id : E; V : F); procedure Set_Freeze_Node (Id : E; V : N); - procedure Set_From_With_Type (Id : E; V : B := True); + procedure Set_From_Limited_With (Id : E; V : B := True); procedure Set_Full_View (Id : E; V : E); procedure Set_Generic_Homonym (Id : E; V : E); procedure Set_Generic_Renamings (Id : E; V : L); @@ -6905,6 +6949,7 @@ package Einfo is procedure Set_Has_Anonymous_Master (Id : E; V : B := True); procedure Set_Has_Atomic_Components (Id : E; V : B := True); procedure Set_Has_Biased_Representation (Id : E; V : B := True); + procedure Set_Has_Body_References (Id : E; V : B := True); procedure Set_Has_Completion (Id : E; V : B := True); procedure Set_Has_Completion_In_Body (Id : E; V : B := True); procedure Set_Has_Complex_Representation (Id : E; V : B := True); @@ -6980,6 +7025,7 @@ package Einfo is procedure Set_Has_Unchecked_Union (Id : E; V : B := True); procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True); procedure Set_Has_Up_Level_Access (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); procedure Set_Hiding_Loop_Variable (Id : E; V : E); @@ -6988,7 +7034,6 @@ package Einfo is procedure Set_In_Private_Part (Id : E; V : B := True); procedure Set_In_Use (Id : E; V : B := True); procedure Set_Initialization_Statements (Id : E; V : N); - procedure Set_Integrity_Level (Id : E; V : U); procedure Set_Inner_Instances (Id : E; V : L); procedure Set_Interface_Alias (Id : E; V : E); procedure Set_Interface_Name (Id : E; V : N); @@ -7153,6 +7198,7 @@ package Einfo is procedure Set_Referenced_As_LHS (Id : E; V : B := True); procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True); procedure Set_Refined_State (Id : E; V : E); + procedure Set_Refinement_Constituents (Id : E; V : L); procedure Set_Register_Exception_Call (Id : E; V : N); procedure Set_Related_Array_Object (Id : E; V : E); procedure Set_Related_Expression (Id : E; V : N); @@ -7397,11 +7443,19 @@ package Einfo is -- Empty is returned. function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id; - -- Searches the Rep_Item chain for a given entity E, for an instance of - -- a pragma with the given pragma Id. If found, the value returned is the - -- N_Pragma node, otherwise Empty is returned. Delayed pragmas such as - -- Precondition, Postcondition, Contract_Cases, Depends and Global appear - -- in the N_Contract node of entity E and are also handled by this routine. + -- Searches the Rep_Item chain of entity E, for an instance of a pragma + -- with the given pragma Id. If found, the value returned is the N_Pragma + -- node, otherwise Empty is returned. The following contract pragmas that + -- appear in N_Contract nodes are also handled by this routine: + -- Contract_Cases + -- Depends + -- Global + -- Initial_Condition + -- Initializes + -- Precondition + -- Postcondition + -- Refined_Depends + -- Refined_Global function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id; -- Searches the Rep_Item chain for a given entity E, for a record @@ -7522,6 +7576,7 @@ package Einfo is pragma Inline (Block_Node); pragma Inline (Body_Entity); pragma Inline (Body_Needed_For_SAL); + pragma Inline (Body_References); pragma Inline (CR_Discriminant); pragma Inline (C_Pass_By_Copy); pragma Inline (Can_Never_Be_Null); @@ -7603,7 +7658,7 @@ package Einfo is pragma Inline (First_Private_Entity); pragma Inline (First_Rep_Item); pragma Inline (Freeze_Node); - pragma Inline (From_With_Type); + pragma Inline (From_Limited_With); pragma Inline (Full_View); pragma Inline (Generic_Homonym); pragma Inline (Generic_Renamings); @@ -7614,6 +7669,7 @@ package Einfo is pragma Inline (Has_Anonymous_Master); pragma Inline (Has_Atomic_Components); pragma Inline (Has_Biased_Representation); + pragma Inline (Has_Body_References); pragma Inline (Has_Completion); pragma Inline (Has_Completion_In_Body); pragma Inline (Has_Complex_Representation); @@ -7689,6 +7745,7 @@ package Einfo is pragma Inline (Has_Unchecked_Union); pragma Inline (Has_Unknown_Discriminants); pragma Inline (Has_Up_Level_Access); + pragma Inline (Has_Visible_Refinement); pragma Inline (Has_Volatile_Components); pragma Inline (Has_Xref_Entry); pragma Inline (Hiding_Loop_Variable); @@ -7696,7 +7753,6 @@ package Einfo is pragma Inline (In_Package_Body); pragma Inline (In_Private_Part); pragma Inline (In_Use); - pragma Inline (Integrity_Level); pragma Inline (Inner_Instances); pragma Inline (Interface_Alias); pragma Inline (Interface_Name); @@ -7904,6 +7960,7 @@ package Einfo is pragma Inline (Referenced_As_LHS); pragma Inline (Referenced_As_Out_Parameter); pragma Inline (Refined_State); + pragma Inline (Refinement_Constituents); pragma Inline (Register_Exception_Call); pragma Inline (Related_Array_Object); pragma Inline (Related_Expression); @@ -7984,6 +8041,7 @@ package Einfo is pragma Inline (Set_Block_Node); pragma Inline (Set_Body_Entity); pragma Inline (Set_Body_Needed_For_SAL); + pragma Inline (Set_Body_References); pragma Inline (Set_CR_Discriminant); pragma Inline (Set_C_Pass_By_Copy); pragma Inline (Set_Can_Never_Be_Null); @@ -8063,7 +8121,7 @@ package Einfo is pragma Inline (Set_First_Private_Entity); pragma Inline (Set_First_Rep_Item); pragma Inline (Set_Freeze_Node); - pragma Inline (Set_From_With_Type); + pragma Inline (Set_From_Limited_With); pragma Inline (Set_Full_View); pragma Inline (Set_Generic_Homonym); pragma Inline (Set_Generic_Renamings); @@ -8074,6 +8132,7 @@ package Einfo is pragma Inline (Set_Has_Anonymous_Master); pragma Inline (Set_Has_Atomic_Components); pragma Inline (Set_Has_Biased_Representation); + pragma Inline (Set_Has_Body_References); pragma Inline (Set_Has_Completion); pragma Inline (Set_Has_Completion_In_Body); pragma Inline (Set_Has_Complex_Representation); @@ -8149,6 +8208,7 @@ package Einfo is pragma Inline (Set_Has_Unchecked_Union); pragma Inline (Set_Has_Unknown_Discriminants); pragma Inline (Set_Has_Up_Level_Access); + pragma Inline (Set_Has_Visible_Refinement); pragma Inline (Set_Has_Volatile_Components); pragma Inline (Set_Has_Xref_Entry); pragma Inline (Set_Hiding_Loop_Variable); @@ -8157,7 +8217,6 @@ package Einfo is pragma Inline (Set_In_Private_Part); pragma Inline (Set_In_Use); pragma Inline (Set_Inner_Instances); - pragma Inline (Set_Integrity_Level); pragma Inline (Set_Interface_Alias); pragma Inline (Set_Interface_Name); pragma Inline (Set_Interfaces); @@ -8321,6 +8380,7 @@ package Einfo is pragma Inline (Set_Referenced_As_LHS); pragma Inline (Set_Referenced_As_Out_Parameter); pragma Inline (Set_Refined_State); + pragma Inline (Set_Refinement_Constituents); pragma Inline (Set_Register_Exception_Call); pragma Inline (Set_Related_Array_Object); pragma Inline (Set_Related_Expression); diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb index 6170585272e..7e62ce49f69 100644 --- a/gcc/ada/elists.adb +++ b/gcc/ada/elists.adb @@ -287,6 +287,34 @@ package body Elists is Elmts.Release; end Lock; + -------------------- + -- New_Copy_Elist -- + -------------------- + + function New_Copy_Elist (List : Elist_Id) return Elist_Id is + Result : Elist_Id; + Elmt : Elmt_Id; + + begin + if List = No_Elist then + return No_Elist; + + -- Replicate the contents of the input list while preserving the + -- original order. + + else + Result := New_Elmt_List; + + Elmt := First_Elmt (List); + while Present (Elmt) loop + Append_Elmt (Node (Elmt), Result); + Next_Elmt (Elmt); + end loop; + + return Result; + end if; + end New_Copy_Elist; + ------------------- -- New_Elmt_List -- ------------------- @@ -397,6 +425,27 @@ package body Elists is return Elmt /= No_Elmt; end Present; + ------------ + -- Remove -- + ------------ + + procedure Remove (List : Elist_Id; N : Node_Or_Entity_Id) is + Elmt : Elmt_Id; + + begin + if Present (List) then + Elmt := First_Elmt (List); + while Present (Elmt) loop + if Node (Elmt) = N then + Remove_Elmt (List, Elmt); + exit; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + end Remove; + ----------------- -- Remove_Elmt -- ----------------- diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads index 8f66e0553bf..f0331362ea3 100644 --- a/gcc/ada/elists.ads +++ b/gcc/ada/elists.ads @@ -137,12 +137,20 @@ package Elists is -- Add a new element (N) right after the pre-existing element Elmt -- It is invalid to call this subprogram with Elmt = No_Elmt. + function New_Copy_Elist (List : Elist_Id) return Elist_Id; + -- Replicate the contents of a list. Internal list nodes are not shared and + -- order of elements is preserved. + procedure Replace_Elmt (Elmt : Elmt_Id; New_Node : Node_Or_Entity_Id); pragma Inline (Replace_Elmt); -- Causes the given element of the list to refer to New_Node, the node -- which was previously referred to by Elmt is effectively removed from -- the list and replaced by New_Node. + procedure Remove (List : Elist_Id; N : Node_Or_Entity_Id); + -- Remove a node or an entity from a list. If the list does not contain the + -- item in question, the routine has no effect. + procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id); -- Removes Elmt from the given list. The node itself is not affected, -- but the space used by the list element may be (but is not required diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 12cf828a2f2..2c783b2bddf 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -49,7 +49,6 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stylesw; use Stylesw; -with Targparm; use Targparm; with Uname; use Uname; package body Errout is @@ -234,6 +233,15 @@ package body Errout is begin if not Finalize_Called then raise Program_Error; + + -- In formal verification mode, errors issued when generating Why code + -- are not compilation errors, and should not result in exiting with + -- an error status. These errors are handled in the driver of the + -- verification process instead. + + elsif SPARK_Mode and not Frame_Condition_Mode then + return False; + else return Erroutc.Compilation_Errors; end if; @@ -1617,15 +1625,19 @@ package body Errout is Set_Standard_Error; end if; - -- Message giving total number of lines + -- Message giving total number of lines. Don't give this message if + -- the Main_Source line is unknown (this happens in error situations, + -- e.g. when integrated preprocessing fails). - Write_Str (" "); - Write_Int (Num_Source_Lines (Main_Source_File)); + if Main_Source_File /= No_Source_File then + Write_Str (" "); + Write_Int (Num_Source_Lines (Main_Source_File)); - if Num_Source_Lines (Main_Source_File) = 1 then - Write_Str (" line: "); - else - Write_Str (" lines: "); + if Num_Source_Lines (Main_Source_File) = 1 then + Write_Str (" line: "); + else + Write_Str (" lines: "); + end if; end if; if Total_Errors_Detected = 0 then @@ -1823,8 +1835,13 @@ package body Errout is begin Write_Eol; - Write_Header (Sfile); - Write_Eol; + + -- Only write the header if Sfile is known + + if Sfile /= No_Source_File then + Write_Header (Sfile); + Write_Eol; + end if; -- Normally, we don't want an "error messages from file" -- message when listing the entire file, so we set the @@ -1839,28 +1856,33 @@ package body Errout is Current_Error_Source_File := Sfile; end if; - for N in 1 .. Last_Source_Line (Sfile) loop - while E /= No_Error_Msg - and then Errors.Table (E).Deleted - loop - E := Errors.Table (E).Next; - end loop; + -- Only output the listing if Sfile is known, to avoid + -- crashing the compiler. + + if Sfile /= No_Source_File then + for N in 1 .. Last_Source_Line (Sfile) loop + while E /= No_Error_Msg + and then Errors.Table (E).Deleted + loop + E := Errors.Table (E).Next; + end loop; - Err_Flag := - E /= No_Error_Msg - and then Errors.Table (E).Line = N - and then Errors.Table (E).Sfile = Sfile; + Err_Flag := + E /= No_Error_Msg + and then Errors.Table (E).Line = N + and then Errors.Table (E).Sfile = Sfile; - Output_Source_Line (N, Sfile, Err_Flag); + Output_Source_Line (N, Sfile, Err_Flag); - if Err_Flag then - Output_Error_Msgs (E); + if Err_Flag then + Output_Error_Msgs (E); - if not Debug_Flag_2 then - Write_Eol; + if not Debug_Flag_2 then + Write_Eol; + end if; end if; - end if; - end loop; + end loop; + end if; end; end if; end loop; @@ -1909,7 +1931,13 @@ package body Errout is and then (not Full_List or else Full_List_File_Name /= null) then Write_Eol; - Write_Header (Main_Source_File); + + -- Output the header only when Main_Source_File is known + + if Main_Source_File /= No_Source_File then + Write_Header (Main_Source_File); + end if; + E := First_Error_Msg; -- Loop through error lines @@ -2705,7 +2733,7 @@ package body Errout is Warning_Msg_Char := ' '; if P <= Text'Last and then Text (P) = '?' then - if Warning_Doc_Switch and not OpenVMS_On_Target then + if Warning_Doc_Switch then Warning_Msg_Char := '?'; end if; @@ -2717,7 +2745,7 @@ package body Errout is Text (P) in 'A' .. 'Z') and then Text (P + 1) = '?' then - if Warning_Doc_Switch and not OpenVMS_On_Target then + if Warning_Doc_Switch then Warning_Msg_Char := Text (P); end if; @@ -2805,7 +2833,6 @@ package body Errout is if Error_Msg_Warn and Warning_Doc_Switch - and not OpenVMS_On_Target then Warning_Msg_Char := '?'; end if; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 0c363222c37..e268d1f58d7 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -313,6 +313,8 @@ package Errout is -- taken as an Ada reserved word, and are converted to the default -- case for reserved words (see Scans package spec). Surrounding -- quotes are added unless manual quotation mode is currently set. + -- RM and SPARK are special exceptions, they are never treated as + -- keywords, and just appear verbatim, with no surrounding quotes. -- Insertion character ` (Backquote: set manual quotation mode) -- The backquote character always appears in pairs. Each backquote of @@ -813,9 +815,11 @@ package Errout is -- matching Warnings Off pragma preceding this one. function Compilation_Errors return Boolean; - -- Returns true if errors have been detected, or warnings in -gnatwe - -- (treat warnings as errors) mode. Note that it is mandatory to call - -- Finalize before calling this routine. + -- Returns True if errors have been detected, or warnings in -gnatwe (treat + -- warnings as errors) mode. Note that it is mandatory to call Finalize + -- before calling this routine. Always returns False in formal verification + -- mode, because errors issued when generating Why code are not compilation + -- errors, and should not result in exiting with an error status. procedure Error_Msg_CRT (Feature : String; N : Node_Id); -- Posts a non-fatal message on node N saying that the feature identified diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 97ce9d77891..e2631f84e7f 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -31,6 +31,7 @@ with Atree; use Atree; with Casing; use Casing; +with Csets; use Csets; with Debug; use Debug; with Err_Vars; use Err_Vars; with Namet; use Namet; @@ -461,10 +462,7 @@ package body Erroutc is Warn_Tag := new String'(" [-gnatw" & Warn_Chr & ']'); else pragma Assert (Warn_Chr in 'A' .. 'Z'); - Warn_Tag := - new String'(" [-gnatw." - & Character'Val (Character'Pos (Warn_Chr) + 32) - & ']'); + Warn_Tag := new String'(" [-gnatw." & Fold_Lower (Warn_Chr) & ']'); end if; else diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 02101852d44..647e58bafdd 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -427,7 +427,8 @@ package Erroutc is -- Handle reserved word insertion (upper case letters). The Text argument -- is the current error message input text, and J is an index which on -- entry points to the first character of the reserved word, and on exit - -- points past the last character of the reserved word. + -- points past the last character of the reserved word. Note that RM and + -- SPARK are treated specially and not considered to be keywords. procedure Set_Msg_Insertion_Run_Time_Name; -- If package System contains a definition for Run_Time_Name (see package diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index e0a91324a80..20a82b1d7f1 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -376,7 +376,7 @@ package body Exp_Aggr is -- Start of processing for Aggr_Size_OK begin - -- The normal aggregate limit is 5000, but we increase this limit to + -- The normal aggregate limit is 50000, but we increase this limit to -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code) or -- Restrictions (No_Implicit_Loops) is specified, since in either case -- we are at risk of declaring the program illegal because of this @@ -389,10 +389,14 @@ package body Exp_Aggr is -- efficient to construct a one-dimensional equivalent array with static -- components. + -- Conversely, we decrease the maximum size if none of the above + -- requirements apply, and if the aggregate has a single component + -- association, which will be more efficient if implemented with a loop. + -- Finally, we use a small limit in CodePeer mode where we favor loops -- instead of thousands of single assignments (from large aggregates). - Max_Aggr_Size := 5000; + Max_Aggr_Size := 50000; if CodePeer_Mode then Max_Aggr_Size := 100; @@ -404,6 +408,11 @@ package body Exp_Aggr is and then Static_Elaboration_Desired (Current_Scope))) then Max_Aggr_Size := 2 ** 24; + + elsif No (Expressions (N)) + and then No (Next (First (Component_Associations (N)))) + then + Max_Aggr_Size := 5000; end if; Siz := Component_Count (Component_Type (Typ)); @@ -619,7 +628,7 @@ package body Exp_Aggr is -- If component is limited, aggregate must be expanded because each -- component assignment must be built in place. - if Is_Immutably_Limited_Type (Component_Type (Typ)) then + if Is_Limited_View (Component_Type (Typ)) then return False; end if; @@ -3338,7 +3347,7 @@ package body Exp_Aggr is -- in place within the caller's scope). or else - (Is_Immutably_Limited_Type (Typ) + (Is_Limited_View (Typ) and then (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement or else Nkind (Parent_Node) = N_Simple_Return_Statement)) @@ -4878,6 +4887,43 @@ package body Exp_Aggr is Check_Same_Aggr_Bounds (N, 1); end if; + -- STEP 1d + + -- If we have a default component value, or simple initialization is + -- required for the component type, then we replace <> in component + -- associations by the required default value. + + declare + Default_Val : Node_Id; + Assoc : Node_Id; + + begin + if (Present (Default_Aspect_Component_Value (Typ)) + or else Needs_Simple_Initialization (Ctyp)) + and then Present (Component_Associations (N)) + then + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + if Nkind (Assoc) = N_Component_Association + and then Box_Present (Assoc) + then + Set_Box_Present (Assoc, False); + + if Present (Default_Aspect_Component_Value (Typ)) then + Default_Val := Default_Aspect_Component_Value (Typ); + else + Default_Val := Get_Simple_Init_Val (Ctyp, N); + end if; + + Set_Expression (Assoc, New_Copy_Tree (Default_Val)); + Analyze_And_Resolve (Expression (Assoc), Ctyp); + end if; + + Next (Assoc); + end loop; + end if; + end; + -- STEP 2 -- Here we test for is packed array aggregate that we can handle at @@ -5622,7 +5668,7 @@ package body Exp_Aggr is -- Extension aggregates, aggregates in extended return statements, and -- aggregates for C++ imported types must be expanded. - if Ada_Version >= Ada_2005 and then Is_Immutably_Limited_Type (Typ) then + if Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then if not Nkind_In (Parent (N), N_Object_Declaration, N_Component_Association) then diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 00347672511..bd193598b0d 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1296,14 +1296,14 @@ package body Exp_Attr is -- Handle designated types that come from the limited view if Ekind (Btyp_DDT) = E_Incomplete_Type - and then From_With_Type (Btyp_DDT) + and then From_Limited_With (Btyp_DDT) and then Present (Non_Limited_View (Btyp_DDT)) then Btyp_DDT := Non_Limited_View (Btyp_DDT); elsif Is_Class_Wide_Type (Btyp_DDT) and then Ekind (Etype (Btyp_DDT)) = E_Incomplete_Type - and then From_With_Type (Etype (Btyp_DDT)) + and then From_Limited_With (Etype (Btyp_DDT)) and then Present (Non_Limited_View (Etype (Btyp_DDT))) and then Present (Class_Wide_Type (Non_Limited_View (Etype (Btyp_DDT)))) @@ -6485,6 +6485,7 @@ package body Exp_Attr is Attribute_Has_Tagged_Values | Attribute_Large | Attribute_Last_Valid | + Attribute_Library_Level | Attribute_Lock_Free | Attribute_Machine_Emax | Attribute_Machine_Emin | @@ -6608,12 +6609,14 @@ package body Exp_Attr is procedure Process_Range_Update (Temp : Entity_Id; Comp : Node_Id; - Expr : Node_Id); + Expr : Node_Id; + Typ : Entity_Id); -- Generate the statements necessary to update a slice of the prefix. -- The code is inserted before the attribute N. Temp denotes the entity -- of the anonymous object created to reflect the changes in values. -- Comp is range of the slice to be updated. Expr is an expression - -- yielding the new value of Comp. + -- yielding the new value of Comp. Typ is the type of the prefix of + -- attribute Update. ----------------------------------------- -- Process_Component_Or_Element_Update -- @@ -6687,10 +6690,12 @@ package body Exp_Attr is procedure Process_Range_Update (Temp : Entity_Id; Comp : Node_Id; - Expr : Node_Id) + Expr : Node_Id; + Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (Comp); - Index : Entity_Id; + Index_Typ : constant Entity_Id := Etype (First_Index (Typ)); + Loc : constant Source_Ptr := Sloc (Comp); + Index : Entity_Id; begin -- A range update appears as @@ -6702,7 +6707,7 @@ package body Exp_Attr is -- value of Expr: -- for Index in Low .. High loop - -- Temp (Index) := Expr; + -- Temp (<Index_Typ> (Index)) := Expr; -- end loop; Index := Make_Temporary (Loc, 'I'); @@ -6721,7 +6726,8 @@ package body Exp_Attr is Name => Make_Indexed_Component (Loc, Prefix => New_Reference_To (Temp, Loc), - Expressions => New_List (New_Reference_To (Index, Loc))), + Expressions => New_List ( + Convert_To (Index_Typ, New_Reference_To (Index, Loc)))), Expression => Relocate_Node (Expr))), End_Label => Empty)); @@ -6729,10 +6735,10 @@ package body Exp_Attr is -- Local variables - Aggr : constant Node_Id := First (Expressions (N)); + Aggr : constant Node_Id := First (Expressions (N)); Loc : constant Source_Ptr := Sloc (N); - Pref : constant Node_Id := Prefix (N); - Typ : constant Entity_Id := Etype (Pref); + Pref : constant Node_Id := Prefix (N); + Typ : constant Entity_Id := Etype (Pref); Assoc : Node_Id; Comp : Node_Id; Expr : Node_Id; @@ -6762,7 +6768,7 @@ package body Exp_Attr is Expr := Expression (Assoc); while Present (Comp) loop if Nkind (Comp) = N_Range then - Process_Range_Update (Temp, Comp, Expr); + Process_Range_Update (Temp, Comp, Expr, Typ); else Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ); end if; @@ -6879,7 +6885,7 @@ package body Exp_Attr is -- Function to check whether the specified run-time call is available -- in the run time used. In the case of a configurable run time, it -- is normal that some subprograms are not there. - + -- -- I don't understand this routine at all, why is this not just a -- call to RTE_Available? And if for some reason we need a different -- routine with different semantics, why is not in Rtsfind ??? @@ -6893,8 +6899,7 @@ package body Exp_Attr is -- Assume that the unit will always be available when using a -- "normal" (not configurable) run time. - return not Configurable_Run_Time_Mode - or else RTE_Available (Entity); + return not Configurable_Run_Time_Mode or else RTE_Available (Entity); end Is_Available; -- Start of processing for Find_Stream_Subprogram @@ -6929,9 +6934,148 @@ package body Exp_Attr is and then not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) then + -- Storage_Array as defined in package System.Storage_Elements + + if Is_RTE (Base_Typ, RE_Storage_Array) then + + -- Case of No_Stream_Optimizations restriction active + + if Restriction_Active (No_Stream_Optimizations) then + if Nam = TSS_Stream_Input + and then Is_Available (RE_Storage_Array_Input) + then + return RTE (RE_Storage_Array_Input); + + elsif Nam = TSS_Stream_Output + and then Is_Available (RE_Storage_Array_Output) + then + return RTE (RE_Storage_Array_Output); + + elsif Nam = TSS_Stream_Read + and then Is_Available (RE_Storage_Array_Read) + then + return RTE (RE_Storage_Array_Read); + + elsif Nam = TSS_Stream_Write + and then Is_Available (RE_Storage_Array_Write) + then + return RTE (RE_Storage_Array_Write); + + elsif Nam /= TSS_Stream_Input and then + Nam /= TSS_Stream_Output and then + Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Write + then + raise Program_Error; + end if; + + -- Restriction No_Stream_Optimizations is not set, so we can go + -- ahead and optimize using the block IO forms of the routines. + + else + if Nam = TSS_Stream_Input + and then Is_Available (RE_Storage_Array_Input_Blk_IO) + then + return RTE (RE_Storage_Array_Input_Blk_IO); + + elsif Nam = TSS_Stream_Output + and then Is_Available (RE_Storage_Array_Output_Blk_IO) + then + return RTE (RE_Storage_Array_Output_Blk_IO); + + elsif Nam = TSS_Stream_Read + and then Is_Available (RE_Storage_Array_Read_Blk_IO) + then + return RTE (RE_Storage_Array_Read_Blk_IO); + + elsif Nam = TSS_Stream_Write + and then Is_Available (RE_Storage_Array_Write_Blk_IO) + then + return RTE (RE_Storage_Array_Write_Blk_IO); + + elsif Nam /= TSS_Stream_Input and then + Nam /= TSS_Stream_Output and then + Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Write + then + raise Program_Error; + end if; + end if; + + -- Stream_Element_Array as defined in package Ada.Streams + + elsif Is_RTE (Base_Typ, RE_Stream_Element_Array) then + + -- Case of No_Stream_Optimizations restriction active + + if Restriction_Active (No_Stream_Optimizations) then + if Nam = TSS_Stream_Input + and then Is_Available (RE_Stream_Element_Array_Input) + then + return RTE (RE_Stream_Element_Array_Input); + + elsif Nam = TSS_Stream_Output + and then Is_Available (RE_Stream_Element_Array_Output) + then + return RTE (RE_Stream_Element_Array_Output); + + elsif Nam = TSS_Stream_Read + and then Is_Available (RE_Stream_Element_Array_Read) + then + return RTE (RE_Stream_Element_Array_Read); + + elsif Nam = TSS_Stream_Write + and then Is_Available (RE_Stream_Element_Array_Write) + then + return RTE (RE_Stream_Element_Array_Write); + + elsif Nam /= TSS_Stream_Input and then + Nam /= TSS_Stream_Output and then + Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Write + then + raise Program_Error; + end if; + + -- Restriction No_Stream_Optimizations is not set, so we can go + -- ahead and optimize using the block IO forms of the routines. + + else + if Nam = TSS_Stream_Input + and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO) + then + return RTE (RE_Stream_Element_Array_Input_Blk_IO); + + elsif Nam = TSS_Stream_Output + and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO) + then + return RTE (RE_Stream_Element_Array_Output_Blk_IO); + + elsif Nam = TSS_Stream_Read + and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO) + then + return RTE (RE_Stream_Element_Array_Read_Blk_IO); + + elsif Nam = TSS_Stream_Write + and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO) + then + return RTE (RE_Stream_Element_Array_Write_Blk_IO); + + elsif Nam /= TSS_Stream_Input and then + Nam /= TSS_Stream_Output and then + Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Write + then + raise Program_Error; + end if; + end if; + -- String as defined in package Ada - if Base_Typ = Standard_String then + elsif Base_Typ = Standard_String then + + -- Case of No_Stream_Optimizations restriction active + if Restriction_Active (No_Stream_Optimizations) then if Nam = TSS_Stream_Input and then Is_Available (RE_String_Input) @@ -6961,6 +7105,9 @@ package body Exp_Attr is raise Program_Error; end if; + -- Restriction No_Stream_Optimizations is not set, so we can go + -- ahead and optimize using the block IO forms of the routines. + else if Nam = TSS_Stream_Input and then Is_Available (RE_String_Input_Blk_IO) @@ -6982,9 +7129,9 @@ package body Exp_Attr is then return RTE (RE_String_Write_Blk_IO); - elsif Nam /= TSS_Stream_Input and then + elsif Nam /= TSS_Stream_Input and then Nam /= TSS_Stream_Output and then - Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Read and then Nam /= TSS_Stream_Write then raise Program_Error; @@ -6994,6 +7141,9 @@ package body Exp_Attr is -- Wide_String as defined in package Ada elsif Base_Typ = Standard_Wide_String then + + -- Case of No_Stream_Optimizations restriction active + if Restriction_Active (No_Stream_Optimizations) then if Nam = TSS_Stream_Input and then Is_Available (RE_Wide_String_Input) @@ -7015,14 +7165,17 @@ package body Exp_Attr is then return RTE (RE_Wide_String_Write); - elsif Nam /= TSS_Stream_Input and then + elsif Nam /= TSS_Stream_Input and then Nam /= TSS_Stream_Output and then - Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Read and then Nam /= TSS_Stream_Write then raise Program_Error; end if; + -- Restriction No_Stream_Optimizations is not set, so we can go + -- ahead and optimize using the block IO forms of the routines. + else if Nam = TSS_Stream_Input and then Is_Available (RE_Wide_String_Input_Blk_IO) @@ -7044,9 +7197,9 @@ package body Exp_Attr is then return RTE (RE_Wide_String_Write_Blk_IO); - elsif Nam /= TSS_Stream_Input and then + elsif Nam /= TSS_Stream_Input and then Nam /= TSS_Stream_Output and then - Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Read and then Nam /= TSS_Stream_Write then raise Program_Error; @@ -7056,6 +7209,9 @@ package body Exp_Attr is -- Wide_Wide_String as defined in package Ada elsif Base_Typ = Standard_Wide_Wide_String then + + -- Case of No_Stream_Optimizations restriction active + if Restriction_Active (No_Stream_Optimizations) then if Nam = TSS_Stream_Input and then Is_Available (RE_Wide_Wide_String_Input) @@ -7077,14 +7233,17 @@ package body Exp_Attr is then return RTE (RE_Wide_Wide_String_Write); - elsif Nam /= TSS_Stream_Input and then + elsif Nam /= TSS_Stream_Input and then Nam /= TSS_Stream_Output and then - Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Read and then Nam /= TSS_Stream_Write then raise Program_Error; end if; + -- Restriction No_Stream_Optimizations is not set, so we can go + -- ahead and optimize using the block IO forms of the routines. + else if Nam = TSS_Stream_Input and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO) @@ -7106,9 +7265,9 @@ package body Exp_Attr is then return RTE (RE_Wide_Wide_String_Write_Blk_IO); - elsif Nam /= TSS_Stream_Input and then + elsif Nam /= TSS_Stream_Input and then Nam /= TSS_Stream_Output and then - Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Read and then Nam /= TSS_Stream_Write then raise Program_Error; @@ -7117,9 +7276,7 @@ package body Exp_Attr is end if; end if; - if Is_Tagged_Type (Typ) - and then Is_Derived_Type (Typ) - then + if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then return Find_Prim_Op (Typ, Nam); else return Find_Inherited_TSS (Typ, Nam); diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 90ca6dae79b..8be585c7725 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1025,7 +1025,13 @@ package body Exp_Ch11 is -- ... -- end; - if Present (Choice_Parameter (Handler)) then + -- This expansion is not performed when using GCC ZCX. Gigi + -- will insert a call to initialize the choice parameter. + + if Present (Choice_Parameter (Handler)) + and then (Exception_Mechanism /= Back_End_Exceptions + or else CodePeer_Mode) + then declare Cparm : constant Entity_Id := Choice_Parameter (Handler); Cloc : constant Source_Ptr := Sloc (Cparm); @@ -1033,43 +1039,42 @@ package body Exp_Ch11 is Save : Node_Id; begin - -- Note use of No_Location to hide this code from the - -- debugger, so single stepping doesn't jump back and - -- forth. + -- Note: No_Location used to hide code from the debugger, + -- so single stepping doesn't jump back and forth. Save := Make_Procedure_Call_Statement (No_Location, - Name => + Name => New_Occurrence_Of (RTE (RE_Save_Occurrence), No_Location), Parameter_Associations => New_List ( New_Occurrence_Of (Cparm, No_Location), Make_Explicit_Dereference (No_Location, - Make_Function_Call (No_Location, - Name => - Make_Explicit_Dereference (No_Location, - New_Occurrence_Of - (RTE (RE_Get_Current_Excep), - No_Location)))))); + Prefix => + Make_Function_Call (No_Location, + Name => + Make_Explicit_Dereference (No_Location, + Prefix => + New_Occurrence_Of + (RTE (RE_Get_Current_Excep), + No_Location)))))); Mark_Rewrite_Insertion (Save); Prepend (Save, Statements (Handler)); Obj_Decl := - Make_Object_Declaration - (Cloc, - Defining_Identifier => Cparm, - Object_Definition => - New_Occurrence_Of - (RTE (RE_Exception_Occurrence), Cloc)); + Make_Object_Declaration (Cloc, + Defining_Identifier => Cparm, + Object_Definition => + New_Occurrence_Of + (RTE (RE_Exception_Occurrence), Cloc)); Set_No_Initialization (Obj_Decl, True); Rewrite (Handler, Make_Exception_Handler (Hloc, Choice_Parameter => Empty, Exception_Choices => Exception_Choices (Handler), - - Statements => New_List ( + Statements => New_List ( Make_Block_Statement (Hloc, Declarations => New_List (Obj_Decl), Handled_Statement_Sequence => @@ -1166,18 +1171,17 @@ package body Exp_Ch11 is -- Generates: -- exceptE : constant String := "A.B.EXCEP"; -- static data - -- except : exception_data := ( - -- Handled_By_Other => False, - -- Lang => 'A', - -- Name_Length => exceptE'Length, - -- Full_Name => exceptE'Address, - -- HTable_Ptr => null, - -- Import_Code => 0, - -- Raise_Hook => null, - -- ); + -- except : exception_data := + -- (Handled_By_Other => False, + -- Lang => 'A', + -- Name_Length => exceptE'Length, + -- Full_Name => exceptE'Address, + -- HTable_Ptr => null, + -- Foreign_Data => null, + -- Raise_Hook => null); -- (protecting test only needed if not at library level) - -- + -- exceptF : Boolean := True -- static data -- if exceptF then -- exceptF := False; @@ -1319,9 +1323,9 @@ package body Exp_Ch11 is Append_To (L, Make_Null (Loc)); - -- Import_Code component: 0 + -- Foreign_Data component: null - Append_To (L, Make_Integer_Literal (Loc, 0)); + Append_To (L, Make_Null (Loc)); -- Raise_Hook component: null @@ -1446,7 +1450,7 @@ package body Exp_Ch11 is RCE : Node_Id; begin - Possible_Local_Raise (N, Name (N)); + Possible_Local_Raise (N, Entity (Name (N))); -- Later we must teach the back end/gigi how to deal with this, but -- for now we will assume the type is Standard_Boolean and transform diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index a21de7edb16..f1ab0c5e765 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1893,7 +1893,7 @@ package body Exp_Ch3 is if Needs_Finalization (Typ) and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) - and then not Is_Immutably_Limited_Type (Typ) + and then not Is_Limited_View (Typ) then Append_To (Res, Make_Adjust_Call @@ -4940,7 +4940,7 @@ package body Exp_Ch3 is Next_Elmt (Discr); end loop; - -- Now collect values of initialized components. + -- Now collect values of initialized components Comp := First_Component (Full_Type); while Present (Comp) loop @@ -4957,11 +4957,11 @@ package body Exp_Ch3 is Next_Component (Comp); end loop; - -- Finally, box-initialize remaining components. + -- Finally, box-initialize remaining components Append_To (Component_Associations (Aggr), Make_Component_Association (Loc, - Choices => New_List (Make_Others_Choice (Loc)), + Choices => New_List (Make_Others_Choice (Loc)), Expression => Empty)); Set_Box_Present (Last (Component_Associations (Aggr))); Set_Expression (N, Aggr); @@ -5310,7 +5310,7 @@ package body Exp_Ch3 is -- creating the object (via allocator) and initializing it. if Is_Return_Object (Def_Id) - and then Is_Immutably_Limited_Type (Typ) + and then Is_Limited_View (Typ) then null; @@ -5578,7 +5578,7 @@ package body Exp_Ch3 is -- renaming declaration. if Needs_Finalization (Typ) - and then not Is_Immutably_Limited_Type (Typ) + and then not Is_Limited_View (Typ) and then not Rewrite_As_Renaming then Insert_Action_After (Init_After, @@ -5846,23 +5846,18 @@ package body Exp_Ch3 is -- Expand_N_Variant_Part -- --------------------------- - -- If the last variant does not contain the Others choice, replace it with - -- an N_Others_Choice node since Gigi always wants an Others. Note that we - -- do not bother to call Analyze on the modified variant part, since its - -- only effect would be to compute the Others_Discrete_Choices node - -- laboriously, and of course we already know the list of choices that - -- corresponds to the others choice (it's the list we are replacing!) + -- Note: this procedure no longer has any effect. It used to be that we + -- would replace the choices in the last variant by a when others, and + -- also expanded static predicates in variant choices here, but both of + -- those activities were being done too early, since we can't check the + -- choices until the statically predicated subtypes are frozen, which can + -- happen as late as the free point of the record, and we can't change the + -- last choice to an others before checking the choices, which is now done + -- at the freeze point of the record. procedure Expand_N_Variant_Part (N : Node_Id) is - Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N)); - Others_Node : Node_Id; begin - if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then - Others_Node := Make_Others_Choice (Sloc (Last_Var)); - Set_Others_Discrete_Choices - (Others_Node, Discrete_Choices (Last_Var)); - Set_Discrete_Choices (Last_Var, New_List (Others_Node)); - end if; + null; end Expand_N_Variant_Part; --------------------------------- @@ -6156,12 +6151,6 @@ package body Exp_Ch3 is elsif CodePeer_Mode then return; - - -- Do not create TSS routine Finalize_Address when compiling in SPARK - -- mode because it is not necessary and results in useless expansion. - - elsif SPARK_Mode then - return; end if; -- Create the body of TSS primitive Finalize_Address. This automatically @@ -6908,13 +6897,9 @@ package body Exp_Ch3 is -- 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. Do not create the body of - -- Finalize_Address in SPARK mode since it is not needed. - - if not SPARK_Mode then - Make_Finalize_Address_Body (Def_Id); - end if; + -- 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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0802f2dfa51..ad65378cffb 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1244,7 +1244,7 @@ package body Exp_Ch4 is -- want to Adjust. if not Aggr_In_Place - and then not Is_Immutably_Limited_Type (T) + and then not Is_Limited_View (T) then Insert_Action (N, @@ -1268,14 +1268,10 @@ package body Exp_Ch4 is -- * .NET/JVM - these targets do not support address arithmetic -- and unchecked conversion, key elements of Finalize_Address. - -- * SPARK mode - the call is useless and results in unwanted - -- expansion. - -- * CodePeer mode - TSS primitive Finalize_Address is not -- created in this mode. if VM_Target = No_VM - and then not SPARK_Mode and then not CodePeer_Mode and then Present (Finalization_Master (PtrT)) and then Present (Temp_Decl) @@ -4295,16 +4291,13 @@ package body Exp_Ch4 is end if; -- The finalization master must be inserted and analyzed as part of - -- the current semantic unit. This form of expansion is not carried - -- out in SPARK mode because it is useless. Note that the master is - -- updated when analysis changes current units. + -- the current semantic unit. Note that the master is updated when + -- analysis changes current units. - if not SPARK_Mode then - if Present (Rel_Typ) then - Set_Finalization_Master (PtrT, Finalization_Master (Rel_Typ)); - else - Set_Finalization_Master (PtrT, Current_Anonymous_Master); - end if; + if Present (Rel_Typ) then + Set_Finalization_Master (PtrT, Finalization_Master (Rel_Typ)); + else + Set_Finalization_Master (PtrT, Current_Anonymous_Master); end if; end if; @@ -4839,15 +4832,11 @@ package body Exp_Ch4 is -- Set_Finalize_Address -- (<PtrT>FM, <T>FD'Unrestricted_Access); - -- Do not generate this call in the following cases: - -- - -- * SPARK mode - the call is useless and results in - -- unwanted expansion. - -- - -- * CodePeer mode - TSS primitive Finalize_Address is - -- not created in this mode. + -- Do not generate this call in CodePeer mode, as TSS + -- primitive Finalize_Address is not created in this + -- mode. - elsif not (SPARK_Mode or CodePeer_Mode) then + elsif not CodePeer_Mode then Insert_Action (N, Make_Set_Finalize_Address_Call (Loc => Loc, @@ -4891,6 +4880,7 @@ package body Exp_Ch4 is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); Cstmt : Node_Id; + Decl : Node_Id; Tnn : Entity_Id; Pnn : Entity_Id; Actions : List_Id; @@ -4958,19 +4948,24 @@ package body Exp_Ch4 is Append_To (Actions, Make_Full_Type_Declaration (Loc, Defining_Identifier => Pnn, - Type_Definition => + Type_Definition => Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => - New_Reference_To (Typ, Loc)))); + All_Present => True, + Subtype_Indication => New_Reference_To (Typ, Loc)))); Ttyp := Pnn; end if; Tnn := Make_Temporary (Loc, 'T'); - Append_To (Actions, + + -- Create declaration for target of expression, and indicate that it + -- does not require initialization. + + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Tnn, - Object_Definition => New_Occurrence_Of (Ttyp, Loc))); + Object_Definition => New_Occurrence_Of (Ttyp, Loc)); + Set_No_Initialization (Decl); + Append_To (Actions, Decl); -- Now process the alternatives @@ -7315,9 +7310,9 @@ package body Exp_Ch4 is begin Binary_Op_Validity_Checks (N); - -- CodePeer and GNATprove want to see the unexpanded N_Op_Expon node + -- CodePeer wants to see the unexpanded N_Op_Expon node - if CodePeer_Mode or SPARK_Mode then + if CodePeer_Mode then return; end if; @@ -12140,24 +12135,44 @@ package body Exp_Ch4 is (Decl : Node_Id; Rel_Node : Node_Id) is - function Find_Enclosing_Context (N : Node_Id) return Node_Id; - -- Find the logical context where N appears. The context is chosen such - -- that it is possible to insert before and after it. + Hook_Context : Node_Id; + -- Node on which to insert the hook pointer (as an action) - ---------------------------- - -- Find_Enclosing_Context -- - ---------------------------- + Finalization_Context : Node_Id; + -- Node after which to insert finalization actions + + Finalize_Always : Boolean; + -- If False, call to finalizer includes a test of whether the + -- hook pointer is null. - function Find_Enclosing_Context (N : Node_Id) return Node_Id is + procedure Find_Enclosing_Contexts (N : Node_Id); + -- Find the logical context where N appears, and initializae + -- Hook_Context and Finalization_Context accordingly. Also + -- sets Finalize_Always. + + ----------------------------- + -- Find_Enclosing_Contexts -- + ----------------------------- + + procedure Find_Enclosing_Contexts (N : Node_Id) is Par : Node_Id; Top : Node_Id; + Wrapped_Node : Node_Id; + -- Note: if we are in a transient scope, we want to reuse it as + -- the context for actions insertion, if possible. But if N is itself + -- part of the stored actions for the current transient scope, + -- then we need to insert at the appropriate (inner) location in + -- the not as an action on Node_To_Be_Wrapped. + + In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N); + begin -- When the node is inside a case/if expression, the lifetime of any -- temporary controlled object is extended. Find a suitable insertion -- node by locating the topmost case or if expressions. - if Within_Case_Or_If_Expression (N) then + if In_Cond_Expr then Par := N; Top := N; while Present (Par) loop @@ -12187,7 +12202,8 @@ package body Exp_Ch4 is N_Parameter_Association, N_Pragma_Argument_Association) then - return Par; + Hook_Context := Par; + goto Hook_Context_Found; -- Prevent the search from going too far @@ -12198,26 +12214,10 @@ package body Exp_Ch4 is Par := Parent (Par); end loop; - return Par; - - -- Short circuit operators in complex expressions are converted into - -- expression_with_actions. + Hook_Context := Par; + goto Hook_Context_Found; else - -- Handle the case where the node is buried deep inside an if - -- statement. The temporary controlled object must be finalized - -- before the then, elsif or else statements are evaluated. - - -- if Something - -- and then Ctrl_Func_Call - -- then - -- <result must be finalized at this point> - -- <statements> - -- end if; - - -- To achieve this, find the topmost logical operator. Generated - -- actions are then inserted before/after it. - Par := N; while Present (Par) loop @@ -12254,14 +12254,23 @@ package body Exp_Ch4 is -- Proc (... and then Ctrl_Func_Call ...); + if Scope_Is_Transient then + Wrapped_Node := Node_To_Be_Wrapped; + else + Wrapped_Node := Empty; + end if; + while Present (Par) loop - if Nkind_In (Par, N_Assignment_Statement, + if Par = Wrapped_Node + or else + Nkind_In (Par, N_Assignment_Statement, N_Object_Declaration, N_Pragma, N_Procedure_Call_Statement, N_Simple_Return_Statement) then - return Par; + Hook_Context := Par; + goto Hook_Context_Found; -- Prevent the search from going too far @@ -12274,25 +12283,71 @@ package body Exp_Ch4 is -- Return the topmost short circuit operator - return Top; + Hook_Context := Top; end if; - end Find_Enclosing_Context; + + <<Hook_Context_Found>> + + -- Special case for Boolean EWAs: capture expression in a temporary, + -- whose declaration will serve as the context around which to insert + -- finalization code. The finalization thus remains local to the + -- specific condition being evaluated. + + if Is_Boolean_Type (Etype (N)) then + + -- In this case, the finalization context is chosen so that + -- we know at finalization point that the hook pointer is + -- never null, so no need for a test, we can call the finalizer + -- unconditionally, except in the case where the object is + -- created in a specific branch of a conditional expression. + + Finalize_Always := + not (In_Cond_Expr + or else + Nkind_In (Original_Node (N), N_Case_Expression, + N_If_Expression)); + + declare + Loc : constant Source_Ptr := Sloc (N); + Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N); + begin + Append_To (Actions (N), + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Etype (N), Loc), + Expression => Expression (N))); + Finalization_Context := Last (Actions (N)); + + Analyze (Last (Actions (N))); + + Set_Expression (N, New_Occurrence_Of (Temp, Loc)); + Analyze (Expression (N)); + end; + + else + Finalize_Always := False; + Finalization_Context := Hook_Context; + end if; + end Find_Enclosing_Contexts; -- Local variables - Context : constant Node_Id := Find_Enclosing_Context (Rel_Node); Loc : constant Source_Ptr := Sloc (Decl); Obj_Id : constant Entity_Id := Defining_Identifier (Decl); Obj_Typ : constant Node_Id := Etype (Obj_Id); Desig_Typ : Entity_Id; Expr : Node_Id; - Fin_Call : Node_Id; + Fin_Stmts : List_Id; Ptr_Id : Entity_Id; Temp_Id : Entity_Id; -- Start of processing for Process_Transient_Object begin + Find_Enclosing_Contexts (Rel_Node); + -- Step 1: Create the access type which provides a reference to the -- transient controlled object. @@ -12309,7 +12364,7 @@ package body Exp_Ch4 is Ptr_Id := Make_Temporary (Loc, 'A'); - Insert_Action (Context, + Insert_Action (Hook_Context, Make_Full_Type_Declaration (Loc, Defining_Identifier => Ptr_Id, Type_Definition => @@ -12324,7 +12379,7 @@ package body Exp_Ch4 is Temp_Id := Make_Temporary (Loc, 'T'); - Insert_Action (Context, + Insert_Action (Hook_Context, Make_Object_Declaration (Loc, Defining_Identifier => Temp_Id, Object_Definition => New_Reference_To (Ptr_Id, Loc))); @@ -12338,6 +12393,13 @@ package body Exp_Ch4 is -- Step 3: Hook the transient object to the temporary + -- This must be inserted right after the object declaration, so that + -- the assignment is executed if, and only if, the object is actually + -- created (whereas the declaration of the hook pointer, and the + -- finalization call, may be inserted at an outer level, and may + -- remain unused for some executions, if the actual creation of + -- the object is conditional). + -- The use of unchecked conversion / unrestricted access is needed to -- avoid an accessibility violation. Note that the finalization code is -- structured in such a way that the "hook" is processed only when it @@ -12377,34 +12439,29 @@ package body Exp_Ch4 is -- insert the finalization code after the return statement as this will -- render it unreachable. - if Nkind (Context) /= N_Simple_Return_Statement then - Fin_Call := - Make_Implicit_If_Statement (Decl, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Reference_To (Temp_Id, Loc), - Right_Opnd => Make_Null (Loc)), - - Then_Statements => New_List ( - Make_Final_Call - (Obj_Ref => - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Temp_Id, Loc)), - Typ => Desig_Typ), - - Make_Assignment_Statement (Loc, - Name => New_Reference_To (Temp_Id, Loc), - Expression => Make_Null (Loc)))); + if Nkind (Finalization_Context) /= N_Simple_Return_Statement then + Fin_Stmts := New_List ( + Make_Final_Call + (Obj_Ref => + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp_Id, Loc)), + Typ => Desig_Typ), - -- Use the Actions list of logical operators when inserting the - -- finalization call. This ensures that all transient controlled - -- objects are finalized after the operators are evaluated. + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Temp_Id, Loc), + Expression => Make_Null (Loc))); - if Nkind_In (Context, N_And_Then, N_Or_Else) then - Insert_Action (Context, Fin_Call); - else - Insert_Action_After (Context, Fin_Call); + if not Finalize_Always then + Fin_Stmts := New_List ( + Make_Implicit_If_Statement (Decl, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Reference_To (Temp_Id, Loc), + Right_Opnd => Make_Null (Loc)), + Then_Statements => Fin_Stmts)); end if; + + Insert_Actions_After (Finalization_Context, Fin_Stmts); end if; end Process_Transient_Object; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 95e649a13e9..f166ff464ae 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2537,7 +2537,11 @@ package body Exp_Ch5 is -- if statement, since this can result in subsequent optimizations. -- This helps not only with case statements in the source of a -- simple form, but also with generated code (discriminant check - -- functions in particular) + -- functions in particular). + + -- Note: it is OK to do this before expanding out choices for any + -- static predicates, since the if statement processing will handle + -- the static predicate case fine. elsif Len = 2 then Chlist := Discrete_Choices (First (Alternatives (N))); @@ -2617,12 +2621,18 @@ package body Exp_Ch5 is Set_Discrete_Choices (Last_Alt, New_List (Others_Node)); end if; - Alt := First (Alternatives (N)); - while Present (Alt) - and then Nkind (Alt) = N_Case_Statement_Alternative - loop + -- Deal with possible declarations of controlled objects, and also + -- with rewriting choice sequences for static predicate references. + + Alt := First_Non_Pragma (Alternatives (N)); + while Present (Alt) loop Process_Statements_For_Controlled_Objects (Alt); - Next (Alt); + + if Has_SP_Choice (Alt) then + Expand_Static_Predicates_In_Choices (Alt); + end if; + + Next_Non_Pragma (Alt); end loop; end; end Expand_N_Case_Statement; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d48544fdada..adc0987fc44 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3947,7 +3947,7 @@ package body Exp_Ch6 is -- result from the secondary stack. if Needs_Finalization (Etype (Subp)) then - if not Is_Immutably_Limited_Type (Etype (Subp)) + if not Is_Limited_View (Etype (Subp)) and then (No (First_Formal (Subp)) or else @@ -4311,7 +4311,7 @@ package body Exp_Ch6 is if No (Checks) then Checks := - Make_If_Statement (Loc, + Make_Implicit_If_Statement (CCs, Condition => Cond, Then_Statements => New_List (Error)); @@ -4481,7 +4481,7 @@ package body Exp_Ch6 is -- end if; Append_To (Decls, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (CCs, Condition => Relocate_Node (Case_Guard), Then_Statements => New_List ( Set (Flag), @@ -4536,7 +4536,7 @@ package body Exp_Ch6 is end if; CG_Checks := - Make_If_Statement (Loc, + Make_Implicit_If_Statement (CCs, Condition => Make_Op_Eq (Loc, Left_Opnd => New_Reference_To (Count, Loc), @@ -7100,7 +7100,7 @@ package body Exp_Ch6 is then null; - elsif Is_Immutably_Limited_Type (Typ) then + elsif Is_Limited_View (Typ) then Set_Returns_By_Ref (Spec_Id); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then @@ -7702,7 +7702,7 @@ package body Exp_Ch6 is -- the type of the expression may be. if not Comes_From_Extended_Return_Statement (N) - and then Is_Immutably_Limited_Type (Etype (Expression (N))) + and then Is_Limited_View (Etype (Expression (N))) and then Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L @@ -7781,7 +7781,7 @@ package body Exp_Ch6 is -- type that requires special processing (indicated by the fact that -- it requires a cleanup scope for the secondary stack case). - if Is_Immutably_Limited_Type (Exptyp) + if Is_Limited_View (Exptyp) or else Is_Limited_Interface (Exptyp) then null; @@ -8084,8 +8084,9 @@ package body Exp_Ch6 is -- AI05-0073: If function has a controlling access result, check that -- the tag of the return value, if it is not null, matches designated -- type of return type. - -- The return expression is referenced twice in the code below, so - -- it must be made free of side effects. Given that different compilers + + -- The return expression is referenced twice in the code below, so it + -- must be made free of side effects. Given that different compilers -- may evaluate these parameters in different order, both occurrences -- perform a copy. @@ -8489,6 +8490,1050 @@ package body Exp_Ch6 is end Expand_Simple_Function_Return; -------------------------------- + -- Expand_Subprogram_Contract -- + -------------------------------- + + procedure Expand_Subprogram_Contract + (N : Node_Id; + Spec_Id : Entity_Id; + Body_Id : Entity_Id) + is + 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 Collect_Body_Postconditions (Stmts : in out List_Id); + -- Process all postconditions found in the declarations of the body. The + -- routine appends the pragma Check equivalents to list Stmts. + + procedure Collect_Spec_Postconditions + (Subp_Id : Entity_Id; + Stmts : in out List_Id); + -- Process all [inherited] postconditions of subprogram spec Subp_Id. + -- The routine appends the pragma Check equivalents to list Stmts. + + procedure Collect_Spec_Preconditions (Subp_Id : Entity_Id); + -- Process all [inherited] preconditions of subprogram spec Subp_Id. The + -- routine prepends the pragma Check equivalents to the declarations of + -- the body. + + procedure Prepend_To_Declarations (Item : Node_Id); + -- Prepend a single item to the declarations of the subprogram body + + procedure Process_Contract_Cases + (Subp_Id : Entity_Id; + Stmts : in out List_Id); + -- Process pragma Contract_Cases of subprogram spec Subp_Id. The routine + -- appends the expanded code to list Stmts. + + ---------------------------------------- + -- 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. + + function Predicate_Checks_OK (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ can benefit from predicate checks. To + -- qualify, the type must have at least one checked predicate. + + --------------------------------- + -- 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); + Vis_Decls : constant List_Id := + Visible_Declarations (Specification + (Unit_Declaration_Node (Scope (Typ)))); + 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; + + -- 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) = Vis_Decls; + 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; + + ------------------------- + -- Predicate_Checks_OK -- + ------------------------- + + function Predicate_Checks_OK (Typ : Entity_Id) return Boolean is + function Has_Checked_Predicate return Boolean; + -- Determine whether type Typ has or inherits at least one + -- predicate aspect or pragma, for which the applicable policy is + -- Checked. + + --------------------------- + -- Has_Checked_Predicate -- + --------------------------- + + function Has_Checked_Predicate return Boolean is + Anc : Entity_Id; + Pred : Node_Id; + + begin + -- Climb the ancestor type chain staring from the input. This + -- is done because the input type may lack aspect/pragma + -- predicate and simply inherit those from its ancestor. + + -- Note that predicate pragmas include all three cases of + -- predicate aspects (Predicate, Dynamic_Predicate, + -- Static_Predicate), so this routine checks for all three + -- cases. + + Anc := Typ; + while Present (Anc) loop + Pred := Get_Pragma (Anc, Pragma_Predicate); + + if Present (Pred) and then not Is_Ignored (Pred) then + return True; + end if; + + Anc := Nearest_Ancestor (Anc); + end loop; + + return False; + end Has_Checked_Predicate; + + -- Start of processing for Predicate_Checks_OK + + begin + return + Has_Predicates (Typ) + and then Present (Predicate_Function (Typ)) + and then Has_Checked_Predicate; + end Predicate_Checks_OK; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (N); + Formal : Entity_Id; + Typ : Entity_Id; + + -- Start of processing for Add_Invariant_And_Predicate_Checks + + begin + Result := Empty; + + -- Do not generate any checks if no code is being generated + + if not Expander_Active then + return; + end if; + + -- Process the result of a function + + if Ekind_In (Subp_Id, E_Function, E_Generic_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); + + if Predicate_Checks_OK (Typ) then + Append_Enabled_Item + (Item => + Make_Predicate_Check + (Typ, New_Reference_To (Formal, Loc)), + List => Stmts); + end if; + 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; + + -- Add the item + + else + if No (List) then + List := New_List; + end if; + + Append (Item, List); + 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_After_Last_Declaration (Stmt : Node_Id); + -- Insert node Stmt after the last declaration of the subprogram body + + ----------------------------------- + -- Insert_After_Last_Declaration -- + ----------------------------------- + + procedure Insert_After_Last_Declaration (Stmt : Node_Id) is + Decls : List_Id := Declarations (N); + + begin + -- Ensure that the body has a declaration list + + if No (Decls) then + Decls := New_List; + Set_Declarations (N, Decls); + end if; + + Append_To (Decls, Stmt); + end Insert_After_Last_Declaration; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (N); + Params : List_Id := No_List; + Proc_Id : Entity_Id; + + -- Start of processing for Build_Postconditions_Procedure + + begin + -- Do not create the routine if no code is being generated + + if not Expander_Active then + return; + + -- Nothing to do if there are no actions to check on exit + + elsif No (Stmts) then + return; + end if; + + Proc_Id := Make_Defining_Identifier (Loc, Name_uPostconditions); + + -- 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_Reference_To (Etype (Result), Loc))); + end if; + + -- Insert _Postconditions after the last 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. + + Insert_After_Last_Declaration ( + 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, Stmts))); + + -- Set the attributes of the related subprogram to capture the + -- generated procedure. + + if Ekind_In (Subp_Id, E_Generic_Procedure, E_Procedure) then + Set_Postcondition_Proc (Subp_Id, Proc_Id); + end if; + + Set_Has_Postconditions (Subp_Id); + 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 + 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; + + 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_Comes_From_Source (Check_Prag, False); + Set_Analyzed (Check_Prag, False); + + -- For a postcondition pragma within a generic, preserve the pragma + -- for later expansion. This is also used when an error was detected, + -- thus setting Expander_Active to False. + + if Prag_Nam = Name_Postcondition and then not Expander_Active then + return Check_Prag; + end if; + + 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; + + --------------------------------- + -- Collect_Body_Postconditions -- + --------------------------------- + + procedure Collect_Body_Postconditions (Stmts : in out List_Id) is + procedure Collect_Body_Postconditions_Of_Kind (Post_Nam : Name_Id); + -- Process postconditions of a particular kind denoted by Post_Nam + + ----------------------------------------- + -- Collect_Body_Postconditions_Of_Kind -- + ----------------------------------------- + + procedure Collect_Body_Postconditions_Of_Kind (Post_Nam : Name_Id) is + Check_Prag : Node_Id; + Decl : Node_Id; + + begin + pragma Assert (Nam_In (Post_Nam, Name_Postcondition, + Name_Refined_Post)); + + -- Inspect the declarations of the subprogram body looking for a + -- pragma that matches the desired name. + + Decl := First (Declarations (N)); + while Present (Decl) loop + if Nkind (Decl) = N_Pragma then + if Pragma_Name (Decl) = Post_Nam then + Analyze (Decl); + Check_Prag := Build_Pragma_Check_Equivalent (Decl); + + if Expander_Active then + Append_Enabled_Item + (Item => Check_Prag, + List => Stmts); + + -- When analyzing a generic unit, save the pragma for + -- later. + + else + Prepend_To_Declarations (Check_Prag); + end if; + end if; + + -- Skip internally generated code + + elsif not Comes_From_Source (Decl) then + null; + + -- Postconditions in bodies are usually grouped at the top of + -- the declarations. There is no point in inspecting the whole + -- source list. + + else + exit; + end if; + + Next (Decl); + end loop; + end Collect_Body_Postconditions_Of_Kind; + + -- Start of processing for Collect_Body_Postconditions + + begin + Collect_Body_Postconditions_Of_Kind (Name_Refined_Post); + Collect_Body_Postconditions_Of_Kind (Name_Postcondition); + end Collect_Body_Postconditions; + + --------------------------------- + -- Collect_Spec_Postconditions -- + --------------------------------- + + procedure Collect_Spec_Postconditions + (Subp_Id : Entity_Id; + Stmts : in out List_Id) + is + Inher_Subps : constant Subprogram_List := + Inherited_Subprograms (Subp_Id); + Check_Prag : Node_Id; + Prag : Node_Id; + Inher_Subp_Id : Entity_Id; + + begin + -- Process the contract of the spec + + Prag := Pre_Post_Conditions (Contract (Subp_Id)); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Postcondition then + Check_Prag := Build_Pragma_Check_Equivalent (Prag); + + if Expander_Active then + Append_Enabled_Item + (Item => Check_Prag, + List => Stmts); + + -- When analyzing a generic unit, save the pragma for later + + else + Prepend_To_Declarations (Check_Prag); + end if; + end if; + + Prag := Next_Pragma (Prag); + end loop; + + -- Process the contracts of all inherited subprograms, looking for + -- class-wide postconditions. + + for Index in Inher_Subps'Range loop + Inher_Subp_Id := Inher_Subps (Index); + + Prag := Pre_Post_Conditions (Contract (Inher_Subp_Id)); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Postcondition + and then Class_Present (Prag) + then + Check_Prag := + Build_Pragma_Check_Equivalent + (Prag => Prag, + Subp_Id => Subp_Id, + Inher_Id => Inher_Subp_Id); + + if Expander_Active then + Append_Enabled_Item + (Item => Check_Prag, + List => Stmts); + + -- When analyzing a generic unit, save the pragma for later + + else + Prepend_To_Declarations (Check_Prag); + end if; + end if; + + Prag := Next_Pragma (Prag); + end loop; + end loop; + end Collect_Spec_Postconditions; + + -------------------------------- + -- Collect_Spec_Preconditions -- + -------------------------------- + + procedure Collect_Spec_Preconditions (Subp_Id : Entity_Id) is + 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. + + ------------------------- + -- 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; + + -- Local variables + + Inher_Subps : constant Subprogram_List := + Inherited_Subprograms (Subp_Id); + Check_Prag : Node_Id; + Class_Pre : Node_Id := Empty; + Inher_Subp_Id : Entity_Id; + Prag : Node_Id; + + -- Start of processing for Collect_Spec_Preconditions + + begin + -- Process the contract of the spec + + Prag := Pre_Post_Conditions (Contract (Subp_Id)); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Precondition then + 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 + Class_Pre := Check_Prag; + + -- Accumulate the corresponding Check pragmas to the top of the + -- declarations. Prepending the items ensures that they will + -- be evaluated in their original order. + + else + Prepend_To_Declarations (Check_Prag); + end if; + end if; + + Prag := Next_Pragma (Prag); + end loop; + + -- Process the contracts of all inherited subprograms, looking for + -- class-wide preconditions. + + for Index in Inher_Subps'Range loop + Inher_Subp_Id := Inher_Subps (Index); + + Prag := Pre_Post_Conditions (Contract (Inher_Subp_Id)); + 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 => Subp_Id, + Inher_Id => Inher_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 loop; + + -- Add the merged class-wide preconditions (if any) + + if Present (Class_Pre) then + Prepend_To_Declarations (Class_Pre); + end if; + end Collect_Spec_Preconditions; + + ----------------------------- + -- Prepend_To_Declarations -- + ----------------------------- + + procedure Prepend_To_Declarations (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_Declarations; + + ---------------------------- + -- Process_Contract_Cases -- + ---------------------------- + + procedure Process_Contract_Cases + (Subp_Id : Entity_Id; + Stmts : in out List_Id) + is + Prag : Node_Id; + + begin + -- Do not build the Contract_Cases circuitry if no code is being + -- generated. + + if not Expander_Active then + return; + end if; + + Prag := Contract_Test_Cases (Contract (Subp_Id)); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Contract_Cases then + Expand_Contract_Cases + (CCs => Prag, + Subp_Id => Subp_Id, + Decls => Declarations (N), + Stmts => Stmts); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end Process_Contract_Cases; + + -- Local variables + + Post_Stmts : List_Id := No_List; + Result : Entity_Id; + Subp_Id : Entity_Id; + + -- Start of processing for Expand_Subprogram_Contract + + begin + if Present (Spec_Id) then + Subp_Id := Spec_Id; + else + Subp_Id := Body_Id; + end if; + + -- Do not process a predicate function as its body will end up with a + -- recursive call to itself and blow up the stack. + + if Ekind (Subp_Id) = E_Function + and then Is_Predicate_Function (Subp_Id) + then + return; + + -- Do not process TSS subprograms + + elsif Get_TSS_Name (Subp_Id) /= TSS_Null then + return; + end if; + + -- The expansion of a subprogram contract involves the relocation of + -- various contract assertions to the declarations of the 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 cases> + -- <invariant check of function result (if applicable)> + -- <invariant and predicate checks of parameters> + -- end _Postconditions; + + -- <inherited preconditions> + -- <preconditions from spec> + -- <preconditions from body> + -- <refined preconditions from body> + + -- <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 routine. + + -- Collect all [inherited] preconditions from the spec, transform them + -- into Check pragmas and add them to the declarations of the body in + -- the order outlined above. + + if Present (Spec_Id) then + Collect_Spec_Preconditions (Spec_Id); + end if; + + -- Transform all [refined] postconditions of the body into Check + -- pragmas. The resulting pragmas are accumulated in list Post_Stmts. + + Collect_Body_Postconditions (Post_Stmts); + + -- Transform all [inherited] postconditions from the spec into Check + -- pragmas. The resulting pragmas are accumulated in list Post_Stmts. + + if Present (Spec_Id) then + Collect_Spec_Postconditions (Spec_Id, Post_Stmts); + + -- Transform pragma Contract_Cases from the spec into its circuitry + + Process_Contract_Cases (Spec_Id, Post_Stmts); + end if; + + -- Apply invariant and predicate checks on the result of a function (if + -- applicable) and all formals. The resulting checks are accumulated in + -- list Post_Stmts. + + Add_Invariant_And_Predicate_Checks (Subp_Id, Post_Stmts, Result); + + -- Construct procedure _Postconditions + + Build_Postconditions_Procedure (Subp_Id, Post_Stmts, Result); + end Expand_Subprogram_Contract; + + -------------------------------- -- Is_Build_In_Place_Function -- -------------------------------- @@ -8527,7 +9572,7 @@ package body Exp_Ch6 is -- may return objects of nonlimited descendants. else - return Is_Immutably_Limited_Type (Etype (E)) + return Is_Limited_View (Etype (E)) and then Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L; end if; @@ -8554,7 +9599,11 @@ package body Exp_Ch6 is -- disabled (such as with -gnatc) since those would trip over the raise -- of Program_Error below. - if not Expander_Active then + -- In SPARK mode, build-in-place calls are not expanded, so that we + -- may end up with a call that is neither resolved to an entity, nor + -- an indirect call. + + if not Full_Expander_Active then return False; end if; @@ -8571,14 +9620,7 @@ package body Exp_Ch6 is return False; else - -- In SPARK mode, build-in-place calls are not expanded, so that we - -- may end up with a call that is neither resolved to an entity, nor - -- an indirect call. - - if SPARK_Mode then - return False; - - elsif Is_Entity_Name (Name (Exp_Node)) then + if Is_Entity_Name (Name (Exp_Node)) then Function_Id := Entity (Name (Exp_Node)); -- In the case of an explicitly dereferenced call, use the subprogram @@ -8771,7 +9813,7 @@ package body Exp_Ch6 is Typ : constant Entity_Id := Etype (Subp); Utyp : constant Entity_Id := Underlying_Type (Typ); begin - if Is_Immutably_Limited_Type (Typ) then + if Is_Limited_View (Typ) then Set_Returns_By_Ref (Subp); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Subp); @@ -9047,14 +10089,10 @@ package body Exp_Ch6 is then null; - -- Do not generate the call to Set_Finalize_Address in SPARK mode - -- because it is not necessary and results in unwanted expansion. - -- This expansion is also not carried out in CodePeer mode because - -- Finalize_Address is never built. + -- Do not generate the call to Set_Finalize_Address in CodePeer mode + -- because Finalize_Address is never built. - elsif not SPARK_Mode - and then not CodePeer_Mode - then + elsif not CodePeer_Mode then Insert_Action (Allocator, Make_Set_Finalize_Address_Call (Loc, Typ => Etype (Function_Id), diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index f9829f52b34..02cca2401df 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -82,6 +82,18 @@ package Exp_Ch6 is -- Subp_Id's body. All generated code is added to list Stmts. If Stmts is -- empty, a new list is created. + procedure Expand_Subprogram_Contract + (N : Node_Id; + Spec_Id : Entity_Id; + 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. N is the body of the + -- subprogram. Spec_Id denotes the entity of its specification. Body_Id + -- denotes the entity of the subprogram body. This routine is not a "pure" + -- expansion mechanism as it is invoked during analysis and may perform + -- actions for generic subprograms or set up contract assertions for ASIS. + 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 diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index fdaf213ff86..8449f6aba1f 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -310,11 +310,11 @@ package body Exp_Ch7 is Defer_Abort : Boolean; Fin_Id : out Entity_Id); -- N may denote an accept statement, block, entry body, package body, - -- package spec, protected body, subprogram body, and a task body. Create + -- package spec, protected body, subprogram body, or a task body. Create -- a procedure which contains finalization calls for all controlled objects -- declared in the declarative or statement region of N. The calls are -- built in reverse order relative to the original declarations. In the - -- case of a tack body, the routine delays the creation of the finalizer + -- case of a task body, the routine delays the creation of the finalizer -- until all statements have been moved to the task body procedure. -- Clean_Stmts may contain additional context-dependent code used to abort -- asynchronous calls or complete tasks (see Build_Cleanup_Statements). @@ -368,6 +368,11 @@ package body Exp_Ch7 is -- Given an arbitrary entity, traverse the scope chain looking for the -- first enclosing function. Return Empty if no function was found. + procedure Expand_Pragma_Initial_Condition (N : Node_Id); + -- Subsidiary to the expansion of package specs and bodies. Generate a + -- runtime check needed to verify the assumption introduced by pragma + -- Initial_Condition. N denotes the package spec or body. + function Make_Call (Loc : Source_Ptr; Proc_Id : Entity_Id; @@ -427,7 +432,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); - if not Is_Immutably_Limited_Type (Typ) then + if not Is_Limited_View (Typ) then Set_TSS (Typ, Make_Deep_Proc (Prim => Adjust_Case, @@ -3222,7 +3227,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); - if not Is_Immutably_Limited_Type (Typ) then + if not Is_Limited_View (Typ) then Set_TSS (Typ, Make_Deep_Proc (Prim => Adjust_Case, @@ -3959,6 +3964,15 @@ package body Exp_Ch7 is end if; Build_Task_Activation_Call (N); + + -- When the package is subject to pragma Initial_Condition, the + -- assertion expression must be verified at the end of the body + -- statements. + + if Present (Get_Pragma (Spec_Ent, Pragma_Initial_Condition)) then + Expand_Pragma_Initial_Condition (N); + end if; + Pop_Scope; end if; @@ -4053,10 +4067,9 @@ package body Exp_Ch7 is if No_Body then Push_Scope (Id); - if Has_RACW (Id) then - - -- Generate RACW subprogram bodies + -- Generate RACW subprogram bodies + if Has_RACW (Id) then Decls := Private_Declarations (Spec); if No (Decls) then @@ -4072,11 +4085,19 @@ package body Exp_Ch7 is Analyze_List (Decls); end if; + -- Generate task activation call as last step of elaboration + if Present (Activation_Chain_Entity (N)) then + Build_Task_Activation_Call (N); + end if; - -- Generate task activation call as last step of elaboration + -- When the package is subject to pragma Initial_Condition and lacks + -- a body, the assertion expression must be verified at the end of + -- the visible declarations. Otherwise the check is performed at the + -- end of the body statements (see Expand_N_Package_Body). - Build_Task_Activation_Call (N); + if Present (Get_Pragma (Id, Pragma_Initial_Condition)) then + Expand_Pragma_Initial_Condition (N); end if; Pop_Scope; @@ -4114,6 +4135,88 @@ package body Exp_Ch7 is end if; end Expand_N_Package_Declaration; + ------------------------------------- + -- Expand_Pragma_Initial_Condition -- + ------------------------------------- + + procedure Expand_Pragma_Initial_Condition (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Check : Node_Id; + Expr : Node_Id; + Init_Cond : Node_Id; + List : List_Id; + Pack_Id : Entity_Id; + + begin + if Nkind (N) = N_Package_Body then + Pack_Id := Corresponding_Spec (N); + + if Present (Handled_Statement_Sequence (N)) then + List := Statements (Handled_Statement_Sequence (N)); + + -- The package body lacks statements, create an empty list + + else + List := New_List; + + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, Statements => List)); + end if; + + elsif Nkind (N) = N_Package_Declaration then + Pack_Id := Defining_Entity (N); + + if Present (Visible_Declarations (Specification (N))) then + List := Visible_Declarations (Specification (N)); + + -- The package lacks visible declarations, create an empty list + + else + List := New_List; + + Set_Visible_Declarations (Specification (N), List); + end if; + + -- This routine should not be used on anything other than packages + + else + raise Program_Error; + end if; + + Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition); + + -- The caller should check whether the package is subject to pragma + -- Initial_Condition. + + pragma Assert (Present (Init_Cond)); + + Expr := + Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond))); + + -- The assertion expression was found to be illegal, do not generate the + -- runtime check as it will repeat the illegality. + + if Error_Posted (Init_Cond) or else Error_Posted (Expr) then + return; + end if; + + -- Generate: + -- pragma Check (Initial_Condition, <Expr>); + + Check := + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Initial_Condition)), + + Make_Pragma_Argument_Association (Loc, + Expression => New_Copy_Tree (Expr)))); + + Append_To (List, Check); + Analyze (Check); + end Expand_Pragma_Initial_Condition; + ----------------------------- -- Find_Node_To_Be_Wrapped -- ----------------------------- diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 16e83091529..8db80bde74b 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -8987,8 +8987,6 @@ package body Exp_Ch9 is (Prot_Typ, Cdecls, Loc); begin - -- Could this be simplified using Corresponding_Runtime_Package??? - if Has_Attach_Handler (Prot_Typ) then Ritem := First_Rep_Item (Prot_Typ); while Present (Ritem) loop @@ -9000,47 +8998,40 @@ package body Exp_Ch9 is Next_Rep_Item (Ritem); end loop; + end if; - if Restricted_Profile then - if Has_Entries (Prot_Typ) then - Protection_Subtype := - New_Reference_To (RTE (RE_Protection_Entry), Loc); - else - Protection_Subtype := - New_Reference_To (RTE (RE_Protection), Loc); - end if; + -- Determine the proper protection type. There are two special + -- cases: 1) when the protected type has dynamic interrupt + -- handlers, and 2) when it has static handlers and we use a + -- restricted profile. - else - Protection_Subtype := - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Reference_To - (RTE (RE_Static_Interrupt_Protection), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Entry_Count_Expr, - Make_Integer_Literal (Loc, Num_Attach_Handler)))); - end if; + if Has_Attach_Handler (Prot_Typ) + and then not Restricted_Profile + then + Protection_Subtype := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To + (RTE (RE_Static_Interrupt_Protection), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Entry_Count_Expr, + Make_Integer_Literal (Loc, Num_Attach_Handler)))); elsif Has_Interrupt_Handler (Prot_Typ) and then not Restriction_Active (No_Dynamic_Attachment) then Protection_Subtype := - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Reference_To - (RTE (RE_Dynamic_Interrupt_Protection), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List (Entry_Count_Expr))); - - -- Type has explicit entries or generated primitive entry wrappers + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To + (RTE (RE_Dynamic_Interrupt_Protection), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List (Entry_Count_Expr))); - elsif Has_Entries (Prot_Typ) - or else (Ada_Version >= Ada_2005 - and then Present (Interface_List (N))) - then + else case Corresponding_Runtime_Package (Prot_Typ) is when System_Tasking_Protected_Objects_Entries => Protection_Subtype := @@ -9056,13 +9047,13 @@ package body Exp_Ch9 is Protection_Subtype := New_Reference_To (RTE (RE_Protection_Entry), Loc); + when System_Tasking_Protected_Objects => + Protection_Subtype := + New_Reference_To (RTE (RE_Protection), Loc); + when others => raise Program_Error; end case; - - else - Protection_Subtype := - New_Reference_To (RTE (RE_Protection), Loc); end if; Object_Comp := @@ -11957,7 +11948,10 @@ package body Exp_Ch9 is -- end if; -- end; - -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call; + -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there + -- is no delay and the triggering statements are executed. We first + -- determine the kind of of the triggering call and then execute a + -- synchronized operation or a direct call. -- declare -- B : Boolean := False; @@ -11974,7 +11968,7 @@ package body Exp_Ch9 is -- or else K = Ada.Tags.TK_Tagged -- then -- <dispatching-call>; - -- <triggering-statements> + -- B := True; -- else -- S := @@ -11998,20 +11992,19 @@ package body Exp_Ch9 is -- then -- <dispatching-call>; -- end if; - - -- <triggering-statements> - -- else - -- <timed-statements> - -- end if; + -- end if; -- end if; + + -- if B then + -- <triggering-statements> + -- else + -- <timed-statements> + -- end if; -- end; -- The triggering statement and the sequence of timed statements have not -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain - -- global references if within an instantiation. To prevent duplication - -- between various uses of those statements, they are encapsulated into a - -- local procedure which is invoked multiple time when the trigger is a - -- dispatching call. + -- global references if within an instantiation. procedure Expand_N_Timed_Entry_Call (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -12054,63 +12047,6 @@ package body Exp_Ch9 is P : Entity_Id; -- Parameter block S : Entity_Id; -- Primitive operation slot - procedure Rewrite_Triggering_Statements; - -- If the trigger is a dispatching call, the expansion inserts multiple - -- copies of the abortable part. This is both inefficient, and may lead - -- to duplicate definitions that the back-end will reject, when the - -- abortable part includes loops. This procedure rewrites the abortable - -- part into a call to a generated procedure. - - ----------------------------------- - -- Rewrite_Triggering_Statements -- - ----------------------------------- - - procedure Rewrite_Triggering_Statements is - Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); - Decl : Node_Id; - Stat : Node_Id; - - begin - Decl := - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc), - Declarations => New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, E_Stats)); - - Append_To (Decls, Decl); - - -- Adjust the scope of blocks in the procedure. Needed because blocks - -- generate declarations that are processed before other analysis - -- takes place, and their scope is already set. The backend depends - -- on the scope chain to determine the legality of some anonymous - -- types, and thus we must indicate that the block is within the new - -- procedure. - - Stat := First (E_Stats); - while Present (Stat) loop - if Nkind (Stat) = N_Block_Statement then - Insert_Before (Stat, - Make_Implicit_Label_Declaration (Sloc (Stat), - Defining_Identifier => - Make_Defining_Identifier ( - Sloc (Stat), Chars (Identifier (Stat))))); - end if; - - Next (Stat); - end loop; - - -- Analyze (Decl); - - -- Rewrite abortable part into a call to this procedure. - - E_Stats := - New_List - (Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Proc, Loc))); - end Rewrite_Triggering_Statements; - -- Start of processing for Expand_N_Timed_Entry_Call begin @@ -12153,7 +12089,6 @@ package body Exp_Ch9 is if Is_Disp_Select then Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); Decls := New_List; - Rewrite_Triggering_Statements; Stmts := New_List; @@ -12358,20 +12293,10 @@ package body Exp_Ch9 is -- then -- <dispatching-call> -- end if; - -- <triggering-statements> - -- else - -- <timed-statements> -- end if; - -- Note: we used to do Copy_Separate_List here, but this was changed - -- to New_Copy_List_Tree with no explanation or RH note??? We should - -- explain the need for the change ??? - - N_Stats := New_Copy_List_Tree (E_Stats); - - Prepend_To (N_Stats, + N_Stats := New_List ( Make_Implicit_If_Statement (N, - Condition => Make_Or_Else (Loc, Left_Opnd => @@ -12400,19 +12325,17 @@ package body Exp_Ch9 is Append_To (Conc_Typ_Stmts, Make_Implicit_If_Statement (N, Condition => New_Reference_To (B, Loc), - Then_Statements => N_Stats, - Else_Statements => D_Stats)); + Then_Statements => N_Stats)); -- Generate: -- <dispatching-call>; - -- <triggering-statements> - - -- Note: the following was Copy_Separate_List but it was changed to - -- New_Copy_List_Tree without comments or RH documentation ??? We - -- should explain the need for the change ??? + -- B := True; - Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats); - Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call)); + Lim_Typ_Stmts := + New_List (New_Copy_Tree (E_Call), + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (B, Loc), + Expression => New_Occurrence_Of (Standard_True, Loc))); -- Generate: -- if K = Ada.Tags.TK_Limited_Tagged @@ -12429,8 +12352,24 @@ package body Exp_Ch9 is Then_Statements => Lim_Typ_Stmts, Else_Statements => Conc_Typ_Stmts)); + -- Generate: + + -- if B then + -- <triggering-statements> + -- else + -- <timed-statements> + -- end if; + + Append_To (Stmts, + Make_Implicit_If_Statement (N, + Condition => New_Occurrence_Of (B, Loc), + Then_Statements => E_Stats, + Else_Statements => D_Stats)); + else - -- Skip assignments to temporaries created for in-out parameters. + -- Simple case of a non-dispatching trigger. Skip assignments to + -- temporaries created for in-out parameters. + -- This makes unwarranted assumptions about the shape of the expanded -- tree for the call, and should be cleaned up ??? @@ -13095,7 +13034,6 @@ package body Exp_Ch9 is if Has_Attach_Handler (Conc_Typ) and then not Restricted_Profile - and then not Restriction_Active (No_Dynamic_Attachment) then Prot_Typ := RE_Static_Interrupt_Protection; @@ -13104,14 +13042,7 @@ package body Exp_Ch9 is then Prot_Typ := RE_Dynamic_Interrupt_Protection; - -- The type has explicit entries or generated primitive entry - -- wrappers. - - elsif Has_Entries (Conc_Typ) - or else - (Ada_Version >= Ada_2005 - and then Present (Interface_List (Parent (Conc_Typ)))) - then + else case Corresponding_Runtime_Package (Conc_Typ) is when System_Tasking_Protected_Objects_Entries => Prot_Typ := RE_Protection_Entries; @@ -13119,12 +13050,12 @@ package body Exp_Ch9 is when System_Tasking_Protected_Objects_Single_Entry => Prot_Typ := RE_Protection_Entry; + when System_Tasking_Protected_Objects => + Prot_Typ := RE_Protection; + when others => raise Program_Error; end case; - - else - Prot_Typ := RE_Protection; end if; -- Generate: @@ -13659,91 +13590,108 @@ package body Exp_Ch9 is -- considered equivalent to a protected type with entries in the -- context of dispatching select statements. - if Has_Entry - or else Has_Interfaces (Protect_Rec) - or else - ((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp)) - and then not Restriction_Active (No_Dynamic_Attachment)) - then - declare - Pkg_Id : constant RTU_Id := - Corresponding_Runtime_Package (Ptyp); + -- Protected types with interrupt handlers (when not using a + -- restricted profile) are also considered equivalent to protected + -- types with entries. - Called_Subp : RE_Id; + -- The types which are used (Static_Interrupt_Protection and + -- Dynamic_Interrupt_Protection) are derived from Protection_Entries. - begin - case Pkg_Id is - when System_Tasking_Protected_Objects_Entries => - Called_Subp := RE_Initialize_Protection_Entries; + declare + Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); - when System_Tasking_Protected_Objects => - Called_Subp := RE_Initialize_Protection; + Called_Subp : RE_Id; - when System_Tasking_Protected_Objects_Single_Entry => - Called_Subp := RE_Initialize_Protection_Entry; + begin + case Pkg_Id is + when System_Tasking_Protected_Objects_Entries => + Called_Subp := RE_Initialize_Protection_Entries; - when others => - raise Program_Error; - end case; + -- Argument Compiler_Info - if Has_Entry - or else not Restricted - or else Has_Interfaces (Protect_Rec) - then Append_To (Args, Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Attribute_Name => Name_Address)); - end if; - -- Entry_Bodies parameter. This is a pointer to an array of - -- pointers to the entry body procedures and barrier functions - -- of the object. If the protected type has no entries this - -- object will not exist, in this case, pass a null. + when System_Tasking_Protected_Objects_Single_Entry => + Called_Subp := RE_Initialize_Protection_Entry; - if Has_Entry then - P_Arr := Entry_Bodies_Array (Ptyp); + -- Argument Compiler_Info Append_To (Args, Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (P_Arr, Loc), - Attribute_Name => Name_Unrestricted_Access)); + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Address)); + + when System_Tasking_Protected_Objects => + Called_Subp := RE_Initialize_Protection; + + when others => + raise Program_Error; + end case; - if Pkg_Id = System_Tasking_Protected_Objects_Entries then + -- Entry_Bodies parameter. This is a pointer to an array of + -- pointers to the entry body procedures and barrier functions of + -- the object. If the protected type has no entries this object + -- will not exist, in this case, pass a null (it can happen when + -- there are protected interrupt handlers or interfaces). - -- Find index mapping function (clumsy but ok for now) + if Has_Entry then + P_Arr := Entry_Bodies_Array (Ptyp); - while Ekind (P_Arr) /= E_Function loop - Next_Entity (P_Arr); - end loop; + -- Argument Entry_Body (for single entry) or Entry_Bodies (for + -- multiple entries). - Append_To (Args, - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (P_Arr, Loc), - Attribute_Name => Name_Unrestricted_Access)); - end if; + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P_Arr, Loc), + Attribute_Name => Name_Unrestricted_Access)); - elsif Pkg_Id = - System_Tasking_Protected_Objects_Single_Entry - then - Append_To (Args, Make_Null (Loc)); + if Pkg_Id = System_Tasking_Protected_Objects_Entries then + + -- Find index mapping function (clumsy but ok for now) + + while Ekind (P_Arr) /= E_Function loop + Next_Entity (P_Arr); + end loop; - elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then - Append_To (Args, Make_Null (Loc)); - Append_To (Args, Make_Null (Loc)); + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P_Arr, Loc), + Attribute_Name => Name_Unrestricted_Access)); end if; - Append_To (L, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (Called_Subp), Loc), - Parameter_Associations => Args)); - end; - else + elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then + + -- This is the case where we have a protected object with + -- interfaces and no entries, and the single entry restriction + -- is in effect. We pass a null pointer for the entry + -- parameter because there is no actual entry. + + Append_To (Args, Make_Null (Loc)); + + elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then + + -- This is the case where we have a protected object with no + -- entries and: + -- - either interrupt handlers with non restricted profile, + -- - or interfaces + -- Note that the types which are used for interrupt handlers + -- (Static/Dynamic_Interrupt_Protection) are derived from + -- Protection_Entries. We pass two null pointers because there + -- is no actual entry, and the initialization procedure needs + -- both Entry_Bodies and Find_Body_Index. + + Append_To (Args, Make_Null (Loc)); + Append_To (Args, Make_Null (Loc)); + end if; + Append_To (L, Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc), + Name => New_Reference_To (RTE (Called_Subp), Loc), Parameter_Associations => Args)); - end if; + end; end if; if Has_Attach_Handler (Ptyp) then diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index cc5ff4fc8fb..7dd72069aca 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -411,7 +411,6 @@ package body Exp_Dbug is Ren := Prefix (Ren); when N_Explicit_Dereference => - Set_Materialize_Entity (Ent); Prepend_String_To_Buffer ("XA"); Ren := Prefix (Ren); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 7490e9df7bf..8ba4704328a 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1568,7 +1568,7 @@ package body Exp_Disp is else Actual_Dup := Relocate_Node (Actual); - if From_With_Type (Actual_Typ) then + if From_Limited_With (Actual_Typ) then -- If the type of the actual parameter comes from a limited -- with-clause and the non-limited view is already available @@ -1983,7 +1983,7 @@ package body Exp_Disp is begin if Ekind (Typ) = E_Incomplete_Type then - if From_With_Type (Typ) then + if From_Limited_With (Typ) then Typ := Non_Limited_View (Typ); else Typ := Full_View (Typ); @@ -7645,7 +7645,7 @@ package body Exp_Disp is end if; return List_Containing (Parent (Typ)) = - Visible_Declarations (Specification (Unit_Declaration_Node (Scop))); + Visible_Declarations (Package_Specification (Scop)); end Original_View_In_Visible_Part; ------------------ @@ -8446,8 +8446,7 @@ package body Exp_Disp is and then In_Private_Part (Current_Scope) and then List_Containing (Parent (Prim)) = - Private_Declarations - (Specification (Unit_Declaration_Node (Current_Scope))) + Private_Declarations (Package_Specification (Current_Scope)) and then Original_View_In_Visible_Part (Typ) then -- We exclude Input and Output stream operations because diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 364330339fe..068a950ba11 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -2874,8 +2874,7 @@ package body Exp_Dist is if RCI_Locator = Empty then RCI_Locator_Decl := - RCI_Package_Locator - (Loc, Specification (Unit_Declaration_Node (RCI_Package))); + RCI_Package_Locator (Loc, Package_Specification (RCI_Package)); Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl); Analyze (RCI_Locator_Decl); RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl); @@ -9839,7 +9838,8 @@ package body Exp_Dist is -- Constrained and unconstrained array types declare - Constrained : constant Boolean := Is_Constrained (Typ); + Constrained : constant Boolean := + not Transmit_As_Unconstrained (Typ); procedure TA_Ary_Add_Process_Element (Stmts : List_Id; @@ -9958,16 +9958,29 @@ package body Exp_Dist is -- Generate: -- T'Output (Strm'Access, E); + -- or + -- T'Write (Strm'Access, E); + -- depending on whether to transmit as unconstrained - Append_To (Stms, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Output, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Strm, Loc), - Attribute_Name => Name_Access), - New_Occurrence_Of (Expr_Parameter, Loc)))); + declare + Attr_Name : Name_Id; + begin + if Transmit_As_Unconstrained (Typ) then + Attr_Name := Name_Output; + else + Attr_Name := Name_Write; + end if; + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Attr_Name, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Strm, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Expr_Parameter, Loc)))); + end; -- Generate: -- BS_To_Any (Strm, A); diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 0d9ed4ee19d..0baab98d9cd 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -543,39 +543,78 @@ package body Exp_Pakd is -- array type on the fly). Such actions are inserted into the tree -- directly using Insert_Action. - function Byte_Swap (N : Node_Id) return Node_Id; + function Byte_Swap + (N : Node_Id; + Left_Justify : Boolean := False; + Right_Justify : Boolean := False) return Node_Id; -- Wrap N in a call to a byte swapping function, with appropriate type - -- conversions. + -- conversions. If Left_Justify is set True, the value is left justified + -- before swapping. If Right_Justify is set True, the value is right + -- justified after swapping. The Etype of the returned node is an + -- integer type of an appropriate power-of-2 size. --------------- -- Byte_Swap -- --------------- - function Byte_Swap (N : Node_Id) return Node_Id is + function Byte_Swap + (N : Node_Id; + Left_Justify : Boolean := False; + Right_Justify : Boolean := False) return Node_Id + is Loc : constant Source_Ptr := Sloc (N); T : constant Entity_Id := Etype (N); + T_Size : constant Uint := RM_Size (T); + Swap_RE : RE_Id; Swap_F : Entity_Id; + Swap_T : Entity_Id; + -- Swapping function + + Arg : Node_Id; + Swapped : Node_Id; + Shift : Uint; begin - pragma Assert (Esize (T) > 8); + pragma Assert (T_Size > 8); - if Esize (T) <= 16 then + if T_Size <= 16 then Swap_RE := RE_Bswap_16; - elsif Esize (T) <= 32 then + + elsif T_Size <= 32 then Swap_RE := RE_Bswap_32; - else pragma Assert (Esize (T) <= 64); + + else pragma Assert (T_Size <= 64); Swap_RE := RE_Bswap_64; end if; Swap_F := RTE (Swap_RE); + Swap_T := Etype (Swap_F); + Shift := Esize (Swap_T) - T_Size; + + Arg := RJ_Unchecked_Convert_To (Swap_T, N); + + if Left_Justify and then Shift > Uint_0 then + Arg := + Make_Op_Shift_Left (Loc, + Left_Opnd => Arg, + Right_Opnd => Make_Integer_Literal (Loc, Shift)); + end if; + + Swapped := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Swap_F, Loc), + Parameter_Associations => New_List (Arg)); + + if Right_Justify and then Shift > Uint_0 then + Swapped := + Make_Op_Shift_Right (Loc, + Left_Opnd => Swapped, + Right_Opnd => Make_Integer_Literal (Loc, Shift)); + end if; - return - Unchecked_Convert_To (T, - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Swap_F, Loc), - Parameter_Associations => - New_List (Unchecked_Convert_To (Etype (Swap_F), N)))); + Set_Etype (Swapped, Swap_T); + return Swapped; end Byte_Swap; ------------------------------ @@ -1326,8 +1365,8 @@ package body Exp_Pakd is -- The expression for the shift value that is required Shift_Used : Boolean := False; - -- Set True if Shift has been used in the generated code at least - -- once, so that it must be duplicated if used again + -- Set True if Shift has been used in the generated code at least once, + -- so that it must be duplicated if used again. New_Lhs : Node_Id; New_Rhs : Node_Id; @@ -1537,7 +1576,9 @@ package body Exp_Pakd is and then not In_Reverse_Storage_Order_Object (Obj) then Require_Byte_Swapping := True; - New_Rhs := Byte_Swap (New_Rhs); + New_Rhs := Byte_Swap (New_Rhs, + Left_Justify => Bytes_Big_Endian, + Right_Justify => not Bytes_Big_Endian); end if; end; @@ -1610,7 +1651,6 @@ package body Exp_Pakd is -- not a left justified conversion. Rhs := RJ_Unchecked_Convert_To (Etype (Obj), Rhs); - end Fixup_Rhs; begin @@ -1660,6 +1700,14 @@ package body Exp_Pakd is if Nkind (New_Rhs) = N_Op_And then Set_Paren_Count (New_Rhs, 1); + Set_Etype (New_Rhs, Etype (Left_Opnd (New_Rhs))); + end if; + + -- If New_Rhs has been byte swapped, need to convert Or_Rhs + -- to the return type of the byte swapping function now. + + if Require_Byte_Swapping then + Or_Rhs := Unchecked_Convert_To (Etype (New_Rhs), Or_Rhs); end if; New_Rhs := @@ -1671,7 +1719,11 @@ package body Exp_Pakd is if Require_Byte_Swapping then Set_Etype (New_Rhs, Etype (Obj)); - New_Rhs := Byte_Swap (New_Rhs); + New_Rhs := + Unchecked_Convert_To (Etype (Obj), + Byte_Swap (New_Rhs, + Left_Justify => not Bytes_Big_Endian, + Right_Justify => Bytes_Big_Endian)); end if; -- Now do the rewrite @@ -1991,7 +2043,25 @@ package body Exp_Pakd is Lit : Node_Id; Arg : Node_Id; + Byte_Swapped : Boolean; + -- Set true if bytes were swapped for the purpose of extracting the + -- element, in which case we must swap back if the component type is + -- a composite type with reverse scalar storage order. + begin + -- If the node is an actual in a call, the prefix has not been fully + -- expanded, to account for the additional expansion for in-out actuals + -- (see expand_actuals for details). If the prefix itself is a packed + -- reference as well, we have to recurse to complete the transformation + -- of the prefix. + + if Nkind (Prefix (N)) = N_Indexed_Component + and then not Analyzed (Prefix (N)) + and then Is_Bit_Packed_Array (Etype (Prefix (Prefix (N)))) + then + Expand_Packed_Element_Reference (Prefix (N)); + end if; + -- If not bit packed, we have the enumeration case, which is easily -- dealt with (just adjust the subscripts of the indexed component) @@ -2044,7 +2114,13 @@ package body Exp_Pakd is and then Esize (Atyp) > 8 and then not In_Reverse_Storage_Order_Object (Obj) then - Obj := Byte_Swap (Obj); + Obj := Byte_Swap (Obj, + Left_Justify => Bytes_Big_Endian, + Right_Justify => not Bytes_Big_Endian); + Byte_Swapped := True; + + else + Byte_Swapped := False; end if; -- We generate a shift right to position the field, followed by a @@ -2062,6 +2138,21 @@ package body Exp_Pakd is Left_Opnd => Make_Shift_Right (Obj, Shift), Right_Opnd => Lit); + -- Swap back if necessary + + Set_Etype (Arg, Ctyp); + + if Byte_Swapped + and then (Is_Record_Type (Ctyp) or else Is_Array_Type (Ctyp)) + and then Reverse_Storage_Order (Ctyp) + then + Arg := + Byte_Swap + (Arg, + Left_Justify => not Bytes_Big_Endian, + Right_Justify => False); + end if; + -- We needed to analyze this before we do the unchecked convert -- below, but we need it temporarily attached to the tree for -- this analysis (hence the temporary Set_Parent call). @@ -2584,6 +2675,18 @@ package body Exp_Pakd is Source_Siz := UI_To_Int (RM_Size (Source_Typ)); Target_Siz := UI_To_Int (RM_Size (Target_Typ)); + -- For a little-endian target type stored byte-swapped on a + -- big-endian machine, do not mask to Target_Siz bits. + + if Bytes_Big_Endian + and then (Is_Record_Type (Target_Typ) + or else + Is_Array_Type (Target_Typ)) + and then Reverse_Storage_Order (Target_Typ) + then + Source_Siz := Target_Siz; + end if; + -- First step, if the source type is not a discrete type, then we first -- convert to a modular type of the source length, since otherwise, on -- a big-endian machine, we get left-justification. We do it for little- diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index eeafa72d356..693aac9b35f 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -311,6 +311,10 @@ package body Exp_Prag is -- at" is omitted for name = Assertion, since it is redundant, given -- that the name of the exception is Assert_Failure.) + -- Also, instead of "XXX failed at", we generate slightly + -- different messages for some of the contract assertions (see + -- code below for details). + -- An alternative expansion is used when the No_Exception_Propagation -- restriction is active and there is a local Assert_Failure handler. -- This is not a common combination of circumstances, but it occurs in @@ -400,6 +404,15 @@ package body Exp_Prag is Insert_Str_In_Name_Buffer ("failed ", 1); Add_Str_To_Name_Buffer (" from "); + -- For special case of Invariant, the string is "failed + -- invariant from yy", to be consistent with the string that is + -- generated for the aspect case (the code later on checks for + -- this specific string to modify it in some cases, so this is + -- functionally important). + + elsif Nam = Name_Invariant then + Add_Str_To_Name_Buffer ("failed invariant from "); + -- For all other checks, the string is "xxx failed at yyy" -- where xxx is the check name with current source file casing. @@ -530,30 +543,34 @@ package body Exp_Prag is -- Expand_Pragma_Import_Or_Interface -- --------------------------------------- - -- When applied to a variable, the default initialization must not be done. - -- As it is already done when the pragma is found, we just get rid of the - -- call the initialization procedure which followed the object declaration. - -- The call is inserted after the declaration, but validity checks may - -- also have been inserted and the initialization call does not necessarily - -- appear immediately after the object declaration. - - -- We can't use the freezing mechanism for this purpose, since we have to - -- elaborate the initialization expression when it is first seen (i.e. this - -- elaboration cannot be deferred to the freeze point). - procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is Def_Id : Entity_Id; Init_Call : Node_Id; begin Def_Id := Entity (Arg2 (N)); + + -- Variable case + if Ekind (Def_Id) = E_Variable then + -- When applied to a variable, the default initialization must not be + -- done. As it is already done when the pragma is found, we just get + -- rid of the call the initialization procedure which followed the + -- object declaration. The call is inserted after the declaration, + -- but validity checks may also have been inserted and thus the + -- initialization call does not necessarily appear immediately + -- after the object declaration. + + -- We can't use the freezing mechanism for this purpose, since we + -- have to elaborate the initialization expression when it is first + -- seen (so this elaboration cannot be deferred to the freeze point). + -- Find and remove generated initialization call for object, if any Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N); - -- Any default initialization expression should be removed (e.g., + -- Any default initialization expression should be removed (e.g. -- null defaults for access objects, zero initialization of packed -- bit arrays). Imported objects aren't allowed to have explicit -- initialization, so the expression must have been generated by @@ -562,6 +579,71 @@ package body Exp_Prag is if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then Set_Expression (Parent (Def_Id), Empty); end if; + + -- Case of exception with convention C++ + + elsif Ekind (Def_Id) = E_Exception + and then Convention (Def_Id) = Convention_CPP + then + -- Import a C++ convention + + declare + Loc : constant Source_Ptr := Sloc (N); + Rtti_Name : constant Node_Id := Arg3 (N); + Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); + Exdata : List_Id; + Lang_Char : Node_Id; + Foreign_Data : Node_Id; + + begin + Exdata := Component_Associations (Expression (Parent (Def_Id))); + + Lang_Char := Next (First (Exdata)); + + -- Change the one-character language designator to 'C' + + Rewrite (Expression (Lang_Char), + Make_Character_Literal (Loc, + Chars => Name_uC, + Char_Literal_Value => UI_From_Int (Character'Pos ('C')))); + Analyze (Expression (Lang_Char)); + + -- Change the value of Foreign_Data + + Foreign_Data := Next (Next (Next (Next (Lang_Char)))); + + Insert_Actions (Def_Id, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Dum, + Object_Definition => + New_Occurrence_Of (Standard_Character, Loc)), + + Make_Pragma (Loc, + Chars => Name_Import, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Ada)), + + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Chars (Dum))), + + Make_Pragma_Argument_Association (Loc, + Chars => Name_External_Name, + Expression => Relocate_Node (Rtti_Name)))))); + + Rewrite (Expression (Foreign_Data), + Unchecked_Convert_To (Standard_A_Char, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Chars (Dum)), + Attribute_Name => Name_Address))); + Analyze (Expression (Foreign_Data)); + end; + + -- No special expansion required for any other case + + else + null; + end if; end Expand_Pragma_Import_Or_Interface; @@ -603,6 +685,8 @@ package body Exp_Prag is Code : Node_Id; begin + -- Compute the symbol for the code of the condition + if Present (Interface_Name (Id)) then Excep_Image := Strval (Interface_Name (Id)); else @@ -626,23 +710,35 @@ package body Exp_Prag is Analyze (Expression (Lang_Char)); if Exception_Code (Id) /= No_Uint then + + -- The code for the exception is present. Create a linker + -- alias to define the symbol. + Code := - Make_Integer_Literal (Loc, - Intval => Exception_Code (Id)); + Unchecked_Convert_To (RTE (RE_Address), + Make_Integer_Literal (Loc, + Intval => Exception_Code (Id))); + + -- Declare a dummy object Excep_Object := Make_Object_Declaration (Loc, Defining_Identifier => Excep_Internal, Object_Definition => - New_Reference_To (RTE (RE_Exception_Code), Loc)); + New_Reference_To (RTE (RE_Address), Loc)); Insert_Action (N, Excep_Object); Analyze (Excep_Object); + -- Clear severity bits + Start_String; Store_String_Int (UI_To_Int (Exception_Code (Id)) / 8 * 8); + -- Insert a pragma Linker_Alias to set the value of the + -- dummy object symbol. + Excep_Alias := Make_Pragma (Loc, Chars => Name_Linker_Alias, @@ -658,6 +754,9 @@ package body Exp_Prag is Insert_Action (N, Excep_Alias); Analyze (Excep_Alias); + -- Insert a pragma Export to give a Linker_Name to the + -- dummy object. + Export_Pragma := Make_Pragma (Loc, Chars => Name_Export, @@ -682,15 +781,16 @@ package body Exp_Prag is else Code := - Unchecked_Convert_To (RTE (RE_Exception_Code), - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Import_Value), Loc), - Parameter_Associations => New_List - (Make_String_Literal (Loc, - Strval => Excep_Image)))); + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Import_Address), Loc), + Parameter_Associations => New_List + (Make_String_Literal (Loc, + Strval => Excep_Image))); end if; + -- Generate the call to Register_VMS_Exception + Rewrite (Call, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To @@ -702,7 +802,7 @@ package body Exp_Prag is Prefix => New_Occurrence_Of (Id, Loc), Attribute_Name => Name_Unrestricted_Access))))); - Analyze_And_Resolve (Code, RTE (RE_Exception_Code)); + Analyze_And_Resolve (Code, RTE (RE_Address)); Analyze (Call); end if; diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index 0050799a104..a4415e837e7 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -25,19 +25,13 @@ with Atree; use Atree; with Einfo; use Einfo; -with Exp_Attr; use Exp_Attr; -with Exp_Ch4; use Exp_Ch4; -with Exp_Ch6; use Exp_Ch6; with Exp_Dbug; use Exp_Dbug; with Exp_Util; use Exp_Util; -with Rtsfind; use Rtsfind; with Sem_Aux; use Sem_Aux; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; -with Snames; use Snames; with Stand; use Stand; -with Tbuild; use Tbuild; package body Exp_SPARK is @@ -47,22 +41,11 @@ package body Exp_SPARK is procedure Expand_SPARK_Call (N : Node_Id); -- This procedure contains common processing for function and procedure - -- calls: - -- * expansion of actuals to introduce necessary temporaries - -- * replacement of renaming by subprogram renamed - - procedure Expand_SPARK_N_Attribute_Reference (N : Node_Id); - -- Expand attributes 'Old and 'Result only + -- calls: replacement of renaming by subprogram renamed procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id); -- Perform name evaluation for a renamed object - procedure Expand_SPARK_N_Simple_Return_Statement (N : Node_Id); - -- Insert conversion on function return if necessary - - procedure Expand_SPARK_Simple_Function_Return (N : Node_Id); - -- Expand simple return from function - procedure Expand_Potential_Renaming (N : Node_Id); -- N denotes a N_Identifier or N_Expanded_Name. If N references a renaming, -- replace N with the renamed object. @@ -74,8 +57,6 @@ package body Exp_SPARK is procedure Expand_SPARK (N : Node_Id) is begin case Nkind (N) is - when N_Attribute_Reference => - Expand_SPARK_N_Attribute_Reference (N); -- Qualification of entity names in formal verification mode -- is limited to the addition of a suffix for homonyms (see @@ -98,18 +79,9 @@ package body Exp_SPARK is N_Identifier => Expand_Potential_Renaming (N); - -- A NOT IN B gets transformed to NOT (A IN B). This is the same - -- expansion used in the normal case, so shared the code. - - when N_Not_In => - Expand_N_Not_In (N); - when N_Object_Renaming_Declaration => Expand_SPARK_N_Object_Renaming_Declaration (N); - when N_Simple_Return_Statement => - Expand_SPARK_N_Simple_Return_Statement (N); - -- In SPARK mode, no other constructs require expansion when others => @@ -124,7 +96,6 @@ package body Exp_SPARK is procedure Expand_SPARK_Call (N : Node_Id) is Call_Node : constant Node_Id := N; Parent_Subp : Entity_Id; - Subp : Entity_Id; begin -- Ignore if previous error @@ -138,14 +109,12 @@ package body Exp_SPARK is -- Call using access to subprogram with explicit dereference if Nkind (Name (Call_Node)) = N_Explicit_Dereference then - Subp := Etype (Name (Call_Node)); Parent_Subp := Empty; -- Case of call to simple entry, where the Name is a selected component -- whose prefix is the task, and whose selector name is the entry name elsif Nkind (Name (Call_Node)) = N_Selected_Component then - Subp := Entity (Selector_Name (Name (Call_Node))); Parent_Subp := Empty; -- Case of call to member of entry family, where Name is an indexed @@ -153,20 +122,14 @@ package body Exp_SPARK is -- task and entry family name, and the index being the entry index. elsif Nkind (Name (Call_Node)) = N_Indexed_Component then - Subp := Entity (Selector_Name (Prefix (Name (Call_Node)))); Parent_Subp := Empty; -- Normal case else - Subp := Entity (Name (Call_Node)); - Parent_Subp := Alias (Subp); + Parent_Subp := Alias (Entity (Name (Call_Node))); end if; - -- Various expansion activities for actuals are carried out - - Expand_Actuals (N, Subp); - -- If the subprogram is a renaming, replace it in the call with the name -- of the actual subprogram being called. @@ -179,24 +142,6 @@ package body Exp_SPARK is end if; end Expand_SPARK_Call; - ---------------------------------------- - -- Expand_SPARK_N_Attribute_Reference -- - ---------------------------------------- - - procedure Expand_SPARK_N_Attribute_Reference (N : Node_Id) is - Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); - - begin - case Id is - when Attribute_Old | - Attribute_Result => - Expand_N_Attribute_Reference (N); - - when others => - null; - end case; - end Expand_SPARK_N_Attribute_Reference; - ------------------------------------------------ -- Expand_SPARK_N_Object_Renaming_Declaration -- ------------------------------------------------ @@ -208,80 +153,6 @@ package body Exp_SPARK is Evaluate_Name (Name (N)); end Expand_SPARK_N_Object_Renaming_Declaration; - -------------------------------------------- - -- Expand_SPARK_N_Simple_Return_Statement -- - -------------------------------------------- - - procedure Expand_SPARK_N_Simple_Return_Statement (N : Node_Id) is - begin - -- Defend against previous errors (i.e. the return statement calls a - -- function that is not available in configurable runtime). - - if Present (Expression (N)) - and then Nkind (Expression (N)) = N_Empty - then - return; - end if; - - -- Distinguish the function and non-function cases: - - case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is - - when E_Function | - E_Generic_Function => - Expand_SPARK_Simple_Function_Return (N); - - when E_Procedure | - E_Generic_Procedure | - E_Entry | - E_Entry_Family | - E_Return_Statement => - null; - - when others => - raise Program_Error; - end case; - - exception - when RE_Not_Available => - return; - end Expand_SPARK_N_Simple_Return_Statement; - - ----------------------------------------- - -- Expand_SPARK_Simple_Function_Return -- - ----------------------------------------- - - procedure Expand_SPARK_Simple_Function_Return (N : Node_Id) is - Scope_Id : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - -- The function we are returning from - - R_Type : constant Entity_Id := Etype (Scope_Id); - -- The result type of the function - - Exp : constant Node_Id := Expression (N); - pragma Assert (Present (Exp)); - - Exptyp : constant Entity_Id := Etype (Exp); - -- The type of the expression (not necessarily the same as R_Type) - - begin - -- Check the result expression of a scalar function against the subtype - -- of the function by inserting a conversion. This conversion must - -- eventually be performed for other classes of types, but for now it's - -- only done for scalars. - -- ??? - - if Is_Scalar_Type (Exptyp) then - Rewrite (Exp, Convert_To (R_Type, Exp)); - - -- The expression is resolved to ensure that the conversion gets - -- expanded to generate a possible constraint check. - - Analyze_And_Resolve (Exp, R_Type); - end if; - end Expand_SPARK_Simple_Function_Return; - ------------------------------- -- Expand_Potential_Renaming -- ------------------------------- diff --git a/gcc/ada/exp_spark.ads b/gcc/ada/exp_spark.ads index 726b69ac014..c422bc73e52 100644 --- a/gcc/ada/exp_spark.ads +++ b/gcc/ada/exp_spark.ads @@ -30,54 +30,6 @@ -- Expand_SPARK is called directly by Expander.Expand. --- SPARK expansion has three main objectives: - --- 1. Perform limited expansion to explicit some Ada rules and constructs --- (translate 'Old and 'Result, replace renamings by renamed, insert --- conversions, expand actuals in calls to introduce temporaries, expand --- generics instantiations) - --- 2. Facilitate treatment for the formal verification back-end (fully --- qualify names, expand set membership, compute data dependences) - --- 3. Avoid the introduction of low-level code that is difficult to analyze --- formally, as typically done in the full expansion for high-level --- constructs (tasking, dispatching) - --- To fulfill objective 1, Expand_SPARK selectively expands some constructs. - --- To fulfill objective 2, the tree after SPARK expansion should be fully --- analyzed semantically. In particular, all expression must have their proper --- type, and semantic links should be set between tree nodes (partial to full --- view, etc.) Some kinds of nodes should be either absent, or can be ignored --- by the formal verification backend: - --- N_Object_Renaming_Declaration: can be ignored safely --- N_Expression_Function: absent (rewitten) --- N_Expression_With_Actions: absent (not generated) - --- SPARK cross-references are generated from the regular cross-references --- (used for browsing and code understanding) and additional references --- collected during semantic analysis, in particular on all --- dereferences. These SPARK cross-references are output in a separate section --- of ALI files, as described in spark_xrefs.adb. They are the basis for the --- computation of data dependences in the formal verification backend. This --- implies that all cross-references should be generated in this mode, even --- those that would not make sense from a user point-of-view, and that --- cross-references that do not lead to data dependences for subprograms can --- be safely ignored. - --- To support the formal verification of units parameterized by data, the --- value of deferred constants should not be considered as a compile-time --- constant at program locations where the full view is not visible. - --- To fulfill objective 3, Expand_SPARK does not expand features that are not --- formally analyzed (tasking), or for which formal analysis relies on the --- source level representation (dispatching, aspects, pragmas). However, these --- should be semantically analyzed, which sometimes requires the insertion of --- semantic pre-analysis, for example for subprogram contracts and pragma --- check/assert. - with Types; use Types; package Exp_SPARK is diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index 8b19f9190db..2b6dc92d315 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -211,7 +211,7 @@ package body Exp_Tss is begin return Present (BIP) and then (Restriction_Active (No_Default_Initialization) - or else not Is_Null_Init_Proc (BIP)); + or else not Is_Null_Init_Proc (BIP)); end Has_Non_Null_Base_Init_Proc; --------------- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index ca8bc9839ab..a14b1bc1e19 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -560,13 +560,6 @@ package body Exp_Util is -- Start of processing for Build_Allocate_Deallocate_Proc begin - -- Do not perform this expansion in SPARK mode because it is not - -- necessary. - - if SPARK_Mode then - return; - end if; - -- Obtain the attributes of the allocation / deallocation if Nkind (N) = N_Free_Statement then @@ -1631,10 +1624,15 @@ package body Exp_Util is -- node to recognize this case. or else Present (Interface_List (Parent (Typ))) - or else - (((Has_Attach_Handler (Typ) and then not Restricted_Profile) - or else Has_Interrupt_Handler (Typ)) - and then not Restriction_Active (No_Dynamic_Attachment)) + + -- Protected types with interrupt handlers (when not using a + -- restricted profile) are also considered equivalent to + -- protected types with entries. The types which are used + -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection) + -- are derived from Protection_Entries. + + or else (Has_Attach_Handler (Typ) and then not Restricted_Profile) + or else Has_Interrupt_Handler (Typ) then if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False @@ -1773,35 +1771,6 @@ package body Exp_Util is end if; end Ensure_Defined; - --------------- - -- Entity_Of -- - --------------- - - function Entity_Of (N : Node_Id) return Entity_Id is - Id : Entity_Id; - - begin - Id := Empty; - - if Is_Entity_Name (N) then - Id := Entity (N); - - -- Follow a possible chain of renamings to reach the root renamed - -- object. - - while Present (Renamed_Object (Id)) loop - if Is_Entity_Name (Renamed_Object (Id)) then - Id := Entity (Renamed_Object (Id)); - else - Id := Empty; - exit; - end if; - end loop; - end if; - - return Id; - end Entity_Of; - -------------------- -- Entry_Names_OK -- -------------------- @@ -1941,6 +1910,69 @@ package body Exp_Util is end if; end Evolve_Or_Else; + ----------------------------------------- + -- Expand_Static_Predicates_In_Choices -- + ----------------------------------------- + + procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is + pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant)); + + Choices : constant List_Id := Discrete_Choices (N); + + Choice : Node_Id; + Next_C : Node_Id; + P : Node_Id; + C : Node_Id; + + begin + Choice := First (Choices); + while Present (Choice) loop + Next_C := Next (Choice); + + -- Check for name of subtype with static predicate + + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + and then Has_Predicates (Entity (Choice)) + then + -- Loop through entries in predicate list, converting to choices + -- and inserting in the list before the current choice. Note that + -- if the list is empty, corresponding to a False predicate, then + -- no choices are inserted. + + P := First (Static_Predicate (Entity (Choice))); + while Present (P) loop + + -- If low bound and high bounds are equal, copy simple choice + + if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then + C := New_Copy (Low_Bound (P)); + + -- Otherwise copy a range + + else + C := New_Copy (P); + end if; + + -- Change Sloc to referencing choice (rather than the Sloc of + -- the predicate declaration element itself). + + Set_Sloc (C, Sloc (Choice)); + Insert_Before (Choice, C); + Next (P); + end loop; + + -- Delete the predicated entry + + Remove (Choice); + end if; + + -- Move to next choice to check + + Choice := Next_C; + end loop; + end Expand_Static_Predicates_In_Choices; + ------------------------------ -- Expand_Subtype_From_Expr -- ------------------------------ @@ -2166,7 +2198,7 @@ package body Exp_Util is -- function being called is build-in-place. This will have to be revised -- when build-in-place functions are generalized to other types. - elsif Is_Immutably_Limited_Type (Exp_Typ) + elsif Is_Limited_View (Exp_Typ) and then (Is_Class_Wide_Type (Exp_Typ) or else Is_Interface (Exp_Typ) @@ -2645,18 +2677,36 @@ package body Exp_Util is (N : Node_Id; S : Boolean) is - Cond : Node_Id; - Sens : Boolean; + Cond : Node_Id; + Prev_Cond : Node_Id; + Sens : Boolean; begin Cond := N; Sens := S; - -- Deal with NOT operators, inverting sense + loop + Prev_Cond := Cond; - while Nkind (Cond) = N_Op_Not loop - Cond := Right_Opnd (Cond); - Sens := not Sens; + -- Deal with NOT operators, inverting sense + + while Nkind (Cond) = N_Op_Not loop + Cond := Right_Opnd (Cond); + Sens := not Sens; + end loop; + + -- Deal with conversions, qualifications, and expressions with + -- actions. + + while Nkind_In (Cond, + N_Type_Conversion, + N_Qualified_Expression, + N_Expression_With_Actions) + loop + Cond := Expression (Cond); + end loop; + + exit when Cond = Prev_Cond; end loop; -- Deal with AND THEN and AND cases @@ -2737,8 +2787,15 @@ package body Exp_Util is return; - -- Case of Boolean variable reference, return as though the - -- reference had said var = True. + elsif Nkind_In (Cond, + N_Type_Conversion, + N_Qualified_Expression, + N_Expression_With_Actions) + then + Cond := Expression (Cond); + + -- Case of Boolean variable reference, return as though the + -- reference had said var = True. else if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then @@ -3345,8 +3402,13 @@ package body Exp_Util is when N_Expression_With_Actions => if N = Expression (P) then - Insert_List_After_And_Analyze - (Last (Actions (P)), Ins_Actions); + if Is_Empty_List (Actions (P)) then + Append_List_To (Actions (P), Ins_Actions); + Analyze_List (Actions (P)); + else + Insert_List_After_And_Analyze + (Last (Actions (P)), Ins_Actions); + end if; return; end if; @@ -3448,7 +3510,8 @@ package body Exp_Util is -- Freeze entity behaves like a declaration or statement - N_Freeze_Entity + N_Freeze_Entity | + N_Freeze_Generic_Entity => -- Do not insert here if the item is not a list member (this -- happens for example with a triggering statement, and the @@ -6640,6 +6703,14 @@ package body Exp_Util is when N_Explicit_Dereference => return Safe_Prefixed_Reference (N); + -- An expression with action is side effect free if its expression + -- is side effect free and it has no actions. + + when N_Expression_With_Actions => + return Is_Empty_List (Actions (N)) + and then + Side_Effect_Free (Expression (N)); + -- A call to _rep_to_pos is side effect free, since we generate -- this pure function call ourselves. Moreover it is critically -- important to make this exception, since otherwise we can have @@ -7019,7 +7090,7 @@ package body Exp_Util is if Ada_Version >= Ada_2005 and then Nkind (Exp) = N_Function_Call - and then Is_Immutably_Limited_Type (Etype (Exp)) + and then Is_Limited_View (Etype (Exp)) and then Nkind (Parent (Exp)) /= N_Object_Declaration then declare @@ -7041,7 +7112,6 @@ package body Exp_Util is end if; Def_Id := Make_Temporary (Loc, 'R', Exp); - Set_Etype (Def_Id, Exp_Type); -- The regular expansion of functions with side effects involves the -- generation of an access type to capture the return value found on @@ -7718,7 +7788,14 @@ package body Exp_Util is Set_Entity_Current_Value (Right_Opnd (Cond)); end if; - -- Check possible boolean variable reference + elsif Nkind_In (Cond, + N_Type_Conversion, + N_Qualified_Expression, + N_Expression_With_Actions) + then + Set_Expression_Current_Value (Expression (Cond)); + + -- Check possible boolean variable reference else Set_Entity_Current_Value (Cond); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 568b9f7d5c1..bf72220f826 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -349,19 +349,15 @@ package Exp_Util is -- used to ensure that an Itype is properly defined outside a conditional -- construct when it is referenced in more than one branch. - function Entity_Of (N : Node_Id) return Entity_Id; - -- Return the entity of N or Empty. If N is a renaming, return the entity - -- of the root renamed object. - function Entry_Names_OK return Boolean; -- Determine whether it is appropriate to dynamically allocate strings -- which represent entry [family member] names. These strings are created -- by the compiler and used by GDB. procedure Evaluate_Name (Nam : Node_Id); - -- Remove the all side effects from a name which appears as part of an - -- object renaming declaration. More comments are needed here that explain - -- how this differs from Force_Evaluation and Remove_Side_Effects ??? + -- Remove all side effects from a name which appears as part of an object + -- renaming declaration. More comments are needed here that explain how + -- this differs from Force_Evaluation and Remove_Side_Effects ??? procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id); -- Rewrites Cond with the expression: Cond and then Cond1. If Cond is @@ -377,6 +373,12 @@ package Exp_Util is -- indicating that no checks were required). The Sloc field of the -- constructed N_Or_Else node is copied from Cond1. + procedure Expand_Static_Predicates_In_Choices (N : Node_Id); + -- N is either a case alternative or a variant. The Discrete_Choices field + -- of N points to a list of choices. If any of these choices is the name + -- of a (statically) predicated subtype, then it is rewritten as the series + -- of choices that correspond to the values allowed for the subtype. + procedure Expand_Subtype_From_Expr (N : Node_Id; Unc_Type : Entity_Id; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 58098be741d..f6c60678143 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -92,11 +92,15 @@ package body Freeze is procedure Check_Component_Storage_Order (Encl_Type : Entity_Id; - Comp : Entity_Id); + Comp : Entity_Id; + ADC : Node_Id); -- For an Encl_Type that has a Scalar_Storage_Order attribute definition - -- clause, verify that the component type is compatible. For arrays, - -- Comp is Empty; for records, it is the entity of the component under - -- consideration. + -- clause, verify that the component type has an explicit and compatible + -- attribute/aspect. For arrays, Comp is Empty; for records, it is the + -- entity of the component under consideration. For an Encl_Type that + -- does not have a Scalar_Storage_Order attribute definition clause, + -- verify that the component also does not have such a clause. + -- ADC is the attribute definition clause if present (or Empty). procedure Check_Strict_Alignment (E : Entity_Id); -- E is a base type. If E is tagged or has a component that is aliased @@ -835,7 +839,7 @@ package body Freeze is and then not Has_Independent_Components (T); Packed_Size : Uint := Uint_0; - -- SIze in bis so far + -- Size in bits so far begin -- Test for variant part present @@ -846,8 +850,9 @@ package body Freeze is and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition and then not Null_Present (Type_Definition (Parent (T))) - and then Present (Variant_Part - (Component_List (Type_Definition (Parent (T))))) + and then + Present (Variant_Part + (Component_List (Type_Definition (Parent (T))))) then -- If variant part is present, and type is unconstrained, -- then we must have defaulted discriminants, or a size @@ -880,11 +885,13 @@ package body Freeze is end if; -- We do not know the packed size if we have a by reference - -- type, or an atomic type or an atomic component. + -- type, or an atomic type or an atomic component, or an + -- aliased component (because packing does not touch these). if Is_Atomic (Ctyp) or else Is_Atomic (Comp) or else Is_By_Reference_Type (Ctyp) + or else Is_Aliased (Comp) then Packed_Size_Known := False; end if; @@ -1065,17 +1072,19 @@ package body Freeze is procedure Check_Component_Storage_Order (Encl_Type : Entity_Id; - Comp : Entity_Id) + Comp : Entity_Id; + ADC : Node_Id) is Comp_Type : Entity_Id; - Comp_Def : Node_Id; + Comp_ADC : Node_Id; Err_Node : Node_Id; - ADC : Node_Id; Comp_Byte_Aligned : Boolean; -- Set True for the record case, when Comp starts on a byte boundary -- (in which case it is allowed to have different storage order). + Component_Aliased : Boolean; + begin -- Record case @@ -1084,15 +1093,15 @@ package body Freeze is Comp_Type := Etype (Comp); if Is_Tag (Comp) then - Comp_Def := Empty; Comp_Byte_Aligned := True; + Component_Aliased := False; else - Comp_Def := Component_Definition (Parent (Comp)); Comp_Byte_Aligned := Present (Component_Clause (Comp)) and then Normalized_First_Bit (Comp) mod System_Storage_Unit = 0; + Component_Aliased := Is_Aliased (Comp); end if; -- Array case @@ -1100,21 +1109,33 @@ package body Freeze is else Err_Node := Encl_Type; Comp_Type := Component_Type (Encl_Type); - Comp_Def := Component_Definition - (Type_Definition (Declaration_Node (Encl_Type))); Comp_Byte_Aligned := False; + Component_Aliased := Has_Aliased_Components (Encl_Type); end if; -- Note: the Reverse_Storage_Order flag is set on the base type, but -- the attribute definition clause is attached to the first subtype. Comp_Type := Base_Type (Comp_Type); - ADC := Get_Attribute_Definition_Clause - (First_Subtype (Comp_Type), - Attribute_Scalar_Storage_Order); + Comp_ADC := Get_Attribute_Definition_Clause + (First_Subtype (Comp_Type), + Attribute_Scalar_Storage_Order); + + -- Case of enclosing type not having explicit SSO: component cannot + -- have it either. + + if No (ADC) then + if Present (Comp_ADC) then + Error_Msg_N + ("composite type must have explicit scalar storage order", + Err_Node); + end if; - if Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then + -- Case of enclosing type having explicit SSO: check compatible + -- attribute on Comp_Type if composite. + + elsif Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then if Present (Comp) and then Chars (Comp) = Name_uParent then if Reverse_Storage_Order (Encl_Type) /= @@ -1139,7 +1160,10 @@ package body Freeze is & "storage order as enclosing composite", Err_Node); end if; - elsif Present (Comp_Def) and then Aliased_Present (Comp_Def) then + -- Enclosing type has explicit SSO, non-composite component must not + -- be aliased. + + elsif Component_Aliased then Error_Msg_N ("aliased component not permitted for type with " & "explicit Scalar_Storage_Order", Err_Node); @@ -1697,8 +1721,15 @@ package body Freeze is -- integer literal without an explicit corresponding size clause. The -- caller has checked that Utype is a modular integer type. + procedure Freeze_Array_Type (Arr : Entity_Id); + -- Freeze array type, including freezing index and component types + + function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id; + -- Create Freeze_Generic_Entity nodes for types declared in a generic + -- package. Recurse on inner generic packages. + procedure Freeze_Record_Type (Rec : Entity_Id); - -- Freeze each component, handle some representation clauses, and freeze + -- Freeze record type, including freezing component types, and freezing -- primitive operations if this is a tagged type. ------------------- @@ -1841,8 +1872,16 @@ package body Freeze is and then Is_Type (Entity (Prefix (N))) and then Entity (Prefix (N)) = E then - Error_Msg_N - ("current instance must be a limited type", Prefix (N)); + if Ada_Version < Ada_2012 then + Error_Msg_N + ("current instance must be a limited type", + Prefix (N)); + else + Error_Msg_N + ("current instance must be an immutably limited " & + "type (RM-2012, 7.5 (8.1/3))", + Prefix (N)); + end if; return Abandon; else return OK; @@ -1943,6 +1982,558 @@ package body Freeze is end if; end Check_Suspicious_Modulus; + ----------------------- + -- Freeze_Array_Type -- + ----------------------- + + procedure Freeze_Array_Type (Arr : Entity_Id) is + FS : constant Entity_Id := First_Subtype (Arr); + Ctyp : constant Entity_Id := Component_Type (Arr); + Clause : Entity_Id; + + Non_Standard_Enum : Boolean := False; + -- Set true if any of the index types is an enumeration type with a + -- non-standard representation. + + begin + Freeze_And_Append (Ctyp, N, Result); + + Indx := First_Index (Arr); + while Present (Indx) loop + Freeze_And_Append (Etype (Indx), N, Result); + + if Is_Enumeration_Type (Etype (Indx)) + and then Has_Non_Standard_Rep (Etype (Indx)) + then + Non_Standard_Enum := True; + end if; + + Next_Index (Indx); + end loop; + + -- Processing that is done only for base types + + if Ekind (Arr) = E_Array_Type then + + -- Propagate flags for component type + + if Is_Controlled (Component_Type (Arr)) + or else Has_Controlled_Component (Ctyp) + then + Set_Has_Controlled_Component (Arr); + end if; + + if Has_Unchecked_Union (Component_Type (Arr)) then + Set_Has_Unchecked_Union (Arr); + end if; + + -- Warn for pragma Pack overriding foreign convention + + if Has_Foreign_Convention (Ctyp) + and then Has_Pragma_Pack (Arr) + then + declare + CN : constant Name_Id := + Get_Convention_Name (Convention (Ctyp)); + PP : constant Node_Id := + Get_Pragma (First_Subtype (Arr), Pragma_Pack); + begin + if Present (PP) then + Error_Msg_Name_1 := CN; + Error_Msg_Sloc := Sloc (Arr); + Error_Msg_N + ("pragma Pack affects convention % components #??", + PP); + Error_Msg_Name_1 := CN; + Error_Msg_N + ("\array components may not have % compatible " + & "representation??", PP); + end if; + end; + end if; + + -- If packing was requested or if the component size was + -- set explicitly, then see if bit packing is required. This + -- processing is only done for base types, since all of the + -- representation aspects involved are type-related. This is not + -- just an optimization, if we start processing the subtypes, they + -- interfere with the settings on the base type (this is because + -- Is_Packed has a slightly different meaning before and after + -- freezing). + + declare + Csiz : Uint; + Esiz : Uint; + + begin + if (Is_Packed (Arr) or else Has_Pragma_Pack (Arr)) + and then Known_Static_RM_Size (Ctyp) + and then not Has_Component_Size_Clause (Arr) + then + Csiz := UI_Max (RM_Size (Ctyp), 1); + + elsif Known_Component_Size (Arr) then + Csiz := Component_Size (Arr); + + elsif not Known_Static_Esize (Ctyp) then + Csiz := Uint_0; + + else + Esiz := Esize (Ctyp); + + -- We can set the component size if it is less than 16, + -- rounding it up to the next storage unit size. + + if Esiz <= 8 then + Csiz := Uint_8; + elsif Esiz <= 16 then + Csiz := Uint_16; + else + Csiz := Uint_0; + end if; + + -- Set component size up to match alignment if it would + -- otherwise be less than the alignment. This deals with + -- cases of types whose alignment exceeds their size (the + -- padded type cases). + + if Csiz /= 0 then + declare + A : constant Uint := Alignment_In_Bits (Ctyp); + begin + if Csiz < A then + Csiz := A; + end if; + end; + end if; + end if; + + -- Case of component size that may result in packing + + if 1 <= Csiz and then Csiz <= 64 then + declare + Ent : constant Entity_Id := + First_Subtype (Arr); + Pack_Pragma : constant Node_Id := + Get_Rep_Pragma (Ent, Name_Pack); + Comp_Size_C : constant Node_Id := + Get_Attribute_Definition_Clause + (Ent, Attribute_Component_Size); + begin + -- Warn if we have pack and component size so that the + -- pack is ignored. + + -- Note: here we must check for the presence of a + -- component size before checking for a Pack pragma to + -- deal with the case where the array type is a derived + -- type whose parent is currently private. + + if Present (Comp_Size_C) + and then Has_Pragma_Pack (Ent) + and then Warn_On_Redundant_Constructs + then + Error_Msg_Sloc := Sloc (Comp_Size_C); + Error_Msg_NE + ("?r?pragma Pack for& ignored!", + Pack_Pragma, Ent); + Error_Msg_N + ("\?r?explicit component size given#!", + Pack_Pragma); + Set_Is_Packed (Base_Type (Ent), False); + Set_Is_Bit_Packed_Array (Base_Type (Ent), False); + end if; + + -- Set component size if not already set by a component + -- size clause. + + if not Present (Comp_Size_C) then + Set_Component_Size (Arr, Csiz); + end if; + + -- Check for base type of 8, 16, 32 bits, where an + -- unsigned subtype has a length one less than the + -- base type (e.g. Natural subtype of Integer). + + -- In such cases, if a component size was not set + -- explicitly, then generate a warning. + + if Has_Pragma_Pack (Arr) + and then not Present (Comp_Size_C) + and then + (Csiz = 7 or else Csiz = 15 or else Csiz = 31) + and then Esize (Base_Type (Ctyp)) = Csiz + 1 + then + Error_Msg_Uint_1 := Csiz; + + if Present (Pack_Pragma) then + Error_Msg_N + ("??pragma Pack causes component size " + & "to be ^!", Pack_Pragma); + Error_Msg_N + ("\??use Component_Size to set " + & "desired value!", Pack_Pragma); + end if; + end if; + + -- Actual packing is not needed for 8, 16, 32, 64. Also + -- not needed for 24 if alignment is 1. + + if Csiz = 8 + or else Csiz = 16 + or else Csiz = 32 + or else Csiz = 64 + or else (Csiz = 24 and then Alignment (Ctyp) = 1) + then + -- Here the array was requested to be packed, but + -- the packing request had no effect, so Is_Packed + -- is reset. + + -- Note: semantically this means that we lose track + -- of the fact that a derived type inherited a pragma + -- Pack that was non- effective, but that seems fine. + + -- We regard a Pack pragma as a request to set a + -- representation characteristic, and this request + -- may be ignored. + + Set_Is_Packed (Base_Type (Arr), False); + Set_Is_Bit_Packed_Array (Base_Type (Arr), False); + + if Known_Static_Esize (Component_Type (Arr)) + and then Esize (Component_Type (Arr)) = Csiz + then + Set_Has_Non_Standard_Rep + (Base_Type (Arr), False); + end if; + + -- In all other cases, packing is indeed needed + + else + Set_Has_Non_Standard_Rep (Base_Type (Arr), True); + Set_Is_Bit_Packed_Array (Base_Type (Arr), True); + Set_Is_Packed (Base_Type (Arr), True); + end if; + end; + end if; + end; + + -- Check for Atomic_Components or Aliased with unsuitable packing + -- or explicit component size clause given. + + if (Has_Atomic_Components (Arr) + or else Has_Aliased_Components (Arr)) + and then (Has_Component_Size_Clause (Arr) + or else Is_Packed (Arr)) + then + Alias_Atomic_Check : declare + + procedure Complain_CS (T : String); + -- Outputs error messages for incorrect CS clause or pragma + -- Pack for aliased or atomic components (T is "aliased" or + -- "atomic"); + + ----------------- + -- Complain_CS -- + ----------------- + + procedure Complain_CS (T : String) is + begin + if Has_Component_Size_Clause (Arr) then + Clause := + Get_Attribute_Definition_Clause + (FS, Attribute_Component_Size); + + if Known_Static_Esize (Ctyp) then + Error_Msg_N + ("incorrect component size for " + & T & " components", Clause); + Error_Msg_Uint_1 := Esize (Ctyp); + Error_Msg_N + ("\only allowed value is^", Clause); + + else + Error_Msg_N + ("component size cannot be given for " + & T & " components", Clause); + end if; + + else + Error_Msg_N + ("cannot pack " & T & " components", + Get_Rep_Pragma (FS, Name_Pack)); + end if; + + return; + end Complain_CS; + + -- Start of processing for Alias_Atomic_Check + + begin + + -- If object size of component type isn't known, we cannot + -- be sure so we defer to the back end. + + if not Known_Static_Esize (Ctyp) then + null; + + -- Case where component size has no effect. First check for + -- object size of component type multiple of the storage + -- unit size. + + elsif Esize (Ctyp) mod System_Storage_Unit = 0 + + -- OK in both packing case and component size case if RM + -- size is known and static and same as the object size. + + and then + ((Known_Static_RM_Size (Ctyp) + and then Esize (Ctyp) = RM_Size (Ctyp)) + + -- Or if we have an explicit component size clause and + -- the component size and object size are equal. + + or else + (Has_Component_Size_Clause (Arr) + and then Component_Size (Arr) = Esize (Ctyp))) + then + null; + + elsif Has_Aliased_Components (Arr) + or else Is_Aliased (Ctyp) + then + Complain_CS ("aliased"); + + elsif Has_Atomic_Components (Arr) + or else Is_Atomic (Ctyp) + then + Complain_CS ("atomic"); + end if; + end Alias_Atomic_Check; + end if; + + -- Warn for case of atomic type + + Clause := Get_Rep_Pragma (FS, Name_Atomic); + + if Present (Clause) + and then not Addressable (Component_Size (FS)) + then + Error_Msg_NE + ("non-atomic components of type& may not be " + & "accessible by separate tasks??", Clause, Arr); + + if Has_Component_Size_Clause (Arr) then + Error_Msg_Sloc := + Sloc + (Get_Attribute_Definition_Clause + (FS, Attribute_Component_Size)); + Error_Msg_N + ("\because of component size clause#??", + Clause); + + elsif Has_Pragma_Pack (Arr) then + Error_Msg_Sloc := + Sloc (Get_Rep_Pragma (FS, Name_Pack)); + Error_Msg_N + ("\because of pragma Pack#??", Clause); + end if; + end if; + + -- Check for scalar storage order + + Check_Component_Storage_Order + (Encl_Type => Arr, + Comp => Empty, + ADC => Get_Attribute_Definition_Clause + (First_Subtype (Arr), + Attribute_Scalar_Storage_Order)); + + -- Processing that is done only for subtypes + + else + -- Acquire alignment from base type + + if Unknown_Alignment (Arr) then + Set_Alignment (Arr, Alignment (Base_Type (Arr))); + Adjust_Esize_Alignment (Arr); + end if; + end if; + + -- Specific checks for bit-packed arrays + + if Is_Bit_Packed_Array (Arr) then + + -- Check number of elements for bit packed arrays that come from + -- source and have compile time known ranges. The bit-packed + -- arrays circuitry does not support arrays with more than + -- Integer'Last + 1 elements, and when this restriction is + -- violated, causes incorrect data access. + + -- For the case where this is not compile time known, a run-time + -- check should be generated??? + + if Comes_From_Source (Arr) and then Is_Constrained (Arr) then + declare + Elmts : Uint; + Index : Node_Id; + Ilen : Node_Id; + Ityp : Entity_Id; + + begin + Elmts := Uint_1; + Index := First_Index (Arr); + while Present (Index) loop + Ityp := Etype (Index); + + -- Never generate an error if any index is of a generic + -- type. We will check this in instances. + + if Is_Generic_Type (Ityp) then + Elmts := Uint_0; + exit; + end if; + + Ilen := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Ityp, Loc), + Attribute_Name => Name_Range_Length); + Analyze_And_Resolve (Ilen); + + -- No attempt is made to check number of elements + -- if not compile time known. + + if Nkind (Ilen) /= N_Integer_Literal then + Elmts := Uint_0; + exit; + end if; + + Elmts := Elmts * Intval (Ilen); + Next_Index (Index); + end loop; + + if Elmts > Intval (High_Bound + (Scalar_Range + (Standard_Integer))) + 1 + then + Error_Msg_N + ("bit packed array type may not have " + & "more than Integer''Last+1 elements", Arr); + end if; + end; + end if; + + -- Check size + + if Known_RM_Size (Arr) then + declare + SizC : constant Node_Id := Size_Clause (Arr); + + Discard : Boolean; + pragma Warnings (Off, Discard); + + begin + -- It is not clear if it is possible to have no size clause + -- at this stage, but it is not worth worrying about. Post + -- error on the entity name in the size clause if present, + -- else on the type entity itself. + + if Present (SizC) then + Check_Size (Name (SizC), Arr, RM_Size (Arr), Discard); + else + Check_Size (Arr, Arr, RM_Size (Arr), Discard); + end if; + end; + end if; + end if; + + -- If any of the index types was an enumeration type with a + -- non-standard rep clause, then we indicate that the array type + -- is always packed (even if it is not bit packed). + + if Non_Standard_Enum then + Set_Has_Non_Standard_Rep (Base_Type (Arr)); + Set_Is_Packed (Base_Type (Arr)); + end if; + + Set_Component_Alignment_If_Not_Set (Arr); + + -- If the array is packed, we must create the packed array type to be + -- used to actually implement the type. This is only needed for real + -- array types (not for string literal types, since they are present + -- only for the front end). + + if Is_Packed (Arr) + and then Ekind (Arr) /= E_String_Literal_Subtype + then + Create_Packed_Array_Type (Arr); + Freeze_And_Append (Packed_Array_Type (Arr), N, Result); + + -- Size information of packed array type is copied to the array + -- type, since this is really the representation. But do not + -- override explicit existing size values. If the ancestor subtype + -- is constrained the packed_array_type will be inherited from it, + -- but the size may have been provided already, and must not be + -- overridden either. + + if not Has_Size_Clause (Arr) + and then + (No (Ancestor_Subtype (Arr)) + or else not Has_Size_Clause (Ancestor_Subtype (Arr))) + then + Set_Esize (Arr, Esize (Packed_Array_Type (Arr))); + Set_RM_Size (Arr, RM_Size (Packed_Array_Type (Arr))); + end if; + + if not Has_Alignment_Clause (Arr) then + Set_Alignment (Arr, Alignment (Packed_Array_Type (Arr))); + end if; + end if; + + -- For non-packed arrays set the alignment of the array to the + -- alignment of the component type if it is unknown. Skip this + -- in atomic case (atomic arrays may need larger alignments). + + if not Is_Packed (Arr) + and then Unknown_Alignment (Arr) + and then Known_Alignment (Ctyp) + and then Known_Static_Component_Size (Arr) + and then Known_Static_Esize (Ctyp) + and then Esize (Ctyp) = Component_Size (Arr) + and then not Is_Atomic (Arr) + then + Set_Alignment (Arr, Alignment (Component_Type (Arr))); + end if; + end Freeze_Array_Type; + + ----------------------------- + -- Freeze_Generic_Entities -- + ----------------------------- + + function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id is + E : Entity_Id; + F : Node_Id; + Flist : List_Id; + + begin + Flist := New_List; + E := First_Entity (Pack); + while Present (E) loop + if Is_Type (E) and then not Is_Generic_Type (E) then + F := Make_Freeze_Generic_Entity (Sloc (Pack)); + Set_Entity (F, E); + Append_To (Flist, F); + + elsif Ekind (E) = E_Generic_Package then + Append_List_To (Flist, Freeze_Generic_Entities (E)); + end if; + + Next_Entity (E); + end loop; + + return Flist; + end Freeze_Generic_Entities; + ------------------------ -- Freeze_Record_Type -- ------------------------ @@ -1970,6 +2561,11 @@ package body Freeze is -- clause (used to warn about useless Bit_Order pragmas, and also -- to detect cases where Implicit_Packing may have an effect). + Aliased_Component : Boolean := False; + -- Set True if we find at least one component which is aliased. This + -- is used to prevent Implicit_Packing of the record, since packing + -- cannot modify the size of alignment of an aliased component. + All_Scalar_Components : Boolean := True; -- Set False if we encounter a component of a non-scalar type @@ -1993,6 +2589,11 @@ package body Freeze is -- freeze node at some eventual point of call. Protected operations -- are handled elsewhere. + procedure Freeze_Choices_In_Variant_Part (VP : Node_Id); + -- Make sure that all types mentioned in Discrete_Choices of the + -- variants referenceed by the Variant_Part VP are frozen. This is + -- a recursive routine to deal with nested variants. + --------------------- -- Check_Allocator -- --------------------- @@ -2045,6 +2646,50 @@ package body Freeze is end if; end Check_Itype; + ------------------------------------ + -- Freeze_Choices_In_Variant_Part -- + ------------------------------------ + + procedure Freeze_Choices_In_Variant_Part (VP : Node_Id) is + pragma Assert (Nkind (VP) = N_Variant_Part); + + Variant : Node_Id; + Choice : Node_Id; + CL : Node_Id; + + begin + -- Loop through variants + + Variant := First_Non_Pragma (Variants (VP)); + while Present (Variant) loop + + -- Loop through choices, checking that all types are frozen + + Choice := First_Non_Pragma (Discrete_Choices (Variant)); + while Present (Choice) loop + if Nkind (Choice) in N_Has_Etype + and then Present (Etype (Choice)) + then + Freeze_And_Append (Etype (Choice), N, Result); + end if; + + Next_Non_Pragma (Choice); + end loop; + + -- Check for nested variant part to process + + CL := Component_List (Variant); + + if not Null_Present (CL) then + if Present (Variant_Part (CL)) then + Freeze_Choices_In_Variant_Part (Variant_Part (CL)); + end if; + end if; + + Next_Non_Pragma (Variant); + end loop; + end Freeze_Choices_In_Variant_Part; + -- Start of processing for Freeze_Record_Type begin @@ -2094,6 +2739,9 @@ package body Freeze is Comp := First_Entity (Rec); Prev := Empty; while Present (Comp) loop + if Is_Aliased (Comp) then + Aliased_Component := True; + end if; -- Handle the component and discriminant case @@ -2119,6 +2767,36 @@ package body Freeze is Freeze_And_Append (Etype (Comp), N, Result); + -- Warn for pragma Pack overriding foreign convention + + if Has_Foreign_Convention (Etype (Comp)) + and then Has_Pragma_Pack (Rec) + + -- Don't warn for aliased components, since override + -- cannot happen in that case. + + and then not Is_Aliased (Comp) + then + declare + CN : constant Name_Id := + Get_Convention_Name (Convention (Etype (Comp))); + PP : constant Node_Id := + Get_Pragma (Rec, Pragma_Pack); + begin + if Present (PP) then + Error_Msg_Name_1 := CN; + Error_Msg_Sloc := Sloc (Comp); + Error_Msg_N + ("pragma Pack affects convention % component#??", + PP); + Error_Msg_Name_1 := CN; + Error_Msg_NE + ("\component & may not have % compatible " + & "representation??", PP, Comp); + end if; + end; + end if; + -- Check for error of component clause given for variable -- sized type. We have to delay this test till this point, -- since the component type has to be frozen for us to know @@ -2272,7 +2950,7 @@ package body Freeze is begin if Present (Alloc) then - -- If component is pointer to a classwide type, freeze + -- If component is pointer to a class-wide type, freeze -- the specific type in the expression being allocated. -- The expression may be a subtype indication, in which -- case freeze the subtype mark. @@ -2351,15 +3029,16 @@ package body Freeze is ("??scalar storage order specified but no component clause", ADC); end if; + end if; - -- Check attribute on component types + -- Check consistent attribute setting on component types - Comp := First_Component (Rec); - while Present (Comp) loop - Check_Component_Storage_Order (Rec, Comp); - Next_Component (Comp); - end loop; - end if; + Comp := First_Component (Rec); + while Present (Comp) loop + Check_Component_Storage_Order + (Encl_Type => Rec, Comp => Comp, ADC => ADC); + Next_Component (Comp); + end loop; -- Deal with Bit_Order aspect specifying a non-default bit order @@ -2367,7 +3046,8 @@ package body Freeze is if Present (ADC) and then Base_Type (Rec) = Rec then if not (Placed_Component or else Is_Packed (Rec)) then - Error_Msg_N ("??bit order specification has no effect", ADC); + Error_Msg_N + ("??bit order specification has no effect", ADC); Error_Msg_N ("\??since no component clauses were specified", ADC); @@ -2443,15 +3123,13 @@ package body Freeze is -- remote type here since that is what we are semantically freezing. -- This prevents the freeze node for that type in an inner scope. - -- Also, Check for controlled components and unchecked unions. - -- Finally, enforce the restriction that access attributes with a - -- current instance prefix can only apply to limited types. - if Ekind (Rec) = E_Record_Type then if Present (Corresponding_Remote_Type (Rec)) then Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result); end if; + -- Check for controlled components and unchecked unions. + Comp := First_Component (Rec); while Present (Comp) loop @@ -2459,18 +3137,18 @@ package body Freeze is -- equivalent type. See Make_CW_Equivalent_Type. if not Is_Class_Wide_Equivalent_Type (Rec) - and then (Has_Controlled_Component (Etype (Comp)) - or else (Chars (Comp) /= Name_uParent - and then Is_Controlled (Etype (Comp))) - or else (Is_Protected_Type (Etype (Comp)) - and then - Present - (Corresponding_Record_Type - (Etype (Comp))) - and then - Has_Controlled_Component - (Corresponding_Record_Type - (Etype (Comp))))) + and then + (Has_Controlled_Component (Etype (Comp)) + or else + (Chars (Comp) /= Name_uParent + and then Is_Controlled (Etype (Comp))) + or else + (Is_Protected_Type (Etype (Comp)) + and then + Present (Corresponding_Record_Type (Etype (Comp))) + and then + Has_Controlled_Component + (Corresponding_Record_Type (Etype (Comp))))) then Set_Has_Controlled_Component (Rec); end if; @@ -2490,11 +3168,17 @@ package body Freeze is end loop; end if; + -- Enforce the restriction that access attributes with a current + -- instance prefix can only apply to limited types. This comment + -- is floating here, but does not seem to belong here??? + + -- Set component alignment if not otherwise already set + Set_Component_Alignment_If_Not_Set (Rec); -- For first subtypes, check if there are any fixed-point fields with -- component clauses, where we must check the size. This is not done - -- till the freeze point, since for fixed-point types, we do not know + -- till the freeze point since for fixed-point types, we do not know -- the size until the type is frozen. Similar processing applies to -- bit packed arrays. @@ -2565,6 +3249,10 @@ package body Freeze is and then not Placed_Component + -- Or even one component is aliased + + and then not Aliased_Component + -- Must have size clause and all scalar components and then Has_Size_Clause (Rec) @@ -2613,6 +3301,53 @@ package body Freeze is end; end if; end if; + + -- All done if not a full record definition + + if Ekind (Rec) /= E_Record_Type then + return; + end if; + + -- Finally we need to check the variant part to make sure that + -- all types within choices are properly frozen as part of the + -- freezing of the record type. + + Check_Variant_Part : declare + D : constant Node_Id := Declaration_Node (Rec); + T : Node_Id; + C : Node_Id; + + begin + -- Find component list + + C := Empty; + + if Nkind (D) = N_Full_Type_Declaration then + T := Type_Definition (D); + + if Nkind (T) = N_Record_Definition then + C := Component_List (T); + + elsif Nkind (T) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (T)) + then + C := Component_List (Record_Extension_Part (T)); + end if; + end if; + + -- Case of variant part present + + if Present (C) and then Present (Variant_Part (C)) then + Freeze_Choices_In_Variant_Part (Variant_Part (C)); + end if; + + -- Note: we used to call Check_Choices here, but it is too early, + -- since predicated subtypes are frozen here, but their freezing + -- actions are in Analyze_Freeze_Entity, which has not been called + -- yet for entities frozen within this procedure, so we moved that + -- call to the Analyze_Freeze_Entity for the record type. + + end Check_Variant_Part; end Freeze_Record_Type; -- Start of processing for Freeze_Entity @@ -2659,6 +3394,12 @@ package body Freeze is then return No_List; + -- Generic types need no freeze node and have no delayed semantic + -- checks. + + elsif Is_Generic_Type (E) then + return No_List; + -- Do not freeze a global entity within an inner scope created during -- expansion. A call to subprogram E within some internal procedure -- (a stream attribute for example) might require freezing E, but the @@ -2728,6 +3469,9 @@ package body Freeze is return No_List; end if; end; + + elsif Ekind (E) = E_Generic_Package then + return Freeze_Generic_Entities (E); end if; -- Add checks to detect proper initialization of scalars that may appear @@ -2813,6 +3557,7 @@ package body Freeze is if Is_Incomplete_Type (F_Type) and then Present (Full_View (F_Type)) + and then not From_Limited_With (F_Type) then F_Type := Full_View (F_Type); Set_Etype (Formal, F_Type); @@ -2962,7 +3707,7 @@ package body Freeze is Error_Msg_Qual_Level := 0; end if; - if not From_With_Type (F_Type) then + if not From_Limited_With (F_Type) then if Is_Access_Type (F_Type) then F_Type := Designated_Type (F_Type); end if; @@ -2991,10 +3736,15 @@ package body Freeze is R_Type := Etype (E); -- AI05-0151: the return type may have been incomplete - -- at the point of declaration. + -- at the point of declaration. Replace it with the full + -- view, unless the current type is a limited view. In + -- that case the full view is in a different unit, and + -- gigi finds the non-limited view after the other unit + -- is elaborated. if Ekind (R_Type) = E_Incomplete_Type and then Present (Full_View (R_Type)) + and then not From_Limited_With (R_Type) then R_Type := Full_View (R_Type); Set_Etype (E, R_Type); @@ -3196,6 +3946,24 @@ package body Freeze is Check_Address_Clause (E); + -- Reset Is_True_Constant for aliased object. We consider that + -- the fact that something is aliased may indicate that some + -- funny business is going on, e.g. an aliased object is passed + -- by reference to a procedure which captures the address of + -- the object, which is later used to assign a new value. Such + -- code is highly dubious, but we choose to make it "work" for + -- aliased objects. + + -- However, we don't do that for internal entities. We figure + -- that if we deliberately set Is_True_Constant for an internal + -- entity, e.g. a dispatch table entry, then we mean it! + + if (Is_Aliased (E) or else Is_Aliased (Etype (E))) + and then not Is_Internal_Name (Chars (E)) + then + Set_Is_True_Constant (E, False); + end if; + -- If the object needs any kind of default initialization, an -- error must be issued if No_Default_Initialization applies. -- The check doesn't apply to imported objects, which are not @@ -3372,7 +4140,6 @@ package body Freeze is end if; end; end if; - end if; -- Case of a type or subtype being frozen @@ -3399,7 +4166,9 @@ package body Freeze is if Present (Scope (E)) and then Is_Generic_Unit (Scope (E)) - and then not Has_Predicates (E) + and then + (not Has_Predicates (E) + and then not Has_Delayed_Freeze (E)) then Check_Compile_Time_Size (E); return No_List; @@ -3581,506 +4350,10 @@ package body Freeze is Inherit_Aspects_At_Freeze_Point (E); end if; - -- For array type, freeze index types and component type first - -- before freezing the array (RM 13.14(15)). + -- Array type if Is_Array_Type (E) then - declare - FS : constant Entity_Id := First_Subtype (E); - Ctyp : constant Entity_Id := Component_Type (E); - Clause : Entity_Id; - - Non_Standard_Enum : Boolean := False; - -- Set true if any of the index types is an enumeration type - -- with a non-standard representation. - - begin - Freeze_And_Append (Ctyp, N, Result); - - Indx := First_Index (E); - while Present (Indx) loop - Freeze_And_Append (Etype (Indx), N, Result); - - if Is_Enumeration_Type (Etype (Indx)) - and then Has_Non_Standard_Rep (Etype (Indx)) - then - Non_Standard_Enum := True; - end if; - - Next_Index (Indx); - end loop; - - -- Processing that is done only for base types - - if Ekind (E) = E_Array_Type then - - -- Propagate flags for component type - - if Is_Controlled (Component_Type (E)) - or else Has_Controlled_Component (Ctyp) - then - Set_Has_Controlled_Component (E); - end if; - - if Has_Unchecked_Union (Component_Type (E)) then - Set_Has_Unchecked_Union (E); - end if; - - -- If packing was requested or if the component size was set - -- explicitly, then see if bit packing is required. This - -- processing is only done for base types, since all the - -- representation aspects involved are type-related. This - -- is not just an optimization, if we start processing the - -- subtypes, they interfere with the settings on the base - -- type (this is because Is_Packed has a slightly different - -- meaning before and after freezing). - - declare - Csiz : Uint; - Esiz : Uint; - - begin - if (Is_Packed (E) or else Has_Pragma_Pack (E)) - and then Known_Static_RM_Size (Ctyp) - and then not Has_Component_Size_Clause (E) - then - Csiz := UI_Max (RM_Size (Ctyp), 1); - - elsif Known_Component_Size (E) then - Csiz := Component_Size (E); - - elsif not Known_Static_Esize (Ctyp) then - Csiz := Uint_0; - - else - Esiz := Esize (Ctyp); - - -- We can set the component size if it is less than - -- 16, rounding it up to the next storage unit size. - - if Esiz <= 8 then - Csiz := Uint_8; - elsif Esiz <= 16 then - Csiz := Uint_16; - else - Csiz := Uint_0; - end if; - - -- Set component size up to match alignment if it - -- would otherwise be less than the alignment. This - -- deals with cases of types whose alignment exceeds - -- their size (padded types). - - if Csiz /= 0 then - declare - A : constant Uint := Alignment_In_Bits (Ctyp); - begin - if Csiz < A then - Csiz := A; - end if; - end; - end if; - end if; - - -- Case of component size that may result in packing - - if 1 <= Csiz and then Csiz <= 64 then - declare - Ent : constant Entity_Id := - First_Subtype (E); - Pack_Pragma : constant Node_Id := - Get_Rep_Pragma (Ent, Name_Pack); - Comp_Size_C : constant Node_Id := - Get_Attribute_Definition_Clause - (Ent, Attribute_Component_Size); - begin - -- Warn if we have pack and component size so that - -- the pack is ignored. - - -- Note: here we must check for the presence of a - -- component size before checking for a Pack pragma - -- to deal with the case where the array type is a - -- derived type whose parent is currently private. - - if Present (Comp_Size_C) - and then Has_Pragma_Pack (Ent) - and then Warn_On_Redundant_Constructs - then - Error_Msg_Sloc := Sloc (Comp_Size_C); - Error_Msg_NE - ("?r?pragma Pack for& ignored!", - Pack_Pragma, Ent); - Error_Msg_N - ("\?r?explicit component size given#!", - Pack_Pragma); - Set_Is_Packed (Base_Type (Ent), False); - Set_Is_Bit_Packed_Array (Base_Type (Ent), False); - end if; - - -- Set component size if not already set by a - -- component size clause. - - if not Present (Comp_Size_C) then - Set_Component_Size (E, Csiz); - end if; - - -- Check for base type of 8, 16, 32 bits, where an - -- unsigned subtype has a length one less than the - -- base type (e.g. Natural subtype of Integer). - - -- In such cases, if a component size was not set - -- explicitly, then generate a warning. - - if Has_Pragma_Pack (E) - and then not Present (Comp_Size_C) - and then - (Csiz = 7 or else Csiz = 15 or else Csiz = 31) - and then Esize (Base_Type (Ctyp)) = Csiz + 1 - then - Error_Msg_Uint_1 := Csiz; - - if Present (Pack_Pragma) then - Error_Msg_N - ("??pragma Pack causes component size " - & "to be ^!", Pack_Pragma); - Error_Msg_N - ("\??use Component_Size to set " - & "desired value!", Pack_Pragma); - end if; - end if; - - -- Actual packing is not needed for 8, 16, 32, 64. - -- Also not needed for 24 if alignment is 1. - - if Csiz = 8 - or else Csiz = 16 - or else Csiz = 32 - or else Csiz = 64 - or else (Csiz = 24 and then Alignment (Ctyp) = 1) - then - -- Here the array was requested to be packed, - -- but the packing request had no effect, so - -- Is_Packed is reset. - - -- Note: semantically this means that we lose - -- track of the fact that a derived type - -- inherited a pragma Pack that was non- - -- effective, but that seems fine. - - -- We regard a Pack pragma as a request to set - -- a representation characteristic, and this - -- request may be ignored. - - Set_Is_Packed (Base_Type (E), False); - Set_Is_Bit_Packed_Array (Base_Type (E), False); - - if Known_Static_Esize (Component_Type (E)) - and then Esize (Component_Type (E)) = Csiz - then - Set_Has_Non_Standard_Rep - (Base_Type (E), False); - end if; - - -- In all other cases, packing is indeed needed - - else - Set_Has_Non_Standard_Rep (Base_Type (E), True); - Set_Is_Bit_Packed_Array (Base_Type (E), True); - Set_Is_Packed (Base_Type (E), True); - end if; - end; - end if; - end; - - -- Check for Atomic_Components or Aliased with unsuitable - -- packing or explicit component size clause given. - - if (Has_Atomic_Components (E) - or else Has_Aliased_Components (E)) - and then (Has_Component_Size_Clause (E) - or else Is_Packed (E)) - then - Alias_Atomic_Check : declare - - procedure Complain_CS (T : String); - -- Outputs error messages for incorrect CS clause or - -- pragma Pack for aliased or atomic components (T is - -- "aliased" or "atomic"); - - ----------------- - -- Complain_CS -- - ----------------- - - procedure Complain_CS (T : String) is - begin - if Has_Component_Size_Clause (E) then - Clause := - Get_Attribute_Definition_Clause - (FS, Attribute_Component_Size); - - if Known_Static_Esize (Ctyp) then - Error_Msg_N - ("incorrect component size for " - & T & " components", Clause); - Error_Msg_Uint_1 := Esize (Ctyp); - Error_Msg_N - ("\only allowed value is^", Clause); - - else - Error_Msg_N - ("component size cannot be given for " - & T & " components", Clause); - end if; - - else - Error_Msg_N - ("cannot pack " & T & " components", - Get_Rep_Pragma (FS, Name_Pack)); - end if; - - return; - end Complain_CS; - - -- Start of processing for Alias_Atomic_Check - - begin - - -- If object size of component type isn't known, we - -- cannot be sure so we defer to the back end. - - if not Known_Static_Esize (Ctyp) then - null; - - -- Case where component size has no effect. First - -- check for object size of component type multiple - -- of the storage unit size. - - elsif Esize (Ctyp) mod System_Storage_Unit = 0 - - -- OK in both packing case and component size case - -- if RM size is known and static and the same as - -- the object size. - - and then - ((Known_Static_RM_Size (Ctyp) - and then Esize (Ctyp) = RM_Size (Ctyp)) - - -- Or if we have an explicit component size - -- clause and the component size and object size - -- are equal. - - or else - (Has_Component_Size_Clause (E) - and then Component_Size (E) = Esize (Ctyp))) - then - null; - - elsif Has_Aliased_Components (E) - or else Is_Aliased (Ctyp) - then - Complain_CS ("aliased"); - - elsif Has_Atomic_Components (E) - or else Is_Atomic (Ctyp) - then - Complain_CS ("atomic"); - end if; - end Alias_Atomic_Check; - end if; - - -- Warn for case of atomic type - - Clause := Get_Rep_Pragma (FS, Name_Atomic); - - if Present (Clause) - and then not Addressable (Component_Size (FS)) - then - Error_Msg_NE - ("non-atomic components of type& may not be " - & "accessible by separate tasks??", Clause, E); - - if Has_Component_Size_Clause (E) then - Error_Msg_Sloc := - Sloc - (Get_Attribute_Definition_Clause - (FS, Attribute_Component_Size)); - Error_Msg_N - ("\because of component size clause#??", - Clause); - - elsif Has_Pragma_Pack (E) then - Error_Msg_Sloc := - Sloc (Get_Rep_Pragma (FS, Name_Pack)); - Error_Msg_N - ("\because of pragma Pack#??", Clause); - end if; - end if; - - -- Check for scalar storage order - - if Present (Get_Attribute_Definition_Clause - (E, Attribute_Scalar_Storage_Order)) - then - Check_Component_Storage_Order (E, Empty); - end if; - - -- Processing that is done only for subtypes - - else - -- Acquire alignment from base type - - if Unknown_Alignment (E) then - Set_Alignment (E, Alignment (Base_Type (E))); - Adjust_Esize_Alignment (E); - end if; - end if; - - -- Specific checks for bit-packed arrays - - if Is_Bit_Packed_Array (E) then - - -- Check number of elements for bit packed arrays that come - -- from source and have compile time known ranges. The - -- bit-packed arrays circuitry does not support arrays - -- with more than Integer'Last + 1 elements, and when this - -- restriction is violated, causes incorrect data access. - - -- For the case where this is not compile time known, a - -- run-time check should be generated??? - - if Comes_From_Source (E) and then Is_Constrained (E) then - declare - Elmts : Uint; - Index : Node_Id; - Ilen : Node_Id; - Ityp : Entity_Id; - - begin - Elmts := Uint_1; - Index := First_Index (E); - while Present (Index) loop - Ityp := Etype (Index); - - -- Never generate an error if any index is of a - -- generic type. We will check this in instances. - - if Is_Generic_Type (Ityp) then - Elmts := Uint_0; - exit; - end if; - - Ilen := - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Ityp, Loc), - Attribute_Name => Name_Range_Length); - Analyze_And_Resolve (Ilen); - - -- No attempt is made to check number of elements - -- if not compile time known. - - if Nkind (Ilen) /= N_Integer_Literal then - Elmts := Uint_0; - exit; - end if; - - Elmts := Elmts * Intval (Ilen); - Next_Index (Index); - end loop; - - if Elmts > Intval (High_Bound - (Scalar_Range - (Standard_Integer))) + 1 - then - Error_Msg_N - ("bit packed array type may not have " - & "more than Integer''Last+1 elements", E); - end if; - end; - end if; - - -- Check size - - if Known_RM_Size (E) then - declare - SizC : constant Node_Id := Size_Clause (E); - - Discard : Boolean; - pragma Warnings (Off, Discard); - - begin - -- It is not clear if it is possible to have no size - -- clause at this stage, but it is not worth worrying - -- about. Post error on the entity name in the size - -- clause if present, else on the type entity itself. - - if Present (SizC) then - Check_Size (Name (SizC), E, RM_Size (E), Discard); - else - Check_Size (E, E, RM_Size (E), Discard); - end if; - end; - end if; - end if; - - -- If any of the index types was an enumeration type with a - -- non-standard rep clause, then we indicate that the array - -- type is always packed (even if it is not bit packed). - - if Non_Standard_Enum then - Set_Has_Non_Standard_Rep (Base_Type (E)); - Set_Is_Packed (Base_Type (E)); - end if; - - Set_Component_Alignment_If_Not_Set (E); - - -- If the array is packed, we must create the packed array - -- type to be used to actually implement the type. This is - -- only needed for real array types (not for string literal - -- types, since they are present only for the front end). - - if Is_Packed (E) - and then Ekind (E) /= E_String_Literal_Subtype - then - Create_Packed_Array_Type (E); - Freeze_And_Append (Packed_Array_Type (E), N, Result); - - -- Size information of packed array type is copied to the - -- array type, since this is really the representation. But - -- do not override explicit existing size values. If the - -- ancestor subtype is constrained the packed_array_type - -- will be inherited from it, but the size may have been - -- provided already, and must not be overridden either. - - if not Has_Size_Clause (E) - and then - (No (Ancestor_Subtype (E)) - or else not Has_Size_Clause (Ancestor_Subtype (E))) - then - Set_Esize (E, Esize (Packed_Array_Type (E))); - Set_RM_Size (E, RM_Size (Packed_Array_Type (E))); - end if; - - if not Has_Alignment_Clause (E) then - Set_Alignment (E, Alignment (Packed_Array_Type (E))); - end if; - end if; - - -- For non-packed arrays set the alignment of the array to the - -- alignment of the component type if it is unknown. Skip this - -- in atomic case (atomic arrays may need larger alignments). - - if not Is_Packed (E) - and then Unknown_Alignment (E) - and then Known_Alignment (Ctyp) - and then Known_Static_Component_Size (E) - and then Known_Static_Esize (Ctyp) - and then Esize (Ctyp) = Component_Size (E) - and then not Is_Atomic (E) - then - Set_Alignment (E, Alignment (Component_Type (E))); - end if; - end; + Freeze_Array_Type (E); -- For a class-wide type, the corresponding specific type is -- frozen as well (RM 13.14(15)) @@ -4142,7 +4415,9 @@ package body Freeze is -- for the case of a private type with record extension (we will do -- that later when the full type is frozen). - elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) then + elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) + and then not Is_Generic_Unit (Scope (E)) + then Freeze_Record_Type (E); -- For a concurrent type, freeze corresponding record type. This @@ -4446,6 +4721,7 @@ package body Freeze is if Is_Pure_Unit_Access_Type (E) and then (Ada_Version < Ada_2005 or else not No_Pool_Assigned (E)) + and then not Is_Generic_Unit (Scope (E)) then Error_Msg_N ("named access type not allowed in pure unit", E); @@ -4518,7 +4794,7 @@ package body Freeze is if Has_Private_Declaration (E) then if (not Is_Record_Type (E) - or else not Is_Immutably_Limited_Type (E)) + or else not Is_Limited_View (E)) and then not Is_Private_Type (E) then Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 7c56ac9789f..8a64134d91d 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -99,13 +99,6 @@ begin CStand.Create_Standard; - -- If the -gnatd.H flag is present, we are only interested in the Standard - -- package, so the frontend has done its job here. - - if Debug_Flag_Dot_HH then - return; - end if; - -- Check possible symbol definitions specified by -gnateD switches Prepcomp.Process_Command_Line_Symbol_Definitions; diff --git a/gcc/ada/g-arrspl.adb b/gcc/ada/g-arrspl.adb index a897b13f913..9229610554f 100644 --- a/gcc/ada/g-arrspl.adb +++ b/gcc/ada/g-arrspl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2013, 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- -- @@ -118,14 +118,22 @@ package body GNAT.Array_Split is procedure Free is new Ada.Unchecked_Deallocation (Natural, Counter); + Ref_Counter : Counter := S.Ref_Counter; + begin - S.Ref_Counter.all := S.Ref_Counter.all - 1; + -- Ensure call is idempotent + + S.Ref_Counter := null; - if S.Ref_Counter.all = 0 then - Free (S.Source); - Free (S.Indexes); - Free (S.Slices); - Free (S.Ref_Counter); + if Ref_Counter /= null then + Ref_Counter.all := Ref_Counter.all - 1; + + if Ref_Counter.all = 0 then + Free (S.Source); + Free (S.Indexes); + Free (S.Slices); + Free (Ref_Counter); + end if; end if; end Finalize; diff --git a/gcc/ada/g-cppexc.adb b/gcc/ada/g-cppexc.adb new file mode 100644 index 00000000000..d89cf0ccac3 --- /dev/null +++ b/gcc/ada/g-cppexc.adb @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C P P _ E X C E P T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; +with System.Storage_Elements; +with Interfaces.C; use Interfaces.C; +with Ada.Unchecked_Conversion; +with System.Standard_Library; use System.Standard_Library; + +package body GNAT.CPP_Exceptions is + + -- Note: all functions prefixed by __cxa are part of the c++ ABI for + -- exception handling. As they are provided by the c++ library, there + -- must be no dependencies on it in the compiled code of this unit, but + -- there can be dependencies in instances. This is required to be able + -- to build the shared library without the c++ library. + + function To_Exception_Data_Ptr is new + Ada.Unchecked_Conversion + (Exception_Id, Exception_Data_Ptr); + -- Convert an Exception_Id to its non-private type. This is used to get + -- the RTTI of a C++ exception + + function Get_Exception_Machine_Occurrence + (X : Exception_Occurrence) return System.Address; + pragma Import (Ada, Get_Exception_Machine_Occurrence, + "__gnat_get_exception_machine_occurrence"); + -- Imported function (from Ada.Exceptions) that returns the machine + -- occurrence from an exception occurrence. + + ------------------------- + -- Raise_Cpp_Exception -- + ------------------------- + + procedure Raise_Cpp_Exception (Id : Exception_Id; Value : T) + is + Id_Data : constant Exception_Data_Ptr := To_Exception_Data_Ptr (Id); + -- Get a non-private view on the exception + + type T_Acc is access all T; + pragma Convention (C, T_Acc); + -- Access type to the object compatible with C + + Occ : T_Acc; + -- The occurrence to propagate + + function cxa_allocate_exception (Size : size_t) return T_Acc; + pragma Import (C, cxa_allocate_exception, "__cxa_allocate_exception"); + -- The C++ function to allocate an occurrence + + procedure cxa_throw (Obj : T_Acc; Tinfo : System.Address; + Dest : System.Address); + pragma Import (C, cxa_throw, "__cxa_throw"); + pragma No_Return (cxa_throw); + -- The C++ function to raise an exception + begin + -- Check the exception was imported from C++ + + if Id_Data.Lang /= 'C' then + raise Constraint_Error; + end if; + + -- Allocate the C++ occurrence + + Occ := cxa_allocate_exception (T'Size / System.Storage_Unit); + + -- Set the object + + Occ.all := Value; + + -- Throw the exception + + cxa_throw (Occ, Id_Data.Foreign_Data, System.Null_Address); + end Raise_Cpp_Exception; + + ---------------- + -- Get_Object -- + ---------------- + + function Get_Object (X : Exception_Occurrence) return T + is + use System; + use System.Storage_Elements; + + Unwind_Exception_Size : Natural; + pragma Import (C, Unwind_Exception_Size, "__gnat_unwind_exception_size"); + -- Size in bytes of _Unwind_Exception + + Exception_Addr : constant Address := + Get_Exception_Machine_Occurrence (X); + -- Machine occurrence of X + + begin + -- Check the machine occurrence exists + + if Exception_Addr = Null_Address then + raise Constraint_Error; + end if; + + declare + -- Import the object from the occurrence + Result : T; + pragma Import (Ada, Result); + for Result'Address use + Exception_Addr + Storage_Offset (Unwind_Exception_Size); + begin + -- And return it + return Result; + end; + end Get_Object; +end GNAT.CPP_Exceptions; diff --git a/gcc/ada/g-cppexc.ads b/gcc/ada/g-cppexc.ads new file mode 100644 index 00000000000..60105e6f98c --- /dev/null +++ b/gcc/ada/g-cppexc.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C P P _ E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2013, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface for raising and handling C++ exceptions + +with Ada.Exceptions; use Ada.Exceptions; + +package GNAT.CPP_Exceptions is + generic + type T is private; + procedure Raise_Cpp_Exception (Id : Exception_Id; Value : T); + -- Raise a C++ exception identified by Id. Associate Value with this + -- occurrence. Id must refer to an exception that has the Cpp convention. + + generic + type T is private; + function Get_Object (X : Exception_Occurrence) return T; + -- Extract the object associated with X. The exception of the occurrence + -- X must have a Cpp Convention. +end GNAT.CPP_Exceptions; diff --git a/gcc/ada/g-decstr.adb b/gcc/ada/g-decstr.adb index a08584f22e3..255e78a2614 100644 --- a/gcc/ada/g-decstr.adb +++ b/gcc/ada/g-decstr.adb @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007-2010, AdaCore -- +-- Copyright (C) 2007-2013, 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- -- @@ -192,6 +192,11 @@ package body GNAT.Decode_String is elsif (U and 2#11100000#) = 2#110_00000# then W := U and 2#00011111#; Get_UTF_Byte; + + if W not in 16#00_0080# .. 16#00_07FF# then + Bad; + end if; + Result := Wide_Wide_Character'Val (W); -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx @@ -200,6 +205,11 @@ package body GNAT.Decode_String is W := U and 2#00001111#; Get_UTF_Byte; Get_UTF_Byte; + + if W not in 16#00_0800# .. 16#00_FFFF# then + Bad; + end if; + Result := Wide_Wide_Character'Val (W); -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx @@ -211,6 +221,10 @@ package body GNAT.Decode_String is Get_UTF_Byte; end loop; + if W not in 16#01_0000# .. 16#10_FFFF# then + Bad; + end if; + Result := Wide_Wide_Character'Val (W); -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx @@ -223,6 +237,10 @@ package body GNAT.Decode_String is Get_UTF_Byte; end loop; + if W not in 16#0020_0000# .. 16#03FF_FFFF# then + Bad; + end if; + Result := Wide_Wide_Character'Val (W); -- All other cases are invalid, note that this includes: @@ -304,100 +322,10 @@ package body GNAT.Decode_String is ------------------------- procedure Next_Wide_Character (Input : String; Ptr : in out Natural) is + Discard : Wide_Character; + pragma Unreferenced (Discard); begin - if Ptr < Input'First then - Past_End; - end if; - - -- Special efficient encoding for UTF-8 case - - if Encoding_Method = WCEM_UTF8 then - UTF8 : declare - U : Unsigned_32; - - procedure Getc; - pragma Inline (Getc); - -- Gets the character at Input (Ptr) and returns code in U as - -- Unsigned_32 value. On return Ptr is bumped past the character. - - procedure Skip_UTF_Byte; - pragma Inline (Skip_UTF_Byte); - -- Skips past one encoded byte which must be 2#10xxxxxx# - - ---------- - -- Getc -- - ---------- - - procedure Getc is - begin - if Ptr > Input'Last then - Past_End; - else - U := Unsigned_32 (Character'Pos (Input (Ptr))); - Ptr := Ptr + 1; - end if; - end Getc; - - ------------------- - -- Skip_UTF_Byte -- - ------------------- - - procedure Skip_UTF_Byte is - begin - Getc; - - if (U and 2#11000000#) /= 2#10_000000# then - Bad; - end if; - end Skip_UTF_Byte; - - -- Start of processing for UTF-8 case - - begin - -- 16#00_0000#-16#00_007F#: 0xxxxxxx - - Getc; - - if (U and 2#10000000#) = 2#00000000# then - return; - - -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx - - elsif (U and 2#11100000#) = 2#110_00000# then - Skip_UTF_Byte; - - -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx - - elsif (U and 2#11110000#) = 2#1110_0000# then - Skip_UTF_Byte; - Skip_UTF_Byte; - - -- Any other code is invalid, note that this includes: - - -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - - -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx - - -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx 10xxxxxx - - -- since Wide_Character does not allow codes > 16#FFFF# - - else - Bad; - end if; - end UTF8; - - -- Non-UTF-8 case - - else - declare - Discard : Wide_Character; - begin - Decode_Wide_Character (Input, Ptr, Discard); - end; - end if; + Decode_Wide_Character (Input, Ptr, Discard); end Next_Wide_Character; ------------------------------ @@ -405,110 +333,10 @@ package body GNAT.Decode_String is ------------------------------ procedure Next_Wide_Wide_Character (Input : String; Ptr : in out Natural) is + Discard : Wide_Wide_Character; + pragma Unreferenced (Discard); begin - -- Special efficient encoding for UTF-8 case - - if Encoding_Method = WCEM_UTF8 then - UTF8 : declare - U : Unsigned_32; - - procedure Getc; - pragma Inline (Getc); - -- Gets the character at Input (Ptr) and returns code in U as - -- Unsigned_32 value. On return Ptr is bumped past the character. - - procedure Skip_UTF_Byte; - pragma Inline (Skip_UTF_Byte); - -- Skips past one encoded byte which must be 2#10xxxxxx# - - ---------- - -- Getc -- - ---------- - - procedure Getc is - begin - if Ptr > Input'Last then - Past_End; - else - U := Unsigned_32 (Character'Pos (Input (Ptr))); - Ptr := Ptr + 1; - end if; - end Getc; - - ------------------- - -- Skip_UTF_Byte -- - ------------------- - - procedure Skip_UTF_Byte is - begin - Getc; - - if (U and 2#11000000#) /= 2#10_000000# then - Bad; - end if; - end Skip_UTF_Byte; - - -- Start of processing for UTF-8 case - - begin - if Ptr < Input'First then - Past_End; - end if; - - -- 16#00_0000#-16#00_007F#: 0xxxxxxx - - Getc; - - if (U and 2#10000000#) = 2#00000000# then - null; - - -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx - - elsif (U and 2#11100000#) = 2#110_00000# then - Skip_UTF_Byte; - - -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx - - elsif (U and 2#11110000#) = 2#1110_0000# then - Skip_UTF_Byte; - Skip_UTF_Byte; - - -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - - elsif (U and 2#11111000#) = 2#11110_000# then - for K in 1 .. 3 loop - Skip_UTF_Byte; - end loop; - - -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx - - elsif (U and 2#11111100#) = 2#111110_00# then - for K in 1 .. 4 loop - Skip_UTF_Byte; - end loop; - - -- Any other code is invalid, note that this includes: - - -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx 10xxxxxx - - -- since Wide_Wide_Character does not allow codes > 16#03FF_FFFF# - - else - Bad; - end if; - end UTF8; - - -- Non-UTF-8 case - - else - declare - Discard : Wide_Wide_Character; - begin - Decode_Wide_Wide_Character (Input, Ptr, Discard); - end; - end if; + Decode_Wide_Wide_Character (Input, Ptr, Discard); end Next_Wide_Wide_Character; -------------- diff --git a/gcc/ada/g-decstr.ads b/gcc/ada/g-decstr.ads index e4d7b7f1633..d59f10dcb20 100644 --- a/gcc/ada/g-decstr.ads +++ b/gcc/ada/g-decstr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007-2010, AdaCore -- +-- Copyright (C) 2007-2013, 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- -- @@ -47,6 +47,17 @@ -- does not make any assumptions about the character coding. See also the -- packages Ada.Wide_[Wide_]Characters.Unicode for unicode specific functions. +-- In particular, in the case of UTF-8, all valid UTF-8 encodings, as listed +-- in table 3.6 of the Unicode Standard, version 6.2.0, are recognized as +-- legitimate. This includes the full range 16#0000_0000# .. 16#03FF_FFFF#. +-- This includes codes in the range 16#D800# - 16#DFFF#. These codes all +-- have UTF-8 encoding sequences that are well-defined (e.g. the encoding for +-- 16#D800# is ED A0 80). But these codes do not correspond to defined Unicode +-- characters and are thus considered to be "not well-formed" (see table 3.7 +-- of the Unicode Standard). If you need to exclude these codes, you must do +-- that manually, e.g. use Decode_Wide_Character/Decode_Wide_String and check +-- that the resulting code(s) are not in this range. + -- Note on the use of brackets encoding (WCEM_Brackets). The brackets encoding -- method is ambiguous in the context of this package, since there is no way -- to tell if ["1234"] is eight unencoded characters or one encoded character. @@ -86,7 +97,6 @@ package GNAT.Decode_String is -- will be raised. function Decode_Wide_Wide_String (S : String) return Wide_Wide_String; - pragma Inline (Decode_Wide_Wide_String); -- Same as above function but for Wide_Wide_String output procedure Decode_Wide_Wide_String @@ -124,16 +134,17 @@ package GNAT.Decode_String is (Input : String; Ptr : in out Natural; Result : out Wide_Wide_Character); + pragma Inline (Decode_Wide_Wide_Character); -- Same as above procedure but with Wide_Wide_Character input procedure Next_Wide_Character (Input : String; Ptr : in out Natural); + pragma Inline (Next_Wide_Character); -- This procedure examines the input string starting at Input (Ptr), and -- advances Ptr past one character in the encoded string, so that on return -- Ptr points to the next encoded character. Constraint_Error is raised if -- an invalid encoding is encountered, or the end of the string is reached -- or if Ptr is less than String'First on entry, or if the character - -- skipped is not a valid Wide_Character code. This call may be more - -- efficient than calling Decode_Wide_Character and discarding the result. + -- skipped is not a valid Wide_Character code. procedure Prev_Wide_Character (Input : String; Ptr : in out Natural); -- This procedure is similar to Next_Encoded_Character except that it moves @@ -149,8 +160,12 @@ package GNAT.Decode_String is -- WCEM_Brackets). For all other encodings, we work by starting at the -- beginning of the string and moving forward till Ptr is reached, which -- is correct but slow. + -- + -- Note: this routine assumes that the sequence prior to Ptr is correctly + -- encoded, it does not have a defined behavior if this is not the case. procedure Next_Wide_Wide_Character (Input : String; Ptr : in out Natural); + pragma Inline (Next_Wide_Wide_Character); -- Similar to Next_Wide_Character except that codes skipped must be valid -- Wide_Wide_Character codes. diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index fbbb417f649..74eff664618 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -100,10 +100,27 @@ ada-warn = $(ADA_CFLAGS) $(filter-out -pedantic, $(STRICT_WARN)) # Unresolved warnings in specific files. ada/adaint.o-warn = -Wno-error +ada/%.o: ada/gcc-interface/%.c + $(COMPILE) $< + $(POSTCOMPILE) + +# Function that dumps the dependencies of an Ada object file by parsing the +# associated ALI file. We match the lines starting with D to achieve that. +ADA_DEPS=case $@ in \ + *sdefault.o);; \ + *)a="`echo $@ | sed -e 's/.o$$/.ali/'`"; \ + echo "$@: `cat $$a | \ + sed -ne "s;^D \([a-z0-9_\.-]*\).*;ada/\1;gp" | \ + tr -d '\015' | tr '\n' ' '`" > $(dir $@)/$(DEPDIR)/$(patsubst %.o,%.Po,$(notdir $@));; \ + esac; + .adb.o: $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + @$(ADA_DEPS) + .ads.o: $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + @$(ADA_DEPS) # Define the names for selecting Ada in LANGUAGES. ada: gnat1$(exeext) gnatbind$(exeext) @@ -354,11 +371,14 @@ GNAT_ADA_OBJS = \ ada/s-traent.o \ ada/s-unstyp.o \ ada/s-utf_32.o \ + ada/s-valint.o \ + ada/s-valuns.o \ + ada/s-valuti.o \ ada/s-wchcnv.o \ ada/s-wchcon.o \ ada/s-wchjis.o \ ada/scans.o \ - ada/scil_ll.o \ + ada/scil_ll.o \ ada/scn.o \ ada/scng.o \ ada/scos.o \ @@ -905,9 +925,6 @@ $(check_acats_targets): check-acats%: # Compiling object files from source files. -# Note that dependencies on obstack.h are not written -# because that file is not part of GCC. - # Ada language specific files. ada/b_gnat1.adb : $(GNAT1_ADA_OBJS) @@ -946,27 +963,29 @@ ada/sdefault.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/s-wchcon.ads ada/system.ads ada/table.adb ada/table.ads ada/tree_io.ads \ ada/types.ads ada/unchdeal.ads ada/unchconv.ads -ADA_TREE_H = ada/gcc-interface/ada-tree.h - -# Special flags - see gcc-interface/Makefile.in for the template +# Special flags - see gcc-interface/Makefile.in for the template. ada/a-except.o : ada/a-except.adb ada/a-except.ads $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \ $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + @$(ADA_DEPS) ada/s-excdeb.o : ada/s-excdeb.adb ada/s-excdeb.ads $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + @$(ADA_DEPS) ada/s-assert.o : ada/s-assert.adb ada/s-assert.ads $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ $< $(OUTPUT_OPTION) + @$(ADA_DEPS) ada/a-tags.o : ada/a-tags.adb ada/a-tags.ads $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ $< $(OUTPUT_OPTION) + @$(ADA_DEPS) -# dependencies for windows specific tool (mdll) +# Dependencies for windows specific tool (mdll) ada/mdll.o : ada/mdll.adb ada/mdll.ads ada/mdll-fil.ads ada/mdll-utl.ads $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) @@ -977,3539 +996,17 @@ ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads ada/mdll-utl.o : ada/mdll-utl.adb ada/mdll.ads ada/mdll-utl.ads ada/sdefault.ads ada/types.ads $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) -ada/adadecode.o : ada/adadecode.c $(CONFIG_H) $(SYSTEM_H) ada/adadecode.h ada/adaint.h -ada/adaint.o : ada/adaint.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h version.h -ada/argv.o : ada/argv.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h -ada/cio.o : ada/cio.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h -ada/cstreams.o : ada/cstreams.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h -ada/env.o: ada/env.c $(CONFIG_H) $(SYSTEM_H) ada/env.h -ada/exit.o : ada/exit.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h -ada/final.o : ada/final.c -ada/init.o : ada/init.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h ada/raise.h -ada/initialize.o : ada/initialize.c $(CONFIG_H) $(SYSTEM_H) ada/raise.h -ada/link.o : ada/link.c auto-host.h -ada/raise.o : ada/raise.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h ada/raise.h -ada/seh_init.o: ada/seh_init.c $(CONFIG_H) $(SYSTEM_H) ada/raise.h -ada/targext.o : ada/targext.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) - -ada/cuintp.o : ada/gcc-interface/cuintp.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ - $(TM_H) $(TREE_H) ada/gcc-interface/ada.h ada/types.h ada/uintp.h \ - ada/atree.h ada/elists.h ada/nlists.h ada/stringt.h ada/fe.h $(ADA_TREE_H) \ - ada/gcc-interface/gigi.h - $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ - -ada/decl.o : ada/gcc-interface/decl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ - $(TM_H) $(TREE_H) $(FLAGS_H) toplev.h $(TARGET_H) $(TREE_INLINE_H) \ - $(DIAGNOSTIC_CORE_H) ada/gcc-interface/ada.h ada/types.h ada/atree.h \ - ada/elists.h ada/namet.h ada/nlists.h ada/repinfo.h ada/snames.h \ - ada/stringt.h ada/uintp.h ada/fe.h ada/sinfo.h ada/einfo.h $(ADA_TREE_H) \ - ada/gcc-interface/gigi.h gt-ada-decl.h - $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ - -ada/misc.o : ada/gcc-interface/misc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ - $(TM_H) $(TREE_H) $(DIAGNOSTIC_H) $(TARGET_H) $(FUNCTION_H) \ - $(FLAGS_H) debug.h toplev.h langhooks.h \ - $(LANGHOOKS_DEF_H) $(OPTS_H) $(OPTIONS_H) $(TREE_INLINE_H) \ - ada/gcc-interface/ada.h ada/adadecode.h ada/types.h ada/atree.h \ - ada/elists.h ada/namet.h ada/nlists.h ada/stringt.h ada/uintp.h ada/fe.h \ - ada/sinfo.h ada/einfo.h $(ADA_TREE_H) ada/gcc-interface/gigi.h \ - gt-ada-misc.h - $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ - -ada/targtyps.o : ada/gcc-interface/targtyps.c $(CONFIG_H) $(SYSTEM_H) \ - coretypes.h $(TM_H) $(TM_P_H) $(TREE_H) ada/gcc-interface/ada.h \ - ada/types.h ada/atree.h ada/elists.h ada/namet.h ada/nlists.h \ - ada/snames.h ada/stringt.h ada/uintp.h ada/urealp.h ada/fe.h ada/sinfo.h \ - ada/einfo.h $(ADA_TREE_H) ada/gcc-interface/gigi.h - $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ - -ada/trans.o : ada/gcc-interface/trans.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ - $(TM_H) $(TREE_H) $(FLAGS_H) output.h tree-iterator.h $(GIMPLE_H) \ - $(BITMAP_H) $(CGRAPH_H) $(DIAGNOSTIC_H) $(OPTS_H) $(TARGET_H) \ - ada/gcc-interface/ada.h ada/adadecode.h ada/types.h ada/atree.h \ - ada/elists.h ada/namet.h ada/nlists.h ada/snames.h ada/stringt.h \ - ada/uintp.h ada/urealp.h ada/fe.h ada/sinfo.h ada/einfo.h \ - ada/gcc-interface/gadaint.h $(ADA_TREE_H) ada/gcc-interface/gigi.h \ - gt-ada-trans.h - $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ - -ada/utils.o : ada/gcc-interface/utils.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ - $(TM_H) $(TREE_H) $(FLAGS_H) toplev.h $(RTL_H) output.h debug.h convert.h \ - $(TARGET_H) $(COMMON_TARGET_H) function.h langhooks.h \ - $(CGRAPH_H) $(DIAGNOSTIC_H) $(TIMEVAR_H) \ - $(TREE_DUMP_H) $(TREE_INLINE_H) tree-iterator.h \ - ada/gcc-interface/ada.h ada/types.h ada/atree.h ada/elists.h ada/namet.h \ - ada/nlists.h ada/stringt.h ada/uintp.h ada/fe.h ada/sinfo.h ada/einfo.h \ - $(ADA_TREE_H) ada/gcc-interface/gigi.h gt-ada-utils.h gtype-ada.h - $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ - -ada/utils2.o : ada/gcc-interface/utils2.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ - $(TM_H) $(TREE_H) $(FLAGS_H) toplev.h $(TREE_INLINE_H) \ - ada/gcc-interface/ada.h ada/types.h ada/atree.h ada/elists.h ada/namet.h \ - ada/nlists.h ada/snames.h ada/stringt.h ada/uintp.h ada/fe.h ada/sinfo.h \ - ada/einfo.h $(ADA_TREE_H) ada/gcc-interface/gigi.h - $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ - -# -# DO NOT PUT SPECIAL RULES BELOW, THIS SECTION IS UPDATED AUTOMATICALLY -# -# GNAT DEPENDENCIES -# regular dependencies -ada/a-charac.o : ada/ada.ads ada/a-charac.ads ada/system.ads - -ada/a-chlat1.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ - ada/system.ads - -ada/a-clrefi.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ - ada/a-clrefi.adb ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads - -ada/a-comlin.o : ada/ada.ads ada/a-comlin.ads ada/a-comlin.adb \ - ada/a-unccon.ads ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \ - ada/s-stoele.adb - -ada/a-elchha.o : ada/ada.ads ada/a-except.ads ada/a-elchha.ads \ - ada/a-elchha.adb ada/a-unccon.ads ada/system.ads ada/s-parame.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-traent.ads - -ada/a-except.o : ada/ada.ads ada/a-except.ads ada/a-except.adb \ - ada/a-exexda.adb ada/a-exextr.adb ada/a-elchha.ads ada/a-excpol.adb \ - ada/a-exstat.adb ada/a-unccon.ads ada/system.ads ada/s-exctab.ads \ - ada/s-excdeb.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-traent.ads - -ada/a-ioexce.o : ada/ada.ads ada/a-except.ads ada/a-ioexce.ads \ - ada/a-unccon.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads - -ada/ada.o : ada/ada.ads ada/system.ads - -ada/ali-util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/ali.ads ada/ali.adb ada/ali-util.ads \ - ada/ali-util.adb ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/binderr.ads ada/butil.ads ada/casing.ads \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ - ada/fname-uf.ads ada/gnat.ads ada/g-byorma.ads ada/g-htable.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/opt.ads ada/osint.ads \ - ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ - ada/scans.ads ada/scng.ads ada/scng.adb ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/sinput-c.ads ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-utf_32.adb ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads - -ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/ali.ads ada/ali.adb ada/alloc.ads ada/butil.ads ada/casing.ads \ - ada/debug.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/widechar.ads - -ada/alloc.o : ada/alloc.ads ada/system.ads - -ada/aspects.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/aspects.adb \ - ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-strhas.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/atree.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - -ada/back_end.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/back_end.ads ada/back_end.adb ada/casing.ads \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ - ada/gnat.ads ada/g-byorma.ads ada/g-hesorg.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/opt.ads ada/osint.ads ada/osint-c.ads ada/output.ads ada/scans.ads \ - ada/sinfo.ads ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/switch.ads ada/switch-c.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/bcheck.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/ali.ads ada/ali.adb ada/ali-util.ads \ - ada/ali-util.adb ada/alloc.ads ada/atree.ads ada/bcheck.ads \ - ada/bcheck.adb ada/binderr.ads ada/butil.ads ada/casing.ads \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads \ - ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ - ada/opt.ads ada/osint.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/scans.ads ada/scng.ads ada/scng.adb ada/sinfo.ads \ - ada/sinput.ads ada/sinput-c.ads ada/snames.ads ada/stringt.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/binde.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/ali.ads ada/ali.adb ada/alloc.ads ada/binde.ads \ - ada/binde.adb ada/binderr.ads ada/butil.ads ada/casing.ads \ - ada/debug.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ - ada/system.ads ada/s-assert.ads ada/s-casuti.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads - -ada/binderr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/binderr.ads ada/binderr.adb \ - ada/butil.ads ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ - ada/output.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads - -ada/bindgen.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/ali.ads ada/ali.adb ada/alloc.ads ada/binde.ads \ - ada/binde.adb ada/binderr.ads ada/bindgen.ads ada/bindgen.adb \ - ada/butil.ads ada/casing.ads ada/debug.ads ada/fname.ads ada/gnat.ads \ - ada/g-hesora.ads ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/osint-b.ads ada/output.ads \ - ada/rident.ads ada/system.ads ada/s-assert.ads ada/s-casuti.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads - -ada/bindusg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/bindusg.ads ada/bindusg.adb \ - ada/debug.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \ - ada/opt.ads ada/osint.ads ada/output.ads ada/switch.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads - -ada/butil.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/butil.ads ada/butil.adb \ - ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/rident.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads - -ada/casing.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/casing.adb \ - ada/csets.ads ada/csets.adb ada/debug.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/output.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/widechar.ads - -ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/expander.ads ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads ada/warnsw.ads ada/widechar.ads - -ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/comperr.ads ada/comperr.adb \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/fname.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/opt.ads ada/osint.ads ada/output.ads ada/output.adb \ - ada/rident.ads ada/sdefault.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_io.ads ada/treepr.ads \ - ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/csets.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/csets.ads \ - ada/csets.adb ada/hostparm.ads ada/opt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-stalib.ads ada/s-string.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads - -ada/cstand.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads \ - ada/cstand.ads ada/cstand.adb ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_ch11.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ - ada/layout.ads ada/lib.ads ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads - -ada/debug.o : ada/debug.ads ada/debug.adb ada/system.ads - -ada/debug_a.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/debug_a.ads \ - ada/debug_a.adb ada/einfo.ads ada/hostparm.ads ada/namet.ads \ - ada/nlists.ads ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinput.ads \ - ada/snames.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - -ada/einfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/snames.adb \ - ada/stand.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb - -ada/elists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/elists.ads \ - ada/elists.adb ada/hostparm.ads ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - -ada/err_vars.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/err_vars.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads - -ada/errout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/errout.adb \ - ada/erroutc.ads ada/erroutc.adb ada/fname.ads ada/gnat.ads \ - ada/g-byorma.ads ada/g-hesorg.ads ada/gnatvsn.ads ada/hostparm.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/rident.ads \ - ada/scans.ads ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/erroutc.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ - ada/err_vars.ads ada/erroutc.ads ada/erroutc.adb ada/gnat.ads \ - ada/g-byorma.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/opt.ads ada/output.ads ada/output.adb \ - ada/rident.ads ada/scans.ads ada/sinfo.ads ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - -ada/eval_fat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/einfo.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/eval_fat.adb ada/exp_tss.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/sem_util.ads ada/snames.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb - -ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_aggr.ads ada/exp_aggr.adb ada/exp_ch11.ads \ - ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ - ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/warnsw.ads ada/widechar.ads - -ada/exp_atag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_atag.ads ada/exp_atag.adb \ - ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/lib.ads ada/lib-load.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/rtsfind.adb ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb \ - ada/sem_ch7.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_aggr.ads ada/exp_atag.ads ada/exp_attr.ads ada/exp_attr.adb \ - ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_imgv.ads ada/exp_pakd.ads ada/exp_strm.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads ada/expander.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch11.ads \ - ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-carun8.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/exp_cg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/exp_cg.ads ada/exp_cg.adb \ - ada/exp_dbug.ads ada/exp_disp.ads ada/exp_tss.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/opt.ads ada/output.ads \ - ada/sem_aux.ads ada/sem_aux.adb ada/sem_disp.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/widechar.ads - -ada/exp_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/casing.adb ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_ch11.ads ada/exp_ch11.adb ada/exp_ch7.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/expander.ads ada/fname.ads ada/fname-uf.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/lib.ads ada/lib-load.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \ - ada/sem_prag.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/warnsw.ads ada/widechar.ads - -ada/exp_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/exp_ch12.ads ada/exp_ch12.adb \ - ada/exp_tss.ads ada/exp_util.ads ada/hostparm.ads ada/lib.ads \ - ada/namet.ads ada/nlists.ads ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - -ada/exp_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_ch13.ads ada/exp_ch13.adb ada/exp_ch3.ads \ - ada/exp_ch6.ads ada/exp_imgv.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/fname.ads ada/fname-uf.ads ada/hostparm.ads ada/lib.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/types.ads \ - ada/uintp.ads ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads - -ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/exp_ch2.ads \ - ada/exp_ch2.adb ada/exp_smem.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/rtsfind.ads ada/sem.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_aggr.ads ada/exp_atag.ads ada/exp_cg.ads \ - ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch3.adb \ - ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads \ - ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb ada/exp_dist.ads \ - ada/exp_pakd.ads ada/exp_smem.ads ada/exp_strm.ads ada/exp_tss.ads \ - ada/exp_tss.adb ada/exp_util.ads ada/exp_util.adb ada/expander.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads \ - ada/lib-load.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/rtsfind.adb ada/scil_ll.ads ada/sem.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch3.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_mech.ads \ - ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/warnsw.ads \ - ada/widechar.ads - -ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads \ - ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch4.adb \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads \ - ada/exp_fixd.ads ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads ada/expander.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/par_sco.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scil_ll.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads ada/warnsw.ads ada/widechar.ads - -ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ - ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_dbug.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ - ada/lib.ads ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \ - ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/put_spark_xrefs.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/warnsw.ads - -ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_cg.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads \ - ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch6.adb ada/exp_ch7.ads \ - ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb \ - ada/exp_dist.ads ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads ada/expander.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ - ada/scil_ll.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch10.ads ada/sem_ch11.ads \ - ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_dim.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_prag.ads \ - ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/exp_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_ch7.adb ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch10.ads \ - ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads \ - ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/warnsw.ads \ - ada/widechar.ads - -ada/exp_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_aggr.ads ada/exp_ch4.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_ch8.ads ada/exp_ch8.adb ada/exp_dbug.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/freeze.ads \ - ada/get_targ.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ - ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/warnsw.ads - -ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads \ - ada/exp_ch11.ads ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_ch9.ads ada/exp_ch9.adb ada/exp_dbug.ads ada/exp_disp.ads \ - ada/exp_sel.ads ada/exp_smem.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/layout.ads ada/lib.ads ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb \ - ada/output.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ - ada/sem_ch11.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch5.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_ch9.adb \ - ada/sem_disp.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/exp_code.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/eval_fat.ads ada/exp_ch11.ads ada/exp_code.ads \ - ada/exp_code.adb ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-util.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/put_spark_xrefs.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-carun8.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/exp_dbug.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/exp_dbug.ads ada/exp_dbug.adb ada/exp_tss.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/rident.ads ada/sem_aux.ads \ - ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads - -ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads \ - ada/exp_atag.ads ada/exp_cg.ads ada/exp_ch11.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb \ - ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads ada/exp_util.adb \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/itypes.ads ada/layout.ads \ - ada/lib.ads ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scil_ll.ads \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-carun8.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/exp_atag.ads \ - ada/exp_disp.ads ada/exp_dist.ads ada/exp_dist.adb ada/exp_strm.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \ - ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch12.ads ada/sem_ch3.ads \ - ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_util.ads \ - ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/warnsw.ads ada/widechar.ads - -ada/exp_fixd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/eval_fat.ads ada/exp_fixd.ads ada/exp_fixd.adb \ - ada/exp_tss.ads ada/exp_util.ads ada/freeze.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \ - ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb - -ada/exp_imgv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_dist.ads ada/exp_imgv.ads \ - ada/exp_imgv.adb ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/rtsfind.adb ada/sem.ads ada/sem_aux.ads ada/sem_ch7.ads \ - ada/sem_dist.ads ada/sem_res.ads ada/sem_util.ads ada/set_targ.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads - -ada/exp_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads \ - ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch4.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_code.ads ada/exp_disp.ads ada/exp_fixd.ads \ - ada/exp_intr.ads ada/exp_intr.adb ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-byorma.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/exp_pakd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_pakd.ads \ - ada/exp_pakd.adb ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/expander.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ - ada/layout.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \ - ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \ - ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/validsw.ads ada/warnsw.ads - -ada/exp_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/casing.adb ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_ch11.ads ada/exp_prag.ads ada/exp_prag.adb \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/gnat.ads ada/g-byorma.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \ - ada/sem_ch8.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/snames.adb ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/exp_sel.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/exp_sel.ads \ - ada/exp_sel.adb ada/hostparm.ads ada/lib.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - -ada/exp_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/exp_ch9.ads ada/exp_smem.ads ada/exp_smem.adb ada/exp_tss.ads \ - ada/exp_util.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/exp_spark.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/exp_attr.ads ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_dbug.ads \ - ada/exp_spark.ads ada/exp_spark.adb ada/exp_tss.ads ada/exp_util.ads \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ - ada/output.ads ada/rtsfind.ads ada/sem_aux.ads ada/sem_aux.adb \ - ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tbuild.ads ada/tree_io.ads ada/types.ads \ - ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/exp_strm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/exp_strm.ads ada/exp_strm.adb \ - ada/exp_tss.ads ada/exp_util.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/sem_aux.ads ada/sem_util.ads ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/exp_tss.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_tss.ads ada/exp_tss.adb \ - ada/exp_util.ads ada/fname.ads ada/fname-uf.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/sem_aux.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/exp_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/casing.adb ada/checks.ads \ - ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \ - ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_ch9.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_prag.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \ - ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/system.ads ada/s-assert.ads ada/s-carun8.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads ada/warnsw.ads ada/widechar.ads - -ada/exp_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/eval_fat.ads ada/exp_vfpt.ads ada/exp_vfpt.adb ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/rtsfind.ads ada/sem_res.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb - -ada/expander.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/debug_a.ads \ - ada/debug_a.adb ada/einfo.ads ada/elists.ads ada/exp_aggr.ads \ - ada/exp_attr.ads ada/exp_ch11.ads ada/exp_ch12.ads ada/exp_ch13.ads \ - ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch5.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch8.ads ada/exp_ch9.ads \ - ada/exp_prag.ads ada/exp_spark.ads ada/exp_tss.ads ada/expander.ads \ - ada/expander.adb ada/fname.ads ada/hostparm.ads ada/inline.ads \ - ada/lib.ads ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \ - ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/warnsw.ads - -ada/fmap.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/fmap.adb \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \ - ada/opt.ads ada/osint.ads ada/output.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - -ada/fname-uf.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ - ada/fmap.ads ada/fname.ads ada/fname-uf.ads ada/fname-uf.adb \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/krunch.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-htable.adb ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/types.ads ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/widechar.ads - -ada/fname.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fname.ads \ - ada/fname.adb ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - -ada/freeze.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch3.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/freeze.adb ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/namet-sp.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/put_spark_xrefs.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \ - ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \ - ada/sem_dim.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_mech.ads \ - ada/sem_prag.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/set_targ.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/frontend.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads \ - ada/cstand.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_dbug.ads \ - ada/fmap.ads ada/fname.ads ada/fname-uf.ads ada/frontend.ads \ - ada/frontend.adb ada/gnat.ads ada/g-dyntab.ads ada/g-dyntab.adb \ - ada/g-hesorg.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/live.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/osint.ads ada/output.ads \ - ada/par.ads ada/prep.ads ada/prepcomp.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scil_ll.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aux.ads ada/sem_ch8.ads ada/sem_elab.ads ada/sem_prag.ads \ - ada/sem_scil.ads ada/sem_vfpt.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput-l.ads ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/warnsw.ads \ - ada/widechar.ads - -ada/g-byorma.o : ada/gnat.ads ada/g-byorma.ads ada/g-byorma.adb \ - ada/system.ads - -ada/g-hesora.o : ada/gnat.ads ada/g-hesora.ads ada/g-hesora.adb \ - ada/system.ads - -ada/g-htable.o : ada/gnat.ads ada/g-htable.ads ada/g-htable.adb \ - ada/system.ads ada/s-htable.ads - -ada/g-spchge.o : ada/gnat.ads ada/g-spchge.ads ada/g-spchge.adb \ - ada/system.ads - -ada/g-speche.o : ada/gnat.ads ada/g-speche.ads ada/g-speche.adb \ - ada/g-spchge.ads ada/g-spchge.adb ada/system.ads - -ada/g-u3spch.o : ada/gnat.ads ada/g-spchge.ads ada/g-spchge.adb \ - ada/g-u3spch.ads ada/g-u3spch.adb ada/system.ads ada/s-wchcnv.ads \ - ada/s-wchcon.ads - -ada/get_spark_xrefs.o : ada/ada.ads ada/a-ioexce.ads ada/a-unccon.ads \ - ada/get_spark_xrefs.ads ada/get_spark_xrefs.adb ada/gnat.ads \ - ada/g-hesorg.ads ada/g-table.ads ada/g-table.adb ada/spark_xrefs.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - -ada/get_targ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/einfo.ads \ - ada/get_targ.ads ada/get_targ.adb ada/hostparm.ads ada/namet.ads \ - ada/opt.ads ada/output.ads ada/snames.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - -ada/gnat.o : ada/gnat.ads ada/system.ads - -ada/gnat1drv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/back_end.ads ada/casing.ads ada/comperr.ads \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_cg.ads \ - ada/exp_ch6.ads ada/fmap.ads ada/fname.ads ada/fname-uf.ads \ - ada/frontend.ads ada/get_targ.ads ada/gnat.ads ada/g-byorma.ads \ - ada/g-hesorg.ads ada/g-table.ads ada/g-table.adb ada/gnat1drv.ads \ - ada/gnat1drv.adb ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-util.ads ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads \ - ada/nlists.ads ada/opt.ads ada/osint.ads ada/output.ads ada/par_sco.ads \ - ada/prepcomp.ads ada/put_spark_xrefs.ads ada/repinfo.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scos.ads ada/sem.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch8.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_type.ads \ - ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/sinput-l.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_gen.ads ada/tree_io.ads ada/treepr.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/usage.ads ada/validsw.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/gnatbind.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ - ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/ali.ads \ - ada/ali.adb ada/ali-util.ads ada/alloc.ads ada/bcheck.ads ada/binde.ads \ - ada/binde.adb ada/binderr.ads ada/bindgen.ads ada/bindusg.ads \ - ada/butil.ads ada/casing.ads ada/csets.ads ada/debug.ads ada/fmap.ads \ - ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/gnatbind.ads \ - ada/gnatbind.adb ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \ - ada/opt.ads ada/osint.ads ada/osint-b.ads ada/output.ads ada/rident.ads \ - ada/snames.ads ada/switch.ads ada/switch.adb ada/switch-b.ads \ - ada/system.ads ada/s-assert.ads ada/s-casuti.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - -ada/gnatvsn.o : ada/ada.ads ada/a-unccon.ads ada/gnatvsn.ads \ - ada/gnatvsn.adb ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \ - ada/s-stoele.adb - -ada/hostparm.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ - ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - -ada/impunit.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ - ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/hostparm.ads \ - ada/impunit.ads ada/impunit.adb ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ - ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/widechar.ads - -ada/inline.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_ch7.ads ada/exp_tss.ads \ - ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/hostparm.ads ada/inline.ads ada/inline.adb ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/sem.ads ada/sem_aux.ads \ - ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch8.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/interfac.o : ada/interfac.ads ada/system.ads - -ada/itypes.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/exp_tss.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/itypes.ads ada/itypes.adb ada/namet.ads ada/nlists.ads ada/opt.ads \ - ada/output.ads ada/rident.ads ada/sem.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/krunch.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ - ada/krunch.ads ada/krunch.adb ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads - -ada/layout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_ch3.ads \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/layout.ads ada/layout.adb ada/lib.ads \ - ada/lib-util.ads ada/lib-xref.ads ada/namet.ads ada/namet-sp.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/put_spark_xrefs.ads ada/repinfo.ads ada/repinfo.adb \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch13.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/set_targ.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - -ada/lib-load.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/fname.ads ada/fname-uf.ads ada/gnat.ads \ - ada/g-byorma.ads ada/g-hesorg.ads ada/hostparm.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-load.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads ada/osint-c.ads \ - ada/output.ads ada/par.ads ada/restrict.ads ada/rident.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem_aux.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/sinput-l.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/lib-util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/lib.ads ada/lib-util.ads ada/lib-util.adb ada/namet.ads ada/opt.ads \ - ada/osint.ads ada/osint-c.ads ada/output.ads ada/stringt.ads \ - ada/stringt.adb ada/system.ads ada/s-assert.ads ada/s-carun8.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads - -ada/lib-writ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/ali.ads ada/ali.adb ada/alloc.ads ada/aspects.ads \ - ada/atree.ads ada/atree.adb ada/butil.ads ada/casing.ads ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ - ada/fname-uf.ads ada/gnat.ads ada/g-byorma.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-util.ads ada/lib-util.adb ada/lib-writ.ads ada/lib-writ.adb \ - ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/opt.ads ada/osint.ads ada/osint-c.ads ada/output.ads \ - ada/par.ads ada/par_sco.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-casuti.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/lib-xref.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-byorma.ads \ - ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads ada/g-table.ads \ - ada/g-table.adb ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-util.adb ada/lib-xref.ads ada/lib-xref.adb \ - ada/lib-xref-spark_specific.adb ada/namet.ads ada/namet.adb \ - ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/osint.ads ada/osint-c.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/put_spark_xrefs.adb ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/spark_xrefs.ads ada/spark_xrefs.adb \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/lib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/alloc.ads ada/aspects.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/fname.ads ada/gnat.ads ada/g-byorma.ads ada/g-hesorg.ads \ - ada/g-hesorg.adb ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ - ada/scans.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/live.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/exp_tss.ads ada/fname.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/live.ads ada/live.adb \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ - ada/sem_aux.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/namet-sp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ - ada/g-u3spch.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/namet-sp.ads ada/namet-sp.adb ada/opt.ads \ - ada/output.ads ada/system.ads ada/s-assert.ads ada/s-carun8.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcnv.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/types.adb ada/unchconv.ads ada/unchdeal.ads \ - ada/widechar.ads - -ada/namet.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-assert.ads ada/s-carun8.ads ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads - -ada/nlists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/nmake.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/debug.ads \ - ada/einfo.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/sinfo.ads \ - ada/sinfo.adb ada/snames.ads ada/stand.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - -ada/opt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/opt.adb ada/system.ads \ - ada/s-exctab.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - -ada/osint-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/osint-b.ads ada/osint-b.adb \ - ada/output.ads ada/rident.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads - -ada/osint-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads \ - ada/osint-c.ads ada/osint-c.adb ada/output.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/widechar.ads - -ada/osint.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/gnat.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \ - ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads ada/osint.adb \ - ada/output.ads ada/rident.ads ada/sdefault.ads ada/system.ads \ - ada/s-assert.ads ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-htable.adb ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads - -ada/output.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/hostparm.ads ada/output.ads ada/output.adb \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads - -ada/par.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/alloc.ads ada/aspects.ads ada/aspects.adb ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/errout.adb ada/erroutc.ads ada/exp_ch11.ads \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-byorma.ads ada/g-hesorg.ads ada/g-htable.ads ada/g-speche.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ - ada/lib-util.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/osint.ads ada/output.ads ada/par.ads \ - ada/par.adb ada/par-ch10.adb ada/par-ch11.adb ada/par-ch12.adb \ - ada/par-ch13.adb ada/par-ch2.adb ada/par-ch3.adb ada/par-ch4.adb \ - ada/par-ch5.adb ada/par-ch6.adb ada/par-ch7.adb ada/par-ch8.adb \ - ada/par-ch9.adb ada/par-endh.adb ada/par-labl.adb ada/par-load.adb \ - ada/par-prag.adb ada/par-sync.adb ada/par-tchk.adb ada/par-util.adb \ - ada/par_sco.ads ada/put_spark_xrefs.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scans.adb ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/set_targ.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ - ada/sinput.adb ada/sinput-l.ads ada/snames.ads ada/snames.adb \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/style.adb ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/warnsw.ads \ - ada/widechar.ads - -ada/par_sco.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/aspects.adb \ - ada/atree.ads ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_tss.ads ada/fname.ads ada/gnat.ads ada/g-byorma.ads \ - ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads ada/g-table.ads \ - ada/g-table.adb ada/hostparm.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-util.ads ada/lib-util.adb \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads \ - ada/osint-c.ads ada/output.ads ada/par_sco.ads ada/par_sco.adb \ - ada/put_scos.ads ada/put_scos.adb ada/scans.ads ada/scos.ads \ - ada/scos.adb ada/sem.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/prep.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \ - ada/debug.ads ada/err_vars.ads ada/gnat.ads ada/g-dyntab.ads \ - ada/g-dyntab.adb ada/g-hesorg.ads ada/g-hesorg.adb ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \ - ada/prep.adb ada/scans.ads ada/sinput.ads ada/snames.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-assert.ads \ - ada/s-carun8.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/prepcomp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/gnat.ads ada/g-dyntab.ads \ - ada/g-dyntab.adb ada/g-hesorg.ads ada/hostparm.ads ada/interfac.ads \ - ada/lib.ads ada/lib-writ.ads ada/namet.ads ada/opt.ads ada/osint.ads \ - ada/output.ads ada/prep.ads ada/prep.adb ada/prepcomp.ads \ - ada/prepcomp.adb ada/restrict.ads ada/rident.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sinfo.ads ada/sinput.ads \ - ada/sinput-l.ads ada/snames.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/put_scos.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-table.ads ada/g-table.adb ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/output.ads ada/put_scos.ads \ - ada/put_scos.adb ada/scos.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - -ada/put_spark_xrefs.o : ada/ada.ads ada/a-unccon.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-table.ads ada/g-table.adb \ - ada/put_spark_xrefs.ads ada/put_spark_xrefs.adb ada/spark_xrefs.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - -ada/repinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/fname.ads ada/gnat.ads ada/g-byorma.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/opt.ads ada/output.ads ada/output.adb \ - ada/repinfo.ads ada/repinfo.adb ada/scans.ads ada/sem_aux.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/restrict.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/aspects.adb \ - ada/atree.ads ada/atree.adb ada/casing.ads ada/casing.adb ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/fname.ads ada/fname-uf.ads \ - ada/gnat.ads ada/g-byorma.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/scans.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/rident.o : ada/rident.ads ada/system.ads ada/s-rident.ads - -ada/rtsfind.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_dist.ads ada/exp_tss.ads \ - ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/rtsfind.adb ada/sem.ads ada/sem_aux.ads ada/sem_ch7.ads \ - ada/sem_dist.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/s-addope.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-addope.ads ada/s-addope.adb - -ada/s-assert.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/system.ads ada/s-assert.ads ada/s-assert.adb ada/s-exctab.ads \ - ada/s-exctab.adb ada/s-excdeb.ads ada/s-htable.ads ada/s-parame.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-traent.ads - -ada/s-bitops.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/system.ads ada/s-bitops.ads ada/s-bitops.adb ada/s-parame.ads \ - ada/s-stalib.ads ada/s-traent.ads ada/s-unstyp.ads - -ada/s-carun8.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-addope.ads ada/s-addope.adb ada/s-carun8.ads ada/s-carun8.adb - -ada/s-casuti.o : ada/system.ads ada/s-casuti.ads ada/s-casuti.adb - -ada/s-conca2.o : ada/system.ads ada/s-conca2.ads ada/s-conca2.adb - -ada/s-conca3.o : ada/system.ads ada/s-conca2.ads ada/s-conca3.ads \ - ada/s-conca3.adb - -ada/s-conca4.o : ada/system.ads ada/s-conca3.ads ada/s-conca4.ads \ - ada/s-conca4.adb - -ada/s-conca5.o : ada/system.ads ada/s-conca4.ads ada/s-conca5.ads \ - ada/s-conca5.adb - -ada/s-conca6.o : ada/system.ads ada/s-conca5.ads ada/s-conca6.ads \ - ada/s-conca6.adb - -ada/s-conca7.o : ada/system.ads ada/s-conca6.ads ada/s-conca7.ads \ - ada/s-conca7.adb - -ada/s-conca8.o : ada/system.ads ada/s-conca7.ads ada/s-conca8.ads \ - ada/s-conca8.adb - -ada/s-conca9.o : ada/system.ads ada/s-conca8.ads ada/s-conca9.ads \ - ada/s-conca9.adb - -ada/s-crc32.o : ada/interfac.ads ada/system.ads ada/s-crc32.ads \ - ada/s-crc32.adb - -ada/s-crtl.o : ada/system.ads ada/s-crtl.ads ada/s-parame.ads - -ada/s-excdeb.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-excdeb.ads ada/s-excdeb.adb ada/s-stalib.ads - -ada/s-except.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-except.ads \ - ada/s-except.adb ada/s-htable.ads ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-traent.ads - -ada/s-exctab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-htable.adb ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strhas.ads ada/s-traent.ads - -ada/s-htable.o : ada/ada.ads ada/a-uncdea.ads ada/system.ads \ - ada/s-htable.ads ada/s-htable.adb ada/s-strhas.ads - -ada/s-imenne.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-imenne.adb \ - ada/s-stalib.ads - -ada/s-imgenu.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-imgenu.ads ada/s-imgenu.adb ada/s-secsta.ads ada/s-stoele.ads \ - ada/s-stoele.adb - -ada/s-mastop.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-mastop.ads ada/s-mastop.adb ada/s-stoele.ads ada/s-stoele.adb - -ada/s-memory.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/system.ads ada/s-crtl.ads ada/s-memory.ads ada/s-memory.adb \ - ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads - -ada/s-os_lib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/system.ads ada/s-casuti.ads ada/s-crtl.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-os_lib.ads \ - ada/s-os_lib.adb ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads - -ada/s-parame.o : ada/system.ads ada/s-parame.ads ada/s-parame.adb - -ada/s-purexc.o : ada/system.ads ada/s-purexc.ads - -ada/s-restri.o : ada/system.ads ada/s-restri.ads ada/s-restri.adb \ - ada/s-rident.ads - -ada/s-secsta.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/system.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-secsta.adb ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads - -ada/s-soflin.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/system.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-soflin.adb ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-traent.ads - -ada/s-sopco3.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-sopco3.ads \ - ada/s-sopco3.adb - -ada/s-sopco4.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-sopco4.ads \ - ada/s-sopco4.adb - -ada/s-sopco5.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-sopco5.ads \ - ada/s-sopco5.adb - -ada/s-stache.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-stache.ads ada/s-stache.adb ada/s-stoele.ads ada/s-stoele.adb - -ada/s-stalib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/system.ads ada/s-memory.ads ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stalib.adb ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-traent.ads - -ada/s-stoele.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-stoele.ads ada/s-stoele.adb - -ada/s-strcom.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-strcom.ads ada/s-strcom.adb - -ada/s-strhas.o : ada/system.ads ada/s-strhas.ads ada/s-strhas.adb - -ada/s-string.o : ada/ada.ads ada/a-uncdea.ads ada/system.ads \ - ada/s-string.ads ada/s-string.adb - -ada/s-strops.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ - ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \ - ada/s-strops.adb - -ada/s-traent.o : ada/system.ads ada/s-traent.ads ada/s-traent.adb - -ada/s-unstyp.o : ada/system.ads ada/s-unstyp.ads - -ada/s-utf_32.o : ada/system.ads ada/s-utf_32.ads ada/s-utf_32.adb - -ada/s-wchcnv.o : ada/interfac.ads ada/system.ads ada/s-wchcnv.ads \ - ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads - -ada/s-wchcon.o : ada/system.ads ada/s-wchcon.ads ada/s-wchcon.adb - -ada/s-wchjis.o : ada/system.ads ada/s-wchjis.ads ada/s-wchjis.adb - -ada/scans.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ - ada/scans.ads ada/scans.adb ada/snames.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - -ada/scil_ll.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ - ada/output.ads ada/scil_ll.ads ada/scil_ll.adb ada/sinfo.ads \ - ada/sinput.ads ada/snames.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - -ada/scn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/alloc.ads ada/aspects.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ - ada/fname-uf.ads ada/gnat.ads ada/g-byorma.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/scans.ads \ - ada/scn.ads ada/scn.adb ada/scng.ads ada/scng.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/style.adb ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-utf_32.adb ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads - -ada/scng.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/hostparm.ads \ - ada/interfac.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/scans.ads ada/scng.ads ada/scng.adb \ - ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stringt.ads \ - ada/styleg.ads ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/scos.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-hesorg.adb ada/g-table.ads ada/g-table.adb \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads ada/scos.ads \ - ada/scos.adb ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads - -ada/sem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/alloc.ads ada/aspects.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/debug_a.ads \ - ada/debug_a.adb ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/exp_tss.ads ada/expander.ads ada/fname.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/hostparm.ads ada/inline.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads ada/sem.ads \ - ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch10.ads \ - ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads \ - ada/sem_ch2.adb ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \ - ada/sem_dim.ads ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/warnsw.ads ada/widechar.ads - -ada/sem_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ - ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/expander.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/sem.ads ada/sem_aggr.ads ada/sem_aggr.adb \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_dim.ads \ - ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/warnsw.ads \ - ada/widechar.ads - -ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ - ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/alloc.ads \ - ada/aspects.ads ada/atree.ads ada/atree.adb ada/casing.ads \ - ada/checks.ads ada/checks.adb ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/expander.ads ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-byorma.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/namet-sp.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sdefault.ads ada/sem.ads ada/sem.adb ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_attr.adb ada/sem_aux.ads ada/sem_aux.adb \ - ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \ - ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_ch9.ads ada/sem_dim.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_res.adb \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-carun8.ads ada/s-exctab.ads \ - ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads ada/warnsw.ads ada/widechar.ads - -ada/sem_aux.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ - ada/output.ads ada/sem_aux.ads ada/sem_aux.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/sem_case.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_tss.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/sem.ads ada/sem_aux.ads ada/sem_case.ads \ - ada/sem_case.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/widechar.ads - -ada/sem_cat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/opt.ads ada/output.ads ada/put_spark_xrefs.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_cat.adb ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_ch11.ads ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-byorma.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/impunit.ads \ - ada/inline.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/namet-sp.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/opt.adb ada/output.ads ada/par_sco.ads ada/put_spark_xrefs.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_ch10.ads ada/sem_ch10.adb ada/sem_ch11.ads ada/sem_ch12.ads \ - ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_ch9.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ - ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/warnsw.ads ada/widechar.ads - -ada/sem_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_code.ads ada/exp_tss.ads ada/fname.ads ada/hostparm.ads \ - ada/lib.ads ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/par_sco.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \ - ada/sem_ch11.ads ada/sem_ch11.adb ada/sem_ch13.ads ada/sem_ch5.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads \ - ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - -ada/sem_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/aspects.adb \ - ada/atree.ads ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads \ - ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_ch11.ads ada/exp_ch7.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/inline.adb ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/rtsfind.adb ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \ - ada/sem_ch12.ads ada/sem_ch12.adb ada/sem_ch13.ads ada/sem_ch2.ads \ - ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_dim.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ - ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/set_targ.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ - ada/sinput-l.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/warnsw.ads ada/widechar.ads - -ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/aspects.adb \ - ada/atree.ads ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/rtsfind.adb ada/scans.ads ada/sem.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch13.adb ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_dim.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_prag.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/sem_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/sem_ch2.ads \ - ada/sem_ch2.adb ada/sem_ch8.ads ada/sem_dim.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-assert.ads ada/s-carun8.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch11.ads \ - ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/layout.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_case.ads \ - ada/sem_case.adb ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch10.ads \ - ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads \ - ada/sem_ch3.ads ada/sem_ch3.adb ada/sem_ch4.ads ada/sem_ch5.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \ - ada/sem_dim.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_mech.ads ada/sem_prag.ads \ - ada/sem_res.ads ada/sem_smem.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads ada/warnsw.ads ada/widechar.ads - -ada/sem_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \ - ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_case.ads \ - ada/sem_case.adb ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch4.adb ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_dim.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \ - ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_code.ads \ - ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/expander.ads ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/lib.ads ada/lib-load.ads ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb \ - ada/output.ads ada/par_sco.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sem.ads ada/sem.adb ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads \ - ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ - ada/sem_ch5.adb ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_ch9.ads ada/sem_dim.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_res.adb \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sem_warn.adb ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/warnsw.ads - -ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/expander.ads ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/namet-sp.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/opt.adb ada/output.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \ - ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch6.adb \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_dim.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/snames.ads ada/snames.adb ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-carun8.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ - ada/exp_dbug.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch7.adb \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/snames.adb ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/warnsw.ads \ - ada/widechar.ads - -ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/impunit.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb \ - ada/output.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ - ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \ - ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_ch8.adb ada/sem_ch9.ads ada/sem_dim.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ - ada/sem_eval.ads ada/sem_intr.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/warnsw.ads ada/widechar.ads - -ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/aspects.adb \ - ada/atree.ads ada/atree.adb ada/casing.ads ada/checks.ads \ - ada/checks.adb ada/csets.ads ada/debug.ads ada/debug_a.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_ch11.ads \ - ada/exp_ch2.ads ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_ch9.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/expander.ads ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ - ada/layout.ads ada/lib.ads ada/lib-load.ads ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb \ - ada/output.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sem.ads ada/sem.adb ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \ - ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_ch9.adb ada/sem_dim.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ - ada/sem_eval.ads ada/sem_intr.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/warnsw.ads - -ada/sem_dim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-byorma.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \ - ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/put_spark_xrefs.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ - ada/scans.ads ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dim.ads ada/sem_dim.adb \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/set_targ.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_atag.ads \ - ada/exp_cg.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads \ - ada/exp_util.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/interfac.ads ada/itypes.ads ada/layout.ads \ - ada/lib.ads ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scil_ll.ads \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_disp.adb ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/set_targ.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/widechar.ads - -ada/sem_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_dist.ads \ - ada/exp_tss.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_dist.adb ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/system.ads ada/s-assert.ads ada/s-carun8.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-byorma.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/namet-sp.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_elab.ads \ - ada/sem_elab.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_tss.ads ada/fname.ads ada/gnat.ads ada/g-byorma.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/scans.ads \ - ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_elim.ads \ - ada/sem_elim.adb ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/widechar.ads - -ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ - ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_dim.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads - -ada/sem_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_tss.ads ada/fname.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/opt.ads ada/output.ads ada/rident.ads \ - ada/sem_aux.ads ada/sem_aux.adb ada/sem_eval.ads ada/sem_intr.ads \ - ada/sem_intr.adb ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/sem_mech.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_tss.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/rident.ads \ - ada/sem.ads ada/sem_aux.ads ada/sem_mech.ads ada/sem_mech.adb \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/aspects.ads \ - ada/aspects.adb ada/atree.ads ada/atree.adb ada/casing.ads \ - ada/checks.ads ada/checks.adb ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_code.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-byorma.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-writ.ads ada/lib-writ.adb ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads ada/osint-c.ads \ - ada/output.ads ada/par.ads ada/par_sco.ads ada/put_spark_xrefs.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem.adb ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \ - ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch13.adb ada/sem_ch2.ads \ - ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_dim.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_mech.ads \ - ada/sem_prag.ads ada/sem_prag.adb ada/sem_res.ads ada/sem_res.adb \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_vfpt.ads \ - ada/sem_warn.ads ada/sem_warn.adb ada/set_targ.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/snames.adb ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-casuti.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/urealp.adb ada/validsw.ads ada/warnsw.ads ada/widechar.ads - -ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/csets.ads ada/debug.ads ada/debug_a.ads ada/debug_a.adb \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ - ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/expander.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb ada/output.ads \ - ada/put_spark_xrefs.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ - ada/sem.ads ada/sem.adb ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \ - ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_dim.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_intr.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/sem_scil.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/opt.ads ada/output.ads ada/rtsfind.ads ada/scil_ll.ads \ - ada/sem_aux.ads ada/sem_scil.ads ada/sem_scil.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/sem_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/hostparm.ads \ - ada/namet.ads ada/nlists.ads ada/opt.ads ada/output.ads ada/sem_aux.ads \ - ada/sem_smem.ads ada/sem_smem.adb ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/sem_type.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-util.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/opt.ads ada/output.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch12.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_type.adb ada/sem_util.ads \ - ada/sem_util.adb ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/treepr.ads ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/warnsw.ads ada/widechar.ads - -ada/sem_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch11.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-byorma.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-util.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/namet-sp.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/put_spark_xrefs.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ - ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \ - ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_ch9.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/set_targ.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/warnsw.ads \ - ada/widechar.ads - -ada/sem_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/cstand.ads \ - ada/debug.ads ada/einfo.ads ada/einfo.adb ada/hostparm.ads \ - ada/namet.ads ada/nlists.ads ada/opt.ads ada/output.ads ada/rident.ads \ - ada/sem_vfpt.ads ada/sem_vfpt.adb ada/sinfo.ads ada/snames.ads \ - ada/stand.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/sem_warn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_code.ads \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-byorma.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-util.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/opt.ads ada/output.ads ada/par_sco.ads ada/put_spark_xrefs.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sem_warn.adb ada/set_targ.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - -ada/set_targ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/einfo.ads \ - ada/get_targ.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ - ada/output.ads ada/set_targ.ads ada/set_targ.adb ada/snames.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/sinfo-cn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ - ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinfo-cn.adb ada/sinput.ads ada/snames.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/sinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/sinput-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/gnat.ads \ - ada/g-byorma.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/opt.ads ada/output.ads ada/scans.ads ada/sinfo.ads ada/sinput.ads \ - ada/sinput.adb ada/sinput-c.ads ada/sinput-c.adb ada/snames.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/sinput-d.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/gnat.ads \ - ada/g-byorma.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/opt.ads ada/osint.ads ada/osint-c.ads ada/output.ads ada/scans.ads \ - ada/sinfo.ads ada/sinput.ads ada/sinput.adb ada/sinput-d.ads \ - ada/sinput-d.adb ada/snames.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - -ada/sinput-l.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_tss.ads ada/fname.ads ada/gnat.ads ada/g-byorma.ads \ - ada/g-dyntab.ads ada/g-dyntab.adb ada/g-hesorg.ads ada/hostparm.ads \ - ada/interfac.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ - ada/osint.ads ada/output.ads ada/prep.ads ada/prepcomp.ads \ - ada/restrict.ads ada/rident.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem_aux.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/sinput-l.ads \ - ada/sinput-l.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-assert.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/sinput.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/gnat.ads \ - ada/g-byorma.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ - ada/scans.ads ada/sinfo.ads ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/snames.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/interfac.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \ - ada/snames.ads ada/snames.adb ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads - -ada/spark_xrefs.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/gnat.ads ada/g-hesorg.ads ada/g-hesorg.adb \ - ada/g-table.ads ada/g-table.adb ada/hostparm.ads ada/output.ads \ - ada/output.adb ada/put_spark_xrefs.ads ada/put_spark_xrefs.adb \ - ada/spark_xrefs.ads ada/spark_xrefs.adb ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - -ada/sprint.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/exp_tss.ads ada/fname.ads ada/gnat.ads \ - ada/g-byorma.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/output.adb \ - ada/rtsfind.ads ada/scans.ads ada/sem_eval.ads ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/sinput-d.ads ada/snames.ads ada/sprint.ads ada/sprint.adb \ - ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads - -ada/stand.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/stand.ads \ - ada/stand.adb ada/system.ads ada/s-exctab.ads ada/s-os_lib.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-unstyp.ads ada/tree_io.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - -ada/stringt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/output.ads ada/stringt.ads \ - ada/stringt.adb ada/system.ads ada/s-assert.ads ada/s-carun8.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/types.adb ada/unchconv.ads ada/unchdeal.ads - -ada/style.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/gnat.ads ada/g-byorma.ads ada/hostparm.ads ada/interfac.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/opt.ads ada/output.ads \ - ada/scans.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/style.ads ada/style.adb ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - -ada/styleg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/casing.ads \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads ada/scans.ads \ - ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads - -ada/stylesw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/hostparm.ads ada/opt.ads ada/stylesw.ads ada/stylesw.adb \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads - -ada/switch-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \ - ada/switch.ads ada/switch-b.ads ada/switch-b.adb ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads - -ada/switch-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/einfo.ads \ - ada/get_targ.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/set_targ.ads \ - ada/snames.ads ada/stylesw.ads ada/switch.ads ada/switch-c.ads \ - ada/switch-c.adb ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/warnsw.ads - -ada/switch.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \ - ada/switch.ads ada/switch.adb ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads - -ada/system.o : ada/system.ads - -ada/table.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/debug.ads \ - ada/hostparm.ads ada/opt.ads ada/output.ads ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads - -ada/targparm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/csets.ads ada/debug.ads \ - ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/namet.adb \ - ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/targparm.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/widechar.ads - -ada/tbuild.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/fname.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/sem_aux.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads - -ada/tree_gen.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/fname.ads \ - ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/opt.ads \ - ada/osint.ads ada/osint-c.ads ada/output.ads ada/repinfo.ads \ - ada/sem_aux.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_gen.ads ada/tree_gen.adb ada/tree_in.ads \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - -ada/tree_in.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ - ada/fname.ads ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ - ada/opt.ads ada/output.ads ada/repinfo.ads ada/sem_aux.ads \ - ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_in.ads ada/tree_in.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads - -ada/tree_io.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/debug.ads ada/hostparm.ads ada/output.ads \ - ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/tree_io.ads ada/tree_io.adb \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads - -ada/treepr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/einfo.adb ada/elists.ads ada/elists.adb ada/fname.ads ada/gnat.ads \ - ada/g-byorma.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/output.adb \ - ada/scans.ads ada/scil_ll.ads ada/sem_mech.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-assert.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/treepr.ads \ - ada/treepr.adb ada/treeprs.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - -ada/treeprs.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/output.ads ada/sinfo.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/treeprs.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/ttypes.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/einfo.ads \ - ada/get_targ.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \ - ada/output.ads ada/set_targ.ads ada/snames.ads ada/system.ads \ - ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads - -ada/types.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/system.ads \ - ada/s-assert.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads \ - ada/s-unstyp.ads ada/types.ads ada/types.adb ada/unchconv.ads \ - ada/unchdeal.ads - -ada/uintp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-htable.adb ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads - -ada/uname.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/fname.ads ada/gnat.ads ada/g-byorma.ads ada/g-hesorg.ads \ - ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/opt.ads ada/output.ads ada/scans.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uname.ads ada/uname.adb ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads - -ada/urealp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/urealp.adb - -ada/usage.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ - ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/usage.ads ada/usage.adb - -ada/validsw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/hostparm.ads ada/opt.ads ada/system.ads ada/s-exctab.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/validsw.ads \ - ada/validsw.adb +ada_generated_files = ada/sinfo.h ada/einfo.h ada/nmake.adb ada/nmake.ads \ + ada/treeprs.ads ada/snames.ads ada/snames.adb ada/snames.h -ada/warnsw.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/err_vars.ads \ - ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ - ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/warnsw.ads ada/warnsw.adb +# 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) -ada/widechar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/hostparm.ads ada/interfac.ads ada/opt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcnv.ads \ - ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads ada/widechar.adb +# Manually include the auto-generated dependencies for the Ada host objects. +ADA_DEPFILES = $(foreach obj,(GNAT1_ADA_OBJS) $(GNATBIND_OBJS),\ + $(dir $(obj))/$(DEPDIR)/$(patsubst %.o,%.Po,$(notdir $(obj)))) +-include $(ADA_DEPFILES) -# end of regular dependencies +# Automatically include the auto-generated dependencies for the C host objects. +ada_OBJS = $(GNAT1_C_OBJS) diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 4fd368283a9..91778c5fcf6 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -1,5 +1,5 @@ # Makefile for GNU Ada Compiler (GNAT). -# Copyright (C) 1994-2012 Free Software Foundation, Inc. +# Copyright (C) 1994-2013 Free Software Foundation, Inc. #This file is part of GCC. @@ -122,7 +122,7 @@ THREAD_KIND = native THREADSLIB = GMEM_LIB = MISCLIB = -OUTPUT_OPTION = @OUTPUT_OPTION@ +OUTPUT_OPTION = -o $@ objext = .o exeext = @@ -167,6 +167,13 @@ tmake_file = @tmake_file@ # Directory where sources are, from where we are. VPATH = $(srcdir)/ada +# Full path to top source directory +# In particular this is used to access libgcc headers, so that references to +# these headers from GNAT runtime objects have path names in debugging info +# that are consistent with libgcc objects. Also used for other references to +# the top source directory for consistency. +ftop_srcdir := $(shell cd $(srcdir)/..;${PWD_COMMAND}) + fsrcdir := $(shell cd $(srcdir);${PWD_COMMAND}) fsrcpfx := $(shell cd $(srcdir);${PWD_COMMAND})/ fcurdir := $(shell ${PWD_COMMAND}) @@ -262,7 +269,7 @@ TOOLS_LIBS = ../link.o ../targext.o ../../ggc-none.o ../../libcommon-target.a \ # Both . and srcdir are used, in that order, # so that tm.h and config.h will be found in the compilation # subdirectory rather than in the source directory. -INCLUDES = -I- -I. -I.. -I$(srcdir)/ada -I$(srcdir) -I$(srcdir)/../include $(GMPINC) +INCLUDES = -I- -I. -I.. -I$(srcdir)/ada -I$(srcdir) -I$(ftop_srcdir)/include $(GMPINC) ADA_INCLUDES = -I- -I. -I$(srcdir)/ada @@ -272,11 +279,11 @@ ADA_INCLUDES = -I- -I. -I$(srcdir)/ada ifneq ($(findstring vxworks,$(target_os)),) INCLUDES_FOR_SUBDIR = -iquote . -iquote .. -iquote ../.. \ -iquote $(fsrcdir)/ada \ - -I$(fsrcdir)/../include $(GMPINC) + -I$(ftop_srcdir)/include $(GMPINC) else INCLUDES_FOR_SUBDIR = -iquote . -iquote .. -iquote ../.. \ -iquote $(fsrcdir)/ada -iquote $(fsrcdir) \ - -I$(fsrcdir)/../include $(GMPINC) + -I$(ftop_srcdir)/include $(GMPINC) endif ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir)/ada @@ -408,6 +415,8 @@ DUMMY_SOCKETS_TARGET_PAIRS = \ # special version of Ada.Strings.Unbounded package can be used. ATOMICS_TARGET_PAIRS = \ + a-coinho.adb<a-coinho-shared.adb \ + a-coinho.ads<a-coinho-shared.ads \ a-stunau.adb<a-stunau-shared.adb \ a-suteio.adb<a-suteio-shared.adb \ a-strunb.ads<a-strunb-shared.ads \ @@ -493,6 +502,13 @@ endif # PowerPC and e500v2 VxWorks ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(target_cpu) $(target_vendor) $(target_os))),) + + ifeq ($(strip $(filter-out e500%, $(target_alias))),) + ARCH_STR=e500 + else + ARCH_STR=ppc + endif + LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-vxworks.ads \ a-numaux.ads<a-numaux-vxworks.ads \ @@ -545,7 +561,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(target_cpu) $(target_vendor) $ 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-ppc-rtp.ads + system.ads<system-vxworks-$(ARCH_STR)-rtp.ads EXTRA_GNATRTL_NONTASKING_OBJS=s-vxwexc.o else @@ -555,7 +571,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(target_cpu) $(target_vendor) $ s-vxwext.ads<s-vxwext-rtp.ads \ s-vxwext.adb<s-vxwext-rtp-smp.adb \ s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \ - system.ads<system-vxworks-ppc-rtp.ads + system.ads<system-vxworks-$(ARCH_STR)-rtp.ads EXTRA_GNATRTL_NONTASKING_OBJS=s-vxwexc.o EXTRA_LIBGNAT_OBJS+=affinity.o @@ -567,7 +583,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(target_cpu) $(target_vendor) $ s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \ s-vxwext.ads<s-vxwext-kernel.ads \ s-vxwext.adb<s-vxwext-kernel-smp.adb \ - system.ads<system-vxworks-ppc-kernel.ads + system.ads<system-vxworks-$(ARCH_STR)-kernel.ads EH_MECHANISM=-gcc EXTRA_LIBGNAT_OBJS+=affinity.o @@ -581,7 +597,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(target_cpu) $(target_vendor) $ LIBGNAT_TARGET_PAIRS += \ s-vxwext.ads<s-vxwext-kernel.ads \ s-vxwext.adb<s-vxwext-kernel.adb \ - system.ads<system-vxworks-ppc-kernel.ads + system.ads<system-vxworks-$(ARCH_STR)-kernel.ads else LIBGNAT_TARGET_PAIRS += \ system.ads<system-vxworks-ppc.ads @@ -984,7 +1000,7 @@ ifeq ($(strip $(filter-out mips% wrs vx%,$(target_cpu) $(target_vendor) $(target EXTRA_LIBGNAT_OBJS+=vx_stack_info.o endif -# ARM linux, Android eabi +# ARM android ifeq ($(strip $(filter-out arm% linux-androideabi,$(target_cpu) $(target_os))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-linux.ads \ @@ -1201,6 +1217,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),) indepsw.adb<indepsw-gnu.adb GNATLIB_SHARED = gnatlib-shared-dual + MISCLIB = -ldl GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1581,7 +1598,14 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(target_ LIBRARY_VERSION := $(subst .,_,$(LIB_VERSION)) endif -# *-elf, *-eabi or *-eabispe +# PikeOS +ifeq ($(strip $(filter-out powerpc% %86 sysgo pikeos,$(target_cpu) $(target_vendor) $(target_os)))),) + TOOLS_TARGET_PAIRS=\ + mlib-tgt-specific.adb<mlib-tgt-specific-xi.adb \ + indepsw.adb<indepsw-gnu.adb +endif + +# *-elf, *-eabi, or *-eabispe ifeq ($(strip $(filter-out elf eabi eabispe,$(target_os))),) TOOLS_TARGET_PAIRS=\ mlib-tgt-specific.adb<mlib-tgt-specific-xi.adb \ @@ -2147,6 +2171,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),) EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o EH_MECHANISM=-gcc THREADSLIB=-lpthread -lrt + MISCLIB = -ldl GNATLIB_SHARED=gnatlib-shared-dual GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) @@ -2291,9 +2316,10 @@ ifeq ($(strip $(filter-out arm nucleus%,$(target_cpu) $(target_os))),) GNATRTL_SOCKETS_OBJS = endif -ifneq ($(EH_MECHANISM),) - LIBGNAT_TARGET_PAIRS += a-exexpr.adb<a-exexpr$(EH_MECHANISM).adb - EXTRA_LIBGNAT_OBJS+=raise$(EH_MECHANISM).o +ifeq ($(EH_MECHANISM),-gcc) + LIBGNAT_TARGET_PAIRS += a-exexpr.adb<a-exexpr-gcc.adb + EXTRA_LIBGNAT_OBJS+=raise-gcc.o + EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o endif # Use the Ada 2005 version of Ada.Exceptions by default, unless specified @@ -2998,7 +3024,7 @@ vx_stack_info.o : vx_stack_info.c raise-gcc.o : raise-gcc.c raise.h $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \ - -iquote $(srcdir) -iquote $(srcdir)/../libgcc \ + -iquote $(srcdir) -iquote $(ftop_srcdir)/libgcc \ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION) cio.o : cio.c diff --git a/gcc/ada/gcc-interface/cuintp.c b/gcc/ada/gcc-interface/cuintp.c index 807a15132e2..da575c0efc0 100644 --- a/gcc/ada/gcc-interface/cuintp.c +++ b/gcc/ada/gcc-interface/cuintp.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2012, Free Software Foundation, Inc. * + * Copyright (C) 1992-2013, 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,8 +23,8 @@ * * ****************************************************************************/ -/* This file corresponds to the Ada package body Uintp. It was created - manually from the files uintp.ads and uintp.adb. */ +/* This file corresponds to the Ada package body Uintp. It was created + manually from the files uintp.ads and uintp.adb. */ #include "config.h" #include "system.h" @@ -35,11 +35,6 @@ #include "ada.h" #include "types.h" #include "uintp.h" -#include "atree.h" -#include "elists.h" -#include "nlists.h" -#include "stringt.h" -#include "fe.h" #include "ada-tree.h" #include "gigi.h" @@ -53,13 +48,13 @@ the integer value itself. The origin of the Uints_Ptr table is adjusted so that a Uint value of Uint_Bias indexes the first element. - First define a utility function that operates like build_int_cst for - integral types and does a conversion to floating-point for real types. */ + First define a utility function that operates like build_int_cst_type for + integral types and does a conversion for floating-point types. */ static tree build_cst_from_int (tree type, HOST_WIDE_INT low) { - if (TREE_CODE (type) == REAL_TYPE) + if (SCALAR_FLOAT_TYPE_P (type)) return convert (type, build_int_cst (NULL_TREE, low)); else return build_int_cst_type (type, low); @@ -73,20 +68,15 @@ build_cst_from_int (tree type, HOST_WIDE_INT low) tree UI_To_gnu (Uint Input, tree type) { + /* We might have a TYPE with biased representation and be passed an unbiased + value that doesn't fit. We always use an unbiased type to be able to hold + any such possible value for intermediate computations and then rely on a + conversion back to TYPE to perform the bias adjustment when need be. */ + tree comp_type + = TREE_CODE (type) == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type) + ? get_base_type (type) : type; tree gnu_ret; - /* We might have a TYPE with biased representation and be passed an - unbiased value that doesn't fit. We always use an unbiased type able - to hold any such possible value for intermediate computations, and - then rely on a conversion back to TYPE to perform the bias adjustment - when need be. */ - - int biased_type_p - = (TREE_CODE (type) == INTEGER_TYPE - && TYPE_BIASED_REPRESENTATION_P (type)); - - tree comp_type = biased_type_p ? get_base_type (type) : type; - if (Input <= Uint_Direct_Last) gnu_ret = build_cst_from_int (comp_type, Input - Uint_Direct_Bias); else @@ -192,7 +182,9 @@ UI_From_gnu (tree Input) gnu_temp = fold_build2 (TRUNC_DIV_EXPR, gnu_type, gnu_temp, gnu_base); } - temp.Low_Bound = 1, temp.High_Bound = Max_For_Dint; - vec.Array = v, vec.Bounds = &temp; + temp.Low_Bound = 1; + temp.High_Bound = Max_For_Dint; + vec.Bounds = &temp; + vec.Array = v; return Vector_To_Uint (vec, tree_int_cst_sgn (Input) < 0); } diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 80520a5acc8..a0f96036758 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -98,7 +98,7 @@ struct incomplete static int defer_incomplete_level = 0; static struct incomplete *defer_incomplete_list; -/* This variable is used to delay expanding From_With_Type types until the +/* This variable is used to delay expanding From_Limited_With types until the end of the spec. */ static struct incomplete *defer_limited_with; @@ -1497,7 +1497,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* If we are defining an Out parameter and optimization isn't enabled, create a fake PARM_DECL for debugging purposes and make it point to the VAR_DECL. Suppress debug info for the latter but make sure it - will live on the stack so that it can be accessed from within the + will live in memory so that it can be accessed from within the debugger through the PARM_DECL. */ if (kind == E_Out_Parameter && definition @@ -1520,7 +1520,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* If this is a renaming pointer, attach the renamed object to it and register it if we are at the global level. Note that an external constant is at the global level. */ - else if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj) + if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj) { SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj); if ((!definition && kind == E_Constant) || global_bindings_p ()) @@ -1579,6 +1579,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && Has_Nested_Block_With_Handler (Scope (gnat_entity))) TREE_ADDRESSABLE (gnu_decl) = 1; + /* If this is a local variable with non-BLKmode and aggregate type, + and optimization isn't enabled, then force it in memory so that + a register won't be allocated to it with possible subparts left + uninitialized and reaching the register allocator. */ + else if (TREE_CODE (gnu_decl) == VAR_DECL + && !DECL_EXTERNAL (gnu_decl) + && !TREE_STATIC (gnu_decl) + && DECL_MODE (gnu_decl) != BLKmode + && AGGREGATE_TYPE_P (TREE_TYPE (gnu_decl)) + && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_decl)) + && !optimize) + TREE_ADDRESSABLE (gnu_decl) = 1; + /* If we are defining an object with variable size or an object with fixed size that will be dynamically allocated, and we are using the setjmp/longjmp exception mechanism, update the setjmp buffer. */ @@ -3725,7 +3738,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* Whether it comes from a limited with. */ bool is_from_limited_with = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind) - && From_With_Type (gnat_desig_equiv)); + && From_Limited_With (gnat_desig_equiv)); /* The "full view" of the designated type. If this is an incomplete entity from a limited with, treat its non-limited view as the full view. Otherwise, if this is an incomplete or private type, use the @@ -4217,7 +4230,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) we are only annotating types, break circularities here. */ if (type_annotate_only && IN (Ekind (gnat_return_type), Incomplete_Kind) - && From_With_Type (gnat_return_type) + && From_Limited_With (gnat_return_type) && In_Extended_Main_Code_Unit (Non_Limited_View (gnat_return_type)) && !present_gnu_tree (Non_Limited_View (gnat_return_type))) @@ -4330,7 +4343,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) we are only annotating types, break circularities here. */ if (type_annotate_only && IN (Ekind (gnat_param_type), Incomplete_Kind) - && From_With_Type (Etype (gnat_param_type)) + && From_Limited_With (Etype (gnat_param_type)) && In_Extended_Main_Code_Unit (Non_Limited_View (gnat_param_type)) && !present_gnu_tree (Non_Limited_View (gnat_param_type))) @@ -4725,7 +4738,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) full view, whichever is present. This is used in all the tests below. */ Entity_Id full_view - = (IN (kind, Incomplete_Kind) && From_With_Type (gnat_entity)) + = (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity)) ? Non_Limited_View (gnat_entity) : Present (Full_View (gnat_entity)) ? Full_View (gnat_entity) @@ -5477,10 +5490,10 @@ is_cplusplus_method (Entity_Id gnat_entity) return false; } -/* Finalize the processing of From_With_Type incomplete types. */ +/* Finalize the processing of From_Limited_With incomplete types. */ void -finalize_from_with_types (void) +finalize_from_limited_with (void) { struct incomplete *p, *next; @@ -5824,12 +5837,8 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, ro_param || by_ref || by_component_ptr); DECL_BY_REF_P (gnu_param) = by_ref; DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr; - DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor || - mech == By_Short_Descriptor); - /* Note that, in case of a parameter passed by double reference, the - DECL_POINTS_TO_READONLY_P flag is meant for the second reference. - The first reference always points to read-only, as it points to - the second reference, i.e. the reference to the actual parameter. */ + DECL_BY_DESCRIPTOR_P (gnu_param) + = (mech == By_Descriptor || mech == By_Short_Descriptor); DECL_POINTS_TO_READONLY_P (gnu_param) = (ro_param && (by_ref || by_component_ptr)); DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param); diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index d18fd4d2207..832803ccfc3 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -93,8 +93,8 @@ do { \ mark_visited (EXP); \ } while (0) -/* Finalize the processing of From_With_Type incomplete types. */ -extern void finalize_from_with_types (void); +/* Finalize the processing of From_Limited_With incomplete types. */ +extern void finalize_from_limited_with (void); /* Return the equivalent type to be used for GNAT_ENTITY, if it's a kind of type (such E_Task_Type) that has a different type which Gigi @@ -411,6 +411,7 @@ enum standard_datatypes ADT_update_setjmp_buf_decl, ADT_raise_nodefer_decl, ADT_reraise_zcx_decl, + ADT_set_exception_parameter_decl, ADT_begin_handler_decl, ADT_end_handler_decl, ADT_unhandled_except_decl, @@ -470,6 +471,8 @@ extern GTY(()) tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1]; #define update_setjmp_buf_decl gnat_std_decls[(int) ADT_update_setjmp_buf_decl] #define raise_nodefer_decl gnat_std_decls[(int) ADT_raise_nodefer_decl] #define reraise_zcx_decl gnat_std_decls[(int) ADT_reraise_zcx_decl] +#define set_exception_parameter_decl \ + gnat_std_decls[(int) ADT_set_exception_parameter_decl] #define begin_handler_decl gnat_std_decls[(int) ADT_begin_handler_decl] #define others_decl gnat_std_decls[(int) ADT_others_decl] #define all_others_decl gnat_std_decls[(int) ADT_all_others_decl] diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 197f3159f4f..b283b561c38 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -565,6 +565,15 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, NULL_TREE, is_disabled, true, true, true, NULL, Empty); DECL_IGNORED_P (get_excptr_decl) = 1; + set_exception_parameter_decl + = create_subprog_decl + (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE, + build_function_type_list (void_type_node, + ptr_void_type_node, + ptr_void_type_node, + NULL_TREE), + NULL_TREE, is_disabled, true, true, true, NULL, Empty); + raise_nodefer_decl = create_subprog_decl (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, @@ -632,20 +641,20 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, others_decl = create_var_decl (get_identifier ("OTHERS"), get_identifier ("__gnat_others_value"), - integer_type_node, NULL_TREE, true, false, true, false, - NULL, Empty); + unsigned_char_type_node, + NULL_TREE, true, false, true, false, NULL, Empty); all_others_decl = create_var_decl (get_identifier ("ALL_OTHERS"), get_identifier ("__gnat_all_others_value"), - integer_type_node, NULL_TREE, true, false, true, false, - NULL, Empty); + unsigned_char_type_node, + NULL_TREE, true, false, true, false, NULL, Empty); unhandled_others_decl = create_var_decl (get_identifier ("UNHANDLED_OTHERS"), get_identifier ("__gnat_unhandled_others_value"), - integer_type_node, NULL_TREE, true, false, true, false, - NULL, Empty); + unsigned_char_type_node, + NULL_TREE, true, false, true, false, NULL, Empty); main_identifier_node = get_identifier ("main"); @@ -4885,6 +4894,19 @@ Exception_Handler_to_gnu_zcx (Node_Id gnat_node) add_stmt_with_node (build_call_n_expr (begin_handler_decl, 1, gnu_incoming_exc_ptr), gnat_node); + + /* Declare and initialize the choice parameter, if present. */ + if (Present (Choice_Parameter (gnat_node))) + { + tree gnu_param = gnat_to_gnu_entity + (Choice_Parameter (gnat_node), NULL_TREE, 1); + + add_stmt (build_call_n_expr + (set_exception_parameter_decl, 2, + build_unary_op (ADDR_EXPR, NULL_TREE, gnu_param), + gnu_incoming_exc_ptr)); + } + /* We don't have an End_Label at hand to set the location of the cleanup actions, so we use that of the exception handler itself instead. */ add_cleanup (build_call_n_expr (end_handler_decl, 1, gnu_incoming_exc_ptr), @@ -4987,7 +5009,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) /* Process any pragmas and actions following the unit. */ add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node))); add_stmt_list (Actions (Aux_Decls_Node (gnat_node))); - finalize_from_with_types (); + finalize_from_limited_with (); /* Save away what we've made so far and record this potential elaboration procedure. */ @@ -6607,7 +6629,7 @@ gnat_to_gnu (Node_Id gnat_node) Present (gnat_temp); gnat_temp = Next_Formal_With_Extras (gnat_temp)) if (Is_Itype (Etype (gnat_temp)) - && !From_With_Type (Etype (gnat_temp))) + && !From_Limited_With (Etype (gnat_temp))) gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); /* Then the result type, set to Standard_Void_Type for procedures. */ @@ -6615,7 +6637,7 @@ gnat_to_gnu (Node_Id gnat_node) Entity_Id gnat_temp_type = Etype (Defining_Entity (Specification (gnat_node))); - if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type)) + if (Is_Itype (gnat_temp_type) && !From_Limited_With (gnat_temp_type)) gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0); } @@ -6988,6 +7010,10 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = end_stmt_group (); break; + case N_Freeze_Generic_Entity: + gnu_result = alloc_stmt_list (); + break; + case N_Itype_Reference: if (!present_gnu_tree (Itype (gnat_node))) process_type (Itype (gnat_node)); @@ -9195,10 +9221,14 @@ post_error (const char *msg, Node_Id node) String_Template temp; Fat_Pointer fp; - temp.Low_Bound = 1, temp.High_Bound = strlen (msg); - fp.Array = msg, fp.Bounds = &temp; - if (Present (node)) - Error_Msg_N (fp, node); + if (No (node)) + return; + + temp.Low_Bound = 1; + temp.High_Bound = strlen (msg); + fp.Bounds = &temp; + fp.Array = msg; + Error_Msg_N (fp, node); } /* Similar to post_error, but NODE is the node at which to post the error and @@ -9210,10 +9240,14 @@ post_error_ne (const char *msg, Node_Id node, Entity_Id ent) String_Template temp; Fat_Pointer fp; - temp.Low_Bound = 1, temp.High_Bound = strlen (msg); - fp.Array = msg, fp.Bounds = &temp; - if (Present (node)) - Error_Msg_NE (fp, node, ent); + if (No (node)) + return; + + temp.Low_Bound = 1; + temp.High_Bound = strlen (msg); + fp.Bounds = &temp; + fp.Array = msg; + Error_Msg_NE (fp, node, ent); } /* Similar to post_error_ne, but NUM is the number to use for the '^'. */ diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 34edf87cf55..0998c5b4a8c 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -232,6 +232,7 @@ static tree compute_related_constant (tree, tree); static tree split_plus (tree, tree *); static tree float_type_for_precision (int, enum machine_mode); static tree convert_to_fat_pointer (tree, tree); +static unsigned int scale_by_factor_of (tree, unsigned int); static bool potential_alignment_gap (tree, tree, tree); /* Initialize data structures of the utils.c module. */ @@ -531,6 +532,22 @@ gnat_zaplevel (void) free_binding_level = level; } +/* Set the context of TYPE and its parallel types (if any) to CONTEXT. */ + +static void +gnat_set_type_context (tree type, tree context) +{ + tree decl = TYPE_STUB_DECL (type); + + TYPE_CONTEXT (type) = context; + + while (decl && DECL_PARALLEL_TYPE (decl)) + { + TYPE_CONTEXT (DECL_PARALLEL_TYPE (decl)) = context; + decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl)); + } +} + /* Record DECL as belonging to the current lexical scope and use GNAT_NODE for location information and flag propagation. */ @@ -612,7 +629,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) if (TREE_CODE (t) == POINTER_TYPE) TYPE_NEXT_PTR_TO (t) = tt; TYPE_NAME (tt) = DECL_NAME (decl); - TYPE_CONTEXT (tt) = DECL_CONTEXT (decl); + gnat_set_type_context (tt, DECL_CONTEXT (decl)); TYPE_STUB_DECL (tt) = TYPE_STUB_DECL (t); DECL_ORIGINAL_TYPE (decl) = tt; } @@ -622,7 +639,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) /* We need a variant for the placeholder machinery to work. */ tree tt = build_variant_type_copy (t); TYPE_NAME (tt) = decl; - TYPE_CONTEXT (tt) = DECL_CONTEXT (decl); + gnat_set_type_context (tt, DECL_CONTEXT (decl)); TREE_USED (tt) = TREE_USED (t); TREE_TYPE (decl) = tt; if (DECL_ORIGINAL_TYPE (TYPE_NAME (t))) @@ -644,7 +661,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL)) { TYPE_NAME (t) = decl; - TYPE_CONTEXT (t) = DECL_CONTEXT (decl); + gnat_set_type_context (t, DECL_CONTEXT (decl)); } } } @@ -1692,92 +1709,74 @@ rest_of_record_type_compilation (tree record_type) TYPE_SIZE_UNIT (new_record_type) = size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT); - /* Now scan all the fields, replacing each field with a new - field corresponding to the new encoding. */ + /* Now scan all the fields, replacing each field with a new field + corresponding to the new encoding. */ for (old_field = TYPE_FIELDS (record_type); old_field; old_field = DECL_CHAIN (old_field)) { tree field_type = TREE_TYPE (old_field); tree field_name = DECL_NAME (old_field); - tree new_field; tree curpos = bit_position (old_field); + tree pos, new_field; bool var = false; unsigned int align = 0; - tree pos; - - /* See how the position was modified from the last position. - There are two basic cases we support: a value was added - to the last position or the last position was rounded to - a boundary and they something was added. Check for the - first case first. If not, see if there is any evidence - of rounding. If so, round the last position and try - again. + /* We're going to do some pattern matching below so remove as many + conversions as possible. */ + curpos = remove_conversions (curpos, true); - If this is a union, the position can be taken as zero. */ + /* See how the position was modified from the last position. - /* Some computations depend on the shape of the position expression, - so strip conversions to make sure it's exposed. */ - curpos = remove_conversions (curpos, true); + There are two basic cases we support: a value was added + to the last position or the last position was rounded to + a boundary and they something was added. Check for the + first case first. If not, see if there is any evidence + of rounding. If so, round the last position and retry. + If this is a union, the position can be taken as zero. */ if (TREE_CODE (new_record_type) == UNION_TYPE) - pos = bitsize_zero_node, align = 0; + pos = bitsize_zero_node; else pos = compute_related_constant (curpos, last_pos); - if (!pos && TREE_CODE (curpos) == MULT_EXPR + if (!pos + && TREE_CODE (curpos) == MULT_EXPR && tree_fits_uhwi_p (TREE_OPERAND (curpos, 1))) { tree offset = TREE_OPERAND (curpos, 0); align = tree_to_uhwi (TREE_OPERAND (curpos, 1)); - - /* An offset which is a bitwise AND with a mask increases the - alignment according to the number of trailing zeros. */ - offset = remove_conversions (offset, true); - if (TREE_CODE (offset) == BIT_AND_EXPR - && TREE_CODE (TREE_OPERAND (offset, 1)) == INTEGER_CST) - { - unsigned HOST_WIDE_INT mask - = tree_to_hwi (TREE_OPERAND (offset, 1)); - unsigned int i; - - for (i = 0; i < HOST_BITS_PER_WIDE_INT; i++) - { - if (mask & 1) - break; - mask >>= 1; - align *= 2; - } - } - - pos = compute_related_constant (curpos, - round_up (last_pos, align)); + align = scale_by_factor_of (offset, align); + last_pos = round_up (last_pos, align); + pos = compute_related_constant (curpos, last_pos); } - else if (!pos && TREE_CODE (curpos) == PLUS_EXPR - && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST + else if (!pos + && TREE_CODE (curpos) == PLUS_EXPR + && tree_fits_uhwi_p (TREE_OPERAND (curpos, 1)) && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR - && tree_fits_uhwi_p (TREE_OPERAND - (TREE_OPERAND (curpos, 0), 1))) + && tree_fits_uhwi_p + (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1))) { + tree offset = TREE_OPERAND (TREE_OPERAND (curpos, 0), 0); + unsigned HOST_WIDE_INT addend + = tree_to_uhwi (TREE_OPERAND (curpos, 1)); align - = tree_to_uhwi - (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1)); - pos = compute_related_constant (curpos, - round_up (last_pos, align)); + = tree_to_uhwi (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1)); + align = scale_by_factor_of (offset, align); + align = MIN (align, addend & -addend); + last_pos = round_up (last_pos, align); + pos = compute_related_constant (curpos, last_pos); } - else if (potential_alignment_gap (prev_old_field, old_field, - pos)) + else if (potential_alignment_gap (prev_old_field, old_field, pos)) { align = TYPE_ALIGN (field_type); - pos = compute_related_constant (curpos, - round_up (last_pos, align)); + last_pos = round_up (last_pos, align); + pos = compute_related_constant (curpos, last_pos); } /* If we can't compute a position, set it to zero. - ??? We really should abort here, but it's too much work - to get this correct for all cases. */ - + ??? We really should abort here, but it's too much work + to get this correct for all cases. */ if (!pos) pos = bitsize_zero_node; @@ -2559,6 +2558,32 @@ value_factor_p (tree value, HOST_WIDE_INT factor) return false; } +/* Return VALUE scaled by the biggest power-of-2 factor of EXPR. */ + +static unsigned int +scale_by_factor_of (tree expr, unsigned int value) +{ + expr = remove_conversions (expr, true); + + /* An expression which is a bitwise AND with a mask has a power-of-2 factor + corresponding to the number of trailing zeros of the mask. */ + if (TREE_CODE (expr) == BIT_AND_EXPR + && TREE_CODE (TREE_OPERAND (expr, 1)) == INTEGER_CST) + { + unsigned HOST_WIDE_INT mask = tree_to_hwi (TREE_OPERAND (expr, 1)); + unsigned int i = 0; + + while ((mask & 1) == 0 && i < HOST_BITS_PER_WIDE_INT) + { + mask >>= 1; + value *= 2; + i++; + } + } + + return value; +} + /* Given two consecutive field decls PREV_FIELD and CURR_FIELD, return true unless we can prove these 2 fields are laid out in such a way that no gap exist between the end of PREV_FIELD and the beginning of CURR_FIELD. OFFSET @@ -5764,6 +5789,7 @@ enum c_builtin_type #define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME, #define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME, #define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME, +#define DEF_FUNCTION_TYPE_8(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7, ARG8) 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, @@ -5782,6 +5808,7 @@ enum c_builtin_type #undef DEF_FUNCTION_TYPE_5 #undef DEF_FUNCTION_TYPE_6 #undef DEF_FUNCTION_TYPE_7 +#undef DEF_FUNCTION_TYPE_8 #undef DEF_FUNCTION_TYPE_VAR_0 #undef DEF_FUNCTION_TYPE_VAR_1 #undef DEF_FUNCTION_TYPE_VAR_2 @@ -5877,6 +5904,10 @@ install_builtin_function_types (void) #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ ARG6, ARG7) \ def_fn_type (ENUM, RETURN, 0, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7); +#define DEF_FUNCTION_TYPE_8(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7, ARG8) \ + def_fn_type (ENUM, RETURN, 0, 8, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \ + ARG7, ARG8); #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ def_fn_type (ENUM, RETURN, 1, 0); #define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \ diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index b0e3087508f..24341acd991 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -117,6 +117,13 @@ procedure Gnat1drv is Relaxed_RM_Semantics := True; end if; + -- -gnatd.E sets Error_To_Warning mode, causing selected error messages + -- to be treated as warnings instead of errors. + + if Debug_Flag_Dot_EE then + Error_To_Warning := True; + end if; + -- Disable CodePeer_Mode in Check_Syntax, since we need front-end -- expansion. diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index c1109b9c98a..5dcfbe86634 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -206,11 +206,15 @@ Implementation Defined Pragmas * Pragma Passive:: * Pragma Persistent_BSS:: * Pragma Polling:: +* Pragma Post:: * Pragma Postcondition:: +* Pragma Post_Class:: +* Pragma Pre:: * Pragma Precondition:: * Pragma Predicate:: * Pragma Preelaborable_Initialization:: * Pragma Preelaborate_05:: +* Pragma Pre_Class:: * Pragma Priority_Specific_Dispatching:: * Pragma Profile:: * Pragma Profile_Warnings:: @@ -249,6 +253,8 @@ Implementation Defined Pragmas * Pragma Thread_Local_Storage:: * Pragma Time_Slice:: * Pragma Title:: +* Pragma Type_Invariant:: +* Pragma Type_Invariant_Class:: * Pragma Unchecked_Union:: * Pragma Unimplemented_Unit:: * Pragma Universal_Aliasing :: @@ -331,6 +337,7 @@ Implementation Defined Attributes * Attribute Integer_Value:: * Attribute Invalid_Value:: * Attribute Large:: +* Attribute Library_Level:: * Attribute Loop_Entry:: * Attribute Machine_Size:: * Attribute Mantissa:: @@ -1022,11 +1029,15 @@ consideration, the use of these pragmas should be minimized. * Pragma Passive:: * Pragma Persistent_BSS:: * Pragma Polling:: +* Pragma Post:: * Pragma Postcondition:: +* Pragma Post_Class:: +* Pragma Pre:: * Pragma Precondition:: * Pragma Predicate:: * Pragma Preelaborable_Initialization:: * Pragma Preelaborate_05:: +* Pragma Pre_Class:: * Pragma Priority_Specific_Dispatching:: * Pragma Profile:: * Pragma Profile_Warnings:: @@ -1065,6 +1076,8 @@ consideration, the use of these pragmas should be minimized. * Pragma Thread_Local_Storage:: * Pragma Time_Slice:: * Pragma Title:: +* Pragma Type_Invariant:: +* Pragma Type_Invariant_Class:: * Pragma Unchecked_Union:: * Pragma Unimplemented_Unit:: * Pragma Universal_Aliasing :: @@ -1375,7 +1388,9 @@ ID_ASSERTION_KIND ::= Assertions | Loop_Variant | Postcondition | Precondition | - Predicate + Predicate | + Refined_Post | + Refined_Pre | Statement_Assertions POLICY_IDENTIFIER ::= Check | Disable | Ignore @@ -1391,7 +1406,10 @@ are implementation defined additions recognized by the GNAT compiler. The pragma applies in both cases to pragmas and aspects with matching names, e.g. @code{Pre} applies to the Pre aspect, and @code{Precondition} applies to both the @code{Precondition} pragma -and the aspect @code{Precondition}. +and the aspect @code{Precondition}. Note that the identifiers for +pragmas Pre_Class and Post_Class are Pre'Class and Post'Class (not +Pre_Class and Post_Class), since these pragmas are intended to be +identical to the corresponding aspects). If the policy is @code{CHECK}, then assertions are enabled, i.e. the corresponding pragma or aspect is activated. @@ -5014,6 +5032,28 @@ Note that polling can also be enabled by use of the @option{-gnatP} switch. @xref{Switches for gcc,,, gnat_ugn, @value{EDITION} User's Guide}, for details. +@node Pragma Post +@unnumberedsec Pragma Post +@cindex Post +@cindex Checks, postconditions +@findex Postconditions +@noindent +Syntax: + +@smallexample @c ada +pragma Post (Boolean_Expression); +@end smallexample + +@noindent +The @code{Post} pragma is intended to be an exact replacement for +the language-defined +@code{Post} aspect, and shares its restrictions and semantics. +It must appear either immediately following the corresponding +subprogram declaration (only other pragmas may intervene), or +if there is no separate subprogram declaration, then it can +appear at the start of the declarations in a subprogram body +(preceded only by other pragmas). + @node Pragma Postcondition @unnumberedsec Pragma Postcondition @cindex Postcondition @@ -5171,6 +5211,69 @@ inlining (-gnatN option set) are accepted and legality-checked by the compiler, but are ignored at run-time even if postcondition checking is enabled. +Note that pragma @code{Postcondition} differs from the language-defined +@code{Post} aspect (and corresponding @code{Post} pragma) in allowing +multiple occurrences, allowing occurences in the body even if there +is a separate spec, and allowing a second string parameter, and the +use of the pragma identifier @code{Check}. Historically, pragma +@code{Postcondition} was implemented prior to the development of +Ada 2012, and has been retained in its original form for +compatibility purposes. + +@node Pragma Post_Class +@unnumberedsec Pragma Post_Class +@cindex Post +@cindex Checks, postconditions +@findex Postconditions +@noindent +Syntax: + +@smallexample @c ada +pragma Post_Class (Boolean_Expression); +@end smallexample + +@noindent +The @code{Post_Class} pragma is intended to be an exact replacement for +the language-defined +@code{Post'Class} aspect, and shares its restrictions and semantics. +It must appear either immediately following the corresponding +subprogram declaration (only other pragmas may intervene), or +if there is no separate subprogram declaration, then it can +appear at the start of the declarations in a subprogram body +(preceded only by other pragmas). + +Note: This pragma is called @code{Post_Class} rather than +@code{Post'Class} because the latter would not be strictly +conforming to the allowed syntax for pragmas. The motivation +for provinding pragmas equivalent to the aspects is to allow a program +to be written using the pragmas, and then compiled if necessary +using an Ada compiler that does not recognize the pragmas or +aspects, but is prepared to ignore the pragmas. The assertion +policy that controls this pragma is @code{Post'Class}, not +@code{Post_Class}. + +@node Pragma Pre +@unnumberedsec Pragma Pre +@cindex Pre +@cindex Checks, preconditions +@findex Preconditions +@noindent +Syntax: + +@smallexample @c ada +pragma Pre (Boolean_Expression); +@end smallexample + +@noindent +The @code{Pre} pragma is intended to be an exact replacement for +the language-defined +@code{Pre} aspect, and shares its restrictions and semantics. +It must appear either immediately following the corresponding +subprogram declaration (only other pragmas may intervene), or +if there is no separate subprogram declaration, then it can +appear at the start of the declarations in a subprogram body +(preceded only by other pragmas). + @node Pragma Precondition @unnumberedsec Pragma Precondition @cindex Preconditions @@ -5219,6 +5322,15 @@ inlining (-gnatN option set) are accepted and legality-checked by the compiler, but are ignored at run-time even if precondition checking is enabled. +Note that pragma @code{Precondition} differs from the language-defined +@code{Pre} aspect (and corresponding @code{Pre} pragma) in allowing +multiple occurrences, allowing occurences in the body even if there +is a separate spec, and allowing a second string parameter, and the +use of the pragma identifier @code{Check}. Historically, pragma +@code{Precondition} was implemented prior to the development of +Ada 2012, and has been retained in its original form for +compatibility purposes. + @node Pragma Predicate @unnumberedsec Pragma Predicate @findex Predicate @@ -5260,6 +5372,21 @@ subtype Q is R with Dynamic_Predicate => F(Q) or G(Q); @end smallexample +Note that there is are no pragmas @code{Dynamic_Predicate} +or @code{Static_Predicate}. That is +because these pragmas would affect legality and semantics of +the program and thus do not have a neutral effect if ignored. +The motivation behind providing pragmas equivalent to +corresponding aspects is to allow a program to be written +using the pragmas, and then compiled with a compiler that +will ignore the pragmas. That doesn't work in the case of +static and dynamic predicates, since if the corresponding +pragmas are ignored, then the behavior of the program is +fundamentally changed (for example a membership test +@code{A in B} would not take into account a predicate +defined for subtype B). When following this approach, the +use of predicates should be avoided. + @node Pragma Preelaborable_Initialization @unnumberedsec Pragma Preelaborable_Initialization @findex Preelaborable_Initialization @@ -5293,6 +5420,38 @@ equivalent to @code{pragma Prelaborate} when operating in later Ada versions. This is used to handle some cases where packages not previously preelaborable became so in Ada 2005. +@node Pragma Pre_Class +@unnumberedsec Pragma Pre_Class +@cindex Pre_Class +@cindex Checks, preconditions +@findex Preconditions +@noindent +Syntax: + +@smallexample @c ada +pragma Pre_Class (Boolean_Expression); +@end smallexample + +@noindent +The @code{Pre_Class} pragma is intended to be an exact replacement for +the language-defined +@code{Pre'Class} aspect, and shares its restrictions and semantics. +It must appear either immediately following the corresponding +subprogram declaration (only other pragmas may intervene), or +if there is no separate subprogram declaration, then it can +appear at the start of the declarations in a subprogram body +(preceded only by other pragmas). + +Note: This pragma is called @code{Pre_Class} rather than +@code{Pre'Class} because the latter would not be strictly +conforming to the allowed syntax for pragmas. The motivation +for providing pragmas equivalent to the aspects is to allow a program +to be written using the pragmas, and then compiled if necessary +using an Ada compiler that does not recognize the pragmas or +aspects, but is prepared to ignore the pragmas. The assertion +policy that controls this pragma is @code{Pre'Class}, not +@code{Pre_Class}. + @node Pragma Priority_Specific_Dispatching @unnumberedsec Pragma Priority_Specific_Dispatching @findex Priority_Specific_Dispatching @@ -6647,6 +6806,56 @@ for this pragma, i.e.@: the parameters may be given in any order if named notation is used, and named and positional notation can be mixed following the normal rules for procedure calls in Ada. +@node Pragma Type_Invariant +@unnumberedsec Pragma Type_Invariant +@findex Invariant +@findex Type_Invariant pragma +@noindent +Syntax: + +@smallexample @c ada +pragma Type_Invariant + ([Entity =>] type_LOCAL_NAME, + [Check =>] EXPRESSION); +@end smallexample + +@noindent +The @code{Type_Invariant} pragma is intended to be an exact +replacement for the language-defined @code{Type_Invariant} +aspect, and shares its restrictions and semantics. It differs +from the language defined @code{Invariant} pragma in that it +does not permit a string parameter, and it is +controlled by the assertion identifier @code{Type_Invariant} +rather than @code{Invariant}. + +@node Pragma Type_Invariant_Class +@unnumberedsec Pragma Type_Invariant_Class +@findex Invariant +@findex Type_Invariant_Class pragma +@noindent +Syntax: + +@smallexample @c ada +pragma Type_Invariant_Class + ([Entity =>] type_LOCAL_NAME, + [Check =>] EXPRESSION); +@end smallexample + +@noindent +The @code{Type_Invariant_Class} pragma is intended to be an exact +replacement for the language-defined @code{Type_Invariant'Class} +aspect, and shares its restrictions and semantics. + +Note: This pragma is called @code{Type_Invariant_Class} rather than +@code{Type_Invariant'Class} because the latter would not be strictly +conforming to the allowed syntax for pragmas. The motivation +for providing pragmas equivalent to the aspects is to allow a program +to be written using the pragmas, and then compiled if necessary +using an Ada compiler that does not recognize the pragmas or +aspects, but is prepared to ignore the pragmas. The assertion +policy that controls this pragma is @code{Type_Invariant'Class}, +not @code{Type_Invariant_Class}. + @node Pragma Unchecked_Union @unnumberedsec Pragma Unchecked_Union @cindex Unions in C @@ -7634,6 +7843,7 @@ consideration, you should minimize the use of these attributes. * Attribute Integer_Value:: * Attribute Invalid_Value:: * Attribute Large:: +* Attribute Library_Level:: * Attribute Loop_Entry:: * Attribute Machine_Size:: * Attribute Mantissa:: @@ -8133,6 +8343,30 @@ The @code{Large} attribute is provided for compatibility with Ada 83. See the Ada 83 reference manual for an exact description of the semantics of this attribute. +@node Attribute Library_Level +@unnumberedsec Attribute Library_Level +@findex Library_Level +@noindent +@noindent +@code{P'Library_Level}, where P is an entity name, +returns a Boolean value which is True if the entity is declared +at the library level, and False otherwise. Note that within a +generic instantition, the name of the generic unit denotes the +instance, which means that this attribute can be used to test +if a generic is instantiated at the library level, as shown +in this example: + +@smallexample @c ada +generic + ... +package Gen is + pragma Compile_Time_Error + (not Gen'Library_Level, + "Gen can only be instantiated at library level"); + ... +end Gen; +@end smallexample + @node Attribute Loop_Entry @unnumberedsec Attribute Loop_Entry @findex Loop_Entry @@ -8493,6 +8727,10 @@ have a @code{Scalar_Storage_Order} attribute definition clause. In addition, if the component does not start on a byte boundary, then the scalar storage order specified for S and for the nested component type shall be identical. +If @var{S} appears as the type of a record or array component, the enclosing +record or array shall also have a @code{Scalar_Storage_Order} attribute +definition clause. + No component of a type that has a @code{Scalar_Storage_Order} attribute definition may be aliased. @@ -8665,11 +8903,15 @@ denotes a function identical to @code{System.Storage_Elements.To_Address} except that it is a static attribute. This means that if its argument is a static expression, then the result of the attribute is a -static expression. The result is that such an expression can be +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 -argument is static). +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 +modular manner (e.g. -1 means the same as 16#FFFF_FFFF# on +a 32 bits machine). @node Attribute Type_Class @unnumberedsec Attribute Type_Class @@ -8777,7 +9019,7 @@ The @code{Update} attribute creates a copy of an array or record value with one or more modified components. The syntax is: @smallexample @c ada -PREFIX'Update (AGGREGATE); +PREFIX'Update (AGGREGATE) @end smallexample @noindent @@ -8825,6 +9067,8 @@ kept in mind when considering efficiency. The @code{Update} attribute cannot be applied to prefixes of a limited type, and cannot reference discriminants in the case of a record type. +The accessibility level of an Update attribute result object is defined +as for an aggregate. In the record case, no component can be mentioned more than once. In the array case, two overlapping ranges can appear in the aggregate, @@ -11723,6 +11967,7 @@ where @var{nnn} is an integer. @emph{Exception_Name:} nnnnn @emph{Message:} mmmmm @emph{PID:} ppp +@emph{Load address:} 0xhhhh @emph{Call stack traceback locations:} 0xhhhh 0xhhhh 0xhhhh ... 0xhhh @end smallexample @@ -11744,10 +11989,12 @@ present only if the Process Id is nonzero). Currently we are not making use of this field. @item -The Call stack traceback locations line and the following values -are present only if at least one traceback location was recorded. -The values are given in C style format, with lower case letters -for a-f, and only as many digits present as are necessary. +The Load address line, the Call stack traceback locations line and the +following values are present only if at least one traceback location was +recorded. The Load address indicates the address at which the main executable +was loaded; this line may not be present if operating system hasn't relocated +the main executable. The values are given in C style format, with lower case +letters for a-f, and only as many digits present as are necessary. @end itemize @noindent @@ -12003,7 +12250,18 @@ See items describing the integer and floating-point types supported. @sp 1 @cartouche @noindent -@strong{61}. The accuracy actually achieved by the elementary +@strong{61}. The string returned by @code{Character_Set_Version}. +See A.3.5(3). +@end cartouche +@noindent +@code{Ada.Wide_Characters.Handling.Character_Set_Version} returns +the string "Unicode 6.2", referring to version 6.2.x of the +Unicode specification. + +@sp 1 +@cartouche +@noindent +@strong{62}. The accuracy actually achieved by the elementary functions. See A.5.1(1). @end cartouche @noindent @@ -12013,7 +12271,7 @@ library. Only fast math mode is implemented. @sp 1 @cartouche @noindent -@strong{62}. The sign of a zero result from some of the operators or +@strong{63}. The sign of a zero result from some of the operators or functions in @code{Numerics.Generic_Elementary_Functions}, when @code{Float_Type'Signed_Zeros} is @code{True}. See A.5.1(46). @end cartouche @@ -12024,7 +12282,7 @@ floating-point. @sp 1 @cartouche @noindent -@strong{63}. The value of +@strong{64}. The value of @code{Numerics.Float_Random.Max_Image_Width}. See A.5.2(27). @end cartouche @noindent @@ -12033,7 +12291,7 @@ Maximum image width is 6864, see library file @file{s-rannum.ads}. @sp 1 @cartouche @noindent -@strong{64}. The value of +@strong{65}. The value of @code{Numerics.Discrete_Random.Max_Image_Width}. See A.5.2(27). @end cartouche @noindent @@ -12042,7 +12300,7 @@ Maximum image width is 6864, see library file @file{s-rannum.ads}. @sp 1 @cartouche @noindent -@strong{65}. The algorithms for random number generation. See +@strong{66}. The algorithms for random number generation. See A.5.2(32). @end cartouche @noindent @@ -12053,7 +12311,7 @@ The algorithm is the Mersenne Twister, as documented in the source file @sp 1 @cartouche @noindent -@strong{66}. The string representation of a random number generator's +@strong{67}. The string representation of a random number generator's state. See A.5.2(38). @end cartouche @noindent @@ -12064,7 +12322,7 @@ of the state vector. @sp 1 @cartouche @noindent -@strong{67}. The minimum time interval between calls to the +@strong{68}. 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). @end cartouche @@ -12075,7 +12333,7 @@ random numbers is one microsecond. @sp 1 @cartouche @noindent -@strong{68}. The values of the @code{Model_Mantissa}, +@strong{69}. The values of the @code{Model_Mantissa}, @code{Model_Emin}, @code{Model_Epsilon}, @code{Model}, @code{Safe_First}, and @code{Safe_Last} attributes, if the Numerics Annex is not supported. See A.5.3(72). @@ -12087,7 +12345,7 @@ Run the compiler with @option{-gnatS} to produce a listing of package @sp 1 @cartouche @noindent -@strong{69}. Any implementation-defined characteristics of the +@strong{70}. Any implementation-defined characteristics of the input-output packages. See A.7(14). @end cartouche @noindent @@ -12097,7 +12355,7 @@ packages. @sp 1 @cartouche @noindent -@strong{70}. The value of @code{Buffer_Size} in @code{Storage_IO}. See +@strong{71}. The value of @code{Buffer_Size} in @code{Storage_IO}. See A.9(10). @end cartouche @noindent @@ -12108,7 +12366,7 @@ boundary. @sp 1 @cartouche @noindent -@strong{71}. External files for standard input, standard output, and +@strong{72}. External files for standard input, standard output, and standard error See A.10(5). @end cartouche @noindent @@ -12118,7 +12376,7 @@ libraries. See source file @file{i-cstrea.ads} for further details. @sp 1 @cartouche @noindent -@strong{72}. The accuracy of the value produced by @code{Put}. See +@strong{73}. The accuracy of the value produced by @code{Put}. See A.10.9(36). @end cartouche @noindent @@ -12129,7 +12387,7 @@ significant digit positions. @sp 1 @cartouche @noindent -@strong{73}. The meaning of @code{Argument_Count}, @code{Argument}, and +@strong{74}. The meaning of @code{Argument_Count}, @code{Argument}, and @code{Command_Name}. See A.15(1). @end cartouche @noindent @@ -12139,7 +12397,7 @@ main program in the natural manner. @sp 1 @cartouche @noindent -@strong{74}. The interpretation of the @code{Form} parameter in procedure +@strong{75}. The interpretation of the @code{Form} parameter in procedure @code{Create_Directory}. See A.16(56). @end cartouche @noindent @@ -12148,7 +12406,7 @@ The @code{Form} parameter is not used. @sp 1 @cartouche @noindent -@strong{75}. The interpretation of the @code{Form} parameter in procedure +@strong{76}. The interpretation of the @code{Form} parameter in procedure @code{Create_Path}. See A.16(60). @end cartouche @noindent @@ -12157,7 +12415,7 @@ The @code{Form} parameter is not used. @sp 1 @cartouche @noindent -@strong{76}. The interpretation of the @code{Form} parameter in procedure +@strong{77}. The interpretation of the @code{Form} parameter in procedure @code{Copy_File}. See A.16(68). @end cartouche @noindent @@ -12236,7 +12494,7 @@ Form => "mode=internal, preserve=timestamps" @sp 1 @cartouche @noindent -@strong{77}. Implementation-defined convention names. See B.1(11). +@strong{78}. Implementation-defined convention names. See B.1(11). @end cartouche @noindent The following convention names are supported @@ -12303,7 +12561,7 @@ implementations, these names are accepted silently. @sp 1 @cartouche @noindent -@strong{78}. The meaning of link names. See B.1(36). +@strong{79}. The meaning of link names. See B.1(36). @end cartouche @noindent Link names are the actual names used by the linker. @@ -12311,7 +12569,7 @@ Link names are the actual names used by the linker. @sp 1 @cartouche @noindent -@strong{79}. The manner of choosing link names when neither the link +@strong{80}. 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). @end cartouche @@ -12323,7 +12581,7 @@ letters. @sp 1 @cartouche @noindent -@strong{80}. The effect of pragma @code{Linker_Options}. See B.1(37). +@strong{81}. The effect of pragma @code{Linker_Options}. See B.1(37). @end cartouche @noindent The string passed to @code{Linker_Options} is presented uninterpreted as @@ -12344,7 +12602,7 @@ from the corresponding package spec. @sp 1 @cartouche @noindent -@strong{81}. The contents of the visible part of package +@strong{82}. The contents of the visible part of package @code{Interfaces} and its language-defined descendants. See B.2(1). @end cartouche @noindent @@ -12353,7 +12611,7 @@ See files with prefix @file{i-} in the distributed library. @sp 1 @cartouche @noindent -@strong{82}. Implementation-defined children of package +@strong{83}. Implementation-defined children of package @code{Interfaces}. The contents of the visible part of package @code{Interfaces}. See B.2(11). @end cartouche @@ -12363,7 +12621,7 @@ See files with prefix @file{i-} in the distributed library. @sp 1 @cartouche @noindent -@strong{83}. The types @code{Floating}, @code{Long_Floating}, +@strong{84}. The types @code{Floating}, @code{Long_Floating}, @code{Binary}, @code{Long_Binary}, @code{Decimal_ Element}, and @code{COBOL_Character}; and the initialization of the variables @code{Ada_To_COBOL} and @code{COBOL_To_Ada}, in @@ -12391,7 +12649,7 @@ For initialization, see the file @file{i-cobol.ads} in the distributed library. @sp 1 @cartouche @noindent -@strong{84}. Support for access to machine instructions. See C.1(1). +@strong{85}. Support for access to machine instructions. See C.1(1). @end cartouche @noindent See documentation in file @file{s-maccod.ads} in the distributed library. @@ -12399,7 +12657,7 @@ See documentation in file @file{s-maccod.ads} in the distributed library. @sp 1 @cartouche @noindent -@strong{85}. Implementation-defined aspects of access to machine +@strong{86}. Implementation-defined aspects of access to machine operations. See C.1(9). @end cartouche @noindent @@ -12408,7 +12666,7 @@ See documentation in file @file{s-maccod.ads} in the distributed library. @sp 1 @cartouche @noindent -@strong{86}. Implementation-defined aspects of interrupts. See C.3(2). +@strong{87}. Implementation-defined aspects of interrupts. See C.3(2). @end cartouche @noindent Interrupts are mapped to signals or conditions as appropriate. See @@ -12419,7 +12677,7 @@ on the interrupts supported on a particular target. @sp 1 @cartouche @noindent -@strong{87}. Implementation-defined aspects of pre-elaboration. See +@strong{88}. Implementation-defined aspects of pre-elaboration. See C.4(13). @end cartouche @noindent @@ -12429,7 +12687,7 @@ except under control of the debugger. @sp 1 @cartouche @noindent -@strong{88}. The semantics of pragma @code{Discard_Names}. See C.5(7). +@strong{89}. The semantics of pragma @code{Discard_Names}. See C.5(7). @end cartouche @noindent Pragma @code{Discard_Names} causes names of enumeration literals to @@ -12440,7 +12698,7 @@ Pos values. @sp 1 @cartouche @noindent -@strong{89}. The result of the @code{Task_Identification.Image} +@strong{90}. The result of the @code{Task_Identification.Image} attribute. See C.7.1(7). @end cartouche @noindent @@ -12470,7 +12728,7 @@ virtual address of the control block of the task. @sp 1 @cartouche @noindent -@strong{90}. The value of @code{Current_Task} when in a protected entry +@strong{91}. The value of @code{Current_Task} when in a protected entry or interrupt handler. See C.7.1(17). @end cartouche @noindent @@ -12480,7 +12738,7 @@ convenient thread, so the value of @code{Current_Task} is undefined. @sp 1 @cartouche @noindent -@strong{91}. The effect of calling @code{Current_Task} from an entry +@strong{92}. The effect of calling @code{Current_Task} from an entry body or interrupt handler. See C.7.1(19). @end cartouche @noindent @@ -12491,7 +12749,7 @@ executing the code. @sp 1 @cartouche @noindent -@strong{92}. Implementation-defined aspects of +@strong{93}. Implementation-defined aspects of @code{Task_Attributes}. See C.7.2(19). @end cartouche @noindent @@ -12500,7 +12758,7 @@ There are no implementation-defined aspects of @code{Task_Attributes}. @sp 1 @cartouche @noindent -@strong{93}. Values of all @code{Metrics}. See D(2). +@strong{94}. Values of all @code{Metrics}. See D(2). @end cartouche @noindent The metrics information for GNAT depends on the performance of the @@ -12515,7 +12773,7 @@ the required metrics. @sp 1 @cartouche @noindent -@strong{94}. The declarations of @code{Any_Priority} and +@strong{95}. The declarations of @code{Any_Priority} and @code{Priority}. See D.1(11). @end cartouche @noindent @@ -12524,7 +12782,7 @@ See declarations in file @file{system.ads}. @sp 1 @cartouche @noindent -@strong{95}. Implementation-defined execution resources. See D.1(15). +@strong{96}. Implementation-defined execution resources. See D.1(15). @end cartouche @noindent There are no implementation-defined execution resources. @@ -12532,7 +12790,7 @@ There are no implementation-defined execution resources. @sp 1 @cartouche @noindent -@strong{96}. Whether, on a multiprocessor, a task that is waiting for +@strong{97}. Whether, on a multiprocessor, a task that is waiting for access to a protected object keeps its processor busy. See D.2.1(3). @end cartouche @noindent @@ -12542,7 +12800,7 @@ object does not keep its processor busy. @sp 1 @cartouche @noindent -@strong{97}. The affect of implementation defined execution resources +@strong{98}. The affect of implementation defined execution resources on task dispatching. See D.2.1(9). @end cartouche @noindent @@ -12553,7 +12811,7 @@ underlying operating system. @sp 1 @cartouche @noindent -@strong{98}. Implementation-defined @code{policy_identifiers} allowed +@strong{99}. Implementation-defined @code{policy_identifiers} allowed in a pragma @code{Task_Dispatching_Policy}. See D.2.2(3). @end cartouche @noindent @@ -12563,7 +12821,7 @@ pragma. @sp 1 @cartouche @noindent -@strong{99}. Implementation-defined aspects of priority inversion. See +@strong{100}. Implementation-defined aspects of priority inversion. See D.2.2(16). @end cartouche @noindent @@ -12573,7 +12831,7 @@ of delay expirations for lower priority tasks. @sp 1 @cartouche @noindent -@strong{100}. Implementation-defined task dispatching. See D.2.2(18). +@strong{101}. Implementation-defined task dispatching. See D.2.2(18). @end cartouche @noindent The policy is the same as that of the underlying threads implementation. @@ -12581,7 +12839,7 @@ The policy is the same as that of the underlying threads implementation. @sp 1 @cartouche @noindent -@strong{101}. Implementation-defined @code{policy_identifiers} allowed +@strong{102}. Implementation-defined @code{policy_identifiers} allowed in a pragma @code{Locking_Policy}. See D.3(4). @end cartouche @noindent @@ -12598,7 +12856,7 @@ concurrently. @sp 1 @cartouche @noindent -@strong{102}. Default ceiling priorities. See D.3(10). +@strong{103}. Default ceiling priorities. See D.3(10). @end cartouche @noindent The ceiling priority of protected objects of the type @@ -12608,7 +12866,7 @@ Reference Manual D.3(10), @sp 1 @cartouche @noindent -@strong{103}. The ceiling of any protected object used internally by +@strong{104}. The ceiling of any protected object used internally by the implementation. See D.3(16). @end cartouche @noindent @@ -12618,7 +12876,7 @@ The ceiling priority of internal protected objects is @sp 1 @cartouche @noindent -@strong{104}. Implementation-defined queuing policies. See D.4(1). +@strong{105}. Implementation-defined queuing policies. See D.4(1). @end cartouche @noindent There are no implementation-defined queuing policies. @@ -12626,7 +12884,7 @@ There are no implementation-defined queuing policies. @sp 1 @cartouche @noindent -@strong{105}. On a multiprocessor, any conditions that cause the +@strong{106}. 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). @end cartouche @@ -12637,7 +12895,7 @@ processor, there are no further delays. @sp 1 @cartouche @noindent -@strong{106}. Any operations that implicitly require heap storage +@strong{107}. Any operations that implicitly require heap storage allocation. See D.7(8). @end cartouche @noindent @@ -12647,7 +12905,7 @@ task creation. @sp 1 @cartouche @noindent -@strong{107}. Implementation-defined aspects of pragma +@strong{108}. Implementation-defined aspects of pragma @code{Restrictions}. See D.7(20). @end cartouche @noindent @@ -12656,7 +12914,7 @@ There are no such implementation-defined aspects. @sp 1 @cartouche @noindent -@strong{108}. Implementation-defined aspects of package +@strong{109}. Implementation-defined aspects of package @code{Real_Time}. See D.8(17). @end cartouche @noindent @@ -12665,7 +12923,7 @@ There are no implementation defined aspects of package @code{Real_Time}. @sp 1 @cartouche @noindent -@strong{109}. Implementation-defined aspects of +@strong{110}. Implementation-defined aspects of @code{delay_statements}. See D.9(8). @end cartouche @noindent @@ -12675,7 +12933,7 @@ delayed (see D.9(7)). @sp 1 @cartouche @noindent -@strong{110}. The upper bound on the duration of interrupt blocking +@strong{111}. The upper bound on the duration of interrupt blocking caused by the implementation. See D.12(5). @end cartouche @noindent @@ -12685,7 +12943,7 @@ no cases is it more than 10 milliseconds. @sp 1 @cartouche @noindent -@strong{111}. The means for creating and executing distributed +@strong{112}. The means for creating and executing distributed programs. See E(5). @end cartouche @noindent @@ -12695,7 +12953,7 @@ distributed programs. See the GLADE reference manual for further details. @sp 1 @cartouche @noindent -@strong{112}. Any events that can result in a partition becoming +@strong{113}. Any events that can result in a partition becoming inaccessible. See E.1(7). @end cartouche @noindent @@ -12704,7 +12962,7 @@ See the GLADE reference manual for full details on such events. @sp 1 @cartouche @noindent -@strong{113}. The scheduling policies, treatment of priorities, and +@strong{114}. The scheduling policies, treatment of priorities, and management of shared resources between partitions in certain cases. See E.1(11). @end cartouche @@ -12715,7 +12973,7 @@ multi-partition execution. @sp 1 @cartouche @noindent -@strong{114}. Events that cause the version of a compilation unit to +@strong{115}. Events that cause the version of a compilation unit to change. See E.3(5). @end cartouche @noindent @@ -12728,7 +12986,7 @@ comments. @sp 1 @cartouche @noindent -@strong{115}. Whether the execution of the remote subprogram is +@strong{116}. Whether the execution of the remote subprogram is immediately aborted as a result of cancellation. See E.4(13). @end cartouche @noindent @@ -12738,7 +12996,7 @@ a distributed application. @sp 1 @cartouche @noindent -@strong{116}. Implementation-defined aspects of the PCS@. See E.5(25). +@strong{117}. Implementation-defined aspects of the PCS@. See E.5(25). @end cartouche @noindent See the GLADE reference manual for a full description of all implementation @@ -12747,7 +13005,7 @@ defined aspects of the PCS@. @sp 1 @cartouche @noindent -@strong{117}. Implementation-defined interfaces in the PCS@. See +@strong{118}. Implementation-defined interfaces in the PCS@. See E.5(26). @end cartouche @noindent @@ -12757,7 +13015,7 @@ implementation defined interfaces. @sp 1 @cartouche @noindent -@strong{118}. The values of named numbers in the package +@strong{119}. The values of named numbers in the package @code{Decimal}. See F.2(7). @end cartouche @noindent @@ -12777,7 +13035,7 @@ implementation defined interfaces. @sp 1 @cartouche @noindent -@strong{119}. The value of @code{Max_Picture_Length} in the package +@strong{120}. The value of @code{Max_Picture_Length} in the package @code{Text_IO.Editing}. See F.3.3(16). @end cartouche @noindent @@ -12786,7 +13044,7 @@ implementation defined interfaces. @sp 1 @cartouche @noindent -@strong{120}. The value of @code{Max_Picture_Length} in the package +@strong{121}. The value of @code{Max_Picture_Length} in the package @code{Wide_Text_IO.Editing}. See F.3.4(5). @end cartouche @noindent @@ -12795,7 +13053,7 @@ implementation defined interfaces. @sp 1 @cartouche @noindent -@strong{121}. The accuracy actually achieved by the complex elementary +@strong{122}. The accuracy actually achieved by the complex elementary functions and by other complex arithmetic operations. See G.1(1). @end cartouche @noindent @@ -12805,7 +13063,7 @@ operations. Only fast math mode is currently supported. @sp 1 @cartouche @noindent -@strong{122}. The sign of a zero result (or a component thereof) from +@strong{123}. The sign of a zero result (or a component thereof) from any operator or function in @code{Numerics.Generic_Complex_Types}, when @code{Real'Signed_Zeros} is True. See G.1.1(53). @end cartouche @@ -12816,7 +13074,7 @@ implementation advice. @sp 1 @cartouche @noindent -@strong{123}. The sign of a zero result (or a component thereof) from +@strong{124}. The sign of a zero result (or a component thereof) from any operator or function in @code{Numerics.Generic_Complex_Elementary_Functions}, when @code{Real'Signed_Zeros} is @code{True}. See G.1.2(45). @@ -12828,7 +13086,7 @@ implementation advice. @sp 1 @cartouche @noindent -@strong{124}. Whether the strict mode or the relaxed mode is the +@strong{125}. Whether the strict mode or the relaxed mode is the default. See G.2(2). @end cartouche @noindent @@ -12838,7 +13096,7 @@ provides a highly efficient implementation of strict mode. @sp 1 @cartouche @noindent -@strong{125}. The result interval in certain cases of fixed-to-float +@strong{126}. The result interval in certain cases of fixed-to-float conversion. See G.2.1(10). @end cartouche @noindent @@ -12849,7 +13107,7 @@ floating-point format. @sp 1 @cartouche @noindent -@strong{126}. The result of a floating point arithmetic operation in +@strong{127}. The result of a floating point arithmetic operation in overflow situations, when the @code{Machine_Overflows} attribute of the result type is @code{False}. See G.2.1(13). @end cartouche @@ -12866,7 +13124,7 @@ properly generated. @sp 1 @cartouche @noindent -@strong{127}. The result interval for division (or exponentiation by a +@strong{128}. 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). @end cartouche @@ -12876,7 +13134,7 @@ Not relevant, division is IEEE exact. @sp 1 @cartouche @noindent -@strong{128}. The definition of close result set, which determines the +@strong{129}. The definition of close result set, which determines the accuracy of certain fixed point multiplications and divisions. See G.2.3(5). @end cartouche @@ -12889,7 +13147,7 @@ is converted to the target type. @sp 1 @cartouche @noindent -@strong{129}. Conditions on a @code{universal_real} operand of a fixed +@strong{130}. Conditions on a @code{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). @end cartouche @@ -12901,7 +13159,7 @@ representable in 64-bits. @sp 1 @cartouche @noindent -@strong{130}. The result of a fixed point arithmetic operation in +@strong{131}. The result of a fixed point arithmetic operation in overflow situations, when the @code{Machine_Overflows} attribute of the result type is @code{False}. See G.2.3(27). @end cartouche @@ -12912,7 +13170,7 @@ types. @sp 1 @cartouche @noindent -@strong{131}. The result of an elementary function reference in +@strong{132}. The result of an elementary function reference in overflow situations, when the @code{Machine_Overflows} attribute of the result type is @code{False}. See G.2.4(4). @end cartouche @@ -12922,7 +13180,7 @@ IEEE infinite and Nan values are produced as appropriate. @sp 1 @cartouche @noindent -@strong{132}. The value of the angle threshold, within which certain +@strong{133}. 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 error bound. See G.2.4(10). @@ -12933,7 +13191,7 @@ Information on this subject is not yet available. @sp 1 @cartouche @noindent -@strong{133}. The accuracy of certain elementary functions for +@strong{134}. The accuracy of certain elementary functions for parameters beyond the angle threshold. See G.2.4(10). @end cartouche @noindent @@ -12942,7 +13200,7 @@ Information on this subject is not yet available. @sp 1 @cartouche @noindent -@strong{134}. The result of a complex arithmetic operation or complex +@strong{135}. The result of a complex arithmetic operation or complex elementary function reference in overflow situations, when the @code{Machine_Overflows} attribute of the corresponding real type is @code{False}. See G.2.6(5). @@ -12953,7 +13211,7 @@ IEEE infinite and Nan values are produced as appropriate. @sp 1 @cartouche @noindent -@strong{135}. The accuracy of certain complex arithmetic operations and +@strong{136}. 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). @end cartouche @@ -12963,7 +13221,7 @@ Information on those subjects is not yet available. @sp 1 @cartouche @noindent -@strong{136}. Information regarding bounded errors and erroneous +@strong{137}. Information regarding bounded errors and erroneous execution. See H.2(1). @end cartouche @noindent @@ -12972,7 +13230,7 @@ Information on this subject is not yet available. @sp 1 @cartouche @noindent -@strong{137}. Implementation-defined aspects of pragma +@strong{138}. Implementation-defined aspects of pragma @code{Inspection_Point}. See H.3.2(8). @end cartouche @noindent @@ -12982,7 +13240,7 @@ be examined by the debugger at the inspection point. @sp 1 @cartouche @noindent -@strong{138}. Implementation-defined aspects of pragma +@strong{139}. Implementation-defined aspects of pragma @code{Restrictions}. See H.4(25). @end cartouche @noindent @@ -12993,7 +13251,7 @@ generated code. Checks must suppressed by use of pragma @code{Suppress}. @sp 1 @cartouche @noindent -@strong{139}. Any restrictions on pragma @code{Restrictions}. See +@strong{140}. Any restrictions on pragma @code{Restrictions}. See H.4(27). @end cartouche @noindent @@ -16991,9 +17249,11 @@ is specifically authorized by the Ada Reference Manual @cindex Formal container for doubly linked lists @noindent -This child of @code{Ada.Containers} defines a modified version of the Ada 2005 -container for doubly linked lists, meant to facilitate formal verification of -code using such containers. +This child of @code{Ada.Containers} defines a modified version of the +Ada 2005 container for doubly linked lists, meant to facilitate formal +verification of code using such containers. The specification of this +unit is compatible with SPARK 2014. Note that the API of this unit may +be subject to incompatible changes as SPARK 2014 evolves. @node Ada.Containers.Formal_Hashed_Maps (a-cfhama.ads) @section @code{Ada.Containers.Formal_Hashed_Maps} (@file{a-cfhama.ads}) @@ -17001,9 +17261,11 @@ code using such containers. @cindex Formal container for hashed maps @noindent -This child of @code{Ada.Containers} defines a modified version of the Ada 2005 -container for hashed maps, meant to facilitate formal verification of -code using such containers. +This child of @code{Ada.Containers} defines a modified version of the +Ada 2005 container for hashed maps, meant to facilitate formal +verification of code using such containers. The specification of this +unit is compatible with SPARK 2014. Note that the API of this unit may +be subject to incompatible changes as SPARK 2014 evolves. @node Ada.Containers.Formal_Hashed_Sets (a-cfhase.ads) @section @code{Ada.Containers.Formal_Hashed_Sets} (@file{a-cfhase.ads}) @@ -17011,9 +17273,11 @@ code using such containers. @cindex Formal container for hashed sets @noindent -This child of @code{Ada.Containers} defines a modified version of the Ada 2005 -container for hashed sets, meant to facilitate formal verification of -code using such containers. +This child of @code{Ada.Containers} defines a modified version of the +Ada 2005 container for hashed sets, meant to facilitate formal +verification of code using such containers. The specification of this +unit is compatible with SPARK 2014. Note that the API of this unit may +be subject to incompatible changes as SPARK 2014 evolves. @node Ada.Containers.Formal_Ordered_Maps (a-cforma.ads) @section @code{Ada.Containers.Formal_Ordered_Maps} (@file{a-cforma.ads}) @@ -17021,9 +17285,11 @@ code using such containers. @cindex Formal container for ordered maps @noindent -This child of @code{Ada.Containers} defines a modified version of the Ada 2005 -container for ordered maps, meant to facilitate formal verification of -code using such containers. +This child of @code{Ada.Containers} defines a modified version of the +Ada 2005 container for ordered maps, meant to facilitate formal +verification of code using such containers. The specification of this +unit is compatible with SPARK 2014. Note that the API of this unit may +be subject to incompatible changes as SPARK 2014 evolves. @node Ada.Containers.Formal_Ordered_Sets (a-cforse.ads) @section @code{Ada.Containers.Formal_Ordered_Sets} (@file{a-cforse.ads}) @@ -17031,9 +17297,11 @@ code using such containers. @cindex Formal container for ordered sets @noindent -This child of @code{Ada.Containers} defines a modified version of the Ada 2005 -container for ordered sets, meant to facilitate formal verification of -code using such containers. +This child of @code{Ada.Containers} defines a modified version of the +Ada 2005 container for ordered sets, meant to facilitate formal +verification of code using such containers. The specification of this +unit is compatible with SPARK 2014. Note that the API of this unit may +be subject to incompatible changes as SPARK 2014 evolves. @node Ada.Containers.Formal_Vectors (a-cofove.ads) @section @code{Ada.Containers.Formal_Vectors} (@file{a-cofove.ads}) @@ -17041,9 +17309,11 @@ code using such containers. @cindex Formal container for vectors @noindent -This child of @code{Ada.Containers} defines a modified version of the Ada 2005 -container for vectors, meant to facilitate formal verification of -code using such containers. +This child of @code{Ada.Containers} defines a modified version of the +Ada 2005 container for vectors, meant to facilitate formal +verification of code using such containers. The specification of this +unit is compatible with SPARK 2014. Note that the API of this unit may +be subject to incompatible changes as SPARK 2014 evolves. @node Ada.Command_Line.Environment (a-colien.ads) @section @code{Ada.Command_Line.Environment} (@file{a-colien.ads}) @@ -18611,6 +18881,19 @@ occurrence has no message, and the simple name of the exception identity contains @samp{Foreign_Exception}. Finalization and awaiting dependent tasks works properly when such foreign exceptions are propagated. +It is also possible to import a C++ exception using the following syntax: + +@smallexample @c ada +LOCAL_NAME : exception; +pragma Import (Cpp, + [Entity =>] LOCAL_NAME, + [External_Name =>] static_string_EXPRESSION); +@end smallexample + +@noindent +The @code{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 @section Interfacing to COBOL diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 40ffc35dacd..a82f20b08c7 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -179,6 +179,9 @@ AdaCore@* * Tools Supporting Project Files:: * The Cross-Referencing Tools gnatxref and gnatfind:: * The GNAT Pretty-Printer gnatpp:: +@ifclear vms +* The Ada-to-XML converter gnat2xml:: +@end ifclear * The GNAT Metrics Tool gnatmetric:: * File Name Krunching with gnatkr:: * Preprocessing with gnatprep:: @@ -241,7 +244,7 @@ By default, @value{EDITION} assumes Ada 2012, but you can override with a compiler switch (@pxref{Compiling Different Versions of Ada}) to explicitly specify the language version. Throughout this manual, references to ``Ada'' without a year suffix -apply to both all Ada 95/2005/2012 versions of the language. +apply to all Ada 95/2005/2012 versions of the language. @ifclear FSFEDITION For ease of exposition, ``@value{EDITION}'' will be referred to simply as @@ -328,6 +331,12 @@ way to navigate through sources. version of an Ada source file with control over casing, indentation, comment placement, and other elements of program presentation style. +@ifclear vms +@item +@ref{The Ada-to-XML converter gnat2xml}, shows how to convert Ada +source code into XML. +@end ifclear + @item @ref{The GNAT Metrics Tool gnatmetric}, shows how to compute various metrics for an Ada source file, such as the number of types and subprograms, @@ -3816,9 +3825,120 @@ temporary use of special test software. @cindex @option{-gnateS} (@command{gcc}) Synonym of @option{-fdump-scos}, kept for backards compatibility. -@item ^-gnatet^/TARGET_DEPENDENT_INFO^ -@cindex @option{-gnatet} (@command{gcc}) -Generate target dependent information. +@item -gnatet=@var{path} +@cindex @option{-gnatet=file} (@command{gcc}) +Generate target dependent information. The format of the output file is +described in the section about switch @option{-gnateT}. + +@item -gnateT=@var{path} +@cindex @option{-gnateT} (@command{gcc}) +Read target dependent information, such as endianness or sizes and alignments +of base type. If this switch is passed, the default target dependent +information of the compiler is replaced by the one read from the input file. +This is used by tools other than the compiler, e.g. to do +semantic analysis of programs that will run on some other target than +the machine on which the tool is run. + +The following target dependent values should be defined, +where @code{Nat} denotes a natural integer value, @code{Pos} denotes a +positive integer value, and fields marked with a question mark are +boolean fields, where a value of 0 is False, and a value of 1 is True: + +@smallexample +Bits_BE : Nat; -- Bits stored big-endian? +Bits_Per_Unit : Pos; -- Bits in a storage unit +Bits_Per_Word : Pos; -- Bits in a word +Bytes_BE : Nat; -- Bytes stored big-endian? +Char_Size : Pos; -- Standard.Character'Size +Double_Float_Alignment : Nat; -- Alignment of double float +Double_Scalar_Alignment : Nat; -- Alignment of double length scalar +Double_Size : Pos; -- Standard.Long_Float'Size +Float_Size : Pos; -- Standard.Float'Size +Float_Words_BE : Nat; -- Float words stored big-endian? +Int_Size : Pos; -- Standard.Integer'Size +Long_Double_Size : Pos; -- Standard.Long_Long_Float'Size +Long_Long_Size : Pos; -- Standard.Long_Long_Integer'Size +Long_Size : Pos; -- Standard.Long_Integer'Size +Maximum_Alignment : Pos; -- Maximum permitted alignment +Max_Unaligned_Field : Pos; -- Maximum size for unaligned bit field +Pointer_Size : Pos; -- System.Address'Size +Short_Size : Pos; -- Standard.Short_Integer'Size +Strict_Alignment : Nat; -- Strict alignment? +System_Allocator_Alignment : Nat; -- Alignment for malloc calls +Wchar_T_Size : Pos; -- Interfaces.C.wchar_t'Size +Words_BE : Nat; -- Words stored big-endian? +@end smallexample + +The format of the input file is as follows. First come the values of +the variables defined above, with one line per value: + +@smallexample +name value +@end smallexample + +where @code{name} is the name of the parameter, spelled out in full, +and cased as in the above list, and @code{value} is an unsigned decimal +integer. Two or more blanks separates the name from the value. + +All the variables must be present, in alphabetical order (i.e. the +same order as the list above). + +Then there is a blank line to separate the two parts of the file. Then +come the lines showing the floating-point types to be registered, with +one line per registered mode: + +@smallexample +name digs float_rep size alignment +@end smallexample + +where @code{name} is the string name of the type (which can have +single spaces embedded in the name (e.g. long double), @code{digs} is +the number of digits for the floating-point type, @code{float_rep} is +the float representation (I/V/A for IEEE-754-Binary, Vax_Native, +AAMP), @code{size} is the size in bits, @code{alignment} is the +alignment in bits. The name is followed by at least two blanks, fields +are separated by at least one blank, and a LF character immediately +follows the alignment field. + +Here is an example of target parametrization file: + +@smallexample +Bits_BE 0 +Bits_Per_Unit 8 +Bits_Per_Word 64 +Bytes_BE 0 +Char_Size 8 +Double_Float_Alignment 0 +Double_Scalar_Alignment 0 +Double_Size 64 +Float_Size 32 +Float_Words_BE 0 +Int_Size 64 +Long_Double_Size 128 +Long_Long_Size 64 +Long_Size 64 +Maximum_Alignment 16 +Max_Unaligned_Field 64 +Pointer_Size 64 +Short_Size 16 +Strict_Alignment 0 +System_Allocator_Alignment 16 +Wchar_T_Size 32 +Words_BE 0 + +float 15 I 64 64 +double 15 I 64 64 +long double 18 I 80 128 +TF 33 I 128 128 +@end smallexample + +@item -gnateu +@cindex @option{-gnateu} (@command{gcc}) +Ignore unrecognized validity, warning, and style switches that +appear after this switch is given. This may be useful when +compiling sources developed on a later version of the compiler +with an earlier version. Of course the earlier version must +support this switch. @item ^-gnateV^/PARAMETER_VALIDITY_CHECK^ @cindex @option{-gnateV} (@command{gcc}) @@ -4773,9 +4893,7 @@ individually controlled. The warnings that are not turned on by this switch are @option{-gnatwd} (implicit dereferencing), @option{-gnatwh} (hiding), -@ifclear vms @option{-gnatw.d} (tag warnings with -gnatw switch) -@end ifclear @option{-gnatw.h} (holes (gaps) in record layouts) @option{-gnatw.i} (overlapping actuals), @option{-gnatw.k} (redefinition of names in standard), @@ -4924,7 +5042,6 @@ this warning option. This switch suppresses warnings for implicit dereferences in indexed components, slices, and selected components. -@ifclear vms @item -gnatw.d @emph{Activate tagging of warning messages.} @cindex @option{-gnatw.d} (@command{gcc}) @@ -4940,7 +5057,6 @@ affected by the use of @code{-gnatwa}. If this switch is set, then warning messages return to the default mode in which warnings are not tagged as described above for @code{-gnatw.d}. -@end ifclear @item -gnatwe @emph{Treat warnings and style checks as errors.} @@ -5622,6 +5738,25 @@ This warning can also be turned on using @option{-gnatwa}. This switch suppresses the warnings intended to help in identifying incompatibilities between Ada language versions. +@item -gnatw.y +@emph{Activate information messages for why package spec needs body} +@cindex @option{-gnatw.y} (@command{gcc}) +@cindex Package spec needing 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 +of a procedure specification requiring a completion. This switch +causes information messages to be output showing why a package +specification requires a body. This can be useful in the case of +a large package specification which is unexpectedly requiring a +body. The default is that such information messages are not output. + +@item -gnatw.Y +@emph{Disable information messages for why package spec needs body} +@cindex @option{-gnatw.Y} (@command{gcc}) +@cindex No information messages for why package spec needs body +This switch suppresses the output of information messages showing why +a package specification needs a body. + @item -gnatwz @emph{Activate warnings on unchecked conversions.} @cindex @option{-gnatwz} (@command{gcc}) @@ -7589,11 +7724,23 @@ Examples of valid lines in a preprocessor data file: Define or redefine a preprocessing symbol, associated with value. If no value is given on the command line, then the value of the symbol is @code{True}. A symbol is an identifier, following normal Ada (case-insensitive) -rules for its syntax, and value is any sequence (including an empty sequence) -of characters from the set (letters, digits, period, underline). +rules for its syntax, and value is either an arbitrary string between double +quotes or any sequence (including an empty sequence) of characters from the +set (letters, digits, period, underline). Ada reserved words may be used as symbols, with the exceptions of @code{if}, @code{else}, @code{elsif}, @code{end}, @code{and}, @code{or} and @code{then}. +@ifclear vms +@noindent +Examples: + +@smallexample + -gnateDToto=Titi + -gnateDFoo + -gnateDFoo=\"Foo-Bar\" +@end smallexample +@end ifclear + @noindent A symbol declared with this ^switch^switch^ on the command line replaces a symbol with the same name either in a definition file or specified with a @@ -9999,6 +10146,7 @@ some guidelines on debugging optimized code. * Vectorization of loops:: * Other Optimization Switches:: * Optimization and Strict Aliasing:: +* Aliased Variables and Optimization:: @ifset vms * Coverage Analysis:: @@ -10797,6 +10945,58 @@ has on size and speed of the code. If you really need to use review any uses of unchecked conversion of access types, particularly if you are getting the warnings described above. +@node Aliased Variables and Optimization +@subsection Aliased Variables and Optimization +@cindex Aliasing +There are scenarios in which programs may +use low level techniques to modify variables +that otherwise might be considered to be unassigned. For example, +a variable can be passed to a procedure by reference, which takes +the address of the parameter and uses the address to modify the +variable's value, even though it is passed as an IN parameter. +Consider the following example: + +@smallexample @c ada +procedure P is + Max_Length : constant Natural := 16; + type Char_Ptr is access all Character; + + procedure Get_String(Buffer: Char_Ptr; Size : Integer); + pragma Import (C, Get_String, "get_string"); + + Name : aliased String (1 .. Max_Length) := (others => ' '); + Temp : Char_Ptr; + + function Addr (S : String) return Char_Ptr is + function To_Char_Ptr is + new Ada.Unchecked_Conversion (System.Address, Char_Ptr); + begin + return To_Char_Ptr (S (S'First)'Address); + end; + +begin + Temp := Addr (Name); + Get_String (Temp, Max_Length); +end; +@end smallexample + +@noindent +where Get_String is a C function that uses the address in Temp to +modify the variable @code{Name}. This code is dubious, and arguably +erroneous, and the compiler would be entitled to assume that +@code{Name} is never modified, and generate code accordingly. + +However, in practice, this would cause some existing code that +seems to work with no optimization to start failing at high +levels of optimzization. + +What the compiler does for such cases is to assume that marking +a variable as aliased indicates that some "funny business" may +be going on. The optimizer recognizes the aliased keyword and +inhibits optimizations that assume the value cannot be assigned. +This means that the above example will in fact "work" reliably, +that is, it will produce the expected results. + @ifset vms @node Coverage Analysis @subsection Coverage Analysis @@ -13622,6 +13822,14 @@ version as output. You can specify various style directives via switches; e.g., identifier case conventions, rules of indentation, and comment layout. +Note: A newly-redesigned set of formatting algorithms used by gnatpp +is now available. +To invoke the new experimental formatting algorithms, use the +@option{--pp-new} switch. +The default is @option{--pp-old}; that is, gnatpp uses the old +formatting algorithms by default. +We intend to make @option{--pp-new} the default at some point. + To produce a reformatted file, @command{gnatpp} generates and uses the ASIS tree for the input source and thus requires the input to be syntactically and semantically legal. @@ -14230,6 +14438,14 @@ Display Copyright and version, then exit disregarding all other options. @cindex @option{--help} @command{gnatpp} Display usage, then exit disregarding all other options. +@item --pp-new +@cindex @option{--pp-new} @command{gnatpp} +Use the new experimental formatting algorithms. + +@item --pp-old +@cindex @option{--pp-old} @command{gnatpp} +Use the old formatting algorithms. This is the default. + @item ^-files @var{filename}^/FILES=@var{filename}^ @cindex @option{^-files^/FILES^} (@code{gnatpp}) Take the argument source files from the specified file. This file should be an @@ -14786,6 +15002,468 @@ end Test; @end cartouche @end smallexample +@ifclear vms +@c ********************************* +@node The Ada-to-XML converter gnat2xml +@chapter The Ada-to-XML converter @command{gnat2xml} +@findex gnat2xml +@cindex XML generation + +@noindent +The @command{gnat2xml} tool is an ASIS-based utility that converts +Ada source code into XML. + +@menu +* Switches for gnat2xml:: +* Driving gnat2xml with gnatmake or gprbuild:: +* Other Programs:: +* Structure of the XML:: +@end menu + +@node Switches for gnat2xml +@section Switches for @command{gnat2xml} + +@noindent +@command{gnat2xml} takes Ada source code as input, and produces XML +that conforms to the schema. + +Usage: + +@smallexample +gnat2xml [options] files +@end smallexample + +``files'' are the Ada source file names. + +@noindent +Options: +@smallexample +-h +--help -- generate usage information and quit, ignoring all other options + +-mdir -- generate one .xml file for each Ada source file, in directory + @file{dir}. (Default is to generate the XML to standard output.) + +-q -- debugging version, with interspersed source, and a more + compact representation of "sloc". This version does not conform + to any schema. + +-I <include-dir> + directories to search for dependencies + You can also set the ADA_INCLUDE_PATH environment variable for this. + +-v -- verbose (print out the command line options, and the names of + output files as they are generated). + +-t -- do not delete tree files when done (they are deleted by default). + +-cargs ... -- options to pass to gcc +@end smallexample + +@noindent +You can generate the ``tree files'' ahead of time using the -gnatct switch: + +@smallexample +gnatmake -gnat2012 -gnatct *.ad[sb] +@end smallexample + +@noindent +If tree files do not exist, @command{gnat2xml} will create them by running gcc. +See the ASIS documentation for more information on tree files. + +Example: + +@smallexample +mkdir xml-files +gnat2xml -v -mxml-files *.ad[sb] -cargs -gnat2012 +@end smallexample + +@noindent +The above will create *.xml files in the @file{xml-files} subdirectory. +For example, if there is an Ada package Mumble.Dumble, whose spec and +body source code lives in mumble-dumble.ads and mumble-dumble.adb, +the above will produce xml-files/mumble-dumble.ads.xml and +xml-files/mumble-dumble.adb.xml. + +@node Driving gnat2xml with gnatmake or gprbuild +@section Driving @command{gnat2xml} with @command{gnatmake} or @command{gprbuild} + +@noindent +You can use gnatmake or gprbuild to drive @command{gnat2xml} to get +incremental updates of the XML files on a per-source-file basis. For +example, if you already have a bunch of XML files, and then you change +one source file, it will regenerate XML files only for that source +file, and other source files that depend on it. Gnatmake and gprbuild +take care of tracking inter-file dependencies. For example, if +this.adb says @code{with That;}, then this.adb depends on that.ads. + +To do this, you tell gnatmake/gprbuild to pretend that +@command{gnat2xml} is the Ada compiler (instead of using gcc as the +Ada compiler, as is normal). + +To tell gnatmake to use @command{gnat2xml} instead of gcc as the +``compiler'', for example: + +@smallexample +gnatmake -gnatc *.adb --GCC="gnat2xml -t -mxml" +@end smallexample + +@noindent +The @option{--GCC=} switch tells gnatmake that the ``compiler'' to run +is @command{gnat2xml -t -mxml}. The @option{-t} switch means to keep the tree +files, so they can be reused on the next run. (@command{gnat2xml} +deletes them by default.) As usual, @option{-mxml} means to put the +XML files in the @file{xml} subdirectory. + +You must give the @option{-gnatc} switch to gnatmake, which means +``compile only; do not generate object code''. Otherwise, gnatmake will +complain about missing object (*.o) files; @command{gnat2xml} of +course does not generate *.o files. + +Using gprbuild is similar: you tell it to use @command{gnat2xml} +instead of gcc. First write a project file, such as my_project.gpr: + +@smallexample @c projectfile +project My_Project is + + package Compiler is + for Driver ("ada") use "gnat2xml"; + -- Use gnat2xml instead of the usual gcc. + + for Default_Switches ("ada") use ("-t", "-mxml"); + -- Same switches as in the gnatmake case. + end Compiler; + +end My_Project; +@end smallexample + +@noindent +Then: + +@smallexample @c projectfile +gprbuild --no-object-check -P my_project.gpr +@end smallexample + +@noindent +The @option{--no-object-check} switch serves the same purpose as +@option{-gnatc} in the gnatmake case --- it tells gprbuild not to +expect that the ``compiler'' (really @command{gnat2xml}) will produce +*.o files. + +See the gprbuild documentation for information on many other things +you can put in the project file, such as telling it where to find +the source files. + +@node Other Programs +@section Other Programs + +@noindent +The distribution includes two other programs that are related to +@command{gnat2xml}: + +@command{gnat2xsd} is the schema generator, which generates the schema +to standard output, based on the structure of Ada as encoded by +ASIS. You don't need to run @command{gnat2xsd} in order to use +@command{gnat2xml}. To generate the schema, type: + +@smallexample +gnat2xsd > ada-schema.xsd +@end smallexample + +@noindent +@command{gnat2xml} generates XML files that will validate against +@file{ada-schema.xsd}. + +@command{xml2gnat} is a back-translator that translates the XML back +into Ada source code. The Ada generated by @command{xml2gnat} has +identical semantics to the original Ada code passed to +@command{gnat2xml}. It is not textually identical, however --- for +example, no attempt is made to preserve the original indentation. + +@node Structure of the XML +@section Structure of the XML + +@noindent +The primary documentation for the structure of the XML generated by +@command{gnat2xml} is the schema (see @command{gnat2xsd} above). The +following documentation gives additional details needed to understand +the schema and therefore the XML. + +The elements listed under Defining Occurrences, Usage Occurrences, and +Other Elements represent the syntactic structure of the Ada program. +Element names are given in lower case, with the corresponding element +type Capitalized_Like_This. The element and element type names are +derived directly from the ASIS enumeration type Flat_Element_Kinds, +declared in Asis.Extensions.Flat_Kinds, with the leading ``An_'' or ``A_'' +removed. For example, the ASIS enumeration literal +An_Assignment_Statement corresponds to the XML element +assignment_statement of XML type Assignment_Statement. + +To understand the details of the schema and the corresponding XML, it is +necessary to understand the ASIS standard, as well as the GNAT-specific +extension to ASIS. + +A defining occurrence is an identifier (or character literal or operator +symbol) declared by a declaration. A usage occurrence is an identifier +(or ...) that references such a declared entity. For example, in: + +@smallexample +type T is range 1..10; +X, Y : constant T := 1; +@end smallexample + +@noindent +The first ``T'' is the defining occurrence of a type. The ``X'' is the +defining occurrence of a constant, as is the ``Y'', and the second ``T'' is +a usage occurrence referring to the defining occurrence of T. + +Each element has a 'sloc' (source location), and subelements for each +syntactic subtree, reflecting the Ada grammar as implemented by ASIS. +The types of subelements are as defined in the ASIS standard. For +example, for the right-hand side of an assignment_statement we have +the following comment in asis-statements.ads: + +@smallexample +------------------------------------------------------------------------------ +-- 18.3 function Assignment_Expression +------------------------------------------------------------------------------ + + function Assignment_Expression + (Statement : Asis.Statement) + return Asis.Expression; + +------------------------------------------------------------------------------ +... +-- Returns the expression from the right hand side of the assignment. +... +-- Returns Element_Kinds: +-- An_Expression +@end smallexample + +@noindent +The corresponding sub-element of type Assignment_Statement is: + +@smallexample +<xsd:element name="assignment_expression_q" type="Expression_Class"/> +@end smallexample + +@noindent +where Expression_Class is defined by an xsd:choice of all the +various kinds of expression. + +The 'sloc' of each element indicates the starting and ending line and +column numbers. Column numbers are character counts; that is, a tab +counts as 1, not as however many spaces it might expand to. + +Subelements of type Element have names ending in ``_q'' (for ASIS +``Query''), and those of type Element_List end in ``_ql'' (``Query returning +List''). + +Some subelements are ``Boolean''. For example, Private_Type_Definition +has has_abstract_q and has_limited_q, to indicate whether those +keywords are present, as in @code{type T is abstract limited +private;}. False is represented by a Nil_Element. True is represented +by an element type specific to that query (for example, Abstract and +Limited). + +The root of the tree is a Compilation_Unit, with attributes: + +@itemize @bullet +@item +unit_kind, unit_class, and unit_origin. These are strings that match the +enumeration literals of types Unit_Kinds, Unit_Classes, and Unit_Origins +in package Asis. + +@item +unit_full_name is the full expanded name of the unit, starting from a +root library unit. So for @code{package P.Q.R is ...}, +@code{unit_full_name="P.Q.R"}. Same for @code{separate (P.Q) package R is ...}. + +@item +def_name is the same as unit_full_name for library units; for subunits, +it is just the simple name. + +@item +source_file is the name of the Ada source file. For example, for +the spec of @code{P.Q.R}, @code{source_file="p-q-r.ads"}. This allows one to +interpret the source locations --- the ``sloc'' of all elements +within this Compilation_Unit refers to line and column numbers +within the named file. +@end itemize + +@noindent +Defining occurrences have these attributes: + +@itemize @bullet +@item +def_name is the simple name of the declared entity, as written in the Ada +source code. + +@item +def is a unique URI of the form: + + ada://kind/fully/qualified/name + +where: + + kind indicates the kind of Ada entity being declared (see below), and + + fully/qualified/name, is the fully qualified name of the Ada + entity, with each of ``fully'', ``qualified'', and ``name'' being + mangled for uniqueness. We do not document the mangling + algorithm, which is subject to change; we just guarantee that the + names are unique in the face of overloading. + +@item +type is the type of the declared object, or @code{null} for +declarations of things other than objects. +@end itemize + +@noindent +Usage occurrences have these attributes: + +@itemize @bullet +@item +ref_name is the same as the def_name of the corresponding defining +occurrence. This attribute is not of much use, because of +overloading; use ref for lookups, instead. + +@item +ref is the same as the def of the corresponding defining +occurrence. +@end itemize + +@noindent +In summary, @code{def_name} and @code{ref_name} are as in the source +code of the declaration, possibly overloaded, whereas @code{def} and +@code{ref} are unique-ified. + +Literal elements have this attribute: + +@itemize @bullet +@item +lit_val is the value of the literal as written in the source text, +appropriately escaped (e.g. @code{"} ---> @code{"}). This applies +only to numeric and string literals. Enumeration literals in Ada are +not really "literals" in the usual sense; they are usage occurrences, +and have ref_name and ref as described above. Note also that string +literals used as operator symbols are treated as defining or usage +occurrences, not as literals. +@end itemize + +@noindent +Elements that can syntactically represent names and expressions (which +includes usage occurrences, plus function calls and so forth) have this +attribute: + +@itemize @bullet +@item +type. If the element represents an expression or the name of an object, +'type' is the 'def' for the defining occurrence of the type of that +expression or name. Names of other kinds of entities, such as package +names and type names, do not have a type in Ada; these have type="null" +in the XML. +@end itemize + +@noindent +Pragma elements have this attribute: + +@itemize @bullet +@item +pragma_name is the name of the pragma. For language-defined pragmas, the +pragma name is redundant with the element kind (for example, an +assert_pragma element necessarily has pragma_name="Assert"). However, all +implementation-defined pragmas are lumped together in ASIS as a single +element kind (for example, the GNAT-specific pragma Unreferenced is +represented by an implementation_defined_pragma element with +pragma_name="Unreferenced"). +@end itemize + +@noindent +Defining occurrences of formal parameters and generic formal objects have this +attribute: + +@itemize @bullet +@item +mode indicates that the parameter is of mode 'in', 'in out', or 'out'. +@end itemize + +@noindent +The "kind" part of the "def" and "ref" attributes is taken from the ASIS +enumeration type Flat_Declaration_Kinds, declared in +Asis.Extensions.Flat_Kinds, with the leading "An_" or "A_" removed, and +any trailing "_Declaration" or "_Specification" removed. Thus, the +possible kinds are as follows: + +@smallexample +ordinary_type +task_type +protected_type +incomplete_type +tagged_incomplete_type +private_type +private_extension +subtype +variable +constant +deferred_constant +single_task +single_protected +integer_number +real_number +enumeration_literal +discriminant +component +loop_parameter +generalized_iterator +element_iterator +procedure +function +parameter +procedure_body +function_body +return_variable +return_constant +null_procedure +expression_function +package +package_body +object_renaming +exception_renaming +package_renaming +procedure_renaming +function_renaming +generic_package_renaming +generic_procedure_renaming +generic_function_renaming +task_body +protected_body +entry +entry_body +entry_index +procedure_body_stub +function_body_stub +package_body_stub +task_body_stub +protected_body_stub +exception +choice_parameter +generic_procedure +generic_function +generic_package +package_instantiation +procedure_instantiation +function_instantiation +formal_object +formal_type +formal_incomplete_type +formal_procedure +formal_function +formal_package +formal_package_declaration_with_box +@end smallexample +@end ifclear + @c ********************************* @node The GNAT Metrics Tool gnatmetric @chapter The GNAT Metrics Tool @command{gnatmetric} @@ -16154,6 +16832,11 @@ In this example, @i{expression} is defined by the following grammar: @i{expression} ::= <symbol> @i{expression} ::= <symbol> = "<value>" @i{expression} ::= <symbol> = <symbol> +@i{expression} ::= <symbol> = <integer> +@i{expression} ::= <symbol> > <integer> +@i{expression} ::= <symbol> >= <integer> +@i{expression} ::= <symbol> < <integer> +@i{expression} ::= <symbol> <= <integer> @i{expression} ::= <symbol> 'Defined @i{expression} ::= not @i{expression} @i{expression} ::= @i{expression} and @i{expression} @@ -16186,6 +16869,11 @@ symbol definition must be one of the (case-insensitive) literals corresponding lines are included, and if the value is false, they are excluded. +When comparing a symbol to an integer, the integer is any non negative +literal integer as defined in the Ada Reference Manual, such as 3, 16#FF# or +2#11#. The symbol value must also be a non negative integer. Integer values +in the range 0 .. 2**31-1 are supported. + The test (@i{expression} ::= <symbol> @code{'Defined}) is true only if the symbol has been defined in the definition file or by a @option{-D} switch on the command line. Otherwise, the test is false. @@ -18565,8 +19253,8 @@ by @command{gnatstub} to compile an argument source file. @item ^-gnatyM^/MAX_LINE_LENGTH=^@var{n} @cindex @option{^-gnatyM^/MAX_LINE_LENGTH^} (@command{gnatstub}) -(@var{n} is a non-negative integer). Set the maximum line length in the -body stub to @var{n}; the default is 79. The maximum value that can be +(@var{n} is a non-negative integer). Set the maximum line length that is +allowed in a source file. The default is 79. The maximum value that can be specified is 32767. Note that in the special case of configuration pragma files, the maximum is always 32767 regardless of whether or not this switch appears. @@ -21267,7 +21955,7 @@ end STB; @end smallexample @smallexample -$ gnatmake -g .\stb -bargs -E -largs -lgnat -laddr2line -lintl +$ gnatmake -g .\stb -bargs -E $ stb 0040149F in stb.p1 at stb.adb:8 @@ -26919,7 +27607,7 @@ The preprocessing language allows such constructs as @smallexample @group -#if DEBUG or PRIORITY > 4 then +#if DEBUG or else (PRIORITY > 4) then bunch of declarations #else completely different bunch of declarations diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 793feb95690..68262f447e4 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -265,9 +265,7 @@ procedure Gnatlink is end loop; Findex2 := File_Name'Last; - while Findex2 > Findex1 - and then File_Name (Findex2) /= '.' - loop + while Findex2 > Findex1 and then File_Name (Findex2) /= '.' loop Findex2 := Findex2 - 1; end loop; @@ -343,7 +341,8 @@ procedure Gnatlink is ------------------ procedure Process_Args is - Next_Arg : Integer; + Next_Arg : Integer; + Skip_Next : Boolean := False; -- Set to true if the next argument is to be added into the list of -- linker's argument without parsing it. @@ -637,8 +636,8 @@ procedure Gnatlink is Linker_Objects.Table (Linker_Objects.Last) := new String'(Arg); - -- If host object file, record object file - -- e.g. accept foo.o as well as foo.obj on VMS target + -- If host object file, record object file e.g. accept foo.o + -- as well as foo.obj on VMS target. elsif Arg'Length > Get_Object_Suffix.all'Length and then Arg @@ -684,8 +683,8 @@ procedure Gnatlink is and then Linker_Options.Last >= Linker_Options.First then Ali_File_Name := - new String'(Linker_Options.Table (Linker_Options.First).all & - ".ali"); + new String'(Linker_Options.Table (Linker_Options.First).all + & ".ali"); end if; end Process_Args; @@ -895,6 +894,7 @@ procedure Gnatlink is procedure Store_File_Context is use type System.CRTL.long; + begin RB_Next_Line := Next_Line; RB_Nfirst := Nfirst; @@ -995,9 +995,10 @@ procedure Gnatlink is Linker_Objects.Table (Linker_Objects.Last) := new String'(Next_Line (Nfirst .. Nlast)); - Link_Bytes := Link_Bytes + Nlast - Nfirst + 2; -- Nlast - Nfirst + 1, for the size, plus one for the space between -- each arguments. + + Link_Bytes := Link_Bytes + Nlast - Nfirst + 2; end loop; Objs_End := Linker_Objects.Last; @@ -1127,10 +1128,12 @@ procedure Gnatlink is elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat" or else Next_Line (Nfirst .. Nlast) = "-lgnarl" or else Next_Line (Nfirst .. Nlast) = "-lgnat" - or else Next_Line + or else + Next_Line (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) = Shared_Lib ("gnarl") - or else Next_Line + or else + Next_Line (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) = Shared_Lib ("gnat") then @@ -1138,8 +1141,8 @@ procedure Gnatlink is -- We will be looking for the static version of the library -- as it is in the same directory as the shared version. - if Next_Line (Nlast - Library_Version'Length + 1 .. Nlast) - = Library_Version + if Next_Line (Nlast - Library_Version'Length + 1 .. Nlast) = + Library_Version then -- Set Last to point to last character before the -- library version. @@ -1159,11 +1162,10 @@ procedure Gnatlink is File_Path : String_Access; Object_Lib_Extension : constant String := - Value (Object_Library_Ext_Ptr); + Value (Object_Library_Ext_Ptr); File_Name : constant String := "lib" & - Next_Line (Nfirst + 2 .. Last) & - Object_Lib_Extension; + Next_Line (Nfirst + 2 .. Last) & Object_Lib_Extension; Run_Path_Opt : constant String := Value (Run_Path_Option_Ptr); @@ -1179,9 +1181,9 @@ procedure Gnatlink is if File_Path /= null then if GNAT_Static then - -- If static gnatlib found, explicitly - -- specify to overcome possible linker - -- default usage of shared version. + -- If static gnatlib found, explicitly specify to + -- overcome possible linker default usage of shared + -- version. Linker_Options.Increment_Last; @@ -1191,9 +1193,9 @@ procedure Gnatlink is elsif GNAT_Shared then if Opt.Run_Path_Option then - -- If shared gnatlib desired, add the - -- appropriate system specific switch - -- so that it can be located at runtime. + -- If shared gnatlib desired, add appropriate + -- system specific switch so that it can be + -- located at runtime. if Run_Path_Opt'Length /= 0 then @@ -1204,6 +1206,7 @@ procedure Gnatlink is declare Path : String (1 .. File_Path'Length + 15); + Path_Last : constant Natural := File_Path'Length; @@ -1299,9 +1302,9 @@ procedure Gnatlink is Run_Path_Opt then -- We have found an already - -- specified run_path_option: we - -- will add to this switch, - -- because only one + -- specified run_path_option: + -- we will add to this + -- switch, because only one -- run_path_option should be -- specified. @@ -1378,9 +1381,8 @@ procedure Gnatlink is end if; else - -- If gnatlib library not found, then - -- add it anyway in case some other - -- mechanism may find it. + -- If gnatlib library not found, then add it anyway in + -- case some other mechanism may find it. Linker_Options.Increment_Last; Linker_Options.Table (Linker_Options.Last) := @@ -1872,8 +1874,9 @@ begin if Compile_Bind_File then Bind_Step : declare Success : Boolean; - Args : Argument_List - (1 .. Binder_Options_From_ALI.Last + Binder_Options.Last + 1); + + Args : Argument_List + (1 .. Binder_Options_From_ALI.Last + Binder_Options.Last + 1); begin for J in 1 .. Binder_Options_From_ALI.Last loop @@ -1954,8 +1957,7 @@ begin elsif RTX_RTSS_Kernel_Module_On_Target then - -- Remove flags not relevant for Microsoft linker and adapt some - -- others. + -- Remove irrelevant flags for Microsoft linker, adapt some others for J in reverse Linker_Options.First .. Linker_Options.Last loop @@ -1976,12 +1978,13 @@ begin -- Replace "-L" by its counterpart "/LIBPATH:" and UNIX "/" by -- Windows "\". + elsif Linker_Options.Table (J) (1 .. 2) = "-L" then declare Libpath_Option : constant String_Access := new String' ("/LIBPATH:" & - Linker_Options.Table (J) - (3 .. Linker_Options.Table (J).all'Last)); + Linker_Options.Table + (J) (3 .. Linker_Options.Table (J).all'Last)); begin for Index in 10 .. Libpath_Option'Last loop if Libpath_Option (Index) = '/' then @@ -1993,10 +1996,12 @@ begin end; -- Replace "-g" by "/DEBUG" + elsif Linker_Options.Table (J) (1 .. 2) = "-g" then Linker_Options.Table (J) := new String'("/DEBUG"); -- Replace "-o" by "/OUT:" + elsif Linker_Options.Table (J) (1 .. 2) = "-o" then Linker_Options.Table (J + 1) := new String' ("/OUT:" & Linker_Options.Table (J + 1).all); @@ -2007,6 +2012,7 @@ begin Num_Args := Num_Args - 1; -- Replace "--stack=" by "/STACK:" + elsif Linker_Options.Table (J) (1 .. 8) = "--stack=" then Linker_Options.Table (J) := new String' ("/STACK:" & @@ -2014,6 +2020,7 @@ begin (9 .. Linker_Options.Table (J).all'Last)); -- Replace "-v" by its counterpart "/VERBOSE" + elsif Linker_Options.Table (J) (1 .. 2) = "-v" then Linker_Options.Table (J) := new String'("/VERBOSE"); end if; @@ -2069,30 +2076,30 @@ begin end; end if; - -- Remove duplicate stack size setting from the Linker_Options - -- table. The stack setting option "-Xlinker --stack=R,C" can be - -- found in one line when set by a pragma Linker_Options or in two - -- lines ("-Xlinker" then "--stack=R,C") when set on the command - -- line. We also check for the "-Wl,--stack=R" style option. + -- Remove duplicate stack size setting from the Linker_Options table. + -- The stack setting option "-Xlinker --stack=R,C" can be found + -- in one line when set by a pragma Linker_Options or in two lines + -- ("-Xlinker" then "--stack=R,C") when set on the command line. We + -- also check for the "-Wl,--stack=R" style option. - -- We must remove the second stack setting option instance - -- because the one on the command line will always be the first - -- one. And any subsequent stack setting option will overwrite the - -- previous one. This is done especially for GNAT/NT where we set - -- the stack size for tasking programs by a pragma in the NT - -- specific tasking package System.Task_Primitives.Operations. + -- We must remove the second stack setting option instance because + -- the one on the command line will always be the first one. And any + -- subsequent stack setting option will overwrite the previous one. + -- This is done especially for GNAT/NT where we set the stack size + -- for tasking programs by a pragma in the NT specific tasking + -- package System.Task_Primitives.Operations. -- Note: This is not a FOR loop that runs from Linker_Options.First -- to Linker_Options.Last, since operations within the loop can -- modify the length of the table. Clean_Link_Option_Set : declare - J : Natural := Linker_Options.First; + J : Natural; Shared_Libgcc_Seen : Boolean := False; begin + J := Linker_Options.First; while J <= Linker_Options.Last loop - if Linker_Options.Table (J).all = "-Xlinker" and then J < Linker_Options.Last and then Linker_Options.Table (J + 1)'Length > 8 @@ -2128,12 +2135,12 @@ begin -- pragma Linker_Options set in the NT runtime. if (Linker_Options.Table (J)'Length > 17 - and then Linker_Options.Table (J) (1 .. 17) - = "-Xlinker --stack=") + and then Linker_Options.Table (J) (1 .. 17) = + "-Xlinker --stack=") or else (Linker_Options.Table (J)'Length > 12 - and then Linker_Options.Table (J) (1 .. 12) - = "-Wl,--stack=") + and then Linker_Options.Table (J) (1 .. 12) = + "-Wl,--stack=") then if Stack_Op then Linker_Options.Table (J .. Linker_Options.Last - 1) := @@ -2245,8 +2252,7 @@ begin Write_Eol; for J in - Response_File_Objects.First .. - Response_File_Objects.Last + Response_File_Objects.First .. Response_File_Objects.Last loop Write_Str (Response_File_Objects.Table (J).all); Write_Eol; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index bb62264c66b..6b6b45febaa 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -253,6 +253,7 @@ package body Impunit is ("g-cgideb", F), -- GNAT.CGI.Debug ("g-comlin", F), -- GNAT.Command_Line ("g-comver", F), -- GNAT.Compiler_Version + ("g-cppexc", F), -- GNAT.CPP_Exceptions ("g-crc32 ", F), -- GNAT.CRC32 ("g-ctrl_c", F), -- GNAT.Ctrl_C ("g-curexc", F), -- GNAT.Current_Exception diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 1b2e188ab51..7f8b3a3e58c 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -226,19 +226,6 @@ nanosleep (struct timestruc_t *Rqtp, struct timestruc_t *Rmtp) #endif /* _AIXVERSION_430 */ -/* Version of AIX before 5.3 don't have pthread_condattr_setclock: - * supply it as a weak symbol here so that if linking on a 5.3 or newer - * machine, we get the real one. - */ - -#ifndef _AIXVERSION_530 -#pragma weak pthread_condattr_setclock -int -pthread_condattr_setclock (pthread_condattr_t *attr, clockid_t cl) { - return 0; -} -#endif - static void __gnat_error_handler (int sig, siginfo_t *si ATTRIBUTE_UNUSED, @@ -443,19 +430,22 @@ __gnat_install_handler (void) #pragma weak linux_sigaction int linux_sigaction (int signum, const struct sigaction *act, - struct sigaction *oldact) { + struct sigaction *oldact) +{ return sigaction (signum, act, oldact); } #define sigaction(signum, act, oldact) linux_sigaction (signum, act, oldact) #pragma weak fake_linux_sigfillset -void fake_linux_sigfillset (sigset_t *set) { +void fake_linux_sigfillset (sigset_t *set) +{ sigfillset (set); } #define sigfillset(set) fake_linux_sigfillset (set) #pragma weak fake_linux_sigemptyset -void fake_linux_sigemptyset (sigset_t *set) { +void fake_linux_sigemptyset (sigset_t *set) +{ sigemptyset (set); } #define sigemptyset(set) fake_linux_sigemptyset (set) @@ -593,7 +583,7 @@ __gnat_install_handler (void) /* Turn the current Linux task into a native Xenomai task */ - rt_task_shadow(&main_task, "environment_task", prio, T_FPU); + rt_task_shadow (&main_task, "environment_task", prio, T_FPU); #endif /* Set up signal handler to map synchronous signals to appropriate @@ -910,10 +900,10 @@ extern struct Exception_Data Layout_Error; extern struct Exception_Data Non_Ada_Error; #define Coded_Exception system__vms_exception_table__coded_exception -extern struct Exception_Data *Coded_Exception (Exception_Code); +extern struct Exception_Data *Coded_Exception (void *); #define Base_Code_In system__vms_exception_table__base_code_in -extern Exception_Code Base_Code_In (Exception_Code); +extern void *Base_Code_In (void *); /* DEC Ada exceptions are not defined in a header file, so they must be declared. */ @@ -1046,8 +1036,7 @@ static const struct cond_except system_cond_except_table [] = should be use with caution since the implementation has been kept very simple. */ -typedef int -resignal_predicate (int code); +typedef int resignal_predicate (int code); static const int * const cond_resignal_table [] = { @@ -1136,7 +1125,7 @@ copy_msg (struct descriptor_s *msgdesc, char *message) /* Scan TABLE for a match for the condition contained in SIGARGS, and return the entry, or the empty entry if no match found. */ static const struct cond_except * - scan_conditions ( int *sigargs, const struct cond_except *table []) +scan_conditions ( int *sigargs, const struct cond_except *table []) { int i; struct cond_except entry; @@ -1190,7 +1179,7 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs) { struct Exception_Data *exception = 0; unsigned int needs_adjust = 0; - Exception_Code base_code; + void *base_code; struct descriptor_s gnat_facility = {4, 0, "GNAT"}; char message [Default_Exception_Msg_Max_Length]; @@ -1209,7 +1198,7 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs) #ifdef IN_RTS /* See if it's an imported exception. Beware that registered exceptions are bound to their base code, with the severity bits masked off. */ - base_code = Base_Code_In ((Exception_Code) sigargs[1]); + base_code = Base_Code_In ((void *) sigargs[1]); exception = Coded_Exception (base_code); #endif @@ -1674,12 +1663,14 @@ __gnat_install_handler () #include <iv.h> #endif +#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) +#include <vmLib.h> +#endif + #ifdef VTHREADS #include "private/vThreadsP.h" #endif -void __gnat_error_handler (int, void *, struct sigcontext *); - #ifndef __RTP__ /* Directly vectored Interrupt routines are not supported when using RTPs. */ @@ -1690,7 +1681,7 @@ extern int __gnat_inum_to_ivec (int); int __gnat_inum_to_ivec (int num) { - return INUM_TO_IVEC (num); + return (int) INUM_TO_IVEC (num); } #endif @@ -1724,8 +1715,8 @@ __gnat_clear_exception_count (void) /* Handle different SIGnal to exception mappings in different VxWorks versions. */ static void -__gnat_map_signal (int sig, void *si ATTRIBUTE_UNUSED, - struct sigcontext *sc ATTRIBUTE_UNUSED) +__gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, + void *sc ATTRIBUTE_UNUSED) { struct Exception_Data *exception; const char *msg; @@ -1812,6 +1803,49 @@ __gnat_map_signal (int sig, void *si ATTRIBUTE_UNUSED, msg = "unhandled signal"; } + /* On ARM VxWorks 6.x, the guard page is left un-armed by the kernel + after being violated, so subsequent violations aren't detected. + so we retrieve the address of the guard page from the TCB and compare it + with the page that is violated (pREG 12 in the context) and re-arm that + 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) + + /* We re-arm the guard page by marking it invalid */ + +#define PAGE_SIZE 4096 +#define REG_IP 12 + + if (sig == SIGSEGV || sig == SIGBUS || sig == SIGILL) + { + TASK_ID tid = taskIdSelf (); + WIND_TCB *pTcb = taskTcb (tid); + unsigned long violated_page + = ((struct sigcontext *) sc)->sc_pregs->r[REG_IP] & ~(PAGE_SIZE - 1); + + if ((unsigned long) (pTcb->pStackEnd - PAGE_SIZE) == violated_page) + { + vmStateSet (NULL, violated_page, + PAGE_SIZE, VM_STATE_MASK_VALID, VM_STATE_VALID_NOT); + exception = &storage_error; + + switch (sig) + { + case SIGSEGV: + msg = "SIGSEGV: stack overflow"; + break; + case SIGBUS: + msg = "SIGBUS: stack overflow"; + break; + case SIGILL: + msg = "SIGILL: stack overflow"; + break; + } + } + } +#endif /* defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) */ + __gnat_clear_exception_count (); Raise_From_Signal_Handler (exception, msg); } @@ -1819,8 +1853,8 @@ __gnat_map_signal (int sig, void *si ATTRIBUTE_UNUSED, /* Tasking and Non-tasking signal handler. Map SIGnal to Ada exception propagation after the required low level adjustments. */ -void -__gnat_error_handler (int sig, void *si, struct sigcontext *sc) +static void +__gnat_error_handler (int sig, siginfo_t *si, void *sc) { sigset_t mask; @@ -1878,7 +1912,7 @@ __gnat_install_handler (void) exceptions. Make sure that the handler isn't interrupted by another signal that might cause a scheduling event! */ - act.sa_handler = __gnat_error_handler; + act.sa_sigaction = __gnat_error_handler; act.sa_flags = SA_SIGINFO | SA_ONSTACK; sigemptyset (&act.sa_mask); diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb index e9a86b411ae..20915bc42c3 100644 --- a/gcc/ada/itypes.adb +++ b/gcc/ada/itypes.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -105,7 +105,7 @@ package body Itypes is Set_Etype (I_Typ, Base_Type (T)); Set_Depends_On_Private (I_Typ, Depends_On_Private (T)); Set_Is_Public (I_Typ, Is_Public (T)); - Set_From_With_Type (I_Typ, From_With_Type (T)); + Set_From_Limited_With (I_Typ, From_Limited_With (T)); Set_Is_Access_Constant (I_Typ, Is_Access_Constant (T)); Set_Is_Generic_Type (I_Typ, Is_Generic_Type (T)); Set_Is_Volatile (I_Typ, Is_Volatile (T)); diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 55fe37812ce..ff49104e066 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2013, 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- -- @@ -2388,7 +2388,7 @@ package body Layout is -- If we only have a limited view of the type, see whether the -- non-limited view is available. - if From_With_Type (Designated_Type (E)) + if From_Limited_With (Designated_Type (E)) and then Ekind (Designated_Type (E)) = E_Incomplete_Type and then Present (Non_Limited_View (Designated_Type (E))) then diff --git a/gcc/ada/lib-util.adb b/gcc/ada/lib-util.adb index 9047690d663..ae6e204c223 100644 --- a/gcc/ada/lib-util.adb +++ b/gcc/ada/lib-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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,6 +176,51 @@ package body Lib.Util is Write_Info_Name (Name_Id (Name)); end Write_Info_Name; + ----------------------------------- + -- Write_Info_Name_May_Be_Quoted -- + ----------------------------------- + + procedure Write_Info_Name_May_Be_Quoted (Name : File_Name_Type) is + Quoted : Boolean := False; + Cur : Positive; + + begin + Get_Name_String (Name); + + -- The file/path name is quoted only if it includes spaces + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = ' ' then + Quoted := True; + exit; + end if; + end loop; + + -- Deal with quoting string if needed + + if Quoted then + Insert_Str_In_Name_Buffer ("""", 1); + Add_Char_To_Name_Buffer ('"'); + + -- Any character '"' is doubled + + Cur := 2; + while Cur < Name_Len loop + if Name_Buffer (Cur) = '"' then + Insert_Str_In_Name_Buffer ("""", Cur); + Cur := Cur + 2; + else + Cur := Cur + 1; + end if; + end loop; + end if; + + Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) := + Name_Buffer (1 .. Name_Len); + Info_Buffer_Len := Info_Buffer_Len + Name_Len; + Info_Buffer_Col := Info_Buffer_Col + Name_Len; + end Write_Info_Name_May_Be_Quoted; + -------------------- -- Write_Info_Nat -- -------------------- diff --git a/gcc/ada/lib-util.ads b/gcc/ada/lib-util.ads index b34bd277a09..f4034d62d6d 100644 --- a/gcc/ada/lib-util.ads +++ b/gcc/ada/lib-util.ads @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -65,6 +65,10 @@ package Lib.Util is -- name is written literally from the names table entry without modifying -- the case, using simply Get_Name_String. + procedure Write_Info_Name_May_Be_Quoted (Name : File_Name_Type); + -- Similar to Write_Info_Name, but if Name includes spaces, then it is + -- quoted and the '"' are doubled. + procedure Write_Info_Slit (S : String_Id); -- Write string literal value in format required for L/N lines in ali file diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index c95b9dc4f83..f794162e20b 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -38,6 +38,7 @@ with Gnatvsn; use Gnatvsn; with Opt; use Opt; with Osint; use Osint; with Osint.C; use Osint.C; +with Output; use Output; with Par; with Par_SCO; use Par_SCO; with Restrict; use Restrict; @@ -281,7 +282,7 @@ package body Lib.Writ is end if; else - Set_From_With_Type (Cunit_Entity (Unum)); + Set_From_Limited_With (Cunit_Entity (Unum)); end if; if Implicit_With (Unum) /= Yes then @@ -615,9 +616,28 @@ package body Lib.Writ is Write_With_Lines; - -- Output linker option lines + -- Generate the linker option lines for J in 1 .. Linker_Option_Lines.Last loop + + -- Pragma Linker_Options is not allowed in predefined generic + -- units. This is because they won't be read, due to the fact that + -- with lines for generic units lack the file name and lib name + -- parameters (see Lib_Writ spec for an explanation). + + if Is_Generic_Unit (Cunit_Entity (Main_Unit)) + and then + Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) + and then Linker_Option_Lines.Table (J).Unit = Unit_Num + then + Set_Standard_Error; + Write_Line + ("linker options not allowed in predefined generic unit"); + raise Unrecoverable_Error; + end if; + + -- Output one linker option line + declare S : Linker_Option_Entry renames Linker_Option_Lines.Table (J); begin @@ -790,7 +810,7 @@ package body Lib.Writ is Write_Info_Initiate ('Z'); elsif Ekind (Cunit_Entity (Unum)) = E_Package - and then From_With_Type (Cunit_Entity (Unum)) + and then From_Limited_With (Cunit_Entity (Unum)) then Write_Info_Initiate ('Y'); @@ -858,7 +878,7 @@ package body Lib.Writ is end if; if Ekind (Cunit_Entity (Unum)) = E_Package - and then From_With_Type (Cunit_Entity (Unum)) + and then From_Limited_With (Cunit_Entity (Unum)) then null; else @@ -940,7 +960,7 @@ package body Lib.Writ is for Unum in Units.First .. Last_Unit loop if Cunit_Entity (Unum) = Empty - or else not From_With_Type (Cunit_Entity (Unum)) + or else not From_Limited_With (Cunit_Entity (Unum)) then Num_Sdep := Num_Sdep + 1; Sdep_Table (Num_Sdep) := Unum; @@ -1408,7 +1428,7 @@ package body Lib.Writ is Fname := Name_Find; end if; - Write_Info_Name (Fname); + Write_Info_Name_May_Be_Quoted (Fname); Write_Info_Tab (25); Write_Info_Str (String (Time_Stamp (Sind))); Write_Info_Char (' '); diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index b9d69c2c99c..f886b668ce0 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -183,55 +183,55 @@ package Lib.Writ is -- corresponding source file. Parameters is a sequence of zero or more -- two letter codes that indicate configuration pragmas and other -- parameters that apply: - -- + -- The arguments are as follows: - -- + -- CE Compilation errors. If this is present it means that the ali -- file resulted from a compilation with the -gnatQ switch set, -- and illegalities were detected. The ali file contents may -- not be completely reliable, but the format will be correct -- and complete. Note that NO is always present if CE is -- present. - -- + -- DB Detect_Blocking pragma is in effect for all units in this -- file. - -- + -- Ex A valid Partition_Elaboration_Policy pragma applies to all -- the units in this file, where x is the first character -- (upper case) of the policy name (e.g. 'C' for Concurrent). - -- + -- FD Configuration pragmas apply to all the units in this file -- specifying a possibly non-standard floating point format -- (VAX float with Long_Float using D_Float). - -- + -- FG Configuration pragmas apply to all the units in this file -- specifying a possibly non-standard floating point format -- (VAX float with Long_Float using G_Float). - -- + -- FI Configuration pragmas apply to all the units in this file -- specifying a possibly non-standard floating point format -- (IEEE Float). - -- + -- Lx A valid Locking_Policy pragma applies to all the units in -- this file, where x is the first character (upper case) of -- the policy name (e.g. 'C' for Ceiling_Locking). - -- + -- NO No object. This flag indicates that the units in this file -- were not compiled to produce an object. This can occur as a -- result of the use of -gnatc, or if no object can be produced -- (e.g. when a package spec is compiled instead of the body, -- or a subunit on its own). - -- + -- NR No_Run_Time. Indicates that a pragma No_Run_Time applies -- to all units in the file. - -- + -- NS Normalize_Scalars pragma in effect for all units in -- this file. - -- + -- Qx A valid Queueing_Policy pragma applies to all the units -- in this file, where x is the first character (upper case) -- of the policy name (e.g. 'P' for Priority_Queueing). - -- + -- SL Indicates that the unit is an Interface to a Standalone -- Library. Note that this indication is never given by the -- compiler, but is added by the Project Manager in gnatmake @@ -240,19 +240,19 @@ package Lib.Writ is -- SS This unit references System.Secondary_Stack (that is, -- the unit makes use of the secondary stack facilities). - -- + -- Tx A valid Task_Dispatching_Policy pragma applies to all -- the units in this file, where x is the first character -- (upper case) of the corresponding policy name (e.g. 'F' -- for FIFO_Within_Priorities). - -- + -- UA Unreserve_All_Interrupts pragma was processed in one or -- more units in this file - -- + -- ZX Units in this file use zero-cost exceptions and have -- generated exception tables. If ZX is not present, the -- longjmp/setjmp exception scheme is in use. - -- + -- Note that language defined units never output policy (Lx, Tx, Qx) -- parameters. Language defined units must correctly handle all -- possible cases. These values are checked for consistency by the @@ -513,19 +513,19 @@ package Lib.Writ is -- The lines for each compilation unit have the following form -- U unit-name source-name version <<attributes>> - -- + -- This line identifies the unit to which this section of the library -- information file applies. The first three parameters are the unit -- name in internal format, as described in package Uname, and the name -- of the source file containing the unit. - -- + -- Version is the version given as eight hexadecimal characters with -- upper case letters. This value is the exclusive or of the source -- checksums of the unit and all its semantically dependent units. - -- + -- The <<attributes>> are a series of two letter codes indicating -- information about the unit: - -- + -- BD Unit does not have pragma Elaborate_Body, but the elaboration -- circuit has determined that it would be a good idea if this -- pragma were present, since the body of the package contains @@ -533,7 +533,7 @@ package Lib.Writ is -- visible part of the package. The binder will try, but does -- not promise, to keep the elaboration of the body close to -- the elaboration of the spec. - -- + -- DE Dynamic Elaboration. This unit was compiled with the dynamic -- elaboration model, as set by either the -gnatE switch or -- pragma Elaboration_Checks (Dynamic). @@ -545,7 +545,7 @@ package Lib.Writ is -- body together whenever possible, and for an instance it is -- always possible; however setting EB ensures that this is done -- even when using the -p gnatbind switch). - -- + -- EE Elaboration entity is present which must be set true when -- the unit is elaborated. The name of the elaboration entity is -- formed from the unit name in the usual way. If EE is present, @@ -554,28 +554,28 @@ package Lib.Writ is -- be set even if NE is set. This happens when the boolean is -- needed solely for checking for the case of access before -- elaboration. - -- + -- GE Unit is a generic declaration, or corresponding body -- -- IL Unit source uses a style with identifiers in all lower-case -- IU (IL) or all upper case (IU). If the standard mixed-case usage -- is detected, or the compiler cannot determine the style, then -- no I parameter will appear. - -- + -- IS Initialize_Scalars pragma applies to this unit, or else there -- is at least one use of the Invalid_Value attribute. - -- + -- KM Unit source uses a style with keywords in mixed case (KM) -- KU or all upper case (KU). If the standard lower-case usage is -- is detected, or the compiler cannot determine the style, then -- no K parameter will appear. - -- + -- NE Unit has no elaboration routine. All subprogram bodies and -- specs are in this category. Package bodies and specs may or -- may not have NE set, depending on whether or not elaboration -- code is required. Set if N_Compilation_Unit node has flag -- Has_No_Elaboration_Code set. - -- + -- OL The units in this file are compiled with a local pragma -- Optimize_Alignment, so no consistency requirement applies -- to these units. All internal units have this status since @@ -584,33 +584,33 @@ package Lib.Writ is -- OO Optimize_Alignment (Off) is the default setting for all -- units in this file. All files in the partition that specify -- a default must specify the same default. - -- + -- OS Optimize_Alignment (Space) is the default setting for all -- units in this file. All files in the partition that specify -- a default must specify the same default. - -- + -- OT Optimize_Alignment (Time) is the default setting for all -- units in this file. All files in the partition that specify -- a default must specify the same default. - -- + -- PF The unit has a library-level (package) finalizer - -- + -- PK Unit is package, rather than a subprogram - -- + -- PU Unit has pragma Pure - -- + -- PR Unit has pragma Preelaborate - -- + -- RA Unit declares a Remote Access to Class-Wide (RACW) type - -- + -- RC Unit has pragma Remote_Call_Interface - -- + -- RT Unit has pragma Remote_Types - -- + -- SP Unit has pragma Shared_Passive. - -- + -- SU Unit is a subprogram, rather than a package - -- + -- The attributes may appear in any order, separated by spaces. -- ----------------------------- @@ -624,7 +624,7 @@ package Lib.Writ is -- Y unit-name [source-name lib-name] [E] [EA] [ED] [AD] -- or -- Z unit-name [source-name lib-name] [E] [EA] [ED] [AD] - -- + -- One W line is present for each unit that is mentioned in an explicit -- non-limited with clause by the current unit. One Y line is present -- for each unit that is mentioned in an explicit limited with clause @@ -638,26 +638,32 @@ package Lib.Writ is -- third parameter is the file name of the library information file -- that contains the results of compiling this unit. The optional -- modifiers are used as follows: - -- + -- E pragma Elaborate applies to this unit - -- + -- EA pragma Elaborate_All applies to this unit - -- + -- ED Elaborate_Desirable set for this unit, which means that there -- is no Elaborate, but the analysis suggests that Program_Error -- may be raised if the Elaborate conditions cannot be satisfied. -- The binder will attempt to treat ED as E if it can. - -- + -- AD Elaborate_All_Desirable set for this unit, which means that -- there is no Elaborate_All, but the analysis suggests that -- Program_Error may be raised if the Elaborate_All conditions -- cannot be satisfied. The binder will attempt to treat AD as -- EA if it can. - -- + -- The parameter source-name and lib-name are omitted for the case of a -- generic unit compiled with earlier versions of GNAT which did not - -- generate object or ali files for generics. - -- + -- generate object or ali files for generics. For compatibility in the + -- bootstrap path we continue to omit these entries for predefined + -- generic units, even though we do now generate object and ali files. + + -- However, in SPARK mode, we always generate source-name and lib-name + -- parameters. Bootstrap issues do not apply there, and we need this + -- information to properly compute frame conditions of subprograms. + -- The parameter source-name and lib-name are also omitted for the W -- lines that result from use of a Restriction_Set attribute which gets -- a result of False from a No_Dependence check, in the case where the @@ -696,6 +702,12 @@ package Lib.Writ is -- source file, so that this order is preserved by the binder in -- constructing the set of linker arguments. + -- Note: Linker_Options lines never appear in the ALI file generated for + -- a predefined generic unit, and there is cicuitry in Sem_Prag to enforce + -- this restriction, which is needed because of not generating source name + -- and lib name parameters on the with lines for such files, as explained + -- above in the section on with lines. + -- -------------- -- -- N Notes -- -- -------------- @@ -765,6 +777,13 @@ package Lib.Writ is -- D source-name time-stamp checksum [subunit-name] line:file-name + -- source-name also includes preprocessing data file and preprocessing + -- definition file. These preprocessing files may be given as full + -- path names instead of simple file names. If a full path name + -- includes a directory with spaces, the path name is quoted (quote + -- characters (") added at start and end, and any internal quotes are + -- doubled). + -- The time-stamp field contains the time stamp of the corresponding -- source file. See types.ads for details on time stamp representation. diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index 78413137b0f..849ff0e2dbf 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -1020,17 +1020,27 @@ package body SPARK_Specific is Result := Defining_Unit_Name (Specification (Result)); exit; - -- The enclosing subprogram for a pre- or postconditions should be - -- the subprogram to which the pragma is attached. This is not - -- always the case in the AST, as the pragma may be declared after - -- the declaration of the subprogram. Return Empty in this case. - when N_Pragma => + + -- The enclosing subprogram for a precondition, postcondition, + -- or contract case should be the subprogram to which the + -- pragma is attached, which can be found by following + -- previous elements in the list to which the pragma belongs. + if Get_Pragma_Id (Result) = Pragma_Precondition or else Get_Pragma_Id (Result) = Pragma_Postcondition + or else + Get_Pragma_Id (Result) = Pragma_Contract_Cases then - return Empty; + if Is_List_Member (Result) + and then Present (Prev (Result)) + then + Result := Prev (Result); + else + Result := Parent (Result); + end if; + else Result := Parent (Result); end if; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 182c2b0a979..972d9637b74 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -610,6 +610,15 @@ package body Lib.Xref is Error_Msg_NE ("& is only defined in Ada 2012?y?", N, E); end if; + -- 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 + -- file at the proper source location. + + if Chars (Current_Scope) = Name_uPostconditions then + return; + end if; + -- Never collect references if not in main source unit. However, we omit -- this test if Typ is 'e' or 'k', since these entries are structural, -- and it is useful to have them in units that reference packages as @@ -1298,9 +1307,23 @@ package body Lib.Xref is Right := '>'; end if; - -- If non-derived ptr, get directly designated type. + -- If the completion of a private type is itself a derived + -- type, we need the parent of the full view. + + elsif Is_Private_Type (Tref) + and then Present (Full_View (Tref)) + and then Etype (Full_View (Tref)) /= Full_View (Tref) + then + Tref := Etype (Full_View (Tref)); + + if Left /= '(' then + Left := '<'; + Right := '>'; + end if; + + -- If non-derived pointer, get directly designated type. -- If the type has a full view, all references are on the - -- partial view, that is seen first. + -- partial view that is seen first. elsif Is_Access_Type (Tref) then Tref := Directly_Designated_Type (Tref); diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 3101354d14a..945f9137252 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2011, AdaCore -- +-- Copyright (C) 2001-2013, 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- -- @@ -1185,9 +1185,9 @@ package body MLib.Prj is Delete_File (Get_Name_String (Path), Succ); - if not Succ then - null; - end if; + -- We ignore a failure in this Delete_File operation. + -- Is that OK??? If so, worth a comment as to why we + -- are OK with the operation failing end; end if; @@ -1651,7 +1651,7 @@ package body MLib.Prj is -- content of Rpath. As Rpath contains at least libgnat directory -- path name, it is guaranteed that it is not null. - if Path_Option /= null then + if Opt.Run_Path_Option and then Path_Option /= null then Opts.Increment_Last; Opts.Table (Opts.Last) := new String'(Path_Option.all & Rpath (1 .. Rpath_Last)); diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 605dc89e839..06d9a4bcbab 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -516,6 +516,13 @@ package Opt is -- to make a single long message, and then this message is split up into -- multiple lines not exceeding the specified length. Set by -gnatj=nn. + Error_To_Warning : Boolean := False; + -- GNAT + -- If True, then certain error messages (e.g. parameter overlap messages + -- for procedure calls in Ada 2012 mode) are treated as warnings instead + -- of errors. Set by debug flag -gnatd.E. A search for Error_To_Warning + -- will identify affected messages. + Exception_Handler_Encountered : Boolean := False; -- GNAT -- This flag is set true if the parser encounters an exception handler. @@ -719,6 +726,12 @@ package Opt is -- Set True to ignore all Style_Checks pragmas. Can be set True by use -- of -gnateY. + Ignore_Unrecognized_VWY_Switches : Boolean := False; + -- GNAT + -- Set True to ignore unrecognized y, V, w switches. Can be set True + -- by use of -gnateu, causing subsequent unrecognized switches to result + -- in a warning rather than an error. + Implementation_Unit_Warnings : Boolean := True; -- GNAT -- Set True to active warnings for use of implementation internal units. @@ -828,6 +841,11 @@ package Opt is -- Set to True to skip compile and bind steps (except when Bind_Only is -- set to True). + List_Body_Required_Info : Boolean := False; + -- GNATMAKE + -- List info messages about why a package requires a body. Modified by use + -- of -gnatw.y/.Y. + List_Inherited_Aspects : Boolean := False; -- GNAT -- List inherited invariants, preconditions, and postconditions from @@ -1734,12 +1752,12 @@ package Opt is Ada_Version_Config : Ada_Version_Type; -- GNAT -- This is the value of the configuration switch for the Ada 83 mode, as - -- set by the command line switches -gnat83/95/05, and possibly modified by - -- the use of configuration pragmas Ada_*. This switch is used to set the - -- initial value for Ada_Version mode at the start of analysis of a unit. - -- Note however that the setting of this flag is ignored for internal and - -- predefined units (which are always compiled in the most up to date - -- version of Ada). + -- set by the command line switches -gnat83/95/2005/2012, and possibly + -- modified by the use of configuration pragmas Ada_*. This switch is used + -- to set the initial value for Ada_Version mode at the start of analysis + -- of a unit. Note however that the setting of this flag is ignored for + -- internal and predefined units (which are always compiled in the most up + -- to date version of Ada). Ada_Version_Pragma_Config : Node_Id; -- This will be set non empty if it is set by a configuration pragma diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 8765b4cb60e..aefffc3ed59 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -1044,8 +1044,8 @@ package body Osint is procedure Fail (S : String) is begin - -- We use Output in case there is a special output set up. - -- In this case Set_Standard_Error will have no immediate effect. + -- We use Output in case there is a special output set up. In this case + -- Set_Standard_Error will have no immediate effect. Set_Standard_Error; Osint.Write_Program_Name; diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 26b8056f80f..18c63a3bf6c 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -78,15 +78,19 @@ package body Ch13 is -- are in Ada 2012 mode, Strict is False, and we consider that we have -- an aspect specification if the identifier is an aspect name (even if -- not followed by =>) or the identifier is not an aspect name but is - -- followed by =>. P_Aspect_Specifications will generate messages if the - -- aspect specification is ill-formed. + -- followed by =>, by a comma, or by a semicolon. The last two cases + -- correspond to (misspelled) Boolean aspects with a defaulted value of + -- True. P_Aspect_Specifications will generate messages if the aspect + -- specification is ill-formed. elsif not Strict then if Get_Aspect_Id (Token_Name) /= No_Aspect then Result := True; else Scan; -- past identifier - Result := Token = Tok_Arrow; + Result := Token = Tok_Arrow or else + Token = Tok_Comma or else + Token = Tok_Semicolon; end if; -- If earlier than Ada 2012, check for valid aspect identifier (possibly @@ -107,9 +111,9 @@ package body Ch13 is -- The identifier may be the name of a boolean aspect with a -- defaulted True value. Further checks when analyzing aspect - -- specification. + -- specification, which may include further aspects. - elsif Token = Tok_Comma then + elsif Token = Tok_Comma or else Token = Tok_Semicolon then Result := True; elsif Token = Tok_Apostrophe then diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index 224c63b7eb9..2218dacb17e 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -250,23 +250,15 @@ package body Ch2 is procedure Skip_Pragma_Semicolon is begin - if Token /= Tok_Semicolon then + -- If skipping the pragma, ignore a missing semicolon - -- If skipping the pragma, ignore a missing semicolon + if Token /= Tok_Semicolon and then Skipping then + null; - if Skipping then - null; - - -- Otherwise demand a semicolon - - else - T_Semicolon; - end if; - - -- Scan past semicolon if present + -- Otherwise demand a semicolon else - Scan; + T_Semicolon; end if; end Skip_Pragma_Semicolon; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 5766639816a..cdf0dab653a 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -3120,6 +3120,14 @@ package body Ch4 is Scan; -- Past ELSE Append_To (Exprs, P_Expression); + -- Skip redundant ELSE parts + + while Token = Tok_Else loop + Error_Msg_SC ("only one ELSE part is allowed"); + Scan; -- past ELSE + Discard_Junk_Node (P_Expression); + end loop; + -- Two expression case (implied True, filled in during semantics) else diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index f060b3f2822..560cf4c989c 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -73,9 +73,6 @@ package body Ch6 is else Restore_Scan_State (Scan_State); end if; - - elsif Bad_Spelling_Of (Tok_Return) then - null; end if; end Check_Junk_Semicolon_Before_Return; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 5de6ecc0081..4cb9fd16ad4 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1185,7 +1185,9 @@ begin Pragma_Import_Valued_Procedure | Pragma_Independent | Pragma_Independent_Components | + Pragma_Initial_Condition | Pragma_Initialize_Scalars | + Pragma_Initializes | Pragma_Inline | Pragma_Inline_Always | Pragma_Inline_Generic | @@ -1234,11 +1236,15 @@ begin Pragma_Preelaborable_Initialization | Pragma_Polling | Pragma_Persistent_BSS | + Pragma_Post | Pragma_Postcondition | + Pragma_Post_Class | + Pragma_Pre | Pragma_Precondition | Pragma_Predicate | Pragma_Preelaborate | Pragma_Preelaborate_05 | + Pragma_Pre_Class | Pragma_Priority | Pragma_Priority_Specific_Dispatching | Pragma_Profile | @@ -1250,6 +1256,10 @@ begin Pragma_Pure_12 | Pragma_Pure_Function | Pragma_Queuing_Policy | + Pragma_Refined_Depends | + Pragma_Refined_Global | + Pragma_Refined_Post | + Pragma_Refined_State | Pragma_Relative_Deadline | Pragma_Remote_Access_Type | Pragma_Remote_Call_Interface | @@ -1283,6 +1293,8 @@ begin Pragma_Thread_Local_Storage | Pragma_Time_Slice | Pragma_Title | + Pragma_Type_Invariant | + Pragma_Type_Invariant_Class | Pragma_Unchecked_Union | Pragma_Unimplemented_Unit | Pragma_Universal_Aliasing | diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb index 3ec2087926a..c38234b052e 100644 --- a/gcc/ada/prep.adb +++ b/gcc/ada/prep.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2013, 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,6 +33,7 @@ with Snames; use Snames; with Sinput; with Stringt; use Stringt; with Table; +with Uintp; use Uintp; with GNAT.Heap_Sort_G; @@ -146,21 +147,19 @@ package body Prep is type Pp_State is record If_Ptr : Source_Ptr; - -- The location of the #if statement. - -- Used to flag #if with no corresponding #end if, at the end. + -- The location of the #if statement (used to flag #if with no + -- corresponding #end if, at the end). Else_Ptr : Source_Ptr; - -- The location of the #else statement. - -- Used to detect multiple #else. + -- The location of the #else statement (used to detect multiple #else's) Deleting : Boolean; -- Set to True when the code should be deleted or commented out Match_Seen : Boolean; - -- Set to True when a condition in an #if or an #elsif is True. - -- Also set to True if Deleting at the previous level is True. - -- Used to decide if Deleting should be set to True in a following - -- #elsif or #else. + -- Set to True when a condition in an #if or an #elsif is True. Also set + -- to True if Deleting at the previous level is True. Used to decide if + -- Deleting should be set to True in a following #elsif or #else. end record; @@ -189,13 +188,13 @@ package body Prep is function Expression (Evaluate_It : Boolean; Complemented : Boolean := False) return Boolean; - -- Evaluate a condition in an #if or an #elsif statement. - -- If Evaluate_It is False, the condition is effectively evaluated, - -- otherwise, only the syntax is checked. + -- Evaluate a condition in an #if or an #elsif statement. If Evaluate_It + -- is False, the condition is effectively evaluated, otherwise, only the + -- syntax is checked. procedure Go_To_End_Of_Line; - -- Advance the scan pointer until we reach an end of line or the end - -- of the buffer. + -- Advance the scan pointer until we reach an end of line or the end of the + -- buffer. function Matching_Strings (S1, S2 : String_Id) return Boolean; -- Returns True if the two string parameters are equal (case insensitive) @@ -250,6 +249,7 @@ package body Prep is -- If no character '=', then the value is True if Index = 0 then + -- Put the symbol in the name buffer Name_Len := Definition'Length; @@ -284,9 +284,14 @@ package body Prep is end loop; end if; - -- And put the value in the result + -- Even if the value is a string, we still set Is_A_String to False, + -- to avoid adding additional quotes in the preprocessed sources when + -- replacing $<symbol>. Result.Is_A_String := False; + + -- Put the value in the result + Start_String; Store_String_Chars (Definition (Index + 1 .. Definition'Last)); Result.Value := End_String; @@ -372,8 +377,8 @@ package body Prep is Complemented : Boolean := False) return Boolean is Evaluation : Boolean := Evaluate_It; - -- Is set to False after an "or else" when left term is True and - -- after an "and then" when left term is False. + -- Is set to False after an "or else" when left term is True and after + -- an "and then" when left term is False. Final_Result : Boolean := False; @@ -390,6 +395,8 @@ package body Prep is Symbol_Value1 : String_Id; Symbol_Value2 : String_Id; + Relop : Token_Type; + begin -- Loop for each term @@ -398,12 +405,13 @@ package body Prep is Current_Result := False; - case Token is + -- Scan current term, starting with Token - when Tok_Left_Paren => + case Token is - -- ( expression ) + -- Handle parenthesized expression + when Tok_Left_Paren => Scan.all; Current_Result := Expression (Evaluation); @@ -415,14 +423,15 @@ package body Prep is ("`)` expected", Token_Ptr); end if; - when Tok_Not => - - -- not expression + -- Handle not expression + when Tok_Not => Scan.all; Current_Result := not Expression (Evaluation, Complemented => True); + -- Handle sequence starting with identifier + when Tok_Identifier => Symbol_Name1 := Token_Name; Symbol_Pos1 := Token_Ptr; @@ -447,12 +456,105 @@ package body Prep is Current_Result := Index_Of (Symbol_Name1) /= No_Symbol; end if; - elsif Token = Tok_Equal then - Scan.all; + -- Handle relational operator + elsif + Token = Tok_Equal or else + Token = Tok_Less or else + Token = Tok_Less_Equal or else + Token = Tok_Greater or else + Token = Tok_Greater_Equal + then + Relop := Token; + Scan.all; Change_Reserved_Keyword_To_Symbol; - if Token = Tok_Identifier then + if Token = Tok_Integer_Literal then + + -- symbol = integer + -- symbol < integer + -- symbol <= integer + -- symbol > integer + -- symbol >= integer + + declare + Value : constant Int := UI_To_Int (Int_Literal_Value); + Data : Symbol_Data; + + Symbol_Value : Int; + -- Value of symbol as Int + + begin + if Evaluation then + Symbol1 := Index_Of (Symbol_Name1); + + if Symbol1 = No_Symbol then + Error_Msg_Name_1 := Symbol_Name1; + Error_Msg ("unknown symbol %", Symbol_Pos1); + Symbol_Value1 := No_String; + + else + Data := Mapping.Table (Symbol1); + + if Data.Is_A_String then + Error_Msg_Name_1 := Symbol_Name1; + Error_Msg + ("symbol % value is not integer", + Symbol_Pos1); + + else + begin + String_To_Name_Buffer (Data.Value); + Symbol_Value := + Int'Value (Name_Buffer (1 .. Name_Len)); + + case Relop is + when Tok_Equal => + Current_Result := + Symbol_Value = Value; + + when Tok_Less => + Current_Result := + Symbol_Value < Value; + + when Tok_Less_Equal => + Current_Result := + Symbol_Value <= Value; + + when Tok_Greater => + Current_Result := + Symbol_Value > Value; + + when Tok_Greater_Equal => + Current_Result := + Symbol_Value >= Value; + + when others => + null; + end case; + + exception + when Constraint_Error => + Error_Msg_Name_1 := Symbol_Name1; + Error_Msg + ("symbol % value is not an integer", + Symbol_Pos1); + end; + end if; + end if; + end if; + + Scan.all; + end; + + -- Error if relational operator other than = if not numbers + + elsif Relop /= Tok_Equal then + Error_Msg ("number expected", Token_Ptr); + + -- Equality comparison of two strings + + elsif Token = Tok_Identifier then -- symbol = symbol @@ -495,10 +597,11 @@ package body Prep is end if; if Symbol_Value1 /= No_String - and then Symbol_Value2 /= No_String + and then + Symbol_Value2 /= No_String then - Current_Result := Matching_Strings - (Symbol_Value1, Symbol_Value2); + Current_Result := + Matching_Strings (Symbol_Value1, Symbol_Value2); end if; end if; @@ -535,12 +638,13 @@ package body Prep is else Error_Msg - ("symbol or literal string expected", Token_Ptr); + ("literal integer, symbol or literal string expected", + Token_Ptr); end if; - else - -- symbol (True or False) + -- Handle True or False + else if Evaluation then Symbol1 := Index_Of (Symbol_Name1); @@ -582,6 +686,8 @@ package body Prep is end if; end if; + -- Unrecognized sequence + when others => Error_Msg ("`(`, NOT or symbol expected", Token_Ptr); end case; @@ -599,7 +705,7 @@ package body Prep is Final_Result := Final_Result and Current_Result; end case; - -- Check the next operator + -- Handle AND if Token = Tok_And then if Complemented then @@ -622,6 +728,8 @@ package body Prep is end if; end if; + -- Handle OR + elsif Token = Tok_Or then if Complemented then Error_Msg @@ -643,9 +751,9 @@ package body Prep is end if; end if; - else - -- No operator: exit the term loop + -- No AND/OR operator, so exit from the loop through terms + else exit; end if; end loop; @@ -732,7 +840,6 @@ package body Prep is Get_Name_String (Mapping.Table (Order (Op1)).Symbol); S2 : constant String := Get_Name_String (Mapping.Table (Order (Op2)).Symbol); - begin return S1 < S2; end Lt; @@ -869,6 +976,8 @@ package body Prep is -- Parse_Def_File -- -------------------- + -- This procedure REALLY needs some more comments ??? + procedure Parse_Def_File is Symbol : Symbol_Id; Symbol_Name : Name_Id; @@ -914,7 +1023,32 @@ package body Prep is Scan.all; - if Token = Tok_String_Literal then + if Token = Tok_Integer_Literal then + declare + Ptr : Source_Ptr := Token_Ptr; + + begin + Start_String; + while Ptr < Scan_Ptr loop + Store_String_Char (Sinput.Source (Ptr)); + Ptr := Ptr + 1; + end loop; + + Data := (Symbol => Symbol_Name, + Original => Original_Name, + On_The_Command_Line => False, + Is_A_String => False, + Value => End_String); + end; + + Scan.all; + + if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then + Error_Msg ("extraneous text in definition", Token_Ptr); + goto Cleanup; + end if; + + elsif Token = Tok_String_Literal then Data := (Symbol => Symbol_Name, Original => Original_Name, On_The_Command_Line => False, @@ -984,9 +1118,10 @@ package body Prep is Symbol := Index_Of (Symbol_Name); if Symbol /= No_Symbol then + -- If we already have an entry for this symbol, replace it - -- with the new value, except if the symbol was declared - -- on the command line. + -- with the new value, except if the symbol was declared on + -- the command line. if Mapping.Table (Symbol).On_The_Command_Line then goto Continue; @@ -1088,8 +1223,7 @@ package body Prep is begin Start_Of_Processing := Scan_Ptr; - -- We need to call Scan for the first time, because Initialize_Scanner - -- is no longer doing it. + -- First a call to Scan, because Initialize_Scanner is not doing it Scan.all; @@ -1182,8 +1316,8 @@ package body Prep is Scan.all; end if; - -- It is an error to have trailing characters after - -- the condition or "then". + -- It is an error to have trailing characters after the + -- condition or "then". if Token /= Tok_End_Of_Line and then Token /= Tok_EOF @@ -1196,8 +1330,9 @@ package body Prep is Go_To_End_Of_Line; end if; - -- Depending on the value of the condition, set the - -- new values of Deleting and Match_Seen. + -- Depending on the value of the condition, set the new + -- values of Deleting and Match_Seen. + if Pp_States.Last > 0 then if Pp_States.Table (Pp_States.Last).Match_Seen then Pp_States.Table (Pp_States.Last).Deleting := True; @@ -1226,8 +1361,7 @@ package body Prep is No_Error_Found := False; end if; - -- Set the possibly new values of Deleting and - -- Match_Seen. + -- Set the possibly new values of Deleting and Match_Seen if Pp_States.Last > 0 then if Pp_States.Table (Pp_States.Last).Match_Seen then @@ -1241,8 +1375,7 @@ package body Prep is False; end if; - -- Set the Else_Ptr to check for illegal #elsif - -- later. + -- Set the Else_Ptr to check for illegal #elsif later Pp_States.Table (Pp_States.Last).Else_Ptr := Token_Ptr; @@ -1250,7 +1383,8 @@ package body Prep is Scan.all; - -- It is an error to have characters after "#else" + -- Error of character present after "#else" + if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then @@ -1287,8 +1421,8 @@ package body Prep is else Scan.all; - -- It is an error to have character after - -- "#end if;". + -- Error of character present after "#end if;" + if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then @@ -1418,15 +1552,14 @@ package body Prep is pragma Assert (Token = Tok_End_Of_Line or else Token = Tok_EOF); - -- At this point, the token is either end of line or EOF. - -- The line to possibly output stops just before the token. + -- At this point, the token is either end of line or EOF. The line to + -- possibly output stops just before the token. Output_Line (Start_Of_Processing, Token_Ptr - 1); -- If we are at the end of a line, the scan pointer is at the first - -- non blank character, not necessarily the first character of the - -- line; so, we have to deduct Start_Of_Processing from the token - -- pointer. + -- non-blank character (may not be the first character of the line), + -- so we have to deduct Start_Of_Processing from the token pointer. if Token = Tok_End_Of_Line then if (Sinput.Source (Token_Ptr) = ASCII.CR diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index a69281130dd..4f818f84717 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -111,6 +111,7 @@ package body Prj.Attr is "SVlibrary_auto_init#" & "LVleading_library_options#" & "LVlibrary_options#" & + "Lalibrary_rpath_options#" & "SVlibrary_src_dir#" & "SVlibrary_ali_dir#" & "SVlibrary_gcc#" & @@ -288,6 +289,8 @@ package body Prj.Attr is "LVswitches#" & "Lasource_artifact_extensions#" & "Laobject_artifact_extensions#" & + "LVartifacts_in_exec_dir#" & + "LVartifacts_in_object_dir#" & -- package Cross_Reference diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 48241efbdd0..f16509b18ab 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -68,16 +68,6 @@ package body Prj.Conf is -- Local_Subprograms -- ----------------------- - procedure Add_Attributes - (Project_Tree : Project_Tree_Ref; - Conf_Decl : Declarations; - User_Decl : in out Declarations); - -- Process the attributes in the config declarations. - -- For single string values, if the attribute is not declared in the user - -- declarations, declare it with the value in the config declarations. - -- For string list values, prepend the value in the user declarations with - -- the value in the config declarations. - function Check_Target (Config_File : Prj.Project_Id; Autoconf_Specified : Boolean; @@ -109,219 +99,6 @@ package body Prj.Conf is -- projects, so that when the second phase of the processing is performed -- these attributes are automatically taken into account. - -------------------- - -- Add_Attributes -- - -------------------- - - procedure Add_Attributes - (Project_Tree : Project_Tree_Ref; - Conf_Decl : Declarations; - User_Decl : in out Declarations) - is - Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; - Conf_Attr_Id : Variable_Id; - Conf_Attr : Variable; - Conf_Array_Id : Array_Id; - Conf_Array : Array_Data; - Conf_Array_Elem_Id : Array_Element_Id; - Conf_Array_Elem : Array_Element; - Conf_List : String_List_Id; - Conf_List_Elem : String_Element; - - User_Attr_Id : Variable_Id; - User_Attr : Variable; - User_Array_Id : Array_Id; - User_Array : Array_Data; - User_Array_Elem_Id : Array_Element_Id; - User_Array_Elem : Array_Element; - - begin - Conf_Attr_Id := Conf_Decl.Attributes; - User_Attr_Id := User_Decl.Attributes; - while Conf_Attr_Id /= No_Variable loop - Conf_Attr := Shared.Variable_Elements.Table (Conf_Attr_Id); - User_Attr := Shared.Variable_Elements.Table (User_Attr_Id); - - if not Conf_Attr.Value.Default then - if User_Attr.Value.Default then - - -- No attribute declared in user project file: just copy the - -- value of the configuration attribute. - - User_Attr.Value := Conf_Attr.Value; - Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr; - - elsif User_Attr.Value.Kind = List - and then Conf_Attr.Value.Values /= Nil_String - then - -- List attribute declared in both the user project and the - -- configuration project: prepend the user list with the - -- configuration list. - - declare - User_List : constant String_List_Id := - User_Attr.Value.Values; - Conf_List : String_List_Id := Conf_Attr.Value.Values; - Conf_Elem : String_Element; - New_List : String_List_Id; - New_Elem : String_Element; - - begin - -- Create new list - - String_Element_Table.Increment_Last - (Shared.String_Elements); - New_List := - String_Element_Table.Last (Shared.String_Elements); - - -- Value of attribute is new list - - User_Attr.Value.Values := New_List; - Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr; - - loop - -- Get each element of configuration list - - Conf_Elem := Shared.String_Elements.Table (Conf_List); - New_Elem := Conf_Elem; - Conf_List := Conf_Elem.Next; - - if Conf_List = Nil_String then - - -- If it is the last element in the list, connect to - -- first element of user list, and we are done. - - New_Elem.Next := User_List; - Shared.String_Elements.Table (New_List) := New_Elem; - exit; - - else - -- If it is not the last element in the list, add to - -- new list. - - String_Element_Table.Increment_Last - (Shared.String_Elements); - New_Elem.Next := - String_Element_Table.Last (Shared.String_Elements); - Shared.String_Elements.Table (New_List) := New_Elem; - New_List := New_Elem.Next; - end if; - end loop; - end; - end if; - end if; - - Conf_Attr_Id := Conf_Attr.Next; - User_Attr_Id := User_Attr.Next; - end loop; - - Conf_Array_Id := Conf_Decl.Arrays; - while Conf_Array_Id /= No_Array loop - Conf_Array := Shared.Arrays.Table (Conf_Array_Id); - - User_Array_Id := User_Decl.Arrays; - while User_Array_Id /= No_Array loop - User_Array := Shared.Arrays.Table (User_Array_Id); - exit when User_Array.Name = Conf_Array.Name; - User_Array_Id := User_Array.Next; - end loop; - - -- If this associative array does not exist in the user project file, - -- do a shallow copy of the full associative array. - - if User_Array_Id = No_Array then - Array_Table.Increment_Last (Shared.Arrays); - User_Array := Conf_Array; - User_Array.Next := User_Decl.Arrays; - User_Decl.Arrays := Array_Table.Last (Shared.Arrays); - Shared.Arrays.Table (User_Decl.Arrays) := User_Array; - - -- Otherwise, check each array element - - else - Conf_Array_Elem_Id := Conf_Array.Value; - while Conf_Array_Elem_Id /= No_Array_Element loop - Conf_Array_Elem := - Shared.Array_Elements.Table (Conf_Array_Elem_Id); - - User_Array_Elem_Id := User_Array.Value; - while User_Array_Elem_Id /= No_Array_Element loop - User_Array_Elem := - Shared.Array_Elements.Table (User_Array_Elem_Id); - exit when User_Array_Elem.Index = Conf_Array_Elem.Index; - User_Array_Elem_Id := User_Array_Elem.Next; - end loop; - - -- If the array element doesn't exist in the user array, insert - -- a shallow copy of the conf array element in the user array. - - if User_Array_Elem_Id = No_Array_Element then - Array_Element_Table.Increment_Last (Shared.Array_Elements); - User_Array_Elem := Conf_Array_Elem; - User_Array_Elem.Next := User_Array.Value; - User_Array.Value := - Array_Element_Table.Last (Shared.Array_Elements); - Shared.Array_Elements.Table (User_Array.Value) := - User_Array_Elem; - Shared.Arrays.Table (User_Array_Id) := User_Array; - - -- Otherwise, if the value is a string list, prepend the conf - -- array element value to the array element. - - elsif Conf_Array_Elem.Value.Kind = List then - Conf_List := Conf_Array_Elem.Value.Values; - - if Conf_List /= Nil_String then - declare - Link : constant String_List_Id := - User_Array_Elem.Value.Values; - Previous : String_List_Id := Nil_String; - Next : String_List_Id; - - begin - loop - Conf_List_Elem := - Shared.String_Elements.Table (Conf_List); - String_Element_Table.Increment_Last - (Shared.String_Elements); - Next := - String_Element_Table.Last - (Shared.String_Elements); - Shared.String_Elements.Table (Next) := - Conf_List_Elem; - - if Previous = Nil_String then - User_Array_Elem.Value.Values := Next; - Shared.Array_Elements.Table - (User_Array_Elem_Id) := User_Array_Elem; - - else - Shared.String_Elements.Table - (Previous).Next := Next; - end if; - - Previous := Next; - - Conf_List := Conf_List_Elem.Next; - - if Conf_List = Nil_String then - Shared.String_Elements.Table (Previous).Next := - Link; - exit; - end if; - end loop; - end; - end if; - end if; - - Conf_Array_Elem_Id := Conf_Array_Elem.Next; - end loop; - end if; - - Conf_Array_Id := Conf_Array.Next; - end loop; - end Add_Attributes; - ------------------------------------ -- Add_Default_GNAT_Naming_Scheme -- ------------------------------------ @@ -464,6 +241,235 @@ package body Prj.Conf is (Config_File : Prj.Project_Id; Project_Tree : Prj.Project_Tree_Ref) is + procedure Add_Attributes + (Project_Tree : Project_Tree_Ref; + Conf_Decl : Declarations; + User_Decl : in out Declarations); + -- Process the attributes in the config declarations. For + -- single string values, if the attribute is not declared in + -- the user declarations, declare it with the value in the + -- config declarations. For string list values, prepend the + -- value in the user declarations with the value in the config + -- declarations. + + -------------------- + -- Add_Attributes -- + -------------------- + + procedure Add_Attributes + (Project_Tree : Project_Tree_Ref; + Conf_Decl : Declarations; + User_Decl : in out Declarations) + is + Shared : constant Shared_Project_Tree_Data_Access := + Project_Tree.Shared; + Conf_Attr_Id : Variable_Id; + Conf_Attr : Variable; + Conf_Array_Id : Array_Id; + Conf_Array : Array_Data; + Conf_Array_Elem_Id : Array_Element_Id; + Conf_Array_Elem : Array_Element; + Conf_List : String_List_Id; + Conf_List_Elem : String_Element; + + User_Attr_Id : Variable_Id; + User_Attr : Variable; + User_Array_Id : Array_Id; + User_Array : Array_Data; + User_Array_Elem_Id : Array_Element_Id; + User_Array_Elem : Array_Element; + + begin + Conf_Attr_Id := Conf_Decl.Attributes; + User_Attr_Id := User_Decl.Attributes; + + while Conf_Attr_Id /= No_Variable loop + Conf_Attr := Shared.Variable_Elements.Table (Conf_Attr_Id); + User_Attr := Shared.Variable_Elements.Table (User_Attr_Id); + + if not Conf_Attr.Value.Default then + if User_Attr.Value.Default then + + -- No attribute declared in user project file: just copy + -- the value of the configuration attribute. + + User_Attr.Value := Conf_Attr.Value; + Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr; + + elsif User_Attr.Value.Kind = List + and then Conf_Attr.Value.Values /= Nil_String + then + -- List attribute declared in both the user project and the + -- configuration project: prepend the user list with the + -- configuration list. + + declare + User_List : constant String_List_Id := + User_Attr.Value.Values; + Conf_List : String_List_Id := Conf_Attr.Value.Values; + Conf_Elem : String_Element; + New_List : String_List_Id; + New_Elem : String_Element; + + begin + -- Create new list + + String_Element_Table.Increment_Last + (Shared.String_Elements); + New_List := + String_Element_Table.Last (Shared.String_Elements); + + -- Value of attribute is new list + + User_Attr.Value.Values := New_List; + Shared.Variable_Elements.Table (User_Attr_Id) := + User_Attr; + + loop + -- Get each element of configuration list + + Conf_Elem := Shared.String_Elements.Table (Conf_List); + New_Elem := Conf_Elem; + Conf_List := Conf_Elem.Next; + + if Conf_List = Nil_String then + + -- If it is the last element in the list, connect + -- to first element of user list, and we are done. + + New_Elem.Next := User_List; + Shared.String_Elements.Table (New_List) := New_Elem; + exit; + + else + -- If it is not the last element in the list, add + -- to new list. + + String_Element_Table.Increment_Last + (Shared.String_Elements); + New_Elem.Next := String_Element_Table.Last + (Shared.String_Elements); + Shared.String_Elements.Table (New_List) := New_Elem; + New_List := New_Elem.Next; + end if; + end loop; + end; + end if; + end if; + + Conf_Attr_Id := Conf_Attr.Next; + User_Attr_Id := User_Attr.Next; + end loop; + + Conf_Array_Id := Conf_Decl.Arrays; + while Conf_Array_Id /= No_Array loop + Conf_Array := Shared.Arrays.Table (Conf_Array_Id); + + User_Array_Id := User_Decl.Arrays; + while User_Array_Id /= No_Array loop + User_Array := Shared.Arrays.Table (User_Array_Id); + exit when User_Array.Name = Conf_Array.Name; + User_Array_Id := User_Array.Next; + end loop; + + -- If this associative array does not exist in the user project + -- file, do a shallow copy of the full associative array. + + if User_Array_Id = No_Array then + Array_Table.Increment_Last (Shared.Arrays); + User_Array := Conf_Array; + User_Array.Next := User_Decl.Arrays; + User_Decl.Arrays := Array_Table.Last (Shared.Arrays); + Shared.Arrays.Table (User_Decl.Arrays) := User_Array; + + -- Otherwise, check each array element + + else + Conf_Array_Elem_Id := Conf_Array.Value; + while Conf_Array_Elem_Id /= No_Array_Element loop + Conf_Array_Elem := + Shared.Array_Elements.Table (Conf_Array_Elem_Id); + + User_Array_Elem_Id := User_Array.Value; + while User_Array_Elem_Id /= No_Array_Element loop + User_Array_Elem := + Shared.Array_Elements.Table (User_Array_Elem_Id); + exit when User_Array_Elem.Index = Conf_Array_Elem.Index; + User_Array_Elem_Id := User_Array_Elem.Next; + end loop; + + -- If the array element doesn't exist in the user array, + -- insert a shallow copy of the conf array element in the + -- user array. + + if User_Array_Elem_Id = No_Array_Element then + Array_Element_Table.Increment_Last + (Shared.Array_Elements); + User_Array_Elem := Conf_Array_Elem; + User_Array_Elem.Next := User_Array.Value; + User_Array.Value := + Array_Element_Table.Last (Shared.Array_Elements); + Shared.Array_Elements.Table (User_Array.Value) := + User_Array_Elem; + Shared.Arrays.Table (User_Array_Id) := User_Array; + + -- Otherwise, if the value is a string list, prepend the + -- conf array element value to the array element. + + elsif Conf_Array_Elem.Value.Kind = List then + Conf_List := Conf_Array_Elem.Value.Values; + + if Conf_List /= Nil_String then + declare + Link : constant String_List_Id := + User_Array_Elem.Value.Values; + Previous : String_List_Id := Nil_String; + Next : String_List_Id; + + begin + loop + Conf_List_Elem := + Shared.String_Elements.Table (Conf_List); + String_Element_Table.Increment_Last + (Shared.String_Elements); + Next := + String_Element_Table.Last + (Shared.String_Elements); + Shared.String_Elements.Table (Next) := + Conf_List_Elem; + + if Previous = Nil_String then + User_Array_Elem.Value.Values := Next; + Shared.Array_Elements.Table + (User_Array_Elem_Id) := User_Array_Elem; + + else + Shared.String_Elements.Table + (Previous).Next := Next; + end if; + + Previous := Next; + + Conf_List := Conf_List_Elem.Next; + + if Conf_List = Nil_String then + Shared.String_Elements.Table + (Previous).Next := Link; + exit; + end if; + end loop; + end; + end if; + end if; + + Conf_Array_Elem_Id := Conf_Array_Elem.Next; + end loop; + end if; + + Conf_Array_Id := Conf_Array.Next; + end loop; + end Add_Attributes; + Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; Conf_Decl : constant Declarations := Config_File.Decl; @@ -483,9 +489,9 @@ package body Prj.Conf is if Proj.Project /= Config_File then User_Decl := Proj.Project.Decl; Add_Attributes - (Project_Tree => Project_Tree, - Conf_Decl => Conf_Decl, - User_Decl => User_Decl); + (Project_Tree => Project_Tree, + Conf_Decl => Conf_Decl, + User_Decl => User_Decl); Conf_Pack_Id := Conf_Decl.Packages; while Conf_Pack_Id /= No_Package loop @@ -637,8 +643,8 @@ package body Prj.Conf is -- Check for switches --config and --RTS in package Builder procedure Get_Project_Target; - -- Target_Name is empty, get the specifiedtarget in the project file, - -- if any. + -- If Target_Name is empty, get the specified target in the project + -- file, if any. function Get_Config_Switches return Argument_List_Access; -- Return the --config switches to use for gprconfig diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index f1538de9922..eb647df1492 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -1127,6 +1127,9 @@ package body Prj.Nmsc is procedure Process_Builder (Attributes : Variable_Id); -- Process the simple attributes of package Builder + procedure Process_Clean (Attributes : Variable_Id); + -- Process the simple attributes of package Clean + procedure Process_Clean (Arrays : Array_Id); -- Process the associated array attributes of package Clean @@ -1256,6 +1259,55 @@ package body Prj.Nmsc is -- Process_Clean -- ------------------- + procedure Process_Clean (Attributes : Variable_Id) is + Attribute_Id : Variable_Id; + Attribute : Variable; + List : String_List_Id; + + begin + -- Process non associated array attributes from package Clean + + Attribute_Id := Attributes; + while Attribute_Id /= No_Variable loop + Attribute := Shared.Variable_Elements.Table (Attribute_Id); + + if not Attribute.Value.Default then + if Attribute.Name = Name_Artifacts_In_Exec_Dir then + + -- Attribute Artifacts_In_Exec_Dir: the list of file + -- names to be cleaned in the exec dir of the main + -- project. + + List := Attribute.Value.Values; + + if List /= Nil_String then + Put (Into_List => + Project.Config.Artifacts_In_Exec_Dir, + From_List => List, + In_Tree => Data.Tree); + end if; + + elsif Attribute.Name = Name_Artifacts_In_Object_Dir then + + -- Attribute Artifacts_In_Exec_Dir: the list of file + -- names to be cleaned in the object dir of every + -- project. + + List := Attribute.Value.Values; + + if List /= Nil_String then + Put (Into_List => + Project.Config.Artifacts_In_Object_Dir, + From_List => List, + In_Tree => Data.Tree); + end if; + end if; + end if; + + Attribute_Id := Attribute.Next; + end loop; + end Process_Clean; + procedure Process_Clean (Arrays : Array_Id) is Current_Array_Id : Array_Id; Current_Array : Array_Data; @@ -1932,6 +1984,7 @@ package body Prj.Nmsc is -- Process attributes of package Clean + Process_Clean (Element.Decl.Attributes); Process_Clean (Element.Decl.Arrays); when Name_Compiler => @@ -2663,7 +2716,8 @@ package body Prj.Nmsc is Other : Source_Id; Unit_Found : Boolean; - Interface_ALIs : String_List_Id := Nil_String; + Interface_ALIs : String_List_Id := Nil_String; + Other_Interfaces : String_List_Id := Nil_String; begin if not Interfaces.Default then @@ -2718,6 +2772,8 @@ package body Prj.Nmsc is Other.Declared_In_Interfaces := True; end if; + -- Unit based case + if Source.Language.Config.Kind = Unit_Based then if Source.Kind = Spec and then Other_Part (Source) /= No_Source @@ -2741,6 +2797,26 @@ package body Prj.Nmsc is Interface_ALIs := String_Element_Table.Last (Shared.String_Elements); + + -- File based case + + else + String_Element_Table.Increment_Last + (Shared.String_Elements); + + Shared.String_Elements.Table + (String_Element_Table.Last + (Shared.String_Elements)) := + (Value => Name_Id (Source.File), + Index => 0, + Display_Value => Name_Id (Source.Display_File), + Location => No_Location, + Flag => False, + Next => Other_Interfaces); + + Other_Interfaces := + String_Element_Table.Last + (Shared.String_Elements); end if; Debug_Output @@ -2772,6 +2848,7 @@ package body Prj.Nmsc is Project.Interfaces_Defined := True; Project.Lib_Interface_ALIs := Interface_ALIs; + Project.Other_Interfaces := Other_Interfaces; elsif Project.Library and then not Library_Interface.Default then diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 66f878688d0..089d0c76c0d 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -165,8 +165,8 @@ package Prj is -- The defined kinds of variables Ignored : constant Variable_Kind; - -- Used to indicate that a package declaration must be ignored - -- while processing the project tree (unknown package name). + -- Used to indicate that a package declaration must be ignored while + -- processing the project tree (unknown package name). type Variable_Value (Kind : Variable_Kind := Undefined) is record Project : Project_Id := No_Project; @@ -262,7 +262,7 @@ package Prj is Attributes => No_Variable, Arrays => No_Array, Packages => No_Package); - -- Default value of Declarations: indicates that there is no declarations + -- Default value of Declarations: used if there are no declarations type Package_Element is record Name : Name_Id := No_Name; @@ -435,8 +435,8 @@ package Prj is function Other_Part (Source : Source_Id) return Source_Id; pragma Inline (Other_Part); - -- Source ID for the other part, if any: for a spec, indicates its body; - -- for a body, indicates its spec. + -- Source ID for the other part, if any: for a spec, returns its body; + -- for a body, returns its spec. No_Source : constant Source_Id := null; @@ -595,9 +595,9 @@ package Prj is -- spec pattern. Config_File_Unique : Boolean := False; - -- Indicate if the config file specified to the compiler needs to be - -- unique. If it is unique, then all config files are concatenated into - -- a temp config file. + -- True if the config file specified to the compiler needs to be unique. + -- If it is unique, then all config files are concatenated into a temp + -- config file. Binder_Driver : File_Name_Type := No_File; -- The name of the binder driver for the language, if any @@ -675,16 +675,26 @@ package Prj is Clean_Object_Artifacts => No_Name_List, Clean_Source_Artifacts => No_Name_List); - -- The following record ??? - type Language_Data is record - Name : Name_Id := No_Name; - Display_Name : Name_Id := No_Name; - Config : Language_Config := No_Language_Config; - First_Source : Source_Id := No_Source; + Name : Name_Id := No_Name; + -- The name of the language in lower case + + Display_Name : Name_Id := No_Name; + -- The name of the language, as found in attribute Languages + + Config : Language_Config := No_Language_Config; + -- Configuration of the language + + First_Source : Source_Id := No_Source; + -- Head of the list of sources of the language in the project + Mapping_Files : Mapping_Files_Htable.Instance := Mapping_Files_Htable.Nil; - Next : Language_Ptr := No_Language_Index; + -- Hash table containing the mapping of the sources to their path names + + Next : Language_Ptr := No_Language_Index; + -- Next language of the project + end record; No_Language_Data : constant Language_Data := @@ -755,8 +765,7 @@ package Prj is -- recursive notation <dir>/** is used in attribute Source_Dirs. Language : Language_Ptr := No_Language_Index; - -- Index of the language. This is an index into - -- Project_Tree.Languages_Data. + -- Language of the source In_Interfaces : Boolean := True; -- False when the source is not included in interfaces, when attribute @@ -1133,6 +1142,17 @@ package Prj is Auto_Init_Supported : Boolean := False; -- True if automatic initialisation is supported for shared stand-alone -- libraries. + + -- Cleaning + + Artifacts_In_Exec_Dir : Name_List_Index := No_Name_List; + -- List of regexp file names to be cleaned in the exec directory of the + -- main project. + + Artifacts_In_Object_Dir : Name_List_Index := No_Name_List; + -- List of regexp file names to be cleaned in the object directory of + -- all projects. + end record; Default_Project_Config : constant Project_Configuration := @@ -1167,7 +1187,9 @@ package Prj is Lib_Version_Options => No_Name_List, Symbolic_Link_Supported => False, Lib_Maj_Min_Id_Supported => False, - Auto_Init_Supported => False); + Auto_Init_Supported => False, + Artifacts_In_Exec_Dir => No_Name_List, + Artifacts_In_Object_Dir => No_Name_List); ------------------------- -- Aggregated projects -- @@ -1245,10 +1267,8 @@ package Prj is --------------- Languages : Language_Ptr := No_Language_Index; - -- First index of the language data in the project. - -- This is an index into the project_tree_data.languages_data. - -- Traversing the list gives access to all the languages supported by - -- the project. + -- First index of the language data in the project. Traversing the list + -- gives access to all the languages supported by the project. -------------- -- Projects -- @@ -1332,19 +1352,20 @@ package Prj is -- Indicate that this is a Standalone Library Project File Lib_Interface_ALIs : String_List_Id := Nil_String; - -- For Standalone Library Project Files, indicate the list of Interface - -- ALI files. + -- For Standalone Library Project Files, list of Interface ALI files. + + Other_Interfaces : String_List_Id := Nil_String; + -- List of non unit based sources in attribute Interfaces Lib_Auto_Init : Boolean := False; - -- For non static Stand-Alone Library Project Files, indicate if - -- the library initialisation should be automatic. + -- For non static Stand-Alone Library Project Files, True if the library + -- initialisation should be automatic. Symbol_Data : Symbol_Record := No_Symbols; -- Symbol file name, reference symbol file name, symbol policy Need_To_Build_Lib : Boolean := False; - -- Indicates that the library of a Library Project needs to be built or - -- rebuilt. + -- True if the library of a Library Project needs to be built or rebuilt ------------- -- Sources -- @@ -1402,8 +1423,8 @@ package Prj is -- The path name of the configuration pragmas file, if any Config_File_Temp : Boolean := False; - -- An indication that the configuration pragmas file is a temporary file - -- that must be deleted at the end. + -- True if the configuration pragmas file is a temporary file that must + -- be deleted at the end. Config_Checked : Boolean := False; -- A flag to avoid checking repetitively the configuration pragmas file @@ -1959,8 +1980,7 @@ private -- setting the env var to the same value. When different from No_Path, -- this indicates that logical names (VMS) or environment variables were -- created and should be deassigned to avoid polluting the environment - -- on VMS. - -- gnatmake only + -- on VMS. This is for gnatmake only. Current_Object_Path_File : Path_Name_Type := No_Path; -- Current value of project object path file env var. Used to avoid diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index 7072e0e6ada..4a6f0533eb4 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -41,7 +41,7 @@ project files allow you to specify: @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; +@item ^Switch^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) @@ -68,7 +68,7 @@ Subsystems}). 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. + (^switch^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 @@ -89,7 +89,7 @@ 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 + directories via different ^switch^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 @@ -174,6 +174,7 @@ detailed later in this documentation. They are summarized here as a reference. @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. +/first exam @end table @@ -184,7 +185,8 @@ 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 +these source files with the ^switch^switch^ +@option{^-O2^-O2^}, and put the resulting files in the directory @file{obj/}. @smallexample @@ -448,7 +450,8 @@ 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}). +the switch @code{^-p^/CREATE_MISSING_DIRS^} 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. @@ -614,13 +617,13 @@ packages would be involved in the build process. @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 +of the example, we want to compile all files with @option{^-O2^-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: +Several attributes can be used to specify the ^switches^switches^: @table @asis @item @b{Default_Switches}: @@ -633,49 +636,53 @@ Several attributes can be used to specify the switches: 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 - @option{-O2} switch, and the resulting project file is as follows + In this example, we want to compile all Ada source files with the ^switch^switch^ + @option{^-O2^-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{for} Default_Switches ("Ada") @b{use} ("^-O2^-O2^"); @b{end} Compiler; @end smallexample -@item @b{Switches}: -@cindex @code{Switches} - in some cases, we might want to use specific switches +@item @b{^Switches^Switches^}: +@cindex @code{^Switches^Switches^} + in some cases, we might want to use specific ^switches^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} + In such a case, the @emph{^Switches^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 - @b{package} Compiler @b{is} - @b{for} Default_Switches ("Ada") @b{use} ("-O2"); - @b{for} Switches ("proc.adb") @b{use} ("-O0"); - @b{end} Compiler; + package Compiler is + for Default_Switches ("Ada") + use ("^-O2^-O2^"); + for ^Switches^Switches^ ("proc.adb") + use ("^-O0^-O0^"); + end Compiler; @end smallexample @noindent - @code{Switches} may take a pattern as an index, such as in: + @code{^Switches^Switches^} may take a pattern as an index, such as in: @smallexample - @b{package} Compiler @b{is} - @b{for} Default_Switches ("Ada") @b{use} ("-O2"); - @b{for} Switches ("pkg*") @b{use} ("-O0"); - @b{end} Compiler; + package Compiler is + for Default_Switches ("Ada") + use ("^-O2^-O2^"); + for ^Switches^Switches^ ("pkg*") + use ("^-O0^-O0^"); + end Compiler; @end smallexample @noindent - Sources @file{pkg.adb} and @file{pkg-child.adb} would be compiled with -O0, - not -O2. + Sources @file{pkg.adb} and @file{pkg-child.adb} would be compiled with ^-O0^-O0^, + not ^-O2^-O2^. @noindent - @code{Switches} can also be given a language name as index instead of a file + @code{^Switches^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. @@ -689,7 +696,7 @@ Several attributes can be used to specify the switches: @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 +@b{Default_Switches} and @b{^Switches^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). @@ -816,8 +823,8 @@ project C_Main is package Compiler is C_Switches := ("-pedantic"); for Default_Switches ("C") use C_Switches; - for Default_Switches ("Ada") use ("-gnaty"); - for Switches ("main.c") use C_Switches & ("-g"); + for Default_Switches ("Ada") use ("^-gnaty^-gnaty^"); + for ^Switches^Switches^ ("main.c") use C_Switches & ("-g"); end Compiler; end C_Main; @end smallexample @@ -841,7 +848,7 @@ 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 - for Switches ("c_main.c") use Compiler'Default_Switches ("C") & ("-g"); + for ^Switches^Switches^ ("c_main.c") use Compiler'Default_Switches ("C") & ("-g"); @end smallexample @noindent @@ -1353,10 +1360,12 @@ There are two main approaches to avoiding this duplication: @smallexample @c projectfile project Logging is package Compiler is - for Switches ("Ada") use ("-O2"); + for ^Switches^Switches^ ("Ada") + use ("^-O2^-O2^"); end Compiler; package Binder is - for Switches ("Ada") use ("-E"); + for ^Switches^Switches^ ("Ada") + use ("-E"); end Binder; end Logging; @@ -1364,7 +1373,7 @@ There are two main approaches to avoiding this duplication: project Build is package Compiler renames Logging.Compiler; package Binder is - for Switches ("Ada") use Logging.Binder'Switches ("Ada"); + for ^Switches^Switches^ ("Ada") use Logging.Binder'Switches ("Ada"); end Binder; end Build; @end smallexample @@ -1394,9 +1403,10 @@ There are two main approaches to avoiding this duplication: @smallexample @c projectfile abstract project Shared is - for Source_Files use (); -- no project + for Source_Files use (); -- no sources package Compiler is - for Switches ("Ada") use ("-O2"); + for ^Switches^Switches^ ("Ada") + use ("^-O2^-O2^"); end Compiler; end Shared; @@ -1482,7 +1492,7 @@ information, when the second will focus on improving code optimization). Let's enhance our example to support a debug and a 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} +use @option{-g} as compiler switches in debug mode and @option{^-O2^-O2^} in release mode. We will also setup 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 2 modes. @@ -1556,9 +1566,11 @@ sections in the project. The following example shows how this can be done: package Compiler is case Mode is when "debug" => - for Switches ("Ada") use ("-g"); + for ^Switches^Switches^ ("Ada") + use ("-g"); when "release" => - for Switches ("Ada") use ("-O2"); + for ^Switches^Switches^ ("Ada") + use ("^-O2^-O2^"); end case; end Compiler; end Build; @@ -2414,7 +2426,7 @@ building. The syntax looks like for External ("BUILD") use "PRODUCTION"; package Builder is - for Switches ("Ada") use ("-q"); + for ^Switches^Switches^ ("Ada") use ("-q"); end Builder; end Agg; @end smallexample @@ -2681,15 +2693,15 @@ an aggregate project. In this package, only the following attributes are valid: @table @asis -@item @b{Switches}: -@cindex @code{Switches} +@item @b{^Switches^Switches^}: +@cindex @code{^Switches^Switches^} This attribute gives the list of switches to use for the builder (@command{gprbuild} or @command{gnatmake}), depending on the language of the main file. For instance, @smallexample @c projectfile -for Switches ("Ada") use ("-d", "-p"); -for Switches ("C") use ("-p"); +for ^Switches^Switches^ ("Ada") use ("-d", "-p"); +for ^Switches^Switches^ ("C") use ("-p"); @end smallexample These switches are only read from the main aggregate project (the @@ -2705,8 +2717,8 @@ This attribute gives the list of compiler switches for the various languages. For instance, @smallexample @c projectfile -for Global_Compilation_Switches ("Ada") use ("-O1", "-g"); -for Global_Compilation_Switches ("C") use ("-O2"); +for Global_Compilation_Switches ("Ada") use ("^O1^-O1^", "-g"); +for Global_Compilation_Switches ("C") use ("^-O2^-O2^"); @end smallexample This attribute is only taken into account in the aggregate project @@ -2728,34 +2740,39 @@ both depend on C. Here is an extra for all of these projects: aggregate project Agg is for Project_Files use ("a.gpr", "b.gpr"); package Builder is - for Global_Compilation_Switches ("Ada") use ("-O2"); + for Global_Compilation_Switches ("Ada") use ("^-O2^-O2^"); end Builder; end Agg; with "c.gpr"; project A is package Builder is - for Global_Compilation_Switches ("Ada") use ("-O1"); + for Global_Compilation_Switches ("Ada") use ("^-O1^-O1^"); -- ignored end Builder; package Compiler is - for Default_Switches ("Ada") use ("-O1", "-g"); - for Switches ("a_file1.adb") use ("-O0"); + for Default_Switches ("Ada") + use ("^-O1^-O1^", "-g"); + for ^Switches^Switches^ ("a_file1.adb") + use ("^-O0^-O0^"); end Compiler; end A; with "c.gpr"; project B is package Compiler is - for Default_Switches ("Ada") use ("-O0"); + for Default_Switches ("Ada") use ("^-O0^-O0^"); end Compiler; end B; project C is package Compiler is - for Default_Switches ("Ada") use ("-O3", "-gnatn"); - for Switches ("c_file1.adb") use ("-O0", "-g"); + for Default_Switches ("Ada") + use ("^-O3^-O3^", + "^-gnatn^-gnatn^"); + for ^Switches^Switches^ ("c_file1.adb") + use ("^-O0^-O0^", "-g"); end Compiler; end C; @end smallexample @@ -2764,13 +2781,13 @@ 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. + with "^-O2^-O2^ -g", since the aggregate project has priority. @item the file a_file1.adb is compiled with - "-O0", since the Compiler.Switches has priority + "^-O0^-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" + "^-O2^-O2^", since the aggregate project has priority +@item all files from C are compiled with "^-O2^-O2^ -gnatn", except for + c_file1.adb which is compiled with "^-O0^-O0^ -g" @end itemize Even though C is seen through two paths (through A and through @@ -3141,25 +3158,25 @@ The following packages are currently supported 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 + @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the package @code{Builder}. @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 + @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the package @code{Builder}. @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 + @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the package @code{Builder}. -@item Gnatls +@item ^Gnatls^Gnatls^ This package the options to use when invoking @command{gnatls} via the @command{gnat} driver. -@item Gnatstub +@item ^Gnatstub^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 + @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the package @code{Builder}. @item IDE This package specifies the options used when starting an integrated @@ -3173,7 +3190,7 @@ The following packages are currently supported in project files @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 + @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the package @code{Builder}. @item Naming This package specifies the naming conventions that apply @@ -3184,7 +3201,7 @@ The following packages are currently supported in project files @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 + @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the package @code{Builder}. @item Remote This package is used by @command{gprbuild} to describe how distributed @@ -3192,7 +3209,7 @@ The following packages are currently supported in project files @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 + @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the package @code{Builder}. @item Synchronize This package specifies the options used when calling the tool @@ -3401,11 +3418,14 @@ last separator and the end are components of the string list. @end smallexample @noindent -If the external value is "-O2,-g", the result is ("-O2", "-g"). +If the external value is "^-O2^-O2^,-g", +the result is ("^-O2^-O2^", "-g"). -If the external value is ",-O2,-g,", the result is also ("-O2", "-g"). +If the external value is ",^-O2^-O2^,-g,", +the result is also ("^-O2^-O2^", "-g"). -if the external value is "-gnav", the result is ("-gnatv"). +if the external value is "^-gnatv^-gnatv^", +the result is ("^-gnatv^-gnatv^"). If the external value is ",,", the result is (""). @@ -3582,9 +3602,11 @@ project MyProj is package Compiler is case OS is when "GNU/Linux" | "Unix" => - for Switches ("Ada") use ("-gnath"); + for ^Switches^Switches^ ("Ada") + use ("-gnath"); when "NT" => - for Switches ("Ada") use ("-gnatP"); + for ^Switches^Switches^ ("Ada") + use ("^-gnatP^-gnatP^"); when others => null; end case; @@ -3608,8 +3630,8 @@ end MyProj; * Package Cross_Reference Attributes:: * Package Eliminate Attributes:: * Package Finder Attributes:: -* Package gnatls Attributes:: -* Package gnatstub Attributes:: +* Package ^gnatls^gnatls^ Attributes:: +* Package ^gnatstub^gnatstub^ Attributes:: * Package IDE Attributes:: * Package Install Attributes:: * Package Linker Attributes:: @@ -3663,8 +3685,9 @@ Here are some examples of attribute declarations: -- indexed attributes for Body ("main") use "Main.ada"; - for Switches ("main.ada") use ("-v", "-gnatv"); - for Switches ("main.ada") use Builder'Switches ("main.ada") & "-g"; + for ^Switches^Switches^ ("main.ada") + use ("-v", "^-gnatv^-gnatv^"); + for ^Switches^Switches^ ("main.ada") use Builder'Switches ("main.ada") & "-g"; -- indexed attributes copy (from package Builder in project Default) -- The package name must always be specified, even if it is the current @@ -3962,6 +3985,14 @@ the command line when linking a shared library. 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 @@ -4158,10 +4189,10 @@ sources of runtime libraries are located. @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. +code of the language, if there is no applicable attribute ^Switches^Switches^. -@item @b{Switches}: list, optional index, indexed, case-insensitive index, - others allowed +@item @b{^Switches^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 @@ -4215,7 +4246,7 @@ 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, +@item @b{^Switches^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 @@ -4261,9 +4292,9 @@ project tree. 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. +attribute ^Switches^Switches^. -@item @b{Switches}: list, optional index, indexed, case-insensitive index, +@item @b{^Switches^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 @@ -4276,7 +4307,7 @@ invoking @code{gnatcheck} for the source. @itemize @bullet -@item @b{Switches}: list +@item @b{^Switches^Switches^}: list Value is a list of switches to be used by the cleaning application. @@ -4292,6 +4323,16 @@ 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 @@ -4309,7 +4350,7 @@ 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, +@item @b{^Switches^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 @@ -4543,7 +4584,7 @@ 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, +@item @b{^Switches^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 @@ -4562,7 +4603,7 @@ 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, +@item @b{^Switches^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 @@ -4581,7 +4622,7 @@ 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, +@item @b{^Switches^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 @@ -4589,19 +4630,19 @@ invoking @code{gnatfind} for the source. @end itemize -@node Package gnatls Attributes -@subsubsection Package gnatls Attributes +@node Package ^gnatls^gnatls^ Attributes +@subsubsection Package ^gnatls^gnatls^ Attributes @itemize @bullet -@item @b{Switches}: list +@item @b{^Switches^Switches^}: list Value is a list of switches to be used when invoking @code{gnatls}. @end itemize -@node Package gnatstub Attributes -@subsubsection Package gnatstub Attributes +@node Package ^gnatstub^gnatstub^ Attributes +@subsubsection Package ^gnatstub^gnatstub^ Attributes @itemize @bullet @@ -4609,9 +4650,9 @@ Value is a list of switches to be used when invoking @code{gnatls}. 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. +attribute ^Switches^Switches^. -@item @b{Switches}: list, optional index, indexed, case-insensitive index, +@item @b{^Switches^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 @@ -4658,16 +4699,18 @@ the handling of switches. 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 +@item @b{^gnatlist^gnatlist^}: single -Value is a string that specifies the name of the @command{gnatls} utility +Value is a string that specifies the name of the @command{^gnatls^gnatls^} utility to be used to retrieve information about the predefined path; for example, -@code{"gnatls"}, @code{"powerpc-wrs-vxworks-gnatls"}. +@code{"^gnatls^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 CVS, RCS, ClearCase or Perforce. +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 @@ -4746,7 +4789,7 @@ 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, +@item @b{^Switches^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 @@ -4819,7 +4862,7 @@ 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, +@item @b{^Switches^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 @@ -4907,7 +4950,7 @@ 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, +@item @b{^Switches^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 @@ -4936,7 +4979,7 @@ Value is the root directory used by the slave machines. @itemize @bullet -@item @b{Switches}: list +@item @b{^Switches^Switches^}: list Value is the list of switches to be used when invoking @code{gnatstack}. @@ -4953,7 +4996,7 @@ 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, +@item @b{^Switches^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 diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index d80456436ec..ca1e84afa9a 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -87,6 +87,36 @@ extern void __gnat_unhandled_except_handler (_Unwind_Exception *); #define CXX_EXCEPTION_CLASS 0x474e5543432b2b00ULL #define GNAT_EXCEPTION_CLASS 0x474e552d41646100ULL +/* Structure of a C++ exception, represented as a C structure... See + unwind-cxx.h for the full definition. */ + +struct __cxa_exception +{ + void *exceptionType; + void (*exceptionDestructor)(void *); + + void (*unexpectedHandler)(); + void (*terminateHandler)(); + + struct __cxa_exception *nextException; + + int handlerCount; + +#ifdef __ARM_EABI_UNWINDER__ + struct __cxa_exception* nextPropagatingException; + + int propagationCount; +#else + int handlerSwitchValue; + const unsigned char *actionRecord; + const unsigned char *languageSpecificData; + _Unwind_Ptr catchTemp; + void *adjustedPtr; +#endif + + _Unwind_Exception unwindHeader; +}; + /* -------------------------------------------------------------- -- The DB stuff below is there for debugging purposes only. -- -------------------------------------------------------------- */ @@ -812,22 +842,32 @@ get_call_site_action_for (_Unwind_Ptr ip, #define Is_Handled_By_Others __gnat_is_handled_by_others #define Language_For __gnat_language_for -#define Import_Code_For __gnat_import_code_for +#define Foreign_Data_For __gnat_foreign_data_for #define EID_For __gnat_eid_for extern bool Is_Handled_By_Others (_Unwind_Ptr eid); extern char Language_For (_Unwind_Ptr eid); -extern Exception_Code Import_Code_For (_Unwind_Ptr eid); +extern void *Foreign_Data_For (_Unwind_Ptr eid); extern Exception_Id EID_For (_GNAT_Exception * e); +#define Foreign_Exception system__exceptions__foreign_exception +extern struct Exception_Data Foreign_Exception; + +#ifdef VMS +#define Non_Ada_Error system__aux_dec__non_ada_error +extern struct Exception_Data Non_Ada_Error; +#endif + static enum action_kind is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception) { + /* All others choice match everything. */ if (choice == GNAT_ALL_OTHERS) return handler; + /* GNAT exception occurrence. */ if (propagated_exception->common.exception_class == GNAT_EXCEPTION_CLASS) { /* Pointer to the GNAT exception data corresponding to the propagated @@ -845,6 +885,7 @@ is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception) if (choice == E || (choice == GNAT_OTHERS && Is_Handled_By_Others (E))) return handler; +#ifdef VMS /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we may have different exception data pointers that should match for the same condition code, if both an export and an import have been @@ -852,29 +893,41 @@ is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception) occurrence are expected to have been masked off regarding severity bits already (at registration time for the former and from within the low level exception vector for the latter). */ -#ifdef VMS -# define Non_Ada_Error system__aux_dec__non_ada_error - extern struct Exception_Data Non_Ada_Error; - if ((Language_For (E) == 'V' && choice != GNAT_OTHERS && ((Language_For (choice) == 'V' - && Import_Code_For (choice) != 0 - && Import_Code_For (choice) == Import_Code_For (E)) + && Foreign_Data_For (choice) != 0 + && Foreign_Data_For (choice) == Foreign_Data_For (E)) || choice == (_Unwind_Ptr)&Non_Ada_Error))) return handler; #endif + + /* Otherwise, it doesn't match an Ada choice. */ + return nothing; } - else - { -# define Foreign_Exception system__exceptions__foreign_exception - extern struct Exception_Data Foreign_Exception; - if (choice == GNAT_ALL_OTHERS - || choice == GNAT_OTHERS - || choice == (_Unwind_Ptr) &Foreign_Exception) + /* All others and others choice match any foreign exception. */ + if (choice == GNAT_ALL_OTHERS + || choice == GNAT_OTHERS + || choice == (_Unwind_Ptr) &Foreign_Exception) + return handler; + + /* C++ exception occurrences. */ + if (propagated_exception->common.exception_class == CXX_EXCEPTION_CLASS + && Language_For (choice) == 'C') + { + void *choice_typeinfo = Foreign_Data_For (choice); + void *except_typeinfo = + (((struct __cxa_exception *) + ((_Unwind_Exception *)propagated_exception + 1)) - 1)->exceptionType; + + /* Typeinfo are directly compared, which might not be correct if they + aren't merged. ??? We should call the == operator if this module is + compiled in C++. */ + if (choice_typeinfo == except_typeinfo) return handler; } + return nothing; } @@ -1164,7 +1217,9 @@ PERSONALITY_FUNCTION (version_arg_t version_arg, setup_to_install (uw_context, uw_exception, action.landing_pad, action.ttype_filter); - /* Write current exception, so that it can be retrieved from Ada. */ + /* Write current exception, so that it can be retrieved from Ada. It was + already done during phase 1 (just above), but in between, one or several + exceptions may have been raised (in cleanup handlers). */ __gnat_setup_current_excep (uw_exception); return _URC_INSTALL_CONTEXT; @@ -1408,3 +1463,10 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame, ms_disp, __gnat_personality_imp); } #endif /* SEH */ + +#if !defined (__USING_SJLJ_EXCEPTIONS__) +/* Size of the _Unwind_Exception structure. This is used by g-cppexc to get + the offset to the C++ object. */ + +const int __gnat_unwind_exception_size = sizeof (_Unwind_Exception); +#endif diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h index 57611542350..8f699bc6269 100644 --- a/gcc/ada/raise.h +++ b/gcc/ada/raise.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2012, Free Software Foundation, Inc. * + * Copyright (C) 1992-2013, 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,15 +35,14 @@ extern "C" { /* C counterparts of what System.Standard_Library defines. */ -typedef unsigned Exception_Code; - struct Exception_Data { char Not_Handled_By_Others; char Lang; int Name_Length; - char *Full_Name, *Htable_Ptr; - Exception_Code Import_Code; + char *Full_Name; + char *Htable_Ptr; + void *Foreign_Data; void (*Raise_Hook)(void); }; diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index ea0f89c43bc..668c4440d8d 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -1406,9 +1406,30 @@ package body Restrict is is Msg_Issued : Boolean; Save_Error_Msg_Sloc : Source_Ptr; + Onode : constant Node_Id := Original_Node (N); begin - if Force or else Comes_From_Source (Original_Node (N)) then + -- Output message if Force set + + if Force + + -- Or if this node comes from source + + or else Comes_From_Source (N) + + -- Or if this is a range node which rewrites a range attribute and + -- the range attribute comes from source. + + or else (Nkind (N) = N_Range + and then Nkind (Onode) = N_Attribute_Reference + and then Attribute_Name (Onode) = Name_Range + and then Comes_From_Source (Onode)) + + -- Or this is an expression that does not come from source, which is + -- a rewriting of an expression that does come from source. + + or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode)) + then if Restriction_Check_Required (SPARK_05) and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) then diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 22abb9a581f..75c4c5a5969 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -760,7 +760,7 @@ package body Rtsfind is -- a real semantic dependence when the purpose of the limited_with -- is precisely to avoid such. - if From_With_Type (Cunit_Entity (U.Unum)) then + if From_Limited_With (Cunit_Entity (U.Unum)) then null; else @@ -1120,7 +1120,7 @@ package body Rtsfind is -- only has a limited view, scan the corresponding list of -- incomplete types. - if From_With_Type (U.Entity) then + if From_Limited_With (U.Entity) then Pkg_Ent := First_Entity (Limited_View (U.Entity)); else Pkg_Ent := First_Entity (U.Entity); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 88cd740b00a..5ae85f32b96 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -591,6 +591,7 @@ package Rtsfind is RE_Root_Stream_Type, -- Ada.Streams RE_Stream_Element, -- Ada.Streams + RE_Stream_Element_Array, -- Ada.Streams RE_Stream_Element_Offset, -- Ada.Streams RE_Stream_Access, -- Ada.Streams.Stream_IO @@ -748,6 +749,7 @@ package Rtsfind is RE_Uint64, -- System.Atomic_Primitives RE_AST_Handler, -- System.Aux_DEC + RE_Import_Address, -- System.Aux_DEC RE_Import_Value, -- System.Aux_DEC RE_No_AST_Handler, -- System.Aux_DEC RE_Type_Class, -- System.Aux_DEC @@ -1413,7 +1415,6 @@ package Rtsfind is RE_Shared_Var_Procs, -- System.Shared_Storage RE_Abort_Undefer_Direct, -- System.Standard_Library - RE_Exception_Code, -- System.Standard_Library RE_Exception_Data_Ptr, -- System.Standard_Library RE_Integer_Address, -- System.Storage_Elements @@ -1477,6 +1478,24 @@ package Rtsfind is RE_W_WC, -- System.Stream_Attributes RE_W_WWC, -- System.Stream_Attributes + RE_Storage_Array_Input, -- System.Strings.Stream_Ops + RE_Storage_Array_Input_Blk_IO, -- System.Strings.Stream_Ops + RE_Storage_Array_Output, -- System.Strings.Stream_Ops + RE_Storage_Array_Output_Blk_IO, -- System.Strings.Stream_Ops + RE_Storage_Array_Read, -- System.Strings.Stream_Ops + RE_Storage_Array_Read_Blk_IO, -- System.Strings.Stream_Ops + RE_Storage_Array_Write, -- System.Strings.Stream_Ops + RE_Storage_Array_Write_Blk_IO, -- System.Strings.Stream_Ops + + RE_Stream_Element_Array_Input, -- System.Strings.Stream_Ops + RE_Stream_Element_Array_Input_Blk_IO, -- System.Strings.Stream_Ops + RE_Stream_Element_Array_Output, -- System.Strings.Stream_Ops + RE_Stream_Element_Array_Output_Blk_IO, -- System.Strings.Stream_Ops + RE_Stream_Element_Array_Read, -- System.Strings.Stream_Ops + RE_Stream_Element_Array_Read_Blk_IO, -- System.Strings.Stream_Ops + RE_Stream_Element_Array_Write, -- System.Strings.Stream_Ops + RE_Stream_Element_Array_Write_Blk_IO, -- System.Strings.Stream_Ops + RE_String_Input, -- System.Strings.Stream_Ops RE_String_Input_Blk_IO, -- System.Strings.Stream_Ops RE_String_Output, -- System.Strings.Stream_Ops @@ -1485,6 +1504,7 @@ package Rtsfind is RE_String_Read_Blk_IO, -- System.Strings.Stream_Ops RE_String_Write, -- System.Strings.Stream_Ops RE_String_Write_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_String_Input, -- System.Strings.Stream_Ops RE_Wide_String_Input_Blk_IO, -- System.Strings.Stream_Ops RE_Wide_String_Output, -- System.Strings.Stream_Ops @@ -1493,6 +1513,7 @@ package Rtsfind is RE_Wide_String_Read_Blk_IO, -- System.Strings.Stream_Ops RE_Wide_String_Write, -- System.Strings.Stream_Ops RE_Wide_String_Write_Blk_IO, -- System.Strings.Stream_Ops + RE_Wide_Wide_String_Input, -- System.Strings.Stream_Ops RE_Wide_Wide_String_Input_Blk_IO, -- System.Strings.Stream_Ops RE_Wide_Wide_String_Output, -- System.Strings.Stream_Ops @@ -1844,6 +1865,7 @@ package Rtsfind is RE_Root_Stream_Type => Ada_Streams, RE_Stream_Element => Ada_Streams, + RE_Stream_Element_Array => Ada_Streams, RE_Stream_Element_Offset => Ada_Streams, RE_Stream_Access => Ada_Streams_Stream_IO, @@ -2001,6 +2023,7 @@ package Rtsfind is RE_Uint64 => System_Atomic_Primitives, RE_AST_Handler => System_Aux_DEC, + RE_Import_Address => System_Aux_DEC, RE_Import_Value => System_Aux_DEC, RE_No_AST_Handler => System_Aux_DEC, RE_Type_Class => System_Aux_DEC, @@ -2670,7 +2693,6 @@ package Rtsfind is RE_Shared_Var_Procs => System_Shared_Storage, RE_Abort_Undefer_Direct => System_Standard_Library, - RE_Exception_Code => System_Standard_Library, RE_Exception_Data_Ptr => System_Standard_Library, RE_Integer_Address => System_Storage_Elements, @@ -2734,6 +2756,24 @@ package Rtsfind is RE_W_WC => System_Stream_Attributes, RE_W_WWC => System_Stream_Attributes, + RE_Storage_Array_Input => System_Strings_Stream_Ops, + RE_Storage_Array_Input_Blk_IO => System_Strings_Stream_Ops, + RE_Storage_Array_Output => System_Strings_Stream_Ops, + RE_Storage_Array_Output_Blk_IO => System_Strings_Stream_Ops, + RE_Storage_Array_Read => System_Strings_Stream_Ops, + RE_Storage_Array_Read_Blk_IO => System_Strings_Stream_Ops, + RE_Storage_Array_Write => System_Strings_Stream_Ops, + RE_Storage_Array_Write_Blk_IO => System_Strings_Stream_Ops, + + RE_Stream_Element_Array_Input => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Input_Blk_IO => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Output => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Output_Blk_IO => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Read => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Read_Blk_IO => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Write => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Write_Blk_IO => System_Strings_Stream_Ops, + RE_String_Input => System_Strings_Stream_Ops, RE_String_Input_Blk_IO => System_Strings_Stream_Ops, RE_String_Output => System_Strings_Stream_Ops, @@ -2742,6 +2782,7 @@ package Rtsfind is RE_String_Read_Blk_IO => System_Strings_Stream_Ops, RE_String_Write => System_Strings_Stream_Ops, RE_String_Write_Blk_IO => System_Strings_Stream_Ops, + RE_Wide_String_Input => System_Strings_Stream_Ops, RE_Wide_String_Input_Blk_IO => System_Strings_Stream_Ops, RE_Wide_String_Output => System_Strings_Stream_Ops, @@ -2749,6 +2790,7 @@ package Rtsfind is RE_Wide_String_Read => System_Strings_Stream_Ops, RE_Wide_String_Read_Blk_IO => System_Strings_Stream_Ops, RE_Wide_String_Write => System_Strings_Stream_Ops, + RE_Wide_String_Write_Blk_IO => System_Strings_Stream_Ops, RE_Wide_Wide_String_Input => System_Strings_Stream_Ops, RE_Wide_Wide_String_Input_Blk_IO => System_Strings_Stream_Ops, diff --git a/gcc/ada/s-atocou-builtin.adb b/gcc/ada/s-atocou-builtin.adb index f230721af00..55436aa8388 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, AdaCore -- +-- Copyright (C) 2011-2013, 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- -- @@ -64,14 +64,23 @@ package body System.Atomic_Counters is procedure Increment (Item : in out Atomic_Counter) is begin - -- Note: the use of Unrestricted_Access here is required because we - -- are obtaining an access-to-volatile pointer to a non-volatile object. + -- Note: the use of Unrestricted_Access here is required because we are + -- obtaining an access-to-volatile pointer to a non-volatile object. -- This is not allowed for [Unchecked_]Access, but is safe in this case -- because we know that no aliases are being created. Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1); end Increment; + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Item : out Atomic_Counter) is + begin + Item.Value := 1; + end Initialize; + ------------ -- Is_One -- ------------ diff --git a/gcc/ada/s-atocou-x86.adb b/gcc/ada/s-atocou-x86.adb index bd02c35699f..b85b40274fa 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, AdaCore -- +-- Copyright (C) 2011-2013, 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- -- @@ -74,6 +74,15 @@ package body System.Atomic_Counters is Volatile => True); end Increment; + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Item : out Atomic_Counter) is + begin + Item.Value := 1; + end Initialize; + ------------ -- Is_One -- ------------ diff --git a/gcc/ada/s-atocou.adb b/gcc/ada/s-atocou.adb index 8f2ca01b6d9..51cc79ba59d 100644 --- a/gcc/ada/s-atocou.adb +++ b/gcc/ada/s-atocou.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011, AdaCore -- +-- Copyright (C) 2011-2013, 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- -- @@ -57,6 +57,15 @@ package body System.Atomic_Counters is raise Program_Error; end Increment; + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Item : out Atomic_Counter) is + begin + raise Program_Error; + end Initialize; + ------------ -- Is_One -- ------------ diff --git a/gcc/ada/s-atocou.ads b/gcc/ada/s-atocou.ads index cad18d29896..55d6bf0ece8 100644 --- a/gcc/ada/s-atocou.ads +++ b/gcc/ada/s-atocou.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011, AdaCore -- +-- Copyright (C) 2011-2013, 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- -- @@ -65,6 +65,12 @@ package System.Atomic_Counters is pragma Inline_Always (Is_One); -- Returns True when value of the atomic counter is one. + procedure Initialize (Item : out Atomic_Counter); + pragma Inline_Always (Initialize); + -- Initialize counter by setting its value to one. This subprogram is + -- intended to be used in special cases when counter object can't be + -- initialized in standard way. + private type Unsigned_32 is mod 2 ** 32; diff --git a/gcc/ada/s-exctab.adb b/gcc/ada/s-exctab.adb index 5f2228ceb1a..afd46e96f7d 100644 --- a/gcc/ada/s-exctab.adb +++ b/gcc/ada/s-exctab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2013, 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- -- @@ -67,15 +67,12 @@ package body System.Exception_Table is S1 : constant Big_String_Ptr := To_Ptr (A); S2 : constant Big_String_Ptr := To_Ptr (B); J : Integer := 1; - begin loop if S1 (J) /= S2 (J) then return False; - elsif S1 (J) = ASCII.NUL then return True; - else J := J + 1; end if; @@ -180,7 +177,7 @@ package body System.Exception_Table is Name_Length => Copy'Length, Full_Name => Dyn_Copy.all'Address, HTable_Ptr => null, - Import_Code => 0, + Foreign_Data => Null_Address, Raise_Hook => null); Register_Exception (Res); diff --git a/gcc/ada/s-imgint.adb b/gcc/ada/s-imgint.adb index 12bc0f26f17..88dc5849def 100644 --- a/gcc/ada/s-imgint.adb +++ b/gcc/ada/s-imgint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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,39 +42,15 @@ package body System.Img_Int is is pragma Assert (S'First = 1); - procedure Set_Digits (T : Integer); - -- Set digits of absolute value of T, which is zero or negative. We work - -- with the negative of the value so that the largest negative number is - -- not a special case. - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Integer) is - begin - if T <= -10 then - Set_Digits (T / 10); - P := P + 1; - S (P) := Character'Val (48 - (T rem 10)); - else - P := P + 1; - S (P) := Character'Val (48 - T); - end if; - end Set_Digits; - - -- Start of processing for Image_Integer - begin - P := 1; - if V >= 0 then - S (P) := ' '; - Set_Digits (-V); + S (1) := ' '; + P := 1; else - S (P) := '-'; - Set_Digits (V); + P := 0; end if; + + Set_Image_Integer (V, S, P); end Image_Integer; ----------------------- diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 096488671e0..2357d61d699 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2013, 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- -- @@ -1389,13 +1389,10 @@ CST(Inet_Pton_Linkname, "") /* Note: On HP-UX, CLOCK_REALTIME is an enum, not a macro. */ -#if defined(CLOCK_REALTIME) || defined (__hpux__) -# define HAVE_CLOCK_REALTIME +#if !(defined(CLOCK_REALTIME) || defined (__hpux__)) +# define CLOCK_REALTIME (-1) #endif - -#ifdef HAVE_CLOCK_REALTIME CND(CLOCK_REALTIME, "System realtime clock") -#endif #ifdef CLOCK_MONOTONIC CND(CLOCK_MONOTONIC, "System monotonic clock") @@ -1410,19 +1407,19 @@ CND(CLOCK_FASTEST, "Fastest clock") #endif CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock") -#if defined(__APPLE__) -/* There's no clock_gettime or clock_id's on Darwin, generate a dummy value */ -# define CLOCK_RT_Ada "-1" - -#elif defined(__FreeBSD__) || defined(_AIX) +#if defined(__FreeBSD__) || (defined(_AIX) && defined(_AIXVERSION_530)) /** On these platforms use system provided monotonic clock instead of ** the default CLOCK_REALTIME. We then need to set up cond var attributes ** appropriately (see thread.c). + ** + ** Note that AIX 5.2 does not support CLOCK_MONOTONIC timestamps for + ** pthread_cond_timedwait (and does not have pthread_condattr_setclock), + ** hence the conditionalization on AIX version above). _AIXVERSION_530 + ** is defined in AIX 5.3 and more recent versions. **/ # define CLOCK_RT_Ada "CLOCK_MONOTONIC" -# define NEED_PTHREAD_CONDATTR_SETCLOCK -#elif defined(HAVE_CLOCK_REALTIME) +#else /* By default use CLOCK_REALTIME */ # define CLOCK_RT_Ada "CLOCK_REALTIME" #endif @@ -1435,13 +1432,11 @@ CNS(CLOCK_RT_Ada, "") /* -- Sizes of pthread data types - */ #if defined (__APPLE__) || defined (DUMMY) /* -- (on Darwin, these are just placeholders) - */ #define PTHREAD_SIZE __PTHREAD_SIZE__ #define PTHREAD_ATTR_SIZE __PTHREAD_ATTR_SIZE__ @@ -1463,7 +1458,9 @@ CNS(CLOCK_RT_Ada, "") #define PTHREAD_RWLOCK_SIZE (sizeof (pthread_rwlock_t)) #define PTHREAD_ONCE_SIZE (sizeof (pthread_once_t)) #endif +/* +*/ CND(PTHREAD_SIZE, "pthread_t") CND(PTHREAD_ATTR_SIZE, "pthread_attr_t") CND(PTHREAD_MUTEXATTR_SIZE, "pthread_mutexattr_t") diff --git a/gcc/ada/s-osinte-aix.adb b/gcc/ada/s-osinte-aix.adb index bfe03a637b2..2d5f160ca5f 100644 --- a/gcc/ada/s-osinte-aix.adb +++ b/gcc/ada/s-osinte-aix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2013, 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- -- @@ -99,48 +99,6 @@ 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); - - -- Older AIX don't have clock_gettime, so use gettimeofday - - use Interfaces; - - type timeval is array (1 .. 2) of C.long; - - procedure timeval_to_duration - (T : not null access timeval; - sec : not null access C.long; - usec : not null access C.long); - pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); - - Micro : constant := 10**6; - sec : aliased C.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; - ----------------- -- sched_yield -- ----------------- diff --git a/gcc/ada/s-osinte-aix.ads b/gcc/ada/s-osinte-aix.ads index c89e7296e14..6fce65ffd23 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-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2013, 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,6 +41,7 @@ with Ada.Unchecked_Conversion; with Interfaces.C; +with Interfaces.C.Extensions; package System.OS_Interface is pragma Preelaborate; @@ -55,6 +56,7 @@ package System.OS_Interface is subtype int is Interfaces.C.int; subtype short is Interfaces.C.short; subtype long is Interfaces.C.long; + subtype long_long is Interfaces.C.Extensions.long_long; subtype unsigned is Interfaces.C.unsigned; subtype unsigned_short is Interfaces.C.unsigned_short; subtype unsigned_long is Interfaces.C.unsigned_long; @@ -197,11 +199,12 @@ package System.OS_Interface is type timespec is private; - type clockid_t is new int; + type clockid_t is new long_long; function clock_gettime (clock_id : clockid_t; tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); function To_Duration (TS : timespec) return Duration; pragma Inline (To_Duration); diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/s-regpat.adb index cee229ef6b5..88143289e44 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-2011, AdaCore -- +-- Copyright (C) 1999-2013, 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- -- @@ -921,7 +921,7 @@ package body System.Regpat is Link_Tail (IP, Ender); - if Have_Branch and then Emit_Ptr <= PM.Size then + if Have_Branch and then Emit_Ptr <= PM.Size + 1 then -- Hook the tails of the branches to the closing node diff --git a/gcc/ada/s-stalib.ads b/gcc/ada/s-stalib.ads index f9a28e08017..6658afbae31 100644 --- a/gcc/ada/s-stalib.ads +++ b/gcc/ada/s-stalib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -74,26 +74,6 @@ package System.Standard_Library is function To_Ptr is new Ada.Unchecked_Conversion (System.Address, Big_String_Ptr); - --------------------------------------------- - -- Type For Enumeration Image Index Tables -- - --------------------------------------------- - - -- Note: these types are declared at the start of this unit, since - -- they must appear before any enumeration types declared in this - -- unit. Note that the spec of system is already elaborated at - -- this point (since we are a child of system), which means that - -- enumeration types in package System cannot use these types. - - type Image_Index_Table_8 is - array (Integer range <>) of Short_Short_Integer; - type Image_Index_Table_16 is - array (Integer range <>) of Short_Integer; - type Image_Index_Table_32 is - array (Integer range <>) of Integer; - -- These types are used to generate the index vector used for enumeration - -- type image tables. See spec of Exp_Imgv in the main GNAT sources for a - -- full description of the data structures that are used here. - ------------------------------------- -- Exception Declarations and Data -- ------------------------------------- @@ -105,20 +85,6 @@ package System.Standard_Library is type Exception_Data_Ptr is access all Exception_Data; -- An equivalent of Exception_Id that is public - type Exception_Code is mod 2 ** Integer'Size; - -- A scalar value bound to some exception data. Typically used for - -- imported or exported exceptions on VMS. Having a separate type for this - -- is useful to enforce consistency throughout the various run-time units - -- handling such codes, and having it unsigned is the most appropriate - -- choice for it's currently single use on VMS. - - -- ??? The construction in Cstand has no way to access the proper type - -- node for Exception_Code, and currently uses Standard_Unsigned as a - -- fallback. The representations shall match, and the size clause below - -- is aimed at ensuring that. - - for Exception_Code'Size use Integer'Size; - -- The following record defines the underlying representation of exceptions -- WARNING! Any changes to this may need to be reflected in the following @@ -141,6 +107,7 @@ package System.Standard_Library is -- A character indicating the language raising the exception. -- Set to "A" for exceptions defined by an Ada program. -- Set to "V" for imported VMS exceptions. + -- Set to "C" for imported C++ exceptions. Name_Length : Natural; -- Length of fully expanded name of exception @@ -154,11 +121,10 @@ package System.Standard_Library is -- built (by Register_Exception in s-exctab.adb) for converting between -- identities and names. - Import_Code : Exception_Code; - -- Value for imported exceptions. Needed only for the handling of - -- Import/Export_Exception for the VMS case, but present in all - -- implementations (we might well extend this mechanism for other - -- systems in the future). + Foreign_Data : Address; + -- Data for imported exceptions. This represents the exception code + -- for the handling of Import/Export_Exception for the VMS case. + -- This represents the address of the RTTI for the C++ case. Raise_Hook : Raise_Action; -- This field can be used to place a "hook" on an exception. If the @@ -189,7 +155,7 @@ package System.Standard_Library is Name_Length => Constraint_Error_Name'Length, Full_Name => Constraint_Error_Name'Address, HTable_Ptr => null, - Import_Code => 0, + Foreign_Data => Null_Address, Raise_Hook => null); Numeric_Error_Def : aliased Exception_Data := @@ -198,7 +164,7 @@ package System.Standard_Library is Name_Length => Numeric_Error_Name'Length, Full_Name => Numeric_Error_Name'Address, HTable_Ptr => null, - Import_Code => 0, + Foreign_Data => Null_Address, Raise_Hook => null); Program_Error_Def : aliased Exception_Data := @@ -207,7 +173,7 @@ package System.Standard_Library is Name_Length => Program_Error_Name'Length, Full_Name => Program_Error_Name'Address, HTable_Ptr => null, - Import_Code => 0, + Foreign_Data => Null_Address, Raise_Hook => null); Storage_Error_Def : aliased Exception_Data := @@ -216,7 +182,7 @@ package System.Standard_Library is Name_Length => Storage_Error_Name'Length, Full_Name => Storage_Error_Name'Address, HTable_Ptr => null, - Import_Code => 0, + Foreign_Data => Null_Address, Raise_Hook => null); Tasking_Error_Def : aliased Exception_Data := @@ -225,7 +191,7 @@ package System.Standard_Library is Name_Length => Tasking_Error_Name'Length, Full_Name => Tasking_Error_Name'Address, HTable_Ptr => null, - Import_Code => 0, + Foreign_Data => Null_Address, Raise_Hook => null); Abort_Signal_Def : aliased Exception_Data := @@ -234,7 +200,7 @@ package System.Standard_Library is Name_Length => Abort_Signal_Name'Length, Full_Name => Abort_Signal_Name'Address, HTable_Ptr => null, - Import_Code => 0, + Foreign_Data => Null_Address, Raise_Hook => null); pragma Export (C, Constraint_Error_Def, "constraint_error"); diff --git a/gcc/ada/s-stopoo.ads b/gcc/ada/s-stopoo.ads index e2d66ff747d..d6153acd409 100644 --- a/gcc/ada/s-stopoo.ads +++ b/gcc/ada/s-stopoo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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,6 +41,7 @@ package System.Storage_Pools is type Root_Storage_Pool is abstract new Ada.Finalization.Limited_Controlled with private; + pragma Preelaborable_Initialization (Root_Storage_Pool); procedure Allocate (Pool : in out Root_Storage_Pool; diff --git a/gcc/ada/s-stratt-xdr.adb b/gcc/ada/s-stratt-xdr.adb index d63c2514779..ae4c9b37e7c 100644 --- a/gcc/ada/s-stratt-xdr.adb +++ b/gcc/ada/s-stratt-xdr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- -- -- -- GARLIC 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- -- @@ -283,6 +283,10 @@ package body System.Stream_Attributes is -- Block_IO_OK -- ----------------- + -- We must inhibit Block_IO, because in XDR mode, each element is output + -- according to XDR requirements, which is not at all the same as writing + -- the whole array in one block. + function Block_IO_OK return Boolean is begin return False; diff --git a/gcc/ada/s-stratt.ads b/gcc/ada/s-stratt.ads index 498700e06b5..ce1b4f5e124 100644 --- a/gcc/ada/s-stratt.ads +++ b/gcc/ada/s-stratt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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,7 +88,6 @@ package System.Stream_Attributes is -- the first subtype is specified, or where an enumeration representation -- clause is given, these three types are treated like any other cases -- of enumeration types, as described above. - -- for --------------------- -- Input Functions -- @@ -114,8 +113,8 @@ package System.Stream_Attributes is function I_SF (Stream : not null access RST) return Short_Float; function I_SI (Stream : not null access RST) return Short_Integer; function I_SSI (Stream : not null access RST) return Short_Short_Integer; - function I_SSU (Stream : not null access RST) - return UST.Short_Short_Unsigned; + function I_SSU (Stream : not null access RST) return + UST.Short_Short_Unsigned; function I_SU (Stream : not null access RST) return UST.Short_Unsigned; function I_U (Stream : not null access RST) return UST.Unsigned; function I_WC (Stream : not null access RST) return Wide_Character; @@ -125,10 +124,10 @@ package System.Stream_Attributes is -- Output Procedures -- ----------------------- - -- Procedures for S'Write attribute. These procedures are also used - -- for 'Output, since for elementary types there is no difference - -- between 'Write and 'Output because there are no discriminants - -- or bounds to be written. + -- Procedures for S'Write attribute. These procedures are also used for + -- 'Output, since for elementary types there is no difference between + -- 'Write and 'Output because there are no discriminants or bounds to + -- be written. procedure W_AD (Stream : not null access RST; Item : Fat_Pointer); procedure W_AS (Stream : not null access RST; Item : Thin_Pointer); @@ -140,17 +139,15 @@ package System.Stream_Attributes is procedure W_LI (Stream : not null access RST; Item : Long_Integer); procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float); procedure W_LLI (Stream : not null access RST; Item : Long_Long_Integer); - procedure W_LLU (Stream : not null access RST; - Item : UST.Long_Long_Unsigned); + procedure W_LLU (Stream : not null access RST; Item : + UST.Long_Long_Unsigned); procedure W_LU (Stream : not null access RST; Item : UST.Long_Unsigned); procedure W_SF (Stream : not null access RST; Item : Short_Float); procedure W_SI (Stream : not null access RST; Item : Short_Integer); - procedure W_SSI (Stream : not null access RST; - Item : Short_Short_Integer); - procedure W_SSU (Stream : not null access RST; - Item : UST.Short_Short_Unsigned); - procedure W_SU (Stream : not null access RST; - Item : UST.Short_Unsigned); + procedure W_SSI (Stream : not null access RST; Item : Short_Short_Integer); + procedure W_SSU (Stream : not null access RST; Item : + UST.Short_Short_Unsigned); + procedure W_SU (Stream : not null access RST; Item : UST.Short_Unsigned); procedure W_U (Stream : not null access RST; Item : UST.Unsigned); procedure W_WC (Stream : not null access RST; Item : Wide_Character); procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character); @@ -160,7 +157,7 @@ package System.Stream_Attributes is -- distributed with GNAT, and s-stratt-xdr.adb, which is based on the XDR -- standard. Both bodies share the same spec. The role of this function is -- to indicate whether the current version of System.Stream_Attributes - -- supports block IO. + -- supports block IO. See System.Strings.Stream_Ops (s-ststop) for details. private pragma Inline (I_AD); diff --git a/gcc/ada/s-ststop.adb b/gcc/ada/s-ststop.adb index d9f8d0f8ed9..f57ff09fa6a 100644 --- a/gcc/ada/s-ststop.adb +++ b/gcc/ada/s-ststop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2013, 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,9 @@ with Ada.Streams; use Ada.Streams; with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; with Ada.Unchecked_Conversion; -with System.Stream_Attributes; use System; +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; +with System.Stream_Attributes; package body System.Strings.Stream_Ops is @@ -46,31 +48,32 @@ package body System.Strings.Stream_Ops is -- The following package provides an IO framework for strings. Depending -- on the version of System.Stream_Attributes as well as the size of - -- formal parameter Character_Type, the package will either utilize block - -- IO or character-by-character IO. + -- formal parameter Element_Type, the package will either utilize block + -- IO or element-by-element IO. generic - type Character_Type is private; - type String_Type is array (Positive range <>) of Character_Type; + type Element_Type is private; + type Index_Type is range <>; + type Array_Type is array (Index_Type range <>) of Element_Type; package Stream_Ops_Internal is function Input (Strm : access Root_Stream_Type'Class; - IO : IO_Kind) return String_Type; + IO : IO_Kind) return Array_Type; procedure Output (Strm : access Root_Stream_Type'Class; - Item : String_Type; + Item : Array_Type; IO : IO_Kind); procedure Read (Strm : access Root_Stream_Type'Class; - Item : out String_Type; + Item : out Array_Type; IO : IO_Kind); procedure Write (Strm : access Root_Stream_Type'Class; - Item : String_Type; + Item : Array_Type; IO : IO_Kind); end Stream_Ops_Internal; @@ -86,31 +89,36 @@ package body System.Strings.Stream_Ops is Default_Block_Size : constant := 512 * 8; - -- Shorthand notation for stream element and character sizes + -- Shorthand notation for stream element and element type sizes - C_Size : constant Integer := Character_Type'Size; + ET_Size : constant Integer := Element_Type'Size; SE_Size : constant Integer := Stream_Element'Size; - -- The following constants describe the number of stream elements or - -- characters that can fit into a default block. + -- The following constants describe the number of array elements or + -- stream elements that can fit into a default block. + + AE_In_Default_Block : constant Index_Type := + Index_Type (Default_Block_Size / ET_Size); + -- Number of array elements in a default block - C_In_Default_Block : constant Integer := Default_Block_Size / C_Size; SE_In_Default_Block : constant Integer := Default_Block_Size / SE_Size; + -- Number of storage elements in a default block -- Buffer types subtype Default_Block is Stream_Element_Array (1 .. Stream_Element_Offset (SE_In_Default_Block)); - subtype String_Block is String_Type (1 .. C_In_Default_Block); + subtype Array_Block is + Array_Type (Index_Type range 1 .. AE_In_Default_Block); -- Conversions to and from Default_Block function To_Default_Block is - new Ada.Unchecked_Conversion (String_Block, Default_Block); + new Ada.Unchecked_Conversion (Array_Block, Default_Block); - function To_String_Block is - new Ada.Unchecked_Conversion (Default_Block, String_Block); + function To_Array_Block is + new Ada.Unchecked_Conversion (Default_Block, Array_Block); ----------- -- Input -- @@ -118,7 +126,7 @@ package body System.Strings.Stream_Ops is function Input (Strm : access Root_Stream_Type'Class; - IO : IO_Kind) return String_Type + IO : IO_Kind) return Array_Type is begin if Strm = null then @@ -126,23 +134,21 @@ package body System.Strings.Stream_Ops is end if; declare - Low : Positive; - High : Positive; + Low : Index_Type; + High : Index_Type; begin -- Read the bounds of the string - Positive'Read (Strm, Low); - Positive'Read (Strm, High); + Index_Type'Read (Strm, Low); + Index_Type'Read (Strm, High); - declare - Item : String_Type (Low .. High); + -- Read the character content of the string + declare + Item : Array_Type (Low .. High); begin - -- Read the character content of the string - Read (Strm, Item, IO); - return Item; end; end; @@ -154,7 +160,7 @@ package body System.Strings.Stream_Ops is procedure Output (Strm : access Root_Stream_Type'Class; - Item : String_Type; + Item : Array_Type; IO : IO_Kind) is begin @@ -164,8 +170,8 @@ package body System.Strings.Stream_Ops is -- Write the bounds of the string - Positive'Write (Strm, Item'First); - Positive'Write (Strm, Item'Last); + Index_Type'Write (Strm, Item'First); + Index_Type'Write (Strm, Item'Last); -- Write the character content of the string @@ -178,7 +184,7 @@ package body System.Strings.Stream_Ops is procedure Read (Strm : access Root_Stream_Type'Class; - Item : out String_Type; + Item : out Array_Type; IO : IO_Kind) is begin @@ -194,15 +200,13 @@ package body System.Strings.Stream_Ops is -- Block IO - if IO = Block_IO - and then Stream_Attributes.Block_IO_OK - then + if IO = Block_IO and then Stream_Attributes.Block_IO_OK then declare -- Determine the size in BITS of the block necessary to contain -- the whole string. Block_Size : constant Natural := - (Item'Last - Item'First + 1) * C_Size; + Integer (Item'Last - Item'First + 1) * ET_Size; -- Item can be larger than what the default block can store, -- determine the number of whole reads necessary to read the @@ -218,8 +222,8 @@ package body System.Strings.Stream_Ops is -- String indexes - Low : Positive := Item'First; - High : Positive := Low + C_In_Default_Block - 1; + Low : Index_Type := Item'First; + High : Index_Type := Low + AE_In_Default_Block - 1; -- End of stream error detection @@ -237,10 +241,10 @@ package body System.Strings.Stream_Ops is begin for Counter in 1 .. Blocks loop Read (Strm.all, Block, Last); - Item (Low .. High) := To_String_Block (Block); + Item (Low .. High) := To_Array_Block (Block); Low := High + 1; - High := Low + C_In_Default_Block - 1; + High := Low + AE_In_Default_Block - 1; Sum := Sum + Last; Last := 0; end loop; @@ -254,17 +258,18 @@ package body System.Strings.Stream_Ops is subtype Rem_Block is Stream_Element_Array (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); - subtype Rem_String_Block is - String_Type (1 .. Rem_Size / C_Size); + subtype Rem_Array_Block is + Array_Type (Index_Type range + 1 .. Index_Type (Rem_Size / ET_Size)); - function To_Rem_String_Block is new - Ada.Unchecked_Conversion (Rem_Block, Rem_String_Block); + function To_Rem_Array_Block is new + Ada.Unchecked_Conversion (Rem_Block, Rem_Array_Block); Block : Rem_Block; begin Read (Strm.all, Block, Last); - Item (Low .. Item'Last) := To_Rem_String_Block (Block); + Item (Low .. Item'Last) := To_Rem_Array_Block (Block); Sum := Sum + Last; end; @@ -275,7 +280,7 @@ package body System.Strings.Stream_Ops is -- words, the stream does not contain enough elements to fully -- populate Item. - if (Integer (Sum) * SE_Size) / C_Size < Item'Length then + if (Integer (Sum) * SE_Size) / ET_Size < Item'Length then raise End_Error; end if; end; @@ -284,12 +289,11 @@ package body System.Strings.Stream_Ops is else declare - C : Character_Type; - + E : Element_Type; begin for Index in Item'First .. Item'Last loop - Character_Type'Read (Strm, C); - Item (Index) := C; + Element_Type'Read (Strm, E); + Item (Index) := E; end loop; end; end if; @@ -301,7 +305,7 @@ package body System.Strings.Stream_Ops is procedure Write (Strm : access Root_Stream_Type'Class; - Item : String_Type; + Item : Array_Type; IO : IO_Kind) is begin @@ -317,14 +321,12 @@ package body System.Strings.Stream_Ops is -- Block IO - if IO = Block_IO - and then Stream_Attributes.Block_IO_OK - then + if IO = Block_IO and then Stream_Attributes.Block_IO_OK then declare -- Determine the size in BITS of the block necessary to contain -- the whole string. - Block_Size : constant Natural := Item'Length * C_Size; + Block_Size : constant Natural := Item'Length * ET_Size; -- Item can be larger than what the default block can store, -- determine the number of whole writes necessary to output the @@ -340,8 +342,8 @@ package body System.Strings.Stream_Ops is -- String indexes - Low : Positive := Item'First; - High : Positive := Low + C_In_Default_Block - 1; + Low : Index_Type := Item'First; + High : Index_Type := Low + AE_In_Default_Block - 1; begin -- Step 1: If the string is too large, write out individual @@ -349,9 +351,8 @@ package body System.Strings.Stream_Ops is for Counter in 1 .. Blocks loop Write (Strm.all, To_Default_Block (Item (Low .. High))); - Low := High + 1; - High := Low + C_In_Default_Block - 1; + High := Low + AE_In_Default_Block - 1; end loop; -- Step 2: Write out any remaining elements @@ -361,11 +362,12 @@ package body System.Strings.Stream_Ops is subtype Rem_Block is Stream_Element_Array (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); - subtype Rem_String_Block is - String_Type (1 .. Rem_Size / C_Size); + subtype Rem_Array_Block is + Array_Type (Index_Type range + 1 .. Index_Type (Rem_Size / ET_Size)); function To_Rem_Block is new - Ada.Unchecked_Conversion (Rem_String_Block, Rem_Block); + Ada.Unchecked_Conversion (Rem_Array_Block, Rem_Block); begin Write (Strm.all, To_Rem_Block (Item (Low .. Item'Last))); @@ -377,28 +379,233 @@ package body System.Strings.Stream_Ops is else for Index in Item'First .. Item'Last loop - Character_Type'Write (Strm, Item (Index)); + Element_Type'Write (Strm, Item (Index)); end loop; end if; end Write; end Stream_Ops_Internal; - -- Specific instantiations for all Ada string types + -- Specific instantiations for all Ada array types handled + + package Storage_Array_Ops is + new Stream_Ops_Internal + (Element_Type => Storage_Element, + Index_Type => Storage_Offset, + Array_Type => Storage_Array); + + package Stream_Element_Array_Ops is + new Stream_Ops_Internal + (Element_Type => Stream_Element, + Index_Type => Stream_Element_Offset, + Array_Type => Stream_Element_Array); package String_Ops is new Stream_Ops_Internal - (Character_Type => Character, - String_Type => String); + (Element_Type => Character, + Index_Type => Positive, + Array_Type => String); package Wide_String_Ops is new Stream_Ops_Internal - (Character_Type => Wide_Character, - String_Type => Wide_String); + (Element_Type => Wide_Character, + Index_Type => Positive, + Array_Type => Wide_String); package Wide_Wide_String_Ops is new Stream_Ops_Internal - (Character_Type => Wide_Wide_Character, - String_Type => Wide_Wide_String); + (Element_Type => Wide_Wide_Character, + Index_Type => Positive, + Array_Type => Wide_Wide_String); + + ------------------------- + -- Storage_Array_Input -- + ------------------------- + + function Storage_Array_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Storage_Array + is + begin + return Storage_Array_Ops.Input (Strm, Byte_IO); + end Storage_Array_Input; + + -------------------------------- + -- Storage_Array_Input_Blk_IO -- + -------------------------------- + + function Storage_Array_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Storage_Array + is + begin + return Storage_Array_Ops.Input (Strm, Block_IO); + end Storage_Array_Input_Blk_IO; + + -------------------------- + -- Storage_Array_Output -- + -------------------------- + + procedure Storage_Array_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Storage_Array) + is + begin + Storage_Array_Ops.Output (Strm, Item, Byte_IO); + end Storage_Array_Output; + + --------------------------------- + -- Storage_Array_Output_Blk_IO -- + --------------------------------- + + procedure Storage_Array_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Storage_Array) + is + begin + Storage_Array_Ops.Output (Strm, Item, Block_IO); + end Storage_Array_Output_Blk_IO; + + ------------------------ + -- Storage_Array_Read -- + ------------------------ + + procedure Storage_Array_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Storage_Array) + is + begin + Storage_Array_Ops.Read (Strm, Item, Byte_IO); + end Storage_Array_Read; + + ------------------------------- + -- Storage_Array_Read_Blk_IO -- + ------------------------------- + + procedure Storage_Array_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Storage_Array) + is + begin + Storage_Array_Ops.Read (Strm, Item, Block_IO); + end Storage_Array_Read_Blk_IO; + + ------------------------- + -- Storage_Array_Write -- + ------------------------- + + procedure Storage_Array_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Storage_Array) + is + begin + Storage_Array_Ops.Write (Strm, Item, Byte_IO); + end Storage_Array_Write; + + -------------------------------- + -- Storage_Array_Write_Blk_IO -- + -------------------------------- + + procedure Storage_Array_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Storage_Array) + is + begin + Storage_Array_Ops.Write (Strm, Item, Block_IO); + end Storage_Array_Write_Blk_IO; + + -------------------------------- + -- Stream_Element_Array_Input -- + -------------------------------- + + function Stream_Element_Array_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Stream_Element_Array + is + begin + return Stream_Element_Array_Ops.Input (Strm, Byte_IO); + end Stream_Element_Array_Input; + + --------------------------------------- + -- Stream_Element_Array_Input_Blk_IO -- + --------------------------------------- + + function Stream_Element_Array_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Stream_Element_Array + is + begin + return Stream_Element_Array_Ops.Input (Strm, Block_IO); + end Stream_Element_Array_Input_Blk_IO; + + --------------------------------- + -- Stream_Element_Array_Output -- + --------------------------------- + + procedure Stream_Element_Array_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Output (Strm, Item, Byte_IO); + end Stream_Element_Array_Output; + + ---------------------------------------- + -- Stream_Element_Array_Output_Blk_IO -- + ---------------------------------------- + + procedure Stream_Element_Array_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Output (Strm, Item, Block_IO); + end Stream_Element_Array_Output_Blk_IO; + + ------------------------------- + -- Stream_Element_Array_Read -- + ------------------------------- + + procedure Stream_Element_Array_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Read (Strm, Item, Byte_IO); + end Stream_Element_Array_Read; + + -------------------------------------- + -- Stream_Element_Array_Read_Blk_IO -- + -------------------------------------- + + procedure Stream_Element_Array_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Read (Strm, Item, Block_IO); + end Stream_Element_Array_Read_Blk_IO; + + -------------------------------- + -- Stream_Element_Array_Write -- + -------------------------------- + + procedure Stream_Element_Array_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Write (Strm, Item, Byte_IO); + end Stream_Element_Array_Write; + + --------------------------------------- + -- Stream_Element_Array_Write_Blk_IO -- + --------------------------------------- + + procedure Stream_Element_Array_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Write (Strm, Item, Block_IO); + end Stream_Element_Array_Write_Blk_IO; ------------------ -- String_Input -- diff --git a/gcc/ada/s-ststop.ads b/gcc/ada/s-ststop.ads index db7059069b7..a3fb3c6e6b2 100644 --- a/gcc/ada/s-ststop.ads +++ b/gcc/ada/s-ststop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2013, 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,28 +30,119 @@ ------------------------------------------------------------------------------ -- This package provides subprogram implementations of stream attributes for --- the following types: +-- the following types using a "block IO" approach in which the entire data +-- item is written in one operation, instead of writing individual characters. + +-- Ada.Stream_Element_Array -- Ada.String -- Ada.Wide_String -- Ada.Wide_Wide_String --- +-- System.Storage_Array + +-- Note: this routine is in Ada.Strings because historically it handled only +-- the string types. It is not worth moving it at this stage. + -- The compiler will generate references to the subprograms in this package -- when expanding stream attributes for the above mentioned types. Example: --- + -- String'Output (Some_Stream, Some_String); --- + -- will be expanded into: --- + -- String_Output (Some_Stream, Some_String); -- or -- String_Output_Blk_IO (Some_Stream, Some_String); +-- String_Output form is used if pragma Restrictions (No_String_Optimziations) +-- is active, which requires element by element operations. The BLK_IO form +-- is used if this restriction is not set, allowing block optimization. + +-- Note that if System.Stream_Attributes.Block_IO_OK is False, then the BLK_IO +-- form is treated as equivalent to the normal case, so that the optimization +-- is inhibited anyway, regardless of the setting of the restriction. This +-- handles versions of System.Stream_Attributes (in particular the XDR version +-- found in s-stratt-xdr) which do not permit block io optimization. + pragma Compiler_Unit; with Ada.Streams; +with System.Storage_Elements; + package System.Strings.Stream_Ops is + ------------------------------------- + -- Storage_Array stream operations -- + ------------------------------------- + + function Storage_Array_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return System.Storage_Elements.Storage_Array; + + function Storage_Array_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return System.Storage_Elements.Storage_Array; + + procedure Storage_Array_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : System.Storage_Elements.Storage_Array); + + procedure Storage_Array_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : System.Storage_Elements.Storage_Array); + + procedure Storage_Array_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out System.Storage_Elements.Storage_Array); + + procedure Storage_Array_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out System.Storage_Elements.Storage_Array); + + procedure Storage_Array_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : System.Storage_Elements.Storage_Array); + + procedure Storage_Array_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : System.Storage_Elements.Storage_Array); + + -------------------------------------------- + -- Stream_Element_Array stream operations -- + -------------------------------------------- + + function Stream_Element_Array_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Ada.Streams.Stream_Element_Array; + + function Stream_Element_Array_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Ada.Streams.Stream_Element_Array; + + procedure Stream_Element_Array_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Ada.Streams.Stream_Element_Array); + + procedure Stream_Element_Array_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Ada.Streams.Stream_Element_Array); + + procedure Stream_Element_Array_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Ada.Streams.Stream_Element_Array); + + procedure Stream_Element_Array_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Ada.Streams.Stream_Element_Array); + + procedure Stream_Element_Array_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Ada.Streams.Stream_Element_Array); + + procedure Stream_Element_Array_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Ada.Streams.Stream_Element_Array); + ------------------------------ -- String stream operations -- ------------------------------ diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 667603b73b7..c7747abd27c 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-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -178,6 +178,18 @@ package body System.Task_Primitives.Operations is pragma Import (C, GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); + procedure Compute_Deadline + (Time : Duration; + Mode : ST.Delay_Modes; + Check_Time : out Duration; + Abs_Time : out Duration; + Rel_Time : out Duration); + -- Helper for Timed_Sleep and Timed_Delay: given a deadline specified by + -- Time and Mode, compute the current clock reading (Check_Time), and the + -- target absolute and relative clock readings (Abs_Time, Rel_Time). The + -- epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time + -- is always that of CLOCK_RT_Ada. + ------------------- -- Abort_Handler -- ------------------- @@ -236,6 +248,67 @@ package body System.Task_Primitives.Operations is end if; end Abort_Handler; + ---------------------- + -- Compute_Deadline -- + ---------------------- + + procedure Compute_Deadline + (Time : Duration; + Mode : ST.Delay_Modes; + Check_Time : out Duration; + Abs_Time : out Duration; + Rel_Time : out Duration) + is + begin + Check_Time := Monotonic_Clock; + + -- Relative deadline + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + pragma Warnings (Off); + -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile + -- time known. + + -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada) + + elsif Mode = Absolute_RT + or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME + then + pragma Warnings (On); + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + + -- Absolute deadline specified using the real-time clock, in the + -- case where it is not the same as the tasking clock: compensate for + -- difference between clock epochs (Base_Time - Base_Cal_Time). + + else + declare + Cal_Check_Time : constant Duration := + OS_Primitives.Monotonic_Clock; + RT_Time : constant Duration := + Time + Check_Time - Cal_Check_Time; + begin + Abs_Time := + Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time); + + if Relative_Timed_Wait then + Rel_Time := + Duration'Min (Max_Sensible_Delay, RT_Time - Check_Time); + end if; + end; + end if; + end Compute_Deadline; + ----------------- -- Stack_Guard -- ----------------- @@ -528,10 +601,11 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Reason); - Base_Time : constant Duration := Monotonic_Clock; - Check_Time : Duration := Base_Time; - Rel_Time : Duration; + Base_Time : Duration; + Check_Time : Duration; Abs_Time : Duration; + Rel_Time : Duration; + Request : aliased timespec; Result : Interfaces.C.int; @@ -539,20 +613,13 @@ package body System.Task_Primitives.Operations is Timedout := True; Yielded := False; - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time); - end if; - - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); - end if; - end if; + Compute_Deadline + (Time => Time, + Mode => Mode, + Check_Time => Check_Time, + Abs_Time => Abs_Time, + Rel_Time => Rel_Time); + Base_Time := Check_Time; if Abs_Time > Check_Time then Request := @@ -597,8 +664,8 @@ package body System.Task_Primitives.Operations is Time : Duration; Mode : ST.Delay_Modes) is - Base_Time : constant Duration := Monotonic_Clock; - Check_Time : Duration := Base_Time; + Base_Time : Duration; + Check_Time : Duration; Abs_Time : Duration; Rel_Time : Duration; Request : aliased timespec; @@ -613,20 +680,13 @@ package body System.Task_Primitives.Operations is Write_Lock (Self_ID); - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time); - end if; - - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); - end if; - end if; + Compute_Deadline + (Time => Time, + Mode => Mode, + Check_Time => Check_Time, + Abs_Time => Abs_Time, + Rel_Time => Rel_Time); + Base_Time := Check_Time; if Abs_Time > Check_Time then Request := diff --git a/gcc/ada/s-valuti.adb b/gcc/ada/s-valuti.adb index e25f78c4501..ce6db6fecb4 100644 --- a/gcc/ada/s-valuti.adb +++ b/gcc/ada/s-valuti.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -134,9 +134,9 @@ package body System.Val_Util is -- Scan out the exponent value as an unsigned integer. Values larger -- than (Integer'Last / 10) are simply considered large enough here. - -- This assumption is correct for all machines we know of (e.g. in - -- the case of 16 bit integers it allows exponents up to 3276, which - -- is large enough for the largest floating types in base 2.) + -- This assumption is correct for all machines we know of (e.g. in the + -- case of 16 bit integers it allows exponents up to 3276, which is + -- large enough for the largest floating types in base 2.) X := 0; @@ -222,8 +222,8 @@ package body System.Val_Util is P : Natural := Ptr.all; begin - -- Deal with case of null string (all blanks!). As per spec, we - -- raise constraint error, with Ptr unchanged, and thus > Max. + -- Deal with case of null string (all blanks!). As per spec, we raise + -- constraint error, with Ptr unchanged, and thus > Max. if P > Max then Bad_Value (Str); @@ -300,16 +300,16 @@ package body System.Val_Util is begin P := P + 1; - -- If underscore is at the end of string, then this is an error and - -- we raise Constraint_Error, leaving the pointer past the underscore. - -- This seems a bit strange. It means e.g. that if the field is: + -- If underscore is at the end of string, then this is an error and we + -- raise Constraint_Error, leaving the pointer past the underscore. This + -- seems a bit strange. It means e.g. that if the field is: -- 345_ - -- that Constraint_Error is raised. You might think that the RM in - -- this case would scan out the 345 as a valid integer, leaving the - -- pointer at the underscore, but the ACVC suite clearly requires - -- an error in this situation (see for example CE3704M). + -- that Constraint_Error is raised. You might think that the RM in this + -- case would scan out the 345 as a valid integer, leaving the pointer + -- at the underscore, but the ACVC suite clearly requires an error in + -- this situation (see for example CE3704M). if P > Max then Ptr.all := P; diff --git a/gcc/ada/s-vmexta.adb b/gcc/ada/s-vmexta.adb index b19e27436ea..1164ff8994f 100644 --- a/gcc/ada/s-vmexta.adb +++ b/gcc/ada/s-vmexta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2013, 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,11 +33,10 @@ with System.HTable; pragma Elaborate_All (System.HTable); +with System.Storage_Elements; use System.Storage_Elements; package body System.VMS_Exception_Table is - use type SSL.Exception_Code; - type HTable_Headers is range 1 .. 37; type Exception_Code_Data; @@ -47,7 +46,7 @@ package body System.VMS_Exception_Table is -- Ada exception. type Exception_Code_Data is record - Code : SSL.Exception_Code; + Code : Exception_Code; Except : SSL.Exception_Data_Ptr; HTable_Ptr : Exception_Code_Data_Ptr; end record; @@ -59,8 +58,8 @@ package body System.VMS_Exception_Table is function Get_HT_Link (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr; - function Hash (F : SSL.Exception_Code) return HTable_Headers; - function Get_Key (T : Exception_Code_Data_Ptr) return SSL.Exception_Code; + function Hash (F : Exception_Code) return HTable_Headers; + function Get_Key (T : Exception_Code_Data_Ptr) return Exception_Code; package Exception_Code_HTable is new System.HTable.Static_HTable ( Header_Num => HTable_Headers, @@ -69,7 +68,7 @@ package body System.VMS_Exception_Table is Null_Ptr => null, Set_Next => Set_HT_Link, Next => Get_HT_Link, - Key => SSL.Exception_Code, + Key => Exception_Code, Get_Key => Get_Key, Hash => Hash, Equal => "="); @@ -79,10 +78,10 @@ package body System.VMS_Exception_Table is ------------------ function Base_Code_In - (Code : SSL.Exception_Code) return SSL.Exception_Code + (Code : Exception_Code) return Exception_Code is begin - return Code and not 2#0111#; + return To_Address (To_Integer (Code) and not 2#0111#); end Base_Code_In; --------------------- @@ -90,7 +89,7 @@ package body System.VMS_Exception_Table is --------------------- function Coded_Exception - (X : SSL.Exception_Code) return SSL.Exception_Data_Ptr + (X : Exception_Code) return SSL.Exception_Data_Ptr is Res : Exception_Code_Data_Ptr; @@ -121,7 +120,7 @@ package body System.VMS_Exception_Table is ------------- function Get_Key (T : Exception_Code_Data_Ptr) - return SSL.Exception_Code + return Exception_Code is begin return T.Code; @@ -132,13 +131,14 @@ package body System.VMS_Exception_Table is ---------- function Hash - (F : SSL.Exception_Code) return HTable_Headers + (F : Exception_Code) return HTable_Headers is - Headers_Magnitude : constant SSL.Exception_Code := - SSL.Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1); + Headers_Magnitude : constant Exception_Code := + Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1); begin - return HTable_Headers (F mod Headers_Magnitude + 1); + return HTable_Headers + (To_Address ((To_Integer (F) mod To_Integer (Headers_Magnitude)) + 1)); end Hash; ---------------------------- @@ -146,13 +146,13 @@ package body System.VMS_Exception_Table is ---------------------------- procedure Register_VMS_Exception - (Code : SSL.Exception_Code; + (Code : Exception_Code; E : SSL.Exception_Data_Ptr) is -- We bind the exception data with the base code found in the -- input value, that is with the severity bits masked off. - Excode : constant SSL.Exception_Code := Base_Code_In (Code); + Excode : constant Exception_Code := Base_Code_In (Code); begin -- The exception data registered here is mostly filled prior to this @@ -165,7 +165,7 @@ package body System.VMS_Exception_Table is -- routine attempts to match the import codes in this case. E.Lang := 'V'; - E.Import_Code := Excode; + E.Foreign_Data := Excode; if Exception_Code_HTable.Get (Excode) = null then Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null)); diff --git a/gcc/ada/s-vmexta.ads b/gcc/ada/s-vmexta.ads index e19929e1df9..5ad3f3cd373 100644 --- a/gcc/ada/s-vmexta.ads +++ b/gcc/ada/s-vmexta.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2013, 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,7 +29,7 @@ -- -- ------------------------------------------------------------------------------ --- This package is usually used only on Alpha/VMS systems in the case +-- This package is usually used only on OpenVMS systems in the case -- where there is at least one Import/Export exception present. with System.Standard_Library; @@ -38,22 +38,30 @@ package System.VMS_Exception_Table is package SSL renames System.Standard_Library; + subtype Exception_Code is System.Address; + procedure Register_VMS_Exception - (Code : SSL.Exception_Code; + (Code : Exception_Code; E : SSL.Exception_Data_Ptr); - -- Register an exception in the hash table mapping with a VMS - -- condition code. + -- Register an exception in hash table mapping with a VMS condition code. + -- + -- The table is used by exception code (the personnality routine) to detect + -- wether a VMS exception (aka condition) is known by the Ada code. In + -- that case, the identity of the imported or exported exception is used + -- to create the occurrence. -- LOTS more comments needed here regarding the entire scheme ??? private - function Base_Code_In (Code : SSL.Exception_Code) return SSL.Exception_Code; + -- The following functions are directly called (without import/export) in + -- init.c by __gnat_handle_vms_condition. + + function Base_Code_In (Code : Exception_Code) return Exception_Code; -- Value of Code with the severity bits masked off - function Coded_Exception (X : SSL.Exception_Code) + function Coded_Exception (X : Exception_Code) return SSL.Exception_Data_Ptr; - -- Given a VMS condition, find and return it's allocated Ada exception - -- (called only from init.c). + -- Given a VMS condition, find and return its allocated Ada exception end System.VMS_Exception_Table; diff --git a/gcc/ada/s-vxwork-arm.ads b/gcc/ada/s-vxwork-arm.ads index 1aa6670e164..8c4cf7e53e2 100644 --- a/gcc/ada/s-vxwork-arm.ads +++ b/gcc/ada/s-vxwork-arm.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2013, 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- -- @@ -31,15 +31,30 @@ -- This is the ARM VxWorks version of this package +with Interfaces.C; + package System.VxWorks is pragma Preelaborate (System.VxWorks); + package IC renames Interfaces.C; + -- Floating point context record. ARM version + FP_SGPR_NUM_REGS : constant := 32; + type Fpr_Sgpr_Array is array (1 .. FP_SGPR_NUM_REGS) of IC.unsigned; + -- The record definition below matches what arch/arm/fppArmLib.h says type FP_CONTEXT is record - Dummy : Integer; + fpsid : IC.unsigned; -- system ID register + fpscr : IC.unsigned; -- status and control register + fpexc : IC.unsigned; -- exception register + fpinst : IC.unsigned; -- instruction register + fpinst2 : IC.unsigned; -- instruction register 2 + mfvfr0 : IC.unsigned; -- media and VFP feature Register 0 + mfvfr1 : IC.unsigned; -- media and VFP feature Register 1 + pad : IC.unsigned; + vfp_gpr : Fpr_Sgpr_Array; end record; for FP_CONTEXT'Alignment use 4; diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index e05d1d692ad..ef3d665554a 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -592,14 +592,12 @@ package body Scng is -- which the digit was expected on input, and is unchanged on return. procedure Scan_Integer; - -- Procedure to scan integer literal. On entry, Scan_Ptr points to a - -- digit, on exit Scan_Ptr points past the last character of the - -- integer. + -- Scan integer literal. On entry, Scan_Ptr points to a digit, on + -- exit Scan_Ptr points past the last character of the integer. -- -- For each digit encountered, UI_Int_Value is multiplied by 10, and - -- the value of the digit added to the result. In addition, the - -- value in Scale is decremented by one for each actual digit - -- scanned. + -- the value of the digit added to the result. In addition, the value + -- in Scale is decremented by one for each actual digit scanned. -------------------------- -- Error_Digit_Expected -- diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index dc4248e12d9..6efc5cebcc9 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2013, 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- -- @@ -367,11 +367,12 @@ package SCOs is Last : Boolean := False; Pragma_Sloc : Source_Ptr := No_Location; - -- For the statement SCO for a pragma, or for any expression SCO nested - -- in a pragma Debug/Assert/PPC, location of PRAGMA token (used for - -- control of SCO output, value not recorded in ALI file). For the - -- decision SCO for an aspect, or for any expression SCO nested in an - -- aspect, location of aspect identifier token (likewise). + -- For the decision SCO of a pragma, or for the decision SCO of any + -- expression nested in a pragma Debug/Assert/PPC, location of PRAGMA + -- token (used for control of SCO output, value not recorded in ALI + -- file). Similarly, for the decision SCO of an aspect, or for the + -- decision SCO of any expression nested in an aspect, location of + -- aspect identifier token. Pragma_Aspect_Name : Name_Id := No_Name; -- For the SCO for a pragma/aspect, gives the pragma/apsect name diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 4249ad95595..6094b14f438 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -242,6 +242,9 @@ package body Sem is when N_Freeze_Entity => Analyze_Freeze_Entity (N); + when N_Freeze_Generic_Entity => + Analyze_Freeze_Generic_Entity (N); + when N_Full_Type_Declaration => Analyze_Full_Type_Declaration (N); diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 9d7d7b7e4b1..5aec38a32d0 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -65,23 +65,35 @@ with Uintp; use Uintp; package body Sem_Aggr is type Case_Bounds is record - Choice_Lo : Node_Id; - Choice_Hi : Node_Id; - Choice_Node : Node_Id; + Lo : Node_Id; + -- Low bound of choice. Once we sort the Case_Table, then entries + -- will be in order of ascending Choice_Lo values. + + Hi : Node_Id; + -- High Bound of choice. The sort does not pay any attention to the + -- high bound, so choices 1 .. 4 and 1 .. 5 could be in either order. + + Highest : Uint; + -- If there are duplicates or missing entries, then in the sorted + -- table, this records the highest value among Choice_Hi values + -- seen so far, including this entry. + + Choice : Node_Id; + -- The node of the choice end record; type Case_Table_Type is array (Nat range <>) of Case_Bounds; - -- Table type used by Check_Case_Choices procedure + -- Table type used by Check_Case_Choices procedure. Entry zero is not + -- used (reserved for the sort). Real entries start at one. ----------------------- -- Local Subprograms -- ----------------------- procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); - -- Sort the Case Table using the Lower Bound of each Choice as the key. - -- A simple insertion sort is used since the number of choices in a case - -- statement of variant part will usually be small and probably in near - -- sorted order. + -- Sort the Case Table using the Lower Bound of each Choice as the key. A + -- simple insertion sort is used since the choices in a case statement will + -- usually be in near sorted order. procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id); -- Ada 2005 (AI-231): Check bad usage of null for a component for which @@ -1723,9 +1735,9 @@ package body Sem_Aggr is -- Variables local to Resolve_Array_Aggregate - Assoc : Node_Id; - Choice : Node_Id; - Expr : Node_Id; + Assoc : Node_Id; + Choice : Node_Id; + Expr : Node_Id; Discard : Node_Id; pragma Warnings (Off, Discard); @@ -1900,21 +1912,14 @@ package body Sem_Aggr is High : Node_Id; -- Denote the lowest and highest values in an aggregate choice - Hi_Val : Uint; - Lo_Val : Uint; - -- High end of one range and Low end of the next. Should be - -- contiguous if there is no hole in the list of values. - - Missing_Values : Boolean; - -- Set True if missing index values - S_Low : Node_Id := Empty; S_High : Node_Id := Empty; -- if a choice in an aggregate is a subtype indication these -- denote the lowest and highest values of the subtype - Table : Case_Table_Type (1 .. Case_Table_Size); - -- Used to sort all the different choice values + Table : Case_Table_Type (0 .. Case_Table_Size); + -- Used to sort all the different choice values. Entry zero is + -- reserved for sorting purposes. Single_Choice : Boolean; -- Set to true every time there is a single discrete choice in a @@ -2026,9 +2031,9 @@ package body Sem_Aggr is end if; Nb_Discrete_Choices := Nb_Discrete_Choices + 1; - Table (Nb_Discrete_Choices).Choice_Lo := Low; - Table (Nb_Discrete_Choices).Choice_Hi := High; - Table (Nb_Discrete_Choices).Choice_Node := Choice; + Table (Nb_Discrete_Choices).Lo := Low; + Table (Nb_Discrete_Choices).Hi := High; + Table (Nb_Discrete_Choices).Choice := Choice; Next (Choice); @@ -2064,14 +2069,14 @@ package body Sem_Aggr is -- Resolve_Aggr_Expr to check the rules about -- dimensionality. - if not Resolve_Aggr_Expr (Assoc, - Single_Elmt => Single_Choice) + if not Resolve_Aggr_Expr + (Assoc, Single_Elmt => Single_Choice) then return Failure; end if; - elsif not Resolve_Aggr_Expr (Expression (Assoc), - Single_Elmt => Single_Choice) + elsif not Resolve_Aggr_Expr + (Expression (Assoc), Single_Elmt => Single_Choice) then return Failure; @@ -2134,87 +2139,207 @@ package body Sem_Aggr is end loop; -- If aggregate contains more than one choice then these must be - -- static. Sort them and check that they are contiguous. + -- static. Check for duplicate and missing values. + + -- Note: there is duplicated code here wrt Check_Choice_Set in + -- the body of Sem_Case, and it is possible we could just reuse + -- that procedure. To be checked ??? if Nb_Discrete_Choices > 1 then - Sort_Case_Table (Table); - Missing_Values := False; + Check_Choices : declare + Choice : Node_Id; + -- Location of choice for messages - Outer : for J in 1 .. Nb_Discrete_Choices - 1 loop - if Expr_Value (Table (J).Choice_Hi) >= - Expr_Value (Table (J + 1).Choice_Lo) - then - Error_Msg_N - ("duplicate choice values in array aggregate", - Table (J).Choice_Node); - return Failure; + Hi_Val : Uint; + Lo_Val : Uint; + -- High end of one range and Low end of the next. Should be + -- contiguous if there is no hole in the list of values. - elsif not Others_Present then - Hi_Val := Expr_Value (Table (J).Choice_Hi); - Lo_Val := Expr_Value (Table (J + 1).Choice_Lo); + Lo_Dup : Uint; + Hi_Dup : Uint; + -- End points of duplicated range - -- If missing values, output error messages + Missing_Or_Duplicates : Boolean := False; + -- Set True if missing or duplicate choices found - if Lo_Val - Hi_Val > 1 then + procedure Output_Bad_Choices (Lo, Hi : Uint; C : Node_Id); + -- Output continuation message with a representation of the + -- bounds (just Lo if Lo = Hi, else Lo .. Hi). C is the + -- choice node where the message is to be posted. - -- Header message if not first missing value + ------------------------ + -- Output_Bad_Choices -- + ------------------------ - if not Missing_Values then - Error_Msg_N - ("missing index value(s) in array aggregate", N); - Missing_Values := True; + procedure Output_Bad_Choices (Lo, Hi : Uint; C : Node_Id) is + begin + -- Enumeration type case + + if Is_Enumeration_Type (Index_Typ) then + Error_Msg_Name_1 := + Chars (Get_Enum_Lit_From_Pos (Index_Typ, Lo, Loc)); + Error_Msg_Name_2 := + Chars (Get_Enum_Lit_From_Pos (Index_Typ, Hi, Loc)); + + if Lo = Hi then + Error_Msg_N ("\\ %!", C); + else + Error_Msg_N ("\\ % .. %!", C); end if; - -- Output values of missing indexes + -- Integer types case - Lo_Val := Lo_Val - 1; - Hi_Val := Hi_Val + 1; + else + Error_Msg_Uint_1 := Lo; + Error_Msg_Uint_2 := Hi; - -- Enumeration type case + if Lo = Hi then + Error_Msg_N ("\\ ^!", C); + else + Error_Msg_N ("\\ ^ .. ^!", C); + end if; + end if; + end Output_Bad_Choices; - if Is_Enumeration_Type (Index_Typ) then - Error_Msg_Name_1 := - Chars - (Get_Enum_Lit_From_Pos - (Index_Typ, Hi_Val, Loc)); + -- Start of processing for Check_Choices - if Lo_Val = Hi_Val then - Error_Msg_N ("\ %", N); - else - Error_Msg_Name_2 := - Chars - (Get_Enum_Lit_From_Pos - (Index_Typ, Lo_Val, Loc)); - Error_Msg_N ("\ % .. %", N); - end if; + begin + Sort_Case_Table (Table); - -- Integer types case + -- First we do a quick linear loop to find out if we have + -- any duplicates or missing entries (usually we have a + -- legal aggregate, so this will get us out quickly). - else - Error_Msg_Uint_1 := Hi_Val; + for J in 1 .. Nb_Discrete_Choices - 1 loop + Hi_Val := Expr_Value (Table (J).Hi); + Lo_Val := Expr_Value (Table (J + 1).Lo); - if Lo_Val = Hi_Val then - Error_Msg_N ("\ ^", N); - else - Error_Msg_Uint_2 := Lo_Val; - Error_Msg_N ("\ ^ .. ^", N); - end if; + if Lo_Val <= Hi_Val + or else (Lo_Val > Hi_Val + 1 + and then not Others_Present) + then + Missing_Or_Duplicates := True; + exit; + end if; + end loop; + + -- If we have missing or duplicate entries, first fill in + -- the Highest entries to make life easier in the following + -- loops to detect bad entries. + + if Missing_Or_Duplicates then + Table (1).Highest := Expr_Value (Table (1).Hi); + + for J in 2 .. Nb_Discrete_Choices loop + Table (J).Highest := + UI_Max + (Table (J - 1).Highest, Expr_Value (Table (J).Hi)); + end loop; + + -- Loop through table entries to find duplicate indexes + + for J in 2 .. Nb_Discrete_Choices loop + Lo_Val := Expr_Value (Table (J).Lo); + Hi_Val := Expr_Value (Table (J).Hi); + + -- Case where we have duplicates (the lower bound of + -- this choice is less than or equal to the highest + -- high bound found so far). + + if Lo_Val <= Table (J - 1).Highest then + + -- We move backwards looking for duplicates. We can + -- abandon this loop as soon as we reach a choice + -- highest value that is less than Lo_Val. + + for K in reverse 1 .. J - 1 loop + exit when Table (K).Highest < Lo_Val; + + -- Here we may have duplicates between entries + -- for K and J. Get range of duplicates. + + Lo_Dup := + UI_Max (Lo_Val, Expr_Value (Table (K).Lo)); + Hi_Dup := + UI_Min (Hi_Val, Expr_Value (Table (K).Hi)); + + -- Nothing to do if duplicate range is null + + if Lo_Dup > Hi_Dup then + null; + + -- Otherwise place proper message + + else + -- We place message on later choice, with a + -- line reference to the earlier choice. + + if Sloc (Table (J).Choice) < + Sloc (Table (K).Choice) + then + Choice := Table (K).Choice; + Error_Msg_Sloc := Sloc (Table (J).Choice); + else + Choice := Table (J).Choice; + Error_Msg_Sloc := Sloc (Table (K).Choice); + end if; + + if Lo_Dup = Hi_Dup then + Error_Msg_N + ("index value in array aggregate " + & "duplicates the one given#!", Choice); + else + Error_Msg_N + ("index values in array aggregate " + & "duplicate those given#!", Choice); + end if; + + Output_Bad_Choices (Lo_Dup, Hi_Dup, Choice); + end if; + end loop; end if; + end loop; + + -- Loop through entries in table to find missing indexes. + -- Not needed if others, since missing impossible. + + if not Others_Present then + for J in 2 .. Nb_Discrete_Choices loop + Lo_Val := Expr_Value (Table (J).Lo); + Hi_Val := Table (J - 1).Highest; + + if Lo_Val > Hi_Val + 1 then + Choice := Table (J).Lo; + + if Hi_Val + 1 = Lo_Val - 1 then + Error_Msg_N + ("missing index value in array aggregate!", + Choice); + else + Error_Msg_N + ("missing index values in array aggregate!", + Choice); + end if; + + Output_Bad_Choices + (Hi_Val + 1, Lo_Val - 1, Choice); + end if; + end loop; end if; - end if; - end loop Outer; - if Missing_Values then - Set_Etype (N, Any_Composite); - return Failure; - end if; + -- If either missing or duplicate values, return failure + + Set_Etype (N, Any_Composite); + return Failure; + end if; + end Check_Choices; end if; -- STEP 2 (B): Compute aggregate bounds and min/max choices values if Nb_Discrete_Choices > 0 then - Choices_Low := Table (1).Choice_Lo; - Choices_High := Table (Nb_Discrete_Choices).Choice_Hi; + Choices_Low := Table (1).Lo; + Choices_High := Table (Nb_Discrete_Choices).Hi; end if; -- If Others is present, then bounds of aggregate come from the @@ -2525,8 +2650,9 @@ package body Sem_Aggr is Check_Unset_Reference (Aggregate_Bounds (N)); if not Others_Present and then Nb_Discrete_Choices = 0 then - Set_High_Bound (Aggregate_Bounds (N), - Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N)))); + Set_High_Bound + (Aggregate_Bounds (N), + Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N)))); end if; -- Check the dimensions of each component in the array aggregate @@ -3416,6 +3542,7 @@ package body Sem_Aggr is begin -- A record aggregate is restricted in SPARK: + -- Each named association can have only a single choice. -- OTHERS cannot be used. -- Positional and named associations cannot be mixed. @@ -3758,6 +3885,8 @@ package body Sem_Aggr is end loop; end Find_Private_Ancestor; + -- Start of processing for Step_5 + begin if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then Parent_Typ_List := New_Elmt_List; @@ -3822,11 +3951,12 @@ package body Sem_Aggr is if Nkind (Dnode) = N_Full_Type_Declaration then Record_Def := Type_Definition (Dnode); - Gather_Components (Base_Type (Typ), - Component_List (Record_Def), - Governed_By => New_Assoc_List, - Into => Components, - Report_Errors => Errors_Found); + Gather_Components + (Base_Type (Typ), + Component_List (Record_Def), + Governed_By => New_Assoc_List, + Into => Components, + Report_Errors => Errors_Found); end if; end if; @@ -3915,19 +4045,20 @@ package body Sem_Aggr is null; elsif not Has_Unknown_Discriminants (Typ) then - Gather_Components (Base_Type (Typ), - Component_List (Record_Def), - Governed_By => New_Assoc_List, - Into => Components, - Report_Errors => Errors_Found); + Gather_Components + (Base_Type (Typ), + Component_List (Record_Def), + Governed_By => New_Assoc_List, + Into => Components, + Report_Errors => Errors_Found); else Gather_Components (Base_Type (Underlying_Record_View (Typ)), - Component_List (Record_Def), - Governed_By => New_Assoc_List, - Into => Components, - Report_Errors => Errors_Found); + Component_List (Record_Def), + Governed_By => New_Assoc_List, + Into => Components, + Report_Errors => Errors_Found); end if; end if; @@ -4590,21 +4721,19 @@ package body Sem_Aggr is --------------------- procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is - L : constant Int := Case_Table'First; U : constant Int := Case_Table'Last; K : Int; J : Int; T : Case_Bounds; begin - K := L; - while K /= U loop + K := 1; + while K < U loop T := Case_Table (K + 1); J := K + 1; - while J /= L - and then Expr_Value (Case_Table (J - 1).Choice_Lo) > - Expr_Value (T.Choice_Lo) + while J > 1 + and then Expr_Value (Case_Table (J - 1).Lo) > Expr_Value (T.Lo) loop Case_Table (J) := Case_Table (J - 1); J := J - 1; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index ae58c9d2504..231d0b2e296 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -189,6 +189,11 @@ package body Sem_Attr is -- where therefore the prefix of the attribute does not match the enclosing -- scope. + procedure Set_Boolean_Result (N : Node_Id; B : Boolean); + -- Rewrites node N with an occurrence of either Standard_False or + -- Standard_True, depending on the value of the parameter B. The + -- result is marked as a static expression. + ----------------------- -- Analyze_Attribute -- ----------------------- @@ -212,6 +217,12 @@ package body Sem_Attr is -- Local Subprograms -- ----------------------- + procedure Address_Checks; + -- Semantic checks for valid use of Address attribute. This was made + -- a separate routine with the idea of using it for unrestricted access + -- which seems like it should follow the same rules, but that turned + -- out to be impractical. So now this is only used for Address. + procedure Analyze_Access_Attribute; -- Used for Access, Unchecked_Access, Unrestricted_Access attributes. -- Internally, Id distinguishes which of the three cases is involved. @@ -303,10 +314,6 @@ package body Sem_Attr is -- Verify that prefix of attribute N is a float type and that -- two attribute expressions are present - procedure Legal_Formal_Attribute; - -- Common processing for attributes Definite and Has_Discriminants. - -- Checks that prefix is generic indefinite formal type. - procedure Check_SPARK_Restriction_On_Attribute; -- Issue an error in formal mode because attribute N is allowed @@ -337,13 +344,17 @@ package body Sem_Attr is -- Verify that prefix of attribute N is a scalar type procedure Check_Standard_Prefix; - -- Verify that prefix of attribute N is package Standard + -- Verify that prefix of attribute N is package Standard. Also checks + -- that there are no arguments. procedure Check_Stream_Attribute (Nam : TSS_Name_Type); -- Validity checking for stream attribute. Nam is the TSS name of the -- corresponding possible defined attribute function (e.g. for the -- Read attribute, Nam will be TSS_Stream_Read). + procedure Check_System_Prefix; + -- Verify that prefix of attribute N is package System + procedure Check_PolyORB_Attribute; -- Validity checking for PolyORB/DSA attribute @@ -377,6 +388,14 @@ package body Sem_Attr is pragma No_Return (Error_Attr); -- Like Error_Attr, but error is posted at the start of the prefix + function In_Refined_Post return Boolean; + -- Determine whether the current attribute appears in pragma + -- Refined_Post. + + procedure Legal_Formal_Attribute; + -- Common processing for attributes Definite and Has_Discriminants. + -- Checks that prefix is generic indefinite formal type. + procedure Standard_Attribute (Val : Int); -- Used to process attributes whose prefix is package Standard which -- yield values of type Universal_Integer. The attribute reference @@ -391,6 +410,151 @@ package body Sem_Attr is -- non-scalar arguments or returns a non-scalar result. Verifies that -- such a call does not appear in a preelaborable context. + -------------------- + -- Address_Checks -- + -------------------- + + procedure Address_Checks is + begin + -- An Address attribute created by expansion is legal even when it + -- applies to other entity-denoting expressions. + + if not Comes_From_Source (N) then + return; + + -- Address attribute on a protected object self reference is legal + + elsif Is_Protected_Self_Reference (P) then + return; + + -- Address applied to an entity + + elsif Is_Entity_Name (P) then + declare + Ent : constant Entity_Id := Entity (P); + + begin + if Is_Subprogram (Ent) then + Set_Address_Taken (Ent); + Kill_Current_Values (Ent); + + -- An Address attribute is accepted when generated by the + -- compiler for dispatching operation, and an error is + -- issued once the subprogram is frozen (to avoid confusing + -- errors about implicit uses of Address in the dispatch + -- table initialization). + + if Has_Pragma_Inline_Always (Entity (P)) + and then Comes_From_Source (P) + then + Error_Attr_P + ("prefix of % attribute cannot be Inline_Always " + & "subprogram"); + + -- It is illegal to apply 'Address to an intrinsic + -- subprogram. This is now formalized in AI05-0095. + -- In an instance, an attempt to obtain 'Address of an + -- intrinsic subprogram (e.g the renaming of a predefined + -- operator that is an actual) raises Program_Error. + + elsif Convention (Ent) = Convention_Intrinsic then + if In_Instance then + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Address_Of_Intrinsic)); + + else + Error_Msg_Name_1 := Aname; + Error_Msg_N + ("cannot take % of intrinsic subprogram", N); + end if; + + -- Issue an error if prefix denotes an eliminated subprogram + + else + Check_For_Eliminated_Subprogram (P, Ent); + end if; + + -- Object or label reference + + elsif Is_Object (Ent) or else Ekind (Ent) = E_Label then + Set_Address_Taken (Ent); + + -- Deal with No_Implicit_Aliasing restriction + + if Restriction_Check_Required (No_Implicit_Aliasing) then + if not Is_Aliased_View (P) then + Check_Restriction (No_Implicit_Aliasing, P); + else + Check_No_Implicit_Aliasing (P); + end if; + end if; + + -- If we have an address of an object, and the attribute + -- comes from source, then set the object as potentially + -- source modified. We do this because the resulting address + -- can potentially be used to modify the variable and we + -- might not detect this, leading to some junk warnings. + + Set_Never_Set_In_Source (Ent, False); + + -- Allow Address to be applied to task or protected type, + -- returning null address (what is that about???) + + elsif (Is_Concurrent_Type (Etype (Ent)) + and then Etype (Ent) = Base_Type (Ent)) + or else Ekind (Ent) = E_Package + or else Is_Generic_Unit (Ent) + then + Rewrite (N, + New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); + + -- Anything else is illegal + + else + Error_Attr ("invalid prefix for % attribute", P); + end if; + end; + + -- Allow Address if the prefix is a reference to the AST_Entry + -- attribute. If expansion is active, the attribute will be + -- replaced by a function call, and address will work fine and + -- get the proper value, but if expansion is not active, then + -- the check here allows proper semantic analysis of the reference. + + elsif Nkind (P) = N_Attribute_Reference + and then Attribute_Name (P) = Name_AST_Entry + then + Rewrite (N, + New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); + + -- Object is OK + + elsif Is_Object_Reference (P) then + return; + + -- Subprogram called using dot notation + + elsif Nkind (P) = N_Selected_Component + and then Is_Subprogram (Entity (Selector_Name (P))) + then + return; + + -- What exactly are we allowing here ??? and is this properly + -- documented in the sinfo documentation for this node ??? + + elsif Relaxed_RM_Semantics + and then Nkind (P) = N_Attribute_Reference + then + return; + + -- All other non-entity name cases are illegal + + else + Error_Attr ("invalid prefix for % attribute", P); + end if; + end Address_Checks; + ------------------------------ -- Analyze_Access_Attribute -- ------------------------------ @@ -1472,7 +1636,7 @@ package body Sem_Attr is Typ := Etype (E); - if From_With_Type (Typ) then + if From_Limited_With (Typ) then Error_Attr_P ("prefix of % attribute cannot be an incomplete type"); @@ -1491,7 +1655,7 @@ package body Sem_Attr is -- entities may occur in subprogram formals. if Is_Incomplete_Type (Typ) - and then From_With_Type (Typ) + and then From_Limited_With (Typ) and then Present (Non_Limited_View (Typ)) and then Is_Legal_Shadow_Entity_In_Body (Typ) then @@ -1817,6 +1981,17 @@ package body Sem_Attr is Check_Not_CPP_Type; end Check_Stream_Attribute; + ------------------------- + -- Check_System_Prefix -- + ------------------------- + + procedure Check_System_Prefix is + begin + if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then + Error_Attr ("only allowed prefix for % attribute is System", P); + end if; + end Check_System_Prefix; + ----------------------- -- Check_Task_Prefix -- ----------------------- @@ -1927,6 +2102,60 @@ package body Sem_Attr is Error_Attr; end Error_Attr_P; + --------------------- + -- In_Refined_Post -- + --------------------- + + function In_Refined_Post return Boolean is + function Is_Refined_Post (Prag : Node_Id) return Boolean; + -- Determine whether Prag denotes one of the incarnations of pragma + -- Refined_Post (either as is or pragma Check (Refined_Post, ...). + + --------------------- + -- Is_Refined_Post -- + --------------------- + + function Is_Refined_Post (Prag : Node_Id) return Boolean is + Args : constant List_Id := Pragma_Argument_Associations (Prag); + Nam : constant Name_Id := Pragma_Name (Prag); + + begin + if Nam = Name_Refined_Post then + return True; + + elsif Nam = Name_Check then + pragma Assert (Present (Args)); + + return Chars (Expression (First (Args))) = Name_Refined_Post; + end if; + + return False; + end Is_Refined_Post; + + -- Local variables + + Stmt : Node_Id; + + -- Start of processing for In_Refined_Post + + begin + Stmt := Parent (N); + while Present (Stmt) loop + if Nkind (Stmt) = N_Pragma and then Is_Refined_Post (Stmt) then + return True; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Stmt) then + exit; + end if; + + Stmt := Parent (Stmt); + end loop; + + return False; + end In_Refined_Post; + ---------------------------- -- Legal_Formal_Attribute -- ---------------------------- @@ -2252,136 +2481,7 @@ package body Sem_Attr is when Attribute_Address => Check_E0; - - -- Check for some junk cases, where we have to allow the address - -- attribute but it does not make much sense, so at least for now - -- just replace with Null_Address. - - -- We also do this if the prefix is a reference to the AST_Entry - -- attribute. If expansion is active, the attribute will be - -- replaced by a function call, and address will work fine and - -- get the proper value, but if expansion is not active, then - -- the check here allows proper semantic analysis of the reference. - - -- An Address attribute created by expansion is legal even when it - -- applies to other entity-denoting expressions. - - if Is_Protected_Self_Reference (P) then - - -- Address attribute on a protected object self reference is legal - - null; - - elsif Is_Entity_Name (P) then - declare - Ent : constant Entity_Id := Entity (P); - - begin - if Is_Subprogram (Ent) then - Set_Address_Taken (Ent); - Kill_Current_Values (Ent); - - -- An Address attribute is accepted when generated by the - -- compiler for dispatching operation, and an error is - -- issued once the subprogram is frozen (to avoid confusing - -- errors about implicit uses of Address in the dispatch - -- table initialization). - - if Has_Pragma_Inline_Always (Entity (P)) - and then Comes_From_Source (P) - then - Error_Attr_P - ("prefix of % attribute cannot be Inline_Always" & - " subprogram"); - - -- It is illegal to apply 'Address to an intrinsic - -- subprogram. This is now formalized in AI05-0095. - -- In an instance, an attempt to obtain 'Address of an - -- intrinsic subprogram (e.g the renaming of a predefined - -- operator that is an actual) raises Program_Error. - - elsif Convention (Ent) = Convention_Intrinsic then - if In_Instance then - Rewrite (N, - Make_Raise_Program_Error (Loc, - Reason => PE_Address_Of_Intrinsic)); - - else - Error_Msg_N - ("cannot take Address of intrinsic subprogram", N); - end if; - - -- Issue an error if prefix denotes an eliminated subprogram - - else - Check_For_Eliminated_Subprogram (P, Ent); - end if; - - elsif Is_Object (Ent) - or else Ekind (Ent) = E_Label - then - Set_Address_Taken (Ent); - - -- Deal with No_Implicit_Aliasing restriction - - if Restriction_Check_Required (No_Implicit_Aliasing) then - if not Is_Aliased_View (P) then - Check_Restriction (No_Implicit_Aliasing, P); - else - Check_No_Implicit_Aliasing (P); - end if; - end if; - - -- If we have an address of an object, and the attribute - -- comes from source, then set the object as potentially - -- source modified. We do this because the resulting address - -- can potentially be used to modify the variable and we - -- might not detect this, leading to some junk warnings. - - Set_Never_Set_In_Source (Ent, False); - - elsif (Is_Concurrent_Type (Etype (Ent)) - and then Etype (Ent) = Base_Type (Ent)) - or else Ekind (Ent) = E_Package - or else Is_Generic_Unit (Ent) - then - Rewrite (N, - New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); - - else - Error_Attr ("invalid prefix for % attribute", P); - end if; - end; - - elsif Nkind (P) = N_Attribute_Reference - and then Attribute_Name (P) = Name_AST_Entry - then - Rewrite (N, - New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); - - elsif Is_Object_Reference (P) then - null; - - elsif Nkind (P) = N_Selected_Component - and then Is_Subprogram (Entity (Selector_Name (P))) - then - null; - - -- What exactly are we allowing here ??? and is this properly - -- documented in the sinfo documentation for this node ??? - - elsif not Comes_From_Source (N) then - null; - - elsif Relaxed_RM_Semantics - and then Nkind (P) = N_Attribute_Reference - then - null; - - else - Error_Attr ("invalid prefix for % attribute", P); - end if; - + Address_Checks; Set_Etype (N, RTE (RE_Address)); ------------------ @@ -3583,6 +3683,24 @@ package body Sem_Attr is Check_Array_Type; Set_Etype (N, Universal_Integer); + ------------------- + -- Library_Level -- + ------------------- + + when Attribute_Library_Level => + Check_E0; + + if not Is_Entity_Name (P) then + Error_Attr_P ("prefix of % attribute must be an entity name"); + end if; + + if not Inside_A_Generic then + Set_Boolean_Result (N, + Is_Library_Level_Entity (Entity (P))); + end if; + + Set_Etype (N, Standard_Boolean); + --------------- -- Lock_Free -- --------------- @@ -3775,7 +3893,7 @@ package body Sem_Attr is -- Loop_Entry must create a constant initialized by the evaluated -- prefix. - if Is_Immutably_Limited_Type (Etype (P)) then + if Is_Limited_View (Etype (P)) then Error_Attr_P ("prefix of attribute % cannot be limited"); end if; @@ -4281,7 +4399,32 @@ package body Sem_Attr is Error_Attr ("% attribute can only appear in postcondition", P); end if; - -- Body case, where we must be inside a generated _Postcondition + -- Check the legality of attribute 'Old when it appears inside pragma + -- Refined_Post. These specialized checks are required only when code + -- generation is disabled. In the general case pragma Refined_Post is + -- transformed into pragma Check by Process_PPCs which in turn is + -- relocated to procedure _Postconditions. From then on the legality + -- of 'Old is determined as usual. + + elsif not Expander_Active and then In_Refined_Post then + Preanalyze_And_Resolve (P); + P_Type := Etype (P); + Set_Etype (N, P_Type); + + if Is_Limited_Type (P_Type) then + Error_Attr ("attribute % cannot apply to limited objects", P); + end if; + + if Is_Entity_Name (P) + and then Is_Constant_Object (Entity (P)) + then + Error_Msg_N + ("??attribute Old applied to constant has no effect", P); + end if; + + return; + + -- Body case, where we must be inside a generated _Postconditions -- procedure, or else the attribute use is definitely misplaced. The -- postcondition itself may have generated transient scopes, and is -- not necessarily the current one. @@ -4302,8 +4445,8 @@ package body Sem_Attr is -- If the attribute reference is generated for a Requires clause, -- then no expressions follow. Otherwise it is a primary, in which - -- case, if expressions follow, the attribute reference must be - -- an indexable object, so rewrite the node accordingly. + -- case, if expressions follow, the attribute reference must be an + -- indexable object, so rewrite the node accordingly. if Present (E1) then Rewrite (N, @@ -4320,8 +4463,8 @@ package body Sem_Attr is Check_E0; - -- Prefix has not been analyzed yet, and its full analysis will - -- take place during expansion (see below). + -- Prefix has not been analyzed yet, and its full analysis will take + -- place during expansion (see below). Preanalyze_And_Resolve (P); P_Type := Etype (P); @@ -4725,7 +4868,32 @@ package body Sem_Attr is Set_Is_Overloaded (P, False); end if; - -- Body case, where we must be inside a generated _Postcondition + -- Check the legality of attribute 'Result when it appears inside + -- pragma Refined_Post. These specialized checks are required only + -- when code generation is disabled. In the general case pragma + -- Refined_Post is transformed into pragma Check by Process_PPCs + -- which in turn is relocated to procedure _Postconditions. From + -- then on the legality of 'Result is determined as usual. + + elsif not Expander_Active and then In_Refined_Post then + PS := Current_Scope; + + -- The prefix denotes the proper related function + + if Is_Entity_Name (P) + and then Ekind (Entity (P)) = E_Function + and then Entity (P) = PS + then + null; + + else + Error_Msg_Name_2 := Chars (PS); + Error_Attr ("incorrect prefix for % attribute, expected %", P); + end if; + + Set_Etype (N, Etype (PS)); + + -- Body case, where we must be inside a generated _Postconditions -- procedure, and the prefix must be on the scope stack, or else the -- attribute use is definitely misplaced. The postcondition itself -- may have generated transient scopes, and is not necessarily the @@ -4763,9 +4931,9 @@ package body Sem_Attr is null; else - Error_Msg_NE - ("incorrect prefix for % attribute, expected &", P, PS); - Error_Attr; + Error_Msg_Name_2 := Chars (PS); + Error_Attr + ("incorrect prefix for % attribute, expected %", P); end if; Rewrite (N, Make_Identifier (Sloc (N), Name_uResult)); @@ -4835,35 +5003,10 @@ package body Sem_Attr is U : Node_Id; Unam : Unit_Name_Type; - procedure Set_Result (B : Boolean); - -- Replace restriction node by static constant False or True, - -- depending on the value of B. - - ---------------- - -- Set_Result -- - ---------------- - - procedure Set_Result (B : Boolean) is - begin - if B then - Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - else - Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; - - Set_Is_Static_Expression (N); - end Set_Result; - - -- Start of processing for Restriction_Set - begin Check_E1; Analyze (P); - - if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then - Set_Result (False); - Error_Attr_P ("prefix of % attribute must be System"); - end if; + Check_System_Prefix; -- No_Dependence case @@ -4872,7 +5015,7 @@ package body Sem_Attr is U := Explicit_Actual_Parameter (E1); if not OK_No_Dependence_Unit_Name (U) then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Attr; end if; @@ -4883,14 +5026,14 @@ package body Sem_Attr is if Designate_Same_Unit (U, No_Dependences.Table (J).Unit) and then No_Dependences.Table (J).Warn = False then - Set_Result (True); + Set_Boolean_Result (N, True); return; end if; end loop; -- If not in the No_Dependence table, result is False - Set_Result (False); + Set_Boolean_Result (N, False); -- In this case, we must ensure that the binder will reject any -- other unit in the partition that sets No_Dependence for this @@ -4913,29 +5056,29 @@ package body Sem_Attr is else if Nkind (E1) /= N_Identifier then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Attr ("attribute % requires restriction identifier", E1); else R := Get_Restriction_Id (Process_Restriction_Synonyms (E1)); if R = Not_A_Restriction_Id then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Msg_Node_1 := E1; Error_Attr ("invalid restriction identifier &", E1); elsif R not in Partition_Boolean_Restrictions then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Msg_Node_1 := E1; Error_Attr ("& is not a boolean partition-wide restriction", E1); end if; if Restriction_Active (R) then - Set_Result (True); + Set_Boolean_Result (N, True); else Check_Restriction (R, N); - Set_Result (False); + Set_Boolean_Result (N, False); end if; end if; end if; @@ -5040,21 +5183,42 @@ package body Sem_Attr is -------------------------- when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : + declare + Ent : Entity_Id := Empty; + begin Check_E0; Check_Type; - if not Is_Record_Type (P_Type) or else Is_Array_Type (P_Type) then - Error_Attr_P - ("prefix of % attribute must be record or array type"); - end if; + if not (Is_Record_Type (P_Type) or else Is_Array_Type (P_Type)) then + + -- In GNAT mode, the attribute applies to generic types as well + -- as composite types, and for non-composite types always returns + -- the default bit order for the target. + + if not (GNAT_Mode and then Is_Generic_Type (P_Type)) + and then not In_Instance + then + Error_Attr_P + ("prefix of % attribute must be record or array type"); + + elsif not Is_Generic_Type (P_Type) then + if Bytes_Big_Endian then + Ent := RTE (RE_High_Order_First); + else + Ent := RTE (RE_Low_Order_First); + end if; + end if; + + elsif Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then + Ent := RTE (RE_High_Order_First); - if Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then - Rewrite (N, - New_Occurrence_Of (RTE (RE_High_Order_First), Loc)); else - Rewrite (N, - New_Occurrence_Of (RTE (RE_Low_Order_First), Loc)); + Ent := RTE (RE_Low_Order_First); + end if; + + if Present (Ent) then + Rewrite (N, New_Occurrence_Of (Ent, Loc)); end if; Set_Etype (N, RTE (RE_Bit_Order)); @@ -5439,18 +5603,50 @@ package body Sem_Attr is -- To_Address -- ---------------- - when Attribute_To_Address => + when Attribute_To_Address => To_Address : declare + Val : Uint; + + begin Check_E1; Analyze (P); - - if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then - Error_Attr_P ("prefix of % attribute must be System"); - end if; + Check_System_Prefix; Generate_Reference (RTE (RE_Address), P); Analyze_And_Resolve (E1, Any_Integer); Set_Etype (N, RTE (RE_Address)); + -- Static expression case, check range and set appropriate type + + if Is_OK_Static_Expression (E1) then + Val := Expr_Value (E1); + + if Val < -(2 ** UI_From_Int (Standard'Address_Size - 1)) + or else + Val > 2 ** UI_From_Int (Standard'Address_Size) - 1 + then + Error_Attr ("address value out of range for % attribute", E1); + end if; + + -- In most cases the expression is a numeric literal or some other + -- address expression, but if it is a declared constant it may be + -- of a compatible type that must be left on the node. + + if Is_Entity_Name (E1) then + null; + + -- Set type to universal integer if negative + + elsif Val < 0 then + Set_Etype (E1, Universal_Integer); + + -- Otherwise set type to Unsigned_64 to accomodate max values + + else + Set_Etype (E1, Standard_Unsigned_64); + end if; + end if; + end To_Address; + ------------ -- To_Any -- ------------ @@ -5642,7 +5838,9 @@ package body Sem_Attr is ------------------------- -- This is a GNAT specific attribute which is like Access except that - -- all scope checks and checks for aliased views are omitted. + -- all scope checks and checks for aliased views are omitted. It is + -- documented as being equivalent to the use of the Address attribute + -- followed by an unchecked conversion to the target access type. when Attribute_Unrestricted_Access => @@ -5663,6 +5861,18 @@ package body Sem_Attr is Set_Address_Taken (Entity (P)); end if; + -- It might seem reasonable to call Address_Checks here to apply the + -- same set of semantic checks that we enforce for 'Address (after + -- all we document Unrestricted_Access as being equivalent to the + -- use of Address followed by an Unchecked_Conversion). However, if + -- we do enable these checks, we get multiple failures in both the + -- compiler run-time and in our regression test suite, so we leave + -- out these checks for now. To be investigated further some time??? + + -- Address_Checks; + + -- Now complete analysis using common access processing + Analyze_Access_Attribute; ------------ @@ -5784,7 +5994,7 @@ package body Sem_Attr is then Error_Attr_P ("prefix of attribute % must be a record or array"); - elsif Is_Immutably_Limited_Type (P_Type) then + elsif Is_Limited_View (P_Type) then Error_Attr ("prefix of attribute % cannot be limited", N); elsif Nkind (E1) /= N_Aggregate then @@ -6616,8 +6826,8 @@ package body Sem_Attr is return; end if; - -- Cases where P is not an object. Cannot do anything if P is - -- not the name of an entity. + -- Cases where P is not an object. Cannot do anything if P is not the + -- name of an entity. elsif not Is_Entity_Name (P) then Check_Expressions; @@ -6715,10 +6925,9 @@ package body Sem_Attr is -- We can fold 'Alignment applied to a type if the alignment is known -- (as happens for an alignment from an attribute definition clause). - -- At this stage, this can happen only for types (e.g. record - -- types) for which the size is always non-static. We exclude - -- generic types from consideration (since they have bogus - -- sizes set within templates). + -- At this stage, this can happen only for types (e.g. record types) for + -- which the size is always non-static. We exclude generic types from + -- consideration (since they have bogus sizes set within templates). elsif Id = Attribute_Alignment and then Is_Type (P_Entity) @@ -8925,6 +9134,7 @@ package body Sem_Attr is Attribute_First_Bit | Attribute_Input | Attribute_Last_Bit | + Attribute_Library_Level | Attribute_Maximum_Alignment | Attribute_Old | Attribute_Output | @@ -9495,7 +9705,7 @@ package body Sem_Attr is -- use of it. If it is an incomplete subtype, use the base type -- in any case. - if From_With_Type (Des_Btyp) + if From_Limited_With (Des_Btyp) and then Present (Non_Limited_View (Des_Btyp)) then Des_Btyp := Non_Limited_View (Des_Btyp); @@ -10228,6 +10438,23 @@ package body Sem_Attr is Eval_Attribute (N); end Resolve_Attribute; + ------------------------ + -- Set_Boolean_Result -- + ------------------------ + + procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + + begin + if B then + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + else + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + end if; + + Set_Is_Static_Expression (N); + end Set_Boolean_Result; + -------------------------------- -- Stream_Attribute_Available -- -------------------------------- diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 3c5d2af59ba..d67517e2ceb 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -91,7 +91,7 @@ package body Sem_Aux is elsif Is_Class_Wide_Type (Typ) and then Is_Incomplete_Type (Etype (Typ)) - and then From_With_Type (Etype (Typ)) + and then From_Limited_With (Etype (Typ)) and then Present (Non_Limited_View (Etype (Typ))) then return Class_Wide_Type (Non_Limited_View (Etype (Typ))); @@ -865,48 +865,6 @@ package body Sem_Aux is elsif Is_Concurrent_Type (Btype) then return True; - elsif Is_Record_Type (Btype) then - - -- Note that we return True for all limited interfaces, even though - -- (unsynchronized) limited interfaces can have descendants that are - -- nonlimited, because this is a predicate on the type itself, and - -- things like functions with limited interface results need to be - -- handled as build in place even though they might return objects - -- of a type that is not inherently limited. - - if Is_Class_Wide_Type (Btype) then - return Is_Immutably_Limited_Type (Root_Type (Btype)); - - else - declare - C : Entity_Id; - - begin - C := First_Component (Btype); - while Present (C) loop - - -- Don't consider components with interface types (which can - -- only occur in the case of a _parent component anyway). - -- They don't have any components, plus it would cause this - -- function to return true for nonlimited types derived from - -- limited interfaces. - - if not Is_Interface (Etype (C)) - and then Is_Immutably_Limited_Type (Etype (C)) - then - return True; - end if; - - C := Next_Component (C); - end loop; - end; - - return False; - end if; - - elsif Is_Array_Type (Btype) then - return Is_Immutably_Limited_Type (Component_Type (Btype)); - else return False; end if; @@ -1024,6 +982,105 @@ package body Sem_Aux is end if; end Is_Limited_Type; + --------------------- + -- Is_Limited_View -- + --------------------- + + function Is_Limited_View (Ent : Entity_Id) return Boolean is + Btype : constant Entity_Id := Available_View (Base_Type (Ent)); + + begin + if Is_Limited_Record (Btype) then + return True; + + elsif Ekind (Btype) = E_Limited_Private_Type + and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration + then + return not In_Package_Body (Scope ((Btype))); + + elsif Is_Private_Type (Btype) then + + -- AI05-0063: A type derived from a limited private formal type is + -- not immutably limited in a generic body. + + if Is_Derived_Type (Btype) + and then Is_Generic_Type (Etype (Btype)) + then + if not Is_Limited_Type (Etype (Btype)) then + return False; + + -- A descendant of a limited formal type is not immutably limited + -- in the generic body, or in the body of a generic child. + + elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then + return not In_Package_Body (Scope (Btype)); + + else + return False; + end if; + + else + declare + Utyp : constant Entity_Id := Underlying_Type (Btype); + begin + if No (Utyp) then + return False; + else + return Is_Limited_View (Utyp); + end if; + end; + end if; + + elsif Is_Concurrent_Type (Btype) then + return True; + + elsif Is_Record_Type (Btype) then + + -- Note that we return True for all limited interfaces, even though + -- (unsynchronized) limited interfaces can have descendants that are + -- nonlimited, because this is a predicate on the type itself, and + -- things like functions with limited interface results need to be + -- handled as build in place even though they might return objects + -- of a type that is not inherently limited. + + if Is_Class_Wide_Type (Btype) then + return Is_Limited_View (Root_Type (Btype)); + + else + declare + C : Entity_Id; + + begin + C := First_Component (Btype); + while Present (C) loop + + -- Don't consider components with interface types (which can + -- only occur in the case of a _parent component anyway). + -- They don't have any components, plus it would cause this + -- function to return true for nonlimited types derived from + -- limited interfaces. + + if not Is_Interface (Etype (C)) + and then Is_Limited_View (Etype (C)) + then + return True; + end if; + + C := Next_Component (C); + end loop; + end; + + return False; + end if; + + elsif Is_Array_Type (Btype) then + return Is_Limited_View (Component_Type (Btype)); + + else + return False; + end if; + end Is_Limited_View; + ---------------------- -- Nearest_Ancestor -- ---------------------- @@ -1151,6 +1208,26 @@ package body Sem_Aux is and then Has_Discriminants (Typ)); end Object_Type_Has_Constrained_Partial_View; + --------------------------- + -- Package_Specification -- + --------------------------- + + function Package_Specification (Pack_Id : Entity_Id) return Node_Id is + N : Node_Id; + + begin + N := Parent (Pack_Id); + while Nkind (N) /= N_Package_Specification loop + N := Parent (N); + + if No (N) then + raise Program_Error; + end if; + end loop; + + return N; + end Package_Specification; + --------------- -- Tree_Read -- --------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index e7086cc0ecc..49d75acfa70 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -281,6 +281,12 @@ package Sem_Aux is -- so. False for other type entities, or any entities that are not types. function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean; + -- Implements definition in Ada 2012 RM-7.5 (8.1/3). This differs from the + -- following predicate in that an untagged record with immutably limited + -- components is NOT by itself immutably limited. This matters, e.g. when + -- checking the legality of an access to the current instance. + + function Is_Limited_View (Ent : Entity_Id) return Boolean; -- Ent is any entity. True for a type that is "inherently" limited (i.e. -- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with -- a part that is of a task, protected, or explicitly limited record type". @@ -294,7 +300,8 @@ package Sem_Aux is -- Ent is any entity. Returns true if Ent is a limited type (limited -- private type, limited interface type, task type, protected type, -- composite containing a limited component, or a subtype of any of - -- these types). + -- these types). This older routine overlaps with the previous one, this + -- should be cleaned up??? function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id; -- Given a subtype Typ, this function finds out the nearest ancestor from @@ -348,4 +355,8 @@ package Sem_Aux is -- it returns the subprogram, task or protected body node for it. The unit -- may be a child unit with any number of ancestors. + function Package_Specification (Pack_Id : Entity_Id) return Node_Id; + -- Given an entity for a package or generic package, return corresponding + -- package specification. Simplifies handling of child units, and better + -- than the old idiom: Specification (Unit_Declaration_Node (Pack_Id)). end Sem_Aux; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 515d2a6009e..b3f47a6df9b 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -57,15 +57,15 @@ package body Sem_Case is -- to the choice node itself. type Choice_Table_Type is array (Nat range <>) of Choice_Bounds; - -- Table type used to sort the choices present in a case statement, array - -- aggregate or record variant. The actual entries are stored in 1 .. Last, - -- but we have a 0 entry for convenience in sorting. + -- Table type used to sort the choices present in a case statement or + -- record variant. The actual entries are stored in 1 .. Last, but we + -- have a 0 entry for use in sorting. ----------------------- -- Local Subprograms -- ----------------------- - procedure Check_Choices + procedure Check_Choice_Set (Choice_Table : in out Choice_Table_Type; Bounds_Type : Entity_Id; Subtyp : Entity_Id; @@ -95,7 +95,7 @@ package body Sem_Case is (Case_Table : Choice_Table_Type; Others_Choice : Node_Id; Choice_Type : Entity_Id); - -- The case table is the table generated by a call to Analyze_Choices + -- The case table is the table generated by a call to Check_Choices -- (with just 1 .. Last_Choice entries present). Others_Choice is a -- pointer to the N_Others_Choice node (this routine is only called if -- an others choice is present), and Choice_Type is the discrete type @@ -103,11 +103,11 @@ package body Sem_Case is -- determine the set of values covered by others. This choice list is -- set in the Others_Discrete_Choices field of the N_Others_Choice node. - ------------------- - -- Check_Choices -- - ------------------- + ---------------------- + -- Check_Choice_Set -- + ---------------------- - procedure Check_Choices + procedure Check_Choice_Set (Choice_Table : in out Choice_Table_Type; Bounds_Type : Entity_Id; Subtyp : Entity_Id; @@ -126,6 +126,10 @@ package body Sem_Case is -- choice that covered a predicate set. Error denotes whether the check -- found an illegal intersection. + procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id); + -- Post message "duplication of choice value(s) bla bla at xx". Message + -- is posted at location C. Caller sets Error_Msg_Sloc for xx. + procedure Explain_Non_Static_Bound; -- Called when we find a non-static bound, requiring the base type to -- be covered. Provides where possible a helpful explanation of why the @@ -145,8 +149,7 @@ package body Sem_Case is procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint); -- Emit an error message for each non-covered static predicate set. - -- Prev_Hi denotes the upper bound of the last choice that covered a - -- set. + -- Prev_Hi denotes the upper bound of the last choice covering a set. procedure Move_Choice (From : Natural; To : Natural); -- Move routine for sorting the Choice_Table @@ -238,6 +241,7 @@ package body Sem_Case is Choice_Hi : constant Uint := Expr_Value (Choice.Hi); Choice_Lo : constant Uint := Expr_Value (Choice.Lo); Loc : Source_Ptr; + LocN : Node_Id; Next_Hi : Uint; Next_Lo : Uint; Pred_Hi : Uint; @@ -249,11 +253,13 @@ package body Sem_Case is -- Find the proper error message location if Present (Choice.Node) then - Loc := Sloc (Choice.Node); + LocN := Choice.Node; else - Loc := Sloc (Case_Node); + LocN := Case_Node; end if; + Loc := Sloc (LocN); + if Present (Pred) then Pred_Lo := Expr_Value (Low_Bound (Pred)); Pred_Hi := Expr_Value (High_Bound (Pred)); @@ -263,16 +269,17 @@ package body Sem_Case is else Illegal_Range (Loc, Choice_Lo, Choice_Hi); Error := True; - return; end if; -- Step 1: Detect duplicate choices - if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) - or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) - then - Error_Msg ("duplication of choice value", Loc); + if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then + Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN); + Error := True; + + elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then + Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN); Error := True; -- Step 2: Detect full coverage @@ -312,8 +319,16 @@ package body Sem_Case is -- ^ illegal ^ elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then - Missing_Choice (Pred_Lo, Pred_Hi); - Error := True; + if Others_Present then + + -- Current predicate set is covered by others clause. + + null; + + else + Missing_Choice (Pred_Lo, Pred_Hi); + Error := True; + end if; -- There may be several static predicate sets between the current -- one and the choice. Inspect the next static predicate set. @@ -377,7 +392,12 @@ package body Sem_Case is if Others_Present then Prev_Lo := Choice_Lo; Prev_Hi := Choice_Hi; - Next (Pred); + + -- Check whether predicate set is fully covered by choice + + if Pred_Hi = Choice_Hi then + Next (Pred); + end if; -- Choice_Lo Choice_Hi Pred_Hi -- +===========+===========+ @@ -422,6 +442,45 @@ package body Sem_Case is end if; end Check_Against_Predicate; + ---------------- + -- Dup_Choice -- + ---------------- + + procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id) is + begin + -- In some situations, we call this with a null range, and obviously + -- we don't want to complain in this case. + + if Lo > Hi then + return; + end if; + + -- Case of only one value that is missing + + if Lo = Hi then + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Lo; + Error_Msg_N ("duplication of choice value: ^#!", C); + else + Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); + Error_Msg_N ("duplication of choice value: %#!", C); + end if; + + -- More than one choice value, so print range of values + + else + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Lo; + Error_Msg_Uint_2 := Hi; + Error_Msg_N ("duplication of choice values: ^ .. ^#!", C); + else + Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); + Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type); + Error_Msg_N ("duplication of choice values: % .. %#!", C); + end if; + end if; + end Dup_Choice; + ------------------------------ -- Explain_Non_Static_Bound -- ------------------------------ @@ -443,21 +502,21 @@ package body Sem_Case is if Nkind (Case_Node) = N_Variant_Part then Error_Msg_NE - ("bounds of & are not static," & - " alternatives must cover base type", Expr, Expr); + ("bounds of & are not static, " + & "alternatives must cover base type!", Expr, Expr); -- If this is a case statement, the expression may be non-static -- or else the subtype may be at fault. elsif Is_Entity_Name (Expr) then Error_Msg_NE - ("bounds of & are not static," & - " alternatives must cover base type", Expr, Expr); + ("bounds of & are not static, " + & "alternatives must cover base type!", Expr, Expr); else Error_Msg_N - ("subtype of expression is not static," - & " alternatives must cover base type!", Expr); + ("subtype of expression is not static, " + & "alternatives must cover base type!", Expr); end if; -- Otherwise the expression is not static, even if the bounds of the @@ -600,7 +659,7 @@ package body Sem_Case is Prev_Lo : Uint; Prev_Hi : Uint; - -- Start of processing for Check_Choices + -- Start of processing for Check_Choice_Set begin -- Choice_Table must start at 0 which is an unused location used by the @@ -693,10 +752,12 @@ package body Sem_Case is if Sloc (Prev_Choice) <= Sloc (Choice) then Error_Msg_Sloc := Sloc (Prev_Choice); - Error_Msg_N ("duplication of choice value#", Choice); + Dup_Choice + (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice); else Error_Msg_Sloc := Sloc (Choice); - Error_Msg_N ("duplication of choice value#", Prev_Choice); + Dup_Choice + (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice); end if; elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then @@ -708,15 +769,15 @@ package body Sem_Case is end if; end loop; - if not Others_Present and then Expr_Value (Bounds_Hi) > Choice_Hi then - Missing_Choice (Choice_Hi + 1, Bounds_Hi); + if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then + Missing_Choice (Prev_Hi + 1, Bounds_Hi); - if Expr_Value (Bounds_Hi) > Choice_Hi + 1 then + if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then Explain_Non_Static_Bound; end if; end if; end if; - end Check_Choices; + end Check_Choice_Set; ------------------ -- Choice_Image -- @@ -801,11 +862,10 @@ package body Sem_Case is Previous_Hi : Uint; function Build_Choice (Value1, Value2 : Uint) return Node_Id; - -- Builds a node representing the missing choices given by the - -- Value1 and Value2. A N_Range node is built if there is more than - -- one literal value missing. Otherwise a single N_Integer_Literal, - -- N_Identifier or N_Character_Literal is built depending on what - -- Choice_Type is. + -- Builds a node representing the missing choices given by Value1 and + -- Value2. A N_Range node is built if there is more than one literal + -- value missing. Otherwise a single N_Integer_Literal, N_Identifier + -- or N_Character_Literal is built depending on what Choice_Type is. function Lit_Of (Value : Uint) return Node_Id; -- Returns the Node_Id for the enumeration literal corresponding to the @@ -977,11 +1037,11 @@ package body Sem_Case is null; end No_OP; - -------------------------------- - -- Generic_Choices_Processing -- - -------------------------------- + ----------------------------- + -- Generic_Analyze_Choices -- + ----------------------------- - package body Generic_Choices_Processing is + package body Generic_Analyze_Choices is -- The following type is used to gather the entries for the choice -- table, so that we can then allocate the right length. @@ -994,20 +1054,143 @@ package body Sem_Case is Nxt : Link_Ptr; end record; - procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); - --------------------- -- Analyze_Choices -- --------------------- procedure Analyze_Choices - (N : Node_Id; - Subtyp : Entity_Id; - Raises_CE : out Boolean; - Others_Present : out Boolean) + (Alternatives : List_Id; + Subtyp : Entity_Id) + is + Choice_Type : constant Entity_Id := Base_Type (Subtyp); + -- The actual type against which the discrete choices are resolved. + -- Note that this type is always the base type not the subtype of the + -- ruling expression, index or discriminant. + + Expected_Type : Entity_Id; + -- The expected type of each choice. Equal to Choice_Type, except if + -- the expression is universal, in which case the choices can be of + -- any integer type. + + Alt : Node_Id; + -- A case statement alternative or a variant in a record type + -- declaration. + + Choice : Node_Id; + Kind : Node_Kind; + -- The node kind of the current Choice + + begin + -- Set Expected type (= choice type except for universal integer, + -- where we accept any integer type as a choice). + + if Choice_Type = Universal_Integer then + Expected_Type := Any_Integer; + else + Expected_Type := Choice_Type; + end if; + + -- Now loop through the case alternatives or record variants + + Alt := First (Alternatives); + while Present (Alt) loop + + -- If pragma, just analyze it + + if Nkind (Alt) = N_Pragma then + Analyze (Alt); + + -- Otherwise we have an alternative. In most cases the semantic + -- processing leaves the list of choices unchanged + + -- Check each choice against its base type + + else + Choice := First (Discrete_Choices (Alt)); + while Present (Choice) loop + Analyze (Choice); + Kind := Nkind (Choice); + + -- Choice is a Range + + if Kind = N_Range + or else (Kind = N_Attribute_Reference + and then Attribute_Name (Choice) = Name_Range) + then + Resolve (Choice, Expected_Type); + + -- Choice is a subtype name, nothing further to do now + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + null; + + -- Choice is a subtype indication + + elsif Kind = N_Subtype_Indication then + Resolve_Discrete_Subtype_Indication + (Choice, Expected_Type); + + -- Others choice, no analysis needed + + elsif Kind = N_Others_Choice then + null; + + -- Only other possibility is an expression + + else + Resolve (Choice, Expected_Type); + end if; + + -- Move to next choice + + Next (Choice); + end loop; + + Process_Associated_Node (Alt); + end if; + + Next (Alt); + end loop; + end Analyze_Choices; + + end Generic_Analyze_Choices; + + --------------------------- + -- Generic_Check_Choices -- + --------------------------- + + package body Generic_Check_Choices is + + -- The following type is used to gather the entries for the choice + -- table, so that we can then allocate the right length. + + type Link; + type Link_Ptr is access all Link; + + type Link is record + Val : Choice_Bounds; + Nxt : Link_Ptr; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); + + ------------------- + -- Check_Choices -- + ------------------- + + procedure Check_Choices + (N : Node_Id; + Alternatives : List_Id; + Subtyp : Entity_Id; + Others_Present : out Boolean) is E : Entity_Id; + Raises_CE : Boolean; + -- Set True if one of the bounds of a choice raises CE + Enode : Node_Id; -- This is where we post error messages for bounds out of range @@ -1044,9 +1227,6 @@ package body Sem_Case is Kind : Node_Kind; -- The node kind of the current Choice - Delete_Choice : Boolean; - -- Set to True to delete the current choice - Others_Choice : Node_Id := Empty; -- Remember others choice if it is present (empty otherwise) @@ -1168,12 +1348,20 @@ package body Sem_Case is Num_Choices := Num_Choices + 1; end Check; - -- Start of processing for Analyze_Choices + -- Start of processing for Check_Choices begin Raises_CE := False; Others_Present := False; + -- If Subtyp is not a discrete type or there was some other error, + -- then don't try any semantic checking on the choices since we have + -- a complete mess. + + if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then + return; + end if; + -- If Subtyp is not a static subtype Ada 95 requires then we use the -- bounds of its base type to determine the values covered by the -- discrete choices. @@ -1212,7 +1400,7 @@ package body Sem_Case is -- Now loop through the case alternatives or record variants - Alt := First (Get_Alternatives (N)); + Alt := First (Alternatives); while Present (Alt) loop -- If pragma, just analyze it @@ -1220,13 +1408,14 @@ package body Sem_Case is if Nkind (Alt) = N_Pragma then Analyze (Alt); - -- Otherwise check each choice against its base type + -- Otherwise we have an alternative. In most cases the semantic + -- processing leaves the list of choices unchanged + + -- Check each choice against its base type else - Choice := First (Get_Choices (Alt)); + Choice := First (Discrete_Choices (Alt)); while Present (Choice) loop - Delete_Choice := False; - Analyze (Choice); Kind := Nkind (Choice); -- Choice is a Range @@ -1235,7 +1424,6 @@ package body Sem_Case is or else (Kind = N_Attribute_Reference and then Attribute_Name (Choice) = Name_Range) then - Resolve (Choice, Expected_Type); Check (Choice, Low_Bound (Choice), High_Bound (Choice)); -- Choice is a subtype name @@ -1243,9 +1431,13 @@ package body Sem_Case is elsif Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)) then + -- Check for inappropriate type + if not Covers (Expected_Type, Etype (Choice)) then Wrong_Type (Choice, Choice_Type); + -- Type is OK, so check further + else E := Entity (Choice); @@ -1260,34 +1452,32 @@ package body Sem_Case is then Bad_Predicated_Subtype_Use ("cannot use subtype& with non-static " - & "predicate as case alternative", Choice, E, - Suggest_Static => True); + & "predicate as case alternative", + Choice, E, Suggest_Static => True); - -- Static predicate case + -- Static predicate case else declare - Copy : constant List_Id := Empty_List; - P : Node_Id; - C : Node_Id; + P : Node_Id; + C : Node_Id; begin -- Loop through entries in predicate list, - -- converting to choices. Note that if the + -- checking each entry. Note that if the -- list is empty, corresponding to a False - -- predicate, then no choices are inserted. + -- predicate, then no choices are checked. P := First (Static_Predicate (E)); while Present (P) loop C := New_Copy (P); Set_Sloc (C, Sloc (Choice)); - Append_To (Copy, C); + Check (C, Low_Bound (C), High_Bound (C)); Next (P); end loop; - - Insert_List_After (Choice, Copy); - Delete_Choice := True; end; + + Set_Has_SP_Choice (Alt); end if; -- Not predicated subtype case @@ -1306,8 +1496,6 @@ package body Sem_Case is Resolve_Discrete_Subtype_Indication (Choice, Expected_Type); - -- Here for other than predicated subtype case - if Etype (Choice) /= Any_Type then declare C : constant Node_Id := Constraint (Choice); @@ -1323,7 +1511,8 @@ package body Sem_Case is else if Is_OK_Static_Expression (L) - and then Is_OK_Static_Expression (H) + and then + Is_OK_Static_Expression (H) then if Expr_Value (L) > Expr_Value (H) then Process_Empty_Choice (Choice); @@ -1351,9 +1540,9 @@ package body Sem_Case is -- alternative and as its only choice. elsif Kind = N_Others_Choice then - if not (Choice = First (Get_Choices (Alt)) - and then Choice = Last (Get_Choices (Alt)) - and then Alt = Last (Get_Alternatives (N))) + if not (Choice = First (Discrete_Choices (Alt)) + and then Choice = Last (Discrete_Choices (Alt)) + and then Alt = Last (Alternatives)) then Error_Msg_N ("the choice OTHERS must appear alone and last", @@ -1367,22 +1556,12 @@ package body Sem_Case is -- Only other possibility is an expression else - Resolve (Choice, Expected_Type); Check (Choice, Choice, Choice); end if; - -- Move to next choice, deleting the current one if the - -- flag requesting this deletion is set True. - - declare - C : constant Node_Id := Choice; - begin - Next (Choice); + -- Move to next choice - if Delete_Choice then - Remove (C); - end if; - end; + Next (Choice); end loop; Process_Associated_Node (Alt); @@ -1412,7 +1591,7 @@ package body Sem_Case is end loop; end; - Check_Choices + Check_Choice_Set (Choice_Table, Bounds_Type, Subtyp, @@ -1431,8 +1610,8 @@ package body Sem_Case is Choice_Type => Bounds_Type); end if; end; - end Analyze_Choices; + end Check_Choices; - end Generic_Choices_Processing; + end Generic_Check_Choices; end Sem_Case; diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads index ccee41f02a9..c6917f06837 100644 --- a/gcc/ada/sem_case.ads +++ b/gcc/ada/sem_case.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2013, 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,58 +30,124 @@ -- aggregate case, since issues with nested aggregates make that case -- substantially different. +-- The following processing is required for such cases: + +-- 1. Analysis of names of subtypes, constants, expressions appearing within +-- the choices. This must be done when the construct is encountered to get +-- proper visibility of names. + +-- 2. Checking for semantic correctness of the choices. A lot of this could +-- be done at the time when the construct is encountered, but not all, since +-- in the case of variants, statically predicated subtypes won't be frozen +-- (and the choice sets known) till the enclosing record type is frozen. So +-- at least the check for no overlaps and covering the range must be delayed +-- till the freeze point in this case. + +-- 3. Set the Others_Discrete_Choices list for an others choice. This is +-- used in various ways, e.g. to construct the disriminant checking function +-- for the case of a variant with an others choice. + +-- 4. In the case of static predicates, we need to expand out choices that +-- correspond to the predicate for the back end. This expansion destroys +-- the list of choices, so it should be delayed to expansion time. We do +-- not want to mess up the -gnatct ASIS tree, which needs to be able to + +-- Step 1 is performed by the generic procedure Analyze_Choices, which is +-- called when the variant record or case statement/expression is first +-- encountered. + +-- Step 2 is performed by the generic procedure Check_Choices. We decide to +-- do all semantic checking in that step, since as noted above some of this +-- has to be deferred to the freeze point in any case for variants. For case +-- statements and expressions, this procedure can be called at the time the +-- case construct is encountered (after calling Analyze_Choices). + +-- Step 3 is also performed by Check_Choices, since we need the static ranges +-- for predicated subtypes to accurately construct this. + +-- Step 4 is performed by the procedure Expand_Static_Predicates_In_Choices. +-- For case statements, this call only happens during expansion, so the tree +-- generated for ASIS does not have this expansion. For the Variant case, the +-- expansion is done in the ASIS -gnatct case, but with a proper Rewrite call +-- on the N_Variant node, so ASIS can retrieve the original. The reason we do +-- the expansion unconditionally for variants is that other processing, for +-- example for aggregates, relies on having a complete list of choices. + +-- Historical note: We used to perform all four of these functions at once in +-- a single procedure called Analyze_Choices. This routine was called at the +-- time the construct was first encountered. That seemed to work OK up to Ada +-- 2005, but the introduction of statically predicated subtypes with delayed +-- evaluation of the static ranges made this completely wrong, both because +-- the ASIS tree got destroyed by step 4, and steps 2 and 3 were too early +-- in the variant record case. + with Types; use Types; package Sem_Case is procedure No_OP (C : Node_Id); -- The no-operation routine. Does absolutely nothing. Can be used - -- in the following generic for the parameter Process_Empty_Choice. + -- in the following generics for the parameters Process_Empty_Choice, + -- or Process_Associated_Node. generic - with function Get_Alternatives (N : Node_Id) return List_Id; - -- Function needed to get to the actual list of case statement - -- alternatives, or array aggregate component associations or - -- record variants from which we can then access the actual lists - -- of discrete choices. N is the node for the original construct - -- i.e. a case statement, an array aggregate or a record variant. - - with function Get_Choices (A : Node_Id) return List_Id; - -- Given a case statement alternative, array aggregate component - -- association or record variant A we need different access functions - -- to get to the actual list of discrete choices. + with procedure Process_Associated_Node (A : Node_Id); + -- Associated with each case alternative or record variant A there is + -- a node or list of nodes that need additional processing. This routine + -- implements that processing. + + package Generic_Analyze_Choices is + + procedure Analyze_Choices + (Alternatives : List_Id; + Subtyp : Entity_Id); + -- From a case expression, case statement, or record variant, this + -- routine analyzes the corresponding list of discrete choices which + -- appear in each element of the list Alternatives (for the variant + -- part case, this is the variants, for a case expression or statement, + -- this is the Alternatives). + -- + -- Subtyp is the subtype of the discrete choices. The type against which + -- the discrete choices must be resolved is its base type. + end Generic_Analyze_Choices; + + generic with procedure Process_Empty_Choice (Choice : Node_Id); - -- Processing to carry out for an empty Choice + -- Processing to carry out for an empty Choice. Set to No_Op (declared + -- above) if no such processing is required. with procedure Process_Non_Static_Choice (Choice : Node_Id); - -- Processing to carry out for a non static Choice + -- Processing to carry out for a non static Choice (gives an error msg) with procedure Process_Associated_Node (A : Node_Id); - -- Associated with each case alternative, aggregate component - -- association or record variant A there is a node or list of nodes - -- that need semantic processing. This routine implements that - -- processing. + -- Associated with each case alternative or record variant A there is + -- a node or list of nodes that need semantic processing. This routine + -- implements that processing. - package Generic_Choices_Processing is + package Generic_Check_Choices is - procedure Analyze_Choices - (N : Node_Id; - Subtyp : Entity_Id; - Raises_CE : out Boolean; - Others_Present : out Boolean); - -- From a case expression, case statement, array aggregate or record - -- variant N, this routine analyzes the corresponding list of discrete - -- choices. Subtyp is the subtype of the discrete choices. The type - -- against which the discrete choices must be resolved is its base type. + procedure Check_Choices + (N : Node_Id; + Alternatives : List_Id; + Subtyp : Entity_Id; + Others_Present : out Boolean); + -- From a case expression, case statement, or record variant N, this + -- routine analyzes the corresponding list of discrete choices which + -- appear in each element of the list Alternatives (for the variant + -- part case, this is the variants, for a case expression or statement, + -- this is the Alternatives). -- - -- In one of the bounds of a discrete choice raises a constraint - -- error the flag Raise_CE is set. + -- Subtyp is the subtype of the discrete choices. The type against which + -- the discrete choices must be resolved is its base type. -- - -- Finally Others_Present is set to True if an Others choice is present - -- in the list of choices, and in this case the call also sets - -- Others_Discrete_Choices in the N_Others_Choice node. - - end Generic_Choices_Processing; + -- Others_Present is set to True if an Others choice is present in the + -- list of choices, and in this case Others_Discrete_Choices is set in + -- the N_Others_Choice node. + -- + -- If a Discrete_Choice list contains at least one instance of a subtype + -- with a static predicate, then the Has_SP_Choice flag is set true in + -- the parent node (N_Variant, N_Case_Expression/Statement_Alternative). + end Generic_Check_Choices; end Sem_Case; diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index e4615393dd2..79201c4edf0 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -561,8 +561,7 @@ package body Sem_Cat is and then Is_Package_Or_Generic_Package (Unit_Entity) and then Unit_Kind /= N_Package_Body and then List_Containing (N) = - Visible_Declarations - (Specification (Unit_Declaration_Node (Unit_Entity))) + Visible_Declarations (Package_Specification (Unit_Entity)) and then not In_Package_Body (Unit_Entity) and then not In_Instance; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 6c36bf2cdb7..78520f8b0a1 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -53,6 +53,7 @@ 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_Ch13; use Sem_Ch13; with Sem_Dist; use Sem_Dist; with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; @@ -329,9 +330,8 @@ package body Sem_Ch10 is function Same_Unit (N : Node_Id; P : Entity_Id) return Boolean is begin return Entity (N) = P - or else - (Present (Renamed_Object (P)) - and then Entity (N) = Renamed_Object (P)); + or else (Present (Renamed_Object (P)) + and then Entity (N) = Renamed_Object (P)); end Same_Unit; -- Start of processing for Process_Body_Clauses @@ -403,14 +403,12 @@ package body Sem_Ch10 is elsif Nkind (Cont_Item) = N_Pragma and then Nam_In (Pragma_Name (Cont_Item), Name_Elaborate, - Name_Elaborate_All) + Name_Elaborate_All) and then not Used_Type_Or_Elab then Prag_Unit := First (Pragma_Argument_Associations (Cont_Item)); - while Present (Prag_Unit) - and then not Used_Type_Or_Elab - loop + while Present (Prag_Unit) and then not Used_Type_Or_Elab loop if Entity (Expression (Prag_Unit)) = Nam_Ent then Used_Type_Or_Elab := True; end if; @@ -477,7 +475,7 @@ package body Sem_Ch10 is -- with Pack; -- with Pack; -- pragma Elaborate (Pack); - -- + -- In this case, the second with clause is redundant since -- the pragma applies only to the first "with Pack;". @@ -557,10 +555,8 @@ package body Sem_Ch10 is if (Withed_In_Spec and then not Used_Type_Or_Elab) and then - ((not Used_In_Spec - and then not Used_In_Body) - or else - Used_In_Spec) + ((not Used_In_Spec and then not Used_In_Body) + or else Used_In_Spec) then Error_Msg_N -- CODEFIX ("redundant with clause in body??", Clause); @@ -1013,9 +1009,8 @@ package body Sem_Ch10 is N_Package_Renaming_Declaration, N_Subprogram_Declaration) or else Nkind (Unit_Node) in N_Generic_Declaration - or else - (Nkind (Unit_Node) = N_Subprogram_Body - and then Acts_As_Spec (Unit_Node)) + or else (Nkind (Unit_Node) = N_Subprogram_Body + and then Acts_As_Spec (Unit_Node)) then Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); @@ -1581,6 +1576,7 @@ package body Sem_Ch10 is Set_Has_Completion (Nam); Set_Scope (Defining_Entity (N), Current_Scope); + Set_Corresponding_Spec_Of_Stub (N, Nam); Generate_Reference (Nam, Id, 'b'); Analyze_Proper_Body (N, Nam); end if; @@ -1664,6 +1660,10 @@ package body Sem_Ch10 is end if; end Optional_Subunit; + -- Local variables + + Stub_Id : Entity_Id; + -- Start of processing for Analyze_Proper_Body begin @@ -1818,6 +1818,7 @@ package body Sem_Ch10 is declare Comp_Unit : constant Node_Id := Cunit (Unum); + Prop_Body : Node_Id; begin -- Check for child unit instead of subunit @@ -1830,6 +1831,8 @@ package body Sem_Ch10 is -- OK, we have a subunit else + Prop_Body := Proper_Body (Unit (Comp_Unit)); + -- Set corresponding stub (even if errors) Set_Corresponding_Stub (Unit (Comp_Unit), N); @@ -1845,11 +1848,17 @@ package body Sem_Ch10 is SCO_Record (Unum); end if; - -- Propagate any aspect specifications associated with - -- with the stub to the proper body. + -- Propagate all aspect specifications associated with + -- the stub to the proper body. + + Move_Or_Merge_Aspects (From => N, To => Prop_Body); - Move_Or_Merge_Aspects - (From => N, To => Proper_Body (Unit (Comp_Unit))); + -- Move all source pragmas that follow the body stub and + -- apply to it to the declarations of the proper body. + + if Nkind (N) = N_Subprogram_Body_Stub then + Relocate_Pragmas_To_Body (N, Target_Body => Prop_Body); + end if; -- Analyze the unit if semantics active @@ -1869,6 +1878,24 @@ package body Sem_Ch10 is Version_Update (Cunit (Main_Unit), Comp_Unit); end if; end; + + -- The unit which should contain the proper subprogram body does + -- not exist. Analyze the aspect specifications of the stub (if + -- any). + + elsif Nkind (N) = N_Subprogram_Body_Stub + and then Has_Aspects (N) + then + Stub_Id := Defining_Unit_Name (Specification (N)); + + -- Restore the proper visibility of the stub and its formals + + Push_Scope (Stub_Id); + Install_Formals (Stub_Id); + + Analyze_Aspect_Specifications (N, Stub_Id); + + Pop_Scope; end if; end if; @@ -1899,13 +1926,13 @@ package body Sem_Ch10 is Nam := Full_View (Nam); end if; - if No (Nam) - or else not Is_Protected_Type (Etype (Nam)) - then + if No (Nam) or else not Is_Protected_Type (Etype (Nam)) then Error_Msg_N ("missing specification for Protected body", N); + else Set_Scope (Defining_Entity (N), Current_Scope); Set_Has_Completion (Etype (Nam)); + Set_Corresponding_Spec_Of_Stub (N, Nam); Generate_Reference (Nam, Defining_Identifier (N), 'b'); Analyze_Proper_Body (N, Etype (Nam)); end if; @@ -1936,9 +1963,7 @@ package body Sem_Ch10 is N_Subprogram_Body) then Decl := First (Declarations (Parent (N))); - while Present (Decl) - and then Decl /= N - loop + while Present (Decl) and then Decl /= N loop if Nkind (Decl) = N_Subprogram_Body_Stub and then (Chars (Defining_Unit_Name (Specification (Decl))) = Chars (Defining_Unit_Name (Specification (N)))) @@ -2150,9 +2175,7 @@ package body Sem_Ch10 is E := First_Entity (Current_Scope); while Present (E) loop - if not Is_Child_Unit (E) - or else Is_Visible_Lib_Unit (E) - then + if not Is_Child_Unit (E) or else Is_Visible_Lib_Unit (E) then Set_Is_Immediately_Visible (E); end if; @@ -2278,8 +2301,8 @@ package body Sem_Ch10 is if Is_Package_Or_Generic_Package (Par_Unit) then if not Is_Immediately_Visible (Par_Unit) or else (Present (First_Entity (Par_Unit)) - and then not Is_Immediately_Visible - (First_Entity (Par_Unit))) + and then not + Is_Immediately_Visible (First_Entity (Par_Unit))) then Set_Is_Immediately_Visible (Par_Unit); Install_Visible_Declarations (Par_Unit); @@ -2351,6 +2374,7 @@ package body Sem_Ch10 is else Set_Scope (Defining_Entity (N), Current_Scope); Generate_Reference (Nam, Defining_Identifier (N), 'b'); + Set_Corresponding_Spec_Of_Stub (N, Nam); -- Check for duplicate stub, if so give message and terminate @@ -2888,7 +2912,7 @@ package body Sem_Ch10 is or else Private_Present (Item) or else Nkind_In (Lib_Unit, N_Package_Body, N_Subunit) or else (Nkind (Lib_Unit) = N_Subprogram_Body - and then not Acts_As_Spec (Parent (Lib_Unit))) + and then not Acts_As_Spec (Parent (Lib_Unit))) then null; @@ -3429,7 +3453,7 @@ package body Sem_Ch10 is if Nkind (Lib_Unit) = N_Package_Body or else (Nkind (Lib_Unit) = N_Subprogram_Body - and then not Acts_As_Spec (N)) + and then not Acts_As_Spec (N)) then Install_Context (Library_Unit (N)); @@ -3601,9 +3625,7 @@ package body Sem_Ch10 is -- Check all the enclosing scopes. E2 := E; - while E2 /= Standard_Standard - and then E2 /= WEnt - loop + while E2 /= Standard_Standard and then E2 /= WEnt loop E2 := Scope (E2); end loop; @@ -3821,9 +3843,7 @@ package body Sem_Ch10 is Check_Private_Limited_Withed_Unit (Item); - if not Implicit_With (Item) - and then Is_Child_Spec (Unit (N)) - then + if not Implicit_With (Item) and then Is_Child_Spec (Unit (N)) then Check_Renamings (Parent_Spec (Unit (N)), Item); end if; @@ -3877,7 +3897,7 @@ package body Sem_Ch10 is and then Ekind (Defining_Identifier (Decl)) = E_Incomplete_Subtype and then - From_With_Type (Defining_Identifier (Decl)) + From_Limited_With (Defining_Identifier (Decl)) then Def_Id := Defining_Identifier (Decl); Non_Lim_View := Non_Limited_View (Def_Id); @@ -3963,7 +3983,7 @@ package body Sem_Ch10 is or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation or else (Nkind (Lib_Unit) = N_Package_Declaration - and then Present (Generic_Parent (Specification (Lib_Unit)))) + and then Present (Generic_Parent (Specification (Lib_Unit)))) then null; else @@ -4008,7 +4028,7 @@ package body Sem_Ch10 is Is_Private_Descendant (P_Name) or else Private_Present (Parent (Lib_Unit))); - P_Spec := Specification (Unit_Declaration_Node (P_Name)); + P_Spec := Package_Specification (P_Name); Push_Scope (P_Name); -- Save current visibility of unit @@ -4026,9 +4046,7 @@ package body Sem_Ch10 is Set_Use (Generic_Formal_Declarations (Parent (P_Spec))); end if; - if Is_Private - or else Private_Present (Parent (Lib_Unit)) - then + if Is_Private or else Private_Present (Parent (Lib_Unit)) then Install_Private_Declarations (P_Name); Install_Private_With_Clauses (P_Name); Set_Use (Private_Declarations (P_Spec)); @@ -4957,7 +4975,18 @@ package body Sem_Ch10 is -- Replace E in the homonyms list, so that the limited view -- becomes available. - if E = Non_Limited_View (Lim_Typ) then + -- If the non-limited view is a record with an anonymous + -- self-referential component, the analysis of the record + -- declaration creates an incomplete type with the same name + -- in order to define an internal access type. The visible + -- entity is now the incomplete type, and that is the one to + -- replace in the visibility structure. + + if E = Non_Limited_View (Lim_Typ) + or else + (Ekind (E) = E_Incomplete_Type + and then Full_View (E) = Non_Limited_View (Lim_Typ)) + then Set_Homonym (Lim_Typ, Homonym (Prev)); Set_Current_Entity (Lim_Typ); @@ -4969,9 +4998,7 @@ package body Sem_Ch10 is -- limited_with_clause. exit when No (E); - exit when E = Non_Limited_View (Lim_Typ); - Prev := Homonym (Prev); end loop; @@ -5049,7 +5076,7 @@ package body Sem_Ch10 is end if; Set_Entity (Name (N), P); - Set_From_With_Type (P); + Set_From_Limited_With (P); end Install_Limited_Withed_Unit; ------------------------- @@ -5093,7 +5120,7 @@ package body Sem_Ch10 is if Sloc (Uname) /= No_Location and then (not Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)) - or else Current_Sem_Unit = Main_Unit) + or else Current_Sem_Unit = Main_Unit) then Check_Restricted_Unit (Unit_Name (Get_Source_Unit (Uname)), With_Clause); @@ -5165,7 +5192,7 @@ package body Sem_Ch10 is -- tions on the use of package entities. if Ekind (Uname) = E_Package then - Set_From_With_Type (Uname, False); + Set_From_Limited_With (Uname, False); end if; -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child @@ -5189,9 +5216,7 @@ package body Sem_Ch10 is begin U2 := Homonym (Uname); - while Present (U2) - and then U2 /= Standard_Standard - loop + while Present (U2) and then U2 /= Standard_Standard loop P2 := Scope (U2); Decl2 := Unit_Declaration_Node (P2); @@ -5354,328 +5379,262 @@ package body Sem_Ch10 is ------------------------- procedure Build_Limited_Views (N : Node_Id) is + Nam : constant Node_Id := Name (N); Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N)); - P : constant Entity_Id := Cunit_Entity (Unum); - - Spec : Node_Id; -- To denote a package specification - Lim_Typ : Entity_Id; -- To denote shadow entities - Comp_Typ : Entity_Id; -- To denote real entities - - Lim_Header : Entity_Id; -- Package entity - Last_Lim_E : Entity_Id := Empty; -- Last limited entity built - Last_Pub_Lim_E : Entity_Id; -- To set the first private entity - - procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id); - -- Add attributes of an incomplete type to a shadow entity. The same - -- attributes are placed on the real entity, so that gigi receives - -- a consistent view. - - procedure Decorate_Package_Specification (P : Entity_Id); - -- Add attributes of a package entity to the entity in a package - -- declaration - - procedure Decorate_Tagged_Type - (Loc : Source_Ptr; - T : Entity_Id; - Scop : Entity_Id; - Mark : Boolean := False); - -- Set basic attributes of tagged type T, including its class-wide type. - -- The parameters Loc, Scope are used to decorate the class-wide type. - -- Use flag Mark to label the class-wide type as Materialize_Entity. - - procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id); - -- Construct list of shadow entities and attach it to entity of - -- package that is mentioned in a limited_with clause. - - function New_Internal_Shadow_Entity - (Kind : Entity_Kind; - Sloc_Value : Source_Ptr; - Id_Char : Character) return Entity_Id; - -- Build a new internal entity and append it to the list of shadow - -- entities available through the limited-header - - ----------------- - -- Build_Chain -- - ----------------- - - procedure Build_Chain (Scope : Entity_Id; First_Decl : Node_Id) is - Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum)); - Is_Tagged : Boolean; - Decl : Node_Id; + Pack : constant Entity_Id := Cunit_Entity (Unum); + + Shadow_Pack : Entity_Id; + -- The corresponding shadow entity of the withed package. This entity + -- offers incomplete views of all types and visible packages declared + -- within. + + Last_Shadow : Entity_Id := Empty; + -- The last shadow entity created by routine Build_Shadow_Entity + + function Build_Shadow_Entity + (Ent : Entity_Id; + Scop : Entity_Id; + Is_Tagged : Boolean := False) return Entity_Id; + -- Create a shadow entity that hides Ent and offers an incomplete view + -- of Ent. Scop is the proper scope. Flag Is_Tagged should be set when + -- Ent is a tagged type. The generated entity is added to Lim_Header. + -- This routine updates the value of Last_Shadow. + + procedure Decorate_Package (Ent : Entity_Id; Scop : Entity_Id); + -- Perform minimal decoration of a package or its corresponding shadow + -- entity denoted by Ent. Scop is the proper scope. + + procedure Decorate_Type + (Ent : Entity_Id; + Scop : Entity_Id; + Is_Tagged : Boolean := False; + Materialize : Boolean := False); + -- Perform minimal decoration of a type or its corresponding shadow + -- entity denoted by Ent. Scop is the proper scope. Flag Is_Tagged + -- should be set when Ent is a tagged type. Flag Materialize should be + -- set when Ent is a tagged type and its class-wide type needs to appear + -- in the tree. + + procedure Process_Declarations (Decls : List_Id; Scop : Entity_Id); + -- Inspect declarative list Decls and create shadow entities for all + -- types and packages encountered. Scop is the proper scope. + + ------------------------- + -- Build_Shadow_Entity -- + ------------------------- + + function Build_Shadow_Entity + (Ent : Entity_Id; + Scop : Entity_Id; + Is_Tagged : Boolean := False) return Entity_Id + is + Shadow : constant Entity_Id := Make_Temporary (Sloc (Ent), 'Z'); begin - Decl := First_Decl; - while Present (Decl) loop + -- The shadow entity must share the same name and parent as the + -- entity it hides. - -- For each library_package_declaration in the environment, there - -- is an implicit declaration of a *limited view* of that library - -- package. The limited view of a package contains: - - -- * For each nested package_declaration, a declaration of the - -- limited view of that package, with the same defining- - -- program-unit name. - - -- * For each type_declaration in the visible part, an incomplete - -- type-declaration with the same defining_identifier, whose - -- completion is the type_declaration. If the type_declaration - -- is tagged, then the incomplete_type_declaration is tagged - -- incomplete. - - -- The partial view is tagged if the declaration has the - -- explicit keyword, or else if it is a type extension, both - -- of which can be ascertained syntactically. - - if Nkind (Decl) = N_Full_Type_Declaration then - Is_Tagged := - (Nkind (Type_Definition (Decl)) = N_Record_Definition - and then Tagged_Present (Type_Definition (Decl))) - or else - (Nkind (Type_Definition (Decl)) = N_Derived_Type_Definition - and then - Present - (Record_Extension_Part (Type_Definition (Decl)))); + Set_Chars (Shadow, Chars (Ent)); + Set_Parent (Shadow, Parent (Ent)); + Set_Ekind (Shadow, Ekind (Ent)); + Set_Is_Internal (Shadow); + Set_From_Limited_With (Shadow); - Comp_Typ := Defining_Identifier (Decl); + -- Add the new shadow entity to the limited view of the package - if not Analyzed_Unit then - if Is_Tagged then - Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True); - else - Decorate_Incomplete_Type (Comp_Typ, Scope); - end if; - end if; + Last_Shadow := Shadow; + Append_Entity (Shadow, Shadow_Pack); - -- Create shadow entity for type + if Is_Type (Ent) then + Decorate_Type (Shadow, Scop, Is_Tagged); - Lim_Typ := - New_Internal_Shadow_Entity - (Kind => Ekind (Comp_Typ), - Sloc_Value => Sloc (Comp_Typ), - Id_Char => 'Z'); + if Is_Incomplete_Or_Private_Type (Ent) then + Set_Private_Dependents (Shadow, New_Elmt_List); + end if; - Set_Chars (Lim_Typ, Chars (Comp_Typ)); - Set_Parent (Lim_Typ, Parent (Comp_Typ)); - Set_From_With_Type (Lim_Typ); + Set_Non_Limited_View (Shadow, Ent); - if Is_Tagged then - Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); - else - Decorate_Incomplete_Type (Lim_Typ, Scope); - end if; + elsif Ekind (Ent) = E_Package then + Decorate_Package (Shadow, Scop); + end if; - Set_Non_Limited_View (Lim_Typ, Comp_Typ); - Set_Private_Dependents (Lim_Typ, New_Elmt_List); + return Shadow; + end Build_Shadow_Entity; - elsif Nkind_In (Decl, N_Private_Type_Declaration, - N_Incomplete_Type_Declaration, - N_Task_Type_Declaration, - N_Protected_Type_Declaration) - then - Comp_Typ := Defining_Identifier (Decl); + ---------------------- + -- Decorate_Package -- + ---------------------- - Is_Tagged := - Nkind_In (Decl, N_Private_Type_Declaration, - N_Incomplete_Type_Declaration) - and then Tagged_Present (Decl); + procedure Decorate_Package (Ent : Entity_Id; Scop : Entity_Id) is + begin + Set_Ekind (Ent, E_Package); + Set_Etype (Ent, Standard_Void_Type); + Set_Scope (Ent, Scop); + end Decorate_Package; + + ------------------- + -- Decorate_Type -- + ------------------- + + procedure Decorate_Type + (Ent : Entity_Id; + Scop : Entity_Id; + Is_Tagged : Boolean := False; + Materialize : Boolean := False) + is + CW_Typ : Entity_Id; - if not Analyzed_Unit then - if Is_Tagged then - Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True); - else - Decorate_Incomplete_Type (Comp_Typ, Scope); - end if; - end if; + begin + -- An unanalyzed type or a shadow entity of a type is treated as an + -- incomplete type. + + Set_Ekind (Ent, E_Incomplete_Type); + Set_Etype (Ent, Ent); + Set_Scope (Ent, Scop); + Set_Is_First_Subtype (Ent); + Set_Stored_Constraint (Ent, No_Elist); + Set_Full_View (Ent, Empty); + Init_Size_Align (Ent); + + -- A tagged type and its corresponding shadow entity share one common + -- class-wide type. + + if Is_Tagged then + Set_Is_Tagged_Type (Ent); + + if No (Class_Wide_Type (Ent)) then + CW_Typ := + New_External_Entity + (E_Void, Scope (Ent), Sloc (Ent), Ent, 'C', 0, 'T'); + + Set_Class_Wide_Type (Ent, CW_Typ); + + -- Set parent to be the same as the parent of the tagged type. + -- We need a parent field set, and it is supposed to point to + -- the declaration of the type. The tagged type declaration + -- essentially declares two separate types, the tagged type + -- itself and the corresponding class-wide type, so it is + -- reasonable for the parent fields to point to the declaration + -- in both cases. + + Set_Parent (CW_Typ, Parent (Ent)); + + Set_Ekind (CW_Typ, E_Class_Wide_Type); + Set_Etype (CW_Typ, Ent); + Set_Scope (CW_Typ, Scop); + Set_Is_Tagged_Type (CW_Typ); + Set_Is_First_Subtype (CW_Typ); + Init_Size_Align (CW_Typ); + Set_Has_Unknown_Discriminants (CW_Typ); + Set_Class_Wide_Type (CW_Typ, CW_Typ); + Set_Equivalent_Type (CW_Typ, Empty); + Set_From_Limited_With (CW_Typ, From_Limited_With (Ent)); + Set_Materialize_Entity (CW_Typ, Materialize); + end if; + end if; + end Decorate_Type; - Lim_Typ := - New_Internal_Shadow_Entity - (Kind => Ekind (Comp_Typ), - Sloc_Value => Sloc (Comp_Typ), - Id_Char => 'Z'); + -------------------------- + -- Process_Declarations -- + -------------------------- - Set_Chars (Lim_Typ, Chars (Comp_Typ)); - Set_Parent (Lim_Typ, Parent (Comp_Typ)); - Set_From_With_Type (Lim_Typ); + procedure Process_Declarations (Decls : List_Id; Scop : Entity_Id) is + Is_Analyzed : constant Boolean := Analyzed (Cunit (Unum)); + Is_Tagged : Boolean; + Decl : Node_Id; + Def : Node_Id; + Pack : Entity_Id; + Shadow : Entity_Id; + Typ : Entity_Id; - if Is_Tagged then - Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); - else - Decorate_Incomplete_Type (Lim_Typ, Scope); - end if; + begin + -- Inspect the declarative list, looking for type declarations and + -- nested packages. - Set_Non_Limited_View (Lim_Typ, Comp_Typ); + Decl := First (Decls); + while Present (Decl) loop - -- Initialize Private_Depedents, so the field has the proper - -- type, even though the list will remain empty. + -- Types - Set_Private_Dependents (Lim_Typ, New_Elmt_List); + if Nkind_In (Decl, N_Full_Type_Declaration, + N_Incomplete_Type_Declaration, + N_Private_Extension_Declaration, + N_Private_Type_Declaration, + N_Protected_Type_Declaration, + N_Task_Type_Declaration) + then + Typ := Defining_Entity (Decl); - elsif Nkind (Decl) = N_Private_Extension_Declaration then - Comp_Typ := Defining_Identifier (Decl); + -- Determine whether the type is tagged. Note that packages + -- included via a limited with clause are not always analyzed, + -- hence the tree lookup rather than the use of attribute + -- Is_Tagged_Type. - if not Analyzed_Unit then - Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope, True); - end if; + if Nkind (Decl) = N_Full_Type_Declaration then + Def := Type_Definition (Decl); - -- Create shadow entity for type + Is_Tagged := + (Nkind (Def) = N_Record_Definition + and then Tagged_Present (Def)) + or else + (Nkind (Def) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (Def))); - Lim_Typ := - New_Internal_Shadow_Entity - (Kind => Ekind (Comp_Typ), - Sloc_Value => Sloc (Comp_Typ), - Id_Char => 'Z'); + elsif Nkind_In (Decl, N_Incomplete_Type_Declaration, + N_Private_Type_Declaration) + then + Is_Tagged := Tagged_Present (Decl); - Set_Chars (Lim_Typ, Chars (Comp_Typ)); - Set_Parent (Lim_Typ, Parent (Comp_Typ)); - Set_From_With_Type (Lim_Typ); + elsif Nkind (Decl) = N_Private_Extension_Declaration then + Is_Tagged := True; - Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope); - Set_Non_Limited_View (Lim_Typ, Comp_Typ); + else + Is_Tagged := False; + end if; - elsif Nkind (Decl) = N_Package_Declaration then + -- Perform minor decoration when the withed package has not + -- been analyzed. - -- Local package + if not Is_Analyzed then + Decorate_Type (Typ, Scop, Is_Tagged, True); + end if; - declare - Spec : constant Node_Id := Specification (Decl); + -- Create a shadow entity that hides the type and offers an + -- incomplete view of the said type. - begin - Comp_Typ := Defining_Unit_Name (Spec); + Shadow := Build_Shadow_Entity (Typ, Scop, Is_Tagged); - if not Analyzed (Cunit (Unum)) then - Decorate_Package_Specification (Comp_Typ); - Set_Scope (Comp_Typ, Scope); - end if; + -- Packages - Lim_Typ := - New_Internal_Shadow_Entity - (Kind => Ekind (Comp_Typ), - Sloc_Value => Sloc (Comp_Typ), - Id_Char => 'Z'); + elsif Nkind (Decl) = N_Package_Declaration then + Pack := Defining_Entity (Decl); - Decorate_Package_Specification (Lim_Typ); - Set_Scope (Lim_Typ, Scope); + -- Perform minor decoration when the withed package has not + -- been analyzed. - Set_Chars (Lim_Typ, Chars (Comp_Typ)); - Set_Parent (Lim_Typ, Parent (Comp_Typ)); - Set_From_With_Type (Lim_Typ); + if not Is_Analyzed then + Decorate_Package (Pack, Scop); + end if; - -- Note: The non_limited_view attribute is not used - -- for local packages. + -- Create a shadow entity that offers a limited view of all + -- visible types declared within. - Build_Chain - (Scope => Lim_Typ, - First_Decl => First (Visible_Declarations (Spec))); - end; + Shadow := Build_Shadow_Entity (Pack, Scop); + + Process_Declarations + (Decls => Visible_Declarations (Specification (Decl)), + Scop => Shadow); end if; Next (Decl); end loop; - end Build_Chain; - - ------------------------------ - -- Decorate_Incomplete_Type -- - ------------------------------ - - procedure Decorate_Incomplete_Type (E : Entity_Id; Scop : Entity_Id) is - begin - Set_Ekind (E, E_Incomplete_Type); - Set_Scope (E, Scop); - Set_Etype (E, E); - Set_Is_First_Subtype (E, True); - Set_Stored_Constraint (E, No_Elist); - Set_Full_View (E, Empty); - Init_Size_Align (E); - end Decorate_Incomplete_Type; - - -------------------------- - -- Decorate_Tagged_Type -- - -------------------------- - - procedure Decorate_Tagged_Type - (Loc : Source_Ptr; - T : Entity_Id; - Scop : Entity_Id; - Mark : Boolean := False) - is - CW : Entity_Id; - - begin - Decorate_Incomplete_Type (T, Scop); - Set_Is_Tagged_Type (T); - - -- Build corresponding class_wide type, if not previously done - - -- Note: The class-wide entity is shared by the limited-view - -- and the full-view. - - if No (Class_Wide_Type (T)) then - CW := New_External_Entity (E_Void, Scope (T), Loc, T, 'C', 0, 'T'); - - -- Set parent to be the same as the parent of the tagged type. - -- We need a parent field set, and it is supposed to point to - -- the declaration of the type. The tagged type declaration - -- essentially declares two separate types, the tagged type - -- itself and the corresponding class-wide type, so it is - -- reasonable for the parent fields to point to the declaration - -- in both cases. - - Set_Parent (CW, Parent (T)); + end Process_Declarations; - -- Set remaining fields of classwide type + -- Local variables - Set_Ekind (CW, E_Class_Wide_Type); - Set_Etype (CW, T); - Set_Scope (CW, Scop); - Set_Is_Tagged_Type (CW); - Set_Is_First_Subtype (CW, True); - Init_Size_Align (CW); - Set_Has_Unknown_Discriminants (CW, True); - Set_Class_Wide_Type (CW, CW); - Set_Equivalent_Type (CW, Empty); - Set_From_With_Type (CW, From_With_Type (T)); - Set_Materialize_Entity (CW, Mark); - - -- Link type to its class-wide type - - Set_Class_Wide_Type (T, CW); - end if; - end Decorate_Tagged_Type; - - ------------------------------------ - -- Decorate_Package_Specification -- - ------------------------------------ - - procedure Decorate_Package_Specification (P : Entity_Id) is - begin - -- Place only the most basic attributes - - Set_Ekind (P, E_Package); - Set_Etype (P, Standard_Void_Type); - end Decorate_Package_Specification; - - -------------------------------- - -- New_Internal_Shadow_Entity -- - -------------------------------- - - function New_Internal_Shadow_Entity - (Kind : Entity_Kind; - Sloc_Value : Source_Ptr; - Id_Char : Character) return Entity_Id - is - E : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); - - begin - Set_Ekind (E, Kind); - Set_Is_Internal (E, True); - - if Kind in Type_Kind then - Init_Size_Align (E); - end if; - - Append_Entity (E, Lim_Header); - Last_Lim_E := E; - return E; - end New_Internal_Shadow_Entity; + Last_Public_Shadow : Entity_Id := Empty; + Private_Shadow : Entity_Id; + Spec : Node_Id; -- Start of processing for Build_Limited_Views @@ -5691,49 +5650,51 @@ package body Sem_Ch10 is null; when N_Subprogram_Declaration => - Error_Msg_N ("subprograms not allowed in " - & "limited with_clauses", N); + Error_Msg_N ("subprograms not allowed in limited with_clauses", N); return; when N_Generic_Package_Declaration | N_Generic_Subprogram_Declaration => - Error_Msg_N ("generics not allowed in " - & "limited with_clauses", N); + Error_Msg_N ("generics not allowed in limited with_clauses", N); return; when N_Generic_Instantiation => - Error_Msg_N ("generic instantiations not allowed in " - & "limited with_clauses", N); + Error_Msg_N + ("generic instantiations not allowed in limited with_clauses", + N); return; when N_Generic_Renaming_Declaration => - Error_Msg_N ("generic renamings not allowed in " - & "limited with_clauses", N); + Error_Msg_N + ("generic renamings not allowed in limited with_clauses", N); return; when N_Subprogram_Renaming_Declaration => - Error_Msg_N ("renamed subprograms not allowed in " - & "limited with_clauses", N); + Error_Msg_N + ("renamed subprograms not allowed in limited with_clauses", N); return; when N_Package_Renaming_Declaration => - Error_Msg_N ("renamed packages not allowed in " - & "limited with_clauses", N); + Error_Msg_N + ("renamed packages not allowed in limited with_clauses", N); return; when others => raise Program_Error; end case; - -- The limited unit is not analyzed but the with clause must be - -- minimally decorated so that checks on unused with clause also work - -- with limited with clauses. + -- The withed unit may not be analyzed, but the with calause itself + -- must be minimally decorated. This ensures that the checks on unused + -- with clauses also process limieted withs. + + Set_Ekind (Pack, E_Package); + Set_Etype (Pack, Standard_Void_Type); - if Is_Entity_Name (Name (N)) then - Set_Entity (Name (N), P); + if Is_Entity_Name (Nam) then + Set_Entity (Nam, Pack); - elsif Nkind (Name (N)) = N_Selected_Component then - Set_Entity (Selector_Name (Name (N)), P); + elsif Nkind (Nam) = N_Selected_Component then + Set_Entity (Selector_Name (Nam), Pack); end if; -- Check if the chain is already built @@ -5744,41 +5705,37 @@ package body Sem_Ch10 is return; end if; - Set_Ekind (P, E_Package); + -- Create the shadow package wich hides the withed unit and provides + -- incomplete view of all types and packages declared within. - -- Build the header of the limited_view + Shadow_Pack := Make_Temporary (Sloc (N), 'Z'); + Set_Ekind (Shadow_Pack, E_Package); + Set_Is_Internal (Shadow_Pack); + Set_Limited_View (Pack, Shadow_Pack); - Lim_Header := Make_Temporary (Sloc (N), 'Z'); - Set_Ekind (Lim_Header, E_Package); - Set_Is_Internal (Lim_Header); - Set_Limited_View (P, Lim_Header); + -- Inspect the visible declarations of the withed unit and create shadow + -- entities that hide existing types and packages. - -- Create the auxiliary chain. All the shadow entities are appended to - -- the list of entities of the limited-view header + Process_Declarations + (Decls => Visible_Declarations (Spec), + Scop => Pack); - Build_Chain - (Scope => P, - First_Decl => First (Visible_Declarations (Spec))); + Last_Public_Shadow := Last_Shadow; - -- Save the last built shadow entity. It is needed later to set the - -- reference to the first shadow entity in the private part + -- Ada 2005 (AI-262): Build the limited view of the private declarations + -- to accomodate limited private with clauses. - Last_Pub_Lim_E := Last_Lim_E; + Process_Declarations + (Decls => Private_Declarations (Spec), + Scop => Pack); - -- Ada 2005 (AI-262): Add the limited view of the private declarations - -- Required to give support to limited-private-with clauses - - Build_Chain (Scope => P, - First_Decl => First (Private_Declarations (Spec))); - - if Last_Pub_Lim_E /= Empty then - Set_First_Private_Entity - (Lim_Header, Next_Entity (Last_Pub_Lim_E)); + if Present (Last_Public_Shadow) then + Private_Shadow := Next_Entity (Last_Public_Shadow); else - Set_First_Private_Entity - (Lim_Header, First_Entity (P)); + Private_Shadow := First_Entity (Shadow_Pack); end if; + Set_First_Private_Entity (Shadow_Pack, Private_Shadow); Set_Limited_View_Installed (Spec); end Build_Limited_Views; @@ -5801,9 +5758,7 @@ package body Sem_Ch10 is Ent : Entity_Id; begin - if Is_Subprogram (E) - and then Has_Pragma_Inline (E) - then + if Is_Subprogram (E) and then Has_Pragma_Inline (E) then return True; elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then @@ -6095,7 +6050,7 @@ package body Sem_Ch10 is -- Indicate that the limited view of the package is not installed - Set_From_With_Type (P, False); + Set_From_Limited_With (P, False); Set_Limited_View_Installed (N, False); end Remove_Limited_With_Clause; @@ -6190,9 +6145,8 @@ package body Sem_Ch10 is begin Item := First (Context_Items (Comp_Unit)); while Present (Item) loop - if Nkind (Item) = N_With_Clause - and then Private_Present (Item) - then + if Nkind (Item) = N_With_Clause and then Private_Present (Item) then + -- If private_with_clause is redundant, remove it from context, -- as a small optimization to subsequent handling of private_with -- clauses in other nested packages. @@ -6275,9 +6229,7 @@ package body Sem_Ch10 is Set_Name_Entity_Id (Chars (E), Homonym (E)); else - while Present (Prev) - and then Homonym (Prev) /= E - loop + while Present (Prev) and then Homonym (Prev) /= E loop Prev := Homonym (Prev); end loop; diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 180ecc6ca0b..a397edfb40e 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -199,6 +199,7 @@ package body Sem_Ch11 is if Comes_From_Source (Choice) then Check_Restriction (No_Exception_Propagation, Choice); + Set_Debug_Info_Needed (Choice); end if; if No (H_Scope) then @@ -489,7 +490,10 @@ package body Sem_Ch11 is Par : Node_Id; begin - Check_SPARK_Restriction ("raise statement is not allowed", N); + if Comes_From_Source (N) then + Check_SPARK_Restriction ("raise statement is not allowed", N); + end if; + Check_Unreachable_Code (N); -- Check exception restrictions on the original source @@ -687,7 +691,9 @@ package body Sem_Ch11 is -- Start of processing for Analyze_Raise_xxx_Error begin - Check_SPARK_Restriction ("raise statement is not allowed", N); + if Nkind (Original_Node (N)) = N_Raise_Statement then + Check_SPARK_Restriction ("raise statement is not allowed", N); + end if; if No (Etype (N)) then Set_Etype (N, Standard_Void_Type); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 035d0b0bfda..1572e4ff6dc 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3022,6 +3022,15 @@ package body Sem_Ch12 is Id := Defining_Entity (N); Generate_Definition (Id); + -- Expansion is not applied to generic units + + Start_Generic; + + Enter_Name (Id); + Set_Ekind (Id, E_Generic_Package); + Set_Etype (Id, Standard_Void_Type); + Set_Contract (Id, Make_Contract (Sloc (Id))); + -- Analyze aspects now, so that generated pragmas appear in the -- declarations before building and analyzing the generic copy. @@ -3029,13 +3038,6 @@ package body Sem_Ch12 is Analyze_Aspect_Specifications (N, Id); end if; - -- Expansion is not applied to generic units - - Start_Generic; - - Enter_Name (Id); - Set_Ekind (Id, E_Generic_Package); - Set_Etype (Id, Standard_Void_Type); Push_Scope (Id); Enter_Generic_Scope (Id); Set_Inner_Instances (Id, New_Elmt_List); @@ -3124,7 +3126,7 @@ package body Sem_Ch12 is Aspects : constant List_Id := Aspect_Specifications (N); begin Set_Has_Aspects (N, False); - Move_Aspects (New_N, N); + Move_Aspects (New_N, To => N); Set_Has_Aspects (Original_Node (N), False); Set_Aspect_Specifications (Original_Node (N), Aspects); end; @@ -3475,12 +3477,12 @@ package body Sem_Ch12 is -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause - if From_With_Type (Gen_Unit) then + if From_Limited_With (Gen_Unit) then Error_Msg_N ("cannot instantiate a limited withed package", Gen_Id); else - Error_Msg_N - ("expect name of generic package in instantiation", Gen_Id); + Error_Msg_NE + ("& is not the name of a generic package", Gen_Id, Gen_Unit); end if; Restore_Env; @@ -3717,8 +3719,7 @@ package body Sem_Ch12 is (Unit_Requires_Body (Gen_Unit) or else Enclosing_Body_Present or else Present (Corresponding_Body (Gen_Decl))) - and then (Is_In_Main_Unit (N) - or else Might_Inline_Subp) + and then (Is_In_Main_Unit (N) or else Might_Inline_Subp) and then not Is_Actual_Pack and then not Inline_Now and then (Operating_Mode = Generate_Code @@ -3728,8 +3729,7 @@ package body Sem_Ch12 is -- If front_end_inlining is enabled, do not instantiate body if -- within a generic context. - if (Front_End_Inlining - and then not Expander_Active) + if (Front_End_Inlining and then not Expander_Active) or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) then Needs_Body := False; @@ -4669,34 +4669,17 @@ package body Sem_Ch12 is -- Verify that it is a generic subprogram of the right kind, and that -- it does not lead to a circular instantiation. - if not Ekind_In (Gen_Unit, E_Generic_Procedure, E_Generic_Function) then - Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id); + if K = E_Procedure and then Ekind (Gen_Unit) /= E_Generic_Procedure then + Error_Msg_NE + ("& is not the name of a generic procedure", Gen_Id, Gen_Unit); + + elsif K = E_Function and then Ekind (Gen_Unit) /= E_Generic_Function then + Error_Msg_NE + ("& is not the name of a generic function", Gen_Id, Gen_Unit); elsif In_Open_Scopes (Gen_Unit) then Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); - elsif K = E_Procedure - and then Ekind (Gen_Unit) /= E_Generic_Procedure - then - if Ekind (Gen_Unit) = E_Generic_Function then - Error_Msg_N - ("cannot instantiate generic function as procedure", Gen_Id); - else - Error_Msg_N - ("expect name of generic procedure in instantiation", Gen_Id); - end if; - - elsif K = E_Function - and then Ekind (Gen_Unit) /= E_Generic_Function - then - if Ekind (Gen_Unit) = E_Generic_Procedure then - Error_Msg_N - ("cannot instantiate generic procedure as function", Gen_Id); - else - Error_Msg_N - ("expect name of generic function in instantiation", Gen_Id); - end if; - else Set_Entity (Gen_Id, Gen_Unit); Set_Is_Instantiated (Gen_Unit); @@ -4775,7 +4758,7 @@ package body Sem_Ch12 is -- pre/postconditions on the instance are analyzed below, in a -- separate step. - Move_Aspects (Act_Tree, Act_Decl); + Move_Aspects (Act_Tree, To => Act_Decl); Set_Categorization_From_Pragmas (Act_Decl); if Parent_Installed then @@ -5681,8 +5664,7 @@ package body Sem_Ch12 is (Related_Instance (Instance)))); else Gen_Id := - Generic_Parent - (Specification (Unit_Declaration_Node (Instance))); + Generic_Parent (Package_Specification (Instance)); end if; Parent_Scope := Scope (Gen_Id); @@ -8382,7 +8364,7 @@ package body Sem_Ch12 is -- of its generic parent. if Is_Generic_Instance (Par) then - Gen := Generic_Parent (Specification (Unit_Declaration_Node (Par))); + Gen := Generic_Parent (Package_Specification (Par)); Gen_E := First_Entity (Gen); end if; @@ -8466,8 +8448,7 @@ package body Sem_Ch12 is ------------------ procedure Install_Spec (Par : Entity_Id) is - Spec : constant Node_Id := - Specification (Unit_Declaration_Node (Par)); + Spec : constant Node_Id := Package_Specification (Par); begin -- If this parent of the child instance is a top-level unit, @@ -8536,8 +8517,7 @@ package body Sem_Ch12 is First_Par := Inst_Par; - Gen_Par := - Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par))); + Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); First_Gen := Gen_Par; @@ -8555,9 +8535,7 @@ package body Sem_Ch12 is Inst_Par := Renamed_Entity (Inst_Par); end if; - Gen_Par := - Generic_Parent - (Specification (Unit_Declaration_Node (Inst_Par))); + Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); if Present (Gen_Par) then Prepend_Elmt (Inst_Par, Ancestors); @@ -9026,7 +9004,7 @@ package body Sem_Ch12 is end if; if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then - Parent_Spec := Specification (Unit_Declaration_Node (Actual_Pack)); + Parent_Spec := Package_Specification (Actual_Pack); else Parent_Spec := Parent (Actual_Pack); end if; @@ -10551,23 +10529,13 @@ package body Sem_Ch12 is -- only mode conformance was required. -- This is a binding interpretation that applies to previous versions - -- of the language, but for now we retain the milder check in order - -- to preserve ACATS tests. These will be protested eventually ??? - - if Ada_Version < Ada_2012 then - Check_Mode_Conformant - (Designated_Type (Act_T), - Designated_Type (A_Gen_T), - Actual, - Get_Inst => True); + -- of the language, no need to maintain previous weaker checks. - else - Check_Subtype_Conformant - (Designated_Type (Act_T), - Designated_Type (A_Gen_T), - Actual, - Get_Inst => True); - end if; + Check_Subtype_Conformant + (Designated_Type (Act_T), + Designated_Type (A_Gen_T), + Actual, + Get_Inst => True); if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then if Ekind (A_Gen_T) = E_Access_Subprogram_Type then @@ -10632,7 +10600,7 @@ package body Sem_Ch12 is -- with clause, in which case retrieve the non-limited view. This -- applies to incomplete types as well as to class-wide types. - if From_With_Type (Desig_Act) then + if From_Limited_With (Desig_Act) then Desig_Act := Available_View (Desig_Act); end if; @@ -12588,8 +12556,7 @@ package body Sem_Ch12 is elsif S = Current_Scope and then Is_Generic_Instance (S) then declare Par : constant Entity_Id := - Generic_Parent - (Specification (Unit_Declaration_Node (S))); + Generic_Parent (Package_Specification (S)); begin if Present (Par) and then P = Scope (Par) diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 37b9e9a82b9..15862442175 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -44,6 +44,7 @@ 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_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; @@ -111,6 +112,13 @@ package body Sem_Ch13 is -- list is stored in Static_Predicate (Typ), and the Expr is rewritten as -- a canonicalized membership operation. + procedure Freeze_Entity_Checks (N : Node_Id); + -- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity + -- 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. + function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding -- Uint value. If the value is inappropriate, then error messages are @@ -762,17 +770,9 @@ package body Sem_Ch13 is Set_Has_Default_Aspect (Base_Type (Ent)); if Is_Scalar_Type (Ent) then - Set_Default_Aspect_Value (Ent, Expr); - - -- Place default value of base type as well, because that is - -- the semantics of the aspect. It is convenient to link the - -- aspect to both the (possibly anonymous) base type and to - -- the given first subtype. - Set_Default_Aspect_Value (Base_Type (Ent), Expr); - else - Set_Default_Aspect_Component_Value (Ent, Expr); + Set_Default_Aspect_Component_Value (Base_Type (Ent), Expr); end if; end Analyze_Aspect_Default_Value; @@ -888,7 +888,7 @@ package body Sem_Ch13 is when Aspect_Scalar_Storage_Order => if (Is_Record_Type (E) or else Is_Array_Type (E)) and then No (Get_Attribute_Definition_Clause - (E, Attribute_Scalar_Storage_Order)) + (E, Attribute_Scalar_Storage_Order)) and then Reverse_Storage_Order (P) then Set_Reverse_Storage_Order (Base_Type (E)); @@ -1189,10 +1189,29 @@ package body Sem_Ch13 is elsif Nkind (N) = N_Subprogram_Body then if No (Declarations (N)) then - Set_Declarations (N, New_List); - end if; + Set_Declarations (N, New_List (Prag)); + else + declare + D : Node_Id; + begin - Append (Prag, Declarations (N)); + -- There may be several aspects associated with the body; + -- preserve the ordering of the corresponding pragmas. + + D := First (Declarations (N)); + while Present (D) loop + exit when Nkind (D) /= N_Pragma + or else not From_Aspect_Specification (D); + Next (D); + end loop; + + if No (D) then + Append (Prag, Declarations (N)); + else + Insert_Before (D, Prag); + end if; + end; + end if; -- Default @@ -1364,9 +1383,8 @@ package body Sem_Ch13 is pragma Assert (not Is_Disabled (Aspect)); - -- Certan aspects allow for an optional name or expression. Do - -- not generate a pragma with an empty argument association - -- list. + -- Certain aspects allow for an optional name or expression. Do + -- not generate a pragma with empty argument association list. if No (Args) or else No (Expression (First (Args))) then Args := No_List; @@ -1403,9 +1421,9 @@ package body Sem_Ch13 is goto Continue; end if; - -- Skip looking at aspect if it is totally disabled. Just mark - -- it as such for later reference in the tree. This also sets - -- the Is_Ignored and Is_Checked flags appropriately. + -- Skip looking at aspect if it is totally disabled. Just mark it + -- as such for later reference in the tree. This also sets the + -- Is_Ignored and Is_Checked flags appropriately. Check_Applicable_Policy (Aspect); @@ -1574,6 +1592,18 @@ package body Sem_Ch13 is goto Continue; end if; + -- For case of address aspect, we don't consider that we + -- know the entity is never set in the source, since it is + -- is likely aliasing is occurring. + + -- Note: one might think that the analysis of the resulting + -- attribute definition clause would take care of that, but + -- that's not the case since it won't be from source. + + if A_Id = Aspect_Address then + Set_Never_Set_In_Source (E, False); + end if; + -- Construct the attribute definition clause Aitem := @@ -1764,22 +1794,126 @@ package body Sem_Ch13 is -- CPU, Interrupt_Priority, Priority - -- These three aspects can be specified for a subprogram body, - -- in which case we generate pragmas for them and insert them - -- ahead of local declarations, rather than after the body. + -- These three aspects can be specified for a subprogram spec + -- or body, in which case we analyze the expression and export + -- the value of the aspect. + + -- Previously, we generated an equivalent pragma for bodies + -- (note that the specs cannot contain these pragmas). The + -- pragma was inserted ahead of local declarations, rather than + -- after the body. This leads to a certain duplication between + -- the processing performed for the aspect and the pragma, but + -- given the straightforward handling required it is simpler + -- to duplicate than to translate the aspect in the spec into + -- a pragma in the declarative part of the body. when Aspect_CPU | Aspect_Interrupt_Priority | Aspect_Priority => - if Nkind (N) = N_Subprogram_Body then - Make_Aitem_Pragma - (Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr))), - Pragma_Name => Chars (Id)); + if Nkind_In (N, N_Subprogram_Body, + N_Subprogram_Declaration) + then + -- Analyze the aspect expression + + 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 + -- Interrupt_Priority for subprograms. + + if A_Id = Aspect_Interrupt_Priority then + Error_Msg_N + ("Interrupt_Priority aspect cannot apply to " + & "subprogram", Expr); + + -- The expression must be static + + elsif not Is_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("aspect requires static expression!", Expr); + + -- Check whether this is the main subprogram. Issue a + -- warning only if it is obviously not a main program + -- (when it has parameters or when the subprogram is + -- within a package). + + elsif Present (Parameter_Specifications + (Specification (N))) + or else not Is_Compilation_Unit (Defining_Entity (N)) + then + -- See ARM D.1 (14/3) and D.16 (12/3) + + Error_Msg_N + ("aspect applied to subprogram other than the " + & "main subprogram has no effect??", Expr); + + -- Otherwise check in range and export the value + + -- For the CPU aspect + + elsif A_Id = Aspect_CPU then + if Is_In_Range (Expr, RTE (RE_CPU_Range)) then + + -- Value is correct so we export the value to make + -- it available at execution time. + + Set_Main_CPU + (Main_Unit, UI_To_Int (Expr_Value (Expr))); + + else + Error_Msg_N + ("main subprogram CPU is out of range", Expr); + end if; + + -- For the Priority aspect + + elsif A_Id = Aspect_Priority then + if Is_In_Range (Expr, RTE (RE_Priority)) then + + -- Value is correct so we export the value to make + -- it available at execution time. + + Set_Main_Priority + (Main_Unit, UI_To_Int (Expr_Value (Expr))); + + else + Error_Msg_N + ("main subprogram priority is out of range", + Expr); + end if; + end if; + + -- Load an arbitrary entity from System.Tasking.Stages + -- or System.Tasking.Restricted.Stages (depending on + -- the supported profile) to make sure that one of these + -- packages is implicitly with'ed, since we need to have + -- the tasking run time active for the pragma Priority to + -- have any effect. Previously with with'ed the package + -- System.Tasking, but this package does not trigger the + -- required initialization of the run-time library. + + declare + Discard : Entity_Id; + pragma Warnings (Off, Discard); + begin + if Restricted_Profile then + Discard := RTE (RE_Activate_Restricted_Tasks); + else + Discard := RTE (RE_Activate_Tasks); + end if; + end; + + -- Handling for these Aspects in subprograms is complete + + goto Continue; + + -- For tasks else + -- Pass the aspect as an attribute + Aitem := Make_Attribute_Definition_Clause (Loc, Name => Ent, @@ -1845,12 +1979,43 @@ package body Sem_Ch13 is -- Abstract_State - when Aspect_Abstract_State => - Make_Aitem_Pragma - (Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Relocate_Node (Expr))), - Pragma_Name => Name_Abstract_State); + -- Aspect Abstract_State introduces implicit declarations for + -- all state abstraction entities it defines. To emulate this + -- behavior, insert the pragma at the beginning of the visible + -- declarations of the related package so that it is analyzed + -- immediately. + + when Aspect_Abstract_State => Abstract_State : declare + Decls : List_Id; + + begin + if Nkind_In (N, N_Generic_Package_Declaration, + N_Package_Declaration) + then + Decls := Visible_Declarations (Specification (N)); + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Abstract_State); + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (N, Decls); + end if; + + Prepend_To (Decls, Aitem); + + else + Error_Msg_NE + ("aspect & must apply to a package declaration", + Aspect, Id); + end if; + + goto Continue; + end Abstract_State; -- Depends @@ -1888,6 +2053,83 @@ package body Sem_Ch13 is Insert_Delayed_Pragma (Aitem); goto Continue; + -- Initial_Condition + + -- Aspect Initial_Condition covers the visible declarations of + -- a package and all hidden states through functions. As such, + -- it must be evaluated at the end of the said declarations. + + when Aspect_Initial_Condition => Initial_Condition : declare + Decls : List_Id; + + begin + if Nkind_In (N, N_Generic_Package_Declaration, + N_Package_Declaration) + then + Decls := Visible_Declarations (Specification (N)); + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => + Name_Initial_Condition); + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (N, Decls); + end if; + + Prepend_To (Decls, Aitem); + + else + Error_Msg_NE + ("aspect & must apply to a package declaration", + Aspect, Id); + end if; + + goto Continue; + end Initial_Condition; + + -- Initializes + + -- Aspect Initializes coverts the visible declarations of a + -- package. As such, it must be evaluated at the end of the + -- said declarations. + + when Aspect_Initializes => Initializes : declare + Decls : List_Id; + + begin + if Nkind_In (N, N_Generic_Package_Declaration, + N_Package_Declaration) + then + Decls := Visible_Declarations (Specification (N)); + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Initializes); + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (N, Decls); + end if; + + Prepend_To (Decls, Aitem); + + else + Error_Msg_NE + ("aspect & must apply to a package declaration", + Aspect, Id); + end if; + + goto Continue; + end Initializes; + -- SPARK_Mode when Aspect_SPARK_Mode => @@ -1897,6 +2139,87 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_SPARK_Mode); + -- Refined_Depends + + -- Aspect Refined_Depends must be delayed because it can + -- mention state refinements introduced by aspect Refined_State + -- and further classified by aspect Refined_Global. Since both + -- those aspects are delayed, so is Refined_Depends. + + when Aspect_Refined_Depends => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Refined_Depends); + + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + Insert_Delayed_Pragma (Aitem); + goto Continue; + + -- Refined_Global + + -- Aspect Refined_Global must be delayed because it can mention + -- state refinements introduced by aspect Refined_State. Since + -- Refined_State is already delayed due to forward references, + -- so is Refined_Global. + + when Aspect_Refined_Global => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Refined_Global); + + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + Insert_Delayed_Pragma (Aitem); + goto Continue; + + -- Refined_Post + + when Aspect_Refined_Post => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Refined_Post); + + -- Refined_State + + when Aspect_Refined_State => Refined_State : declare + Decls : List_Id; + + 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_Delayed_Aspect_And_Pragma (Aspect, Aitem); + + if No (Decls) then + Decls := New_List; + Set_Declarations (N, Decls); + end if; + + Prepend_To (Decls, Aitem); + + else + Error_Msg_NE + ("aspect & must apply to a package body", Aspect, Id); + end if; + + goto Continue; + end Refined_State; + -- Relative_Deadline when Aspect_Relative_Deadline => @@ -2208,7 +2531,31 @@ package body Sem_Ch13 is Next (A); end loop; + -- It is legal to specify Import for a variable, in + -- order to suppress initialization for it, without + -- specifying explicitly its convention. However this + -- is only legal if the convention of the object type + -- is Ada or similar. + if No (A) then + if Ekind (E) = E_Variable + and then A_Id = Aspect_Import + then + declare + C : constant Convention_Id := + Convention (Etype (E)); + begin + if C = Convention_Ada or else + C = Convention_Ada_Pass_By_Copy or else + C = Convention_Ada_Pass_By_Reference + then + goto Continue; + end if; + end; + end if; + + -- Otherwise, Convention must be specified + Error_Msg_N ("missing Convention aspect for Export/Import", Aspect); @@ -2317,21 +2664,6 @@ package body Sem_Ch13 is Set_From_Aspect_Specification (Aitem, True); end if; - -- Aspect Abstract_State introduces implicit declarations for all - -- state abstraction entities it defines. To emulate this behavior - -- insert the pragma at the start of the visible declarations of - -- the related package. - - if Nam = Name_Abstract_State - and then Nkind (N) = N_Package_Declaration - then - if No (Visible_Declarations (Specification (N))) then - Set_Visible_Declarations (Specification (N), New_List); - end if; - - Prepend (Aitem, Visible_Declarations (Specification (N))); - goto Continue; - -- In the context of a compilation unit, we directly put the -- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux -- node (no delay is required here) except for aspects on a @@ -2340,7 +2672,7 @@ package body Sem_Ch13 is -- copy (see sem_ch12), and for package instantiations, where -- the library unit pragmas are better handled early. - elsif Nkind (Parent (N)) = N_Compilation_Unit + if Nkind (Parent (N)) = N_Compilation_Unit and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect)) then declare @@ -2368,9 +2700,8 @@ package body Sem_Ch13 is end if; end if; - -- If the aspect is on a subprogram body (relevant aspects - -- are Inline and Priority), add the pragma in front of - -- the declarations. + -- If the aspect is on a subprogram body (relevant aspect + -- is Inline), add the pragma in front of the declarations. if Nkind (N) = N_Subprogram_Body then if No (Declarations (N)) then @@ -3430,16 +3761,21 @@ package body Sem_Ch13 is -- then we make an entry in the table for checking the size -- and alignment of the overlaying variable. We defer this -- check till after code generation to take full advantage - -- of the annotation done by the back end. This entry is - -- only made if the address clause comes from source. + -- of the annotation done by the back end. -- If the entity has a generic type, the check will be -- performed in the instance if the actual type justifies -- it, and we do not insert the clause in the table to -- prevent spurious warnings. + -- Note: we used to test Comes_From_Source and only give + -- this warning for source entities, but we have removed + -- this test. It really seems bogus to generate overlays + -- that would trigger this warning in generated code. + -- Furthermore, by removing the test, we handle the + -- aspect case properly. + if Address_Clause_Overlay_Warnings - and then Comes_From_Source (N) and then Present (O_Ent) and then Is_Object (O_Ent) then @@ -4321,7 +4657,17 @@ package body Sem_Ch13 is Name => Expr); begin - Insert_Before (N, Rnode); + -- If the attribute definition clause comes from an aspect + -- clause, then insert the renaming before the associated + -- entity's declaration, since the attribute clause has + -- not yet been appended to the declaration list. + + if From_Aspect_Specification (N) then + Insert_Before (Parent (Entity (N)), Rnode); + else + Insert_Before (N, Rnode); + end if; + Analyze (Rnode); Set_Associated_Storage_Pool (U_Ent, Pool); end; @@ -4970,189 +5316,18 @@ package body Sem_Ch13 is --------------------------- procedure Analyze_Freeze_Entity (N : Node_Id) is - E : constant Entity_Id := Entity (N); - begin - -- Remember that we are processing a freezing entity. Required to - -- ensure correct decoration of internal entities associated with - -- interfaces (see New_Overloaded_Entity). - - Inside_Freezing_Actions := Inside_Freezing_Actions + 1; - - -- For tagged types covering interfaces add internal entities that link - -- the primitives of the interfaces with the primitives that cover them. - -- Note: These entities were originally generated only when generating - -- code because their main purpose was to provide support to initialize - -- the secondary dispatch tables. They are now generated also when - -- compiling with no code generation to provide ASIS the relationship - -- between interface primitives and tagged type primitives. They are - -- also used to locate primitives covering interfaces when processing - -- generics (see Derive_Subprograms). - - if Ada_Version >= Ada_2005 - and then Ekind (E) = E_Record_Type - and then Is_Tagged_Type (E) - and then not Is_Interface (E) - and then Has_Interfaces (E) - then - -- This would be a good common place to call the routine that checks - -- overriding of interface primitives (and thus factorize calls to - -- Check_Abstract_Overriding located at different contexts in the - -- compiler). However, this is not possible because it causes - -- spurious errors in case of late overriding. - - Add_Internal_Interface_Entities (E); - end if; - - -- Check CPP types - - if Ekind (E) = E_Record_Type - and then Is_CPP_Class (E) - and then Is_Tagged_Type (E) - and then Tagged_Type_Expansion - and then Expander_Active - then - if CPP_Num_Prims (E) = 0 then - - -- If the CPP type has user defined components then it must import - -- primitives from C++. This is required because if the C++ class - -- has no primitives then the C++ compiler does not added the _tag - -- component to the type. - - pragma Assert (Chars (First_Entity (E)) = Name_uTag); - - if First_Entity (E) /= Last_Entity (E) then - Error_Msg_N - ("'C'P'P type must import at least one primitive from C++??", - E); - end if; - end if; - - -- Check that all its primitives are abstract or imported from C++. - -- Check also availability of the C++ constructor. - - declare - Has_Constructors : constant Boolean := Has_CPP_Constructors (E); - Elmt : Elmt_Id; - Error_Reported : Boolean := False; - Prim : Node_Id; - - begin - Elmt := First_Elmt (Primitive_Operations (E)); - while Present (Elmt) loop - Prim := Node (Elmt); - - if Comes_From_Source (Prim) then - if Is_Abstract_Subprogram (Prim) then - null; - - elsif not Is_Imported (Prim) - or else Convention (Prim) /= Convention_CPP - then - Error_Msg_N - ("primitives of 'C'P'P types must be imported from C++ " - & "or abstract??", Prim); - - elsif not Has_Constructors - and then not Error_Reported - then - Error_Msg_Name_1 := Chars (E); - Error_Msg_N - ("??'C'P'P constructor required for type %", Prim); - Error_Reported := True; - end if; - end if; - - Next_Elmt (Elmt); - end loop; - end; - end if; - - -- Check Ada derivation of CPP type - - if Expander_Active - and then Tagged_Type_Expansion - and then Ekind (E) = E_Record_Type - and then Etype (E) /= E - and then Is_CPP_Class (Etype (E)) - and then CPP_Num_Prims (Etype (E)) > 0 - and then not Is_CPP_Class (E) - and then not Has_CPP_Constructors (Etype (E)) - then - -- If the parent has C++ primitives but it has no constructor then - -- check that all the primitives are overridden in this derivation; - -- otherwise the constructor of the parent is needed to build the - -- dispatch table. - - declare - Elmt : Elmt_Id; - Prim : Node_Id; - - begin - Elmt := First_Elmt (Primitive_Operations (E)); - while Present (Elmt) loop - Prim := Node (Elmt); - - if not Is_Abstract_Subprogram (Prim) - and then No (Interface_Alias (Prim)) - and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E - then - Error_Msg_Name_1 := Chars (Etype (E)); - Error_Msg_N - ("'C'P'P constructor required for parent type %", E); - exit; - end if; - - Next_Elmt (Elmt); - end loop; - end; - end if; - - Inside_Freezing_Actions := Inside_Freezing_Actions - 1; - - -- If we have a type with predicates, build predicate function - - if Is_Type (E) and then Has_Predicates (E) then - Build_Predicate_Functions (E, N); - end if; - - -- If type has delayed aspects, this is where we do the preanalysis at - -- the freeze point, as part of the consistent visibility check. Note - -- that this must be done after calling Build_Predicate_Functions or - -- Build_Invariant_Procedure since these subprograms fix occurrences of - -- the subtype name in the saved expression so that they will not cause - -- trouble in the preanalysis. - - if Has_Delayed_Aspects (E) - and then Scope (E) = Current_Scope - then - -- Retrieve the visibility to the discriminants in order to properly - -- analyze the aspects. - - Push_Scope_And_Install_Discriminants (E); - - declare - Ritem : Node_Id; - - begin - -- Look for aspect specification entries for this entity - - Ritem := First_Rep_Item (E); - while Present (Ritem) loop - if Nkind (Ritem) = N_Aspect_Specification - and then Entity (Ritem) = E - and then Is_Delayed_Aspect (Ritem) - then - Check_Aspect_At_Freeze_Point (Ritem); - end if; + Freeze_Entity_Checks (N); + end Analyze_Freeze_Entity; - Next_Rep_Item (Ritem); - end loop; - end; + ----------------------------------- + -- Analyze_Freeze_Generic_Entity -- + ----------------------------------- - Uninstall_Discriminants_And_Pop_Scope (E); - end if; - end Analyze_Freeze_Entity; + procedure Analyze_Freeze_Generic_Entity (N : Node_Id) is + begin + Freeze_Entity_Checks (N); + end Analyze_Freeze_Generic_Entity; ------------------------------------------ -- Analyze_Record_Representation_Clause -- @@ -5922,7 +6097,6 @@ package body Sem_Ch13 is if Present (SId) then PDecl := Unit_Declaration_Node (SId); - else PDecl := Build_Invariant_Procedure_Declaration (Typ); end if; @@ -7096,6 +7270,16 @@ package body Sem_Ch13 is when N_Qualified_Expression => return Get_RList (Expression (Exp)); + -- Expression with actions: if no actions, dig out expression + + when N_Expression_With_Actions => + if Is_Empty_List (Actions (Exp)) then + return Get_RList (Expression (Exp)); + + else + raise Non_Static; + end if; + -- Xor operator when N_Op_Xor => @@ -7705,12 +7889,18 @@ package body Sem_Ch13 is Aspect_Dimension | Aspect_Dimension_System | Aspect_Implicit_Dereference | + Aspect_Initial_Condition | + Aspect_Initializes | 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_Test_Case => raise Program_Error; end case; @@ -8922,6 +9112,369 @@ package body Sem_Ch13 is end if; end Check_Size; + -------------------------- + -- Freeze_Entity_Checks -- + -------------------------- + + procedure Freeze_Entity_Checks (N : Node_Id) is + E : constant Entity_Id := Entity (N); + + Non_Generic_Case : constant Boolean := Nkind (N) = N_Freeze_Entity; + -- True in non-generic case. Some of the processing here is skipped + -- for the generic case since it is not needed. Basically in the + -- generic case, we only need to do stuff that might generate error + -- messages or warnings. + begin + -- Remember that we are processing a freezing entity. Required to + -- ensure correct decoration of internal entities associated with + -- interfaces (see New_Overloaded_Entity). + + Inside_Freezing_Actions := Inside_Freezing_Actions + 1; + + -- For tagged types covering interfaces add internal entities that link + -- the primitives of the interfaces with the primitives that cover them. + -- Note: These entities were originally generated only when generating + -- code because their main purpose was to provide support to initialize + -- the secondary dispatch tables. They are now generated also when + -- compiling with no code generation to provide ASIS the relationship + -- between interface primitives and tagged type primitives. They are + -- also used to locate primitives covering interfaces when processing + -- generics (see Derive_Subprograms). + + -- This is not needed in the generic case + + if Ada_Version >= Ada_2005 + and then Non_Generic_Case + and then Ekind (E) = E_Record_Type + and then Is_Tagged_Type (E) + and then not Is_Interface (E) + and then Has_Interfaces (E) + then + -- This would be a good common place to call the routine that checks + -- overriding of interface primitives (and thus factorize calls to + -- Check_Abstract_Overriding located at different contexts in the + -- compiler). However, this is not possible because it causes + -- spurious errors in case of late overriding. + + Add_Internal_Interface_Entities (E); + end if; + + -- Check CPP types + + if Ekind (E) = E_Record_Type + and then Is_CPP_Class (E) + and then Is_Tagged_Type (E) + and then Tagged_Type_Expansion + then + if CPP_Num_Prims (E) = 0 then + + -- If the CPP type has user defined components then it must import + -- primitives from C++. This is required because if the C++ class + -- has no primitives then the C++ compiler does not added the _tag + -- component to the type. + + if First_Entity (E) /= Last_Entity (E) then + Error_Msg_N + ("'C'P'P type must import at least one primitive from C++??", + E); + end if; + end if; + + -- Check that all its primitives are abstract or imported from C++. + -- Check also availability of the C++ constructor. + + declare + Has_Constructors : constant Boolean := Has_CPP_Constructors (E); + Elmt : Elmt_Id; + Error_Reported : Boolean := False; + Prim : Node_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (E)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Comes_From_Source (Prim) then + if Is_Abstract_Subprogram (Prim) then + null; + + elsif not Is_Imported (Prim) + or else Convention (Prim) /= Convention_CPP + then + Error_Msg_N + ("primitives of 'C'P'P types must be imported from C++ " + & "or abstract??", Prim); + + elsif not Has_Constructors + and then not Error_Reported + then + Error_Msg_Name_1 := Chars (E); + Error_Msg_N + ("??'C'P'P constructor required for type %", Prim); + Error_Reported := True; + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + -- Check Ada derivation of CPP type + + if Expander_Active -- why? losing errors in -gnatc mode??? + and then Tagged_Type_Expansion + and then Ekind (E) = E_Record_Type + and then Etype (E) /= E + and then Is_CPP_Class (Etype (E)) + and then CPP_Num_Prims (Etype (E)) > 0 + and then not Is_CPP_Class (E) + and then not Has_CPP_Constructors (Etype (E)) + then + -- If the parent has C++ primitives but it has no constructor then + -- check that all the primitives are overridden in this derivation; + -- otherwise the constructor of the parent is needed to build the + -- dispatch table. + + declare + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (E)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if not Is_Abstract_Subprogram (Prim) + and then No (Interface_Alias (Prim)) + and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E + then + Error_Msg_Name_1 := Chars (Etype (E)); + Error_Msg_N + ("'C'P'P constructor required for parent type %", E); + exit; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + Inside_Freezing_Actions := Inside_Freezing_Actions - 1; + + -- If we have a type with predicates, build predicate function. This + -- is not needed in the generic casee + + if Non_Generic_Case and then Is_Type (E) and then Has_Predicates (E) then + Build_Predicate_Functions (E, N); + end if; + + -- If type has delayed aspects, this is where we do the preanalysis at + -- the freeze point, as part of the consistent visibility check. Note + -- that this must be done after calling Build_Predicate_Functions or + -- Build_Invariant_Procedure since these subprograms fix occurrences of + -- the subtype name in the saved expression so that they will not cause + -- trouble in the preanalysis. + + -- This is also not needed in the generic case + + if Non_Generic_Case + and then Has_Delayed_Aspects (E) + and then Scope (E) = Current_Scope + then + -- Retrieve the visibility to the discriminants in order to properly + -- analyze the aspects. + + Push_Scope_And_Install_Discriminants (E); + + declare + Ritem : Node_Id; + + begin + -- Look for aspect specification entries for this entity + + Ritem := First_Rep_Item (E); + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification + and then Entity (Ritem) = E + and then Is_Delayed_Aspect (Ritem) + then + Check_Aspect_At_Freeze_Point (Ritem); + end if; + + Next_Rep_Item (Ritem); + end loop; + end; + + Uninstall_Discriminants_And_Pop_Scope (E); + end if; + + -- For a record type, deal with variant parts. This has to be delayed + -- to this point, because of the issue of statically precicated + -- subtypes, which we have to ensure are frozen before checking + -- choices, since we need to have the static choice list set. + + if Is_Record_Type (E) then + Check_Variant_Part : declare + D : constant Node_Id := Declaration_Node (E); + T : Node_Id; + C : Node_Id; + VP : Node_Id; + + Others_Present : Boolean; + pragma Warnings (Off, Others_Present); + -- Indicates others present, not used in this case + + procedure Non_Static_Choice_Error (Choice : Node_Id); + -- Error routine invoked by the generic instantiation below when + -- the variant part has a non static choice. + + procedure Process_Declarations (Variant : Node_Id); + -- Processes declarations associated with a variant. We analyzed + -- the declarations earlier (in Sem_Ch3.Analyze_Variant_Part), + -- but we still need the recursive call to Check_Choices for any + -- nested variant to get its choices properly processed. This is + -- also where we expand out the choices if expansion is active. + + package Variant_Choices_Processing is new + Generic_Check_Choices + (Process_Empty_Choice => No_OP, + Process_Non_Static_Choice => Non_Static_Choice_Error, + Process_Associated_Node => Process_Declarations); + use Variant_Choices_Processing; + + ----------------------------- + -- Non_Static_Choice_Error -- + ----------------------------- + + procedure Non_Static_Choice_Error (Choice : Node_Id) is + begin + Flag_Non_Static_Expr + ("choice given in variant part is not static!", Choice); + end Non_Static_Choice_Error; + + -------------------------- + -- Process_Declarations -- + -------------------------- + + procedure Process_Declarations (Variant : Node_Id) is + CL : constant Node_Id := Component_List (Variant); + VP : Node_Id; + + begin + -- Check for static predicate present in this variant + + if Has_SP_Choice (Variant) then + + -- Here we expand. You might expect to find this call in + -- Expand_N_Variant_Part, but that is called when we first + -- see the variant part, and we cannot do this expansion + -- earlier than the freeze point, since for statically + -- predicated subtypes, the predicate is not known till + -- the freeze point. + + -- Furthermore, we do this expansion even if the expander + -- is not active, because other semantic processing, e.g. + -- for aggregates, requires the expanded list of choices. + + -- If the expander is not active, then we can't just clobber + -- the list since it would invalidate the ASIS -gnatct tree. + -- So we have to rewrite the variant part with a Rewrite + -- call that replaces it with a copy and clobber the copy. + + if not Expander_Active then + declare + NewV : constant Node_Id := New_Copy (Variant); + begin + Set_Discrete_Choices + (NewV, New_Copy_List (Discrete_Choices (Variant))); + Rewrite (Variant, NewV); + end; + end if; + + Expand_Static_Predicates_In_Choices (Variant); + end if; + + -- We don't need to worry about the declarations in the variant + -- (since they were analyzed by Analyze_Choices when we first + -- encountered the variant), but we do need to take care of + -- expansion of any nested variants. + + if not Null_Present (CL) then + VP := Variant_Part (CL); + + if Present (VP) then + Check_Choices + (VP, Variants (VP), Etype (Name (VP)), Others_Present); + end if; + end if; + end Process_Declarations; + + -- Start of processing for Check_Variant_Part + + begin + -- Find component list + + C := Empty; + + if Nkind (D) = N_Full_Type_Declaration then + T := Type_Definition (D); + + if Nkind (T) = N_Record_Definition then + C := Component_List (T); + + elsif Nkind (T) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (T)) + then + C := Component_List (Record_Extension_Part (T)); + end if; + end if; + + -- Case of variant part present + + if Present (C) and then Present (Variant_Part (C)) then + VP := Variant_Part (C); + + -- Check choices + + Check_Choices + (VP, Variants (VP), Etype (Name (VP)), Others_Present); + + -- If the last variant does not contain the Others choice, + -- replace it with an N_Others_Choice node since Gigi always + -- wants an Others. Note that we do not bother to call Analyze + -- on the modified variant part, since its only effect would be + -- to compute the Others_Discrete_Choices node laboriously, and + -- of course we already know the list of choices corresponding + -- to the others choice (it's the list we're replacing!) + + -- We only want to do this if the expander is active, since + -- we do not want to clobber the ASIS tree! + + if Expander_Active then + declare + Last_Var : constant Node_Id := + Last_Non_Pragma (Variants (VP)); + + Others_Node : Node_Id; + + begin + if Nkind (First (Discrete_Choices (Last_Var))) /= + N_Others_Choice + then + Others_Node := Make_Others_Choice (Sloc (Last_Var)); + Set_Others_Discrete_Choices + (Others_Node, Discrete_Choices (Last_Var)); + Set_Discrete_Choices + (Last_Var, New_List (Others_Node)); + end if; + end; + end if; + end if; + end Check_Variant_Part; + end if; + end Freeze_Entity_Checks; + ------------------------- -- Get_Alignment_Value -- ------------------------- @@ -9050,6 +9603,7 @@ package body Sem_Ch13 is -- Default_Component_Value if Is_Array_Type (Typ) + and then Is_Base_Type (Typ) and then Has_Rep_Item (Typ, Name_Default_Component_Value, False) and then Has_Rep_Item (Typ, Name_Default_Component_Value) then @@ -9061,6 +9615,7 @@ package body Sem_Ch13 is -- Default_Value if Is_Scalar_Type (Typ) + and then Is_Base_Type (Typ) and then Has_Rep_Item (Typ, Name_Default_Value, False) and then Has_Rep_Item (Typ, Name_Default_Value) then @@ -9653,7 +10208,7 @@ package body Sem_Ch13 is -- Exclude imported types, which may be frozen if they appear in a -- representation clause for a local type. - and then not From_With_Type (T) + and then not From_Limited_With (T) -- Exclude generated entities (not coming from source). The common -- case is when we generate a renaming which prematurely freezes the diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 0d95174c14a..37bf09132ab 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -33,6 +33,7 @@ package Sem_Ch13 is procedure Analyze_Enumeration_Representation_Clause (N : Node_Id); procedure Analyze_Free_Statement (N : Node_Id); procedure Analyze_Freeze_Entity (N : Node_Id); + procedure Analyze_Freeze_Generic_Entity (N : Node_Id); procedure Analyze_Record_Representation_Clause (N : Node_Id); procedure Analyze_Code_Statement (N : Node_Id); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ea41423b46f..01d6dddd102 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -64,6 +64,7 @@ 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; @@ -895,7 +896,7 @@ package body Sem_Ch3 is -- (which is declared elsewhere in some other scope). if Ekind (Desig_Type) = E_Incomplete_Type - and then not From_With_Type (Desig_Type) + and then not From_Limited_With (Desig_Type) and then Is_Overloadable (Current_Scope) then Append_Elmt (Current_Scope, Private_Dependents (Desig_Type)); @@ -949,7 +950,7 @@ package body Sem_Ch3 is -- generic formal, because no use of it will reach the backend. elsif Nkind (Related_Nod) = N_Function_Specification - and then not From_With_Type (Desig_Type) + and then not From_Limited_With (Desig_Type) and then not Is_Generic_Type (Desig_Type) then if Present (Enclosing_Prot_Type) then @@ -981,7 +982,6 @@ package body Sem_Ch3 is (T_Name : Entity_Id; T_Def : Node_Id) is - procedure Check_For_Premature_Usage (Def : Node_Id); -- Check that type T_Name is not used, directly or recursively, as a -- parameter or a return type in Def. Def is either a subtype, an @@ -1131,7 +1131,7 @@ package body Sem_Ch3 is Scope_Id => Current_Scope)); else - if From_With_Type (Typ) then + if From_Limited_With (Typ) then -- AI05-151: Incomplete types are allowed in all basic -- declarations, including access to subprograms. @@ -1235,12 +1235,14 @@ package body Sem_Ch3 is -- be updated when the full type declaration is seen. This only applies -- to incomplete types declared in some enclosing scope, not to limited -- views from other packages. + -- Prior to Ada 2012, access to functions can only have in_parameters. if Present (Formals) then Formal := First_Formal (Desig_Type); while Present (Formal) loop if Ekind (Formal) /= E_In_Parameter and then Nkind (T_Def) = N_Access_Function_Definition + and then Ada_Version < Ada_2012 then Error_Msg_N ("functions can only have IN parameters", Formal); end if; @@ -1358,7 +1360,7 @@ package body Sem_Ch3 is -- If the type has appeared already in a with_type clause, it is frozen -- and the pointer size is already set. Else, initialize. - if not From_With_Type (T) then + if not From_Limited_With (T) then Init_Size_Align (T); end if; @@ -2056,28 +2058,141 @@ package body Sem_Ch3 is -------------------------- procedure Analyze_Declarations (L : List_Id) is - D : Node_Id; - Freeze_From : Entity_Id := Empty; - Next_Node : Node_Id; + Decl : Node_Id; - procedure Adjust_D; - -- Adjust D not to include implicit label declarations, since these + procedure Adjust_Decl; + -- Adjust Decl not to include implicit label declarations, since these -- have strange Sloc values that result in elaboration check problems. -- (They have the sloc of the label as found in the source, and that -- is ahead of the current declarative part). - -------------- - -- Adjust_D -- - -------------- + procedure Remove_Visible_Refinements (Spec_Id : Entity_Id); + -- Spec_Id is the entity of a package that may define abstract states. + -- If the states have visible refinement, remove the visibility of each + -- constituent at the end of the package body declarations. + + function Requires_State_Refinement + (Spec_Id : Entity_Id; + Body_Id : Entity_Id) return Boolean; + -- Determine whether a package denoted by its spec and body entities + -- requires refinement of abstract states. + + ----------------- + -- Adjust_Decl -- + ----------------- - procedure Adjust_D is + procedure Adjust_Decl is begin - while Present (Prev (D)) - and then Nkind (D) = N_Implicit_Label_Declaration + while Present (Prev (Decl)) + and then Nkind (Decl) = N_Implicit_Label_Declaration loop - Prev (D); + Prev (Decl); end loop; - end Adjust_D; + end Adjust_Decl; + + -------------------------------- + -- Remove_Visible_Refinements -- + -------------------------------- + + procedure Remove_Visible_Refinements (Spec_Id : Entity_Id) is + State_Elmt : Elmt_Id; + begin + if Present (Abstract_States (Spec_Id)) then + State_Elmt := First_Elmt (Abstract_States (Spec_Id)); + while Present (State_Elmt) loop + Set_Has_Visible_Refinement (Node (State_Elmt), False); + Next_Elmt (State_Elmt); + end loop; + end if; + end Remove_Visible_Refinements; + + ------------------------------- + -- Requires_State_Refinement -- + ------------------------------- + + function Requires_State_Refinement + (Spec_Id : Entity_Id; + Body_Id : Entity_Id) return Boolean + is + function Mode_Is_Off (Prag : Node_Id) return Boolean; + -- Given pragma SPARK_Mode, determine whether the mode is Off + + ----------------- + -- Mode_Is_Off -- + ----------------- + + function Mode_Is_Off (Prag : Node_Id) return Boolean is + Mode : Node_Id; + + begin + -- The default SPARK mode is On + + if No (Prag) then + return False; + end if; + + Mode := + Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); + + -- Then the pragma lacks an argument, the default mode is On + + if No (Mode) then + return False; + else + return Chars (Mode) = Name_Off; + end if; + end Mode_Is_Off; + + -- Start of processing for Requires_State_Refinement + + begin + -- A package that does not define at least one abstract state cannot + -- possibly require refinement. + + if No (Abstract_States (Spec_Id)) then + return False; + + -- The package instroduces a single null state which does not merit + -- refinement. + + elsif Has_Null_Abstract_State (Spec_Id) then + return False; + + -- Check whether the package body is subject to pragma SPARK_Mode. If + -- it is and the mode is Off, the package body is considered to be in + -- regular Ada and does not require refinement. + + elsif Mode_Is_Off (SPARK_Mode_Pragmas (Body_Id)) then + return False; + + -- The body's SPARK_Mode may be inherited from a similar pragma that + -- appears in the private declarations of the spec. The pragma we are + -- interested appears as the second entry in SPARK_Mode_Pragmas. + + elsif Present (SPARK_Mode_Pragmas (Spec_Id)) + and then Mode_Is_Off (Next_Pragma (SPARK_Mode_Pragmas (Spec_Id))) + then + return False; + + -- The spec defines at least one abstract state and the body has no + -- way of circumventing the refinement. + + else + return True; + end if; + end Requires_State_Refinement; + + -- Local variables + + Body_Id : Entity_Id; + Context : Node_Id; + Freeze_From : Entity_Id := Empty; + Next_Decl : Node_Id; + Prag : Node_Id; + Spec_Id : Entity_Id; + + In_Package_Body : Boolean := False; + -- Flag set when the current declaration list belongs to a package body -- Start of processing for Analyze_Declarations @@ -2086,23 +2201,23 @@ package body Sem_Ch3 is Check_Later_Vs_Basic_Declarations (L, During_Parsing => False); end if; - D := First (L); - while Present (D) loop + Decl := First (L); + while Present (Decl) loop -- Package spec cannot contain a package declaration in SPARK - if Nkind (D) = N_Package_Declaration + if Nkind (Decl) = N_Package_Declaration and then Nkind (Parent (L)) = N_Package_Specification then Check_SPARK_Restriction ("package specification cannot contain a package declaration", - D); + Decl); end if; -- Complete analysis of declaration - Analyze (D); - Next_Node := Next (D); + Analyze (Decl); + Next_Decl := Next (Decl); if No (Freeze_From) then Freeze_From := First_Entity (Current_Scope); @@ -2124,7 +2239,7 @@ package body Sem_Ch3 is -- be a freeze point once delayed freezing of bodies is implemented. -- (This is needed in any case for early instantiations ???). - if No (Next_Node) then + if No (Next_Decl) then if Nkind_In (Parent (L), N_Component_List, N_Task_Definition, N_Protected_Definition) @@ -2136,8 +2251,8 @@ package body Sem_Ch3 is Freeze_From := First_Entity (Current_Scope); end if; - Adjust_D; - Freeze_All (Freeze_From, D); + Adjust_Decl; + Freeze_All (Freeze_From, Decl); Freeze_From := Last_Entity (Current_Scope); elsif Scope (Current_Scope) /= Standard_Standard @@ -2150,8 +2265,8 @@ package body Sem_Ch3 is or else No (Private_Declarations (Parent (L))) or else Is_Empty_List (Private_Declarations (Parent (L))) then - Adjust_D; - Freeze_All (Freeze_From, D); + Adjust_Decl; + Freeze_All (Freeze_From, Decl); Freeze_From := Last_Entity (Current_Scope); end if; @@ -2170,44 +2285,96 @@ package body Sem_Ch3 is -- care to attach the bodies at a proper place in the tree so as to -- not cause unwanted freezing at that point. - elsif not Analyzed (Next_Node) - and then (Nkind_In (Next_Node, N_Subprogram_Body, + elsif not Analyzed (Next_Decl) + and then (Nkind_In (Next_Decl, N_Subprogram_Body, N_Entry_Body, N_Package_Body, N_Protected_Body, N_Task_Body) or else - Nkind (Next_Node) in N_Body_Stub) + Nkind (Next_Decl) in N_Body_Stub) then - Adjust_D; - Freeze_All (Freeze_From, D); + Adjust_Decl; + Freeze_All (Freeze_From, Decl); Freeze_From := Last_Entity (Current_Scope); end if; - D := Next_Node; + Decl := Next_Decl; end loop; - -- One more thing to do, we need to scan the declarations to check for - -- any precondition/postcondition pragmas (Pre/Post aspects have by this - -- stage been converted into corresponding pragmas). It is at this point - -- that we analyze the expressions in such pragmas, to implement the - -- delayed visibility requirement. + if Present (L) then + Context := Parent (L); - declare - Decl : Node_Id; - Subp_Id : Entity_Id; + -- Analyze pragmas Initializes and Initial_Condition of a package at + -- the end of the visible declarations as the pragmas have visibility + -- over the said region. - begin - Decl := First (L); - while Present (Decl) loop - if Nkind (Decl) = N_Subprogram_Declaration then - Subp_Id := Defining_Unit_Name (Specification (Decl)); - Analyze_Subprogram_Contract (Subp_Id); + if Nkind (Context) = N_Package_Specification + and then L = Visible_Declarations (Context) + then + Spec_Id := Defining_Entity (Parent (Context)); + Prag := Get_Pragma (Spec_Id, Pragma_Initializes); + + if Present (Prag) then + Analyze_Initializes_In_Decl_Part (Prag); end if; - Next (Decl); - end loop; - end; + Prag := Get_Pragma (Spec_Id, Pragma_Initial_Condition); + + if Present (Prag) then + Analyze_Initial_Condition_In_Decl_Part (Prag); + end if; + + -- Analyze the state refinements within a package body now, after + -- all hidden states have been encountered and freely visible. + -- Refinements must be processed before pragmas Refined_Depends and + -- Refined_Global because the last two may mention constituents. + + elsif Nkind (Context) = N_Package_Body then + In_Package_Body := True; + + Body_Id := Defining_Entity (Context); + Spec_Id := Corresponding_Spec (Context); + Prag := 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 (Prag) then + Analyze_Refined_State_In_Decl_Part (Prag); + + -- State refinement is required when the package declaration has + -- abstract states. Null states are not considered. + + elsif Requires_State_Refinement (Spec_Id, Body_Id) then + Error_Msg_NE + ("package & requires state refinement", Context, Spec_Id); + end if; + end if; + end if; + + -- Analyze the contracts of a subprogram declaration or a body now due + -- to delayed visibility requirements of aspects. + + Decl := First (L); + while Present (Decl) loop + if Nkind (Decl) = N_Subprogram_Body then + Analyze_Subprogram_Body_Contract (Defining_Entity (Decl)); + + elsif Nkind (Decl) = N_Subprogram_Declaration then + Analyze_Subprogram_Contract (Defining_Entity (Decl)); + end if; + + Next (Decl); + end loop; + + -- State refinements are visible upto the end the of the package body + -- declarations. Hide the refinements from visibility to restore the + -- original state conditions. + + if In_Package_Body then + Remove_Visible_Refinements (Spec_Id); + end if; end Analyze_Declarations; ----------------------------------- @@ -2459,7 +2626,7 @@ package body Sem_Ch3 is -- finalization list at the point the access type is frozen, to -- prevent unsatisfied references at link time. - if not From_With_Type (T) or else Is_Access_Type (T) then + if not From_Limited_With (T) or else Is_Access_Type (T) then Set_Has_Delayed_Freeze (T); end if; end; @@ -3230,7 +3397,7 @@ package body Sem_Ch3 is end if; end if; - -- Check incorrect use of dynamically tagged expressions. + -- Check incorrect use of dynamically tagged expressions if Is_Tagged_Type (T) then Check_Dynamically_Tagged_Expression @@ -3248,7 +3415,7 @@ package body Sem_Ch3 is -- Only call test if needed and then Restriction_Check_Required (SPARK_05) - and then not Is_SPARK_Initialization_Expr (E) + and then not Is_SPARK_Initialization_Expr (Original_Node (E)) then Check_SPARK_Restriction ("initialization expression is not appropriate", E); @@ -3505,7 +3672,7 @@ package body Sem_Ch3 is if Constant_Present (N) then Set_Ekind (Id, E_Constant); - Set_Is_True_Constant (Id, True); + Set_Is_True_Constant (Id); else Set_Ekind (Id, E_Variable); @@ -3728,6 +3895,13 @@ package body Sem_Ch3 is end if; <<Leave>> + -- Initialize the refined state of a variable here because this is a + -- common destination for legal and illegal object declarations. + + if Ekind (Id) = E_Variable then + Set_Refined_State (Id, Empty); + end if; + if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Id); end if; @@ -4017,6 +4191,13 @@ package body Sem_Ch3 is -- type with constraints. In this case the entity has been introduced -- in the private declaration. + -- Finally this happens in some complex cases when validity checks are + -- enabled, where the same subtype declaration may be analyzed twice. + -- This can happen if the subtype is created by the pre-analysis of + -- an attribute tht gives the range of a loop statement, and the loop + -- itself appears within an if_statement that will be rewritten during + -- expansion. + if Skip or else (Present (Etype (Id)) and then (Is_Private_Type (Etype (Id)) @@ -4025,6 +4206,9 @@ package body Sem_Ch3 is then null; + elsif Current_Entity (Id) = Id then + null; + else Enter_Name (Id); end if; @@ -4362,11 +4546,11 @@ package body Sem_Ch3 is -- Ada 2005 (AI-412): Decorate an incomplete subtype of an -- incomplete type visible through a limited with clause. - if From_With_Type (T) + if From_Limited_With (T) and then Present (Non_Limited_View (T)) then - Set_From_With_Type (Id); - Set_Non_Limited_View (Id, Non_Limited_View (T)); + Set_From_Limited_With (Id); + Set_Non_Limited_View (Id, Non_Limited_View (T)); -- Ada 2005 (AI-412): Add the regular incomplete subtype -- to the private dependents of the original incomplete @@ -4590,61 +4774,31 @@ package body Sem_Ch3 is -------------------------- procedure Analyze_Variant_Part (N : Node_Id) is + Discr_Name : Node_Id; + Discr_Type : Entity_Id; - procedure Non_Static_Choice_Error (Choice : Node_Id); - -- Error routine invoked by the generic instantiation below when the - -- variant part has a non static choice. - - procedure Process_Declarations (Variant : Node_Id); - -- Analyzes all the declarations associated with a Variant. Needed by - -- the generic instantiation below. - - package Variant_Choices_Processing is new - Generic_Choices_Processing - (Get_Alternatives => Variants, - Get_Choices => Discrete_Choices, - Process_Empty_Choice => No_OP, - Process_Non_Static_Choice => Non_Static_Choice_Error, - Process_Associated_Node => Process_Declarations); - use Variant_Choices_Processing; - -- Instantiation of the generic choice processing package - - ----------------------------- - -- Non_Static_Choice_Error -- - ----------------------------- + procedure Process_Variant (A : Node_Id); + -- Analyze declarations for a single variant - procedure Non_Static_Choice_Error (Choice : Node_Id) is - begin - Flag_Non_Static_Expr - ("choice given in variant part is not static!", Choice); - end Non_Static_Choice_Error; + package Analyze_Variant_Choices is + new Generic_Analyze_Choices (Process_Variant); + use Analyze_Variant_Choices; - -------------------------- - -- Process_Declarations -- - -------------------------- + --------------------- + -- Process_Variant -- + --------------------- - procedure Process_Declarations (Variant : Node_Id) is + procedure Process_Variant (A : Node_Id) is + CL : constant Node_Id := Component_List (A); begin - if not Null_Present (Component_List (Variant)) then - Analyze_Declarations (Component_Items (Component_List (Variant))); + if not Null_Present (CL) then + Analyze_Declarations (Component_Items (CL)); - if Present (Variant_Part (Component_List (Variant))) then - Analyze (Variant_Part (Component_List (Variant))); + if Present (Variant_Part (CL)) then + Analyze (Variant_Part (CL)); end if; end if; - end Process_Declarations; - - -- Local Variables - - Discr_Name : Node_Id; - Discr_Type : Entity_Id; - - Dont_Care : Boolean; - Others_Present : Boolean := False; - - pragma Warnings (Off, Dont_Care); - pragma Warnings (Off, Others_Present); - -- We don't care about the assigned values of any of these + end Process_Variant; -- Start of processing for Analyze_Variant_Part @@ -4673,9 +4827,18 @@ package body Sem_Ch3 is return; end if; - -- Call the instantiated Analyze_Choices which does the rest of the work + -- Now analyze the choices, which also analyzes the declarations that + -- are associated with each choice. + + Analyze_Choices (Variants (N), Discr_Type); + + -- Note: we used to instantiate and call Check_Choices here to check + -- that the choices covered the discriminant, but it's too early to do + -- that because of statically predicated subtypes, whose analysis may + -- be deferred to their freeze point which may be as late as the freeze + -- point of the containing record. So this call is now to be found in + -- Freeze_Record_Declaration. - Analyze_Choices (N, Discr_Type, Dont_Care, Others_Present); end Analyze_Variant_Part; ---------------------------- @@ -5101,12 +5264,14 @@ package body Sem_Ch3 is if Nkind (Def) = N_Access_Definition then if Present (Access_To_Subprogram_Definition (Def)) then - Set_Etype (Def, + Set_Etype + (Def, Replace_Anonymous_Access_To_Protected_Subprogram (Spec)); else Find_Type (Subtype_Mark (Def)); end if; + else Find_Type (Def); end if; @@ -7251,45 +7416,65 @@ package body Sem_Ch3 is and then (Is_Constrained (Parent_Type) or else Constraint_Present) then -- First, we must analyze the constraint (see comment in point 5.) + -- The constraint may come from the subtype indication of the full + -- declaration. if Constraint_Present then New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic); - if Has_Discriminants (Derived_Type) - and then Has_Private_Declaration (Derived_Type) - and then Present (Discriminant_Constraint (Derived_Type)) - then - -- Verify that constraints of the full view statically match - -- those given in the partial view. + -- If there is no explicit constraint, there might be one that is + -- inherited from a constrained parent type. In that case verify that + -- it conforms to the constraint in the partial view. In perverse + -- cases the parent subtypes of the partial and full view can have + -- different constraints. - declare - C1, C2 : Elmt_Id; + elsif Present (Stored_Constraint (Parent_Type)) then + New_Discrs := Stored_Constraint (Parent_Type); - begin - C1 := First_Elmt (New_Discrs); - C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); - while Present (C1) and then Present (C2) loop - if Fully_Conformant_Expressions (Node (C1), Node (C2)) - or else - (Is_OK_Static_Expression (Node (C1)) - and then - Is_OK_Static_Expression (Node (C2)) - and then + else + New_Discrs := No_Elist; + end if; + + if Has_Discriminants (Derived_Type) + and then Has_Private_Declaration (Derived_Type) + and then Present (Discriminant_Constraint (Derived_Type)) + and then Present (New_Discrs) + then + -- Verify that constraints of the full view statically match + -- those given in the partial view. + + declare + C1, C2 : Elmt_Id; + + begin + C1 := First_Elmt (New_Discrs); + C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); + while Present (C1) and then Present (C2) loop + if Fully_Conformant_Expressions (Node (C1), Node (C2)) + or else + (Is_OK_Static_Expression (Node (C1)) + and then Is_OK_Static_Expression (Node (C2)) + and then Expr_Value (Node (C1)) = Expr_Value (Node (C2))) - then - null; + then + null; + else + if Constraint_Present then + Error_Msg_N + ("constraint not conformant to previous declaration", + Node (C1)); else - Error_Msg_N ( - "constraint not conformant to previous declaration", - Node (C1)); + Error_Msg_N + ("constraint of full view is incompatible " + & "with partial view", N); end if; + end if; - Next_Elmt (C1); - Next_Elmt (C2); - end loop; - end; - end if; + Next_Elmt (C1); + Next_Elmt (C2); + end loop; + end; end if; -- Insert and analyze the declaration for the unconstrained base type @@ -9418,6 +9603,17 @@ package body Sem_Ch3 is end if; end if; + -- If the operation is a wrapper for a synchronized primitive, it + -- may be called indirectly through a dispatching select. We assume + -- that it will be referenced elsewhere indirectly, and suppress + -- warnings about an unused entity. + + if Is_Primitive_Wrapper (Subp) + and then Present (Wrapped_Entity (Subp)) + then + Set_Referenced (Wrapped_Entity (Subp)); + end if; + Next_Elmt (Elmt); end loop; end Check_Abstract_Overriding; @@ -9440,7 +9636,7 @@ package body Sem_Ch3 is -- or else be a partial view. if Nkind (Discriminant_Type (D)) = N_Access_Definition then - if Is_Immutably_Limited_Type (Current_Scope) + if Is_Limited_View (Current_Scope) or else (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration and then Limited_Present (Parent (Current_Scope))) @@ -10336,6 +10532,14 @@ package body Sem_Ch3 is Set_First_Entity (Full, First_Entity (Full_Base)); Set_Last_Entity (Full, Last_Entity (Full_Base)); + -- If the underlying base type is constrained, we know that the + -- full view of the subtype is constrained as well (the converse + -- is not necessarily true). + + if Is_Constrained (Full_Base) then + Set_Is_Constrained (Full); + end if; + when others => Copy_Node (Full_Base, Full); @@ -10795,8 +10999,7 @@ package body Sem_Ch3 is elsif Ekind (Current_Scope) = E_Package and then List_Containing (Parent (Prev)) /= - Visible_Declarations - (Specification (Unit_Declaration_Node (Current_Scope))) + Visible_Declarations (Package_Specification (Current_Scope)) then Error_Msg_N ("deferred constant must be declared in visible part", @@ -11810,13 +12013,12 @@ package body Sem_Ch3 is -- incomplete type or imported via a limited with clause. if Has_Discriminants (T) - or else - (From_With_Type (T) - and then Present (Non_Limited_View (T)) - and then Nkind (Parent (Non_Limited_View (T))) = - N_Full_Type_Declaration - and then Present (Discriminant_Specifications - (Parent (Non_Limited_View (T))))) + or else (From_Limited_With (T) + and then Present (Non_Limited_View (T)) + and then Nkind (Parent (Non_Limited_View (T))) = + N_Full_Type_Declaration + and then Present (Discriminant_Specifications + (Parent (Non_Limited_View (T))))) then Error_Msg_N ("(Ada 2005) incomplete subtype may not be constrained", C); @@ -14779,7 +14981,8 @@ package body Sem_Ch3 is -- extensions of tagged record types. if No (Extension) then - Check_SPARK_Restriction ("derived type is not allowed", N); + Check_SPARK_Restriction + ("derived type is not allowed", Original_Node (N)); end if; end Derived_Type_Declaration; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index c4247cd403d..52aa233746b 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1315,14 +1315,17 @@ package body Sem_Ch4 is -- Error routine invoked by the generic instantiation below when -- the case expression has a non static choice. - package Case_Choices_Processing is new - Generic_Choices_Processing - (Get_Alternatives => Alternatives, - Get_Choices => Discrete_Choices, - Process_Empty_Choice => No_OP, + package Case_Choices_Analysis is new + Generic_Analyze_Choices + (Process_Associated_Node => No_OP); + use Case_Choices_Analysis; + + package Case_Choices_Checking is new + Generic_Check_Choices + (Process_Empty_Choice => No_OP, Process_Non_Static_Choice => Non_Static_Choice_Error, Process_Associated_Node => No_OP); - use Case_Choices_Processing; + use Case_Choices_Checking; -------------------------- -- Has_Static_Predicate -- @@ -1364,8 +1367,8 @@ package body Sem_Ch4 is Exp_Type : Entity_Id; Exp_Btype : Entity_Id; - Dont_Care : Boolean; Others_Present : Boolean; + -- Indicates if Others was present -- Start of processing for Analyze_Case_Expression @@ -1428,9 +1431,7 @@ package body Sem_Ch4 is -- If error already reported by Resolve, nothing more to do - if Exp_Btype = Any_Discrete - or else Exp_Btype = Any_Type - then + if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then return; elsif Exp_Btype = Any_Character then @@ -1462,10 +1463,11 @@ package body Sem_Ch4 is then null; - -- Call instantiated Analyze_Choices which does the rest of the work + -- Call Analyze_Choices and Check_Choices to do the rest of the work else - Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); + Analyze_Choices (Alternatives (N), Exp_Type); + Check_Choices (N, Alternatives (N), Exp_Type, Others_Present); end if; if Exp_Type = Universal_Integer and then not Others_Present then @@ -1859,8 +1861,8 @@ package body Sem_Ch4 is -- incomplete type imported through a limited_with clause, -- if the full view is visible. - if From_With_Type (DT) - and then not From_With_Type (Scope (DT)) + if From_Limited_With (DT) + and then not From_Limited_With (Scope (DT)) and then (Is_Immediately_Visible (Scope (DT)) or else @@ -2031,7 +2033,9 @@ package body Sem_Ch4 is return; end if; - Check_SPARK_Restriction ("if expression is not allowed", N); + if Comes_From_Source (N) then + Check_SPARK_Restriction ("if expression is not allowed", N); + end if; Else_Expr := Next (Then_Expr); @@ -3962,10 +3966,24 @@ package body Sem_Ch4 is Next (Param); end loop; - -- One of the specs has additional formals + -- One of the specs has additional formals; there is no match, unless + -- this may be an indexing of a parameterless call. + + -- Note that when expansion is disabled, the corresponding record + -- type of synchronized types is not constructed, so that there is + -- no point is attempting an interpretation as a prefixed call, as + -- this is bound to fail because the primitive operations will not + -- be properly located. if Present (Comp_Param) or else Present (Param) then - return False; + if Needs_No_Actuals (Comp) + and then Is_Array_Type (Etype (Comp)) + and then not Expander_Active + then + return True; + else + return False; + end if; end if; return True; @@ -4055,7 +4073,7 @@ package body Sem_Ch4 is -- full view if available. if Is_Incomplete_Type (Prefix_Type) - and then From_With_Type (Prefix_Type) + and then From_Limited_With (Prefix_Type) and then Present (Non_Limited_View (Prefix_Type)) then Prefix_Type := Get_Full_View (Non_Limited_View (Prefix_Type)); @@ -4065,7 +4083,7 @@ package body Sem_Ch4 is end if; elsif Ekind (Prefix_Type) = E_Class_Wide_Type - and then From_With_Type (Prefix_Type) + and then From_Limited_With (Prefix_Type) and then Present (Non_Limited_View (Etype (Prefix_Type))) then Prefix_Type := @@ -4173,7 +4191,7 @@ package body Sem_Ch4 is -- end Pkg; -- Comp is not visible if Nkind (Name) = N_Explicit_Dereference - and then From_With_Type (Etype (Prefix (Name))) + and then From_Limited_With (Etype (Prefix (Name))) and then not Is_Potentially_Use_Visible (Etype (Name)) and then Nkind (Parent (Cunit_Entity (Current_Sem_Unit))) = N_Package_Specification @@ -4626,7 +4644,7 @@ package body Sem_Ch4 is Inc : constant Entity_Id := First_Subtype (Type_To_Use); begin - if From_With_Type (Scope (Type_To_Use)) then + if From_Limited_With (Scope (Type_To_Use)) then Error_Msg_NE ("\limited view of& has no components", N, Inc); @@ -5346,7 +5364,7 @@ package body Sem_Ch4 is -- usage of an entity from the limited view. if not Analyzed (Etype (Actual)) - and then From_With_Type (Etype (Actual)) + and then From_Limited_With (Etype (Actual)) then Error_Msg_Qual_Level := 1; Error_Msg_NE @@ -6507,8 +6525,8 @@ package body Sem_Ch4 is -- incomplete type imported through a limited_with clause, -- if the full view is visible. - if From_With_Type (Typ) - and then not From_With_Type (Scope (Typ)) + if From_Limited_With (Typ) + and then not From_Limited_With (Scope (Typ)) and then (Is_Immediately_Visible (Scope (Typ)) or else @@ -7735,7 +7753,7 @@ package body Sem_Ch4 is -- non-limited view. If still incomplete, retrieve full view. if Ekind (Obj_Type) = E_Incomplete_Type - and then From_With_Type (Obj_Type) + and then From_Limited_With (Obj_Type) then Obj_Type := Get_Full_View (Non_Limited_View (Obj_Type)); end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 2f8eced6fc9..a29aece272c 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1018,12 +1018,12 @@ package body Sem_Ch5 is Exp_Type : Entity_Id; Exp_Btype : Entity_Id; Last_Choice : Nat; - Dont_Care : Boolean; + Others_Present : Boolean; + -- Indicates if Others was present pragma Warnings (Off, Last_Choice); - pragma Warnings (Off, Dont_Care); - -- Don't care about assigned values + -- Don't care about assigned value Statements_Analyzed : Boolean := False; -- Set True if at least some statement sequences get analyzed. If False @@ -1039,17 +1039,21 @@ package body Sem_Ch5 is -- case statement has a non static choice. procedure Process_Statements (Alternative : Node_Id); - -- Analyzes all the statements associated with a case alternative. - -- Needed by the generic instantiation below. - - package Case_Choices_Processing is new - Generic_Choices_Processing - (Get_Alternatives => Alternatives, - Get_Choices => Discrete_Choices, - Process_Empty_Choice => No_OP, + -- Analyzes the statements associated with a case alternative. Needed + -- by instantiation below. + + package Analyze_Case_Choices is new + Generic_Analyze_Choices + (Process_Associated_Node => Process_Statements); + use Analyze_Case_Choices; + -- Instantiation of the generic choice analysis package + + package Check_Case_Choices is new + Generic_Check_Choices + (Process_Empty_Choice => No_OP, Process_Non_Static_Choice => Non_Static_Choice_Error, - Process_Associated_Node => Process_Statements); - use Case_Choices_Processing; + Process_Associated_Node => No_Op); + use Check_Case_Choices; -- Instantiation of the generic choice processing package ----------------------------- @@ -1155,9 +1159,7 @@ package body Sem_Ch5 is -- If error already reported by Resolve, nothing more to do - if Exp_Btype = Any_Discrete - or else Exp_Btype = Any_Type - then + if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then return; elsif Exp_Btype = Any_Character then @@ -1186,12 +1188,12 @@ package body Sem_Ch5 is Exp_Type := Exp_Btype; end if; - -- Call instantiated Analyze_Choices which does the rest of the work + -- Call instantiated procedures to analyzwe and check discrete choices - Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); + Analyze_Choices (Alternatives (N), Exp_Type); + Check_Choices (N, Alternatives (N), Exp_Type, Others_Present); - -- A case statement with a single OTHERS alternative is not allowed - -- in SPARK. + -- Case statement with single OTHERS alternative not allowed in SPARK if Others_Present and then List_Length (Alternatives (N)) = 1 then Check_SPARK_Restriction @@ -1214,6 +1216,12 @@ package body Sem_Ch5 is Unblocked_Exit_Count := Save_Unblocked_Exit_Count; end if; + -- If the expander is active it will detect the case of a statically + -- determined single alternative and remove warnings for the case, but + -- if we are not doing expansion, that circuit won't be active. Here we + -- duplicate the effect of removing warnings in the same way, so that + -- we will get the same set of warnings in -gnatc mode. + if not Expander_Active and then Compile_Time_Known_Value (Expression (N)) and then Serious_Errors_Detected = 0 @@ -1569,6 +1577,43 @@ package body Sem_Ch5 is Remove_Warning_Messages (Then_Statements (N)); end if; end if; + + -- Warn on redundant if statement that has no effect + + -- Note, we could also check empty ELSIF parts ??? + + if Warn_On_Redundant_Constructs + + -- If statement must be from source + + and then Comes_From_Source (N) + + -- Condition must not have obvious side effect + + and then Has_No_Obvious_Side_Effects (Condition (N)) + + -- No elsif parts of else part + + and then No (Elsif_Parts (N)) + and then No (Else_Statements (N)) + + -- Then must be a single null statement + + and then List_Length (Then_Statements (N)) = 1 + then + -- Go to original node, since we may have rewritten something as + -- a null statement (e.g. a case we could figure the outcome of). + + declare + T : constant Node_Id := First (Then_Statements (N)); + S : constant Node_Id := Original_Node (T); + + begin + if Comes_From_Source (S) and then Nkind (S) = N_Null_Statement then + Error_Msg_N ("if statement has no effect?r?", N); + end if; + end; + end if; end Analyze_If_Statement; ---------------------------------------- diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 7913d362f1e..3b5eee1680b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -212,17 +212,6 @@ package body Sem_Ch6 is -- Create the declaration for an inequality operator that is implicitly -- created by a user-defined equality operator that yields a boolean. - procedure Process_PPCs - (N : Node_Id; - Spec_Id : Entity_Id; - Body_Id : Entity_Id); - -- Called from Analyze[_Generic]_Subprogram_Body to deal with scanning post - -- conditions for the body and assembling and inserting the _postconditions - -- procedure. N is the node for the subprogram body and Body_Id/Spec_Id are - -- the entities for the body and separate spec (if there is no separate - -- spec, Spec_Id is Empty). Note that invariants and predicates may also - -- provide postconditions, and are also handled in this procedure. - procedure Set_Formal_Validity (Formal_Id : Entity_Id); -- Formal_Id is an formal parameter entity. This procedure deals with -- setting the proper validity status for this entity, which depends on @@ -349,15 +338,25 @@ package body Sem_Ch6 is Make_Handled_Sequence_Of_Statements (LocX, Statements => New_List (Ret))); + -- If the expression completes a generic subprogram, we must create a + -- separate node for the body, because at instantiation the original + -- node of the generic copy must be a generic subprogram body, and + -- cannot be a expression function. Otherwise we just rewrite the + -- expression with the non-generic body. + if Present (Prev) and then Ekind (Prev) = E_Generic_Function then + Insert_After (N, New_Body); - -- If the expression completes a generic subprogram, we must create a - -- separate node for the body, because at instantiation the original - -- node of the generic copy must be a generic subprogram body, and - -- cannot be a expression function. Otherwise we just rewrite the - -- expression with the non-generic body. + -- Propagate any aspects or pragmas that apply to the expression + -- function to the proper body when the expression function acts + -- as a completion. + + if Has_Aspects (N) then + Move_Aspects (N, To => New_Body); + end if; + + Relocate_Pragmas_To_Body (New_Body); - Insert_After (N, New_Body); Rewrite (N, Make_Null_Statement (Loc)); Set_Has_Completion (Prev, False); Analyze (N); @@ -371,6 +370,12 @@ package body Sem_Ch6 is Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True); Rewrite (N, New_Body); + + -- Propagate any pragmas that apply to the expression function to the + -- proper body when the expression function acts as a completion. + -- Aspects are automatically transfered because of node rewriting. + + Relocate_Pragmas_To_Body (N); Analyze (N); -- Prev is the previous entity with the same name, but it is can @@ -581,7 +586,7 @@ package body Sem_Ch6 is ("(Ada 2005) cannot copy object of a limited type " & "(RM-2005 6.5(5.5/2))", Expr); - if Is_Immutably_Limited_Type (R_Type) then + if Is_Limited_View (R_Type) then Error_Msg_N ("\return by reference not permitted in Ada 2005", Expr); end if; @@ -601,7 +606,7 @@ package body Sem_Ch6 is ("return of limited object not permitted in Ada 2005 " & "(RM-2005 6.5(5.5/2))?y?", Expr); - elsif Is_Immutably_Limited_Type (R_Type) then + elsif Is_Limited_View (R_Type) then Error_Msg_N ("return by reference not permitted in Ada 2005 " & "(RM-2005 6.5(5.5/2))?y?", Expr); @@ -875,7 +880,7 @@ package body Sem_Ch6 is ("aliased only allowed for limited" & " return objects in Ada 2012?", N); - elsif not Is_Immutably_Limited_Type (R_Type) then + elsif not Is_Limited_View (R_Type) then Error_Msg_N ("aliased only allowed for limited" & " return objects", N); end if; @@ -958,7 +963,7 @@ package body Sem_Ch6 is -- check the static cases. if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L) - and then Is_Immutably_Limited_Type (Etype (Scope_Id)) + and then Is_Limited_View (Etype (Scope_Id)) and then Object_Access_Level (Expr) > Subprogram_Access_Level (Scope_Id) then @@ -1104,7 +1109,7 @@ package body Sem_Ch6 is -- Visible generic entity is callable within its own body Set_Ekind (Gen_Id, Ekind (Body_Id)); - Set_Contract (Body_Id, Empty); + Set_Contract (Body_Id, Make_Contract (Sloc (Body_Id))); Set_Ekind (Body_Id, E_Subprogram_Body); Set_Convention (Body_Id, Convention (Gen_Id)); Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id)); @@ -1140,13 +1145,14 @@ package body Sem_Ch6 is Set_Actual_Subtypes (N, Current_Scope); - -- Deal with preconditions and postconditions. In formal verification - -- mode, we keep pre- and postconditions attached to entities rather - -- than inserted in the code, in order to facilitate a distinct - -- treatment for them. + -- Deal with [refined] preconditions, postconditions, Contract_Cases, + -- invariants and predicates associated with the body and its spec. + -- Note that this is not pure expansion as Expand_Subprogram_Contract + -- prepares the contract assertions for generic subprograms or for + -- ASIS. Do not generate contract checks in SPARK mode. if not SPARK_Mode then - Process_PPCs (N, Gen_Id, Body_Id); + Expand_Subprogram_Contract (N, Gen_Id, Body_Id); end if; -- If the generic unit carries pre- or post-conditions, copy them @@ -1965,6 +1971,79 @@ 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 + Body_Decl : constant Node_Id := Parent (Parent (Body_Id)); + Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl); + Prag : Node_Id; + Ref_Depends : Node_Id := Empty; + Ref_Global : Node_Id := Empty; + + begin + -- When a subprogram body declaration is erroneous, its defining entity + -- is left unanalyzed. There is nothing left to do in this case because + -- the body lacks a contract. + + if not Analyzed (Body_Id) then + return; + end if; + + -- Locate and store pragmas Refined_Depends and Refined_Global since + -- their order of analysis matters. + + Prag := Classifications (Contract (Body_Id)); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Refined_Depends then + Ref_Depends := Prag; + elsif Pragma_Name (Prag) = 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); + + -- When the corresponding Global aspect/pragma references a state with + -- visible refinement, the body requires Refined_Global. + + elsif Present (Spec_Id) then + Prag := Get_Pragma (Spec_Id, Pragma_Global); + + if Present (Prag) and then Contains_Refined_State (Prag) then + Error_Msg_NE + ("body of subprogram & requires global refinement", + Body_Decl, Spec_Id); + end if; + 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); + + -- When the corresponding Depends aspect/pragma references a state with + -- visible refinement, the body requires Refined_Depends. + + elsif Present (Spec_Id) then + Prag := Get_Pragma (Spec_Id, Pragma_Depends); + + if Present (Prag) and then Contains_Refined_State (Prag) then + Error_Msg_NE + ("body of subprogram & requires dependance refinement", + Body_Decl, Spec_Id); + end if; + end if; + end Analyze_Subprogram_Body_Contract; + ------------------------------------ -- Analyze_Subprogram_Body_Helper -- ------------------------------------ @@ -2421,7 +2500,7 @@ package body Sem_Ch6 is begin if Ekind (Typ) = E_Incomplete_Type - and then From_With_Type (Typ) + and then From_Limited_With (Typ) and then Present (Non_Limited_View (Typ)) then Set_Etype (Id, Non_Limited_View (Typ)); @@ -2672,20 +2751,30 @@ package body Sem_Ch6 is end if; end if; - -- Language-defined aspects cannot appear in a subprogram body if the - -- corresponding spec already has aspects. Exception to this rule are - -- certain user-defined aspects. Aspects that apply to a body stub are - -- moved to the proper body. Do not emit an error in this case. + -- Language-defined aspects cannot appear in a subprogram body [stub] if + -- the subprogram has a separate spec. Certainly implementation-defined + -- aspects are allowed to appear (per Aspects_On_Body_Of_Stub_OK). if Has_Aspects (N) then if Present (Spec_Id) - and then Nkind (N) not in N_Body_Stub - and then Nkind (Parent (N)) /= N_Subunit - and then not Aspects_On_Body_OK (N) + and then not Aspects_On_Body_Or_Stub_OK (N) + + -- Do not emit an error on a subprogram body stub that act as + -- its own spec. + + and then Nkind (Parent (Parent (Spec_Id))) /= N_Subprogram_Body_Stub then Error_Msg_N ("aspect specifications must appear in subprogram declaration", - N); + N); + + -- Delay the analysis of aspect specifications that apply to a body + -- stub until the proper body is analyzed. If the corresponding body + -- is missing, the aspects are still analyzed in Analyze_Proper_Body. + + elsif Nkind (N) in N_Body_Stub then + null; + else Analyze_Aspect_Specifications (N, Body_Id); end if; @@ -2835,7 +2924,12 @@ package body Sem_Ch6 is Reference_Body_Formals (Spec_Id, Body_Id); end if; - if Nkind (N) /= N_Subprogram_Body_Stub then + if Nkind (N) = N_Subprogram_Body_Stub then + Set_Corresponding_Spec_Of_Stub (N, Spec_Id); + + -- Regular body + + else Set_Corresponding_Spec (N, Spec_Id); -- Ada 2005 (AI-345): If the operation is a primitive operation @@ -2852,12 +2946,9 @@ package body Sem_Ch6 is and then Present (First_Entity (Spec_Id)) and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type and then Is_Tagged_Type (Etype (First_Entity (Spec_Id))) - and then - Present (Interfaces (Etype (First_Entity (Spec_Id)))) - and then - Present - (Corresponding_Concurrent_Type - (Etype (First_Entity (Spec_Id)))) + and then Present (Interfaces (Etype (First_Entity (Spec_Id)))) + and then Present (Corresponding_Concurrent_Type + (Etype (First_Entity (Spec_Id)))) then declare Typ : constant Entity_Id := Etype (First_Entity (Spec_Id)); @@ -2905,7 +2996,7 @@ package body Sem_Ch6 is end if; Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id); - Set_Contract (Body_Id, Empty); + Set_Contract (Body_Id, Make_Contract (Sloc (Body_Id))); Set_Ekind (Body_Id, E_Subprogram_Body); Set_Scope (Body_Id, Scope (Spec_Id)); Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id)); @@ -2967,7 +3058,9 @@ package body Sem_Ch6 is if Ekind (Rtyp) = E_Anonymous_Access_Type then Etyp := Directly_Designated_Type (Rtyp); - if Is_Class_Wide_Type (Etyp) and then From_With_Type (Etyp) then + if Is_Class_Wide_Type (Etyp) + and then From_Limited_With (Etyp) + then Set_Directly_Designated_Type (Etype (Current_Scope), Available_View (Etyp)); end if; @@ -3089,13 +3182,14 @@ package body Sem_Ch6 is HSS := Handled_Statement_Sequence (N); Set_Actual_Subtypes (N, Current_Scope); - -- Deal with preconditions and postconditions. In formal verification - -- mode, we keep pre- and postconditions attached to entities rather - -- than inserted in the code, in order to facilitate a distinct - -- treatment for them. + -- Deal with [refined] preconditions, postconditions, Contract_Cases, + -- invariants and predicates associated with the body and its spec. + -- Note that this is not pure expansion as Expand_Subprogram_Contract + -- prepares the contract assertions for generic subprograms or for ASIS. + -- Do not generate contract checks in SPARK mode. if not SPARK_Mode then - Process_PPCs (N, Spec_Id, Body_Id); + Expand_Subprogram_Contract (N, Spec_Id, Body_Id); end if; -- Add a declaration for the Protection object, renaming declarations @@ -3505,23 +3599,23 @@ package body Sem_Ch6 is -- Local variables Items : constant Node_Id := Contract (Subp); - Error_CCase : Node_Id; - Error_Post : Node_Id; + Depends : Node_Id := Empty; + Error_CCase : Node_Id := Empty; + Error_Post : Node_Id := Empty; + Global : Node_Id := Empty; + Nam : Name_Id; Prag : Node_Id; -- Start of processing for Analyze_Subprogram_Contract begin - Error_CCase := Empty; - Error_Post := Empty; - if Present (Items) then -- Analyze pre- and postconditions Prag := Pre_Post_Conditions (Items); while Present (Prag) loop - Analyze_PPC_In_Decl_Part (Prag, Subp); + Analyze_Pre_Post_Condition_In_Decl_Part (Prag, Subp); -- Verify whether a postcondition mentions attribute 'Result and -- its expression introduces a post-state. @@ -3539,7 +3633,9 @@ package body Sem_Ch6 is Prag := Contract_Test_Cases (Items); while Present (Prag) loop - if Pragma_Name (Prag) = Name_Contract_Cases then + Nam := Pragma_Name (Prag); + + if Nam = Name_Contract_Cases then Analyze_Contract_Cases_In_Decl_Part (Prag); -- Verify whether contract-cases mention attribute 'Result and @@ -3553,7 +3649,7 @@ package body Sem_Ch6 is end if; else - pragma Assert (Pragma_Name (Prag) = Name_Test_Case); + pragma Assert (Nam = Name_Test_Case); Analyze_Test_Case_In_Decl_Part (Prag, Subp); end if; @@ -3564,15 +3660,30 @@ package body Sem_Ch6 is Prag := Classifications (Contract (Subp)); while Present (Prag) loop - if Pragma_Name (Prag) = Name_Depends then - Analyze_Depends_In_Decl_Part (Prag); - else - pragma Assert (Pragma_Name (Prag) = Name_Global); - Analyze_Global_In_Decl_Part (Prag); + Nam := Pragma_Name (Prag); + + if Nam = Name_Depends then + Depends := Prag; + else pragma Assert (Nam = Name_Global); + 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; end if; -- Emit an error when none of the postconditions or contract-cases @@ -6438,7 +6549,9 @@ package body Sem_Ch6 is then Set_Has_Delayed_Freeze (Designator); - elsif Ekind (T) = E_Incomplete_Type and then From_With_Type (T) then + elsif Ekind (T) = E_Incomplete_Type + and then From_Limited_With (T) + then Set_Has_Delayed_Freeze (Designator); -- AI05-0151: In Ada 2012, Incomplete types can appear in the profile @@ -6480,7 +6593,7 @@ package body Sem_Ch6 is Typ : constant Entity_Id := Etype (Designator); Utyp : constant Entity_Id := Underlying_Type (Typ); begin - if Is_Immutably_Limited_Type (Typ) then + if Is_Limited_View (Typ) then Set_Returns_By_Ref (Designator); elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Designator); @@ -7602,14 +7715,14 @@ package body Sem_Ch6 is -- access-to-class-wide type in a formal. Both entities designate the -- same type. - if From_With_Type (T1) and then T2 = Available_View (T1) then + if From_Limited_With (T1) and then T2 = Available_View (T1) then return True; - elsif From_With_Type (T2) and then T1 = Available_View (T2) then + elsif From_Limited_With (T2) and then T1 = Available_View (T2) then return True; - elsif From_With_Type (T1) - and then From_With_Type (T2) + elsif From_Limited_With (T1) + and then From_Limited_With (T2) and then Available_View (T1) = Available_View (T2) then return True; @@ -8103,7 +8216,8 @@ package body Sem_Ch6 is -- the designated type comes from the limited view (for back-end -- purposes). - Set_From_With_Type (Formal_Typ, From_With_Type (Result_Subt)); + Set_From_Limited_With + (Formal_Typ, From_Limited_With (Result_Subt)); Layout_Type (Formal_Typ); @@ -9100,7 +9214,12 @@ package body Sem_Ch6 is Iface_Prim : Entity_Id; Prim : Entity_Id) return Boolean is - Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim); + -- The operation may in fact be an inherited (implicit) operation + -- rather than the original interface primitive, so retrieve the + -- ultimate ancestor. + + Iface : constant Entity_Id := + Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)); Typ : constant Entity_Id := Find_Dispatching_Type (Prim); function Controlling_Formal (Prim : Entity_Id) return Entity_Id; @@ -9111,9 +9230,10 @@ package body Sem_Ch6 is ------------------------ function Controlling_Formal (Prim : Entity_Id) return Entity_Id is - E : Entity_Id := First_Entity (Prim); + E : Entity_Id; begin + E := First_Entity (Prim); while Present (E) loop if Is_Formal (E) and then Is_Controlling_Formal (E) then return E; @@ -9158,8 +9278,8 @@ package body Sem_Ch6 is -- The mode of the controlling formals must match elsif Present (Iface_Ctrl_F) - and then Present (Prim_Ctrl_F) - and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F) + and then Present (Prim_Ctrl_F) + and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F) then return False; @@ -9185,7 +9305,7 @@ package body Sem_Ch6 is return False; else return - Type_Conformant (Prim, Iface_Prim, + Type_Conformant (Prim, Ultimate_Alias (Iface_Prim), Skip_Controlling_Formals => True); end if; @@ -10203,8 +10323,7 @@ package body Sem_Ch6 is and then In_Private_Part (Current_Scope) then Priv_Decls := - Private_Declarations - (Specification (Unit_Declaration_Node (Current_Scope))); + Private_Declarations (Package_Specification (Current_Scope)); return In_Package_Body (Current_Scope) or else @@ -10832,7 +10951,7 @@ package body Sem_Ch6 is First_Out_Param : Entity_Id := Empty; -- Used for setting Is_Only_Out_Parameter - function Designates_From_With_Type (Typ : Entity_Id) return Boolean; + function Designates_From_Limited_With (Typ : Entity_Id) return Boolean; -- Determine whether an access type designates a type coming from a -- limited view. @@ -10841,11 +10960,11 @@ package body Sem_Ch6 is -- default has the type of the formal, so we must also check explicitly -- for an access attribute. - ------------------------------- - -- Designates_From_With_Type -- - ------------------------------- + ---------------------------------- + -- Designates_From_Limited_With -- + ---------------------------------- - function Designates_From_With_Type (Typ : Entity_Id) return Boolean is + function Designates_From_Limited_With (Typ : Entity_Id) return Boolean is Desig : Entity_Id := Typ; begin @@ -10858,8 +10977,9 @@ package body Sem_Ch6 is end if; return - Ekind (Desig) = E_Incomplete_Type and then From_With_Type (Desig); - end Designates_From_With_Type; + Ekind (Desig) = E_Incomplete_Type + and then From_Limited_With (Desig); + end Designates_From_Limited_With; --------------------------- -- Is_Class_Wide_Default -- @@ -10917,7 +11037,7 @@ package body Sem_Ch6 is if Is_Tagged_Type (Formal_Type) then if Ekind (Scope (Current_Scope)) = E_Package - and then not From_With_Type (Formal_Type) + and then not From_Limited_With (Formal_Type) and then not Is_Generic_Type (Formal_Type) and then not Is_Class_Wide_Type (Formal_Type) then @@ -11100,7 +11220,7 @@ package body Sem_Ch6 is -- is also class-wide. if Ekind (Formal_Type) = E_Anonymous_Access_Type - and then not Designates_From_With_Type (Formal_Type) + and then not Designates_From_Limited_With (Formal_Type) and then Is_Class_Wide_Default (Default) and then not Is_Class_Wide_Type (Designated_Type (Formal_Type)) then @@ -11214,841 +11334,6 @@ package body Sem_Ch6 is end if; end Process_Formals; - ------------------ - -- Process_PPCs -- - ------------------ - - procedure Process_PPCs - (N : Node_Id; - Spec_Id : Entity_Id; - Body_Id : Entity_Id) - is - Loc : constant Source_Ptr := Sloc (N); - Prag : Node_Id; - Parms : List_Id; - - Designator : Entity_Id; - -- Subprogram designator, set from Spec_Id if present, else Body_Id - - Precond : Node_Id := Empty; - -- Set non-Empty if we prepend precondition to the declarations. This - -- is used to hook up inherited preconditions (adding the condition - -- expression with OR ELSE, and adding the message). - - Inherited_Precond : Node_Id; - -- Precondition inherited from parent subprogram - - Inherited : constant Subprogram_List := - Inherited_Subprograms (Spec_Id); - -- List of subprograms inherited by this subprogram - - Plist : List_Id := No_List; - -- List of generated 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 Check_Access_Invariants (E : Entity_Id); - -- If the subprogram returns an access to a type with invariants, or - -- has access parameters whose designated type has an invariant, then - -- under the same visibility conditions as for other invariant checks, - -- the type invariant must be applied to the returned value. - - function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id; - -- Prag contains an analyzed precondition or postcondition pragma. This - -- function copies the pragma, changes it to the corresponding Check - -- pragma and returns the Check pragma as the result. If Pspec is non- - -- empty, this is the case of inheriting a PPC, where we must change - -- references to parameters of the inherited subprogram to point to the - -- corresponding parameters of the current subprogram. - - function Has_Checked_Predicate (Typ : Entity_Id) return Boolean; - -- Determine whether type Typ has or inherits at least one predicate - -- aspect or pragma, for which the applicable policy is Checked. - - 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. - - procedure Insert_After_Last_Declaration (Nod : Node_Id); - -- Insert node Nod after the last declaration of the context - - function Is_Public_Subprogram_For (T : Entity_Id) return Boolean; - -- T is the entity for a private type for which invariants are defined. - -- This function returns True if the procedure corresponding to the - -- value of Designator is a public procedure from the point of view of - -- this type (i.e. its spec is in the visible part of the package that - -- contains the declaration of the private type). A True value means - -- that an invariant check is required (for an IN OUT parameter, or - -- the returned value of a function. - - ------------------------- - -- 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; - - -- Add the item - - else - if No (List) then - List := New_List; - end if; - - Append (Item, List); - end if; - end Append_Enabled_Item; - - ----------------------------- - -- Check_Access_Invariants -- - ----------------------------- - - procedure Check_Access_Invariants (E : Entity_Id) is - Call : Node_Id; - Obj : Node_Id; - Typ : Entity_Id; - - begin - if Is_Access_Type (Etype (E)) - and then not Is_Access_Constant (Etype (E)) - then - Typ := Designated_Type (Etype (E)); - - if Has_Invariants (Typ) - and then Present (Invariant_Procedure (Typ)) - and then not Has_Null_Body (Invariant_Procedure (Typ)) - and then Is_Public_Subprogram_For (Typ) - then - Obj := - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (E, Loc)); - Set_Etype (Obj, Typ); - - Call := Make_Invariant_Call (Obj); - - Append_Enabled_Item - (Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => Make_Null (Loc), - Right_Opnd => New_Occurrence_Of (E, Loc)), - Then_Statements => New_List (Call)), - List => Plist); - end if; - end if; - end Check_Access_Invariants; - - -------------- - -- Grab_PPC -- - -------------- - - function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id is - Nam : constant Name_Id := Pragma_Name (Prag); - Map : Elist_Id; - CP : Node_Id; - - Ename : Name_Id; - -- Effective name of pragma (maybe Pre/Post rather than Precondition/ - -- Postcodition if the pragma came from a Pre/Post aspect). We need - -- the name right when we generate the Check pragma, since we want - -- the right set of check policies to apply. - - begin - -- Prepare map if this is the case where we have to map entities of - -- arguments in the overridden subprogram to corresponding entities - -- of the current subprogram. - - if No (Pspec) then - Map := No_Elist; - - else - declare - PF : Entity_Id; - CF : Entity_Id; - - begin - Map := New_Elmt_List; - PF := First_Formal (Pspec); - CF := First_Formal (Designator); - while Present (PF) loop - Append_Elmt (PF, Map); - Append_Elmt (CF, Map); - Next_Formal (PF); - Next_Formal (CF); - end loop; - end; - end if; - - -- Now we can copy the tree, doing any required substitutions - - CP := New_Copy_Tree (Prag, Map => Map, New_Scope => Current_Scope); - - -- Set Analyzed to false, since we want to reanalyze the check - -- procedure. Note that it is only at the outer level that we - -- do this fiddling, for the spec cases, the already preanalyzed - -- parameters are not affected. - - Set_Analyzed (CP, False); - - -- We also make sure Comes_From_Source is False for the copy - - Set_Comes_From_Source (CP, False); - - -- For a postcondition pragma within a generic, preserve the pragma - -- for later expansion. This is also used when an error was detected, - -- thus setting Expander_Active to False. - - if Nam = Name_Postcondition - and then not Expander_Active - then - return CP; - end if; - - -- Get effective name of aspect - - if Present (Corresponding_Aspect (Prag)) then - Ename := Chars (Identifier (Corresponding_Aspect (Prag))); - else - Ename := Nam; - end if; - - -- Change copy of pragma into corresponding pragma Check - - Prepend_To (Pragma_Argument_Associations (CP), - Make_Pragma_Argument_Association (Sloc (Prag), - Expression => Make_Identifier (Loc, Ename))); - Set_Pragma_Identifier (CP, Make_Identifier (Sloc (Prag), Name_Check)); - - -- If this is inherited case and the current message starts with - -- "failed p", we change it to "failed inherited p...". - - if Present (Pspec) then - declare - Msg : constant Node_Id := - Last (Pragma_Argument_Associations (CP)); - - begin - if Chars (Msg) = Name_Message then - String_To_Name_Buffer (Strval (Expression (Msg))); - - if Name_Buffer (1 .. 8) = "failed p" then - Insert_Str_In_Name_Buffer ("inherited ", 8); - Set_Strval - (Expression (Last (Pragma_Argument_Associations (CP))), - String_From_Name_Buffer); - end if; - end if; - end; - end if; - - -- Return the check pragma - - return CP; - end Grab_PPC; - - --------------------------- - -- Has_Checked_Predicate -- - --------------------------- - - function Has_Checked_Predicate (Typ : Entity_Id) return Boolean is - Anc : Entity_Id; - Pred : Node_Id; - - begin - -- Climb the ancestor type chain staring from the input. This is done - -- because the input type may lack aspect/pragma predicate and simply - -- inherit those from its ancestor. - - -- Note that predicate pragmas include all three cases of predicate - -- aspects (Predicate, Dynamic_Predicate, Static_Predicate), so this - -- routine checks for all three cases. - - Anc := Typ; - while Present (Anc) loop - Pred := Get_Pragma (Anc, Pragma_Predicate); - - if Present (Pred) and then not Is_Ignored (Pred) then - return True; - end if; - - Anc := Nearest_Ancestor (Anc); - end loop; - - return False; - end Has_Checked_Predicate; - - ------------------- - -- 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; - - ----------------------------------- - -- Insert_After_Last_Declaration -- - ----------------------------------- - - procedure Insert_After_Last_Declaration (Nod : Node_Id) is - Decls : constant List_Id := Declarations (N); - - begin - if No (Decls) then - Set_Declarations (N, New_List (Nod)); - else - Append_To (Decls, Nod); - end if; - end Insert_After_Last_Declaration; - - ------------------------------ - -- Is_Public_Subprogram_For -- - ------------------------------ - - -- The type T is a private type, its declaration is therefore in - -- the list of public declarations of some package. The test for a - -- public subprogram is that its declaration is in this same list - -- of declarations for the same package (note that all the public - -- declarations are in one list, and all the private declarations - -- in another, so this deals with the public/private distinction). - - function Is_Public_Subprogram_For (T : Entity_Id) return Boolean is - DD : constant Node_Id := Unit_Declaration_Node (Designator); - -- The subprogram declaration for the subprogram in question - - TL : constant List_Id := - Visible_Declarations - (Specification (Unit_Declaration_Node (Scope (T)))); - -- The list of declarations containing the private declaration of - -- the type. We know it is a private type, so we know its scope is - -- the package in question, and we know it must be in the visible - -- declarations of this package. - - begin - -- If the subprogram declaration is not a list member, it must be - -- an Init_Proc, in which case we want to consider it to be a - -- public subprogram, since we do get initializations to deal with. - -- Other internally generated subprograms are not public. - - if not Is_List_Member (DD) - and then Is_Init_Proc (Defining_Entity (DD)) - then - return True; - - -- The declaration may have been generated for an expression function - -- so check whether that function comes from source. - - elsif not Comes_From_Source (DD) - and then - (Nkind (Original_Node (DD)) /= N_Expression_Function - or else not Comes_From_Source (Defining_Entity (DD))) - then - return False; - - -- Otherwise we test whether the subprogram is declared in the - -- visible declarations of the package containing the type. - - else - return TL = List_Containing (DD); - end if; - end Is_Public_Subprogram_For; - - -- Local variables - - Formal : Node_Id; - Formal_Typ : Entity_Id; - Func_Typ : Entity_Id; - Post_Proc : Entity_Id; - Result : Node_Id; - - -- Start of processing for Process_PPCs - - begin - -- Capture designator from spec if present, else from body - - if Present (Spec_Id) then - Designator := Spec_Id; - else - Designator := Body_Id; - end if; - - -- Do not process a predicate function as its body will contain a - -- recursive call to itself and blow up the stack. - - if Ekind (Designator) = E_Function - and then Is_Predicate_Function (Designator) - then - return; - - -- Internally generated subprograms, such as type-specific functions, - -- don't get assertion checks. - - elsif Get_TSS_Name (Designator) /= TSS_Null then - return; - end if; - - -- Grab preconditions from spec - - if Present (Spec_Id) then - - -- Loop through PPC pragmas from spec. Note that preconditions from - -- the body will be analyzed and converted when we scan the body - -- declarations below. - - Prag := Pre_Post_Conditions (Contract (Spec_Id)); - while Present (Prag) loop - if Pragma_Name (Prag) = Name_Precondition then - - -- For Pre (or Precondition pragma), we simply prepend the - -- pragma to the list of declarations right away so that it - -- will be executed at the start of the procedure. Note that - -- this processing reverses the order of the list, which is - -- what we want since new entries were chained to the head of - -- the list. There can be more than one precondition when we - -- use pragma Precondition. - - if not Class_Present (Prag) then - Prepend (Grab_PPC, Declarations (N)); - - -- For Pre'Class there can only be one pragma, and we save - -- it in Precond for now. We will add inherited Pre'Class - -- stuff before inserting this pragma in the declarations. - else - Precond := Grab_PPC; - end if; - end if; - - Prag := Next_Pragma (Prag); - end loop; - - -- Now deal with inherited preconditions - - for J in Inherited'Range loop - Prag := Pre_Post_Conditions (Contract (Inherited (J))); - - while Present (Prag) loop - if Pragma_Name (Prag) = Name_Precondition - and then Class_Present (Prag) - then - Inherited_Precond := Grab_PPC (Inherited (J)); - - -- No precondition so far, so establish this as the first - - if No (Precond) then - Precond := Inherited_Precond; - - -- Here we already have a precondition, add inherited one - - else - -- Add new precondition to old one using OR ELSE - - declare - New_Expr : constant Node_Id := - Get_Pragma_Arg - (Next (First (Pragma_Argument_Associations - (Inherited_Precond)))); - Old_Expr : constant Node_Id := - Get_Pragma_Arg - (Next (First (Pragma_Argument_Associations - (Precond)))); - - begin - if Paren_Count (Old_Expr) = 0 then - Set_Paren_Count (Old_Expr, 1); - end if; - - if Paren_Count (New_Expr) = 0 then - Set_Paren_Count (New_Expr, 1); - end if; - - Rewrite (Old_Expr, - Make_Or_Else (Sloc (Old_Expr), - Left_Opnd => Relocate_Node (Old_Expr), - Right_Opnd => New_Expr)); - end; - - -- Add new message in the form: - - -- failed precondition from bla - -- also failed inherited precondition from bla - -- ... - - -- Skip this if exception locations are suppressed - - if not Exception_Locations_Suppressed then - declare - New_Msg : constant Node_Id := - Get_Pragma_Arg - (Last - (Pragma_Argument_Associations - (Inherited_Precond))); - Old_Msg : constant Node_Id := - Get_Pragma_Arg - (Last - (Pragma_Argument_Associations - (Precond))); - begin - Start_String (Strval (Old_Msg)); - Store_String_Chars (ASCII.LF & " also "); - Store_String_Chars (Strval (New_Msg)); - Set_Strval (Old_Msg, End_String); - end; - end if; - end if; - end if; - - Prag := Next_Pragma (Prag); - end loop; - end loop; - - -- If we have built a precondition for Pre'Class (including any - -- Pre'Class aspects inherited from parent subprograms), then we - -- insert this composite precondition at this stage. - - if Present (Precond) then - Prepend (Precond, Declarations (N)); - end if; - end if; - - -- Build postconditions procedure if needed and prepend the following - -- declaration to the start of the declarations for the subprogram. - - -- procedure _postconditions [(_Result : resulttype)] is - -- begin - -- pragma Check (Postcondition, condition [,message]); - -- pragma Check (Postcondition, condition [,message]); - -- ... - -- Invariant_Procedure (_Result) ... - -- Invariant_Procedure (Arg1) - -- ... - -- end; - - -- First we deal with the postconditions in the body - - if Is_Non_Empty_List (Declarations (N)) then - - -- Loop through declarations - - Prag := First (Declarations (N)); - while Present (Prag) loop - if Nkind (Prag) = N_Pragma then - - -- Capture postcondition pragmas - - if Pragma_Name (Prag) = Name_Postcondition then - Analyze (Prag); - - -- If expansion is disabled, as in a generic unit, save - -- pragma for later expansion. - - if not Expander_Active then - Prepend (Grab_PPC, Declarations (N)); - else - Append_Enabled_Item (Grab_PPC, Plist); - end if; - end if; - - Next (Prag); - - -- Not a pragma, if comes from source, then end scan - - elsif Comes_From_Source (Prag) then - exit; - - -- Skip stuff not coming from source - - else - Next (Prag); - end if; - end loop; - end if; - - -- Now deal with any postconditions from the spec - - if Present (Spec_Id) then - Spec_Postconditions : declare - procedure Process_Contract_Cases (Spec : Node_Id); - -- This processes the Contract_Test_Cases from Spec, processing - -- any contract-cases from the list. The caller has checked that - -- Contract_Test_Cases is non-Empty. - - procedure Process_Post_Conditions - (Spec : Node_Id; - Class : Boolean); - -- This processes the Pre_Post_Conditions from Spec, processing - -- any postconditions from the list. If Class is True, then only - -- postconditions marked with Class_Present are considered. The - -- caller has checked that Pre_Post_Conditions is non-Empty. - - ---------------------------- - -- Process_Contract_Cases -- - ---------------------------- - - procedure Process_Contract_Cases (Spec : Node_Id) is - begin - -- Loop through Contract_Cases pragmas from spec - - Prag := Contract_Test_Cases (Contract (Spec)); - loop - if Pragma_Name (Prag) = Name_Contract_Cases then - Expand_Contract_Cases - (CCs => Prag, - Subp_Id => Spec_Id, - Decls => Declarations (N), - Stmts => Plist); - end if; - - Prag := Next_Pragma (Prag); - exit when No (Prag); - end loop; - end Process_Contract_Cases; - - ----------------------------- - -- Process_Post_Conditions -- - ----------------------------- - - procedure Process_Post_Conditions - (Spec : Node_Id; - Class : Boolean) - is - Pspec : Node_Id; - - begin - if Class then - Pspec := Spec; - else - Pspec := Empty; - end if; - - -- Loop through PPC pragmas from spec - - Prag := Pre_Post_Conditions (Contract (Spec)); - loop - if Pragma_Name (Prag) = Name_Postcondition - and then (not Class or else Class_Present (Prag)) - then - if not Expander_Active then - Prepend (Grab_PPC (Pspec), Declarations (N)); - else - Append_Enabled_Item (Grab_PPC (Pspec), Plist); - end if; - end if; - - Prag := Next_Pragma (Prag); - exit when No (Prag); - end loop; - end Process_Post_Conditions; - - -- Start of processing for Spec_Postconditions - - begin - -- Process postconditions expressed as contract-cases - - if Present (Contract_Test_Cases (Contract (Spec_Id))) then - Process_Contract_Cases (Spec_Id); - end if; - - -- Process spec postconditions - - if Present (Pre_Post_Conditions (Contract (Spec_Id))) then - Process_Post_Conditions (Spec_Id, Class => False); - end if; - - -- Process inherited postconditions - - for J in Inherited'Range loop - if Present (Pre_Post_Conditions (Contract (Inherited (J)))) then - Process_Post_Conditions (Inherited (J), Class => True); - end if; - end loop; - end Spec_Postconditions; - end if; - - -- Add an invariant call to check the result of a function - - if Ekind (Designator) /= E_Procedure and then Expander_Active then - Func_Typ := Etype (Designator); - Result := Make_Defining_Identifier (Loc, Name_uResult); - - Set_Etype (Result, Func_Typ); - - -- Add argument for return - - Parms := New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Result, - Parameter_Type => New_Occurrence_Of (Func_Typ, Loc))); - - -- Add invariant call if returning type with invariants and this is a - -- public function, i.e. a function declared in the visible part of - -- the package defining the private type. - - if Has_Invariants (Func_Typ) - and then Present (Invariant_Procedure (Func_Typ)) - and then not Has_Null_Body (Invariant_Procedure (Func_Typ)) - and then Is_Public_Subprogram_For (Func_Typ) - then - Append_Enabled_Item - (Make_Invariant_Call (New_Occurrence_Of (Result, Loc)), Plist); - end if; - - -- Same if return value is an access to type with invariants - - Check_Access_Invariants (Result); - - -- Procedure case - - else - Parms := No_List; - end if; - - -- Add invariant calls and predicate calls for parameters. Note that - -- this is done for functions as well, since in Ada 2012 they can have - -- IN OUT args. - - if Expander_Active then - Formal := First_Formal (Designator); - while Present (Formal) loop - if Ekind (Formal) /= E_In_Parameter - or else Is_Access_Type (Etype (Formal)) - then - Formal_Typ := Etype (Formal); - - if Has_Invariants (Formal_Typ) - and then Present (Invariant_Procedure (Formal_Typ)) - and then not Has_Null_Body (Invariant_Procedure (Formal_Typ)) - and then Is_Public_Subprogram_For (Formal_Typ) - then - Append_Enabled_Item - (Make_Invariant_Call (New_Occurrence_Of (Formal, Loc)), - Plist); - end if; - - Check_Access_Invariants (Formal); - - if Has_Predicates (Formal_Typ) - and then Present (Predicate_Function (Formal_Typ)) - and then Has_Checked_Predicate (Formal_Typ) - then - Append_Enabled_Item - (Make_Predicate_Check - (Formal_Typ, New_Occurrence_Of (Formal, Loc)), - Plist); - end if; - end if; - - Next_Formal (Formal); - end loop; - end if; - - -- Build and insert postcondition procedure - - if Expander_Active and then Present (Plist) then - Post_Proc := - Make_Defining_Identifier (Loc, Chars => Name_uPostconditions); - - -- Insert the corresponding body of a post condition pragma after the - -- last declaration of the context. 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. - - Insert_After_Last_Declaration ( - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Post_Proc, - Parameter_Specifications => Parms), - - Declarations => Empty_List, - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Plist))); - - Set_Ekind (Post_Proc, E_Procedure); - - -- If this is a procedure, set the Postcondition_Proc attribute on - -- the proper defining entity for the subprogram. - - if Ekind (Designator) = E_Procedure then - Set_Postcondition_Proc (Designator, Post_Proc); - end if; - - Set_Has_Postconditions (Designator); - end if; - end Process_PPCs; - ---------------------------- -- Reference_Body_Formals -- ---------------------------- diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index d967c017ae0..fc0c365e06b 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -46,9 +46,21 @@ 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. The + -- aspects in question are: + -- Refined_Depends + -- Refined_Global + procedure Analyze_Subprogram_Contract (Subp : Entity_Id); -- Analyze all delayed aspects chained on the contract of subprogram Subp - -- as if they appeared at the end of a declarative region. + -- as if they appeared at the end of a declarative region. The aspects in + -- question are: + -- Contract_Cases + -- Postcondition + -- Precondition + -- Test_Case function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id; -- Analyze subprogram specification in both subprogram declarations diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index e06b6b997cf..76875b27afc 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -136,6 +136,11 @@ package body Sem_Ch7 is -- inherited private operation has been overridden, then it's replaced by -- the overriding operation. + procedure Unit_Requires_Body_Info (P : Entity_Id); + -- Outputs info messages showing why package specification P requires a + -- body. Caller has checked that the switch requesting this information + -- is set, and that the package does indeed require a body. + -------------------------- -- Analyze_Package_Body -- -------------------------- @@ -224,15 +229,10 @@ package body Sem_Ch7 is Body_Id := Defining_Entity (N); - if Has_Aspects (N) then - Analyze_Aspect_Specifications (N, Body_Id); - end if; + -- Body is body of package instantiation. Corresponding spec has already + -- been set. if Present (Corresponding_Spec (N)) then - - -- Body is body of package instantiation. Corresponding spec has - -- already been set. - Spec_Id := Corresponding_Spec (N); Pack_Decl := Unit_Declaration_Node (Spec_Id); @@ -315,6 +315,7 @@ package body Sem_Ch7 is Set_Ekind (Body_Id, E_Package_Body); Set_Body_Entity (Spec_Id, Body_Id); Set_Spec_Entity (Body_Id, Spec_Id); + Set_Contract (Body_Id, Make_Contract (Sloc (Body_Id))); -- Defining name for the package body is not a visible entity: Only the -- defining name for the declaration is visible. @@ -338,6 +339,10 @@ package body Sem_Ch7 is Set_Has_Completion (Spec_Id); Last_Spec_Entity := Last_Entity (Spec_Id); + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Body_Id); + end if; + Push_Scope (Spec_Id); Set_Categorization_From_Pragmas (N); @@ -770,6 +775,21 @@ package body Sem_Ch7 is -- True when this package declaration is not a nested declaration begin + if Debug_Flag_C then + Write_Str ("==> package spec "); + Write_Name (Chars (Id)); + Write_Str (" from "); + Write_Location (Sloc (N)); + Write_Eol; + Indent; + end if; + + Generate_Definition (Id); + Enter_Name (Id); + Set_Ekind (Id, E_Package); + Set_Etype (Id, Standard_Void_Type); + Set_Contract (Id, Make_Contract (Sloc (Id))); + -- Analyze aspect specifications immediately, since we need to recognize -- things like Pure early enough to diagnose violations during analysis. @@ -784,24 +804,10 @@ package body Sem_Ch7 is -- limited with Pkg; -- ERROR -- package Pkg is ... - if From_With_Type (Id) then + if From_Limited_With (Id) then return; end if; - if Debug_Flag_C then - Write_Str ("==> package spec "); - Write_Name (Chars (Id)); - Write_Str (" from "); - Write_Location (Sloc (N)); - Write_Eol; - Indent; - end if; - - Generate_Definition (Id); - Enter_Name (Id); - Set_Ekind (Id, E_Package); - Set_Etype (Id, Standard_Void_Type); - Push_Scope (Id); PF := Is_Pure (Enclosing_Lib_Unit_Entity); @@ -1167,6 +1173,11 @@ package body Sem_Ch7 is -- then finish off by looping through the nongeneric parents -- and installing their private declarations. + -- If one of the non-generic parents is itself on the scope + -- stack, do not install its private declarations: they are + -- installed in due time when the private part of that parent + -- is analyzed. This is delicate ??? + else while Present (Inst_Par) and then Inst_Par /= Standard_Standard @@ -1477,7 +1488,19 @@ package body Sem_Ch7 is Clear_Constants (Id, First_Private_Entity (Id)); end if; + -- Issue an error in SPARK mode if a package specification contains + -- more than one tagged type or type extension. + Check_One_Tagged_Type_Or_Extension_At_Most; + + -- If switch set, output information on why body required + + if List_Body_Required_Info + and then In_Extended_Main_Source_Unit (Id) + and then Unit_Requires_Body (Id) + then + Unit_Requires_Body_Info (Id); + end if; end Analyze_Package_Specification; -------------------------------------- @@ -1529,7 +1552,7 @@ package body Sem_Ch7 is E := First_Entity (Spec_Id); while Present (E) loop if Ekind (E) = E_Anonymous_Access_Type - and then From_With_Type (E) + and then From_Limited_With (E) then IR := Make_Itype_Reference (Sloc (P_Body)); Set_Itype (IR, E); @@ -1649,8 +1672,8 @@ package body Sem_Ch7 is and then No (Interface_Alias (Node (Op_Elmt_2))) then -- The private inherited operation has been - -- overridden by an explicit subprogram: replace - -- the former by the latter. + -- overridden by an explicit subprogram: + -- replace the former by the latter. New_Op := Node (Op_Elmt_2); Replace_Elmt (Op_Elmt, New_Op); @@ -2582,7 +2605,10 @@ package body Sem_Ch7 is -- Unit_Requires_Body -- ------------------------ - function Unit_Requires_Body (P : Entity_Id) return Boolean is + function Unit_Requires_Body + (P : Entity_Id; + Ignore_Abstract_State : Boolean := False) return Boolean + is E : Entity_Id; begin @@ -2621,12 +2647,17 @@ package body Sem_Ch7 is end; -- A [generic] package that introduces at least one non-null abstract - -- state requires completion. A null abstract state always appears as - -- the sole element of the state list. + -- state requires completion. However, there is a separate rule that + -- requires that such a package have a reason other than this for a + -- body being required (if necessary a pragma Elaborate_Body must be + -- provided). If Ignore_Abstract_State is True, we don't do this check + -- (so we can use Unit_Requires_Body to check for some other reason). elsif Ekind_In (P, E_Generic_Package, E_Package) + and then not Ignore_Abstract_State and then Present (Abstract_States (P)) - and then not Is_Null_State (Node (First_Elmt (Abstract_States (P)))) + and then + not Is_Null_State (Node (First_Elmt (Abstract_States (P)))) then return True; end if; @@ -2703,4 +2734,135 @@ package body Sem_Ch7 is return False; end Unit_Requires_Body; + ----------------------------- + -- Unit_Requires_Body_Info -- + ----------------------------- + + procedure Unit_Requires_Body_Info (P : Entity_Id) is + E : Entity_Id; + + begin + -- Imported entity never requires body. Right now, only subprograms can + -- be imported, but perhaps in the future we will allow import of + -- packages. + + if Is_Imported (P) then + return; + + -- Body required if library package with pragma Elaborate_Body + + elsif Has_Pragma_Elaborate_Body (P) then + Error_Msg_N + ("?Y?info: & requires body (Elaborate_Body)", P); + + -- Body required if subprogram + + elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then + Error_Msg_N ("?Y?info: & requires body (subprogram case)", P); + + -- Body required if generic parent has Elaborate_Body + + elsif Ekind (P) = E_Package + and then Nkind (Parent (P)) = N_Package_Specification + and then Present (Generic_Parent (Parent (P))) + then + declare + G_P : constant Entity_Id := Generic_Parent (Parent (P)); + begin + if Has_Pragma_Elaborate_Body (G_P) then + Error_Msg_N + ("?Y?info: & requires body (generic parent Elaborate_Body)", + P); + end if; + end; + + -- A [generic] package that introduces at least one non-null abstract + -- state requires completion. However, there is a separate rule that + -- requires that such a package have a reason other than this for a + -- body being required (if necessary a pragma Elaborate_Body must be + -- provided). If Ignore_Abstract_State is True, we don't do this check + -- (so we can use Unit_Requires_Body to check for some other reason). + + elsif Ekind_In (P, E_Generic_Package, E_Package) + and then Present (Abstract_States (P)) + and then + not Is_Null_State (Node (First_Elmt (Abstract_States (P)))) + then + Error_Msg_N + ("?Y?info: & requires body (non-null abstract state aspect)", + P); + end if; + + -- Otherwise search entity chain for entity requiring completion + + E := First_Entity (P); + while Present (E) loop + + -- Always ignore child units. Child units get added to the entity + -- list of a parent unit, but are not original entities of the + -- parent, and so do not affect whether the parent needs a body. + + if Is_Child_Unit (E) then + null; + + -- Ignore formal packages and their renamings + + elsif Ekind (E) = E_Package + and then Nkind (Original_Node (Unit_Declaration_Node (E))) = + N_Formal_Package_Declaration + then + null; + + -- Otherwise test to see if entity requires a completion. + -- Note that subprogram entities whose declaration does not come + -- from source are ignored here on the basis that we assume the + -- expander will provide an implicit completion at some point. + + elsif (Is_Overloadable (E) + and then Ekind (E) /= E_Enumeration_Literal + and then Ekind (E) /= E_Operator + and then not Is_Abstract_Subprogram (E) + and then not Has_Completion (E) + and then Comes_From_Source (Parent (E))) + + or else + (Ekind (E) = E_Package + and then E /= P + and then not Has_Completion (E) + and then Unit_Requires_Body (E)) + + or else + (Ekind (E) = E_Incomplete_Type + and then No (Full_View (E)) + and then not Is_Generic_Type (E)) + + or else + (Ekind_In (E, E_Task_Type, E_Protected_Type) + and then not Has_Completion (E)) + + or else + (Ekind (E) = E_Generic_Package + and then E /= P + and then not Has_Completion (E) + and then Unit_Requires_Body (E)) + + or else + (Is_Generic_Subprogram (E) + and then not Has_Completion (E)) + + then + Error_Msg_Node_2 := E; + Error_Msg_NE + ("?Y?info: & requires body (& requires completion)", + E, P); + + -- Entity that does not require completion + + else + null; + end if; + + Next_Entity (E); + end loop; + end Unit_Requires_Body_Info; end Sem_Ch7; diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads index 0445b242949..783fc57efa0 100644 --- a/gcc/ada/sem_ch7.ads +++ b/gcc/ada/sem_ch7.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -52,9 +52,18 @@ package Sem_Ch7 is -- but is deferred until the compilation of the private part of the -- child for public child packages. - function Unit_Requires_Body (P : Entity_Id) return Boolean; - -- Check if a unit requires a body. A specification requires a body - -- if it contains declarations that require completion in a body. + function Unit_Requires_Body + (P : Entity_Id; + Ignore_Abstract_State : Boolean := False) return Boolean; + -- Check if a unit requires a body. A specification requires a body if it + -- contains declarations that require completion in a body. If the flag + -- Ignore_Abstract_State is set True, then the test for a non-null abstract + -- state (which normally requires a body) is not carried out. This allows + -- the use of this routine to tell if there is some other reason that a + -- body is required (as is required for analyzing Abstract_State). This + -- is not currently used, but may be useful in future if we implement a + -- compatibility mode which warns about possible incompatibilities if a + -- SPARK 2014 program is compiled with a SPARK-unaware compiler. procedure May_Need_Implicit_Body (E : Entity_Id); -- If a package declaration contains tasks or RACWs and does not require diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 1e6470bf223..61d97667840 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -883,7 +883,7 @@ package body Sem_Ch8 is -- there is no copy involved and no performance hit. if Nkind (Nam) = N_Function_Call - and then Is_Immutably_Limited_Type (Etype (Nam)) + and then Is_Limited_View (Etype (Nam)) and then not Is_Constrained (Etype (Nam)) and then Comes_From_Source (N) then @@ -1208,11 +1208,22 @@ package body Sem_Ch8 is -- may have been rewritten in several ways. elsif Is_Object_Reference (Nam) then - if Comes_From_Source (N) - and then Is_Dependent_Component_Of_Mutable_Object (Nam) - then - Error_Msg_N - ("illegal renaming of discriminant-dependent component", Nam); + if Comes_From_Source (N) then + if Is_Dependent_Component_Of_Mutable_Object (Nam) then + Error_Msg_N + ("illegal renaming of discriminant-dependent component", Nam); + end if; + + -- If the renaming comes from source and the renamed object is a + -- dereference, then mark the prefix as needing debug information, + -- since it might have been rewritten hence internally generated + -- and Debug_Renaming_Declaration will link the renaming to it. + + if Nkind (Nam) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Nam)) + then + Set_Debug_Info_Needed (Entity (Prefix (Nam))); + end if; end if; -- A static function call may have been folded into a literal @@ -4093,7 +4104,7 @@ package body Sem_Ch8 is T := Entity (Id); - if T = Any_Type or else From_With_Type (T) then + if T = Any_Type or else From_Limited_With (T) then null; -- Note that the use_type clause may mention a subtype of the type @@ -4987,6 +4998,7 @@ package body Sem_Ch8 is if Comes_From_Source (N) and then Is_Remote_Access_To_Subprogram_Type (E) + and then Ekind (E) = E_Access_Subprogram_Type and then Expander_Active and then Get_PCS_Name /= Name_No_DSA then @@ -5061,9 +5073,14 @@ package body Sem_Ch8 is -- Entity is unambiguous, indicate that it is referenced here -- For a renaming of an object, always generate simple reference, - -- we don't try to keep track of assignments in this case. + -- we don't try to keep track of assignments in this case, except + -- in SPARK mode where renamings are traversed for generating + -- local effects of subprograms. - if Is_Object (E) and then Present (Renamed_Object (E)) then + if Is_Object (E) + and then Present (Renamed_Object (E)) + and then not SPARK_Mode + then Generate_Reference (E, N); -- If the renamed entity is a private protected component, @@ -5157,12 +5174,10 @@ package body Sem_Ch8 is Selector : constant Node_Id := Selector_Name (N); Candidate : Entity_Id := Empty; P_Name : Entity_Id; - O_Name : Entity_Id; Id : Entity_Id; begin P_Name := Entity (Prefix (N)); - O_Name := P_Name; -- If the prefix is a renamed package, look for the entity in the -- original package. @@ -5206,7 +5221,7 @@ package body Sem_Ch8 is -- The non-limited view may itself be incomplete, in which case -- get the full view if available. - elsif From_With_Type (Id) + elsif From_Limited_With (Id) and then Is_Type (Id) and then Ekind (Id) = E_Incomplete_Type and then Present (Non_Limited_View (Id)) @@ -5340,15 +5355,22 @@ package body Sem_Ch8 is else -- Within the instantiation of a child unit, the prefix may -- denote the parent instance, but the selector has the name - -- of the original child. Find whether we are within the - -- corresponding instance, and get the proper entity, which - -- can only be an enclosing scope. - - if O_Name /= P_Name - and then In_Open_Scopes (P_Name) + -- of the original child. That is to say, when A.B appears + -- within an instantiation of generic child unit B, the scope + -- stack includes an instance of A (P_Name) and an instance + -- of B under some other name. We scan the scope to find this + -- child instance, which is the desired entity. + -- Note that the parent may itself be a child instance, if + -- the reference is of the form A.B.C, in which case A.B has + -- already been rewritten with the proper entity. + + if In_Open_Scopes (P_Name) and then Is_Generic_Instance (P_Name) then declare + Gen_Par : constant Entity_Id := + Generic_Parent (Specification + (Unit_Declaration_Node (P_Name))); S : Entity_Id := Current_Scope; P : Entity_Id; @@ -5365,9 +5387,12 @@ package body Sem_Ch8 is P := Generic_Parent (Specification (Unit_Declaration_Node (S))); + -- Check that P is a generic child of the generic + -- parent of the prefix. + if Present (P) - and then Chars (Scope (P)) = Chars (O_Name) and then Chars (P) = Chars (Selector) + and then Scope (P) = Gen_Par then Id := S; goto Found; @@ -5480,6 +5505,7 @@ package body Sem_Ch8 is <<Found>> if Comes_From_Source (N) and then Is_Remote_Access_To_Subprogram_Type (Id) + and then Ekind (Id) = E_Access_Subprogram_Type and then Present (Equivalent_Type (Id)) then -- If we are not actually generating distribution code (i.e. the @@ -5493,8 +5519,8 @@ package body Sem_Ch8 is -- Ada 2005 (AI-50217): Check usage of entities in limited withed units - if Ekind (P_Name) = E_Package and then From_With_Type (P_Name) then - if From_With_Type (Id) + if Ekind (P_Name) = E_Package and then From_Limited_With (P_Name) then + if From_Limited_With (Id) or else Is_Type (Id) or else Ekind (Id) = E_Package then @@ -6302,7 +6328,7 @@ package body Sem_Ch8 is -- tagged if the type itself has an untagged incomplete -- type view in its package. - if From_With_Type (T) + if From_Limited_With (T) and then not Is_Tagged_Type (Available_View (T)) then Error_Msg_N @@ -6493,7 +6519,7 @@ package body Sem_Ch8 is -- Ada 2005 (AI-251, AI-50217): Handle interfaces visible through -- limited-with clauses - if From_With_Type (T_Name) + if From_Limited_With (T_Name) and then Ekind (T_Name) in Incomplete_Kind and then Present (Non_Limited_View (T_Name)) and then Is_Interface (Non_Limited_View (T_Name)) @@ -7071,7 +7097,7 @@ package body Sem_Ch8 is or else (Is_Private_Type (T1) and then Has_Discriminants (T1)) or else (Is_Task_Type (T1) and then Has_Discriminants (T1)) or else (Is_Incomplete_Type (T1) - and then From_With_Type (T1) + and then From_Limited_With (T1) and then Present (Non_Limited_View (T1)) and then Is_Record_Type (Get_Full_View (Non_Limited_View (T1)))); @@ -7852,7 +7878,7 @@ package body Sem_Ch8 is -- Ada 2005 (AI-50217): Check restriction - if From_With_Type (P) then + if From_Limited_With (P) then Error_Msg_N ("limited withed package cannot appear in use clause", N); end if; @@ -8175,7 +8201,7 @@ package body Sem_Ch8 is -- a limited view unless we only have a limited view of its enclosing -- package. - elsif From_With_Type (T) and then From_With_Type (Scope (T)) then + elsif From_Limited_With (T) and then From_Limited_With (Scope (T)) then Error_Msg_N ("incomplete type from limited view " & "cannot appear in use clause", Id); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 52dcb90d184..b7374ba8398 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -1736,16 +1736,16 @@ package body Sem_Ch9 is -- 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 user-defined - -- aspects. Plus we cannot possibly known the semantics of user-defined - -- aspects in order to plan ahead. + -- 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 - ("?user-defined aspects on protected bodies are not supported", N); + ("aspects on protected bodies are not allowed", + First (Aspect_Specifications (N))); - -- The aspects are removed for now to prevent cascading errors down - -- stream. + -- Remove illegal aspects to prevent cascaded errors later on Remove_Aspects (N); end if; @@ -2726,15 +2726,15 @@ package body Sem_Ch9 is -- 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 user-defined aspects. Plus we cannot possibly known the - -- semantics of user-defined aspects in order to plan ahead. + -- 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 - ("?user-defined aspects on task bodies are not supported", N); + ("aspects on task bodies are not allowed", + First (Aspect_Specifications (N))); - -- The aspects are removed for now to prevent cascading errors down - -- stream. + -- Remove illegal aspects to prevent cascaded errors later on Remove_Aspects (N); end if; @@ -2763,7 +2763,6 @@ package body Sem_Ch9 is then if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then Error_Msg_NE ("duplicate body for task type&", N, Spec_Id); - else Error_Msg_NE ("duplicate body for task&", N, Spec_Id); end if; diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 79c1e15037a..233e30168a2 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -2277,6 +2277,12 @@ package body Sem_Dim is Result := No_Rational; end if; + -- Provide minimal semantic information on dimension expressions, + -- even though they have no run-time existence. This is for use by + -- ASIS tools, in particular pretty-printing. + + Set_Entity (N, Standard_Op_Minus); + Set_Etype (N, Standard_Integer); return Result; end Process_Minus; @@ -2302,6 +2308,12 @@ package body Sem_Dim is Result := Left_Rat / Right_Rat; end if; + -- Provide minimal semantic information on dimension expressions, + -- even though they have no run-time existence. This is for use by + -- ASIS tools, in particular pretty-printing. + + Set_Entity (N, Standard_Op_Divide); + Set_Etype (N, Standard_Integer); return Result; end Process_Divide; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 9f80a7dcea1..7b815812a32 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -331,7 +331,7 @@ package body Sem_Disp is -- Ada 2005 (AI-50217) - elsif From_With_Type (Designated_Type (T)) + elsif From_Limited_With (Designated_Type (T)) and then Present (Non_Limited_View (Designated_Type (T))) and then Scope (Designated_Type (T)) = Scope (Subp) then diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 94ce100a7c5..99b6e775218 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1353,16 +1353,7 @@ package body Sem_Eval is if Ekind (E) = E_Enumeration_Literal then return True; - -- In SPARK mode, the value of deferred constants should be - -- ignored outside the scope of their full view. This allows - -- parameterized formal verification, in which a deferred constant - -- value if not known from client units. - - elsif Ekind (E) = E_Constant - and then not (SPARK_Mode - and then Present (Full_View (E)) - and then not In_Open_Scopes (Scope (E))) - then + elsif Ekind (E) = E_Constant then V := Constant_Value (E); return Present (V) and then Compile_Time_Known_Value (V); end if; @@ -5578,7 +5569,7 @@ package body Sem_Eval is then Error_Msg_N ("\aggregate (#) is never static", N); - elsif not Is_Static_Expression (CV) then + elsif No (CV) or else not Is_Static_Expression (CV) then Error_Msg_NE ("\& is not a static constant (RM 4.9(5))", N, E); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 8d716aa8454..19d88778715 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -75,7 +75,6 @@ with Stand; use Stand; with Sinfo; use Sinfo; with Sinfo.CN; use Sinfo.CN; with Sinput; use Sinput; -with Snames; use Snames; with Stringt; use Stringt; with Stylesw; use Stylesw; with Table; @@ -169,9 +168,9 @@ package body Sem_Prag is ------------------------------------- procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id); - -- Subsidiary routine to the analysis of pragmas Depends and Global. Append - -- an input or output item to a list. If the list is empty, a new one is - -- created. + -- 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 @@ -205,27 +204,49 @@ package body Sem_Prag is -- _Post, _Invariant, or _Type_Invariant, which are special names used -- in identifiers to represent these attribute references. + procedure Collect_Global_Items + (Prag : Node_Id; + In_Items : in out Elist_Id; + In_Out_Items : in out Elist_Id; + Out_Items : in out Elist_Id; + Has_In_State : out Boolean; + Has_In_Out_State : out Boolean; + Has_Out_State : out Boolean; + Has_Null_State : out Boolean); + -- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global. + -- Prag denotes pragma [Refined_]Global. Gather all input, in out and + -- output items of Prag in lists In_Items, In_Out_Items and Out_Items. + -- Flags Has_In_State, Has_In_Out_State and Has_Out_State are set when + -- there is at least one abstract state with visible refinement available + -- in the corresponding mode. Flag Has_Null_State is set when at least + -- state has a null refinement. + procedure Collect_Subprogram_Inputs_Outputs (Subp_Id : Entity_Id; Subp_Inputs : in out Elist_Id; Subp_Outputs : in out Elist_Id; Global_Seen : out Boolean); - -- Subsidiary to the analysis of pragma Global and pragma Depends. Gather - -- all inputs and outputs of subprogram Subp_Id in lists Subp_Inputs and - -- Subp_Outputs. If the case where the subprogram has no inputs and/or - -- outputs, the corresponding returned list is No_Elist. Flag Global_Seen - -- is set when the related subprogram has aspect/pragma Global. - - function Find_Related_Subprogram - (Prag : Node_Id; - Check_Duplicates : Boolean := False) return Node_Id; - -- Find the declaration of the related subprogram subject to pragma Prag. - -- If flag Check_Duplicates is set, the routine emits errors concerning - -- duplicate pragmas. If a related subprogram is found, then either the - -- corresponding N_Subprogram_Declaration node is returned, or, if the - -- pragma applies to a subprogram body, then the N_Subprogram_Body node - -- is returned. Note that in the latter case, no check is made to ensure - -- that there is no separate declaration of the subprogram. + -- Subsidiary to the analysis of pragma Depends, Global, Refined_Depends + -- and Refined_Global. Gather all inputs and outputs of subprogram Subp_Id + -- in lists Subp_Inputs and Subp_Outputs. If the case where the subprogram + -- has no inputs and/oroutputs, the returned list is No_Elist. Global_Seen + -- is set when the related subprogram has pragma [Refined_]Global. + + function Find_Related_Subprogram_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. 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. function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; -- If Def_Id refers to a renamed subprogram, then the base subprogram (the @@ -237,45 +258,49 @@ package body Sem_Prag is -- Get_SPARK_Mode_Id. Convert a name into a corresponding value of type -- SPARK_Mode_Id. - function Original_Name (N : Node_Id) return Name_Id; - -- N is a pragma node or aspect specification node. This function returns - -- the name of the pragma or aspect in original source form, taking into - -- account possible rewrites, and also cases where a pragma comes from an - -- aspect (in such cases, the name can be different from the pragma name, - -- e.g. a Pre aspect generates a Precondition pragma). This also deals with - -- the presence of 'Class, which results in one of the special names - -- Name_uPre, Name_uPost, Name_uInvariant, or Name_uType_Invariant being - -- returned to represent the corresponding aspects with x'Class names. + function Is_Part_Of + (State : Entity_Id; + Ancestor : Entity_Id) return Boolean; + -- Subsidiary to the processing of pragma Refined_Depends and pragma + -- Refined_Global. Determine whether abstract state State is part of an + -- ancestor abstract state Ancestor. For this relationship to hold, State + -- must have option Part_Of in its Abstract_State definition. + + 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 + -- tagged, unconstrained array, unconstrained record or a record with at + -- least one unconstrained component. procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id); -- Preanalyze the boolean expressions in the Requires and Ensures arguments -- of a Test_Case pragma if present (possibly Empty). We treat these as -- spec expressions (i.e. similar to a default expression). + procedure Record_Possible_Body_Reference + (Item : Node_Id; + Item_Id : Entity_Id); + -- Given an entity reference (Item) and the corresponding Entity (Item_Id), + -- determines if we have a body reference to an abstract state, which may + -- be illegal if the state is refined within the body. + procedure Rewrite_Assertion_Kind (N : Node_Id); -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class, -- then it is rewritten as an identifier with the corresponding special -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas -- Check, Check_Policy. + procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id); + -- Place semantic information on the argument of an Elaborate/Elaborate_All + -- pragma. Entity name for unit and its parents is taken from item in + -- previous with_clause that mentions the unit. + procedure rv; -- This is a dummy function called by the processing for pragma Reviewable. -- It is there for assisting front end debugging. By placing a Reviewable -- pragma in the source program, a breakpoint on rv catches this place in -- the source, allowing convenient stepping to the point of interest. - function Requires_Profile_Installation - (Prag : Node_Id; - Subp : Node_Id) return Boolean; - -- Subsidiary routine to the analysis of pragma Depends and pragma Global. - -- Determine whether the profile of subprogram Subp must be installed into - -- visibility to access its formals from pragma Prag. - - procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id); - -- Place semantic information on the argument of an Elaborate/Elaborate_All - -- pragma. Entity name for unit and its parents is taken from item in - -- previous with_clause that mentions the unit. - -------------- -- Add_Item -- -------------- @@ -286,7 +311,7 @@ package body Sem_Prag is To_List := New_Elmt_List; end if; - Append_Unique_Elmt (Item, To_List); + Append_Elmt (Item, To_List); end Add_Item; ------------------------------- @@ -402,20 +427,22 @@ package body Sem_Prag is -- Local variables - Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); All_Cases : Node_Id; CCase : Node_Id; Subp_Decl : Node_Id; Subp_Id : Entity_Id; + Restore_Scope : Boolean := False; + -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit + -- Start of processing for Analyze_Contract_Cases_In_Decl_Part begin Set_Analyzed (N); - Subp_Decl := Find_Related_Subprogram (N); - Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); - All_Cases := Expression (Arg1); + Subp_Decl := Find_Related_Subprogram_Or_Body (N); + Subp_Id := Defining_Entity (Subp_Decl); + All_Cases := Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); -- Multiple contract cases appear in aggregate form @@ -431,7 +458,8 @@ package body Sem_Prag is -- pertaining to subprogram declarations. Skip the installation -- for subprogram bodies because the formals are already visible. - if Requires_Profile_Installation (N, Subp_Decl) then + if not In_Open_Scopes (Subp_Id) then + Restore_Scope := True; Push_Scope (Subp_Id); Install_Formals (Subp_Id); end if; @@ -442,7 +470,7 @@ package body Sem_Prag is Next (CCase); end loop; - if Requires_Profile_Installation (N, Subp_Decl) then + if Restore_Scope then End_Scope; end if; end if; @@ -457,29 +485,33 @@ package body Sem_Prag is ---------------------------------- procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is - Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); All_Inputs_Seen : Elist_Id := No_Elist; -- A list containing the entities of all the inputs processed so far. - -- This Elist is populated with unique entities because the same input + -- The list is populated with unique entities because the same input -- may appear in multiple input lists. + All_Outputs_Seen : Elist_Id := No_Elist; + -- A list containing the entities of all the outputs processed so far. + -- The list is populated with unique entities because output items are + -- unique in a dependence relation. + Global_Seen : Boolean := False; -- A flag set when pragma Global has been processed - Outputs_Seen : Elist_Id := No_Elist; - -- A list containing the entities of all the outputs processed so far. - -- The elements of this list may come from different output lists. - Null_Output_Seen : Boolean := False; -- A flag used to track the legality of a null output Result_Seen : Boolean := False; -- A flag set when Subp_Id'Result is processed + Spec_Id : Entity_Id; + -- The entity of the subprogram subject to pragma [Refined_]Depends + Subp_Id : Entity_Id; - -- The entity of the subprogram subject to pragma Depends + -- The entity of the subprogram [body or stub] subject to pragma + -- [Refined_]Depends. Subp_Inputs : Elist_Id := No_Elist; Subp_Outputs : Elist_Id := No_Elist; @@ -500,12 +532,11 @@ package body Sem_Prag is Item_Id : Entity_Id; Is_Input : Boolean; Self_Ref : Boolean); - -- Ensure that an item has a proper "in", "in out" or "out" mode - -- depending on its function. If this is not the case, emit an error. - -- Item and Item_Id denote the attributes of an item. Flag Is_Input - -- should be set when item comes from an input list. Flag Self_Ref - -- should be set when the item is an output and the dependency clause - -- has operator "+". + -- Ensure that an item has a proper IN, IN OUT, or OUT mode depending + -- on its function. If this is not the case, emit an error. Item and + -- Item_Id denote the attributes of an item. Flag Is_Input should be set + -- when item comes from an input list. Flag Self_Ref should be set when + -- the item is an output and the dependency clause has operator "+". procedure Check_Usage (Subp_Items : Elist_Id; @@ -515,10 +546,9 @@ package body Sem_Prag is -- error if this is not the case. procedure Normalize_Clause (Clause : Node_Id); - -- Remove a self-dependency "+" from the input list of a clause. - -- Depending on the contents of the relation, either split the the - -- clause into multiple smaller clauses or perform the normalization in - -- place. + -- Remove a self-dependency "+" from the input list of a clause. Split + -- a clause with multiple outputs into multiple clauses with a single + -- output. ------------------------------- -- Analyze_Dependency_Clause -- @@ -532,12 +562,13 @@ package body Sem_Prag is -- Verify the legality of a single input list procedure Analyze_Input_Output - (Item : Node_Id; - Is_Input : Boolean; - Self_Ref : Boolean; - Top_Level : Boolean; - Seen : in out Elist_Id; - Null_Seen : in out Boolean); + (Item : Node_Id; + Is_Input : Boolean; + Self_Ref : Boolean; + Top_Level : Boolean; + Seen : in out Elist_Id; + Null_Seen : in out Boolean; + Non_Null_Seen : in out Boolean); -- Verify the legality of a single input or output item. Flag -- Is_Input should be set whenever Item is an input, False when it -- denotes an output. Flag Self_Ref should be set when the item is an @@ -545,7 +576,8 @@ package body Sem_Prag is -- be set whenever Item appears immediately within an input or output -- list. Seen is a collection of all abstract states, variables and -- formals processed so far. Flag Null_Seen denotes whether a null - -- input or output has been encountered. + -- input or output has been encountered. Flag Non_Null_Seen denotes + -- whether a non-null input or output has been encountered. ------------------------ -- Analyze_Input_List -- @@ -556,8 +588,9 @@ package body Sem_Prag is -- A list containing the entities of all inputs that appear in the -- current input list. - Null_Input_Seen : Boolean := False; - -- A flag used to track the legality of a null input + Non_Null_Input_Seen : Boolean := False; + Null_Input_Seen : Boolean := False; + -- Flags used to check the legality of an input list Input : Node_Id; @@ -573,12 +606,13 @@ package body Sem_Prag is Input := First (Expressions (Inputs)); while Present (Input) loop Analyze_Input_Output - (Item => Input, - Is_Input => True, - Self_Ref => False, - Top_Level => False, - Seen => Inputs_Seen, - Null_Seen => Null_Input_Seen); + (Item => Input, + Is_Input => True, + Self_Ref => False, + Top_Level => False, + Seen => Inputs_Seen, + Null_Seen => Null_Input_Seen, + Non_Null_Seen => Non_Null_Input_Seen); Next (Input); end loop; @@ -591,12 +625,13 @@ package body Sem_Prag is else Analyze_Input_Output - (Item => Inputs, - Is_Input => True, - Self_Ref => False, - Top_Level => False, - Seen => Inputs_Seen, - Null_Seen => Null_Input_Seen); + (Item => Inputs, + Is_Input => True, + Self_Ref => False, + Top_Level => False, + Seen => Inputs_Seen, + Null_Seen => Null_Input_Seen, + Non_Null_Seen => Non_Null_Input_Seen); end if; -- Detect an illegal dependency clause of the form @@ -615,12 +650,13 @@ package body Sem_Prag is -------------------------- procedure Analyze_Input_Output - (Item : Node_Id; - Is_Input : Boolean; - Self_Ref : Boolean; - Top_Level : Boolean; - Seen : in out Elist_Id; - Null_Seen : in out Boolean) + (Item : Node_Id; + Is_Input : Boolean; + Self_Ref : Boolean; + Top_Level : Boolean; + Seen : in out Elist_Id; + Null_Seen : in out Boolean; + Non_Null_Seen : in out Boolean) is Is_Output : constant Boolean := not Is_Input; Grouped : Node_Id; @@ -643,12 +679,13 @@ package body Sem_Prag is Grouped := First (Expressions (Item)); while Present (Grouped) loop Analyze_Input_Output - (Item => Grouped, - Is_Input => Is_Input, - Self_Ref => Self_Ref, - Top_Level => False, - Seen => Seen, - Null_Seen => Null_Seen); + (Item => Grouped, + Is_Input => Is_Input, + Self_Ref => Self_Ref, + Top_Level => False, + Seen => Seen, + Null_Seen => Null_Seen, + Non_Null_Seen => Non_Null_Seen); Next (Grouped); end loop; @@ -659,20 +696,20 @@ package body Sem_Prag is -- Process Function'Result in the context of a dependency clause - elsif Nkind (Item) = N_Attribute_Reference - and then Attribute_Name (Item) = Name_Result - then + elsif Is_Attribute_Result (Item) then + Non_Null_Seen := True; + -- It is sufficent to analyze the prefix of 'Result in order to -- establish legality of the attribute. Analyze (Prefix (Item)); -- The prefix of 'Result must denote the function for which - -- aspect/pragma Depends applies. + -- pragma Depends applies. if not Is_Entity_Name (Prefix (Item)) - or else Ekind (Subp_Id) /= E_Function - or else Entity (Prefix (Item)) /= Subp_Id + or else Ekind (Spec_Id) /= E_Function + or else Entity (Prefix (Item)) /= Spec_Id then Error_Msg_Name_1 := Name_Result; Error_Msg_N @@ -685,6 +722,10 @@ package body Sem_Prag is elsif Is_Input then Error_Msg_N ("function result cannot act as input", Item); + elsif Null_Seen then + Error_Msg_N + ("cannot mix null and non-null dependency items", Item); + else Result_Seen := True; end if; @@ -697,19 +738,39 @@ package body Sem_Prag is if Null_Seen then Error_Msg_N ("multiple null dependency relations not allowed", Item); + + elsif Non_Null_Seen then + Error_Msg_N + ("cannot mix null and non-null dependency items", Item); + else Null_Seen := True; - if Is_Output and then not Is_Last then - Error_Msg_N - ("null output list must be the last clause in a " - & "dependency relation", Item); + if Is_Output then + if not Is_Last then + Error_Msg_N + ("null output list must be the last clause in a " + & "dependency relation", Item); + + -- Catch a useless dependence of the form: + -- null =>+ ... + + elsif Self_Ref then + Error_Msg_N + ("useless dependence, null depends on itself", Item); + end if; end if; end if; -- Default case else + Non_Null_Seen := True; + + if Null_Seen then + Error_Msg_N ("cannot mix null and non-null items", Item); + end if; + Analyze (Item); -- Find the entity of the item. If this is a renaming, climb @@ -718,6 +779,8 @@ package body Sem_Prag is Item_Id := Entity_Of (Item); + Record_Possible_Body_Reference (Item, Item_Id); + if Present (Item_Id) then if Ekind_In (Item_Id, E_Abstract_State, E_In_Parameter, @@ -740,20 +803,56 @@ package body Sem_Prag is Add_Item (Item_Id, Seen); end if; - -- Detect an illegal use of an input related to a null - -- output. Such input items cannot appear in other input - -- lists. + -- Detect illegal use of an input related to a null + -- output. Such input items cannot appear in other + -- input lists. - if Null_Output_Seen + if Is_Input + and then Null_Output_Seen and then Contains (All_Inputs_Seen, Item_Id) then Error_Msg_N ("input of a null output list appears in multiple " & "input lists", Item); - else + end if; + + -- Add an input or a self-referential output to the list + -- of all processed inputs. + + if Is_Input or else Self_Ref then Add_Item (Item_Id, All_Inputs_Seen); end if; + if Ekind (Item_Id) = E_Abstract_State then + + -- The state acts as a constituent of some other + -- state. Ensure that the other state is a proper + -- ancestor of the item. + + if Present (Refined_State (Item_Id)) then + if not Is_Part_Of + (Item_Id, Refined_State (Item_Id)) + then + Error_Msg_Name_1 := + Chars (Refined_State (Item_Id)); + Error_Msg_NE + ("state & is not a valid constituent of " + & "ancestor state %", Item, Item_Id); + return; + end if; + + -- An abstract state with visible refinement cannot + -- appear in pragma [Refined_]Global as its place must + -- be taken by some of its constituents. + + elsif Has_Visible_Refinement (Item_Id) then + Error_Msg_NE + ("cannot mention state & in global refinement, " + & "use its constituents instead", Item, Item_Id); + return; + end if; + end if; + -- When the item renames an entire object, replace the -- item with a reference to the object. @@ -787,6 +886,9 @@ package body Sem_Prag is Output : Node_Id; Self_Ref : Boolean; + Non_Null_Output_Seen : Boolean := False; + -- Flag used to check the legality of an output list + -- Start of processing for Analyze_Dependency_Clause begin @@ -806,12 +908,13 @@ package body Sem_Prag is Output := First (Choices (Clause)); while Present (Output) loop Analyze_Input_Output - (Item => Output, - Is_Input => False, - Self_Ref => Self_Ref, - Top_Level => True, - Seen => Outputs_Seen, - Null_Seen => Null_Output_Seen); + (Item => Output, + Is_Input => False, + Self_Ref => Self_Ref, + Top_Level => True, + Seen => All_Outputs_Seen, + Null_Seen => Null_Output_Seen, + Non_Null_Seen => Non_Null_Output_Seen); Next (Output); end loop; @@ -827,10 +930,10 @@ package body Sem_Prag is procedure Check_Function_Return is begin - if Ekind (Subp_Id) = E_Function and then not Result_Seen then + if Ekind (Spec_Id) = E_Function and then not Result_Seen then Error_Msg_NE ("result of & must appear in exactly one output list", - N, Subp_Id); + N, Spec_Id); end if; end Check_Function_Return; @@ -848,20 +951,32 @@ package body Sem_Prag is -- Input if Is_Input then - if Ekind (Item_Id) = E_Out_Parameter - or else (Global_Seen - and then not Appears_In (Subp_Inputs, Item_Id)) + + -- IN and IN OUT parameters already have the proper mode to act + -- as input. OUT parameters are valid inputs only when their type + -- is unconstrained or tagged as their discriminants, array bouns + -- or tags can be read. In general, states and variables are + -- considered to have mode IN OUT unless they are classified by + -- pragma [Refined_]Global. In that case, the item must appear in + -- an input global list. + + if (Ekind (Item_Id) = E_Out_Parameter + and then not Is_Unconstrained_Or_Tagged_Item (Item_Id)) + or else + (Global_Seen and then not Appears_In (Subp_Inputs, Item_Id)) then Error_Msg_NE - ("item & must have mode in or in out", Item, Item_Id); + ("item & must have mode IN or `IN OUT`", Item, Item_Id); end if; -- Self-referential output elsif Self_Ref then - -- A self-referential state or variable must appear in both input - -- and output lists of a subprogram. + -- In general, states and variables are considered to have mode + -- IN OUT unless they are explicitly moded by pragma [Refined_] + -- Global. If this is the case, then the item must appear in both + -- an input and output global list. if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then if Global_Seen @@ -870,23 +985,41 @@ package body Sem_Prag is and then Appears_In (Subp_Outputs, Item_Id)) then - Error_Msg_NE ("item & must have mode in out", Item, Item_Id); + Error_Msg_NE + ("item & must have mode `IN OUT`", Item, Item_Id); end if; - -- Self-referential parameter + -- A self-referential OUT parameter of an unconstrained or tagged + -- type acts as an input because the discriminants, array bounds + -- or the tag may be read. Note that the presence of [Refined_] + -- Global is not significant here because the item is a parameter. + + elsif Ekind (Item_Id) = E_Out_Parameter + and then Is_Unconstrained_Or_Tagged_Item (Item_Id) + then + null; + + -- The remaining cases are IN, IN OUT, and OUT parameters. To + -- qualify as self-referential item, the parameter must be of + -- mode IN OUT. elsif Ekind (Item_Id) /= E_In_Out_Parameter then - Error_Msg_NE ("item & must have mode in out", Item, Item_Id); + Error_Msg_NE ("item & must have mode `IN OUT`", Item, Item_Id); end if; - -- Regular output + -- Output + + -- IN OUT and OUT parameters already have the proper mode to act as + -- output. In general, states and variables are considered to have + -- mode IN OUT unless they are moded by pragma [Refined_]Global. In + -- that case, the item must appear in an output global list. elsif Ekind (Item_Id) = E_In_Parameter or else (Global_Seen and then not Appears_In (Subp_Outputs, Item_Id)) then Error_Msg_NE - ("item & must have mode out or in out", Item, Item_Id); + ("item & must have mode OUT or `IN OUT`", Item, Item_Id); end if; end Check_Mode; @@ -984,6 +1117,11 @@ package body Sem_Prag is -- Flag Multiple should be set when Output comes from a list with -- multiple items. + procedure Split_Multiple_Outputs; + -- If Clause contains more than one output, split the clause into + -- multiple clauses with a single output. All new clauses are added + -- after Clause. + ----------------------------- -- Create_Or_Modify_Clause -- ----------------------------- @@ -1099,25 +1237,23 @@ package body Sem_Prag is -- Local variables - Loc : constant Source_Ptr := Sloc (Output); - Clause : Node_Id; + Loc : constant Source_Ptr := Sloc (Clause); + New_Clause : Node_Id; -- Start of processing for Create_Or_Modify_Clause begin - -- A function result cannot depend on itself because it cannot - -- appear in the input list of a relation. + -- A null output depending on itself does not require any + -- normalization. - if Nkind (Output) = N_Attribute_Reference - and then Attribute_Name (Output) = Name_Result - then - Error_Msg_N ("function result cannot depend on itself", Output); + if Nkind (Output) = N_Null then return; - -- A null output depending on itself does not require any - -- normalization. + -- A function result cannot depend on itself because it cannot + -- appear in the input list of a relation. - elsif Nkind (Output) = N_Null then + elsif Is_Attribute_Result (Output) then + Error_Msg_N ("function result cannot depend on itself", Output); return; end if; @@ -1144,16 +1280,15 @@ package body Sem_Prag is else -- Unchain the output from its output list as it will appear in -- a new clause. Note that we cannot simply rewrite the output - -- as null because this will violate the semantics of aspect or - -- pragma Depends. + -- as null because this will violate the semantics of pragma + -- Depends. Remove (Output); - -- Create a new clause of the form: - + -- Generate a new clause of the form: -- (Output => Inputs) - Clause := + New_Clause := Make_Component_Association (Loc, Choices => New_List (Output), Expression => New_Copy_Tree (Inputs)); @@ -1162,16 +1297,80 @@ package body Sem_Prag is -- been analyzed. There is not need to reanalyze it or -- renormalize it again. - Set_Analyzed (Clause); + Set_Analyzed (New_Clause); Propagate_Output - (Output => First (Choices (Clause)), - Inputs => Expression (Clause)); + (Output => First (Choices (New_Clause)), + Inputs => Expression (New_Clause)); - Insert_After (After, Clause); + Insert_After (After, New_Clause); end if; end Create_Or_Modify_Clause; + ---------------------------- + -- Split_Multiple_Outputs -- + ---------------------------- + + procedure Split_Multiple_Outputs is + Inputs : constant Node_Id := Expression (Clause); + Loc : constant Source_Ptr := Sloc (Clause); + Outputs : constant Node_Id := First (Choices (Clause)); + Last_Output : Node_Id; + Next_Output : Node_Id; + Output : Node_Id; + Split : Node_Id; + + -- Start of processing for Split_Multiple_Outputs + + begin + -- Multiple outputs appear as an aggregate. Nothing to do when + -- the clause has exactly one output. + + if Nkind (Outputs) = N_Aggregate then + Last_Output := Last (Expressions (Outputs)); + + -- Create a clause for each output. Note that each time a new + -- clause is created, the original output list slowly shrinks + -- until there is one item left. + + Output := First (Expressions (Outputs)); + while Present (Output) loop + Next_Output := Next (Output); + + -- Unhook the output from the original output list as it + -- will be relocated to a new clause. + + Remove (Output); + + -- Special processing for the last output. At this point + -- the original aggregate has been stripped down to one + -- element. Replace the aggregate by the element itself. + + if Output = Last_Output then + Rewrite (Outputs, Output); + + else + -- Generate a clause of the form: + -- (Output => Inputs) + + Split := + Make_Component_Association (Loc, + Choices => New_List (Output), + Expression => New_Copy_Tree (Inputs)); + + -- The new clause contains replicated content that has + -- already been analyzed. There is not need to reanalyze + -- them. + + Set_Analyzed (Split); + Insert_After (Clause, Split); + end if; + + Output := Next_Output; + end loop; + end if; + end Split_Multiple_Outputs; + -- Local variables Outputs : constant Node_Id := First (Choices (Clause)); @@ -1226,6 +1425,11 @@ package body Sem_Prag is Multiple => False); end if; end if; + + -- Split a clause with multiple outputs into multiple clauses with a + -- single output. + + Split_Multiple_Outputs; end Normalize_Clause; -- Local variables @@ -1235,14 +1439,35 @@ package body Sem_Prag is Last_Clause : Node_Id; Subp_Decl : Node_Id; + Restore_Scope : Boolean := False; + -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit + -- Start of processing for Analyze_Depends_In_Decl_Part begin Set_Analyzed (N); - Subp_Decl := Find_Related_Subprogram (N); - Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); - Clause := Expression (Arg1); + Subp_Decl := Find_Related_Subprogram_Or_Body (N); + Subp_Id := Defining_Entity (Subp_Decl); + + -- The logic in this routine is used to analyze both pragma Depends and + -- pragma Refined_Depends since they have the same syntax and base + -- semantics. Find the entity of the corresponding spec when analyzing + -- Refined_Depends. + + if Nkind (Subp_Decl) = N_Subprogram_Body + and then not Acts_As_Spec (Subp_Decl) + then + Spec_Id := Corresponding_Spec (Subp_Decl); + + elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then + Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); + + else + Spec_Id := Subp_Id; + end if; + + Clause := Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); -- Empty dependency list @@ -1250,7 +1475,7 @@ package body Sem_Prag is -- Gather all states, variables and formal parameters that the -- subprogram may depend on. These items are obtained from the - -- parameter profile or pragma Global (if available). + -- parameter profile or pragma [Refined_]Global (if available). Collect_Subprogram_Inputs_Outputs (Subp_Id => Subp_Id, @@ -1262,7 +1487,7 @@ package body Sem_Prag is -- dependency. Check_Usage (Subp_Inputs, All_Inputs_Seen, True); - Check_Usage (Subp_Outputs, Outputs_Seen, False); + Check_Usage (Subp_Outputs, All_Outputs_Seen, False); Check_Function_Return; -- Dependency clauses appear as component associations of an aggregate @@ -1274,7 +1499,7 @@ package body Sem_Prag is -- Gather all states, variables and formal parameters that the -- subprogram may depend on. These items are obtained from the - -- parameter profile or pragma Global (if available). + -- parameter profile or pragma [Refined_]Global (if available). Collect_Subprogram_Inputs_Outputs (Subp_Id => Subp_Id, @@ -1287,9 +1512,10 @@ package body Sem_Prag is -- to subprogram declarations. Skip the installation for subprogram -- bodies because the formals are already visible. - if Requires_Profile_Installation (N, Subp_Decl) then - Push_Scope (Subp_Id); - Install_Formals (Subp_Id); + if not In_Open_Scopes (Spec_Id) then + Restore_Scope := True; + Push_Scope (Spec_Id); + Install_Formals (Spec_Id); end if; Clause := First (Component_Associations (Clause)); @@ -1297,8 +1523,7 @@ package body Sem_Prag is Errors := Serious_Errors_Detected; -- Normalization may create extra clauses that contain replicated - -- input and output names. There is no need to reanalyze or - -- renormalize these extra clauses. + -- input and output names. There is no need to reanalyze them. if not Analyzed (Clause) then Set_Analyzed (Clause); @@ -1306,19 +1531,19 @@ package body Sem_Prag is Analyze_Dependency_Clause (Clause => Clause, Is_Last => Clause = Last_Clause); + end if; - -- Do not normalize an erroneous clause because the inputs or - -- outputs may denote illegal items. + -- Do not normalize an erroneous clause because the inputs and/or + -- outputs may denote illegal items. - if Errors = Serious_Errors_Detected then - Normalize_Clause (Clause); - end if; + if Serious_Errors_Detected = Errors then + Normalize_Clause (Clause); end if; Next (Clause); end loop; - if Requires_Profile_Installation (N, Subp_Decl) then + if Restore_Scope then End_Scope; end if; @@ -1326,7 +1551,7 @@ package body Sem_Prag is -- dependency. Check_Usage (Subp_Inputs, All_Inputs_Seen, True); - Check_Usage (Subp_Outputs, Outputs_Seen, False); + Check_Usage (Subp_Outputs, All_Outputs_Seen, False); Check_Function_Return; -- The top level dependency relation is malformed @@ -1341,19 +1566,21 @@ package body Sem_Prag is --------------------------------- procedure Analyze_Global_In_Decl_Part (N : Node_Id) is - Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); - Seen : Elist_Id := No_Elist; -- A list containing the entities of all the items processed so far. It -- plays a role in detecting distinct entities. + Spec_Id : Entity_Id; + -- The entity of the subprogram subject to pragma [Refined_]Global + Subp_Id : Entity_Id; - -- The entity of the subprogram subject to pragma Global + -- The entity of the subprogram [body or stub] subject to pragma + -- [Refined_]Global. - Contract_Seen : Boolean := False; - In_Out_Seen : Boolean := False; - Input_Seen : Boolean := False; - Output_Seen : Boolean := False; + In_Out_Seen : Boolean := False; + Input_Seen : Boolean := False; + Output_Seen : Boolean := False; + Proof_Seen : Boolean := False; -- Flags used to verify the consistency of modes procedure Analyze_Global_List @@ -1427,14 +1654,18 @@ package body Sem_Prag is Item_Id := Entity_Of (Item); if Present (Item_Id) then + Record_Possible_Body_Reference (Item, Item_Id); - -- A global item cannot reference a formal parameter. Do this - -- check first to provide a better error diagnostic. + -- A global item may denote a formal parameter of an enclosing + -- subprogram. Do this check first to provide a better error + -- diagnostic. if Is_Formal (Item_Id) then - Error_Msg_N - ("global item cannot reference formal parameter", Item); - return; + if Scope (Item_Id) = Spec_Id then + Error_Msg_N + ("global item cannot reference formal parameter", Item); + return; + end if; -- The only legal references are those to abstract states and -- variables. @@ -1445,6 +1676,33 @@ package body Sem_Prag is return; end if; + if Ekind (Item_Id) = E_Abstract_State then + + -- The state acts as a constituent of some other state. + -- Ensure that the other state is a proper ancestor of the + -- item. + + if Present (Refined_State (Item_Id)) then + if not Is_Part_Of (Item_Id, Refined_State (Item_Id)) then + Error_Msg_Name_1 := Chars (Refined_State (Item_Id)); + Error_Msg_NE + ("state & is not a valid constituent of ancestor " + & "state %", Item, Item_Id); + return; + end if; + + -- An abstract state with visible refinement cannot appear + -- in pragma [Refined_]Global as its place must be taken by + -- some of its constituents. + + elsif Has_Visible_Refinement (Item_Id) then + Error_Msg_NE + ("cannot mention state & in global refinement, use its " + & "constituents instead", Item, Item_Id); + return; + end if; + end if; + -- When the item renames an entire object, replace the item -- with a reference to the object. @@ -1464,27 +1722,27 @@ package body Sem_Prag is -- valid choices. Perform mode- and usage-specific checks. if Ekind (Item_Id) = E_Abstract_State - and then Is_Volatile_State (Item_Id) + and then Is_External_State (Item_Id) then - -- A global item of mode In_Out or Output cannot denote a - -- volatile Input state. + -- A global item of mode In_Out or Output cannot denote an + -- external Input_Only state. - if Is_Input_State (Item_Id) + if Is_Input_Only_State (Item_Id) and then Nam_In (Global_Mode, Name_In_Out, Name_Output) then Error_Msg_N ("global item of mode In_Out or Output cannot reference " - & "Volatile Input state", Item); + & "External Input_Only state", Item); - -- A global item of mode In_Out or Input cannot reference a - -- volatile Output state. + -- A global item of mode In_Out or Input cannot reference an + -- external Output_Only state. - elsif Is_Output_State (Item_Id) + elsif Is_Output_Only_State (Item_Id) and then Nam_In (Global_Mode, Name_In_Out, Name_Input) then Error_Msg_N ("global item of mode In_Out or Input cannot reference " - & "Volatile Output state", Item); + & "External Output_Only state", Item); end if; end if; @@ -1540,12 +1798,12 @@ package body Sem_Prag is begin -- Traverse the scope stack looking for enclosing subprograms - -- subject to aspect/pragma Global. + -- subject to pragma [Refined_]Global. Context := Scope (Subp_Id); while Present (Context) and then Context /= Standard_Standard loop if Is_Subprogram (Context) - and then Has_Aspect (Context, Aspect_Global) + and then Present (Get_Pragma (Context, Pragma_Global)) then Collect_Subprogram_Inputs_Outputs (Subp_Id => Context, @@ -1582,7 +1840,7 @@ package body Sem_Prag is procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is begin - if Ekind (Subp_Id) = E_Function then + if Ekind (Spec_Id) = E_Function then Error_Msg_N ("global mode & not applicable to functions", Mode); end if; @@ -1597,17 +1855,21 @@ package body Sem_Prag is -- Start of processing for Analyze_Global_List begin + if Nkind (List) = N_Null then + Set_Analyzed (List); + -- Single global item declaration - if Nkind_In (List, N_Expanded_Name, - N_Identifier, - N_Selected_Component) + elsif Nkind_In (List, N_Expanded_Name, + N_Identifier, + N_Selected_Component) then Analyze_Global_Item (List, Global_Mode); -- Simple global list or moded global list declaration elsif Nkind (List) = N_Aggregate then + Set_Analyzed (List); -- The declaration of a simple global list appear as a collection -- of expressions. @@ -1640,10 +1902,7 @@ package body Sem_Prag is Mode := First (Choices (Assoc)); if Nkind (Mode) = N_Identifier then - if Chars (Mode) = Name_Contract_In then - Check_Duplicate_Mode (Mode, Contract_Seen); - - elsif Chars (Mode) = Name_In_Out then + if Chars (Mode) = Name_In_Out then Check_Duplicate_Mode (Mode, In_Out_Seen); Check_Mode_Restriction_In_Function (Mode); @@ -1654,6 +1913,9 @@ package body Sem_Prag is Check_Duplicate_Mode (Mode, Output_Seen); Check_Mode_Restriction_In_Function (Mode); + elsif Chars (Mode) = Name_Proof_In then + Check_Duplicate_Mode (Mode, Proof_Seen); + else Error_Msg_N ("invalid mode selector", Mode); end if; @@ -1673,7 +1935,7 @@ package body Sem_Prag is Next (Assoc); end loop; - -- Something went horribly wrong, we have a malformed tree + -- Invalid tree else raise Program_Error; @@ -1688,22 +1950,43 @@ package body Sem_Prag is -- Local variables - List : Node_Id; + Items : Node_Id; Subp_Decl : Node_Id; + Restore_Scope : Boolean := False; + -- Set True if we do a Push_Scope requiring a Pop_Scope on exit + -- Start of processing for Analyze_Global_In_Decl_List begin Set_Analyzed (N); - Subp_Decl := Find_Related_Subprogram (N); - Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); - List := Expression (Arg1); + Subp_Decl := Find_Related_Subprogram_Or_Body (N); + Subp_Id := Defining_Entity (Subp_Decl); + + -- The logic in this routine is used to analyze both pragma Global and + -- pragma Refined_Global since they have the same syntax and base + -- semantics. Find the entity of the corresponding spec when analyzing + -- Refined_Global. + + if Nkind (Subp_Decl) = N_Subprogram_Body + and then not Acts_As_Spec (Subp_Decl) + then + Spec_Id := Corresponding_Spec (Subp_Decl); + + elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then + Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); + + else + Spec_Id := Subp_Id; + end if; + + Items := Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); -- There is nothing to be done for a null global list - if Nkind (List) = N_Null then - null; + if Nkind (Items) = N_Null then + Set_Analyzed (Items); -- Analyze the various forms of global lists and items. Note that some -- of these may be malformed in which case the analysis emits error @@ -1714,171 +1997,533 @@ package body Sem_Prag is -- item. This falls out of the general rule of aspects pertaining to -- subprogram declarations. - if Requires_Profile_Installation (N, Subp_Decl) then - Push_Scope (Subp_Id); - Install_Formals (Subp_Id); + if not In_Open_Scopes (Spec_Id) then + Restore_Scope := True; + Push_Scope (Spec_Id); + Install_Formals (Spec_Id); end if; - Analyze_Global_List (List); + Analyze_Global_List (Items); - if Requires_Profile_Installation (N, Subp_Decl) then + if Restore_Scope then End_Scope; end if; end if; end Analyze_Global_In_Decl_Part; - ------------------------------ - -- Analyze_PPC_In_Decl_Part -- - ------------------------------ + -------------------------------------------- + -- Analyze_Initial_Condition_In_Decl_Part -- + -------------------------------------------- + + procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is + Pack_Id : constant Entity_Id := Defining_Entity (Parent (Parent (N))); + Prag_Init : constant Node_Id := + Get_Pragma (Pack_Id, Pragma_Initializes); + -- The related pragma Initializes + + Vars : Elist_Id := No_Elist; + -- A list of all variables declared in pragma Initializes + + procedure Collect_Variables; + -- Inspect the initialization list of pragma Initializes and collect the + -- entities of all variables declared within the related package. + + function Match_Variable (N : Node_Id) return Traverse_Result; + -- Determine whether arbitrary node N denotes a variable declared in the + -- visible declarations of the related package. + + procedure Report_Unused_Variables; + -- Emit errors for all variables found in list Vars + + ----------------------- + -- Collect_Variables -- + ----------------------- + + procedure Collect_Variables is + procedure Collect_Variable (Item : Node_Id); + -- Determine whether Item denotes a variable that appears in the + -- related package and if it does, add it to list Vars. + + ---------------------- + -- Collect_Variable -- + ---------------------- + + procedure Collect_Variable (Item : Node_Id) is + Item_Id : Entity_Id; + + begin + if Is_Entity_Name (Item) and then Present (Entity (Item)) then + Item_Id := Entity (Item); + + -- The item is a variable declared in the related package + + if Ekind (Item_Id) = E_Variable + and then Scope (Item_Id) = Pack_Id + then + Add_Item (Item_Id, Vars); + end if; + end if; + end Collect_Variable; + + -- Local variables + + Inits : constant Node_Id := + Get_Pragma_Arg + (First (Pragma_Argument_Associations (Prag_Init))); + Init : Node_Id; + + -- Start of processing for Collect_Variables + + begin + -- Multiple initialization items appear as an aggregate + + if Nkind (Inits) = N_Aggregate + and then Present (Expressions (Inits)) + then + Init := First (Expressions (Inits)); + while Present (Init) loop + Collect_Variable (Init); + + Next (Init); + end loop; + + -- Single initialization item + + else + Collect_Variable (Inits); + end if; + end Collect_Variables; + + -------------------- + -- Match_Variable -- + -------------------- + + function Match_Variable (N : Node_Id) return Traverse_Result is + Var_Id : Entity_Id; + + begin + -- Find a variable declared within the related package and try to + -- remove it from the list of collected variables found in pragma + -- Initializes. + + if Is_Entity_Name (N) + and then Present (Entity (N)) + then + Var_Id := Entity (N); + + if Ekind (Var_Id) = E_Variable + and then Scope (Var_Id) = Pack_Id + then + Remove (Vars, Var_Id); + end if; + end if; + + return OK; + end Match_Variable; + + procedure Match_Variables is new Traverse_Proc (Match_Variable); + + ----------------------------- + -- Report_Unused_Variables -- + ----------------------------- + + procedure Report_Unused_Variables is + Posted : Boolean := False; + Var_Elmt : Elmt_Id; + Var_Id : Entity_Id; + + begin + if Present (Vars) then + Var_Elmt := First_Elmt (Vars); + while Present (Var_Elmt) loop + Var_Id := Node (Var_Elmt); + + if not Posted then + Posted := True; + Error_Msg_Name_1 := Name_Initial_Condition; + Error_Msg_N + ("expression of % must mention the following variables", + N); + end if; + + Error_Msg_Sloc := Sloc (Var_Id); + Error_Msg_NE ("\ & declared #", N, Var_Id); + + Next_Elmt (Var_Elmt); + end loop; + end if; + end Report_Unused_Variables; + + Expr : constant Node_Id := + Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); + Errors : constant Nat := Serious_Errors_Detected; - procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is - Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + -- Start of processing for Analyze_Initial_Condition_In_Decl_Part begin - -- Install formals and push subprogram spec onto scope stack so that we - -- can see the formals from the pragma. + Set_Analyzed (N); - Install_Formals (S); - Push_Scope (S); + -- Pragma Initial_Condition depends on the names enumerated in pragma + -- Initializes. Without those, the analysis cannot take place. - -- Preanalyze the boolean expression, we treat this as a spec expression - -- (i.e. similar to a default expression). + if No (Prag_Init) then + Error_Msg_Name_1 := Name_Initial_Condition; + Error_Msg_Name_2 := Name_Initializes; - -- In ASIS mode, for a pragma generated from a source aspect, analyze - -- directly the the original aspect expression, which is shared with - -- the generated pragma. + Error_Msg_N ("% requires the presence of aspect or pragma %", N); + return; + end if; - if ASIS_Mode and then Present (Corresponding_Aspect (N)) then - Preanalyze_Assert_Expression - (Expression (Corresponding_Aspect (N)), Standard_Boolean); - else - Preanalyze_Assert_Expression - (Get_Pragma_Arg (Arg1), Standard_Boolean); + -- The expression is preanalyzed because it has not been moved to its + -- final place yet. A direct analysis may generate sife effects and this + -- is not desired at this point. + + Preanalyze_And_Resolve (Expr, Standard_Boolean); + + -- Perform variable matching only when the expression is legal + + if Serious_Errors_Detected = Errors then + Collect_Variables; + + -- Verify that all variables mentioned in pragma Initializes are used + -- in the expression of pragma Initial_Condition. + + Match_Variables (Expr); end if; - -- For a class-wide condition, a reference to a controlling formal must - -- be interpreted as having the class-wide type (or an access to such) - -- so that the inherited condition can be properly applied to any - -- overriding operation (see ARM12 6.6.1 (7)). + -- Emit errors for all variables that should participate in the + -- expression of pragma Initial_Condition. - if Class_Present (N) then - Class_Wide_Condition : declare - T : constant Entity_Id := Find_Dispatching_Type (S); + if Serious_Errors_Detected = Errors then + Report_Unused_Variables; + end if; + end Analyze_Initial_Condition_In_Decl_Part; - ACW : Entity_Id := Empty; - -- Access to T'class, created if there is a controlling formal - -- that is an access parameter. + -------------------------------------- + -- Analyze_Initializes_In_Decl_Part -- + -------------------------------------- - function Get_ACW return Entity_Id; - -- If the expression has a reference to an controlling access - -- parameter, create an access to T'class for the necessary - -- conversions if one does not exist. + procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is + Pack_Spec : constant Node_Id := Parent (N); + Pack_Id : constant Entity_Id := Defining_Entity (Parent (Pack_Spec)); - function Process (N : Node_Id) return Traverse_Result; - -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class - -- aspect for a primitive subprogram of a tagged type T, a name - -- that denotes a formal parameter of type T is interpreted as - -- having type T'Class. Similarly, a name that denotes a formal - -- accessparameter of type access-to-T is interpreted as having - -- type access-to-T'Class. This ensures the expression is well- - -- defined for a primitive subprogram of a type descended from T. - -- Note that this replacement is not done for selector names in - -- parameter associations. These carry an entity for reference - -- purposes, but semantically they are just identifiers. + Items_Seen : Elist_Id := No_Elist; + -- A list of all initialization items processed so far. This list is + -- used to detect duplicate items. - ------------- - -- Get_ACW -- - ------------- + Non_Null_Seen : Boolean := False; + Null_Seen : Boolean := False; + -- Flags used to check the legality of a null initialization list - function Get_ACW return Entity_Id is - Loc : constant Source_Ptr := Sloc (N); - Decl : Node_Id; + States_And_Vars : Elist_Id := No_Elist; + -- A list of all abstract states and variables declared in the visible + -- declarations of the related package. This list is used to detect the + -- legality of initialization items. - begin - if No (ACW) then - Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'T'), - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Class_Wide_Type (T), Loc), - All_Present => True)); - - Insert_Before (Unit_Declaration_Node (S), Decl); - Analyze (Decl); - ACW := Defining_Identifier (Decl); - Freeze_Before (Unit_Declaration_Node (S), ACW); - end if; + procedure Analyze_Initialization_Item (Item : Node_Id); + -- Verify the legality of a single initialization item - return ACW; - end Get_ACW; + procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id); + -- Verify the legality of a single initialization item followed by a + -- list of input items. - ------------- - -- Process -- - ------------- + procedure Collect_States_And_Variables; + -- Inspect the visible declarations of the related package and gather + -- the entities of all abstract states and variables in States_And_Vars. - function Process (N : Node_Id) return Traverse_Result is - Loc : constant Source_Ptr := Sloc (N); - Typ : Entity_Id; + --------------------------------- + -- Analyze_Initialization_Item -- + --------------------------------- - begin - if Is_Entity_Name (N) - and then Present (Entity (N)) - and then Is_Formal (Entity (N)) - and then Nkind (Parent (N)) /= N_Type_Conversion - and then - (Nkind (Parent (N)) /= N_Parameter_Association - or else N /= Selector_Name (Parent (N))) - then - if Etype (Entity (N)) = T then - Typ := Class_Wide_Type (T); + procedure Analyze_Initialization_Item (Item : Node_Id) is + Item_Id : Entity_Id; + + begin + -- Null initialization list + + if Nkind (Item) = N_Null then + if Null_Seen then + Error_Msg_N ("multiple null initializations not allowed", Item); + + elsif Non_Null_Seen then + Error_Msg_N + ("cannot mix null and non-null initialization items", Item); + else + Null_Seen := True; + end if; + + -- Initialization item + + else + Non_Null_Seen := True; + + if Null_Seen then + Error_Msg_N + ("cannot mix null and non-null initialization items", Item); + end if; + + Analyze (Item); + + if Is_Entity_Name (Item) then + Item_Id := Entity (Item); + + if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then + + -- The state or variable must be declared in the visible + -- declarations of the package. + + if not Contains (States_And_Vars, Item_Id) then + Error_Msg_Name_1 := Chars (Pack_Id); + Error_Msg_NE + ("initialization item & must appear in the visible " + & "declarations of package %", Item, Item_Id); + + -- Detect a duplicate use of the same initialization item + + elsif Contains (Items_Seen, Item_Id) then + Error_Msg_N ("duplicate initialization item", Item); + + -- The item is legal, add it to the list of processed states + -- and variables. - elsif Is_Access_Type (Etype (Entity (N))) - and then Designated_Type (Etype (Entity (N))) = T - then - Typ := Get_ACW; else - Typ := Empty; + Add_Item (Item_Id, Items_Seen); end if; - if Present (Typ) then - Rewrite (N, - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (Typ, Loc), - Expression => New_Occurrence_Of (Entity (N), Loc))); - Set_Etype (N, Typ); - end if; + -- The item references something that is not a state or a + -- variable. + + else + Error_Msg_N + ("initialization item must denote variable or state", + Item); end if; - return OK; - end Process; + -- Some form of illegal construct masquerading as a name - procedure Replace_Type is new Traverse_Proc (Process); + else + Error_Msg_N + ("initialization item must denote variable or state", Item); + end if; + end if; + end Analyze_Initialization_Item; - -- Start of processing for Class_Wide_Condition + --------------------------------------------- + -- Analyze_Initialization_Item_With_Inputs -- + --------------------------------------------- + + procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is + Inputs_Seen : Elist_Id := No_Elist; + -- A list of all inputs processed so far. This list is used to detect + -- duplicate uses of an input. + + Non_Null_Seen : Boolean := False; + Null_Seen : Boolean := False; + -- Flags used to check the legality of an input list + + procedure Analyze_Input_Item (Input : Node_Id); + -- Verify the legality of a single input item + + ------------------------ + -- Analyze_Input_Item -- + ------------------------ + + procedure Analyze_Input_Item (Input : Node_Id) is + Input_Id : Entity_Id; begin - if not Present (T) then - Error_Msg_Name_1 := - Chars (Identifier (Corresponding_Aspect (N))); + -- Null input list + + if Nkind (Input) = N_Null then + if Null_Seen then + Error_Msg_N + ("multiple null initializations not allowed", Item); + + elsif Non_Null_Seen then + Error_Msg_N + ("cannot mix null and non-null initialization item", Item); + else + Null_Seen := True; + end if; + + -- Input item + + else + Non_Null_Seen := True; + + if Null_Seen then + Error_Msg_N + ("cannot mix null and non-null initialization item", Item); + end if; + + Analyze (Input); + + if Is_Entity_Name (Input) then + Input_Id := Entity (Input); + + if Ekind_In (Input_Id, E_Abstract_State, E_Variable) then + + -- The input cannot denote states or variables declared + -- within the related package. + + if In_Same_Code_Unit (Item, Input_Id) then + Error_Msg_Name_1 := Chars (Pack_Id); + Error_Msg_NE + ("input item & cannot denote a visible variable or " + & "state of package %", Input, Input_Id); + + -- Detect a duplicate use of the same input item + + elsif Contains (Inputs_Seen, Input_Id) then + Error_Msg_N ("duplicate input item", Input); + + -- Input is legal, add it to the list of processed inputs + + else + Add_Item (Input_Id, Inputs_Seen); + end if; - Error_Msg_Name_2 := Name_Class; + -- The input references something that is not a state or a + -- variable. + else + Error_Msg_N + ("input item must denote variable or state", Input); + end if; + + -- Some form of illegal construct masquerading as a name + + else + Error_Msg_N + ("input item must denote variable or state", Input); + end if; + end if; + end Analyze_Input_Item; + + -- Local variables + + Inputs : constant Node_Id := Expression (Item); + Elmt : Node_Id; + Input : Node_Id; + + Name_Seen : Boolean := False; + -- A flag used to detect multiple item names + + -- Start of processing for Analyze_Initialization_Item_With_Inputs + + begin + -- Inspect the name of an item with inputs + + Elmt := First (Choices (Item)); + while Present (Elmt) loop + if Name_Seen then + Error_Msg_N ("only one item allowed in initialization", Elmt); + else + Name_Seen := True; + Analyze_Initialization_Item (Elmt); + end if; + + Next (Elmt); + end loop; + + -- Multiple input items appear as an aggregate + + if Nkind (Inputs) = N_Aggregate then + if Present (Expressions (Inputs)) then + Input := First (Expressions (Inputs)); + while Present (Input) loop + Analyze_Input_Item (Input); + Next (Input); + end loop; + end if; + + if Present (Component_Associations (Inputs)) then Error_Msg_N - ("aspect `%''%` can only be specified for a primitive " - & "operation of a tagged type", Corresponding_Aspect (N)); + ("inputs must appear in named association form", Inputs); end if; - Replace_Type (Get_Pragma_Arg (Arg1)); - end Class_Wide_Condition; - end if; + -- Single input item - -- Remove the subprogram from the scope stack now that the pre-analysis - -- of the precondition/postcondition is done. + else + Analyze_Input_Item (Inputs); + end if; + end Analyze_Initialization_Item_With_Inputs; - End_Scope; - end Analyze_PPC_In_Decl_Part; + ---------------------------------- + -- Collect_States_And_Variables -- + ---------------------------------- + + procedure Collect_States_And_Variables is + Decl : Node_Id; + + begin + -- Collect the abstract states defined in the package (if any) + + if Present (Abstract_States (Pack_Id)) then + States_And_Vars := New_Copy_Elist (Abstract_States (Pack_Id)); + end if; + + -- Collect all variables the appear in the visible declarations of + -- the related package. + + if Present (Visible_Declarations (Pack_Spec)) then + Decl := First (Visible_Declarations (Pack_Spec)); + while Present (Decl) loop + if Nkind (Decl) = N_Object_Declaration + and then Ekind (Defining_Entity (Decl)) = E_Variable + and then Comes_From_Source (Decl) + then + Add_Item (Defining_Entity (Decl), States_And_Vars); + end if; + + Next (Decl); + end loop; + end if; + end Collect_States_And_Variables; + + -- Local variables + + Inits : constant Node_Id := + Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); + Init : Node_Id; + + -- Start of processing for Analyze_Initializes_In_Decl_Part + + begin + Set_Analyzed (N); + + -- Initialize the various lists used during analysis + + Collect_States_And_Variables; + + -- Multiple initialization clauses appear as an aggregate + + if Nkind (Inits) = N_Aggregate then + if Present (Expressions (Inits)) then + Init := First (Expressions (Inits)); + while Present (Init) loop + Analyze_Initialization_Item (Init); + + Next (Init); + end loop; + end if; + + if Present (Component_Associations (Inits)) then + Init := First (Component_Associations (Inits)); + while Present (Init) loop + Analyze_Initialization_Item_With_Inputs (Init); + + Next (Init); + end loop; + end if; + + -- Various forms of a single initialization clause. Note that these may + -- include malformed initializations. + + else + Analyze_Initialization_Item (Inits); + end if; + end Analyze_Initializes_In_Decl_Part; -------------------- -- Analyze_Pragma -- @@ -1923,6 +2568,16 @@ 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_Refined_Pragma + (Spec_Id : out Entity_Id; + 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. + procedure Check_Ada_83_Warning; -- Issues a warning message for the current pragma if operating in Ada -- 83 mode (used for language pragmas that are not a standard part of @@ -2026,16 +2681,10 @@ 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_Test_Case; - -- Called to process a test-case pragma. It starts with checking pragma - -- arguments, and the rest of the treatment is similar to the one for - -- pre- and postcondition in Check_Precondition_Postcondition, except - -- the placement rules for the test-case pragma are stricter. These - -- pragmas may only occur after a subprogram spec declared directly - -- in a package spec unit. In this case, the pragma is chained to the - -- subprogram in question (using Contract_Test_Cases and Next_Pragma) - -- and analysis of the pragma is delayed till the end of the spec. In - -- all other cases, an error message for bad placement is given. + 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 @@ -2115,6 +2764,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_Pre_Post; + -- Called to perform checks for Pre, Pre_Class, Post, Post_Class + -- pragmas. These are processed by transformation to equivalent + -- Precondition and Postcondition pragmas, but Pre and Post need an + -- additional check that they are not used in a subprogram body when + -- there is a separate spec present. + procedure Check_Precondition_Postcondition (In_Body : out Boolean); -- Called to process a precondition or postcondition pragma. There are -- three cases: @@ -2145,6 +2801,17 @@ package body Sem_Prag is -- that the constraint is static as required by the restrictions for -- Unchecked_Union. + procedure Check_Test_Case; + -- Called to process a test-case pragma. It starts with checking pragma + -- arguments, and the rest of the treatment is similar to the one for + -- pre- and postcondition in Check_Precondition_Postcondition, except + -- the placement rules for the test-case pragma are stricter. These + -- pragmas may only occur after a subprogram spec declared directly + -- in a package spec unit. In this case, the pragma is chained to the + -- subprogram in question (using Contract_Test_Cases and Next_Pragma) + -- and analysis of the pragma is delayed till the end of the spec. In + -- all other cases, an error message for bad placement is given. + procedure Check_Valid_Configuration_Pragma; -- Legality checks for placement of a configuration pragma @@ -2449,6 +3116,85 @@ package body Sem_Prag is end if; end Ada_2012_Pragma; + ---------------------------- + -- Analyze_Refined_Pragma -- + ---------------------------- + + procedure Analyze_Refined_Pragma + (Spec_Id : out Entity_Id; + Body_Id : out Entity_Id; + Legal : out Boolean) + is + Body_Decl : Node_Id; + Pack_Spec : Node_Id; + Spec_Decl : Node_Id; + + begin + -- Assume that the pragma is illegal + + Spec_Id := Empty; + Body_Id := Empty; + Legal := False; + + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + + -- 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); + + if not Nkind_In (Body_Decl, N_Subprogram_Body, + N_Subprogram_Body_Stub) + then + Pragma_Misplaced; + return; + end if; + + Body_Id := Defining_Entity (Body_Decl); + + -- The body [stub] must not act as a spec, in other words it has to + -- be paired with a corresponding spec. + + if Nkind (Body_Decl) = N_Subprogram_Body then + Spec_Id := Corresponding_Spec (Body_Decl); + else + Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl); + end if; + + if No (Spec_Id) then + Error_Pragma ("pragma % cannot apply to a stand alone body"); + return; + end if; + + -- The pragma may 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 := Parent (Parent (Spec_Id)); + + pragma Assert + (Nkind_In (Spec_Decl, N_Abstract_Subprogram_Declaration, + N_Generic_Subprogram_Declaration, + N_Subprogram_Declaration)); + + Pack_Spec := Parent (Spec_Decl); + + if Nkind (Pack_Spec) /= N_Package_Specification + or else List_Containing (Spec_Decl) /= + Visible_Declarations (Pack_Spec) + then + Error_Pragma + ("pragma % must apply to the body of a visible subprogram"); + return; + end if; + + -- If we get here, then the pragma is legal + + Legal := True; + end Analyze_Refined_Pragma; + -------------------------- -- Check_Ada_83_Warning -- -------------------------- @@ -2913,6 +3659,107 @@ 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 + + Error_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 + Error_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 + + Error_Msg_N ("pragma % cannot come after pragma %", First); + end if; + end if; + end Check_Declaration_Order; + ---------------------------- -- Check_Duplicate_Pragma -- ---------------------------- @@ -3402,6 +4249,97 @@ package body Sem_Prag is Check_Optional_Identifier (Arg, Name_Find); end Check_Optional_Identifier; + -------------------- + -- Check_Pre_Post -- + -------------------- + + procedure Check_Pre_Post is + P : Node_Id; + PO : Node_Id; + + begin + if not Is_List_Member (N) then + Pragma_Misplaced; + end if; + + -- If we are within an inlined body, the legality of the pragma + -- has been checked already. + + if In_Inlined_Body then + return; + end if; + + -- Search prior declarations + + P := N; + while Present (Prev (P)) loop + P := Prev (P); + + -- If the previous node is a generic subprogram, do not go to to + -- the original node, which is the unanalyzed tree: we need to + -- attach the pre/postconditions to the analyzed version at this + -- point. They get propagated to the original tree when analyzing + -- the corresponding body. + + if Nkind (P) not in N_Generic_Declaration then + PO := Original_Node (P); + else + PO := P; + end if; + + -- Skip past prior pragma + + if Nkind (PO) = N_Pragma then + null; + + -- Skip stuff not coming from source + + elsif not Comes_From_Source (PO) then + + -- The condition may apply to a subprogram instantiation + + if Nkind (PO) = N_Subprogram_Declaration + and then Present (Generic_Parent (Specification (PO))) + then + return; + + elsif Nkind (PO) = N_Subprogram_Declaration + and then In_Instance + then + return; + + -- For all other cases of non source code, do nothing + + else + null; + end if; + + -- Only remaining possibility is subprogram declaration + + else + return; + end if; + end loop; + + -- If we fall through loop, pragma is at start of list, so see if it + -- is at the start of declarations of a subprogram body. + + PO := Parent (N); + + if Nkind (PO) = N_Subprogram_Body + and then List_Containing (N) = Declarations (PO) + then + -- This is only allowed if there is no separate specification + + if Present (Corresponding_Spec (PO)) then + Error_Pragma + ("pragma% must apply to subprogram specification"); + end if; + + return; + end if; + end Check_Pre_Post; + -------------------------------------- -- Check_Precondition_Postcondition -- -------------------------------------- @@ -3441,7 +4379,7 @@ package body Sem_Prag is -- compatibility with earlier uses of the Ada pragma, apply this -- rule only to aspect specifications. - -- The above discrpency needs documentation. Robert is dubious + -- The above discrepency needs documentation. Robert is dubious -- about whether it is a good idea ??? elsif Nkind (PO) = N_Subprogram_Declaration @@ -3654,10 +4592,12 @@ package body Sem_Prag is elsif Nkind (PO) = N_Compilation_Unit_Aux then -- In formal verification mode, analyze pragma expression for - -- correctness, as it is not expanded later. + -- correctness, as it is not expanded later. Ditto in ASIS_Mode + -- where there is no later point at which the aspect will be + -- analyzed. - if SPARK_Mode then - Analyze_PPC_In_Decl_Part + if SPARK_Mode or else ASIS_Mode then + Analyze_Pre_Post_Condition_In_Decl_Part (N, Defining_Entity (Unit (Parent (PO)))); end if; @@ -4031,7 +4971,7 @@ package body Sem_Prag is Pragma_Misplaced; elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration - or else Nkind (Parent_Node) = + or else Nkind (Parent_Node) = N_Generic_Subprogram_Declaration) and then Plist = Generic_Formal_Declarations (Parent_Node) then @@ -4294,7 +5234,7 @@ package body Sem_Prag is -- Get name from corresponding aspect - Error_Msg_Name_1 := Original_Name (N); + Error_Msg_Name_1 := Original_Aspect_Name (N); end if; end Fix_Error; @@ -6414,6 +7354,34 @@ package body Sem_Prag is Check_CPP_Type_Has_No_Defaults (Def_Id); end if; + -- Import a CPP exception + + elsif C = Convention_CPP + and then Ekind (Def_Id) = E_Exception + then + if No (Arg3) then + Error_Pragma_Arg + ("'External_'Name arguments is required for 'Cpp exception", + Arg3); + else + -- As only a string is allowed, Check_Arg_Is_External_Name + -- isn't called. + Check_Arg_Is_Static_Expression (Arg3, Standard_String); + end if; + + if Present (Arg4) then + Error_Pragma_Arg + ("Link_Name argument not allowed for imported Cpp exception", + Arg4); + end if; + + -- Do not call Set_Interface_Name as the name of the exception + -- shouldn't be modified (and in particular it shouldn't be + -- the External_Name). For exceptions, the External_Name is the + -- name of the RTTI structure. + + -- ??? Emit an error if pragma Import/Export_Exception is present + elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then Check_No_Link_Name; Check_Arg_Count (3); @@ -8188,7 +9156,7 @@ package body Sem_Prag is -- Here to start processing for recognized pragma Prag_Id := Get_Pragma_Id (Pname); - Pname := Original_Name (N); + Pname := Original_Aspect_Name (N); -- Check applicable policy. We skip this if Is_Checked or Is_Ignored -- is already set, indicating that we have already checked the policy @@ -8283,19 +9251,21 @@ package body Sem_Prag is -- ABSTRACT_STATE_LIST ::= -- null - -- | STATE_NAME_WITH_PROPERTIES {, STATE_NAME_WITH_PROPERTIES} + -- | STATE_NAME_WITH_OPTIONS + -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS}) - -- STATE_NAME_WITH_PROPERTIES ::= - -- STATE_NAME - -- | (STATE_NAME with PROPERTY_LIST) + -- STATE_NAME_WITH_OPTIONS ::= + -- state_NAME + -- | (state_NAME with OPTION_LIST) - -- PROPERTY_LIST ::= PROPERTY {, PROPERTY} - -- PROPERTY ::= SIMPLE_PROPERTY | NAME_VALUE_PROPERTY + -- OPTION_LIST ::= OPTION {, OPTION} - -- SIMPLE_PROPERTY ::= IDENTIFIER - -- NAME_VALUE_PROPERTY ::= IDENTIFIER => EXPRESSION + -- OPTION ::= SIMPLE_OPTION | NAME_VALUE_OPTION - -- STATE_NAME ::= DEFINING_IDENTIFIER + -- SIMPLE_OPTION ::= + -- External | Non_Volatile | Input_Only | Output_Only + + -- NAME_VALUE_OPTION ::= Part_Of => abstract_state_NAME when Pragma_Abstract_State => Abstract_State : declare Pack_Id : Entity_Id; @@ -8315,46 +9285,47 @@ package body Sem_Prag is ---------------------------- procedure Analyze_Abstract_State (State : Node_Id) is - procedure Check_Duplicate_Property - (Prop : Node_Id; + procedure Check_Duplicate_Option + (Opt : Node_Id; Status : in out Boolean); - -- Flag Status denotes whether a particular property has been + -- Flag Status denotes whether a particular option has been -- seen while processing a state. This routine verifies that - -- Prop is not a duplicate property and sets the flag Status. + -- Opt is not a duplicate property and sets the flag Status. - ------------------------------ - -- Check_Duplicate_Property -- - ------------------------------ + ---------------------------- + -- Check_Duplicate_Option -- + ---------------------------- - procedure Check_Duplicate_Property - (Prop : Node_Id; + procedure Check_Duplicate_Option + (Opt : Node_Id; Status : in out Boolean) is begin if Status then - Error_Msg_N ("duplicate state property", Prop); + Error_Msg_N ("duplicate state option", Opt); end if; Status := True; - end Check_Duplicate_Property; + end Check_Duplicate_Option; -- Local variables - Errors : constant Nat := Serious_Errors_Detected; - Loc : constant Source_Ptr := Sloc (State); - Assoc : Node_Id; - Id : Entity_Id; - Is_Null : Boolean := False; - Level : Uint := Uint_0; - Name : Name_Id; - Prop : Node_Id; + Errors : constant Nat := Serious_Errors_Detected; + Loc : constant Source_Ptr := Sloc (State); + Assoc : Node_Id; + Id : Entity_Id; + Is_Null : Boolean := False; + Name : Name_Id; + Opt : Node_Id; + Par_State : Node_Id; - -- Flags used to verify the consistency of properties + -- Flags used to verify the consistency of options - Input_Seen : Boolean := False; - Integrity_Seen : Boolean := False; - Output_Seen : Boolean := False; - Volatile_Seen : Boolean := False; + External_Seen : Boolean := False; + Input_Seen : Boolean := False; + Non_Volatile_Seen : Boolean := False; + Output_Seen : Boolean := False; + Part_Of_Seen : Boolean := False; -- Start of processing for Analyze_Abstract_State @@ -8370,7 +9341,7 @@ package body Sem_Prag is elsif Nkind (State) = N_Null then Name := New_Internal_Name ('S'); - Is_Null := True; + Is_Null := True; Null_Seen := True; -- Catch a case where a null state appears in a list of @@ -8388,7 +9359,7 @@ package body Sem_Prag is Name := Chars (State); Non_Null_Seen := True; - -- State declaration with various properties. This construct + -- State declaration with various options. This construct -- appears as an extension aggregate in the tree. elsif Nkind (State) = N_Extension_Aggregate then @@ -8401,69 +9372,98 @@ package body Sem_Prag is Ancestor_Part (State)); end if; - -- Process properties Input, Output and Volatile. Ensure - -- that none of them appear more than once. - - Prop := First (Expressions (State)); - while Present (Prop) loop - if Nkind (Prop) = N_Identifier then - if Chars (Prop) = Name_Input then - Check_Duplicate_Property (Prop, Input_Seen); - elsif Chars (Prop) = Name_Output then - Check_Duplicate_Property (Prop, Output_Seen); - elsif Chars (Prop) = Name_Volatile then - Check_Duplicate_Property (Prop, Volatile_Seen); + -- Process options External, Input_Only, Output_Only and + -- Volatile. Ensure that none of them appear more than once. + + Opt := First (Expressions (State)); + while Present (Opt) loop + if Nkind (Opt) = N_Identifier then + if Chars (Opt) = Name_External then + Check_Duplicate_Option (Opt, External_Seen); + elsif Chars (Opt) = Name_Input_Only then + Check_Duplicate_Option (Opt, Input_Seen); + elsif Chars (Opt) = Name_Output_Only then + Check_Duplicate_Option (Opt, Output_Seen); + elsif Chars (Opt) = Name_Non_Volatile then + Check_Duplicate_Option (Opt, Non_Volatile_Seen); + + -- Ensure that the abstract state component of option + -- Part_Of has not been omitted. + + elsif Chars (Opt) = Name_Part_Of then + Error_Msg_N + ("option Part_Of requires an abstract state", + Opt); else - Error_Msg_N ("invalid state property", Prop); + Error_Msg_N ("invalid state option", Opt); end if; else - Error_Msg_N ("invalid state property", Prop); + Error_Msg_N ("invalid state option", Opt); end if; - Next (Prop); + Next (Opt); end loop; - -- Volatile requires exactly one Input or Output + -- External may appear on its own or with exactly one option + -- Input_Only or Output_Only, but not both. - if Volatile_Seen and then Input_Seen = Output_Seen then + if External_Seen + and then Input_Seen + and then Output_Seen + then Error_Msg_N - ("property Volatile requires exactly one Input or " - & "Output", State); + ("option External requires exactly one option " + & "Input_Only or Output_Only", State); end if; - -- Either Input or Output require Volatile + -- Either Input_Only or Output_Only require External if (Input_Seen or Output_Seen) - and then not Volatile_Seen + and then not External_Seen then Error_Msg_N - ("properties Input and Output require Volatile", State); + ("options Input_Only and Output_Only require option " + & "External", State); end if; - -- State property Integrity appears as a component - -- association. + -- Option Part_Of appears as a component association Assoc := First (Component_Associations (State)); while Present (Assoc) loop - Prop := First (Choices (Assoc)); - while Present (Prop) loop - if Nkind (Prop) = N_Identifier - and then Chars (Prop) = Name_Integrity + Opt := First (Choices (Assoc)); + while Present (Opt) loop + if Nkind (Opt) = N_Identifier + and then Chars (Opt) = Name_Part_Of then - Check_Duplicate_Property (Prop, Integrity_Seen); + Check_Duplicate_Option (Opt, Part_Of_Seen); else - Error_Msg_N ("invalid state property", Prop); + Error_Msg_N ("invalid state option", Opt); end if; - Next (Prop); + Next (Opt); end loop; - if Nkind (Expression (Assoc)) = N_Integer_Literal then - Level := Intval (Expression (Assoc)); + -- Part_Of must denote a parent state. Ensure that the + -- tree is not malformed by checking the expression of + -- the component association. + + Par_State := Expression (Assoc); + pragma Assert (Present (Par_State)); + + Analyze (Par_State); + + -- Part_Of specified a legal state, this automatically + -- makes the state a constituent. + + if Is_Entity_Name (Par_State) + and then Present (Entity (Par_State)) + and then Ekind (Entity (Par_State)) = E_Abstract_State + then + null; else Error_Msg_N - ("integrity level must be an integer literal", - Expression (Assoc)); + ("option Part_Of must denote an abstract state", + Par_State); end if; Next (Assoc); @@ -8486,12 +9486,12 @@ package body Sem_Prag is -- from the original state declaration. Decorate the entity. Id := Make_Defining_Identifier (Loc, New_External_Name (Name)); - Set_Comes_From_Source (Id, not Is_Null); - Set_Parent (Id, State); - Set_Ekind (Id, E_Abstract_State); - Set_Etype (Id, Standard_Void_Type); - Set_Integrity_Level (Id, Level); - Set_Refined_State (Id, Empty); + Set_Comes_From_Source (Id, not Is_Null); + Set_Parent (Id, State); + Set_Ekind (Id, E_Abstract_State); + Set_Etype (Id, Standard_Void_Type); + Set_Refined_State (Id, Empty); + Set_Refinement_Constituents (Id, New_Elmt_List); -- Every non-null state must be nameable and resolvable the -- same way a constant is. @@ -8520,8 +9520,8 @@ package body Sem_Prag is -- Local variables - Par : Node_Id; - State : Node_Id; + Context : constant Node_Id := Parent (Parent (N)); + State : Node_Id; -- Start of processing for Abstract_State @@ -8533,25 +9533,24 @@ package body Sem_Prag is -- Ensure the proper placement of the pragma. Abstract states must -- be associated with a package declaration. - if From_Aspect_Specification (N) then - Par := Parent (Corresponding_Aspect (N)); - else - Par := Parent (Parent (N)); - end if; - - if Nkind (Par) = N_Compilation_Unit then - Par := Unit (Par); - end if; - - if not Nkind_In (Par, N_Generic_Package_Declaration, - N_Package_Declaration) + if not Nkind_In (Context, N_Generic_Package_Declaration, + N_Package_Declaration) then Pragma_Misplaced; return; end if; - Pack_Id := Defining_Entity (Par); - State := Expression (Arg1); + Pack_Id := Defining_Entity (Context); + Add_Contract_Item (N, Pack_Id); + + -- Verify the declaration order of pragmas Abstract_State and + -- Initializes. + + Check_Declaration_Order + (First => N, + Second => Get_Pragma (Pack_Id, Pragma_Initializes)); + + State := Expression (Arg1); -- Multiple abstract states appear as an aggregate @@ -8962,13 +9961,15 @@ package body Sem_Prag is -- Assume | -- Contract_Cases | -- Debug | + -- Initial_Condition | -- Loop_Invariant | -- Loop_Variant | -- Postcondition | -- Precondition | -- Predicate | + -- Refined_Post | -- Statement_Assertions - -- + -- Note: The RM_ASSERTION_KIND list is language-defined, and the -- ID_ASSERTION_KIND list contains implementation-defined additions -- recognized by GNAT. The effect is to control the behavior of @@ -9634,7 +10635,7 @@ package body Sem_Prag is if Is_Checked (N) and then not Split_PPC (N) then - -- Mark pragma/aspect SCO as enabled + -- Mark aspect/pragma SCO as enabled Set_SCO_Pragma_Enabled (Loc); end if; @@ -10110,9 +11111,7 @@ package body Sem_Prag is -- Contract_Cases -- -------------------- - -- pragma Contract_Cases (CONTRACT_CASE_LIST); - - -- CONTRACT_CASE_LIST ::= CONTRACT_CASE {, CONTRACT_CASE} + -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE)); -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE @@ -10122,17 +11121,22 @@ package body Sem_Prag is when Pragma_Contract_Cases => Contract_Cases : declare Subp_Decl : Node_Id; - Subp_Id : Entity_Id; begin GNAT_Pragma; 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 (N, Check_Duplicates => True); + Subp_Decl := + Find_Related_Subprogram_Or_Body (N, Do_Checks => True); if Nkind (Subp_Decl) /= N_Subprogram_Declaration and then (Nkind (Subp_Decl) /= N_Subprogram_Body @@ -10142,15 +11146,8 @@ package body Sem_Prag is return; end if; - Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); - - -- The pragma is analyzed at the end of the declarative part which - -- contains the related subprogram. Reset the analyzed flag. - - Set_Analyzed (N, False); - - -- When the aspect/pragma appears on a subprogram body, perform - -- the full analysis now. + -- When the pragma appears on a subprogram body, perform the full + -- analysis now. if Nkind (Subp_Decl) = N_Subprogram_Body then Analyze_Contract_Cases_In_Decl_Part (N); @@ -10167,7 +11164,7 @@ package body Sem_Prag is -- Chain the pragma on the contract for further processing - Add_Contract_Item (N, Subp_Id); + Add_Contract_Item (N, Defining_Entity (Subp_Decl)); end Contract_Cases; ---------------- @@ -10642,7 +11639,6 @@ package body Sem_Prag is when Pragma_Depends => Depends : declare Subp_Decl : Node_Id; - Subp_Id : Entity_Id; begin GNAT_Pragma; @@ -10653,7 +11649,8 @@ package body Sem_Prag is -- associated with a subprogram declaration or a body that acts -- as a spec. - Subp_Decl := Find_Related_Subprogram (N, Check_Duplicates => True); + Subp_Decl := + Find_Related_Subprogram_Or_Body (N, Do_Checks => True); if Nkind (Subp_Decl) /= N_Subprogram_Declaration and then (Nkind (Subp_Decl) /= N_Subprogram_Body @@ -10663,10 +11660,8 @@ package body Sem_Prag is return; end if; - Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); - - -- When the aspect/pragma appears on a subprogram body, perform - -- the full analysis now. + -- When the pragma appears on a subprogram body, perform the full + -- analysis now. if Nkind (Subp_Decl) = N_Subprogram_Body then Analyze_Depends_In_Decl_Part (N); @@ -10683,7 +11678,7 @@ package body Sem_Prag is -- Chain the pragma on the contract for further processing - Add_Contract_Item (N, Subp_Id); + Add_Contract_Item (N, Defining_Entity (Subp_Decl)); end Depends; --------------------- @@ -11216,7 +12211,6 @@ package body Sem_Prag is Name_Link_Name)); Check_At_Least_N_Arguments (2); - Check_At_Most_N_Arguments (4); Process_Convention (C, Def_Id); @@ -11879,7 +12873,7 @@ package body Sem_Prag is -- Global -- ------------ - -- pragma Global (GLOBAL_SPECIFICATION) + -- pragma Global (GLOBAL_SPECIFICATION); -- GLOBAL_SPECIFICATION ::= -- null @@ -11888,13 +12882,12 @@ package body Sem_Prag is -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST - -- MODE_SELECTOR ::= Input | Output | In_Out | Contract_In + -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM}) -- GLOBAL_ITEM ::= NAME when Pragma_Global => Global : declare Subp_Decl : Node_Id; - Subp_Id : Entity_Id; begin GNAT_Pragma; @@ -11905,7 +12898,8 @@ package body Sem_Prag is -- associated with a subprogram declaration or a body that acts -- as a spec. - Subp_Decl := Find_Related_Subprogram (N, Check_Duplicates => True); + Subp_Decl := + Find_Related_Subprogram_Or_Body (N, Do_Checks => True); if Nkind (Subp_Decl) /= N_Subprogram_Declaration and then (Nkind (Subp_Decl) /= N_Subprogram_Body @@ -11915,10 +12909,8 @@ package body Sem_Prag is return; end if; - Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); - - -- When the aspect/pragma appears on a subprogram body, perform - -- the full analysis now. + -- When the pragma appears on a subprogram body, perform the full + -- analysis now. if Nkind (Subp_Decl) = N_Subprogram_Body then Analyze_Global_In_Decl_Part (N); @@ -11935,7 +12927,7 @@ package body Sem_Prag is -- Chain the pragma on the contract for further processing - Add_Contract_Item (N, Subp_Id); + Add_Contract_Item (N, Defining_Entity (Subp_Decl)); end Global; ----------- @@ -12617,6 +13609,80 @@ package body Sem_Prag is end if; end Independent_Components; + ----------------------- + -- Initial_Condition -- + ----------------------- + + -- pragma Initial_Condition (boolean_EXPRESSION); + + when Pragma_Initial_Condition => Initial_Condition : declare + Context : constant Node_Id := Parent (Parent (N)); + Pack_Id : Entity_Id; + Stmt : Node_Id; + + begin + GNAT_Pragma; + S14_Pragma; + Check_Arg_Count (1); + + -- Ensure the proper placement of the pragma. Initial_Condition + -- must be associated with a package declaration. + + if not Nkind_In (Context, N_Generic_Package_Declaration, + N_Package_Declaration) + then + Pragma_Misplaced; + return; + end if; + + Stmt := Prev (N); + while Present (Stmt) loop + + -- Skip prior pragmas, but check for duplicates + + 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 + + elsif not Comes_From_Source (Stmt) then + null; + + -- The pragma does not apply to a legal construct, issue an + -- error and stop the analysis. + + else + Pragma_Misplaced; + return; + end if; + + Stmt := Prev (Stmt); + end loop; + + -- 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 (Context); + Add_Contract_Item (N, Pack_Id); + + -- Verify the declaration order of pragma Initial_Condition with + -- respect to pragmas Abstract_State and Initializes. + + Check_Declaration_Order + (First => Get_Pragma (Pack_Id, Pragma_Abstract_State), + Second => N); + + Check_Declaration_Order + (First => Get_Pragma (Pack_Id, Pragma_Initializes), + Second => N); + end Initial_Condition; + ------------------------ -- Initialize_Scalars -- ------------------------ @@ -12640,6 +13706,91 @@ package body Sem_Prag is Initialize_Scalars := True; end if; + ----------------- + -- Initializes -- + ----------------- + + -- pragma Initializes (INITIALIZATION_SPEC); + + -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST + + -- INITIALIZATION_LIST ::= + -- INITIALIZATION_ITEM + -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM}) + + -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST] + + -- INPUT_LIST ::= + -- null + -- | INPUT + -- | (INPUT {, INPUT}) + + -- INPUT ::= name + + when Pragma_Initializes => Initializes : declare + Context : constant Node_Id := Parent (Parent (N)); + Pack_Id : Entity_Id; + Stmt : Node_Id; + + begin + GNAT_Pragma; + S14_Pragma; + Check_Arg_Count (1); + + -- Ensure the proper placement of the pragma. Initializes must be + -- associated with a package declaration. + + if not Nkind_In (Context, N_Generic_Package_Declaration, + N_Package_Declaration) + then + Pragma_Misplaced; + return; + end if; + + Stmt := Prev (N); + while Present (Stmt) loop + + -- Skip prior pragmas, but check for duplicates + + 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 + + elsif not Comes_From_Source (Stmt) then + null; + + -- The pragma does not apply to a legal construct, issue an + -- error and stop the analysis. + + else + Pragma_Misplaced; + return; + end if; + + Stmt := Prev (Stmt); + end loop; + + -- The pragma must be analyzed at the end of the visible + -- declarations of the related package. Save the pragma for later + -- (see Analyze_Initializes_In_Decl_Part) by adding it to the + -- contract of the package. + + Pack_Id := Defining_Entity (Context); + Add_Contract_Item (N, Pack_Id); + + -- Verify the declaration order of pragmas Abstract_State and + -- Initializes. + + Check_Declaration_Order + (First => Get_Pragma (Pack_Id, Pragma_Abstract_State), + Second => N); + end Initializes; + ------------ -- Inline -- ------------ @@ -13075,7 +14226,7 @@ package body Sem_Prag is begin GNAT_Pragma; Check_At_Least_N_Arguments (2); - Check_At_Most_N_Arguments (3); + Check_At_Most_N_Arguments (3); Check_Optional_Identifier (Arg1, Name_Entity); Check_Optional_Identifier (Arg2, Name_Check); @@ -13736,10 +14887,13 @@ package body Sem_Prag is Check_Arg_Is_Library_Level_Local_Name (Arg1); Check_Arg_Is_Static_Expression (Arg2, Standard_String); - -- This pragma applies only to objects + -- This pragma applies to objects and types - if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then - Error_Pragma_Arg ("pragma% applies only to objects", Arg1); + if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) + and then not Is_Type (Entity (Get_Pragma_Arg (Arg1))) + then + Error_Pragma_Arg + ("pragma% applies only to objects and types", Arg1); end if; -- The only processing required is to link this item on to the @@ -14672,7 +15826,7 @@ package body Sem_Prag is begin GNAT_Pragma; Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (2); + Check_At_Most_N_Arguments (2); -- Process first argument @@ -15044,6 +16198,34 @@ package body Sem_Prag is Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On); + ------------------ + -- Post[_Class] -- + ------------------ + + -- pragma Post (Boolean_EXPRESSION); + -- pragma Post_Class (Boolean_EXPRESSION); + + when Pragma_Post | Pragma_Post_Class => Post : declare + PC_Pragma : Node_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Pre_Post; + + -- Rewrite Post[_Class] pragma as Precondition pragma setting the + -- flag Class_Present to True for the Post_Class case. + + Set_Class_Present (N, Prag_Id = Pragma_Pre_Class); + PC_Pragma := New_Copy (N); + Set_Pragma_Identifier + (PC_Pragma, Make_Identifier (Loc, Name_Postcondition)); + Rewrite (N, PC_Pragma); + Set_Analyzed (N, False); + Analyze (N); + end Post; + ------------------- -- Postcondition -- ------------------- @@ -15078,6 +16260,34 @@ package body Sem_Prag is end if; end Postcondition; + ----------------- + -- Pre[_Class] -- + ----------------- + + -- pragma Pre (Boolean_EXPRESSION); + -- pragma Pre_Class (Boolean_EXPRESSION); + + when Pragma_Pre | Pragma_Pre_Class => Pre : declare + PC_Pragma : Node_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Pre_Post; + + -- Rewrite Pre[_Class] pragma as Precondition pragma setting the + -- flag Class_Present to True for the Pre_Class case. + + Set_Class_Present (N, Prag_Id = Pragma_Pre_Class); + PC_Pragma := New_Copy (N); + Set_Pragma_Identifier + (PC_Pragma, Make_Identifier (Loc, Name_Precondition)); + Rewrite (N, PC_Pragma); + Set_Analyzed (N, False); + Analyze (N); + end Pre; + ------------------ -- Precondition -- ------------------ @@ -15091,7 +16301,7 @@ package body Sem_Prag is begin GNAT_Pragma; Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (2); + Check_At_Most_N_Arguments (2); Check_Optional_Identifier (Arg1, Name_Check); Check_Precondition_Postcondition (In_Body); @@ -15318,16 +16528,24 @@ package body Sem_Prag is Set_Main_Priority (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); - -- Load an arbitrary entity from System.Tasking to make sure - -- this package is implicitly with'ed, since we need to have - -- the tasking run-time active for the pragma Priority to have - -- any effect. + -- Load an arbitrary entity from System.Tasking.Stages or + -- System.Tasking.Restricted.Stages (depending on the + -- supported profile) to make sure that one of these packages + -- is implicitly with'ed, since we need to have the tasking + -- run time active for the pragma Priority to have any effect. + -- Previously with with'ed the package System.Tasking, but + -- this package does not trigger the required initialization + -- of the run-time library. declare Discard : Entity_Id; pragma Warnings (Off, Discard); begin - Discard := RTE (RE_Task_List); + if Restricted_Profile then + Discard := RTE (RE_Activate_Restricted_Tasks); + else + Discard := RTE (RE_Activate_Tasks); + end if; end; -- Task or Protected, must be of type Integer @@ -15929,6 +17147,171 @@ package body Sem_Prag is when Pragma_Rational => Set_Rational_Profile; + ------------------------------------ + -- Refined_Depends/Refined_Global -- + ------------------------------------ + + -- pragma Refined_Depends (DEPENDENCY_RELATION); + + -- DEPENDENCY_RELATION ::= + -- null + -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE} + + -- DEPENDENCY_CLAUSE ::= + -- OUTPUT_LIST =>[+] INPUT_LIST + -- | NULL_DEPENDENCY_CLAUSE + + -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST + + -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT}) + + -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT}) + + -- OUTPUT ::= NAME | FUNCTION_RESULT + -- INPUT ::= NAME + + -- where FUNCTION_RESULT is a function Result attribute_reference + + -- pragma Refined_Global (GLOBAL_SPECIFICATION); + + -- GLOBAL_SPECIFICATION ::= + -- null + -- | GLOBAL_LIST + -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST} + + -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST + + -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In + -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM}) + -- GLOBAL_ITEM ::= NAME + + when Pragma_Refined_Depends | + Pragma_Refined_Global => Refined_Depends_Global : + declare + Body_Id : Entity_Id; + Legal : Boolean; + Spec_Id : Entity_Id; + + begin + Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal); + + -- Save the pragma in the contract of the subprogram body. The + -- remaining analysis is performed at the end of the enclosing + -- declarations. + + if Legal then + Add_Contract_Item (N, Body_Id); + end if; + end Refined_Depends_Global; + + ------------------ + -- Refined_Post -- + ------------------ + + -- pragma Refined_Post (boolean_EXPRESSION); + + when Pragma_Refined_Post => Refined_Post : declare + Body_Id : Entity_Id; + Legal : Boolean; + Spec_Id : Entity_Id; + + begin + Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal); + + -- Analyze the boolean expression as a "spec expression" + + if Legal then + Analyze_Pre_Post_Condition_In_Decl_Part (N, Spec_Id); + end if; + end Refined_Post; + + ------------------- + -- Refined_State -- + ------------------- + + -- pragma Refined_State (REFINEMENT_LIST); + + -- REFINEMENT_LIST ::= + -- REFINEMENT_CLAUSE + -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE}) + + -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST + + -- CONSTITUENT_LIST ::= + -- null + -- | CONSTITUENT + -- | (CONSTITUENT {, CONSTITUENT}) + + -- CONSTITUENT ::= object_NAME | state_NAME + + when Pragma_Refined_State => Refined_State : declare + Context : constant Node_Id := Parent (N); + Spec_Id : Entity_Id; + Stmt : Node_Id; + + begin + GNAT_Pragma; + S14_Pragma; + Check_Arg_Count (1); + + -- Ensure the proper placement of the pragma. Refined states must + -- be associated with a package body. + + if Nkind (Context) /= N_Package_Body then + Pragma_Misplaced; + return; + end if; + + Stmt := Prev (N); + while Present (Stmt) loop + + -- Skip prior pragmas, but check for duplicates + + 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 + + elsif not Comes_From_Source (Stmt) then + null; + + -- The pragma does not apply to a legal construct, issue an + -- error and stop the analysis. + + else + Pragma_Misplaced; + return; + end if; + + Stmt := Prev (Stmt); + end loop; + + -- State refinement is allowed only when the corresponding package + -- declaration has a non-null pragma Abstract_State. + + Spec_Id := Corresponding_Spec (Context); + + if No (Abstract_States (Spec_Id)) + or else Has_Null_Abstract_State (Spec_Id) + then + Error_Msg_NE + ("useless refinement, package & does not define abstract " + & "states", N, Spec_Id); + return; + end if; + + -- The pragma must be analyzed at the end of the declarations as + -- it has visibility over the whole declarative region. Save the + -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by + -- adding it to the contract of the package body. + + Add_Contract_Item (N, Defining_Entity (Context)); + end Refined_State; + ----------------------- -- Relative_Deadline -- ----------------------- @@ -16285,7 +17668,7 @@ package body Sem_Prag is -- in Freeze_Entity). if Is_Record_Type (Typ) - and then not Is_Immutably_Limited_Type (Typ) + and then not Is_Limited_View (Typ) then Error_Pragma ("pragma% can only apply to explicitly limited record type"); @@ -17467,6 +18850,34 @@ package body Sem_Prag is end loop; end Title; + ---------------------------- + -- Type_Invariant[_Class] -- + ---------------------------- + + -- pragma Type_Invariant[_Class] + -- ([Entity =>] type_LOCAL_NAME, + -- [Check =>] EXPRESSION); + + when Pragma_Type_Invariant | + Pragma_Type_Invariant_Class => + Type_Invariant : declare + I_Pragma : Node_Id; + + begin + Check_Arg_Count (2); + + -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma, + -- setting Class_Present for the Type_Invariant_Class case. + + Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class); + I_Pragma := New_Copy (N); + Set_Pragma_Identifier + (I_Pragma, Make_Identifier (Loc, Name_Invariant)); + Rewrite (N, I_Pragma); + Set_Analyzed (N, False); + Analyze (N); + end Type_Invariant; + --------------------- -- Unchecked_Union -- --------------------- @@ -18260,6 +19671,2233 @@ package body Sem_Prag is when Pragma_Exit => null; end Analyze_Pragma; + --------------------------------------------- + -- Analyze_Pre_Post_Condition_In_Decl_Part -- + --------------------------------------------- + + procedure Analyze_Pre_Post_Condition_In_Decl_Part + (Prag : Node_Id; + Subp_Id : Entity_Id) + is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag)); + Nam : constant Name_Id := Original_Aspect_Name (Prag); + Expr : Node_Id; + + Restore_Scope : Boolean := False; + -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit + + begin + -- Ensure that the subprogram and its formals are visible when analyzing + -- the expression of the pragma. + + if not In_Open_Scopes (Subp_Id) then + Restore_Scope := True; + Push_Scope (Subp_Id); + Install_Formals (Subp_Id); + end if; + + -- Preanalyze the boolean expression, we treat this as a spec expression + -- (i.e. similar to a default expression). + + Expr := Get_Pragma_Arg (Arg1); + + -- In ASIS mode, for a pragma generated from a source aspect, analyze + -- the original aspect expression, which is shared with the generated + -- pragma. + + if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then + Expr := Expression (Corresponding_Aspect (Prag)); + end if; + + Preanalyze_Assert_Expression (Expr, Standard_Boolean); + + -- For a class-wide condition, a reference to a controlling formal must + -- be interpreted as having the class-wide type (or an access to such) + -- so that the inherited condition can be properly applied to any + -- overriding operation (see ARM12 6.6.1 (7)). + + if Class_Present (Prag) then + Class_Wide_Condition : declare + T : constant Entity_Id := Find_Dispatching_Type (Subp_Id); + + ACW : Entity_Id := Empty; + -- Access to T'class, created if there is a controlling formal + -- that is an access parameter. + + function Get_ACW return Entity_Id; + -- If the expression has a reference to an controlling access + -- parameter, create an access to T'class for the necessary + -- conversions if one does not exist. + + function Process (N : Node_Id) return Traverse_Result; + -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class + -- aspect for a primitive subprogram of a tagged type T, a name + -- that denotes a formal parameter of type T is interpreted as + -- having type T'Class. Similarly, a name that denotes a formal + -- accessparameter of type access-to-T is interpreted as having + -- type access-to-T'Class. This ensures the expression is well- + -- defined for a primitive subprogram of a type descended from T. + -- Note that this replacement is not done for selector names in + -- parameter associations. These carry an entity for reference + -- purposes, but semantically they are just identifiers. + + ------------- + -- Get_ACW -- + ------------- + + function Get_ACW return Entity_Id is + Loc : constant Source_Ptr := Sloc (Prag); + Decl : Node_Id; + + begin + if No (ACW) then + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'T'), + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Class_Wide_Type (T), Loc), + All_Present => True)); + + Insert_Before (Unit_Declaration_Node (Subp_Id), Decl); + Analyze (Decl); + ACW := Defining_Identifier (Decl); + Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW); + end if; + + return ACW; + end Get_ACW; + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + Loc : constant Source_Ptr := Sloc (N); + Typ : Entity_Id; + + begin + if Is_Entity_Name (N) + and then Present (Entity (N)) + and then Is_Formal (Entity (N)) + and then Nkind (Parent (N)) /= N_Type_Conversion + and then + (Nkind (Parent (N)) /= N_Parameter_Association + or else N /= Selector_Name (Parent (N))) + then + if Etype (Entity (N)) = T then + Typ := Class_Wide_Type (T); + + elsif Is_Access_Type (Etype (Entity (N))) + and then Designated_Type (Etype (Entity (N))) = T + then + Typ := Get_ACW; + else + Typ := Empty; + end if; + + if Present (Typ) then + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Expression => New_Occurrence_Of (Entity (N), Loc))); + Set_Etype (N, Typ); + end if; + end if; + + return OK; + end Process; + + procedure Replace_Type is new Traverse_Proc (Process); + + -- Start of processing for Class_Wide_Condition + + begin + if not Present (T) then + + -- Pre'Class/Post'Class aspect cases + + if From_Aspect_Specification (Prag) then + if Nam = Name_uPre then + Error_Msg_Name_1 := Name_Pre; + else + Error_Msg_Name_1 := Name_Post; + end if; + + Error_Msg_Name_2 := Name_Class; + + Error_Msg_N + ("aspect `%''%` can only be specified for a primitive " + & "operation of a tagged type", + Corresponding_Aspect (Prag)); + + -- Pre_Class, Post_Class pragma cases + + else + if Nam = Name_uPre then + Error_Msg_Name_1 := Name_Pre_Class; + else + Error_Msg_Name_1 := Name_Post_Class; + end if; + + Error_Msg_N + ("pragma% can only be specified for a primitive " + & "operation of a tagged type", + Corresponding_Aspect (Prag)); + end if; + end if; + + Replace_Type (Get_Pragma_Arg (Arg1)); + end Class_Wide_Condition; + end if; + + -- Remove the subprogram from the scope stack now that the pre-analysis + -- of the precondition/postcondition is done. + + if Restore_Scope then + End_Scope; + end if; + end Analyze_Pre_Post_Condition_In_Decl_Part; + + ------------------------------------------ + -- Analyze_Refined_Depends_In_Decl_Part -- + ------------------------------------------ + + procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is + Dependencies : List_Id := No_List; + Depends : Node_Id; + -- The corresponding Depends pragma along with its clauses + + Global : Node_Id := Empty; + -- The corresponding Refined_Global pragma (if any) + + Out_Items : Elist_Id := No_Elist; + -- All output items as defined in pragma Refined_Global (if any) + + Refinements : List_Id := No_List; + -- The clauses of pragma Refined_Depends + + Spec_Id : Entity_Id; + -- The entity of the subprogram subject to pragma Refined_Depends + + procedure Check_Dependency_Clause (Dep_Clause : Node_Id); + -- Verify the legality of a single clause + + procedure Report_Extra_Clauses; + -- Emit an error for each extra clause the appears in Refined_Depends + + ----------------------------- + -- Check_Dependency_Clause -- + ----------------------------- + + procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is + function Inputs_Match + (Ref_Clause : Node_Id; + Do_Checks : Boolean) return Boolean; + -- Determine whether the inputs of clause Dep_Clause match those of + -- clause Ref_Clause. If flag Do_Checks is set, the routine reports + -- missed or extra input items. + + function Output_Constituents (State_Id : Entity_Id) return Elist_Id; + -- Given a state denoted by State_Id, return a list of all output + -- constituents that may be referenced within Refined_Depends. The + -- contents of the list depend on whethe Refined_Global is present. + + procedure Report_Unused_Constituents (Constits : Elist_Id); + -- Emit errors for all constituents found in list Constits + + ------------------ + -- Inputs_Match -- + ------------------ + + function Inputs_Match + (Ref_Clause : Node_Id; + Do_Checks : Boolean) return Boolean + is + Ref_Inputs : List_Id; + -- The input list of the refinement clause + + function Is_Matching_Input (Dep_Input : Node_Id) return Boolean; + -- Determine whether input Dep_Input matches one of the inputs of + -- clause Ref_Clause. + + procedure Report_Extra_Inputs; + -- Emit errors for all extra inputs that appear in Ref_Clause + + ----------------------- + -- Is_Matching_Input -- + ----------------------- + + function Is_Matching_Input (Dep_Input : Node_Id) return Boolean is + procedure Match_Error (Msg : String; N : Node_Id); + -- Emit a matching error if flag Do_Checks is set + + ----------------- + -- Match_Error -- + ----------------- + + procedure Match_Error (Msg : String; N : Node_Id) is + begin + if Do_Checks then + Error_Msg_N (Msg, N); + end if; + end Match_Error; + + -- Local variables + + Dep_Id : Node_Id; + Next_Ref_Input : Node_Id; + Ref_Id : Entity_Id; + Ref_Input : Node_Id; + + Has_Constituent : Boolean := False; + -- Flag set when the refinement input list contains at least + -- one constituent of the state denoted by Dep_Id. + + Has_Null_State : Boolean := False; + -- Flag set when the dependency input is a state with a null + -- refinement. + + Has_Refined_State : Boolean := False; + -- Flag set when the dependency input is a state with visible + -- refinement. + + -- Start of processing for Is_Matching_Input + + begin + -- Match a null input with another null input + + if Nkind (Dep_Input) = N_Null then + Ref_Input := First (Ref_Inputs); + + -- Remove the matching null from the pool of candidates + + if Nkind (Ref_Input) = N_Null then + Remove (Ref_Input); + return True; + + else + Match_Error + ("null input cannot be matched in corresponding " + & "refinement clause", Dep_Input); + end if; + + -- Remaining cases are formal parameters, variables, and states + + else + Dep_Id := Entity_Of (Dep_Input); + + -- Inspect all inputs of the refinement clause and attempt + -- to match against the inputs of the dependence clause. + + Ref_Input := First (Ref_Inputs); + while Present (Ref_Input) loop + + -- Store the next input now because a match will remove + -- it from the list. + + Next_Ref_Input := Next (Ref_Input); + + if Ekind (Dep_Id) = E_Abstract_State then + + -- A state with a null refinement matches either a + -- null input list or nothing at all (no input): + + -- Refined_State => (State => null) + + -- No input + + -- Depends => (<output> => (State, Input)) + -- Refined_Depends => (<output> => Input) -- OK + + -- Null input list + + -- Depends => (<output> => State) + -- Refined_Depends => (<output> => null) -- OK + + if Has_Null_Refinement (Dep_Id) then + Has_Null_State := True; + + -- Remove the matching null from the pool of + -- candidates. + + if Nkind (Ref_Input) = N_Null then + Remove (Ref_Input); + end if; + + return True; + + -- The state has a non-null refinement in which case + -- remove all the matching constituents of the state: + + -- Refined_State => (State => (C1, C2)) + -- Depends => (<output> => State) + -- Refined_Depends => (<output> => (C1, C2)) + + elsif Has_Non_Null_Refinement (Dep_Id) then + Has_Refined_State := True; + + -- Ref_Input is an entity name + + if Is_Entity_Name (Ref_Input) then + Ref_Id := Entity_Of (Ref_Input); + + -- The input of the refinement clause is a valid + -- constituent of the state. Remove the input + -- from the pool of candidates. Note that the + -- search continues because the state may be + -- represented by multiple constituents. + + if Ekind_In (Ref_Id, E_Abstract_State, + E_Variable) + and then Present (Refined_State (Ref_Id)) + and then Refined_State (Ref_Id) = Dep_Id + then + Has_Constituent := True; + Remove (Ref_Input); + end if; + end if; + end if; + + -- Formal parameters and variables are matched on + -- entities. If this is the case, remove the input from + -- the candidate list. + + elsif Is_Entity_Name (Ref_Input) + and then Entity_Of (Ref_Input) = Dep_Id + then + Remove (Ref_Input); + return True; + end if; + + Ref_Input := Next_Ref_Input; + end loop; + + -- When a state with a null refinement appears as the last + -- input, it matches nothing: + + -- Refined_State => (State => null) + -- Depends => (<output> => (Input, State)) + -- Refined_Depends => (<output> => Input) -- OK + + if Ekind (Dep_Id) = E_Abstract_State + and then Has_Null_Refinement (Dep_Id) + and then No (Ref_Input) + then + Has_Null_State := True; + end if; + end if; + + -- A state with visible refinement was matched against one or + -- more of its constituents. + + if Has_Constituent then + return True; + + -- A state with a null refinement matched null or nothing + + elsif Has_Null_State then + return True; + + -- The input of a dependence clause does not have a matching + -- input in the refinement clause, emit an error. + + else + Match_Error + ("input cannot be matched in corresponding refinement " + & "clause", Dep_Input); + + if Has_Refined_State then + Match_Error + ("\check the use of constituents in dependence " + & "refinement", Dep_Input); + end if; + + return False; + end if; + end Is_Matching_Input; + + ------------------------- + -- Report_Extra_Inputs -- + ------------------------- + + procedure Report_Extra_Inputs is + Input : Node_Id; + + begin + if Present (Ref_Inputs) and then Do_Checks then + Input := First (Ref_Inputs); + while Present (Input) loop + Error_Msg_N + ("unmatched or extra input in refinement clause", + Input); + + Next (Input); + end loop; + end if; + end Report_Extra_Inputs; + + -- Local variables + + Dep_Inputs : constant Node_Id := Expression (Dep_Clause); + Inputs : constant Node_Id := Expression (Ref_Clause); + Dep_Input : Node_Id; + Result : Boolean; + + -- Start of processing for Inputs_Match + + begin + -- Construct a list of all refinement inputs. Note that the input + -- list is copied because the algorithm modifies its contents and + -- this should not be visible in Refined_Depends. + + if Nkind (Inputs) = N_Aggregate then + Ref_Inputs := New_Copy_List (Expressions (Inputs)); + else + Ref_Inputs := New_List (Inputs); + end if; + + -- Depending on whether the original dependency clause mentions + -- states with visible refinement, the corresponding refinement + -- clause may differ greatly in structure and contents: + + -- State with null refinement + + -- Refined_State => (State => null) + -- Depends => (<output> => State) + -- Refined_Depends => (<output> => null) + + -- Depends => (<output> => (State, Input)) + -- Refined_Depends => (<output> => Input) + + -- Depends => (<output> => (Input_1, State, Input_2)) + -- Refined_Depends => (<output> => (Input_1, Input_2)) + + -- State with non-null refinement + + -- Refined_State => (State_1 => (C1, C2)) + -- Depends => (<output> => State) + -- Refined_Depends => (<output> => C1) + -- or + -- Refined_Depends => (<output> => (C1, C2)) + + if Nkind (Dep_Inputs) = N_Aggregate then + Dep_Input := First (Expressions (Dep_Inputs)); + while Present (Dep_Input) loop + if not Is_Matching_Input (Dep_Input) then + Result := False; + end if; + + Next (Dep_Input); + end loop; + + Result := True; + + -- Solitary input + + else + Result := Is_Matching_Input (Dep_Inputs); + end if; + + Report_Extra_Inputs; + return Result; + end Inputs_Match; + + ------------------------- + -- Output_Constituents -- + ------------------------- + + function Output_Constituents (State_Id : Entity_Id) return Elist_Id is + Item_Elmt : Elmt_Id; + Item_Id : Entity_Id; + Result : Elist_Id := No_Elist; + + begin + -- The related subprogram is subject to pragma Refined_Global. All + -- usable output constituents are defined in its output item list. + + if Present (Global) then + Item_Elmt := First_Elmt (Out_Items); + while Present (Item_Elmt) loop + Item_Id := Node (Item_Elmt); + + -- The constituent is part of the refinement of the input + -- state, add it to the result list. + + if Refined_State (Item_Id) = State_Id then + Add_Item (Item_Id, Result); + end if; + + Next_Elmt (Item_Elmt); + end loop; + + -- When pragma Refined_Global is not present, the usable output + -- constituents are all the constituents as defined in pragma + -- Refined_State. Note that the elements are copied because the + -- algorithm trims the list and this should not be reflected in + -- the state itself. + + else + Result := New_Copy_Elist (Refinement_Constituents (State_Id)); + end if; + + return Result; + end Output_Constituents; + + -------------------------------- + -- Report_Unused_Constituents -- + -------------------------------- + + procedure Report_Unused_Constituents (Constits : Elist_Id) is + Constit : Entity_Id; + Elmt : Elmt_Id; + Posted : Boolean := False; + + begin + if Present (Constits) then + Elmt := First_Elmt (Constits); + while Present (Elmt) loop + Constit := Node (Elmt); + + -- A constituent must always refine a state + + pragma Assert (Present (Refined_State (Constit))); + + -- When a state has a visible refinement and its mode is + -- Output_Only, all its constituents must be used as + -- outputs. + + if not Posted then + Posted := True; + Error_Msg_NE + ("output only state & must be replaced by all its " + & "constituents in dependence refinement", + N, Refined_State (Constit)); + end if; + + Error_Msg_NE + ("\ constituent & is missing in output list", N, Constit); + + Next_Elmt (Elmt); + end loop; + end if; + end Report_Unused_Constituents; + + -- Local variables + + Dep_Output : constant Node_Id := First (Choices (Dep_Clause)); + Dep_Id : Entity_Id; + Matching_Clause : Node_Id := Empty; + Next_Ref_Clause : Node_Id; + Ref_Clause : Node_Id; + Ref_Id : Entity_Id; + Ref_Output : Node_Id; + + Has_Constituent : Boolean := False; + -- Flag set when the refinement output list contains at least one + -- constituent of the state denoted by Dep_Id. + + Has_Null_State : Boolean := False; + -- Flag set when the output of clause Dep_Clause is a state with a + -- null refinement. + + Has_Refined_State : Boolean := False; + -- Flag set when the output of clause Dep_Clause is a state with + -- visible refinement. + + Out_Constits : Elist_Id := No_Elist; + -- This list contains the entities all output constituents of state + -- Dep_Id as defined in pragma Refined_State. + + -- Start of processing for Check_Dependency_Clause + + begin + -- The analysis of pragma Depends should produce normalized clauses + -- with exactly one output. This is important because output items + -- are unique in the whole dependence relation and can be used as + -- keys. + + pragma Assert (No (Next (Dep_Output))); + + -- Inspect all clauses of Refined_Depends and attempt to match the + -- output of Dep_Clause against an output from the refinement clauses + -- set. + + Ref_Clause := First (Refinements); + while Present (Ref_Clause) loop + Matching_Clause := Empty; + + -- Store the next clause now because a match will trim the list of + -- refinement clauses and this side effect should not be visible + -- in pragma Refined_Depends. + + Next_Ref_Clause := Next (Ref_Clause); + + -- The analysis of pragma Refined_Depends should produce + -- normalized clauses with exactly one output. + + Ref_Output := First (Choices (Ref_Clause)); + pragma Assert (No (Next (Ref_Output))); + + -- Two null output lists match if their inputs match + + if Nkind (Dep_Output) = N_Null + and then Nkind (Ref_Output) = N_Null + then + Matching_Clause := Ref_Clause; + exit; + + -- Two function 'Result attributes match if their inputs match. + -- Note that there is no need to compare the two prefixes because + -- the attributes cannot denote anything but the related function. + + elsif Is_Attribute_Result (Dep_Output) + and then Is_Attribute_Result (Ref_Output) + then + Matching_Clause := Ref_Clause; + exit; + + -- The remaining cases are formal parameters, variables and states + + elsif Is_Entity_Name (Dep_Output) then + Dep_Id := Entity_Of (Dep_Output); + + if Ekind (Dep_Id) = E_Abstract_State then + + -- A state with a null refinement matches either a null + -- output list or nothing at all (no clause): + + -- Refined_State => (State => null) + + -- No clause + + -- Depends => (State => null) + -- Refined_Depends => null -- OK + + -- Null output list + + -- Depends => (State => <input>) + -- Refined_Depends => (null => <input>) -- OK + + if Has_Null_Refinement (Dep_Id) then + Has_Null_State := True; + + -- When a state with null refinement matches a null + -- output, compare their inputs. + + if Nkind (Ref_Output) = N_Null then + Matching_Clause := Ref_Clause; + end if; + + exit; + + -- The state has a non-null refinement in which case the + -- match is based on constituents and inputs. A state with + -- multiple output constituents may match multiple clauses: + + -- Refined_State => (State => (C1, C2)) + -- Depends => (State => <input>) + -- Refined_Depends => ((C1, C2) => <input>) + + -- When normalized, the above becomes: + + -- Refined_Depends => (C1 => <input>, + -- C2 => <input>) + + elsif Has_Non_Null_Refinement (Dep_Id) then + Has_Refined_State := True; + + -- Store the entities of all output constituents of an + -- Output_Only state with visible refinement. + + if No (Out_Constits) + and then Is_Output_Only_State (Dep_Id) + then + Out_Constits := Output_Constituents (Dep_Id); + end if; + + if Is_Entity_Name (Ref_Output) then + Ref_Id := Entity_Of (Ref_Output); + + -- The output of the refinement clause is a valid + -- constituent of the state. Remove the clause from + -- the pool of candidates if both input lists match. + -- Note that the search continues because one clause + -- may have been normalized into multiple clauses as + -- per the example above. + + if Ekind_In (Ref_Id, E_Abstract_State, E_Variable) + and then Present (Refined_State (Ref_Id)) + and then Refined_State (Ref_Id) = Dep_Id + and then Inputs_Match + (Ref_Clause, Do_Checks => False) + then + Has_Constituent := True; + Remove (Ref_Clause); + + -- The matching constituent may act as an output + -- for an Output_Only state. Remove the item from + -- the available output constituents. + + Remove (Out_Constits, Ref_Id); + end if; + end if; + end if; + + -- Formal parameters and variables match if their inputs match + + elsif Is_Entity_Name (Ref_Output) + and then Entity_Of (Ref_Output) = Dep_Id + then + Matching_Clause := Ref_Clause; + exit; + end if; + end if; + + Ref_Clause := Next_Ref_Clause; + end loop; + + -- Handle the case where pragma Depends contains one or more clauses + -- that only mention states with null refinements. In that case the + -- corresponding pragma Refined_Depends may have a null relation. + + -- Refined_State => (State => null) + -- Depends => (State => null) + -- Refined_Depends => null -- OK + + -- Another instance of the same scenario occurs when the list of + -- refinements has been depleted while processing previous clauses. + + if Is_Entity_Name (Dep_Output) + and then (No (Refinements) or else Is_Empty_List (Refinements)) + then + Dep_Id := Entity_Of (Dep_Output); + + if Ekind (Dep_Id) = E_Abstract_State + and then Has_Null_Refinement (Dep_Id) + then + Has_Null_State := True; + end if; + end if; + + -- The above search produced a match based on unique output. Ensure + -- that the inputs match as well and if they do, remove the clause + -- from the pool of candidates. + + if Present (Matching_Clause) then + if Inputs_Match (Matching_Clause, Do_Checks => True) then + Remove (Matching_Clause); + end if; + + -- A state with a visible refinement was matched against one or + -- more clauses containing appropriate constituents. + + elsif Has_Constituent then + null; + + -- A state with a null refinement did not warrant a clause + + elsif Has_Null_State then + null; + + -- The dependence relation of pragma Refined_Depends does not contain + -- a matching clause, emit an error. + + else + Error_Msg_NE + ("dependence clause of subprogram & has no matching refinement " + & "in body", Ref_Clause, Spec_Id); + + if Has_Refined_State then + Error_Msg_N + ("\check the use of constituents in dependence refinement", + Ref_Clause); + end if; + end if; + + -- Emit errors for all unused constituents of an Output_Only state + -- with visible refinement. + + Report_Unused_Constituents (Out_Constits); + end Check_Dependency_Clause; + + -------------------------- + -- Report_Extra_Clauses -- + -------------------------- + + procedure Report_Extra_Clauses is + Clause : Node_Id; + + begin + if Present (Refinements) then + Clause := First (Refinements); + while Present (Clause) loop + + -- Do not complain about a null input refinement, since a null + -- input legitimately matches anything. + + if Nkind (Clause) /= N_Component_Association + or else Nkind (Expression (Clause)) /= N_Null + then + Error_Msg_N + ("unmatched or extra clause in dependence refinement", + Clause); + end if; + + Next (Clause); + end loop; + end if; + end Report_Extra_Clauses; + + -- Local variables + + Body_Decl : constant Node_Id := Parent (N); + Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); + Errors : constant Nat := Serious_Errors_Detected; + Clause : Node_Id; + Deps : Node_Id; + Refs : Node_Id; + + -- The following are dummy variables that capture unused output of + -- routine Collect_Global_Items. + + D1, D2 : Elist_Id := No_Elist; + D3, D4, D5, D6 : Boolean; + + -- Start of processing for Analyze_Refined_Depends_In_Decl_Part + + begin + Spec_Id := Corresponding_Spec (Body_Decl); + Depends := Get_Pragma (Spec_Id, Pragma_Depends); + + -- The subprogram declarations lacks pragma Depends. This renders + -- Refined_Depends useless as there is nothing to refine. + + if No (Depends) then + Error_Msg_NE + ("useless refinement, subprogram & lacks dependence clauses", + N, Spec_Id); + return; + end if; + + Deps := Get_Pragma_Arg (First (Pragma_Argument_Associations (Depends))); + + -- A null dependency relation renders the refinement useless because it + -- cannot possibly mention abstract states with visible refinement. Note + -- that the inverse is not true as states may be refined to null. + + if Nkind (Deps) = N_Null then + Error_Msg_NE + ("useless refinement, subprogram & does not depend on abstract " + & "state with visible refinement", N, Spec_Id); + return; + end if; + + -- Multiple dependency clauses appear as component associations of an + -- aggregate. + + pragma Assert (Nkind (Deps) = N_Aggregate); + Dependencies := Component_Associations (Deps); + + -- Analyze Refined_Depends as if it behaved as a regular pragma Depends. + -- This ensures that the categorization of all refined dependency items + -- is consistent with their role. + + Analyze_Depends_In_Decl_Part (N); + Refs := Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); + + if Serious_Errors_Detected = Errors then + + -- The related subprogram may be subject to pragma Refined_Global. If + -- this is the case, gather all output items. These are needed when + -- verifying the use of constituents that apply to output states with + -- visible refinement. + + Global := Get_Pragma (Body_Id, Pragma_Refined_Global); + + if Present (Global) then + Collect_Global_Items + (Prag => Global, + In_Items => D1, + In_Out_Items => D2, + Out_Items => Out_Items, + Has_In_State => D3, + Has_In_Out_State => D4, + Has_Out_State => D5, + Has_Null_State => D6); + end if; + + if Nkind (Refs) = N_Null then + Refinements := No_List; + + -- Multiple dependency clauses appear as component associations of an + -- aggregate. Note that the clauses are copied because the algorithm + -- modifies them and this should not be visible in Refined_Depends. + + else pragma Assert (Nkind (Refs) = N_Aggregate); + Refinements := New_Copy_List (Component_Associations (Refs)); + end if; + + -- Inspect all the clauses of pragma Depends looking for a matching + -- clause in pragma Refined_Depends. The approach is to use the + -- sole output of a clause as a key. Output items are unique in a + -- dependence relation. Clause normalization also ensured that all + -- clauses have exactly one output. Depending on what the key is, one + -- or more refinement clauses may satisfy the dependency clause. Each + -- time a dependency clause is matched, its related refinement clause + -- is consumed. In the end, two things may happen: + + -- 1) A clause of pragma Depends was not matched in which case + -- Check_Dependency_Clause reports the error. + + -- 2) Refined_Depends has an extra clause in which case the error + -- is reported by Report_Extra_Clauses. + + Clause := First (Dependencies); + while Present (Clause) loop + Check_Dependency_Clause (Clause); + Next (Clause); + end loop; + end if; + + if Serious_Errors_Detected = Errors then + Report_Extra_Clauses; + end if; + end Analyze_Refined_Depends_In_Decl_Part; + + ----------------------------------------- + -- Analyze_Refined_Global_In_Decl_Part -- + ----------------------------------------- + + procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is + Global : Node_Id; + -- The corresponding Global pragma + + Has_In_State : Boolean := False; + Has_In_Out_State : Boolean := False; + Has_Out_State : Boolean := False; + -- These flags are set when the corresponding Global pragma has a state + -- of mode Input, In_Out and Output respectively with a visible + -- refinement. + + Has_Null_State : Boolean := False; + -- This flag is set when the corresponding Global pragma has at least + -- one state with a null refinement. + + In_Constits : Elist_Id := No_Elist; + In_Out_Constits : Elist_Id := No_Elist; + Out_Constits : Elist_Id := No_Elist; + -- These lists contain the entities of all Input, In_Out and Output + -- constituents that appear in Refined_Global and participate in state + -- refinement. + + In_Items : Elist_Id := No_Elist; + In_Out_Items : Elist_Id := No_Elist; + Out_Items : Elist_Id := No_Elist; + -- These list contain the entities of all Input, In_Out and Output items + -- defined in the corresponding Global pragma. + + 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 + -- following completions apply to the constituents of the state: + -- 1) there is at least one constituent of mode In_Out + -- 2) there is at least one Input and one Output constituent + -- 3) not all constituents are present and one of them is of mode + -- Output. + -- This routine may remove elements from In_Constits, In_Out_Constits + -- and Out_Constits. + + procedure Check_Input_States; + -- Determine whether the corresponding Global pragma mentions Input + -- states with visible refinement and if so, ensure that at least one of + -- its constituents appears as an Input item in Refined_Global. + -- This routine may remove elements from In_Constits, In_Out_Constits + -- and Out_Constits. + + procedure Check_Output_States; + -- Determine whether the corresponding Global pragma mentions Output + -- states with visible refinement and if so, ensure that all of its + -- constituents appear as Output items in Refined_Global. This routine + -- may remove elements from In_Constits, In_Out_Constits and + -- Out_Constits. + + procedure Check_Refined_Global_List + (List : Node_Id; + Global_Mode : Name_Id := Name_Input); + -- Verify the legality of a single global list declaration. Global_Mode + -- denotes the current mode in effect. + + function Present_Then_Remove + (List : Elist_Id; + Item : Entity_Id) return Boolean; + -- Search List for a particular entity Item. If Item has been found, + -- remove it from List. This routine is used to strip lists In_Constits, + -- In_Out_Constits and Out_Constits of valid constituents. + + procedure Report_Extra_Constituents; + -- Emit an error for each constituent found in lists In_Constits, + -- In_Out_Constits and Out_Constits. + + ------------------------- + -- Check_In_Out_States -- + ------------------------- + + procedure Check_In_Out_States is + procedure Check_Constituent_Usage (State_Id : Entity_Id); + -- Determine whether one of the following coverage scenarios is in + -- effect: + -- 1) there is at least one constituent of mode In_Out + -- 2) there is at least one Input and one Output constituent + -- 3) not all constituents are present and one of them is of mode + -- Output. + -- If this is not the case, emit an error. + + ----------------------------- + -- Check_Constituent_Usage -- + ----------------------------- + + procedure Check_Constituent_Usage (State_Id : Entity_Id) is + Constit_Elmt : Elmt_Id; + Constit_Id : Entity_Id; + Has_Missing : Boolean := False; + In_Out_Seen : Boolean := False; + In_Seen : Boolean := False; + Out_Seen : Boolean := False; + + begin + -- Process all the constituents of the state and note their modes + -- within the global refinement. + + Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); + while Present (Constit_Elmt) loop + Constit_Id := Node (Constit_Elmt); + + if Present_Then_Remove (In_Constits, Constit_Id) then + In_Seen := True; + + elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then + In_Out_Seen := True; + + elsif Present_Then_Remove (Out_Constits, Constit_Id) then + Out_Seen := True; + + else + Has_Missing := True; + end if; + + Next_Elmt (Constit_Elmt); + end loop; + + -- A single In_Out constituent is a valid completion + + if In_Out_Seen then + null; + + -- A pair of one Input and one Output constituent is a valid + -- completion. + + elsif In_Seen and then Out_Seen then + null; + + -- A single Output constituent is a valid completion only when + -- some of the other constituents are missing. + + elsif Has_Missing and then Out_Seen then + null; + + else + Error_Msg_NE + ("global refinement of state & redefines the mode of its " + & "constituents", N, State_Id); + end if; + end Check_Constituent_Usage; + + -- Local variables + + Item_Elmt : Elmt_Id; + Item_Id : Entity_Id; + + -- Start of processing for Check_In_Out_States + + begin + -- Inspect the In_Out items of the corresponding Global pragma + -- looking for a state with a visible refinement. + + if Has_In_Out_State and then Present (In_Out_Items) then + Item_Elmt := First_Elmt (In_Out_Items); + while Present (Item_Elmt) loop + Item_Id := Node (Item_Elmt); + + -- Ensure that one of the three coverage variants is satisfied + + if Ekind (Item_Id) = E_Abstract_State + and then Has_Non_Null_Refinement (Item_Id) + then + Check_Constituent_Usage (Item_Id); + end if; + + Next_Elmt (Item_Elmt); + end loop; + end if; + end Check_In_Out_States; + + ------------------------ + -- Check_Input_States -- + ------------------------ + + procedure Check_Input_States is + procedure Check_Constituent_Usage (State_Id : Entity_Id); + -- Determine whether at least one constituent of state State_Id with + -- visible refinement is used and has mode Input. Ensure that the + -- remaining constituents do not have In_Out or Output modes. + + ----------------------------- + -- Check_Constituent_Usage -- + ----------------------------- + + procedure Check_Constituent_Usage (State_Id : Entity_Id) is + Constit_Elmt : Elmt_Id; + Constit_Id : Entity_Id; + In_Seen : Boolean := False; + + begin + Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); + while Present (Constit_Elmt) loop + Constit_Id := Node (Constit_Elmt); + + -- At least one of the constituents appears as an Input + + if Present_Then_Remove (In_Constits, Constit_Id) then + In_Seen := True; + + -- The constituent appears in the global refinement, but has + -- mode In_Out or Output. + + elsif Present_Then_Remove (In_Out_Constits, Constit_Id) + or else Present_Then_Remove (Out_Constits, Constit_Id) + then + Error_Msg_Name_1 := Chars (State_Id); + Error_Msg_NE + ("constituent & of state % must have mode Input in global " + & "refinement", N, Constit_Id); + end if; + + Next_Elmt (Constit_Elmt); + end loop; + + -- Not one of the constituents appeared as Input + + if not In_Seen then + Error_Msg_NE + ("global refinement of state & must include at least one " + & "constituent of mode Input", N, State_Id); + end if; + end Check_Constituent_Usage; + + -- Local variables + + Item_Elmt : Elmt_Id; + Item_Id : Entity_Id; + + -- Start of processing for Check_Input_States + + begin + -- Inspect the Input items of the corresponding Global pragma + -- looking for a state with a visible refinement. + + if Has_In_State and then Present (In_Items) then + Item_Elmt := First_Elmt (In_Items); + while Present (Item_Elmt) loop + Item_Id := Node (Item_Elmt); + + -- Ensure that at least one of the constituents is utilized and + -- is of mode Input. + + if Ekind (Item_Id) = E_Abstract_State + and then Has_Non_Null_Refinement (Item_Id) + then + Check_Constituent_Usage (Item_Id); + end if; + + Next_Elmt (Item_Elmt); + end loop; + end if; + end Check_Input_States; + + ------------------------- + -- Check_Output_States -- + ------------------------- + + procedure Check_Output_States is + procedure Check_Constituent_Usage (State_Id : Entity_Id); + -- Determine whether all constituents of state State_Id with visible + -- refinement are used and have mode Output. Emit an error if this is + -- not the case. + + ----------------------------- + -- Check_Constituent_Usage -- + ----------------------------- + + procedure Check_Constituent_Usage (State_Id : Entity_Id) is + Constit_Elmt : Elmt_Id; + Constit_Id : Entity_Id; + + begin + Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); + while Present (Constit_Elmt) loop + Constit_Id := Node (Constit_Elmt); + + if Present_Then_Remove (Out_Constits, Constit_Id) then + null; + + else + Remove (In_Constits, Constit_Id); + Remove (In_Out_Constits, Constit_Id); + + Error_Msg_Name_1 := Chars (State_Id); + Error_Msg_NE + ("constituent & of state % must have mode Output in " + & "global refinement", N, Constit_Id); + end if; + + Next_Elmt (Constit_Elmt); + end loop; + end Check_Constituent_Usage; + + -- Local variables + + Item_Elmt : Elmt_Id; + Item_Id : Entity_Id; + + -- Start of processing for Check_Output_States + + begin + -- Inspect the Output items of the corresponding Global pragma + -- looking for a state with a visible refinement. + + if Has_Out_State and then Present (Out_Items) then + Item_Elmt := First_Elmt (Out_Items); + while Present (Item_Elmt) loop + Item_Id := Node (Item_Elmt); + + -- Ensure that all of the constituents are utilized and they + -- have mode Output. + + if Ekind (Item_Id) = E_Abstract_State + and then Has_Non_Null_Refinement (Item_Id) + then + Check_Constituent_Usage (Item_Id); + end if; + + Next_Elmt (Item_Elmt); + end loop; + end if; + end Check_Output_States; + + ------------------------------- + -- Check_Refined_Global_List -- + ------------------------------- + + procedure Check_Refined_Global_List + (List : Node_Id; + Global_Mode : Name_Id := Name_Input) + is + procedure Check_Refined_Global_Item + (Item : Node_Id; + Global_Mode : Name_Id); + -- Verify the legality of a single global item declaration. Parameter + -- Global_Mode denotes the current mode in effect. + + ------------------------------- + -- Check_Refined_Global_Item -- + ------------------------------- + + procedure Check_Refined_Global_Item + (Item : Node_Id; + Global_Mode : Name_Id) + is + Item_Id : constant Entity_Id := Entity_Of (Item); + + procedure Inconsistent_Mode_Error (Expect : Name_Id); + -- Issue a common error message for all mode mismatches. Expect + -- denotes the expected mode. + + ----------------------------- + -- Inconsistent_Mode_Error -- + ----------------------------- + + procedure Inconsistent_Mode_Error (Expect : Name_Id) is + begin + Error_Msg_NE + ("global item & has inconsistent modes", Item, Item_Id); + + Error_Msg_Name_1 := Global_Mode; + Error_Msg_N ("\ expected mode %", Item); + + Error_Msg_Name_1 := Expect; + Error_Msg_N ("\ found mode %", Item); + end Inconsistent_Mode_Error; + + -- Start of processing for Check_Refined_Global_Item + + begin + -- The state or variable acts as a constituent of a state, collect + -- it for the state completeness checks performed later on. + + if Present (Refined_State (Item_Id)) then + if Global_Mode = Name_Input then + Add_Item (Item_Id, In_Constits); + + elsif Global_Mode = Name_In_Out then + Add_Item (Item_Id, In_Out_Constits); + + elsif Global_Mode = Name_Output then + Add_Item (Item_Id, Out_Constits); + end if; + + -- When not a constituent, ensure that both occurrences of the + -- item in pragmas Global and Refined_Global match. + + elsif Contains (In_Items, Item_Id) then + if Global_Mode /= Name_Input then + Inconsistent_Mode_Error (Name_Input); + end if; + + elsif Contains (In_Out_Items, Item_Id) then + if Global_Mode /= Name_In_Out then + Inconsistent_Mode_Error (Name_In_Out); + end if; + + elsif Contains (Out_Items, Item_Id) then + if Global_Mode /= Name_Output then + Inconsistent_Mode_Error (Name_Output); + end if; + + -- The item does not appear in the corresponding Global pragma, it + -- must be an extra. + + else + Error_Msg_NE ("extra global item &", Item, Item_Id); + end if; + end Check_Refined_Global_Item; + + -- Local variables + + Item : Node_Id; + + -- Start of processing for Check_Refined_Global_List + + begin + if Nkind (List) = N_Null then + null; + + -- Single global item declaration + + elsif Nkind_In (List, N_Expanded_Name, + N_Identifier, + N_Selected_Component) + then + Check_Refined_Global_Item (List, Global_Mode); + + -- Simple global list or moded global list declaration + + elsif Nkind (List) = N_Aggregate then + + -- The declaration of a simple global list appear as a collection + -- of expressions. + + if Present (Expressions (List)) then + Item := First (Expressions (List)); + while Present (Item) loop + Check_Refined_Global_Item (Item, Global_Mode); + + Next (Item); + end loop; + + -- The declaration of a moded global list appears as a collection + -- of component associations where individual choices denote + -- modes. + + elsif Present (Component_Associations (List)) then + Item := First (Component_Associations (List)); + while Present (Item) loop + Check_Refined_Global_List + (List => Expression (Item), + Global_Mode => Chars (First (Choices (Item)))); + + Next (Item); + end loop; + + -- Invalid tree + + else + raise Program_Error; + end if; + + -- Invalid list + + else + raise Program_Error; + end if; + end Check_Refined_Global_List; + + ------------------------- + -- Present_Then_Remove -- + ------------------------- + + function Present_Then_Remove + (List : Elist_Id; + Item : Entity_Id) return Boolean + is + Elmt : Elmt_Id; + + begin + if Present (List) then + Elmt := First_Elmt (List); + while Present (Elmt) loop + if Node (Elmt) = Item then + Remove_Elmt (List, Elmt); + return True; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + return False; + end Present_Then_Remove; + + ------------------------------- + -- Report_Extra_Constituents -- + ------------------------------- + + procedure Report_Extra_Constituents is + procedure Report_Extra_Constituents_In_List (List : Elist_Id); + -- Emit an error for every element of List + + --------------------------------------- + -- Report_Extra_Constituents_In_List -- + --------------------------------------- + + procedure Report_Extra_Constituents_In_List (List : Elist_Id) is + Constit_Elmt : Elmt_Id; + + begin + if Present (List) then + Constit_Elmt := First_Elmt (List); + while Present (Constit_Elmt) loop + Error_Msg_NE ("extra constituent &", N, Node (Constit_Elmt)); + Next_Elmt (Constit_Elmt); + end loop; + end if; + end Report_Extra_Constituents_In_List; + + -- Start of processing for Report_Extra_Constituents + + begin + Report_Extra_Constituents_In_List (In_Constits); + Report_Extra_Constituents_In_List (In_Out_Constits); + Report_Extra_Constituents_In_List (Out_Constits); + end Report_Extra_Constituents; + + -- Local variables + + Body_Decl : constant Node_Id := Parent (N); + Errors : constant Nat := Serious_Errors_Detected; + Items : constant Node_Id := + Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); + Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl); + + -- Start of processing for Analyze_Refined_Global_In_Decl_Part + + begin + Global := Get_Pragma (Spec_Id, Pragma_Global); + + -- The subprogram declaration lacks pragma Global. This renders + -- Refined_Global useless as there is nothing to refine. + + if No (Global) then + Error_Msg_NE + ("useless refinement, subprogram & lacks global items", N, Spec_Id); + return; + end if; + + -- Extract all relevant items from the corresponding Global pragma + + Collect_Global_Items + (Prag => Global, + In_Items => In_Items, + In_Out_Items => In_Out_Items, + Out_Items => Out_Items, + Has_In_State => Has_In_State, + Has_In_Out_State => Has_In_Out_State, + Has_Out_State => Has_Out_State, + Has_Null_State => Has_Null_State); + + -- The corresponding Global pragma must mention at least one state with + -- a visible refinement at the point Refined_Global is processed. States + -- with null refinements warrant a Refined_Global pragma. + + if not Has_In_State + and then not Has_In_Out_State + and then not Has_Out_State + and then not Has_Null_State + then + Error_Msg_NE + ("useless refinement, subprogram & does not mention abstract state " + & "with visible refinement", N, Spec_Id); + return; + end if; + + -- The global refinement of inputs and outputs cannot be null when the + -- corresponding Global pragma contains at least one item except in the + -- case where we have states with null refinements. + + if Nkind (Items) = N_Null + and then + (Present (In_Items) + or else Present (In_Out_Items) + or else Present (Out_Items)) + and then not Has_Null_State + then + Error_Msg_NE + ("refinement cannot be null, subprogram & has global items", + N, Spec_Id); + return; + end if; + + -- Analyze Refined_Global as if it behaved as a regular pragma Global. + -- This ensures that the categorization of all refined global items is + -- consistent with their role. + + Analyze_Global_In_Decl_Part (N); + + -- Perform all refinement checks with respect to completeness and mode + -- matching. + + if Serious_Errors_Detected = Errors then + Check_Refined_Global_List (Items); + end if; + + -- For Input states with visible refinement, at least one constituent + -- must be used as an Input in the global refinement. + + if Serious_Errors_Detected = Errors then + Check_Input_States; + end if; + + -- Verify all possible completion variants for In_Out states with + -- visible refinement. + + if Serious_Errors_Detected = Errors then + Check_In_Out_States; + end if; + + -- For Output states with visible refinement, all constituents must be + -- used as Outputs in the global refinement. + + if Serious_Errors_Detected = Errors then + Check_Output_States; + end if; + + -- Emit errors for all constituents that belong to other states with + -- visible refinement that do not appear in Global. + + if Serious_Errors_Detected = Errors then + Report_Extra_Constituents; + end if; + end Analyze_Refined_Global_In_Decl_Part; + + ---------------------------------------- + -- Analyze_Refined_State_In_Decl_Part -- + ---------------------------------------- + + procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id) is + Pack_Body : constant Node_Id := Parent (N); + Spec_Id : constant Entity_Id := Corresponding_Spec (Pack_Body); + + Abstr_States : Elist_Id := No_Elist; + -- A list of all abstract states defined in the package declaration. The + -- list is used to report unrefined states. + + Constituents_Seen : Elist_Id := No_Elist; + -- A list that contains all constituents processed so far. The list is + -- used to detect multiple uses of the same constituent. + + Hidden_States : Elist_Id := No_Elist; + -- A list of all hidden states (abstract states and variables) that + -- appear in the package spec and body. The list is used to report + -- unused hidden states. + + 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. + + procedure Analyze_Refinement_Clause (Clause : Node_Id); + -- Perform full analysis of a single refinement clause + + procedure Collect_Hidden_States; + -- Gather the entities of all hidden states that appear in the spec and + -- body of the related package in Hidden_States. + + procedure Report_Unrefined_States; + -- Emit errors for all abstract states that have not been refined by + -- the pragma. + + procedure Report_Unused_Hidden_States; + -- Emit errors for all hidden states of the related package that do not + -- participate in a refinement. + + ------------------------------- + -- Analyze_Refinement_Clause -- + ------------------------------- + + procedure Analyze_Refinement_Clause (Clause : Node_Id) is + State_Id : Entity_Id := Empty; + -- The entity of the state being refined in the current clause + + Non_Null_Seen : Boolean := False; + Null_Seen : Boolean := False; + -- Flags used to detect multiple uses of null in a single clause or a + -- mixture of null and non-null constituents. + + procedure Analyze_Constituent (Constit : Node_Id); + -- Perform full analysis of a single constituent + + procedure Check_Matching_State + (State : Node_Id; + State_Id : Entity_Id); + -- Determine whether state State denoted by its name State_Id appears + -- in Abstr_States. Emit an error when attempting to re-refine the + -- state or when the state is not defined in the package declaration. + -- Otherwise remove the state from Abstr_States. + + ------------------------- + -- Analyze_Constituent -- + ------------------------- + + procedure Analyze_Constituent (Constit : Node_Id) is + procedure Check_Matching_Constituent (Constit_Id : Entity_Id); + -- Determine whether constituent Constit denoted by its entity + -- Constit_Id appears in Hidden_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. + + -------------------------------- + -- Check_Matching_Constituent -- + -------------------------------- + + procedure Check_Matching_Constituent (Constit_Id : Entity_Id) is + procedure Collect_Constituent; + -- Add constituent Constit_Id to the refinements of State_Id + + ------------------------- + -- Collect_Constituent -- + ------------------------- + + procedure Collect_Constituent is + begin + -- Add the constituent to the lis of processed items to aid + -- with the detection of duplicates. + + Add_Item (Constit_Id, Constituents_Seen); + + -- Collect the constituent in the list of refinement items. + -- Establish a relation between the refined state and its + -- constituent. + + Append_Elmt (Constit_Id, Refinement_Constituents (State_Id)); + Set_Refined_State (Constit_Id, State_Id); + + -- The state has at least one legal constituent, mark the + -- start of the refinement region. The region ends when the + -- body declarations end (see routine Analyze_Declarations). + + Set_Has_Visible_Refinement (State_Id); + end Collect_Constituent; + + -- Local variables + + State_Elmt : Elmt_Id; + + -- Start of processing for Check_Matching_Constituent + + begin + -- Detect a duplicate use of a constituent + + if Contains (Constituents_Seen, Constit_Id) then + Error_Msg_NE + ("duplicate use of constituent &", Constit, Constit_Id); + return; + + -- A state can act as a constituent only when it is part of + -- another state. This relation is expressed by option Part_Of + -- of pragma Abstract_State. + + elsif Ekind (Constit_Id) = E_Abstract_State then + if not Is_Part_Of (Constit_Id, State_Id) then + Error_Msg_Name_1 := Chars (State_Id); + Error_Msg_NE + ("state & is not a valid constituent of ancestor " + & "state %", Constit, Constit_Id); + return; + + -- The constituent has the proper Part_Of option, but may + -- not appear in the immediate hidden state of the related + -- package. This case arises when the constituent appears + -- in a private child or a private sibling. Recognize these + -- scenarios and collect the constituent. + + elsif Is_Child_Or_Sibling + (Pack_1 => Scope (State_Id), + Pack_2 => Scope (Constit_Id), + Private_Child => True) + then + Collect_Constituent; + return; + end if; + end if; + + -- Inspect the hidden states of the related package looking for + -- a match. + + if Present (Hidden_States) then + State_Elmt := First_Elmt (Hidden_States); + while Present (State_Elmt) loop + + -- A valid hidden state or variable acts as a constituent + + if Node (State_Elmt) = Constit_Id then + + -- Add the constituent to the lis of processed items + -- to aid with the detection of duplicates. Remove the + -- constituent from Hidden_States to signal that it + -- has already been matched. + + Add_Item (Constit_Id, Constituents_Seen); + Remove_Elmt (Hidden_States, State_Elmt); + + Collect_Constituent; + return; + end if; + + Next_Elmt (State_Elmt); + end loop; + end if; + + -- If we get here, we are refining a state that is not hidden + -- with respect to the related package. + + Error_Msg_Name_1 := Chars (Spec_Id); + Error_Msg_NE + ("cannot use & in refinement, constituent is not a hidden " + & "state of package %", Constit, Constit_Id); + end Check_Matching_Constituent; + + -- Local variables + + Constit_Id : Entity_Id; + + -- Start of processing for Analyze_Constituent + + begin + -- Detect multiple uses of null in a single refinement clause or a + -- mixture of null and non-null constituents. + + if Nkind (Constit) = N_Null then + if Null_Seen then + Error_Msg_N + ("multiple null constituents not allowed", Constit); + + elsif Non_Null_Seen then + Error_Msg_N + ("cannot mix null and non-null constituents", Constit); + + else + Null_Seen := True; + + -- Collect the constituent in the list of refinement items + + Append_Elmt (Constit, Refinement_Constituents (State_Id)); + + -- The state has at least one legal constituent, mark the + -- start of the refinement region. The region ends when the + -- body declarations end (see Analyze_Declarations). + + Set_Has_Visible_Refinement (State_Id); + end if; + + -- Non-null constituents + + else + Non_Null_Seen := True; + + if Null_Seen then + Error_Msg_N + ("cannot mix null and non-null constituents", Constit); + end if; + + Analyze (Constit); + + -- Ensure that the constituent denotes a valid state or a + -- whole variable. + + if Is_Entity_Name (Constit) then + Constit_Id := Entity (Constit); + + if Ekind_In (Constit_Id, E_Abstract_State, E_Variable) then + Check_Matching_Constituent (Constit_Id); + + else + Error_Msg_NE + ("constituent & must denote a variable or state", + Constit, Constit_Id); + end if; + + -- The constituent is illegal + + else + Error_Msg_N ("malformed constituent", Constit); + end if; + end if; + end Analyze_Constituent; + + -------------------------- + -- Check_Matching_State -- + -------------------------- + + procedure Check_Matching_State + (State : Node_Id; + State_Id : Entity_Id) + is + State_Elmt : Elmt_Id; + + begin + -- Detect a duplicate refinement of a state + + if Contains (Refined_States_Seen, State_Id) then + Error_Msg_NE + ("duplicate refinement of state &", State, State_Id); + return; + end if; + + -- Inspect the abstract states defined in the package declaration + -- looking for a match. + + State_Elmt := First_Elmt (Abstr_States); + while Present (State_Elmt) loop + + -- A valid abstract state is being refined in the body. Add + -- the state to the list of processed refined states to aid + -- with the detection of duplicate refinements. Remove the + -- state from Abstr_States to signal that it has already been + -- refined. + + if Node (State_Elmt) = State_Id then + Add_Item (State_Id, Refined_States_Seen); + Remove_Elmt (Abstr_States, State_Elmt); + return; + end if; + + Next_Elmt (State_Elmt); + end loop; + + -- If we get here, we are refining a state that is not defined in + -- the package declaration. + + Error_Msg_Name_1 := Chars (Spec_Id); + Error_Msg_NE + ("cannot refine state, & is not defined in package %", + State, State_Id); + end Check_Matching_State; + + -- Local declarations + + Constit : Node_Id; + State : Node_Id; + + -- Start of processing for Analyze_Refinement_Clause + + begin + -- Analyze the state name of a refinement clause + + State := First (Choices (Clause)); + while Present (State) loop + if Present (State_Id) then + Error_Msg_N + ("refinement clause cannot cover multiple states", State); + + else + Analyze (State); + + -- Ensure that the state name denotes a valid abstract state + -- that is defined in the spec of the related package. + + if Is_Entity_Name (State) then + State_Id := Entity (State); + + -- 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 (State, State_Id); + else + Error_Msg_NE + ("& must denote an abstract state", State, State_Id); + end if; + + -- Enforce SPARK RM (6.1.5(4)): A global item shall not + -- denote a state abstraction whose refinement is visible + -- (a state abstraction cannot be named within its enclosing + -- package's body other than in its refinement). + + if Has_Body_References (State_Id) then + declare + Ref : Elmt_Id; + Nod : Node_Id; + begin + Ref := First_Elmt (Body_References (State_Id)); + while Present (Ref) loop + Nod := Node (Ref); + Error_Msg_N + ("global reference to & not allowed " + & "(SPARK RM 6.1.5(4))", Nod); + Error_Msg_Sloc := Sloc (State); + Error_Msg_N ("\refinement of & is visible#", Nod); + Next_Elmt (Ref); + end loop; + end; + end if; + + -- The state name is illegal + + else + Error_Msg_N + ("malformed state name in refinement clause", State); + end if; + end if; + + Next (State); + end loop; + + -- Analyze all constituents of the refinement. Multiple constituents + -- appear as an aggregate. + + Constit := Expression (Clause); + + if Nkind (Constit) = N_Aggregate then + if Present (Component_Associations (Constit)) then + Error_Msg_N + ("constituents of refinement clause must appear in " + & "positional form", Constit); + + else pragma Assert (Present (Expressions (Constit))); + Constit := First (Expressions (Constit)); + while Present (Constit) loop + Analyze_Constituent (Constit); + + Next (Constit); + end loop; + end if; + + -- Various forms of a single constituent. Note that these may include + -- malformed constituents. + + else + Analyze_Constituent (Constit); + end if; + end Analyze_Refinement_Clause; + + --------------------------- + -- Collect_Hidden_States -- + --------------------------- + + procedure Collect_Hidden_States is + procedure Collect_Hidden_States_In_Decls (Decls : List_Id); + -- Find all hidden states that appear in declarative list Decls and + -- append their entities to Result. + + ------------------------------------ + -- Collect_Hidden_States_In_Decls -- + ------------------------------------ + + procedure Collect_Hidden_States_In_Decls (Decls : List_Id) is + procedure Collect_Abstract_States (States : Elist_Id); + -- Copy the abstract states defined in list States to list Result + + ----------------------------- + -- Collect_Abstract_States -- + ----------------------------- + + procedure Collect_Abstract_States (States : Elist_Id) is + State_Elmt : Elmt_Id; + + begin + State_Elmt := First_Elmt (States); + while Present (State_Elmt) loop + Add_Item (Node (State_Elmt), Hidden_States); + + Next_Elmt (State_Elmt); + end loop; + end Collect_Abstract_States; + + -- Local variables + + Decl : Node_Id; + + -- Start of processing for Collect_Hidden_States_In_Decls + + begin + Decl := First (Decls); + while Present (Decl) loop + + -- Source objects (non-constants) are valid hidden states + + if Nkind (Decl) = N_Object_Declaration + and then Ekind (Defining_Entity (Decl)) = E_Variable + and then Comes_From_Source (Decl) + then + Add_Item (Defining_Entity (Decl), Hidden_States); + + -- Gather the abstract states of a package along with all + -- hidden states in its visible declarations. + + elsif Nkind (Decl) = N_Package_Declaration then + Collect_Abstract_States + (Abstract_States (Defining_Entity (Decl))); + + Collect_Hidden_States_In_Decls + (Visible_Declarations (Specification (Decl))); + end if; + + Next (Decl); + end loop; + end Collect_Hidden_States_In_Decls; + + -- Local variables + + Pack_Spec : constant Node_Id := Package_Specification (Spec_Id); + + -- Start of processing for Collect_Hidden_States + + begin + -- Process the private declarations of the package spec and the + -- declarations of the body. + + Collect_Hidden_States_In_Decls (Private_Declarations (Pack_Spec)); + Collect_Hidden_States_In_Decls (Declarations (Pack_Body)); + end Collect_Hidden_States; + + ----------------------------- + -- Report_Unrefined_States -- + ----------------------------- + + procedure Report_Unrefined_States is + State_Elmt : Elmt_Id; + + begin + if Present (Abstr_States) then + State_Elmt := First_Elmt (Abstr_States); + while Present (State_Elmt) loop + Error_Msg_N + ("abstract state & must be refined", Node (State_Elmt)); + + Next_Elmt (State_Elmt); + end loop; + end if; + end Report_Unrefined_States; + + --------------------------------- + -- Report_Unused_Hidden_States -- + --------------------------------- + + procedure Report_Unused_Hidden_States is + Posted : Boolean := False; + State_Elmt : Elmt_Id; + State_Id : Entity_Id; + + begin + if Present (Hidden_States) then + State_Elmt := First_Elmt (Hidden_States); + while Present (State_Elmt) loop + State_Id := Node (State_Elmt); + + -- Generate an error message of the form: + + -- package ... has unused hidden states + -- abstract state ... defined at ... + -- variable ... defined at ... + + if not Posted then + Posted := True; + Error_Msg_NE + ("package & has unused hidden states", N, Spec_Id); + end if; + + Error_Msg_Sloc := Sloc (State_Id); + + if Ekind (State_Id) = E_Abstract_State then + Error_Msg_NE ("\ abstract state & defined #", N, State_Id); + else + Error_Msg_NE ("\ variable & defined #", N, State_Id); + end if; + + Next_Elmt (State_Elmt); + end loop; + end if; + end Report_Unused_Hidden_States; + + -- Local declarations + + Clauses : constant Node_Id := + Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); + Clause : Node_Id; + + -- Start of processing for Analyze_Refined_State_In_Decl_Part + + begin + Set_Analyzed (N); + + -- Initialize the various lists used during analysis + + Abstr_States := New_Copy_Elist (Abstract_States (Spec_Id)); + Collect_Hidden_States; + + -- Multiple state refinements appear as an aggregate + + if Nkind (Clauses) = N_Aggregate then + if Present (Expressions (Clauses)) then + Error_Msg_N + ("state refinements must appear as component associations", + Clauses); + + else pragma Assert (Present (Component_Associations (Clauses))); + Clause := First (Component_Associations (Clauses)); + while Present (Clause) loop + Analyze_Refinement_Clause (Clause); + + Next (Clause); + end loop; + end if; + + -- Various forms of a single state refinement. Note that these may + -- include malformed refinements. + + else + Analyze_Refinement_Clause (Clauses); + end if; + + -- Ensure that all abstract states have been refined and all hidden + -- states of the related package unilized in refinements. + + Report_Unrefined_States; + Report_Unused_Hidden_States; + end Analyze_Refined_State_In_Decl_Part; + ------------------------------------ -- Analyze_Test_Case_In_Decl_Part -- ------------------------------------ @@ -18380,7 +22018,7 @@ package body Sem_Prag is PP : Node_Id; Policy : Name_Id; - Ename : constant Name_Id := Original_Name (N); + Ename : constant Name_Id := Original_Aspect_Name (N); begin -- No effect if not valid assertion kind name @@ -18450,6 +22088,153 @@ package body Sem_Prag is end if; end Check_Applicable_Policy; + -------------------------- + -- Collect_Global_Items -- + -------------------------- + + procedure Collect_Global_Items + (Prag : Node_Id; + In_Items : in out Elist_Id; + In_Out_Items : in out Elist_Id; + Out_Items : in out Elist_Id; + Has_In_State : out Boolean; + Has_In_Out_State : out Boolean; + Has_Out_State : out Boolean; + Has_Null_State : out Boolean) + is + procedure Process_Global_List + (List : Node_Id; + Mode : Name_Id := Name_Input); + -- Collect all items housed in a global list. Formal Mode denotes the + -- current mode in effect. + + ------------------------- + -- Process_Global_List -- + ------------------------- + + procedure Process_Global_List + (List : Node_Id; + Mode : Name_Id := Name_Input) + is + procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id); + -- Add a single item to the appropriate list. Formal Mode denotes the + -- current mode in effect. + + ------------------------- + -- Process_Global_Item -- + ------------------------- + + procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id) is + Item_Id : constant Entity_Id := Entity_Of (Item); + + begin + -- Signal that the global list contains at least one abstract + -- state with a visible refinement. Note that the refinement may + -- be null in which case there are no constituents. + + if Ekind (Item_Id) = E_Abstract_State then + if Has_Null_Refinement (Item_Id) then + Has_Null_State := True; + + elsif Has_Non_Null_Refinement (Item_Id) then + if Mode = Name_Input then + Has_In_State := True; + elsif Mode = Name_In_Out then + Has_In_Out_State := True; + elsif Mode = Name_Output then + Has_Out_State := True; + end if; + end if; + end if; + + -- Add the item to the proper list + + if Mode = Name_Input then + Add_Item (Item_Id, In_Items); + elsif Mode = Name_In_Out then + Add_Item (Item_Id, In_Out_Items); + elsif Mode = Name_Output then + Add_Item (Item_Id, Out_Items); + end if; + end Process_Global_Item; + + -- Local variables + + Item : Node_Id; + + -- Start of processing for Process_Global_List + + begin + if Nkind (List) = N_Null then + null; + + -- Single global item declaration + + elsif Nkind_In (List, N_Expanded_Name, + N_Identifier, + N_Selected_Component) + then + Process_Global_Item (List, Mode); + + -- Single global list or moded global list declaration + + elsif Nkind (List) = N_Aggregate then + + -- The declaration of a simple global list appear as a collection + -- of expressions. + + if Present (Expressions (List)) then + Item := First (Expressions (List)); + while Present (Item) loop + Process_Global_Item (Item, Mode); + + Next (Item); + end loop; + + -- The declaration of a moded global list appears as a collection + -- of component associations where individual choices denote mode. + + elsif Present (Component_Associations (List)) then + Item := First (Component_Associations (List)); + while Present (Item) loop + Process_Global_List + (List => Expression (Item), + Mode => Chars (First (Choices (Item)))); + + Next (Item); + end loop; + + -- Invalid tree + + else + raise Program_Error; + end if; + + -- Invalid list + + else + raise Program_Error; + end if; + end Process_Global_List; + + -- Local variables + + Items : constant Node_Id := + Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); + + -- Start of processing for Collect_Global_Items + + begin + -- Assume that no states have been encountered + + Has_In_State := False; + Has_In_Out_State := False; + Has_Out_State := False; + Has_Null_State := False; + + Process_Global_List (Items); + end Collect_Global_Items; + --------------------------------------- -- Collect_Subprogram_Inputs_Outputs -- --------------------------------------- @@ -18499,17 +22284,20 @@ package body Sem_Prag is -- Start of processing for Collect_Global_List begin + if Nkind (List) = N_Null then + null; + -- Single global item declaration - if Nkind_In (List, N_Expanded_Name, - N_Identifier, - N_Selected_Component) + elsif Nkind_In (List, N_Expanded_Name, + N_Identifier, + N_Selected_Component) then Collect_Global_Item (List, Mode); -- Simple global list or moded global list declaration - else + elsif Nkind (List) = N_Aggregate then if Present (Expressions (List)) then Item := First (Expressions (List)); while Present (Item) loop @@ -18526,23 +22314,37 @@ package body Sem_Prag is Next (Assoc); end loop; end if; + + -- Invalid list + + else + raise Program_Error; end if; end Collect_Global_List; -- Local variables - Formal : Entity_Id; - Global : Node_Id; - List : Node_Id; + Formal : Entity_Id; + Global : Node_Id; + List : Node_Id; + Spec_Id : Entity_Id; -- Start of processing for Collect_Subprogram_Inputs_Outputs begin Global_Seen := False; + -- Find the entity of the corresponding spec when processing a body + + if Ekind (Subp_Id) = E_Subprogram_Body then + Spec_Id := Corresponding_Spec (Parent (Parent (Subp_Id))); + else + Spec_Id := Subp_Id; + end if; + -- Process all formal parameters - Formal := First_Formal (Subp_Id); + Formal := First_Formal (Spec_Id); while Present (Formal) loop if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then Add_Item (Formal, Subp_Inputs); @@ -18550,29 +22352,47 @@ package body Sem_Prag is if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then Add_Item (Formal, Subp_Outputs); + + -- Out parameters can act as inputs when the related type is + -- tagged, unconstrained array, unconstrained record or record + -- with unconstrained components. + + if Ekind (Formal) = E_Out_Parameter + and then Is_Unconstrained_Or_Tagged_Item (Formal) + then + Add_Item (Formal, Subp_Inputs); + end if; end if; Next_Formal (Formal); end loop; - -- If the subprogram is subject to pragma Global, traverse all global - -- lists and gather the relevant items. + -- When processing a subprogram body, look for pragma Refined_Global as + -- it provides finer granularity of inputs and outputs. - Global := Find_Aspect (Subp_Id, Aspect_Global); - if Present (Global) then - Global_Seen := True; + if Ekind (Subp_Id) = E_Subprogram_Body then + Global := Get_Pragma (Subp_Id, Pragma_Refined_Global); - -- Retrieve the pragma as it contains the analyzed lists + -- Subprogram declaration case, look for pragma Global - Global := Aspect_Rep_Item (Global); - List := Expression (First (Pragma_Argument_Associations (Global))); + else + Global := Get_Pragma (Spec_Id, Pragma_Global); + end if; + + if Present (Global) then + Global_Seen := True; + List := Expression (First (Pragma_Argument_Associations (Global))); -- 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 - Analyze_Global_In_Decl_Part (Global); + 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; -- Nothing to be done for a null global list @@ -18593,77 +22413,92 @@ package body Sem_Prag is Name_Priority_Specific_Dispatching); end Delay_Config_Pragma_Analyze; - ----------------------------- - -- Find_Related_Subprogram -- - ----------------------------- + ------------------------------------- + -- Find_Related_Subprogram_Or_Body -- + ------------------------------------- - function Find_Related_Subprogram - (Prag : Node_Id; - Check_Duplicates : Boolean := False) return Node_Id + function Find_Related_Subprogram_Or_Body + (Prag : Node_Id; + Do_Checks : Boolean := False) return Node_Id is - Context : constant Node_Id := Parent (Prag); - Nam : constant Name_Id := Pragma_Name (Prag); - Elmt : Node_Id; - Subp_Decl : Node_Id; + Context : constant Node_Id := Parent (Prag); + Nam : constant Name_Id := Pragma_Name (Prag); + Stmt : Node_Id; + + Look_For_Body : constant Boolean := + Nam_In (Nam, Name_Refined_Depends, + Name_Refined_Global, + Name_Refined_Post); + -- Refinement pragmas must be associated with a subprogram body [stub] begin pragma Assert (Nkind (Prag) = N_Pragma); - -- If the pragma comes from an aspect, then what we want is the - -- declaration to which the aspect is attached, i.e. its parent. + -- If the pragma is a byproduct of aspect expansion, return the related + -- context of the original aspect. if Present (Corresponding_Aspect (Prag)) then return Parent (Corresponding_Aspect (Prag)); end if; - -- Otherwise the pragma must be a list element, and the first thing to - -- do is to position past any previous pragmas or generated code. What - -- we are doing here is looking for the preceding declaration. This is - -- also where we will check for a duplicate pragma. + -- Otherwise the pragma is a source construct, most likely part of a + -- declarative list. Skip preceding declarations while looking for a + -- proper subprogram declaration. pragma Assert (Is_List_Member (Prag)); - Elmt := Prag; - loop - Elmt := Prev (Elmt); - exit when No (Elmt); + Stmt := Prev (Prag); + while Present (Stmt) loop - -- Typically want we will want is the declaration original node. But - -- for the generic subprogram case, don't go to to the original node, - -- which is the unanalyzed tree: we need to attach the pre- and post- - -- conditions to the analyzed version at this point. They propagate - -- to the original tree when analyzing the corresponding body. + -- Skip prior pragmas, but check for duplicates - if Nkind (Elmt) not in N_Generic_Declaration then - Subp_Decl := Original_Node (Elmt); - else - Subp_Decl := Elmt; - end if; - - -- Skip prior pragmas - - if Nkind (Subp_Decl) = N_Pragma then - if Check_Duplicates and then Pragma_Name (Subp_Decl) = Nam then + if Nkind (Stmt) = N_Pragma then + if Do_Checks and then Pragma_Name (Stmt) = Nam then Error_Msg_Name_1 := Nam; - Error_Msg_Sloc := Sloc (Subp_Decl); + Error_Msg_Sloc := Sloc (Stmt); Error_Msg_N ("pragma % duplicates pragma declared #", Prag); end if; + -- Emit an error when a refinement pragma appears on an expression + -- function without a completion. + + elsif Do_Checks + and then Look_For_Body + and then Nkind (Stmt) = N_Subprogram_Declaration + and then Nkind (Original_Node (Stmt)) = N_Expression_Function + and then not Has_Completion (Defining_Entity (Stmt)) + then + Error_Msg_Name_1 := Nam; + Error_Msg_N + ("pragma % cannot apply to a stand alone expression function", + Prag); + + return Empty; + + -- The refinement pragma applies to a subprogram body stub + + elsif Look_For_Body + and then Nkind (Stmt) = N_Subprogram_Body_Stub + then + return Stmt; + -- Skip internally generated code - elsif not Comes_From_Source (Subp_Decl) then + elsif not Comes_From_Source (Stmt) then null; - -- Otherwise we have a declaration to return + -- Return the current construct which is either a subprogram body, + -- a subprogram declaration or is illegal. else - return Subp_Decl; + return Stmt; end if; + + Prev (Stmt); end loop; - -- We fell through, which means there was no declaration preceding the - -- pragma (either it was the first element of the list, or we only had - -- other pragmas and generated code before it). + -- 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 library-level subprogram @@ -18675,12 +22510,12 @@ package body Sem_Prag is elsif Nkind (Context) = N_Subprogram_Body then return Context; - -- Otherwise no subprogram found, return original pragma + -- No candidate subprogram [body] found else - return Prag; + return Empty; end if; - end Find_Related_Subprogram; + end Find_Related_Subprogram_Or_Body; ------------------------- -- Get_Base_Subprogram -- @@ -18943,7 +22778,9 @@ package body Sem_Prag is Pragma_Import_Valued_Procedure => 0, Pragma_Independent => 0, Pragma_Independent_Components => 0, + Pragma_Initial_Condition => -1, Pragma_Initialize_Scalars => -1, + Pragma_Initializes => -1, Pragma_Inline => 0, Pragma_Inline_Always => 0, Pragma_Inline_Generic => 0, @@ -18991,14 +22828,18 @@ package body Sem_Prag is Pragma_Page => -1, Pragma_Partition_Elaboration_Policy => -1, Pragma_Passive => -1, - Pragma_Preelaborable_Initialization => -1, - Pragma_Polling => -1, Pragma_Persistent_BSS => 0, + Pragma_Polling => -1, + Pragma_Post => -1, Pragma_Postcondition => -1, + Pragma_Post_Class => -1, + Pragma_Pre => -1, Pragma_Precondition => -1, Pragma_Predicate => -1, + Pragma_Preelaborable_Initialization => -1, Pragma_Preelaborate => -1, Pragma_Preelaborate_05 => -1, + Pragma_Pre_Class => -1, Pragma_Priority => -1, Pragma_Priority_Specific_Dispatching => -1, Pragma_Profile => 0, @@ -19012,6 +22853,10 @@ package body Sem_Prag is Pragma_Queuing_Policy => -1, Pragma_Rational => -1, Pragma_Ravenscar => -1, + Pragma_Refined_Depends => -1, + Pragma_Refined_Global => -1, + Pragma_Refined_Post => -1, + Pragma_Refined_State => -1, Pragma_Relative_Deadline => -1, Pragma_Remote_Access_Type => -1, Pragma_Remote_Call_Interface => -1, @@ -19050,6 +22895,8 @@ package body Sem_Prag is Pragma_Thread_Local_Storage => 0, Pragma_Time_Slice => -1, Pragma_Title => -1, + Pragma_Type_Invariant => -1, + Pragma_Type_Invariant_Class => -1, Pragma_Unchecked_Union => 0, Pragma_Unimplemented_Unit => -1, Pragma_Universal_Aliasing => -1, @@ -19121,6 +22968,40 @@ package body Sem_Prag is end if; end Is_Non_Significant_Pragma_Reference; + ---------------- + -- Is_Part_Of -- + ---------------- + + function Is_Part_Of + (State : Entity_Id; + Ancestor : Entity_Id) return Boolean + is + Options : constant Node_Id := Parent (State); + Name : Node_Id; + Option : Node_Id; + Value : Node_Id; + + begin + -- A state declaration with option Part_Of appears as an extension + -- aggregate with component associations. + + if Nkind (Options) = N_Extension_Aggregate then + Option := First (Component_Associations (Options)); + while Present (Option) loop + Name := First (Choices (Option)); + Value := Expression (Option); + + if Chars (Name) = Name_Part_Of then + return Entity (Value) = Ancestor; + end if; + + Next (Option); + end loop; + end if; + + return False; + end Is_Part_Of; + ------------------------------ -- Is_Pragma_String_Literal -- ------------------------------ @@ -19208,6 +23089,62 @@ package body Sem_Prag is and then List_Containing (N) = Private_Declarations (Parent (N)); end Is_Private_SPARK_Mode; + ------------------------------------- + -- Is_Unconstrained_Or_Tagged_Item -- + ------------------------------------- + + function Is_Unconstrained_Or_Tagged_Item + (Item : Entity_Id) return Boolean + is + function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean; + -- Determine whether record type Typ has at least one unconstrained + -- component. + + --------------------------------- + -- Has_Unconstrained_Component -- + --------------------------------- + + function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is + Comp : Entity_Id; + + begin + Comp := First_Component (Typ); + while Present (Comp) loop + if Is_Unconstrained_Or_Tagged_Item (Comp) then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + end Has_Unconstrained_Component; + + -- Local variables + + Typ : constant Entity_Id := Etype (Item); + + -- Start of processing for Is_Unconstrained_Or_Tagged_Item + + begin + if Is_Tagged_Type (Typ) then + return True; + + elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then + return True; + + elsif Is_Record_Type (Typ) then + if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then + return True; + else + return Has_Unconstrained_Component (Typ); + end if; + + else + return False; + end if; + end Is_Unconstrained_Or_Tagged_Item; + ----------------------------- -- Is_Valid_Assertion_Kind -- ----------------------------- @@ -19234,6 +23171,7 @@ package body Sem_Prag is Name_Assume | Name_Contract_Cases | Name_Debug | + Name_Initial_Condition | Name_Invariant | Name_uInvariant | Name_Loop_Invariant | @@ -19241,6 +23179,7 @@ package body Sem_Prag is Name_Postcondition | Name_Precondition | Name_Predicate | + Name_Refined_Post | Name_Statement_Assertions => return True; when others => return False; @@ -19323,66 +23262,6 @@ package body Sem_Prag is end if; end Make_Aspect_For_PPC_In_Gen_Sub_Decl; - ------------------- - -- Original_Name -- - ------------------- - - function Original_Name (N : Node_Id) return Name_Id is - Pras : Node_Id; - Name : Name_Id; - - begin - pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma)); - Pras := N; - - if Is_Rewrite_Substitution (Pras) - and then Nkind (Original_Node (Pras)) = N_Pragma - then - Pras := Original_Node (Pras); - end if; - - -- Case where we came from aspect specication - - if Nkind (Pras) = N_Pragma and then From_Aspect_Specification (Pras) then - Pras := Corresponding_Aspect (Pras); - end if; - - -- Get name from aspect or pragma - - if Nkind (Pras) = N_Pragma then - Name := Pragma_Name (Pras); - else - Name := Chars (Identifier (Pras)); - end if; - - -- Deal with 'Class - - if Class_Present (Pras) then - case Name is - - -- Names that need converting to special _xxx form - - when Name_Pre => Name := Name_uPre; - when Name_Post => Name := Name_uPost; - when Name_Invariant => Name := Name_uInvariant; - when Name_Type_Invariant => Name := Name_uType_Invariant; - - -- Names already in special _xxx form (leave them alone) - - when Name_uPre => null; - when Name_uPost => null; - when Name_uInvariant => null; - when Name_uType_Invariant => null; - - -- Anything else is impossible with Class_Present set True - - when others => raise Program_Error; - end case; - end if; - - return Name; - end Original_Name; - ------------------------- -- Preanalyze_CTC_Args -- ------------------------- @@ -19446,6 +23325,137 @@ package body Sem_Prag is end Process_Compilation_Unit_Pragmas; + ------------------------------------ + -- Record_Possible_Body_Reference -- + ------------------------------------ + + procedure Record_Possible_Body_Reference + (Item : Node_Id; + Item_Id : Entity_Id) + is + begin + if Is_Body_Name (Unit_Name (Get_Source_Unit (Item))) + and then Ekind (Item_Id) = E_Abstract_State + then + if not Has_Body_References (Item_Id) then + Set_Has_Body_References (Item_Id, True); + Set_Body_References (Item_Id, New_Elmt_List); + end if; + + Append_Elmt (Item, Body_References (Item_Id)); + end if; + end Record_Possible_Body_Reference; + + ------------------------------ + -- Relocate_Pragmas_To_Body -- + ------------------------------ + + procedure Relocate_Pragmas_To_Body + (Subp_Body : Node_Id; + Target_Body : Node_Id := Empty) + is + procedure Relocate_Pragma (Prag : Node_Id); + -- Remove a single pragma from its current list and add it to the + -- declarations of the proper body (either Subp_Body or Target_Body). + + --------------------- + -- Relocate_Pragma -- + --------------------- + + procedure Relocate_Pragma (Prag : Node_Id) is + Decls : List_Id; + Target : Node_Id; + + begin + -- When subprogram stubs or expression functions are involves, the + -- destination declaration list belongs to the proper body. + + if Present (Target_Body) then + Target := Target_Body; + else + Target := Subp_Body; + end if; + + Decls := Declarations (Target); + + if No (Decls) then + Decls := New_List; + Set_Declarations (Target, Decls); + end if; + + -- Unhook the pragma from its current list + + Remove (Prag); + Prepend (Prag, Decls); + end Relocate_Pragma; + + -- Local variables + + Body_Id : constant Entity_Id := + Defining_Unit_Name (Specification (Subp_Body)); + Next_Stmt : Node_Id; + Stmt : Node_Id; + + -- Start of processing for Relocate_Pragmas_To_Body + + begin + -- Do not process a body that comes from a separate unit as no construct + -- can possibly follow it. + + if not Is_List_Member (Subp_Body) then + return; + + -- Do not relocate pragmas that follow a stub if the stub does not have + -- a proper body. + + elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub + and then No (Target_Body) + then + return; + + -- Do not process internally generated routine _Postconditions + + elsif Ekind (Body_Id) = E_Procedure + and then Chars (Body_Id) = Name_uPostconditions + then + return; + end if; + + -- Look at what is following the body. We are interested in certain kind + -- of pragmas (either from source or byproducts of expansion) that can + -- apply to a body [stub]. + + Stmt := Next (Subp_Body); + while Present (Stmt) loop + + -- Preserve the following statement for iteration purposes due to a + -- possible relocation of a pragma. + + Next_Stmt := Next (Stmt); + + -- Move a candidate pragma following the body to the declarations of + -- the body. + + if Nkind (Stmt) = N_Pragma + and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt)) + then + Relocate_Pragma (Stmt); + + -- Skip internally generated code + + elsif not Comes_From_Source (Stmt) then + null; + + -- No candidate pragmas are available for relocation + + else + exit; + end if; + + Stmt := Next_Stmt; + end loop; + end Relocate_Pragmas_To_Body; + ---------------------------- -- Rewrite_Assertion_Kind -- ---------------------------- @@ -19484,44 +23494,6 @@ package body Sem_Prag is null; end rv; - ----------------------------------- - -- Requires_Profile_Installation -- - ----------------------------------- - - function Requires_Profile_Installation - (Prag : Node_Id; - Subp : Node_Id) return Boolean - is - begin - -- When aspects Depends and Global are associated with a subprogram - -- declaration, their corresponding pragmas are analyzed at the end of - -- the declarative part. This is done out of context, therefore the - -- formals must be installed in visibility. - - if Nkind (Subp) = N_Subprogram_Declaration then - return True; - - -- When aspects Depends and Global are associated with a subprogram body - -- which is also a compilation unit, their corresponding pragmas appear - -- in the Pragmas_After list. The Pragmas_After collection is analyzed - -- out of context and the formals must be installed in visibility. This - -- does not apply when the pragma is a source construct. - - elsif Nkind (Subp) = N_Subprogram_Body then - if Nkind (Parent (Subp)) = N_Compilation_Unit then - return Present (Corresponding_Aspect (Prag)); - else - return False; - end if; - - -- In all other cases the two corresponding pragmas are analyzed in - -- context and the formals are already visibile. - - else - return False; - end if; - end Requires_Profile_Installation; - -------------------------------- -- Set_Encoded_Interface_Name -- -------------------------------- diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index ecfb3eda75a..c03799dd56f 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -26,11 +26,25 @@ -- Pragma handling is isolated in a separate package -- (logically this processing belongs in chapter 4) -with Namet; use Namet; -with Types; use Types; +with Namet; use Namet; +with Snames; use Snames; +with Types; use Types; package Sem_Prag is + -- 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. + + Pragma_On_Body_Or_Stub_OK : constant array (Pragma_Id) of Boolean := + (Pragma_Refined_Depends => True, + Pragma_Refined_Global => True, + Pragma_Refined_Post => True, + Pragma_SPARK_Mode => True, + Pragma_Warnings => True, + others => False); + ----------------- -- Subprograms -- ----------------- @@ -42,26 +56,47 @@ package Sem_Prag is -- Perform full analysis and expansion of delayed pragma Contract_Cases procedure Analyze_Depends_In_Decl_Part (N : Node_Id); - -- Perform full analysis of delayed pragma Depends + -- Perform full analysis of delayed pragma Depends. This routine is also + -- capable of performing basic analysis of pragma Refined_Depends. procedure Analyze_Global_In_Decl_Part (N : Node_Id); - -- Perform full analysis of delayed pragma Global + -- Perform full analysis of delayed pragma Global. This routine is also + -- capable of performing basic analysis of pragma Refind_Global. + + procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id); + -- Perform full analysis of delayed pragma Initial_Condition + + procedure Analyze_Initializes_In_Decl_Part (N : Node_Id); + -- Perform full analysis of delayed pragma Initializes - procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id); - -- Special analyze routine for precondition/postcondition pragma that - -- appears within a declarative part where the pragma is associated - -- with a subprogram specification. N is the pragma node, and S is the - -- entity for the related subprogram. This procedure does a preanalysis - -- of the expressions in the pragma as "spec expressions" (see section - -- in Sem "Handling of Default and Per-Object Expressions..."). + procedure Analyze_Pre_Post_Condition_In_Decl_Part + (Prag : Node_Id; + Subp_Id : Entity_Id); + -- Perform preanalysis of a [refined] precondition or postcondition that + -- appears on a subprogram declaration or body [stub]. Prag denotes the + -- pragma, Subp_Id is the entity of the related subprogram. The preanalysis + -- of the expression is done as "spec expression" (see section "Handling + -- of Default and Per-Object Expressions in Sem). + + procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id); + -- Preform full analysis of delayed pragma Refined_Depends. This routine + -- uses Analyze_Depends_In_Decl_Part as a starting point, then performs + -- various consistency checks between Depends and Refined_Depends. + + procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id); + -- Perform full analysis of delayed pragma Refined_Global. This routine + -- 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_Test_Case_In_Decl_Part (N : Node_Id; S : Entity_Id); - -- Special analyze routine for contract-case and test-case pragmas that - -- appears within a declarative part where the pragma is associated with - -- a subprogram specification. N is the pragma node, and S is the entity - -- for the related subprogram. This procedure does a preanalysis of the - -- expressions in the pragma as "spec expressions" (see section in Sem - -- "Handling of Default and Per-Object Expressions..."). + -- Perform preanalysis of pragma Test_Case that applies to a subprogram + -- declaration. Parameter N denotes the pragma, S is the entity of the + -- related subprogram. The preanalysis of the expression is done as "spec + -- expression" (see section "Handling of Default and Per-Object Expressions + -- in Sem). procedure Check_Applicable_Policy (N : Node_Id); -- N is either an N_Aspect or an N_Pragma node. There are two cases. If @@ -155,6 +190,15 @@ 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_Body + (Subp_Body : Node_Id; + Target_Body : Node_Id := Empty); + -- Resocate all pragmas that follow and apply to subprogram body Subp_Body + -- to its own declaration list. Candidate pragmas are classified in table + -- Pragma_On_Body_Or_Stub_OK. If Target_Body is set, the pragma are moved + -- to the declarations of Target_Body. This formal should be set when + -- dealing with subprogram body stubs or expression functions. + procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id); -- This routine is used to set an encoded interface name. The node S is an -- N_String_Literal node for the external name to be set, and E is an diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 387e06f31db..9a76e04adf6 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2095,10 +2095,19 @@ package body Sem_Res is Check_Parameterless_Call (N); + -- The resolution of an Expression_With_Actions is determined by + -- its Expression. + + if Nkind (N) = N_Expression_With_Actions then + Resolve (Expression (N), Typ); + + Found := True; + Expr_Type := Etype (Expression (N)); + -- If not overloaded, then we know the type, and all that needs doing -- is to check that this type is compatible with the context. - if not Is_Overloaded (N) then + elsif not Is_Overloaded (N) then Found := Covers (Typ, Etype (N)); Expr_Type := Etype (N); @@ -3602,7 +3611,7 @@ package body Sem_Res is and then Full_Expander_Active and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) then - Establish_Transient_Scope (A, False); + Establish_Transient_Scope (A, Sec_Stack => False); Resolve (A, Etype (F)); -- A small optimization: if one of the actuals is a concatenation @@ -3621,7 +3630,7 @@ package body Sem_Res is and then Chars (Nam) = Name_Asm) and then not Static_Concatenation (A) then - Establish_Transient_Scope (A, False); + Establish_Transient_Scope (A, Sec_Stack => False); Resolve (A, Etype (F)); else @@ -3634,7 +3643,7 @@ package body Sem_Res is then Error_Msg_N ("conversion between unrelated limited array types " - & "not allowed (\A\I-00246)", A); + & "not allowed ('A'I-00246)", A); if Is_Limited_Type (Etype (F)) then Explain_Limited_Type (Etype (F), A); @@ -3666,8 +3675,8 @@ package body Sem_Res is then New_Itype := Create_Itype (E_Anonymous_Access_Type, A); Set_Etype (New_Itype, Etype (A)); - Set_Directly_Designated_Type (New_Itype, - Directly_Designated_Type (Etype (A))); + Set_Directly_Designated_Type + (New_Itype, Directly_Designated_Type (Etype (A))); Set_Etype (A, New_Itype); end if; @@ -3680,7 +3689,7 @@ package body Sem_Res is if (Is_Controlled (DDT) or else Has_Task (DDT)) and then Full_Expander_Active then - Establish_Transient_Scope (A, False); + Establish_Transient_Scope (A, Sec_Stack => False); end if; end; @@ -3701,7 +3710,7 @@ package body Sem_Res is if Is_Tagged_Type (F_Typ) and then (Is_Concurrent_Type (F_Typ) - or else Is_Concurrent_Record_Type (F_Typ)) + or else Is_Concurrent_Record_Type (F_Typ)) then -- If the actual is overloaded, look for an interpretation -- that has a synchronized type. @@ -3768,10 +3777,10 @@ package body Sem_Res is Resolve (A, Etype (F)); end if; end; - else - -- not a synchronized operation. + -- Not a synchronized operation + else Resolve (A, Etype (F)); end if; end if; @@ -3933,6 +3942,16 @@ package body Sem_Res is and then not Is_Init_Proc (Nam) then Error_Msg_NE ("actual for& must be a variable", A, F); + + if Is_Subprogram (Current_Scope) + and then + (Is_Invariant_Procedure (Current_Scope) + or else Is_Predicate_Function (Current_Scope)) + then + Error_Msg_N + ("function used in predicate cannot " + & "modify its argument", F); + end if; end if; -- What's the following about??? @@ -4155,7 +4174,7 @@ package body Sem_Res is and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) or else (Nkind (A) = N_Attribute_Reference and then - Is_Class_Wide_Type (Etype (Prefix (A))))) + Is_Class_Wide_Type (Etype (Prefix (A))))) and then not Is_Class_Wide_Type (Designated_Type (F_Typ)) and then not Is_Controlling_Formal (F) @@ -4179,12 +4198,14 @@ package body Sem_Res is Eval_Actual (A); -- If it is a named association, treat the selector_name as a - -- proper identifier, and mark the corresponding entity. Ignore - -- this reference in SPARK mode, as it refers to an entity not in - -- scope at the point of reference, so the reference should be - -- ignored for computing effects of subprograms. + -- proper identifier, and mark the corresponding entity. if Nkind (Parent (A)) = N_Parameter_Association + + -- Ignore reference in SPARK mode, as it refers to an entity not + -- in scope at the point of reference, so the reference should + -- be ignored for computing effects of subprograms. + and then not SPARK_Mode then Set_Entity (Selector_Name (Parent (A)), F); @@ -4344,7 +4365,7 @@ package body Sem_Res is -- of the current b-i-p implementation to unify the handling for -- multiple kinds of storage pools). ??? - if Is_Immutably_Limited_Type (Desig_T) + if Is_Limited_View (Desig_T) and then Nkind (Expression (E)) = N_Function_Call then declare @@ -4583,7 +4604,7 @@ package body Sem_Res is if Ada_Version >= Ada_2012 and then Is_Limited_Type (Desig_T) - and then not Is_Immutably_Limited_Type (Scope (Discr)) + and then not Is_Limited_View (Scope (Discr)) then Error_Msg_N ("only immutably limited types can have anonymous " @@ -7262,6 +7283,17 @@ package body Sem_Res is procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is begin Set_Etype (N, Typ); + + -- If N has no actions, and its expression has been constant folded, + -- then rewrite N as just its expression. Note, we can't do this in + -- the general case of Is_Empty_List (Actions (N)) as this would cause + -- Expression (N) to be expanded again. + + if Is_Empty_List (Actions (N)) + and then Compile_Time_Known_Value (Expression (N)) + then + Rewrite (N, Expression (N)); + end if; end Resolve_Expression_With_Actions; --------------------------- @@ -8295,19 +8327,22 @@ package body Sem_Res is begin -- Catch attempts to do fixed-point exponentiation with universal -- operands, which is a case where the illegality is not caught during - -- normal operator analysis. + -- normal operator analysis. This is not done in preanalysis mode + -- since the tree is not fully decorated during preanalysis. - if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then - Error_Msg_N ("exponentiation not available for fixed point", N); - return; + if Full_Analysis then + if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then + Error_Msg_N ("exponentiation not available for fixed point", N); + return; - elsif Nkind (Parent (N)) in N_Op - and then Is_Fixed_Point_Type (Etype (Parent (N))) - and then Etype (N) = Universal_Real - and then Comes_From_Source (N) - then - Error_Msg_N ("exponentiation not available for fixed point", N); - return; + elsif Nkind (Parent (N)) in N_Op + and then Is_Fixed_Point_Type (Etype (Parent (N))) + and then Etype (N) = Universal_Real + and then Comes_From_Source (N) + then + Error_Msg_N ("exponentiation not available for fixed point", N); + return; + end if; end if; if Comes_From_Source (N) @@ -8326,7 +8361,7 @@ package body Sem_Res is end if; -- We do the resolution using the base type, because intermediate values - -- in expressions always are of the base type, not a subtype of it. + -- in expressions are always of the base type, not a subtype of it. Resolve (Left_Opnd (N), B_Typ); Resolve (Right_Opnd (N), Standard_Integer); @@ -8981,6 +9016,30 @@ package body Sem_Res is R : constant Node_Id := Right_Opnd (N); begin + -- Ensure all actions associated with the left operand (e.g. + -- finalization of transient controlled objects) are fully evaluated + -- locally within an expression with actions. This is particularly + -- helpful for coverage analysis. However this should not happen in + -- generics. + + if Full_Expander_Active then + declare + Reloc_L : constant Node_Id := Relocate_Node (L); + begin + Save_Interps (Old_N => L, New_N => Reloc_L); + + Rewrite (L, + Make_Expression_With_Actions (Sloc (L), + Actions => New_List, + Expression => Reloc_L)); + + -- Set Comes_From_Source on L to preserve warnings for unset + -- reference. + + Set_Comes_From_Source (L, Comes_From_Source (Reloc_L)); + end; + end if; + Resolve (L, B_Typ); Resolve (R, B_Typ); @@ -9843,7 +9902,7 @@ package body Sem_Res is -- Ada 2005 (AI-217): Handle entities from limited views - if From_With_Type (Opnd) then + if From_Limited_With (Opnd) then Error_Msg_Qual_Level := 99; Error_Msg_NE -- CODEFIX ("missing WITH clause on package &", N, @@ -9852,7 +9911,7 @@ package body Sem_Res is ("type conversions require visibility of the full view", N); - elsif From_With_Type (Target) + elsif From_Limited_With (Target) and then not (Is_Access_Type (Target_Typ) and then Present (Non_Limited_View (Etype (Target)))) @@ -10856,7 +10915,7 @@ package body Sem_Res is -- it to determine whether the conversion is legal. elsif Is_Class_Wide_Type (Opnd_Type) - and then From_With_Type (Opnd_Type) + and then From_Limited_With (Opnd_Type) and then Present (Non_Limited_View (Etype (Opnd_Type))) and then Is_Interface (Non_Limited_View (Etype (Opnd_Type))) then @@ -11331,7 +11390,7 @@ package body Sem_Res is -- Handle the limited view of a type if Is_Incomplete_Type (Desig) - and then From_With_Type (Desig) + and then From_Limited_With (Desig) and then Present (Non_Limited_View (Desig)) then return Available_View (Desig); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 78e49224e59..8e0fd5fa80d 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -1127,7 +1127,7 @@ package body Sem_Type is then return Covers (Designated_Type (T1), Designated_Type (T2)) or else - (From_With_Type (Designated_Type (T1)) + (From_Limited_With (Designated_Type (T1)) and then Covers (Designated_Type (T2), Designated_Type (T1))); -- A boolean operation on integer literals is compatible with modular @@ -1205,7 +1205,7 @@ package body Sem_Type is -- Ada 2005 (AI-50217): Additional branches to make the shadow entity -- obtained through a limited_with compatible with its real entity. - elsif From_With_Type (T1) then + elsif From_Limited_With (T1) then -- If the expected type is the non-limited view of a type, the -- expression may have the limited view. If that one in turn is @@ -1221,7 +1221,7 @@ package body Sem_Type is return False; end if; - elsif From_With_Type (T2) then + elsif From_Limited_With (T2) then -- If units in the context have Limited_With clauses on each other, -- either type might have a limited view. Checks performed elsewhere @@ -2611,8 +2611,13 @@ package body Sem_Type is begin AI := First (Interface_List (Parent (Target_Typ))); + + -- The progenitor itself may be a subtype of an interface type. + while Present (AI) loop - if Etype (AI) = Iface_Typ then + if Etype (AI) = Iface_Typ + or else Base_Type (Etype (AI)) = Iface_Typ + then return True; elsif Present (Interfaces (Etype (AI))) @@ -3204,6 +3209,8 @@ package body Sem_Type is begin if Is_Overloaded (Old_N) then + Set_Is_Overloaded (New_N); + if Nkind (Old_N) = N_Selected_Component and then Is_Overloaded (Selector_Name (Old_N)) then diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index 2c5c1dba778..60eefa51c75 100644 --- a/gcc/ada/sem_type.ads +++ b/gcc/ada/sem_type.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -124,7 +124,7 @@ package Sem_Type is -- denotes whether an interpretation has been disabled by an abstract -- operator. Add_One_Interp includes semantic processing to deal with -- adding entries that hide one another etc. - + -- -- For operators, the legality of the operation depends on the visibility -- of T and its scope. If the operator is an equality or comparison, T is -- always Boolean, and we use Opnd_Type, which is a candidate type for one @@ -158,8 +158,9 @@ package Sem_Type is procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id); -- If an overloaded node is rewritten during semantic analysis, its -- possible interpretations must be linked to the copy. This procedure - -- transfers the overload information from Old_N, the old node, to - -- New_N, its new copy. It has no effect in the non-overloaded case. + -- transfers the overload information (Is_Overloaded flag, and list of + -- interpretations) from Old_N, the old node, to New_N, its new copy. + -- It has no effect in the non-overloaded case. function Covers (T1, T2 : Entity_Id) return Boolean; -- This is the basic type compatibility routine. T1 is the expected type, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index dcad44f1bba..08acd702caf 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -27,8 +27,8 @@ with Atree; use Atree; with Casing; use Casing; with Checks; use Checks; with Debug; use Debug; -with Errout; use Errout; with Elists; use Elists; +with Errout; use Errout; with Exp_Ch11; use Exp_Ch11; with Exp_Disp; use Exp_Disp; with Exp_Util; use Exp_Util; @@ -212,25 +212,114 @@ package body Sem_Util is -- Add_Contract_Item -- ----------------------- - procedure Add_Contract_Item (Item : Node_Id; Subp_Id : Entity_Id) is - Items : constant Node_Id := Contract (Subp_Id); + procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id) is + Items : constant Node_Id := Contract (Id); Nam : Name_Id; + N : Node_Id; begin - if Present (Items) and then Nkind (Item) = N_Pragma then - Nam := Pragma_Name (Item); + -- The related context must have a contract and the item to be added + -- must be a pragma. + + pragma Assert (Present (Items)); + pragma Assert (Nkind (Prag) = N_Pragma); + + Nam := Original_Aspect_Name (Prag); + + -- Contract items related to [generic] packages. The applicable pragmas + -- are: + -- Abstract_States + -- Initial_Condition + -- Initializes + + if Ekind_In (Id, E_Generic_Package, E_Package) then + if Nam_In (Nam, Name_Abstract_State, + Name_Initial_Condition, + Name_Initializes) + then + Set_Next_Pragma (Prag, Classifications (Items)); + Set_Classifications (Items, Prag); + + -- 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 Nam = Name_Refined_State then + Set_Next_Pragma (Prag, Classifications (Items)); + Set_Classifications (Items, Prag); - if Nam_In (Nam, Name_Precondition, Name_Postcondition) then - Set_Next_Pragma (Item, Pre_Post_Conditions (Items)); - Set_Pre_Post_Conditions (Items, Item); + -- 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 + -- Global + -- Post + -- Postcondition + -- Pre + -- 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 (Nam, Name_Precondition, + Name_Postcondition, + Name_Pre, + Name_Post, + Name_uPre, + Name_uPost) + then + -- Before we add a precondition or postcondition to the list, + -- make sure we do not have a disallowed duplicate, which can + -- happen if we use a pragma for Pre[_Class] or Post[_Class] + -- instead of the corresponding aspect. + + if not From_Aspect_Specification (Prag) + and then Nam_In (Nam, Name_Pre_Class, + Name_Pre, + Name_uPre, + Name_Post_Class, + Name_Post, + Name_uPost) + then + N := Pre_Post_Conditions (Items); + while Present (N) loop + if not Split_PPC (N) + and then Original_Aspect_Name (N) = Nam + then + Error_Msg_Sloc := Sloc (N); + Error_Msg_NE + ("duplication of aspect for & given#", Prag, Id); + return; + else + N := Next_Pragma (N); + end if; + end loop; + end if; + + Set_Next_Pragma (Prag, Pre_Post_Conditions (Items)); + Set_Pre_Post_Conditions (Items, Prag); elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then - Set_Next_Pragma (Item, Contract_Test_Cases (Items)); - Set_Contract_Test_Cases (Items, Item); + Set_Next_Pragma (Prag, Contract_Test_Cases (Items)); + Set_Contract_Test_Cases (Items, Prag); elsif Nam_In (Nam, Name_Depends, Name_Global) then - Set_Next_Pragma (Item, Classifications (Items)); - Set_Classifications (Items, Item); + Set_Next_Pragma (Prag, Classifications (Items)); + Set_Classifications (Items, Prag); -- The pragma is not a proper contract item @@ -238,10 +327,21 @@ package body Sem_Util is raise Program_Error; end if; - -- The subprogram has not been properly decorated or the item is illegal + -- Contract items related to subprogram bodies. The applicable pragmas + -- are: + -- Refined_Depends + -- Refined_Global - else - raise Program_Error; + elsif Ekind (Id) = E_Subprogram_Body then + if Nam_In (Nam, Name_Refined_Depends, Name_Refined_Global) then + Set_Next_Pragma (Prag, Classifications (Items)); + Set_Classifications (Items, Prag); + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; end if; end Add_Contract_Item; @@ -323,7 +423,7 @@ package body Sem_Util is Decl := First (Visible_Declarations - (Specification (Unit_Declaration_Node (Current_Scope)))); + (Package_Specification (Current_Scope))); while Present (Decl) loop if Nkind (Decl) = N_Private_Extension_Declaration and then Defining_Entity (Decl) = Typ @@ -1069,6 +1169,13 @@ package body Sem_Util is return; end if; + -- Ignore in ASIS mode, elaboration entity is not in source and plays + -- no role in analysis. + + if ASIS_Mode then + return; + end if; + -- Construct name of elaboration entity as xxx_E, where xxx is the unit -- name with dots replaced by double underscore. We have to manually -- construct this name, since it will be elaborated in the outer scope, @@ -1338,7 +1445,7 @@ package body Sem_Util is -- Ada 2005 (AI-50217): If the type is available through a limited -- with_clause, verify that its full view has been analyzed. - if From_With_Type (T) + if From_Limited_With (T) and then Present (Non_Limited_View (T)) and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type then @@ -3141,6 +3248,208 @@ package body Sem_Util is end if; end Conditional_Delay; + ---------------------------- + -- Contains_Refined_State -- + ---------------------------- + + function Contains_Refined_State (Prag : Node_Id) return Boolean is + function Has_State_In_Dependency (List : Node_Id) return Boolean; + -- Determine whether a dependency list mentions a state with a visible + -- refinement. + + function Has_State_In_Global (List : Node_Id) return Boolean; + -- Determine whether a global list mentions a state with a visible + -- refinement. + + function Is_Refined_State (Item : Node_Id) return Boolean; + -- Determine whether Item is a reference to an abstract state with a + -- visible refinement. + + ----------------------------- + -- Has_State_In_Dependency -- + ----------------------------- + + function Has_State_In_Dependency (List : Node_Id) return Boolean is + Clause : Node_Id; + Output : Node_Id; + + begin + -- A null dependency list does not mention any states + + if Nkind (List) = N_Null then + return False; + + -- Dependency clauses appear as component associations of an + -- aggregate. + + elsif Nkind (List) = N_Aggregate + and then Present (Component_Associations (List)) + then + Clause := First (Component_Associations (List)); + while Present (Clause) loop + + -- Inspect the outputs of a dependency clause + + Output := First (Choices (Clause)); + while Present (Output) loop + if Is_Refined_State (Output) then + return True; + end if; + + Next (Output); + end loop; + + -- Inspect the outputs of a dependency clause + + if Is_Refined_State (Expression (Clause)) then + return True; + end if; + + Next (Clause); + end loop; + + -- If we get here, then none of the dependency clauses mention a + -- state with visible refinement. + + return False; + + -- An illegal pragma managed to sneak in + + else + raise Program_Error; + end if; + end Has_State_In_Dependency; + + ------------------------- + -- Has_State_In_Global -- + ------------------------- + + function Has_State_In_Global (List : Node_Id) return Boolean is + Item : Node_Id; + + begin + -- A null global list does not mention any states + + if Nkind (List) = N_Null then + return False; + + -- Simple global list or moded global list declaration + + elsif Nkind (List) = N_Aggregate then + + -- The declaration of a simple global list appear as a collection + -- of expressions. + + if Present (Expressions (List)) then + Item := First (Expressions (List)); + while Present (Item) loop + if Is_Refined_State (Item) then + return True; + end if; + + Next (Item); + end loop; + + -- The declaration of a moded global list appears as a collection + -- of component associations where individual choices denote + -- modes. + + else + Item := First (Component_Associations (List)); + while Present (Item) loop + if Has_State_In_Global (Expression (Item)) then + return True; + end if; + + Next (Item); + end loop; + end if; + + -- If we get here, then the simple/moded global list did not + -- mention any states with a visible refinement. + + return False; + + -- Single global item declaration + + elsif Is_Entity_Name (List) then + return Is_Refined_State (List); + + -- An illegal pragma managed to sneak in + + else + raise Program_Error; + end if; + end Has_State_In_Global; + + ---------------------- + -- Is_Refined_State -- + ---------------------- + + function Is_Refined_State (Item : Node_Id) return Boolean is + Elmt : Node_Id; + Item_Id : Entity_Id; + + begin + if Nkind (Item) = N_Null then + return False; + + -- States cannot be subject to attribute 'Result. This case arises + -- in dependency relations. + + elsif Nkind (Item) = N_Attribute_Reference + and then Attribute_Name (Item) = Name_Result + then + return False; + + -- Multiple items appear as an aggregate. This case arises in + -- dependency relations. + + elsif Nkind (Item) = N_Aggregate + and then Present (Expressions (Item)) + then + Elmt := First (Expressions (Item)); + while Present (Elmt) loop + if Is_Refined_State (Elmt) then + return True; + end if; + + Next (Elmt); + end loop; + + -- If we get here, then none of the inputs or outputs reference a + -- state with visible refinement. + + return False; + + -- Single item + + else + Item_Id := Entity_Of (Item); + + return + Ekind (Item_Id) = E_Abstract_State + and then Has_Visible_Refinement (Item_Id); + end if; + end Is_Refined_State; + + -- Local variables + + Arg : constant Node_Id := + Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); + Nam : constant Name_Id := Pragma_Name (Prag); + + -- Start of processing for Contains_Refined_State + + begin + if Nam = Name_Depends then + return Has_State_In_Dependency (Arg); + + else pragma Assert (Nam = Name_Global); + return Has_State_In_Global (Arg); + end if; + end Contains_Refined_State; + ------------------------- -- Copy_Component_List -- ------------------------- @@ -4274,7 +4583,6 @@ package body Sem_Util is procedure Ensure_Freeze_Node (E : Entity_Id) is FN : Node_Id; - begin if No (Freeze_Node (E)) then FN := Make_Freeze_Entity (Sloc (E)); @@ -4567,9 +4875,14 @@ package body Sem_Util is -- Inherited discriminants and components in derived record types are -- immediately visible. Itypes are not. + -- Unless the Itype is for a record type with a corresponding remote + -- type (what is that about, it was not commented ???) + if Ekind_In (Def_Id, E_Discriminant, E_Component) - or else (No (Corresponding_Remote_Type (Def_Id)) - and then not Is_Itype (Def_Id)) + or else + ((not Is_Record_Type (Def_Id) + or else No (Corresponding_Remote_Type (Def_Id))) + and then not Is_Itype (Def_Id)) then Set_Is_Immediately_Visible (Def_Id); Set_Current_Entity (Def_Id); @@ -4669,6 +4982,35 @@ package body Sem_Util is end if; end Enter_Name; + --------------- + -- Entity_Of -- + --------------- + + function Entity_Of (N : Node_Id) return Entity_Id is + Id : Entity_Id; + + begin + Id := Empty; + + if Is_Entity_Name (N) then + Id := Entity (N); + + -- Follow a possible chain of renamings to reach the root renamed + -- object. + + while Present (Id) and then Present (Renamed_Object (Id)) loop + if Is_Entity_Name (Renamed_Object (Id)) then + Id := Entity (Renamed_Object (Id)); + else + Id := Empty; + exit; + end if; + end loop; + end if; + + return Id; + end Entity_Of; + -------------------------- -- Explain_Limited_Type -- -------------------------- @@ -5184,9 +5526,9 @@ package body Sem_Util is Discrim := First (Choices (Assoc)); exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim) or else (Present (Corresponding_Discriminant (Entity (Discrim))) - and then - Chars (Corresponding_Discriminant (Entity (Discrim))) - = Chars (Discrim_Name)) + and then + Chars (Corresponding_Discriminant (Entity (Discrim))) = + Chars (Discrim_Name)) or else Chars (Original_Record_Component (Entity (Discrim))) = Chars (Discrim_Name); @@ -5274,7 +5616,6 @@ package body Sem_Util is Find_Discrete_Value : while Present (Variant) loop Discrete_Choice := First (Discrete_Choices (Variant)); while Present (Discrete_Choice) loop - exit Find_Discrete_Value when Nkind (Discrete_Choice) = N_Others_Choice; @@ -5305,8 +5646,8 @@ package body Sem_Util is -- If we have found the corresponding choice, recursively add its -- components to the Into list. - Gather_Components (Empty, - Component_List (Variant), Governed_By, Into, Report_Errors); + Gather_Components + (Empty, Component_List (Variant), Governed_By, Into, Report_Errors); end Gather_Components; ------------------------ @@ -6441,6 +6782,51 @@ package body Sem_Util is return False; end Has_Interfaces; + --------------------------------- + -- Has_No_Obvious_Side_Effects -- + --------------------------------- + + function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is + begin + -- For now, just handle literals, constants, and non-volatile + -- variables and expressions combining these with operators or + -- short circuit forms. + + if Nkind (N) in N_Numeric_Or_String_Literal then + return True; + + elsif Nkind (N) = N_Character_Literal then + return True; + + elsif Nkind (N) in N_Unary_Op then + return Has_No_Obvious_Side_Effects (Right_Opnd (N)); + + elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then + return Has_No_Obvious_Side_Effects (Left_Opnd (N)) + and then + Has_No_Obvious_Side_Effects (Right_Opnd (N)); + + elsif Nkind (N) = N_Expression_With_Actions + and then + Is_Empty_List (Actions (N)) + then + return Has_No_Obvious_Side_Effects (Expression (N)); + + elsif Nkind (N) in N_Has_Entity then + return Present (Entity (N)) + and then Ekind_In (Entity (N), E_Variable, + E_Constant, + E_Enumeration_Literal, + E_In_Parameter, + E_Out_Parameter, + E_In_Out_Parameter) + and then not Is_Volatile (Entity (N)); + + else + return False; + end if; + end Has_No_Obvious_Side_Effects; + ------------------------ -- Has_Null_Exclusion -- ------------------------ @@ -7794,7 +8180,7 @@ package body Sem_Util is -- statement is aliased if its type is immutably limited. or else (Is_Return_Object (E) - and then Is_Immutably_Limited_Type (Etype (E))); + and then Is_Limited_View (Etype (E))); elsif Nkind (Obj) = N_Selected_Component then return Is_Aliased (Entity (Selector_Name (Obj))); @@ -7929,6 +8315,17 @@ package body Sem_Util is end if; end Is_Atomic_Object; + ------------------------- + -- Is_Attribute_Result -- + ------------------------- + + function Is_Attribute_Result (N : Node_Id) return Boolean is + begin + return + Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Result; + end Is_Attribute_Result; + ------------------------------------ -- Is_Body_Or_Package_Declaration -- ------------------------------------ @@ -7962,6 +8359,181 @@ package body Sem_Util is Is_RTE (Root_Type (Under), RO_WW_Super_String)); end Is_Bounded_String; + ------------------------- + -- Is_Child_Or_Sibling -- + ------------------------- + + function Is_Child_Or_Sibling + (Pack_1 : Entity_Id; + Pack_2 : Entity_Id; + Private_Child : Boolean) return Boolean + is + function Distance_From_Standard (Pack : Entity_Id) return Nat; + -- Given an arbitrary package, return the number of "climbs" necessary + -- to reach scope Standard_Standard. + + procedure Equalize_Depths + (Pack : in out Entity_Id; + Depth : in out Nat; + Depth_To_Reach : Nat); + -- Given an arbitrary package, its depth and a target depth to reach, + -- climb the scope chain until the said depth is reached. The pointer + -- to the package and its depth a modified during the climb. + + function Is_Child (Pack : Entity_Id) return Boolean; + -- Given a package Pack, determine whether it is a child package that + -- satisfies the privacy requirement (if set). + + ---------------------------- + -- Distance_From_Standard -- + ---------------------------- + + function Distance_From_Standard (Pack : Entity_Id) return Nat is + Dist : Nat; + Scop : Entity_Id; + + begin + Dist := 0; + Scop := Pack; + while Present (Scop) and then Scop /= Standard_Standard loop + Dist := Dist + 1; + Scop := Scope (Scop); + end loop; + + return Dist; + end Distance_From_Standard; + + --------------------- + -- Equalize_Depths -- + --------------------- + + procedure Equalize_Depths + (Pack : in out Entity_Id; + Depth : in out Nat; + Depth_To_Reach : Nat) + is + begin + -- The package must be at a greater or equal depth + + if Depth < Depth_To_Reach then + raise Program_Error; + end if; + + -- Climb the scope chain until the desired depth is reached + + while Present (Pack) and then Depth /= Depth_To_Reach loop + Pack := Scope (Pack); + Depth := Depth - 1; + end loop; + end Equalize_Depths; + + -------------- + -- Is_Child -- + -------------- + + function Is_Child (Pack : Entity_Id) return Boolean is + begin + if Is_Child_Unit (Pack) then + if Private_Child then + return Is_Private_Descendant (Pack); + else + return True; + end if; + + -- The package is nested, it cannot act a child or a sibling + + else + return False; + end if; + end Is_Child; + + -- Local variables + + P_1 : Entity_Id := Pack_1; + P_1_Child : Boolean := False; + P_1_Depth : Nat := Distance_From_Standard (P_1); + P_2 : Entity_Id := Pack_2; + P_2_Child : Boolean := False; + P_2_Depth : Nat := Distance_From_Standard (P_2); + + -- Start of processing for Is_Child_Or_Sibling + + begin + pragma Assert + (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); + + -- Both packages denote the same entity, therefore they cannot be + -- children or siblings. + + if P_1 = P_2 then + return False; + + -- One of the packages is at a deeper level than the other. Note that + -- both may still come from differen hierarchies. + + -- (root) P_2 + -- / \ : + -- X P_2 or X + -- : : + -- P_1 P_1 + + elsif P_1_Depth > P_2_Depth then + Equalize_Depths (P_1, P_1_Depth, P_2_Depth); + P_1_Child := True; + + -- (root) P_1 + -- / \ : + -- P_1 X or X + -- : : + -- P_2 P_2 + + elsif P_2_Depth > P_1_Depth then + Equalize_Depths (P_2, P_2_Depth, P_1_Depth); + P_2_Child := True; + end if; + + -- At this stage the package pointers have been elevated to the same + -- depth. If the related entities are the same, then one package is a + -- potential child of the other: + + -- P_1 + -- : + -- X became P_1 P_2 or vica versa + -- : + -- P_2 + + if P_1 = P_2 then + if P_1_Child then + return Is_Child (Pack_1); + else pragma Assert (P_2_Child); + return Is_Child (Pack_2); + end if; + + -- The packages may come from the same package chain or from entirely + -- different hierarcies. To determine this, climb the scope stack until + -- a common root is found. + + -- (root) (root 1) (root 2) + -- / \ | | + -- P_1 P_2 P_1 P_2 + + else + while Present (P_1) and then Present (P_2) loop + + -- The two packages may be siblings + + if P_1 = P_2 then + return Is_Child (Pack_1) and then Is_Child (Pack_2); + end if; + + P_1 := Scope (P_1); + P_2 := Scope (P_2); + end loop; + end if; + + return False; + end Is_Child_Or_Sibling; + ----------------------------- -- Is_Concurrent_Interface -- ----------------------------- @@ -8655,6 +9227,7 @@ package body Sem_Util is return Is_Fully_Initialized_Variant (U); end if; end; + else return False; end if; @@ -8787,7 +9360,7 @@ package body Sem_Util is begin return Is_Class_Wide_Type (Typ) - and then (Is_Limited_Type (Typ) or else From_With_Type (Typ)); + and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ)); end Is_Limited_Class_Wide_Type; --------------------------------- @@ -8863,10 +9436,12 @@ package body Sem_Util is when N_Function_Call => return Etype (N) /= Standard_Void_Type; - -- Attributes 'Input and 'Result produce objects + -- Attributes 'Input, 'Old and 'Result produce objects when N_Attribute_Reference => - return Nam_In (Attribute_Name (N), Name_Input, Name_Result); + return + Nam_In + (Attribute_Name (N), Name_Input, Name_Old, Name_Result); when N_Selected_Component => return @@ -9844,7 +10419,8 @@ package body Sem_Util is function In_Protected_Function (E : Entity_Id) return Boolean; -- Within a protected function, the private components of the enclosing -- protected type are constants. A function nested within a (protected) - -- procedure is not itself protected. + -- procedure is not itself protected. Within the body of a protected + -- function the current instance of the protected type is a constant. function Is_Variable_Prefix (P : Node_Id) return Boolean; -- Prefixes can involve implicit dereferences, in which case we must @@ -9856,12 +10432,24 @@ package body Sem_Util is --------------------------- function In_Protected_Function (E : Entity_Id) return Boolean is - Prot : constant Entity_Id := Scope (E); + Prot : Entity_Id; S : Entity_Id; begin + -- E is the current instance of a type + + if Is_Type (E) then + Prot := E; + + -- E is an object + + else + Prot := Scope (E); + end if; + if not Is_Protected_Type (Prot) then return False; + else S := Current_Scope; while Present (S) and then S /= Prot loop @@ -9982,9 +10570,13 @@ package body Sem_Util is or else K = E_In_Out_Parameter or else K = E_Generic_In_Out_Parameter - -- Current instance of type + -- Current instance of type. If this is a protected type, check + -- we are not within the body of one of its protected functions. + + or else (Is_Type (E) + and then In_Open_Scopes (E) + and then not In_Protected_Function (E)) - or else (Is_Type (E) and then In_Open_Scopes (E)) or else (Is_Incomplete_Or_Private_Type (E) and then In_Open_Scopes (Full_View (E))); end; @@ -12215,8 +12807,8 @@ package body Sem_Util is end if; if Nkind (P) = N_Selected_Component - and then Present ( - Entry_Formal (Entity (Selector_Name (P)))) + and then + Present (Entry_Formal (Entity (Selector_Name (P)))) then -- Case of a reference to an entry formal @@ -12240,15 +12832,15 @@ package body Sem_Util is end if; end; - elsif Nkind (Exp) = N_Type_Conversion - or else Nkind (Exp) = N_Unchecked_Type_Conversion + elsif Nkind_In (Exp, N_Type_Conversion, + N_Unchecked_Type_Conversion) then Exp := Expression (Exp); goto Continue; - elsif Nkind (Exp) = N_Slice - or else Nkind (Exp) = N_Indexed_Component - or else Nkind (Exp) = N_Selected_Component + elsif Nkind_In (Exp, N_Slice, + N_Indexed_Component, + N_Selected_Component) then Exp := Prefix (Exp); goto Continue; @@ -12307,7 +12899,9 @@ package body Sem_Util is -- source. This excludes, for example, calls to a dispatching -- assignment operation when the left-hand side is tagged. - if Modification_Comes_From_Source or else SPARK_Mode then + -- Why is SPARK mode different here ??? + + if Modification_Comes_From_Source or SPARK_Mode then Generate_Reference (Ent, Exp, 'm'); -- If the target of the assignment is the bound variable @@ -12653,6 +13247,71 @@ package body Sem_Util is end if; end Object_Access_Level; + -------------------------- + -- Original_Aspect_Name -- + -------------------------- + + function Original_Aspect_Name (N : Node_Id) return Name_Id is + Pras : Node_Id; + Name : Name_Id; + + begin + pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma)); + Pras := N; + + if Is_Rewrite_Substitution (Pras) + and then Nkind (Original_Node (Pras)) = N_Pragma + then + Pras := Original_Node (Pras); + end if; + + -- Case where we came from aspect specication + + if Nkind (Pras) = N_Pragma and then From_Aspect_Specification (Pras) then + Pras := Corresponding_Aspect (Pras); + end if; + + -- Get name from aspect or pragma + + if Nkind (Pras) = N_Pragma then + Name := Pragma_Name (Pras); + else + Name := Chars (Identifier (Pras)); + end if; + + -- Deal with 'Class + + if Class_Present (Pras) then + case Name is + + -- Names that need converting to special _xxx form + + when Name_Pre | + Name_Pre_Class => + Name := Name_uPre; + + when Name_Post | + Name_Post_Class => + Name := Name_uPost; + + when Name_Invariant => + Name := Name_uInvariant; + + when Name_Type_Invariant | + Name_Type_Invariant_Class => + Name := Name_uType_Invariant; + + -- Nothing to do for other cases (e.g. a Check that derived + -- from Pre_Class and has the flag set). Also we do nothing + -- if the name is already in special _xxx form. + + when others => + null; + end case; + end if; + + return Name; + end Original_Aspect_Name; -------------------------------------- -- Original_Corresponding_Operation -- -------------------------------------- @@ -14970,7 +15629,7 @@ package body Sem_Util is ("\\found an access type with designated}!", Expr, Designated_Type (Found_Type)); else - if From_With_Type (Found_Type) then + if From_Limited_With (Found_Type) then Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); Error_Msg_Qual_Level := 99; Error_Msg_NE -- CODEFIX diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 7ea5657aa2b..8227ee2735b 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -43,10 +43,21 @@ package Sem_Util is -- Add A to the list of access types to process when expanding the -- freeze node of E. - procedure Add_Contract_Item (Item : Node_Id; Subp_Id : Entity_Id); - -- Add a contract item (pragma Precondition, Postcondition, Test_Case, - -- Contract_Cases, Global, Depends) to the contract of a subprogram. Item - -- denotes a pragma and Subp_Id is the related subprogram. + procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id); + -- Add pragma Prag to the contract of an entry, a package [body] or a + -- subprogram [body] denoted by Id. The following are valid pragmas: + -- Abstract_States + -- Contract_Cases + -- Depends + -- Global + -- Initial_Condition + -- Initializes + -- Postcondition + -- Precondition + -- Refined_Depends + -- Refined_Global + -- Refined_States + -- Test_Case procedure Add_Global_Declaration (N : Node_Id); -- These procedures adds a declaration N at the library level, to be @@ -319,6 +330,13 @@ package Sem_Util is -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag of -- Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false). + function Contains_Refined_State (Prag : Node_Id) return Boolean; + -- Determine whether pragma Prag contains a reference to the entity of an + -- abstract state with a visible refinement. Prag must denote one of the + -- following pragmas: + -- Depends + -- Global + function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id; -- Utility to create a parameter profile for a new subprogram spec, when -- the subprogram has a body that acts as spec. This is done for some cases @@ -463,6 +481,10 @@ package Sem_Util is -- Note: Enter_Name is not used for overloadable entities, instead these -- are entered using Sem_Ch6.Enter_Overloadable_Entity. + function Entity_Of (N : Node_Id) return Entity_Id; + -- Return the entity of N or Empty. If N is a renaming, return the entity + -- of the root renamed object. + procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id); -- This procedure is called after issuing a message complaining about an -- inappropriate use of limited type T. If useful, it adds additional @@ -735,6 +757,17 @@ package Sem_Util is -- Use_Full_View controls if the check is done using its full view (if -- available). + function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean; + -- This is a simple minded function for determining whether an expression + -- has no obvious side effects. It is used only for determining whether + -- warnings are needed in certain situations, and is not guaranteed to + -- be accurate in either direction. Exceptions may mean an expression + -- does in fact have side effects, but this may be ignored and True is + -- returned, or a complex expression may in fact be side effect free + -- but we don't recognize it here and return False. The Side_Effect_Free + -- routine in Remove_Side_Effects is much more extensive and perhaps could + -- be shared, so that this routine would be more accurate. + function Has_Null_Exclusion (N : Node_Id) return Boolean; -- Determine whether node N has a null exclusion @@ -874,6 +907,9 @@ package Sem_Util is -- Determines if the given node denotes an atomic object in the sense of -- the legality checks described in RM C.6(12). + function Is_Attribute_Result (N : Node_Id) return Boolean; + -- Determine whether node N denotes attribute 'Result + function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean; -- Determine whether node N denotes a body or a package declaration @@ -913,6 +949,16 @@ 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_Child_Or_Sibling + (Pack_1 : Entity_Id; + Pack_2 : Entity_Id; + Private_Child : Boolean) return Boolean; + -- Determine the following relations between two arbitrary packages: + -- 1) One package is the parent of a child package + -- 2) Both packages are siblings and share a common parent + -- If flag Private_Child is set, then the child in case 1) or both siblings + -- in case 2) must be private. + function Is_Concurrent_Interface (T : Entity_Id) return Boolean; -- First determine whether type T is an interface and then check whether -- it is of protected, synchronized or task kind. @@ -1340,6 +1386,16 @@ package Sem_Util is -- convenience, qualified expressions applied to object names are also -- allowed as actuals for this function. + function Original_Aspect_Name (N : Node_Id) return Name_Id; + -- N is a pragma node or aspect specification node. This function returns + -- the name of the pragma or aspect in original source form, taking into + -- account possible rewrites, and also cases where a pragma comes from an + -- aspect (in such cases, the name can be different from the pragma name, + -- e.g. a Pre aspect generates a Precondition pragma). This also deals with + -- the presence of 'Class, which results in one of the special names + -- Name_uPre, Name_uPost, Name_uInvariant, or Name_uType_Invariant being + -- returned to represent the corresponding aspects with x'Class names. + function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean; -- Returns True if the names of both entities correspond with matching -- primitives. This routine includes support for the case in which one diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 68c3ca89b51..5603464f15e 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1310,6 +1310,7 @@ package body Sem_Warn is UR := Original_Node (UR); while Nkind (UR) = N_Type_Conversion or else Nkind (UR) = N_Qualified_Expression + or else Nkind (UR) = N_Expression_With_Actions loop UR := Expression (UR); end loop; @@ -1674,6 +1675,15 @@ package body Sem_Warn is return; end if; + -- Nothing to do for numeric or string literal. Do this test early to + -- save time in a common case (it does not matter that we do not include + -- character literal here, since that will be caught later on in the + -- when others branch of the case statement). + + if Nkind (N) in N_Numeric_Or_String_Literal then + return; + end if; + -- Ignore reference unless it comes from source. Almost always if we -- have a reference from generated code, it is bogus (e.g. calls to init -- procs to set default discriminant values). @@ -1707,7 +1717,7 @@ package body Sem_Warn is and then (No (Unset_Reference (E)) or else Earlier_In_Extended_Unit - (Sloc (N), Sloc (Unset_Reference (E)))) + (Sloc (N), Sloc (Unset_Reference (E)))) and then not Has_Pragma_Unmodified_Check_Spec (E) and then not Warnings_Off_Check_Spec (E) then @@ -2025,9 +2035,12 @@ package body Sem_Warn is Check_Unset_Reference (Pref); end; - -- For type conversions or qualifications examine the expression + -- For type conversions, qualifications, or expressions with actions, + -- examine the expression. - when N_Type_Conversion | N_Qualified_Expression => + when N_Type_Conversion | + N_Qualified_Expression | + N_Expression_With_Actions => Check_Unset_Reference (Expression (N)); -- For explicit dereference, always check prefix, which will generate @@ -2425,7 +2438,7 @@ package body Sem_Warn is or else Referenced_As_LHS_Check_Spec (Ent) or else Referenced_As_Out_Parameter_Check_Spec (Ent) or else - (From_With_Type (Ent) + (From_Limited_With (Ent) and then Is_Incomplete_Type (Ent) and then Present (Non_Limited_View (Ent)) and then Referenced (Non_Limited_View (Ent))) @@ -2532,13 +2545,16 @@ package body Sem_Warn is return; end if; - -- Flag any unused with clauses, but skip this step if we are compiling - -- a subunit on its own, since we do not have enough information to - -- determine whether with's are used. We will get the relevant warnings - -- when we compile the parent. This is the normal style of GNAT - -- compilation in any case. + -- Flag any unused with clauses. For a subunit, check only the units + -- in its context, not those of the parent, which may be needed by other + -- subunits. We will get the full warnings when we compile the parent, + -- but the following is helpful when compiling a subunit by itself. if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit then + if Current_Sem_Unit = Main_Unit then + Check_One_Unit (Main_Unit); + end if; + return; end if; @@ -3401,12 +3417,26 @@ package body Sem_Warn is then null; - -- Here we may need to issue message + -- Here we may need to issue overlap message else Error_Msg_Warn := + + -- Overlap checking is an error only in Ada 2012. For + -- earlier versions of Ada, this is a warning. + Ada_Version < Ada_2012 - or else not Is_Elementary_Type (Etype (Form1)); + + -- Overlap is only illegal in Ada 2012 in the case of + -- elementary types (passed by copy). For other types, + -- we always have a warning in all Ada versions. + + or else not Is_Elementary_Type (Etype (Form1)) + + -- Finally, debug flag -gnatd.E changes the error to a + -- warning even in Ada 2012 mode. + + or else Error_To_Warning; declare Act : Node_Id; @@ -3448,23 +3478,28 @@ package body Sem_Warn is then if Act1 = First_Actual (N) then Error_Msg_FE - ("`IN OUT` prefix overlaps with " - & "actual for&?I?", Act1, Form); + ("<`IN OUT` prefix overlaps with " + & "actual for&", Act1, Form); else -- For greater clarity, give name of formal Error_Msg_Node_2 := Form; Error_Msg_FE - ("writable actual for & overlaps with " - & "actual for&?I?", Act1, Form); + ("<writable actual for & overlaps with " + & "actual for&", Act1, Form); end if; else + -- For greater clarity, give name of formal + Error_Msg_Node_2 := Form; + + -- This is one of the messages + Error_Msg_FE - ("writable actual for & overlaps with " - & "actual for&?I?", Act1, Form1); + ("<writable actual for & overlaps with " + & "actual for&", Act1, Form1); end if; end; end if; diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads index 0a8839512bb..22a3c6c42ef 100644 --- a/gcc/ada/sem_warn.ads +++ b/gcc/ada/sem_warn.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2013, 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- -- @@ -198,7 +198,9 @@ package Sem_Warn is procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id); -- Called on a subprogram call. Checks whether an IN OUT actual that is -- not by-copy may overlap with another actual, thus leading to aliasing - -- in the body of the called subprogram. + -- in the body of the called subprogram. This is indeed a warning in Ada + -- versions prior to Ada 2012, but, unless Opt.Error_To_Warning is set by + -- use of debug flag -gnatd.E, this is illegal and generates an error. procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id); -- This is called after resolving an indexed component or a slice. Name diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 6cb18c1890c..ba583398e08 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -691,6 +691,17 @@ package body Sinfo is return Node5 (N); end Corresponding_Spec; + function Corresponding_Spec_Of_Stub + (N : Node_Id) return Entity_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Body_Stub + or else NT (N).Nkind = N_Protected_Body_Stub + or else NT (N).Nkind = N_Subprogram_Body_Stub + or else NT (N).Nkind = N_Task_Body_Stub); + return Node2 (N); + end Corresponding_Spec_Of_Stub; + function Corresponding_Stub (N : Node_Id) return Node_Id is begin @@ -1093,7 +1104,8 @@ package body Sinfo is or else NT (N).Nkind in N_Has_Entity or else NT (N).Nkind = N_Aspect_Specification or else NT (N).Nkind = N_Attribute_Definition_Clause - or else NT (N).Nkind = N_Freeze_Entity); + or else NT (N).Nkind = N_Freeze_Entity + or else NT (N).Nkind = N_Freeze_Generic_Entity); return Node4 (N); end Entity; @@ -1541,6 +1553,16 @@ package body Sinfo is return Flag13 (N); end Has_Self_Reference; + function Has_SP_Choice + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Case_Expression_Alternative + or else NT (N).Nkind = N_Case_Statement_Alternative + or else NT (N).Nkind = N_Variant); + return Flag15 (N); + end Has_SP_Choice; + function Has_Storage_Size_Pragma (N : Node_Id) return Boolean is begin @@ -3817,6 +3839,17 @@ package body Sinfo is Set_Node5 (N, Val); -- semantic field, no parent set end Set_Corresponding_Spec; + procedure Set_Corresponding_Spec_Of_Stub + (N : Node_Id; Val : Entity_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Package_Body_Stub + or else NT (N).Nkind = N_Protected_Body_Stub + or else NT (N).Nkind = N_Subprogram_Body_Stub + or else NT (N).Nkind = N_Task_Body_Stub); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_Corresponding_Spec_Of_Stub; + procedure Set_Corresponding_Stub (N : Node_Id; Val : Node_Id) is begin @@ -4219,7 +4252,8 @@ package body Sinfo is or else NT (N).Nkind in N_Has_Entity or else NT (N).Nkind = N_Aspect_Specification or else NT (N).Nkind = N_Attribute_Definition_Clause - or else NT (N).Nkind = N_Freeze_Entity); + or else NT (N).Nkind = N_Freeze_Entity + or else NT (N).Nkind = N_Freeze_Generic_Entity); Set_Node4 (N, Val); -- semantic field, no parent set end Set_Entity; @@ -4658,6 +4692,16 @@ package body Sinfo is Set_Flag13 (N, Val); end Set_Has_Self_Reference; + procedure Set_Has_SP_Choice + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Case_Expression_Alternative + or else NT (N).Nkind = N_Case_Statement_Alternative + or else NT (N).Nkind = N_Variant); + Set_Flag15 (N, Val); + end Set_Has_SP_Choice; + procedure Set_Has_Storage_Size_Pragma (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 112f8fc00ab..a54ef6afa88 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -508,6 +508,48 @@ package Sinfo is -- simply ignore these nodes, since they are not relevant to the task -- of back annotating representation information. + ---------------- + -- SPARK Mode -- + ---------------- + + -- When a file is compiled in SPARK mode (-gnatd.F), a very light expansion + -- is performed and the analysis must generate a tree in a form that meets + -- additional requirements. + + -- The SPARK expansion does two transformations of the tree, that cannot be + -- postponed after the frontend semantic analysis: + + -- 1. Replace renamings by renamed (object/subprogram). This requires + -- introducing temporaries at the point of the renaming, which must be + -- properly analyzed. + + -- 2. Fully qualify entity names. This is needed to generate suitable + -- local effects/call-graphs in ALI files, with the completely + -- qualified names (in particular the suffix to distinguish homonyms). + + -- The tree after SPARK expansion should be fully analyzed semantically, + -- which sometimes requires the insertion of semantic pre-analysis, for + -- example for subprogram contracts and pragma check/assert. In particular, + -- all expression must have their proper type, and semantic links should be + -- set between tree nodes (partial to full view, etc.) Some kinds of nodes + -- should be either absent, or can be ignored by the formal verification + -- backend: + + -- N_Object_Renaming_Declaration: can be ignored safely + -- N_Expression_Function: absent (rewitten) + -- N_Expression_With_Actions: absent (not generated) + + -- SPARK cross-references are generated from the regular cross-references + -- (used for browsing and code understanding) and additional references + -- collected during semantic analysis, in particular on all dereferences. + -- These SPARK cross-references are output in a separate section of ALI + -- files, as described in spark_xrefs.adb. They are the basis for the + -- computation of data dependences in the formal verification backend. + -- This implies that all cross-references should be generated in this mode, + -- even those that would not make sense from a user point-of-view, and that + -- cross-references that do not lead to data dependences for subprograms + -- can be safely ignored. + ------------------------ -- Common Flag Fields -- ------------------------ @@ -822,6 +864,11 @@ package Sinfo is -- In Ada 2012, Corresponding_Spec is set on expression functions that -- complete a subprogram declaration. + -- Corresponding_Spec_Of_Stub (Node2-Sem) + -- This field is present in subprogram, package, task and protected body + -- stubs where it points to the corresponding spec of the stub. Due to + -- clashes in the structure of nodes, we cannot use Corresponding_Spec. + -- Corresponding_Stub (Node3-Sem) -- This field is present in an N_Subunit node. It holds the node in -- the parent unit that is the stub declaration for the subunit. It is @@ -929,6 +976,15 @@ package Sinfo is -- listed above (e.g. in a return statement), an additional type -- conversion node is introduced to represent the required check. + -- A special case arises for the arguments of the Pred/Succ attributes. + -- Here the range check needed is against First + 1 .. Last (Pred) or + -- First .. Last - 1 (Succ) of the corresponding base type. Essentially + -- these checks are what would be performed within the implicit body of + -- the functions that correspond to these attributes. In these cases, + -- the Do_Range check flag is set on the argument to the attribute + -- function, and the back end must special case the appropriate range + -- to check against. + -- Do_Storage_Check (Flag17-Sem) -- This flag is set in an N_Allocator node to indicate that a storage -- check is required for the allocation, or in an N_Subprogram_Body node @@ -1238,6 +1294,12 @@ package Sinfo is -- enclosing type. Such a self-reference can only appear in default- -- initialized aggregate for a record type. + -- Has_SP_Choice (Flag15-Sem) + -- Present in all nodes containing a Discrete_Choices field (N_Variant, + -- N_Case_Expression_Alternative, N_Case_Statement_Alternative). Set to + -- True if the Discrete_Choices list has at least one occurrence of a + -- statically predicated subtype. + -- Has_Storage_Size_Pragma (Flag5-Sem) -- A flag present in an N_Task_Definition node to flag the presence of a -- Storage_Size pragma. @@ -3056,8 +3118,7 @@ package Sinfo is -- VARIANT_PART ::= -- case discriminant_DIRECT_NAME is - -- VARIANT - -- {VARIANT} + -- VARIANT {VARIANT} -- end case; -- Note: the variants list can contain pragmas as well as variants. @@ -3083,6 +3144,14 @@ package Sinfo is -- Enclosing_Variant (Node2-Sem) -- Present_Expr (Uint3-Sem) -- Dcheck_Function (Node5-Sem) + -- Has_SP_Choice (Flag15-Sem) + + -- Note: in the list of Discrete_Choices, the tree passed to the back + -- end does not have choice entries corresponding to names of statically + -- predicated subtypes. Such entries are always expanded out to the list + -- of equivalent values or ranges. The ASIS tree generated in -gnatct + -- mode also has this expansion, but done with a proper Rewrite call on + -- the N_Variant node so that ASIS can properly retrieve the original. --------------------------------- -- 3.8.1 Discrete Choice List -- @@ -3569,7 +3638,7 @@ package Sinfo is -- Sloc points to first selector name -- Choices (List1) -- Loop_Actions (List2-Sem) - -- Expression (Node3) + -- Expression (Node3) (empty if Box_Present) -- Box_Present (Flag15) -- Inherited_Discriminant (Flag13) @@ -4067,12 +4136,16 @@ package Sinfo is -- Actions (List1) -- Discrete_Choices (List4) -- Expression (Node3) + -- Has_SP_Choice (Flag15-Sem) -- Note: The Actions field temporarily holds any actions associated with -- evaluation of the Expression. During expansion of the case expression -- these actions are wrapped into an N_Expressions_With_Actions node -- replacing the original expression. + -- Note: this node never appears in the tree passed to the back end, + -- since the expander converts case expressions into case statements. + --------------------------------- -- 4.5.9 Quantified Expression -- --------------------------------- @@ -4381,6 +4454,13 @@ package Sinfo is -- Sloc points to WHEN -- Discrete_Choices (List4) -- Statements (List3) + -- Has_SP_Choice (Flag15-Sem) + + -- Note: in the list of Discrete_Choices, the tree passed to the back + -- end does not have choice entries corresponding to names of statically + -- predicated subtypes. Such entries are always expanded out to the list + -- of equivalent values or ranges. The ASIS tree generated in -gnatct + -- mode does not have this expansion, and has the original choices. ------------------------- -- 5.5 Loop Statement -- @@ -6055,6 +6135,7 @@ package Sinfo is -- N_Subprogram_Body_Stub -- Sloc points to FUNCTION or PROCEDURE -- Specification (Node1) + -- Corresponding_Spec_Of_Stub (Node2-Sem) -- Library_Unit (Node4-Sem) points to the subunit -- Corresponding_Body (Node5-Sem) @@ -6069,6 +6150,7 @@ package Sinfo is -- N_Package_Body_Stub -- Sloc points to PACKAGE -- Defining_Identifier (Node1) + -- Corresponding_Spec_Of_Stub (Node2-Sem) -- Library_Unit (Node4-Sem) points to the subunit -- Corresponding_Body (Node5-Sem) @@ -6083,6 +6165,7 @@ package Sinfo is -- N_Task_Body_Stub -- Sloc points to TASK -- Defining_Identifier (Node1) + -- Corresponding_Spec_Of_Stub (Node2-Sem) -- Library_Unit (Node4-Sem) points to the subunit -- Corresponding_Body (Node5-Sem) @@ -6099,6 +6182,7 @@ package Sinfo is -- N_Protected_Body_Stub -- Sloc points to PROTECTED -- Defining_Identifier (Node1) + -- Corresponding_Spec_Of_Stub (Node2-Sem) -- Library_Unit (Node4-Sem) points to the subunit -- Corresponding_Body (Node5-Sem) @@ -7109,12 +7193,16 @@ package Sinfo is -- Contract -- -------------- - -- This node is used to hold the various parts of an entry or subprogram - -- contract, consisting in pre- and postconditions on the one hand, and - -- test-cases on the other hand. + -- This node is used to hold the various parts of an entry, subprogram + -- [body] or package [body] contract, in particular: + -- Abstract states declared by a package declaration + -- Contract cases that apply to a subprogram + -- Dependency relations of inputs and output of a subprogram + -- Global annotations classifying data as input or output + -- Initialization sequences for a package declaration + -- Pre- and postconditions that apply to a subprogram - -- It is referenced from an entry, a subprogram or a generic subprogram - -- entity. + -- The node appears in an entry and [generic] subprogram [body] entity. -- Sprint syntax: <none> as the node should not appear in the tree, but -- only attached to an entry or [generic] subprogram @@ -7127,9 +7215,15 @@ package Sinfo is -- Classifications (Node3) (set to Empty if none) -- Pre_Post_Conditions contains a collection of pragmas that correspond - -- to pre- and postconditions associated with an entry or a subprogram. - -- The pragmas can either come from source or be the byproduct of aspect - -- expansion. The ordering in the list is in LIFO fashion. + -- to pre- and postconditions associated with an entry or a subprogram + -- [body or stub]. The pragmas can either come from source or be the + -- byproduct of aspect expansion. Currently the following pragmas appear + -- in this list: + -- Post + -- Postcondition + -- Pre + -- Precondition + -- The ordering in the list is in LIFO fashion. -- Note that there might be multiple preconditions or postconditions -- in this list, either because they come from separate pragmas in the @@ -7140,10 +7234,18 @@ package Sinfo is -- to aspects/pragmas Contract_Cases and Test_Case. The ordering in the -- list is in LIFO fashion. - -- Classifications contains pragmas that either categorize subprogram - -- inputs and outputs or establish dependencies between them. Currently - -- pragmas Depends and Global are stored in this list. The ordering is - -- in LIFO fashion. + -- Classifications contains pragmas that either declare, categorize or + -- establish dependencies between subprogram or package inputs and + -- outputs. Currently the following pragmas appear in this list: + -- Abstract_States + -- Depends + -- Global + -- Initial_Condition + -- Initializes + -- Refined_Depends + -- Refined_Global + -- Refined_States + -- The ordering is in LIFO fashion. ------------------- -- Expanded_Name -- @@ -7286,6 +7388,29 @@ package Sinfo is -- Note: in the case where a debug source file is generated, the Sloc -- for this node points to the FREEZE keyword in the Sprint file output. + --------------------------- + -- Freeze_Generic_Entity -- + --------------------------- + + -- The freeze point of an entity indicates the point at which the + -- information needed to generate code for the entity is complete. + -- The freeze node for an entity triggers expander activities, such as + -- build initialization procedures, and backend activities, such as + -- completing the elaboration of packages. + + -- For entities declared within a generic unit, for which no code is + -- generated, the freeze point is not equally meaningful. However, in + -- Ada 2012 several semantic checks on declarations must be delayed to + -- the freeze point, and we need to include such a mark in the tree to + -- trigger these checks. The Freeze_Generic_Entity node plays no other + -- role, and is ignored by the expander and the back-end. + + -- Sprint syntax: freeze_generic entity-name + + -- N_Freeze_Generic_Entity + -- Sloc points near freeze point + -- Entity (Node4-Sem) + -------------------------------- -- Implicit Label Declaration -- -------------------------------- @@ -7564,7 +7689,7 @@ package Sinfo is -- N_Subprogram_Info -- Sloc points to the entity for the procedure -- Identifier (Node1) identifier referencing the procedure - -- Etype (Node5-Sem) type (always set to Ada.Exceptions.Code_Loc + -- Etype (Node5-Sem) type (always set to Ada.Exceptions.Code_Loc) -- Note: in the case where a debug source file is generated, the Sloc -- for this node points to the quote in the Sprint file output. @@ -7822,13 +7947,18 @@ package Sinfo is N_Raise_Program_Error, N_Raise_Storage_Error, + -- N_Subexpr, N_Has_Etype, N_Numeric_Or_String_Literal + + N_Integer_Literal, + N_Real_Literal, + N_String_Literal, + -- N_Subexpr, N_Has_Etype N_Explicit_Dereference, N_Expression_With_Actions, N_If_Expression, N_Indexed_Component, - N_Integer_Literal, N_Null, N_Qualified_Expression, N_Quantified_Expression, @@ -7838,11 +7968,9 @@ package Sinfo is N_Extension_Aggregate, N_Raise_Expression, N_Range, - N_Real_Literal, N_Reference, N_Selected_Component, N_Slice, - N_String_Literal, N_Subprogram_Info, N_Type_Conversion, N_Unchecked_Expression, @@ -8049,6 +8177,7 @@ package Sinfo is N_Formal_Incomplete_Type_Definition, N_Formal_Signed_Integer_Type_Definition, N_Freeze_Entity, + N_Freeze_Generic_Entity, N_Generic_Association, N_Handled_Sequence_Of_Statements, N_Index_Or_Discriminant_Constraint, @@ -8143,8 +8272,8 @@ package Sinfo is N_Expanded_Name .. N_Attribute_Reference; -- Nodes that have Entity fields - -- Warning: DOES NOT INCLUDE N_Freeze_Entity, N_Aspect_Specification, - -- or N_Attribute_Definition_Clause. + -- Warning: DOES NOT INCLUDE N_Freeze_Entity, N_Freeze_Generic_Entity, + -- N_Aspect_Specification, or N_Attribute_Definition_Clause. subtype N_Has_Etype is Node_Kind range N_Error .. @@ -8173,6 +8302,10 @@ package Sinfo is N_In .. N_Not_In; + subtype N_Numeric_Or_String_Literal is Node_Kind range + N_Integer_Literal .. + N_String_Literal; + subtype N_Op is Node_Kind range N_Op_Add .. N_Op_Plus; @@ -8484,6 +8617,9 @@ package Sinfo is function Corresponding_Spec (N : Node_Id) return Node_Id; -- Node5 + function Corresponding_Spec_Of_Stub + (N : Node_Id) return Node_Id; -- Node2 + function Corresponding_Stub (N : Node_Id) return Node_Id; -- Node3 @@ -8742,6 +8878,9 @@ package Sinfo is function Has_Self_Reference (N : Node_Id) return Boolean; -- Flag13 + function Has_SP_Choice + (N : Node_Id) return Boolean; -- Flag15 + function Has_Storage_Size_Pragma (N : Node_Id) return Boolean; -- Flag5 @@ -9480,6 +9619,9 @@ package Sinfo is procedure Set_Corresponding_Spec (N : Node_Id; Val : Node_Id); -- Node5 + procedure Set_Corresponding_Spec_Of_Stub + (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Corresponding_Stub (N : Node_Id; Val : Node_Id); -- Node3 @@ -9735,6 +9877,9 @@ package Sinfo is procedure Set_Has_Self_Reference (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Has_SP_Choice + (N : Node_Id; Val : Boolean := True); -- Flag15 + procedure Set_Has_Storage_Size_Pragma (N : Node_Id; Val : Boolean := True); -- Flag5 @@ -11490,28 +11635,28 @@ package Sinfo is N_Subprogram_Body_Stub => (1 => True, -- Specification (Node1) - 2 => False, -- unused + 2 => False, -- Corresponding_Spec_Of_Stub (Node2-Sem) 3 => False, -- unused 4 => False, -- Library_Unit (Node4-Sem) 5 => False), -- Corresponding_Body (Node5-Sem) N_Package_Body_Stub => (1 => True, -- Defining_Identifier (Node1) - 2 => False, -- unused + 2 => False, -- Corresponding_Spec_Of_Stub (Node2-Sem) 3 => False, -- unused 4 => False, -- Library_Unit (Node4-Sem) 5 => False), -- Corresponding_Body (Node5-Sem) N_Task_Body_Stub => (1 => True, -- Defining_Identifier (Node1) - 2 => False, -- unused + 2 => False, -- Corresponding_Spec_Of_Stub (Node2-Sem) 3 => False, -- unused 4 => False, -- Library_Unit (Node4-Sem) 5 => False), -- Corresponding_Body (Node5-Sem) N_Protected_Body_Stub => (1 => True, -- Defining_Identifier (Node1) - 2 => False, -- unused + 2 => False, -- Corresponding_Spec_Of_Stub (Node2-Sem) 3 => False, -- unused 4 => False, -- Library_Unit (Node4-Sem) 5 => False), -- Corresponding_Body (Node5-Sem) @@ -11838,6 +11983,13 @@ package Sinfo is 4 => False, -- Entity (Node4-Sem) 5 => False), -- First_Subtype_Link (Node5-Sem) + N_Freeze_Generic_Entity => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- unused + N_Implicit_Label_Declaration => (1 => True, -- Defining_Identifier (Node1) 2 => False, -- Label_Construct (Node2-Sem) @@ -12078,6 +12230,7 @@ package Sinfo is pragma Inline (Corresponding_Generic_Association); pragma Inline (Corresponding_Integer_Value); pragma Inline (Corresponding_Spec); + pragma Inline (Corresponding_Spec_Of_Stub); pragma Inline (Corresponding_Stub); pragma Inline (Dcheck_Function); pragma Inline (Declarations); @@ -12160,6 +12313,7 @@ package Sinfo is pragma Inline (Has_Init_Expression); pragma Inline (Has_Local_Raise); pragma Inline (Has_Self_Reference); + pragma Inline (Has_SP_Choice); pragma Inline (Has_No_Elaboration_Code); pragma Inline (Has_Pragma_Suppress_All); pragma Inline (Has_Private_View); @@ -12407,6 +12561,7 @@ package Sinfo is pragma Inline (Set_Corresponding_Generic_Association); pragma Inline (Set_Corresponding_Integer_Value); pragma Inline (Set_Corresponding_Spec); + pragma Inline (Set_Corresponding_Spec_Of_Stub); pragma Inline (Set_Corresponding_Stub); pragma Inline (Set_Dcheck_Function); pragma Inline (Set_Declarations); @@ -12492,6 +12647,7 @@ package Sinfo is pragma Inline (Set_Has_Private_View); pragma Inline (Set_Has_Relative_Deadline_Pragma); pragma Inline (Set_Has_Self_Reference); + pragma Inline (Set_Has_SP_Choice); pragma Inline (Set_Has_Storage_Size_Pragma); pragma Inline (Set_Has_Wide_Character); pragma Inline (Set_Has_Wide_Wide_Character); diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb index 4ad212b4314..83dadaf408c 100644 --- a/gcc/ada/sinput-c.adb +++ b/gcc/ada/sinput-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -68,7 +68,8 @@ package body Sinput.C is if X = Source_File.First then Lo := First_Source_Ptr; else - Lo := Source_File.Table (X - 1).Source_Last + 1; + Lo := ((Source_File.Table (X - 1).Source_Last + Source_Align) / + Source_Align) * Source_Align; end if; Name_Len := Path'Length; diff --git a/gcc/ada/sinput-d.adb b/gcc/ada/sinput-d.adb index a860058c900..f150ebf7f0a 100644 --- a/gcc/ada/sinput-d.adb +++ b/gcc/ada/sinput-d.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2013, 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,9 @@ package body Sinput.D is Loc : out Source_Ptr) is begin - Loc := Source_File.Table (Source_File.Last).Source_Last + 1; + Loc := + ((Source_File.Table (Source_File.Last).Source_Last + Source_Align) / + Source_Align) * Source_Align; Source_File.Append (Source_File.Table (Source)); Dfile := Source_File.Last; diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index 64a7cdb68b4..b72278851b4 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -112,7 +112,6 @@ package body Sinput.L is procedure Complete_Source_File_Entry is CSF : constant Source_File_Index := Current_Source_File; - begin Trim_Lines_Table (CSF); Source_File.Table (CSF).Source_Checksum := Checksum; @@ -158,7 +157,6 @@ package body Sinput.L is Snew.Inlined_Call := Sloc (Inst_Node); else - -- If the spec has been instantiated already, and we are now -- creating the instance source for the corresponding body now, -- retrieve the instance id that was assigned to the spec, which @@ -167,10 +165,10 @@ package body Sinput.L is Inst_Spec := Instance_Spec (Inst_Node); if Present (Inst_Spec) then declare - Inst_Spec_Ent : Entity_Id; + Inst_Spec_Ent : Entity_Id; -- Instance spec entity - Inst_Spec_Sloc : Source_Ptr; + Inst_Spec_Sloc : Source_Ptr; -- Virtual sloc of the spec instance source Inst_Spec_Inst_Id : Instance_Id; @@ -188,12 +186,13 @@ package body Sinput.L is -- The specification of the instance entity has a virtual -- sloc within the instance sloc range. + -- ??? But the Unit_Declaration_Node has the sloc of the -- instantiation, which is somewhat of an oddity. - Inst_Spec_Sloc := - Sloc (Specification (Unit_Declaration_Node - (Inst_Spec_Ent))); + Inst_Spec_Sloc := + Sloc + (Specification (Unit_Declaration_Node (Inst_Spec_Ent))); Inst_Spec_Inst_Id := Source_File.Table (Get_Source_File_Index (Inst_Spec_Sloc)).Instance; @@ -209,11 +208,16 @@ package body Sinput.L is end if; end if; - -- Now we need to compute the new values of Source_First, + -- Now we need to compute the new values of Source_First and -- Source_Last and adjust the source file pointer to have the -- correct virtual origin for the new range of values. - Snew.Source_First := Source_File.Table (Xnew - 1).Source_Last + 1; + -- Source_First must be greater than the last Source_Last value + -- and also must be a multiple of Source_Align + + Snew.Source_First := + ((Source_File.Table (Xnew - 1).Source_Last + Source_Align) / + Source_Align) * Source_Align; A.Adjust := Snew.Source_First - A.Lo; Snew.Source_Last := A.Hi + A.Adjust; @@ -398,10 +402,13 @@ package body Sinput.L is Source_File.Increment_Last; X := Source_File.Last; + -- Compute starting index, respecting alignment requirement + if X = Source_File.First then Lo := First_Source_Ptr; else - Lo := Source_File.Table (X - 1).Source_Last + 1; + Lo := ((Source_File.Table (X - 1).Source_Last + Source_Align) / + Source_Align) * Source_Align; end if; Osint.Read_Source_File (N, Lo, Hi, Src, T); diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index a01c045d91f..7bd0a693470 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -434,44 +434,9 @@ package body Sinput is -- Get_Source_File_Index -- --------------------------- - Source_Cache_First : Source_Ptr := 1; - Source_Cache_Last : Source_Ptr := 0; - -- Records the First and Last subscript values for the most recently - -- referenced entry in the source table, to optimize the common case of - -- repeated references to the same entry. The initial values force an - -- initial search to set the cache value. - - Source_Cache_Index : Source_File_Index := No_Source_File; - -- Contains the index of the entry corresponding to Source_Cache - function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is begin - if S in Source_Cache_First .. Source_Cache_Last then - return Source_Cache_Index; - - else - pragma Assert (Source_File_Index_Table (Int (S) / Chunk_Size) - /= - No_Source_File); - for J in Source_File_Index_Table (Int (S) / Chunk_Size) - .. Source_File.Last - loop - if S in Source_File.Table (J).Source_First .. - Source_File.Table (J).Source_Last - then - Source_Cache_Index := J; - Source_Cache_First := - Source_File.Table (Source_Cache_Index).Source_First; - Source_Cache_Last := - Source_File.Table (Source_Cache_Index).Source_Last; - return Source_Cache_Index; - end if; - end loop; - end if; - - -- We must find a matching entry in the above loop! - - raise Program_Error; + return Source_File_Index_Table (Int (S) / Source_Align); end Get_Source_File_Index; ---------------- @@ -480,9 +445,6 @@ package body Sinput is procedure Initialize is begin - Source_Cache_First := 1; - Source_Cache_Last := 0; - Source_Cache_Index := No_Source_File; Source_gnat_adc := No_Source_File; First_Time_Around := True; @@ -724,15 +686,13 @@ package body Sinput is Ind : Int; SP : Source_Ptr; SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last; - begin - SP := (Source_File.Table (Xnew).Source_First + Chunk_Size - 1) - / Chunk_Size * Chunk_Size; - Ind := Int (SP) / Chunk_Size; - + SP := Source_File.Table (Xnew).Source_First; + pragma Assert (SP mod Source_Align = 0); + Ind := Int (SP) / Source_Align; while SP <= SL loop Source_File_Index_Table (Ind) := Xnew; - SP := SP + Chunk_Size; + SP := SP + Source_Align; Ind := Ind + 1; end loop; end Set_Source_File_Index_Table; @@ -921,19 +881,14 @@ package body Sinput is end loop; end if; - -- Reset source cache pointers to force new read - - Source_Cache_First := 1; - Source_Cache_Last := 0; - -- Read in source file table and instance table Source_File.Tree_Read; Instances.Tree_Read; - -- The pointers we read in there for the source buffer and lines - -- table pointers are junk. We now read in the actual data that - -- is referenced by these two fields. + -- The pointers we read in there for the source buffer and lines table + -- pointers are junk. We now read in the actual data that is referenced + -- by these two fields. for J in Source_File.First .. Source_File.Last loop declare diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index f678ff62984..b5b2d747cc1 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -342,36 +342,17 @@ package Sinput is -- The Get_Source_File_Index function is called very frequently. Earlier -- versions cached a single entry, but then reverted to a serial search, - -- and this proved to be a significant source of inefficiency. To get - -- around this, we use the following directly indexed array. The space - -- of possible input values is a value of type Source_Ptr which is simply - -- an Int value. The values in this space are allocated sequentially as - -- new units are loaded. - - -- The following table has an entry for each 4K range of possible - -- Source_Ptr values. The value in the table is the lowest value - -- Source_File_Index whose Source_Ptr range contains value in the - -- range. - - -- For example, the entry with index 4 in this table represents Source_Ptr - -- values in the range 4*4096 .. 5*4096-1. The Source_File_Index value - -- stored would be the lowest numbered source file with at least one byte - -- in this range. - - -- The algorithm used in Get_Source_File_Index is simply to access this - -- table and then do a serial search starting at the given position. This - -- will almost always terminate with one or two checks. + -- and this proved to be a significant source of inefficiency. We then + -- switched to using a table with a start point followed by a serial + -- search. Now we make sure source buffers are on a reasonable boundary + -- (see Types.Source_Align), and we can just use a direct look up in the + -- following table. -- Note that this array is pretty large, but in most operating systems -- it will not be allocated in physical memory unless it is actually used. - Chunk_Power : constant := 12; - Chunk_Size : constant := 2 ** Chunk_Power; - -- Change comments above if value changed. Note that Chunk_Size must - -- be a power of 2 (to allow for efficient access to the table). - Source_File_Index_Table : - array (Int range 0 .. Int'Last / Chunk_Size) of Source_File_Index; + array (Int range 0 .. 1 + (Int'Last / Source_Align)) of Source_File_Index; procedure Set_Source_File_Index_Table (Xnew : Source_File_Index); -- Sets entries in the Source_File_Index_Table for the newly created @@ -605,6 +586,7 @@ package Sinput is -- value is the physical line number in the source being compiled. function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index; + pragma Inline (Get_Source_File_Index); -- Return file table index of file identified by given source pointer -- value. This call must always succeed, since any valid source pointer -- value belongs to some previously loaded source file. diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 70afdb70110..0be49580d98 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -142,11 +142,8 @@ package Snames is Name_Dimension : constant Name_Id := N + $; Name_Dimension_System : constant Name_Id := N + $; Name_Dynamic_Predicate : constant Name_Id := N + $; - Name_Post : constant Name_Id := N + $; - Name_Pre : constant Name_Id := N + $; Name_Static_Predicate : constant Name_Id := N + $; Name_Synchronization : constant Name_Id := N + $; - Name_Type_Invariant : constant Name_Id := N + $; -- Some special names used by the expander. Note that the lower case u's -- at the start of these names get translated to extra underscores. These @@ -449,7 +446,7 @@ package Snames is Name_Wide_Character_Encoding : constant Name_Id := N + $; -- GNAT Last_Configuration_Pragma_Name : constant Name_Id := N + $; - -- Remaining pragma names + -- Remaining pragma names (non-configuration pragmas) Name_Abort_Defer : constant Name_Id := N + $; -- GNAT Name_Abstract_State : constant Name_Id := N + $; -- GNAT @@ -512,6 +509,8 @@ package Snames is Name_Import_Valued_Procedure : constant Name_Id := N + $; -- GNAT Name_Independent : constant Name_Id := N + $; -- Ada 12 Name_Independent_Components : constant Name_Id := N + $; -- Ada 12 + Name_Initial_Condition : constant Name_Id := N + $; -- GNAT + Name_Initializes : constant Name_Id := N + $; -- GNAT Name_Inline : constant Name_Id := N + $; Name_Inline_Always : constant Name_Id := N + $; -- GNAT Name_Inline_Generic : constant Name_Id := N + $; -- GNAT @@ -562,12 +561,16 @@ package Snames is Name_Pack : constant Name_Id := N + $; Name_Page : constant Name_Id := N + $; Name_Passive : constant Name_Id := N + $; -- GNAT + Name_Post : constant Name_Id := N + $; -- GNAT Name_Postcondition : constant Name_Id := N + $; -- GNAT + Name_Post_Class : constant Name_Id := N + $; -- GNAT + Name_Pre : constant Name_Id := N + $; -- GNAT Name_Precondition : constant Name_Id := N + $; -- GNAT Name_Predicate : constant Name_Id := N + $; -- GNAT Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 05 Name_Preelaborate : constant Name_Id := N + $; Name_Preelaborate_05 : constant Name_Id := N + $; -- GNAT + Name_Pre_Class : constant Name_Id := N + $; -- GNAT -- Note: Priority is not in this list because its name matches the name of -- the corresponding attribute. However, it is included in the definition @@ -580,6 +583,10 @@ package Snames is Name_Pure_05 : constant Name_Id := N + $; -- GNAT Name_Pure_12 : constant Name_Id := N + $; -- GNAT Name_Pure_Function : constant Name_Id := N + $; -- GNAT + Name_Refined_Depends : constant Name_Id := N + $; -- GNAT + Name_Refined_Global : constant Name_Id := N + $; -- GNAT + Name_Refined_Post : constant Name_Id := N + $; -- GNAT + Name_Refined_State : constant Name_Id := N + $; -- GNAT Name_Relative_Deadline : constant Name_Id := N + $; -- Ada 05 Name_Remote_Access_Type : constant Name_Id := N + $; -- GNAT Name_Remote_Call_Interface : constant Name_Id := N + $; @@ -612,6 +619,8 @@ package Snames is Name_Thread_Local_Storage : constant Name_Id := N + $; -- GNAT Name_Time_Slice : constant Name_Id := N + $; -- GNAT Name_Title : constant Name_Id := N + $; -- GNAT + Name_Type_Invariant : constant Name_Id := N + $; -- GNAT + Name_Type_Invariant_Class : constant Name_Id := N + $; -- GNAT Name_Unchecked_Union : constant Name_Id := N + $; -- Ada 05 Name_Unimplemented_Unit : constant Name_Id := N + $; -- GNAT Name_Universal_Aliasing : constant Name_Id := N + $; -- GNAT @@ -685,7 +694,6 @@ package Snames is Name_Code : constant Name_Id := N + $; Name_Component : constant Name_Id := N + $; Name_Component_Size_4 : constant Name_Id := N + $; - Name_Contract_In : constant Name_Id := N + $; Name_Copy : constant Name_Id := N + $; Name_D_Float : constant Name_Id := N + $; Name_Decreases : constant Name_Id := N + $; @@ -711,7 +719,7 @@ package Snames is Name_In_Out : constant Name_Id := N + $; Name_Increases : constant Name_Id := N + $; Name_Info : constant Name_Id := N + $; - Name_Integrity : constant Name_Id := N + $; + Name_Input_Only : constant Name_Id := N + $; Name_Internal : constant Name_Id := N + $; Name_Link_Name : constant Name_Id := N + $; Name_Lowercase : constant Name_Id := N + $; @@ -745,10 +753,14 @@ package Snames is Name_No_Unroll : constant Name_Id := N + $; Name_No_Vector : constant Name_Id := N + $; Name_Nominal : constant Name_Id := N + $; + Name_Non_Volatile : constant Name_Id := N + $; Name_On : constant Name_Id := N + $; Name_Optional : constant Name_Id := N + $; + Name_Output_Only : constant Name_Id := N + $; Name_Policy : constant Name_Id := N + $; Name_Parameter_Types : constant Name_Id := N + $; + Name_Part_Of : constant Name_Id := N + $; + Name_Proof_In : constant Name_Id := N + $; Name_Reason : constant Name_Id := N + $; Name_Reference : constant Name_Id := N + $; Name_Requires : constant Name_Id := N + $; @@ -795,20 +807,15 @@ package Snames is -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These - -- attributes are implemented in both Ada 83 and Ada 95 modes in GNAT. + -- attributes are implemented in all Ada modes in GNAT. -- The entries marked GNAT are attributes that are defined by GNAT and - -- implemented in both Ada 83 and Ada 95 modes. Full descriptions of these - -- implementation dependent attributes may be found in the appropriate - -- section in Sem_Attr. + -- implemented in all Ada modes. Full descriptions of these implementation + -- dependent attributes may be found in the appropriate Sem_Attr section. -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. - -- The entries marked HiLite are attributes that are defined by Hi-Lite - -- and implemented in GNAT operating under formal verification mode. The - -- entries are treated as illegal in all other contexts. - First_Attribute_Name : constant Name_Id := N + $; Name_Abort_Signal : constant Name_Id := N + $; -- GNAT Name_Access : constant Name_Id := N + $; @@ -869,8 +876,9 @@ package Snames is Name_Last_Valid : constant Name_Id := N + $; -- Ada 12 Name_Leading_Part : constant Name_Id := N + $; Name_Length : constant Name_Id := N + $; + Name_Library_Level : constant Name_Id := N + $; -- GNAT Name_Lock_Free : constant Name_Id := N + $; -- GNAT - Name_Loop_Entry : constant Name_Id := N + $; -- HiLite + Name_Loop_Entry : constant Name_Id := N + $; -- GNAT Name_Machine_Emax : constant Name_Id := N + $; Name_Machine_Emin : constant Name_Id := N + $; Name_Machine_Mantissa : constant Name_Id := N + $; @@ -1213,7 +1221,7 @@ package Snames is -- Additional reserved words and identifiers used in GNAT Project Files -- Note that Name_External is already previously declared. - -- The names with the -- GB annotation are only used in gprbuild. + -- Names with a -- GB annotation are only used in gprbuild or gprclean Name_Active : constant Name_Id := N + $; Name_Aggregate : constant Name_Id := N + $; @@ -1221,6 +1229,8 @@ package Snames is Name_Archive_Builder_Append_Option : constant Name_Id := N + $; Name_Archive_Indexer : constant Name_Id := N + $; Name_Archive_Suffix : constant Name_Id := N + $; + Name_Artifacts_In_Exec_Dir : constant Name_Id := N + $; -- GB + Name_Artifacts_In_Object_Dir : constant Name_Id := N + $; -- GB Name_Binder : constant Name_Id := N + $; Name_Body_Suffix : constant Name_Id := N + $; Name_Builder : constant Name_Id := N + $; @@ -1292,6 +1302,7 @@ package Snames is Name_Library_Options : constant Name_Id := N + $; Name_Library_Partial_Linker : constant Name_Id := N + $; Name_Library_Reference_Symbol_File : constant Name_Id := N + $; + Name_Library_Rpath_Options : constant Name_Id := N + $; -- GB Name_Library_Standalone : constant Name_Id := N + $; Name_Library_Encapsulated_Options : constant Name_Id := N + $; -- GB Name_Library_Encapsulated_Supported : constant Name_Id := N + $; -- GB @@ -1486,6 +1497,7 @@ package Snames is Attribute_Last_Valid, Attribute_Leading_Part, Attribute_Length, + Attribute_Library_Level, Attribute_Lock_Free, Attribute_Loop_Entry, Attribute_Machine_Emax, @@ -1817,6 +1829,8 @@ package Snames is Pragma_Import_Valued_Procedure, Pragma_Independent, Pragma_Independent_Components, + Pragma_Initial_Condition, + Pragma_Initializes, Pragma_Inline, Pragma_Inline_Always, Pragma_Inline_Generic, @@ -1849,17 +1863,25 @@ package Snames is Pragma_Pack, Pragma_Page, Pragma_Passive, + Pragma_Post, Pragma_Postcondition, + Pragma_Post_Class, + Pragma_Pre, Pragma_Precondition, Pragma_Predicate, Pragma_Preelaborable_Initialization, Pragma_Preelaborate, Pragma_Preelaborate_05, + Pragma_Pre_Class, Pragma_Psect_Object, Pragma_Pure, Pragma_Pure_05, Pragma_Pure_12, Pragma_Pure_Function, + Pragma_Refined_Depends, + Pragma_Refined_Global, + Pragma_Refined_Post, + Pragma_Refined_State, Pragma_Relative_Deadline, Pragma_Remote_Access_Type, Pragma_Remote_Call_Interface, @@ -1883,6 +1905,8 @@ package Snames is Pragma_Thread_Local_Storage, Pragma_Time_Slice, Pragma_Title, + Pragma_Type_Invariant, + Pragma_Type_Invariant_Class, Pragma_Unchecked_Union, Pragma_Unimplemented_Unit, Pragma_Universal_Aliasing, diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 5259dd776ff..43ed21a2862 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -800,6 +800,7 @@ package body Sprint is -- do not duplicate the output at this point. if Nkind (Node) = N_Freeze_Entity + or else Nkind (Node) = N_Freeze_Generic_Entity or else Nkind (Node) = N_Implicit_Label_Declaration then Sprint_Node_Actual (Node); @@ -1862,6 +1863,16 @@ package body Sprint is Write_Rewrite_Str (">>>"); end if; + when N_Freeze_Generic_Entity => + if Dump_Original_Only then + null; + + else + Write_Indent; + Write_Str_With_Col_Check_Sloc ("freeze_generic "); + Write_Id (Entity (Node)); + end if; + when N_Full_Type_Declaration => Write_Indent_Str_Sloc ("type "); Sprint_Node (Defining_Identifier (Node)); diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads index 173d148677d..72fde2f23eb 100644 --- a/gcc/ada/sprint.ads +++ b/gcc/ada/sprint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -57,6 +57,7 @@ package Sprint is -- Expression with range check {expression} -- Free statement free expr [storage_pool = xxx] -- Freeze entity with freeze actions freeze entityname [ actions ] + -- Freeze generic entity freeze_generic entityname -- Implicit call to run time routine $routine-name -- Implicit exportation $pragma import (...) -- Implicit importation $pragma export (...) diff --git a/gcc/ada/stand.adb b/gcc/ada/stand.adb index ab703fbb73d..55ec41839b6 100644 --- a/gcc/ada/stand.adb +++ b/gcc/ada/stand.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992,1993,1994,1995,2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -76,7 +76,6 @@ package body Stand is Tree_Read_Int (Int (Standard_Op_Shift_Left)); Tree_Read_Int (Int (Standard_Op_Shift_Right)); Tree_Read_Int (Int (Standard_Op_Shift_Right_Arithmetic)); - end Tree_Read; ---------------- @@ -121,7 +120,6 @@ package body Stand is Tree_Write_Int (Int (Standard_Op_Shift_Left)); Tree_Write_Int (Int (Standard_Op_Shift_Right)); Tree_Write_Int (Int (Standard_Op_Shift_Right_Arithmetic)); - end Tree_Write; end Stand; diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads index 33a184ccfbc..0f6b876937e 100644 --- a/gcc/ada/stand.ads +++ b/gcc/ada/stand.ads @@ -451,13 +451,15 @@ package Stand is Standard_Integer_16 : Entity_Id; Standard_Integer_32 : Entity_Id; Standard_Integer_64 : Entity_Id; - -- These are signed integer types with the indicated sizes, They are used - -- for the underlying implementation types for fixed-point and enumeration - -- types. + -- These are signed integer types with the indicated sizes. Used for the + -- underlying implementation types for fixed-point and enumeration types. Standard_Unsigned : Entity_Id; -- An unsigned type of the same size as Standard_Integer + Standard_Unsigned_64 : Entity_Id; + -- An unsigned type, mod 2 ** 64, size of 64 bits. + Abort_Signal : Entity_Id; -- Entity for abort signal exception diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb index 7b78a164395..a708da9e5bc 100644 --- a/gcc/ada/stylesw.adb +++ b/gcc/ada/stylesw.adb @@ -25,6 +25,7 @@ with Hostparm; use Hostparm; with Opt; use Opt; +with Output; use Output; package body Stylesw is @@ -466,9 +467,13 @@ package body Stylesw is null; when others => - Err_Col := Err_Col - 1; - Bad_Style_Switch ("invalid style switch: " & C); - return; + if Ignore_Unrecognized_VWY_Switches then + Write_Line ("unrecognized switch -gnaty" & C & " ignored"); + else + Err_Col := Err_Col - 1; + Bad_Style_Switch ("invalid style switch: " & C); + return; + end if; end case; -- Turning switches off @@ -571,9 +576,13 @@ package body Stylesw is null; when others => - Err_Col := Err_Col - 1; - Bad_Style_Switch ("invalid style switch: " & C); - return; + if Ignore_Unrecognized_VWY_Switches then + Write_Line ("unrecognized switch -gnaty-" & C & " ignored"); + else + Err_Col := Err_Col - 1; + Bad_Style_Switch ("invalid style switch: " & C); + return; + end if; end case; end if; end loop; diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 197be06a19e..0d80f44a3a5 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -717,6 +717,12 @@ package body Switch.C is return; + -- -gnateu (unrecognized y,V,w switches) + + when 'u' => + Ptr := Ptr + 1; + Ignore_Unrecognized_VWY_Switches := True; + -- -gnateV (validity checks on parameters) when 'V' => diff --git a/gcc/ada/system-vxworks-arm.ads b/gcc/ada/system-vxworks-arm.ads index ae8ddd51065..60a41e1b27b 100644 --- a/gcc/ada/system-vxworks-arm.ads +++ b/gcc/ada/system-vxworks-arm.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (VxWorks Version ARM) -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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 -- @@ -142,8 +142,8 @@ private Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Stack_Check_Limits : constant Boolean := True; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index 17c934a0ab1..c3cace3c559 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -402,7 +402,7 @@ package Targparm is -- appropriate default in some cases, e.g. on embedded targets which do not -- allow the possibility of multi-processors. The default can be overridden -- using pragmas Enable/Disable_Atomic_Synchronization and also by use of - -- the debug flags gnat.d and gnatd.e. + -- the corresponding debug flags -gnatd.e and -gnatd.d. Support_Aggregates_On_Target : Boolean := True; -- In the general case, the use of aggregates may generate calls diff --git a/gcc/ada/thread.c b/gcc/ada/thread.c index 87d7603cfa0..31309e05b6e 100644 --- a/gcc/ada/thread.c +++ b/gcc/ada/thread.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2011, Free Software Foundation, Inc. * + * Copyright (C) 2011-2013, 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,31 +33,15 @@ #include "s-oscons.h" -#ifdef NEED_PTHREAD_CONDATTR_SETCLOCK +/* If the clock we used for tasking (CLOCK_RT_Ada) is not the default + * CLOCK_REALTIME, we need to set cond var attributes accordingly. + */ +#if CLOCK_RT_Ada != CLOCK_REALTIME # include <pthread.h> # include <time.h> -#ifndef _AIXVERSION_530 -/* We use the same runtime library for AIX 5.2 and 5.3, but pthread_condattr_ - * setclock exists only on the latter, so for the former provide a dummy - * implementation (declared below, weak symbol defined in init.c). - * - * Note: this means that under AIX 5.2 we'll be using CLOCK_MONOTONIC - * timestamps from clock_gettime() as arguments to pthread_cond_timedwait, - * which expects a CLOCK_REALTIME value, which is technically wrong, but - * inocuous in practice on that particular platform since both clocks happen - * to use close epochs. - */ - -extern int pthread_condattr_setclock (pthread_condattr_t *attr, clockid_t cl); -#endif - int __gnat_pthread_condattr_setup(pthread_condattr_t *attr) { -/* - * If using a clock other than CLOCK_REALTIME for the Ada Monotonic_Clock, - * the corresponding clock id must be set for condition variables. - */ return pthread_condattr_setclock (attr, CLOCK_RT_Ada); } diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 4bbaa6b43da..4888d69e190 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -172,7 +172,7 @@ package Types is for Physical_Line_Number'Size use 32; -- Line number type, used for storing physical line numbers (i.e. line -- numbers in the physical file being compiled, unaffected by the presence - -- of source reference pragmas. + -- of source reference pragmas). type Column_Number is range 0 .. 32767; for Column_Number'Size use 16; @@ -183,11 +183,17 @@ package Types is No_Column_Number : constant Column_Number := 0; -- Special value used to indicate no column number + Source_Align : constant := 2 ** 12; + -- Alignment requirement for source buffers (by keeping source buffers + -- aligned, we can optimize the implementation of Get_Source_File_Index. + -- See this routine in Sinput for details. + subtype Source_Buffer is Text_Buffer; -- Type used to store text of a source file. The buffer for the main -- source (the source specified on the command line) has a lower bound -- starting at zero. Subsequent subsidiary sources have lower bounds - -- which are one greater than the previous upper bound. + -- which are one greater than the previous upper bound, rounded up to + -- a multiple of Source_Align. subtype Big_Source_Buffer is Text_Buffer (0 .. Text_Ptr'Last); -- This is a virtual type used as the designated type of the access type diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index d450164ee4c..1f73288481a 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -72,7 +72,9 @@ gcc -c ^ GNAT COMPILE -gnatep ^ /DATA_PREPROCESSING -gnateP ^ /CATEGORIZATION_WARNINGS -gnateS ^ /SCO_OUTPUT --gnatet ^ /TARGET_DEPENDENT_INFO +-gnatet ^ /WRITE_TARGET_DEPENDENT_INFO +-gnateT ^ /READ_TARGET_DEPENDENT_INFO +-gnateu ^ /IGNORE_UNRECOGNIZED -gnateV ^ /PARAMETER_VALIDITY_CHECK -gnateY ^ /IGNORE_STYLE_CHECKS_PRAGMAS -gnatE ^ /CHECKS=ELABORATION @@ -142,6 +144,8 @@ gcc -c ^ GNAT COMPILE -gnatwC ^ /WARNINGS=NOCONDITIONALS -gnatw.c ^ /WARNINGS=MISSING_COMPONENT_CLAUSES -gnatw.C ^ /WARNINGS=NOMISSING_COMPONENT_CLAUSES +-gnatw.d ^ /WARNINGS=TAG_WARNINGS +-gnatw.D ^ /WARNINGS=NOTAG_WARNINGS -gnatwd ^ /WARNINGS=IMPLICIT_DEREFERENCE -gnatwD ^ /WARNINGS=NOIMPLICIT_DEREFERENCE -gnatwe ^ /WARNINGS=ERRORS @@ -202,6 +206,8 @@ gcc -c ^ GNAT COMPILE -gnatw.X ^ /WARNINGS=NOLOCAL_RAISE_HANDLING -gnatwy ^ /WARNINGS=ADA_2005_COMPATIBILITY -gnatwY ^ /WARNINGS=NOADA_2005_COMPATIBILITY +-gnatw.y ^ /WARNINGS=WHY_SPEC_NEEDS_BODY +-gnatw.Y ^ /WARNINGS=NOWHY_SPEC_NEEDS_BODY -gnatwz ^ /WARNINGS=UNCHECKED_CONVERSIONS -gnatwZ ^ /WARNINGS=NOUNCHECKED_CONVERSIONS -gnatW8 ^ /WIDE_CHARACTER_ENCODING=UTF8 diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index ffcd7246905..3f566f47fb5 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -251,6 +251,11 @@ begin Write_Switch_Char ("eT=?"); Write_Line ("Read target dependent information file ?, e.g. gnateT=tdf"); + -- Line for -gnateu switch + + Write_Switch_Char ("eu"); + Write_Line ("Ignore unrecognized style/validity/warning switches"); + -- Line for -gnateV switch Write_Switch_Char ("eV"); @@ -571,6 +576,8 @@ begin Write_Line (" .X* turn off warnings for non-local exception"); Write_Line (" y*+ turn on warnings for Ada compatibility issues"); Write_Line (" Y turn off warnings for Ada compatibility issues"); + Write_Line (" .y turn on info messages for why pkg body needed"); + Write_Line (" .Y* turn off info messages for why pkg body needed"); Write_Line (" z*+ turn on warnings for suspicious " & "unchecked conversion"); Write_Line (" Z turn off warnings for suspicious " & diff --git a/gcc/ada/validsw.adb b/gcc/ada/validsw.adb index b37825ed461..517180ad936 100644 --- a/gcc/ada/validsw.adb +++ b/gcc/ada/validsw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2013, 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,7 +23,8 @@ -- -- ------------------------------------------------------------------------------ -with Opt; use Opt; +with Opt; use Opt; +with Output; use Output; package body Validsw is @@ -229,9 +230,14 @@ package body Validsw is null; when others => - OK := False; - Err_Col := J - 1; - return; + if Ignore_Unrecognized_VWY_Switches then + Write_Line ("unrecognized switch -gnatV" & C & " ignored"); + else + OK := False; + Err_Col := J - 1; + return; + end if; + end case; end loop; diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index f92788af69b..aa22577efce 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -1802,6 +1802,13 @@ package VMS_Data is -- otherwise ignored. Allows style checks to be fully controlled by -- command line qualifiers. + S_GCC_IgnoreU : aliased constant S := "/IGNORE_UNRECOGNIZED " & + "-gnateu"; + -- /IGNORE_UNRECOGNIZED + -- + -- Causes unrecognized style switches, validity switches, and warning + -- switches to be ignored rather than generating an error message. + S_GCC_Immed : aliased constant S := "/IMMEDIATE_ERRORS " & "-gnatdO"; -- /NOIMMEDIATE_ERRORS (D) @@ -2885,12 +2892,17 @@ package VMS_Data is -- -- All compiler tables start at nnn times usual starting size. - S_GCC_Target : aliased constant S := "/TARGET_DEPENDENT_INFO " & - "-gnatet"; - -- /NOTARGET_DEPENDENT_INFO (D) - -- /TARGET_DEPENDENT_INFO + S_GCC_Target_W : aliased constant S := "/WRITE_TARGET_DEPENDENT_INFO=<" & + "-gnatet=>"; + -- /WRITE_TARGET_DEPENDENT_INFO=file -- - -- Generate target dependent information. + -- Generate target dependent information to file. + + S_GCC_Target_R : aliased constant S := "/READ_TARGET_DEPENDENT_INFO=<" & + "-gnateT=>"; + -- /READ_TARGET_DEPENDENT_INFO=file + -- + -- Read target dependent information from file. S_GCC_Trace : aliased constant S := "/TRACE_UNITS " & "-gnatdc"; @@ -3094,6 +3106,10 @@ package VMS_Data is "-gnatwd " & "NO_IMPLICIT_DEREFERENCE " & "-gnatwD " & + "TAG_WARNINGS " & + "-gnatw.d " & + "NOTAG_WARNINGS " & + "-gnatw.D " & "ERRORS " & "-gnatwe " & "UNREFERENCED_FORMALS " & @@ -3218,6 +3234,10 @@ package VMS_Data is "-gnatwy " & "NOADA_2005_COMPATIBILITY " & "-gnatwY " & + "WHY_SPEC_NEEDS_BODY " & + "-gnatw.y " & + "NO_WHY_SPEC_NEEDS_BODY " & + "-gnatw.Y " & "UNCHECKED_CONVERSIONS " & "-gnatwz " & "NOUNCHECKED_CONVERSIONS " & @@ -3483,12 +3503,24 @@ package VMS_Data is -- VARIABLES_UNINITIALIZED Activates warnings on unassigned variables. -- Causes warnings to be generated when a variable -- is accessed which may not be properly - -- uninitialized. - -- The default is that such warnings are - -- generated. + -- uninitialized. The default is that such + -- warnings are generated. + -- + -- NOVARIABLES_UNINITIALIZED + -- Suppress warnings for uninitialized variables. + -- + -- TAG_WARNINGS Causes the string [xxx] to be added to warnings + -- that are controlled by the warning string xxx, + -- e.g. [REDUNDANT], or if the warning is enabled + -- by default, the tag is [enabled by default]. + -- + -- NOTAG_WARNINGS Turns off warning tag output (default setting). + -- + -- WHY_SPEC_NEEDS_BODY Generates information messages showing why a + -- package specification requires a body. -- - -- NOVARIABLES_UNINITIALIZED Suppress warnings for uninitialized - -- variables. + -- NO_WHY_SPEC_NEEDS_BODY Turns off information messages showing why a + -- package specification requires a body. S_GCC_WarnX : aliased constant S := "/NOWARNINGS " & "-gnatws"; @@ -3681,6 +3713,7 @@ package VMS_Data is S_GCC_IdentX 'Access, S_GCC_IgnoreR 'Access, S_GCC_IgnoreS 'Access, + S_GCC_IgnoreU 'Access, S_GCC_Immed 'Access, S_GCC_Inline 'Access, S_GCC_InlineX 'Access, @@ -3723,7 +3756,8 @@ package VMS_Data is S_GCC_Symbol 'Access, S_GCC_Syntax 'Access, S_GCC_Table 'Access, - S_GCC_Target 'Access, + S_GCC_Target_W'Access, + S_GCC_Target_R'Access, S_GCC_Trace 'Access, S_GCC_Tree 'Access, S_GCC_Trys 'Access, diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index 36360f96d63..009b450784c 100644 --- a/gcc/ada/warnsw.adb +++ b/gcc/ada/warnsw.adb @@ -25,6 +25,7 @@ with Err_Vars; use Err_Vars; with Opt; use Opt; +with Output; use Output; package body Warnsw is @@ -50,6 +51,8 @@ package body Warnsw is W.Implementation_Unit_Warnings; Ineffective_Inline_Warnings := W.Ineffective_Inline_Warnings; + List_Body_Required_Info := + W.List_Body_Required_Info; List_Inherited_Aspects := W.List_Inherited_Aspects; Warning_Doc_Switch := @@ -144,6 +147,8 @@ package body Warnsw is Implementation_Unit_Warnings; W.Ineffective_Inline_Warnings := Ineffective_Inline_Warnings; + W.List_Body_Required_Info := + List_Body_Required_Info; W.List_Inherited_Aspects := List_Inherited_Aspects; W.Warning_Doc_Switch := @@ -256,6 +261,7 @@ package body Warnsw is Elab_Warnings := True; Implementation_Unit_Warnings := True; Ineffective_Inline_Warnings := True; + List_Body_Required_Info := True; List_Inherited_Aspects := True; Warning_Doc_Switch := True; Warn_On_Ada_2005_Compatibility := True; @@ -385,8 +391,18 @@ package body Warnsw is Warn_On_Non_Local_Exception := False; No_Warn_On_Non_Local_Exception := True; + when 'y' => + List_Body_Required_Info := True; + + when 'Y' => + List_Body_Required_Info := False; + when others => - return False; + if Ignore_Unrecognized_VWY_Switches then + Write_Line ("unrecognized switch -gnatw." & C & " ignored"); + else + return False; + end if; end case; return True; @@ -406,6 +422,7 @@ package body Warnsw is Elab_Warnings := False; Implementation_Unit_Warnings := False; Ineffective_Inline_Warnings := True; + List_Body_Required_Info := False; List_Inherited_Aspects := False; Warning_Doc_Switch := False; Warn_On_Ada_2005_Compatibility := True; @@ -487,6 +504,7 @@ package body Warnsw is Elab_Warnings := False; Implementation_Unit_Warnings := False; Ineffective_Inline_Warnings := False; + List_Body_Required_Info := False; List_Inherited_Aspects := False; Warning_Doc_Switch := False; Warn_On_Ada_2005_Compatibility := False; @@ -672,6 +690,11 @@ package body Warnsw is Warn_On_Unchecked_Conversion := False; when others => + if Ignore_Unrecognized_VWY_Switches then + Write_Line ("unrecognized switch -gnatw" & C & " ignored"); + else + return False; + end if; return False; end case; diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads index b39f545802d..0358fd77d4f 100644 --- a/gcc/ada/warnsw.ads +++ b/gcc/ada/warnsw.ads @@ -68,6 +68,7 @@ package Warnsw is Elab_Warnings : Boolean; Implementation_Unit_Warnings : Boolean; Ineffective_Inline_Warnings : Boolean; + List_Body_Required_Info : Boolean; List_Inherited_Aspects : Boolean; Warning_Doc_Switch : Boolean; Warn_On_Ada_2005_Compatibility : Boolean; |