diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2013-06-26 18:39:06 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2013-06-26 18:39:06 +0000 |
| commit | 21543d4cd558cada630271a0cf3075ad7ce94cbf (patch) | |
| tree | 08bdb3f3e0a9d0f71e72bb56d9ddb7b916e7dfeb /gcc/ada | |
| parent | ed0bc1ffb674fe93d0df68654b5bb76869f0bc8c (diff) | |
| download | gcc-21543d4cd558cada630271a0cf3075ad7ce94cbf.tar.gz | |
2013-06-26 Basile Starynkevitch <basile@starynkevitch.net>
{{merged with trunk [4.9] svn rev. 196654-200426}}
MELT branch merged with trunk rev. 200426 using svnmerge.py
[gcc/]
2013-06-26 Basile Starynkevitch <basile@starynkevitch.net>
{{merge with trunk [4.9] svn rev. 196654-200426}}
* melt-runtime.c (melt_val2passflag): TODO_ggc_collect &
TODO_do_not_ggc_collect are conditionalized.
* melt/generated/warmelt-first+03.cc: Manually remove calls to
MELT_TRACE_EXIT_LOCATION macro.
* melt/generated/warmelt-base+03.cc: Ditto.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@200430 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
270 files changed, 29332 insertions, 17252 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 784448558ad..4122896c915 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,2905 @@ +2013-06-13 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/ada-tree.h (DECL_BY_DOUBLE_REF_P): Delete. + * gcc-interface/gigi.h (annotate_object): Adjust prototype. + (convert_vms_descriptor): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_param): Do not pass fat pointer + types by double dereference. + (annotate_object): Remove BY_DOUBLE_REF parameter and adjust. + (gnat_to_gnu_entity): Adjust calls to annotate_object. + * gcc-interface/trans.c (Identifier_to_gnu): Do not deal with double + dereference. + (Call_to_gnu): Likewise. + (build_function_stub): Adjust call to convert_vms_descriptor. + (Subprogram_Body_to_gnu): Adjust call to annotate_object. + * gcc-interface/utils.c (convert_vms_descriptor): Remove BY_REF + parameter and adjust. + +2013-05-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/Makefile.in (arm% androideabi): Robustify. + +2013-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c: (gnat_to_gnu_entity): In ASIS mode, do not + check that access types have a set size. + +2013-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (vinfo_t): New type and associated vector. + (components_to_record): Change return type to bool. + Lay out the variants in two passes. Do not force a specific layout for + the variant part if the variants do not have a representation clause. + Take the alignment of the variant part into account when laying out + variants without rep clause in a record type with a partial rep clause. + (create_rep_part): Do not set the position of the field. + +2013-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Attribute_to_gnu) <Attr_Last_Bit>: Add kludge + to avoid generating an overflow for -1. + +2013-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/gigi.h (create_type_decl): Adjust prototype. + (create_label_decl): Complete prototype. + (process_attributes): Declare. + * gcc-interface/decl.c (gnat_to_gnu_entity): Adjust multiple calls to + create_type_decl throughout. + <E_Enumeration_Type>: Do the layout of the type manually and call + process_attributes on it. Reindent. + <E_Enumeration_Subtype>: Minor tweak. + <E_Floating_Point_Subtype>: Reindent. + <E_Array_Subtype>: Call process_attributes on the array type built + for a packed array type. + <E_Record_Type>: Call process_attributes on the type. + <E_Record_Subtype>: Likewise. + <E_Access_Type>: Likewise. + <E_Subprogram_Type>: Likewise. + Likewise for all types at the end of the processing. + * gcc-interface/utils.c (make_aligning_type): Adjust call to + create_type_decl. + (maybe_pad_type): Likewise. + (create_index_type): Likewise. + (create_type_decl): Remove attr_list parameter and associated code. + (create_var_decl_1): Call process_attributes on the variable. + (process_attributes): Take a pointer to the object and add in_place + and gnat_node parameters and adjust throughout. + <ATTR_MACHINE_ATTRIBUTE>: Pass ATTR_FLAG_TYPE_IN_PLACE only on demand + and set the input location. + Zap the attribute list at the end. + (create_subprog_decl): Call process_attributes on the subprogram. + (build_unc_object_type): Adjust call to create_type_decl. + (handle_vector_type_attribute): Remove dead code. + +2013-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/gigi.h (make_aligning_type): Adjust prototype. + * gcc-interface/utils.c (make_aligning_type): Take GNAT_NODE parameter + for the position of the associated TYPE_DECL. + * gcc-interface/decl.c (gnat_to_gnu_entity): Adjust call to above. + * gcc-interface/utils2.c (maybe_wrap_malloc): Likewise. + +2013-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity): Do not prematurely + elaborate the full view of a type with a freeze node. + * gcc-interface/trans.c (process_type): Add explicit predicate. + +2013-05-26 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <object>: Always build the + UNC variable for aliased objects with unconstrained nominal subtype. + +2013-05-24 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/gigi.h (gnat_init_gcc_fp): Declare. + * gcc-interface/trans.c (gigi): Call it. + * gcc-interface/misc.c (gnat_init_gcc_fp): New function. + +2013-05-24 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/gigi.h (enum inline_status_t): New type. + (create_subprog_decl): Adjust prototype. + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Procedure>: Adjust + calls to create_subprog_decl. + (get_minimal_subprog_decl): Likewise. + * gcc-interface/trans.c (gigi): Likewise. + (build_raise_check): Likewise. + (establish_gnat_vms_condition_handler): Likewise. + (Compilation_Unit_to_gnu): Likewise. + (gnat_to_gnu): Likewise. + * gcc-interface/utils.c (create_subprog_decl): Change inline_flag + parameter to inline_status and implement for suppressed inlining. + +2013-05-24 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/ada-tree.h (LOOP_STMT_NO_UNROLL): New define. + (LOOP_STMT_UNROLL): Likewise. + (LOOP_STMT_NO_VECTOR): Likewise. + (LOOP_STMT_VECTOR): Likewise. + * gcc-interface/trans.c (struct loop_info_d): Replace label field + with stmt field. + (Pragma_to_gnu) <Pragma_Loop_Optimize>: New case. + (Loop_Statement_to_gnu): Save the loop statement onto the stack + instead of the label. + (gnat_to_gnu) <N_Exit_Statement>: Retrieve the loop label. + +2013-05-24 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c: Include diagnostic.h and opts.h. + (Pragma_to_gnu) <Pragma_Warnings>: New case. + +2013-05-24 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: Constify + a handful of local variables. + For a derived untagged type that renames discriminants, change the type + of the stored discriminants to a subtype with the bounds of the type + of the visible discriminants. + (build_subst_list): Rename local variable. + +2013-05-16 Jason Merrill <jason@redhat.com> + + * gcc-interface/Make-lang.in (gnat1$(exeext)): Use link mutex. + +2013-05-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR ada/57188 + * gcc-interface/Makefile.in: Allow for amd64 solaris2. + +2013-05-07 Eric Botcazou <ebotcazou@adacore.com> + + PR ada/56474 + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Subtype>: Use + int_const_binop to shift bounds by 1 when they are integer constants. + +2013-04-25 Arnaud Charlet <charlet@adacore.com>> + + * gcc-interface/Makefile.in (ADA_EXCLUDE_SRCS): Exclude s-init.ad{s,b} + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb (Apply_Predicate_Check): Update the comment associated + with the call to Check_Expression_Against_Static_Predicate. + * sem_ch3.adb (Analyze_Object_Declaration): Update the comment + associated with the call to Check_Expression_Against_Static_Predicate. + * sem_util.adb (Check_Expression_Against_Static_Predicate): + Broaden the check from a static expression to an expression with + a known value at compile time. + * sem_util.ads (Check_Expression_Against_Static_Predicate): Update + comment on usage. + +2013-04-25 Thomas Quinot <quinot@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference, cases Position, + First_Bit, and Last_Bit): Fix incorrect test in implementation of + RM 2005 13.5.2(3/2). + +2013-04-25 Claire Dross <dross@adacore.com> + + * a-cfhase.adb, a-cfhase.ads, a-cforma.adb, a-cforma.ads, a-cfhama.adb, + a-cfhama.ads, a-cforse.adb, a-cforse.ads, a-cofove.adb, a-cofove.ads + (Query_Element): Removed. + (Update_Element): Removed. + (Insert): The version with no New_Item specified is removed. + (Iterate): Removed. + (Write): Removed. + (Read): Removed. + Every check of fields Busy and Lock has been removed. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb (Analyze_Pragma, case Contract_Cases): Remove + call to S14_Pragma (Find_Related_Subprogram): Require proper + placement in subprogram body (Find_Related_Subprogram): Detect + duplicates for all cases (Find_Related_Subprogram): Handle case + of spec nested inside body. + +2013-04-25 Arnaud Charlet <charlet@adacore.com> + + * par-prag.adb: Fix typo. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb (Apply_Predicate_Check): If the type has a static + predicate and the expression is also static, check whether the + expression satisfies the predicate. + * sem_ch3.adb (Analyze_Object_Declaration): If the type has a + static predicate and the expression is also static, see if the + expression satisfies the predicate. + * sem_util.adb: Alphabetize several routines. + (Check_Expression_Against_Static_Predicate): New routine. + * sem_util.ads (Check_Expression_Against_Static_Predicate): New routine. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Document Reason argument for pragma Warnings. + * par-prag.adb: Handle Reason parameter for pragma Warnings. + * sem_prag.adb (Analyze_Pragma, case Warnings): Allow Reason argument. + * snames.ads-tmpl (Name_Reason): New name entry. + +2013-04-25 Yannick Moy <moy@adacore.com> + + * exp_spark.adb (Expand_SPARK_N_In): Remove procedure. + (Expand_SPARK): Remove special expansion for membership tests. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch3.adb (Expand_N_Object_Declaration): Update all places + that should use constant Base_Typ. When building an invariant + check, account for invariants coming from the base type. Prevent + the creation of a junk invariant check when the related object + is of an array type and it is initialized with an aggregate. + * exp_util.adb (Make_Invariant_Call): Typ is now a variable. Use + the base type to create an invariant call when the type of the + expression is a composite subtype. + +2013-04-25 Vasiliy Fofanov <fofanov@adacore.com> + + * a-cborse.adb: Fix minor typo. + +2013-04-25 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Different_Generic_Profile): A spec and body + match in an instance if a subtype declaration that renames a + generic actual with the same name appears between spec and body. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * sem_util.adb: Minor reformatting. + +2013-04-25 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Expand_N_Aggregate): Use special circuitry to + fold strings with a single others choice only if there are no + expressions in the aggregate. + +2013-04-25 Arnaud Charlet <charlet@adacore.com> + + * gnat_ugn.texi: Update doc on Ada 2012 default mode. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb: Add with and use clause for Stringt. + (Expand_Contract_Cases): Moved from sem_ch6. Add formal parameters + Decls and Stmts along with comments on their usage. + * exp_ch6.ads (Expand_Contract_Cases): Moved from sem_ch6. + * sem_ch6.adb (Expand_Contract_Cases): Moved to exp_ch6. + (Process_Contract_Cases): Update the call to Expand_Contract_Cases. + +2013-04-25 Ed Schonberg <schonberg@adacore.com> + + * gnat_rm.texi: Minor editing, to clarify use of dimension aspects. + * sem_util.adb (Is_OK_Variable_For_Out_Formal): Reject an + aggregate for a packed type, which may be converted into an + unchecked conversion of an object. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb: Minor code reorganization (correct misspelling + Restiction). + * sem_util.adb, aspects.ads, sem_ch6.adb: Minor reformatting. + * gnat_rm.texi: Document impl-defined aspects. + * sem_dim.adb, sem_dim.ads, gnat_ugn.texi, s-dimmks.ads: Minor + reformatting. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb (Set_Abstract_States): The attribute now applies + to generic packages. + * sem_ch4.adb (Referenced): Moved to sem_util. + * sem_ch7.adb (Unit_Requires_Body): A [generic] package with + a non-null abstract state needs a body. + * sem_prag.adb (Analyze_Depends_In_Decl_Part): Update the calls + to Collect_Subprogram_Inputs_Outputs. + (Analyze_Global_Item): Verify the proper usage of an item with mode + In_Out or Output relative to the enclosing context. + (Analyze_Pragma): Abstract_State can now be applied to a generic + package. Do not reset the Analyzed flag for pragmas Depends and Global + as this is not needed. + (Appears_In): Moved to library level. + (Check_Mode_Restiction_In_Enclosing_Context): New routine. + (Collect_Subprogram_Inputs_Outputs): Moved to library level. Add + formal parameters Subp_Id, Subp_Inputs, Subp_Outputs and Global + seen along with comments on usage. + * sem_util.ads, sem_util.adb (Referenced): New routine. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch6.adb (Expand_Contract_Cases): Generate + detailed error messages only when switch -gnateE is in effect. + +2013-04-25 Yannick Moy <moy@adacore.com> + + * sem_attr.adb (Analyze_Attribute): Do not issue + an error for a possibly misplaced 'Result or 'Old attribute when + analyzing the aspect. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * sem_ch12.adb, sem_util.adb, sem_ch4.adb: Minor reformatting. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch4.adb (Analyze_Quantified_Expression): + Add local variable Loop_Id. Verify that the loop variable + is used within the condition of the quantified expression. + (Referenced): New routine. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_case.adb (Analyze_Choices): Enhance the error message + given on a bad use of subtype predicate. + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Enhance + the error message given on a bad use of subtype predicate. + * sem_util.adb (Bad_Predicated_Subtype_Use): Add formal parameter + Suggest_Static. Emit an extra error message advising how to + remedy the bad use of the predicate if the context warrants it. + * sem_util.ads (Bad_Predicated_Subtype_Use): Add formal parameter + Suggest_Static along with a comment explaining its usage. + +2013-04-25 Ed Schonberg <schonberg@adacore.com> + + * sem_disp.adb (Check_Dispatching_Operation): Further refinement + to checks for AI05-0125: the check for a hidden primitive that + may be overridden by the new declaration only applies if the + hidden operation is never declared. This is not the case if the + operation is declared in a parent unit. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * debug.adb: Remove d.X and d.Y entries and documentation. + * exp_ch4.adb (Expand_N_If_Expression): Remove special code used + if expression with actions not available (now always available). + (Expand_Short_Circuit_Operator): Same change. + * gnat1drv.adb (Adjust_Global_Switches) Remove setting + Use_Expression_With_Actions flag, since this is now obsolete. + * opt.ads (Use_Expression_Actions): Removed (always True now). + * sinfo.ads: Minor comment updates. + +2013-04-25 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Check_Generic_Actuals): If an actual is an array + subtype whose base type is currently private, install full view + when compiling instance body. + +2013-04-25 Ed Schonberg <schonberg@adacore.com> + + * sem_disp.adb (Check_Dispatching_Operation): Refine checks for + AI05-0125: the check for a hidden primitive that may be overridden + by the new declaration is only performed if the declaration comes + from source, and it must carry an explicit overriding indicator. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb (Abstract_States): The attribute now applies to + generic packages. + * sem_ch3.adb (Analyze_Object_Declaration): Check whether an + object declaration introduces an illegal hidden state. + * sem_prag.adb (Analyze_Abstract_State): Check whether a state + declaration introduces an illegal hidden state. + * sem_util.ads, sem_util.adb (Check_No_Hidden_State): New routine. + +2013-04-25 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Is_Build_In_Place_Function_Call): The call may + be to a protected function, in which case the name in the call + is a selected component. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch4.adb (Analyze_Quantified_Expression): + Warn on a suspicious use of quantifier "some" when "all" was meant. + (No_Else_Or_Trivial_True): New routine. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * einfo.ads, einfo.adb: Put back with/use for Namet. + (Get_Pragma): New name (wi new spec) for Find_Pragma. + * sem_ch6.adb: Change name Find_Pragma to Get_Pragma with + different interface. + +2013-04-25 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Is_Visible_Component): In an instance all + components are visible. + +2013-04-25 Matthew Heaney <heaney@adacore.com> + + * a-rbtgbo.adb, a-crbtgo.adb (Generic_Equal): do not test for + tampering when container empty. + * a-crbtgk.adb (Ceiling, Find, Floor): ditto. + (Generic_Conditional_Insert, Generic_Conditional_Insert_With_Hint): + ditto. + +2013-04-25 Ed Schonberg <schonberg@adacore.com> + + * par-ch12.adb: Move aspects from package specification to + generic package declaration. + * sem_ch12.adb: Analyze aspect specifications before building + and analyzing the generic copy, so that the generated pragmas + are properly taken into account. + * sem_ch13.adb: For compilation unit aspects that apply to a + generic package declaration, insert corresponding pragmas ahead + of visible declarations. + * sprint.adb: Display properly the aspects of a generic type + declaration. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * frontend.adb: Minor reformatting. + +2013-04-25 Ed Schonberg <schonberg@adacore.com> + + * einfo.ads: Extend documentation on use of Is_Private_Ancestor + for untagged types. + * sem_ch3.adb (Is_Visible_Component): Refine predicate for the + case of untagged types derived from private types, to reject + illegal selected components. + +2013-04-25 Gary Dismukes <dismukes@adacore.com> + + * sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): Test + for case of selecting from an unexpanded implicit dereference + and do not make a recursive call on such a prefix. + +2013-04-25 Doug Rupp <rupp@adacore.com> + + * targparm.adb (VXF{_Str}): New tag for vaxfloat. + (Get_Target_Parameters): Handle VXF tag. + * targparm.ads (VAX_Float_On_Target): New boolean. + * system-vms-ia64.ads (VAX_Float): New boolean. + * frontend.adb (Frontend): Handle VAX float boolean. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.ads, einfo.adb: Remove with and use clauses for Namet. + (Find_Pragma): New routine. + * sem_util.ads, sem_util.adb (Find_Pragma): Moved to einfo. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch13.adb (Add_Call): Do not capture the nature of the inherited + predicate. + (Add_Predicates): Save the static predicate for diagnostics and error + reporting purposes. + (Process_PPCs): Remove local variables Dynamic_Predicate_Present and + Static_Predicate_Present. Add local variable Static_Pred. Ensure that + the expression of a static predicate is static. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb (Is_Ghost_Subprogram): Remove useless code. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Minor addition of index entry. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch6.adb (Check_Access_Invariants): Test whether an + invariant procedure is empty before generating a call to it. + (Has_Enabled_Predicate): New routine. + (Has_Null_Body): New routine. + (Process_PPCs): Test whether an invariant procedure is + empty before generating a call to it. Test whether predicates are + enabled for a particular type before generating a predicate call. + * sem_util.ads, sem_util.adb (Find_Pragma): New routine. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * sem_ch7.adb, einfo.adb, repinfo.adb, snames.adb-tmpl, + snames.ads-tmpl: Minor reformatting. + +2013-04-25 Thomas Quinot <quinot@adacore.com> + + * sem_ch7.adb: Minor reformatting. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Minor fix to Loop_Variant doc (Loop_Entry allowed). + * s-tarest.adb: Minor reformatting. + +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.ads, aspects.adb: Remove aspect Ghost from all relevant + tables. + * einfo.adb: Remove with and use clause for Aspects. + (Is_Ghost_Function): Removed. + (Is_Ghost_Entity): New routine. + (Is_Ghost_Subprogram): New routine. + * einfo.ads: Remove synthesized attribute Is_Ghost_Function + along with its uses in entities. Add synthesized attributes + Is_Ghost_Entity and Is_Ghost_Subprogram along with uses in related + entities. + (Is_Ghost_Function): Removed. + (Is_Ghost_Entity): New routine. + (Is_Ghost_Subprogram): New routine. + * par-prag.adb: Remove pragma Ghost from the processing machinery. + * repinfo.adb (List_Mechanisms): Add a value for convention Ghost. + * sem_attr.adb (Analyze_Access_Attribute): Update the check + for ghost subprograms. + * sem_ch4.adb (Analyze_Call): Update the check for calls + to ghost subprograms. + (Check_Ghost_Function_Call): Removed. + (Check_Ghost_Subprogram_Call): New routine. + * sem_ch6.adb (Check_Convention): Rewritten. + (Check_Overriding_Indicator): Remove the check for overriding + ghost functions. + (Convention_Of): New routine. + * sem_ch12.adb (Preanalyze_Actuals): Update the check for ghost + generic actual subprograms. + * sem_mech.adb (Set_Mechanisms): Add an entry for convention Ghost. + * sem_prag.adb: Remove the value for pragma Ghost from + table Sig_Flags. + (Analyze_Pragma): Remove the processing for pragma Ghost. + (Process_Convention): Emit an error when a ghost + subprogram attempts to override. + (Set_Convention_From_Pragma): Emit an error when a ghost subprogram + attempts to override. + * sinfo.ads: Clarify the usage of field Label_Construct. + * snames.adb-tmpl (Get_Convention_Id): Add an entry for + predefined name Ghost. + (Get_Convention_Name): Add an entry for convention Ghost. + * snames.ads-tmpl: Move predefined name Ghost to the sublist + denoting conventions. Add convention id Ghost. Remove pragma + id Ghost. + +2013-04-25 Ed Schonberg <schonberg@adacore.com> + + * sem_ch7.adb (Swap_Private_Dependents): Do no recurse on child + units if within a generic hierarchy. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb (Expand_Actuals): Add a predicate check on an + actual the related type has a predicate function. + * sem_ch3.adb (Constant_Redeclaration): Ensure that the related + type has an invariant procedure before building a call to it. + * sem_ch6.adb (Append_Enabled_Item): New routine. + (Check_Access_Invariants): Use routine + Append_Enabled_Item to chain onto the list of postconditions. + (Contains_Enabled_Pragmas): Removed. + (Expand_Contract_Cases): Use routine Append_Enabled_Item to chain onto + the list of postconditions. + (Invariants_Or_Predicates_Present): Removed. + (Process_PPCs): Partially reimplemented. + +2013-04-24 Sergey Rybin <rybin@adacore.com frybin> + + * tree_io.ads: Update ASIS_Version_Number because of changes + in the way how entities are chained in a scope by means of + Next_Entity link. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case + Storage_Size): If the clause is not from an aspect, insert + assignment to size variable of task type at the point of the + clause, not after the task definition, to prevent access before + elaboration in the back-end. + +2013-04-24 Yannick Moy <moy@adacore.com> + + * sem_prag.adb (Sig_Flags): Set correct value for Pragma_Assume. + +2013-04-24 Yannick Moy <moy@adacore.com> + + * gnat_rm.texi: Document 'Loop_Entry. + +2013-04-24 Jose Ruiz <ruiz@adacore.com> + + * s-tassta.adb, s-tarest.adb (Task_Wrapper): Start looking for + fall-back termination handlers from the parents, because they apply + only to dependent tasks. + * s-solita.adb (Task_Termination_Handler_T): Do not look for fall-back + termination handlers because the environment task has no parent, + and if it defines one of these handlers it does not apply to + itself because they apply only to dependent tasks. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * sem_type.adb, exp_attr.adb, exp_ch4.adb: Minor reformatting. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Document 'Update attribute. + * sem_attr.adb (Analyze_Attribute, case Update): Remove call + to S14_Attribute (S14_Attribute): removed. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * interfac.ads: Add size clauses for IEEE_Float_32/64 + +2013-04-24 Claire Dross <dross@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Remove + special assignment of Use_Expression_With_Actions for SPARK_Mode. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb (Apply_Predicate_Check): Check for the presence + of the dynamic predicate aspect when trying to determine if the + predicate of a type is non-static. + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Check + for the presence of the dynamic predicate aspect when trying to + determine if the predicate of a type is non- static. + * sem_ch13.adb (Add_Call): Capture the nature of the + inherited ancestor predicate. + (Build_Predicate_Functions): Update comments. Rewrite the checks on + static predicate application. Complain about the form of a non-static + expression only when the type is static. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb: Add guard to tree traversal. + +2013-04-24 Vincent Celier <celier@adacore.com> + + * clean.adb (Clean): Remove local variable Root_Environment, + use Makeutl.Root_Environment instead. + * gnatcmd.adb: Remove local variable Root_Environment, use + Makeutl.Root_Environment instead. + * make.adb (Gnatmake): Remove local variable Root_Environment, + use Makeutl.Root_Environment instead. + * prj-makr.adb: Remove local variable Root_Environment, use + Makeutl.Root_Environment instead. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_attr.adb (Expand_Loop_Entry_Attribute): Clarify the + extraction of the declarative part of the conditional block. Move + the processing of simple infinite loops to the start of the + expansion logic. Correct the check which determines whether the + proper scope is installed in visibility. + * sem_attr.adb (Analyze_Attribute): Add local variable Attr + to keep track of the attribute in case the enclosing indexed + component has to be rewritten. When searching for the enclosing + loop, start from the proper attribute reference in case of a + rewriting. Do not allow for 'Loop_Entry to appear in pragma + Assert. Replace loop variable J with Index. Set the type of the + proper attribute. + * sem_ch5.adb (Check_Unreachable_Code): Detect a specialized + block that services a loop statement subject to at least one + 'Loop_Entry attribute. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * sem_type.adb (Disambiguate): In Ada 2012 mode, when trying to + resolve a fixed point operation, use first subtype to determine + whether type and operator are declared in the same list of + declarations. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * par-ch6.adb (P_Subprogram): Detect an illegal + placement of the aspect specification list in the context of + expression functions. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Expand_N_Allocator): If the designated object + has tasks, and the pointer type is an itype that has no master + id, create a master renaming in the current context, which can + only be an init_proc. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb, sem_ch7.adb: Minor reformatting. + * gnat_rm.texi: Document pragma Loop_Invariant. + * sem_attr.adb (Analyze_Attribute, case Loop_Entry): This is + no longer an S14_Attribute. + * sem_prag.adb (Analyze_Pragma, case Loop_Invariant): Combine + processing with Assert, allow message parameter, remove call + to S14_Pragma. + +2013-04-24 Thomas Quinot <quinot@adacore.com> + + * exp_ch4.adb: Minor reformatting. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * sem_ch7.adb (Swap_Private_Dependents): New internal routine + to Install_Private_Declarations, to make the installation of + private dependents recursive in the presence of child units. + * sem_ch3.adb (Build_Discriminated_Subtype): Initialize properly + the Private_Dependents of a private subtype. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_attr.adb (Expand_Loop_Entry_Attribute): Update the + retrieval of the block declarations. + * par-ch4.adb (P_Name): Let the name parsing machinery create + a sequence of nested indexed components for attribute Loop_Entry. + * sem_attr.adb (Analyze_Attribute): Add local constant + Context. Reimplement part of the analysis of attribute Loop_Entry. + (Convert_To_Indexed_Component): Removed. + * sem_ch4.adb (Analyze_Indexed_Component_Form): Do not analyze + an indexed component after it has been rewritten into attribute + Loop_Entry. + +2013-04-24 Yannick Moy <moy@adacore.com> + + * snames.ads-tmpl: Minor change to list + Loop_(In)variant not in configuration pragma. + * sem_ch3.adb (Analyze_Declarations): Do not look at the original node + for analyzing the expressions in pre/postconditions. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * gnatcmd.adb, xref_lib.adb, gnatls.adb, sem_ch13.adb: Minor + reformatting. + +2013-04-24 Yannick Moy <moy@adacore.com> + + * sem_ch6.adb (Analyze_Generic_Subprogram_Body, + Analyze_Subprogram_Body_Helper): Reset contract node to Empty + before setting entity to E_Subprogram_Body. + * sem_ch8.adb (Analyze_Subprogram_Renaming): Reset contract node to + Empty before setting entity to E_Subprogram_Body. + +2013-04-24 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Document new gnatls switch -aPdir. + * gnatcmd.adb: Pass switch -aP<dir> to gnatls. + * gnatls.adb (Scan_Ls_Arg): Process new switch -aP<dir>. Issue + a warning for unknown switches. + (Usage): Add line for new switch -aPdir. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb, sem_util.ads (Is_Limited_Class_Wide_Type): Return true + if the type comes from a limited view, so that task attributes can be + constructed. + +2013-04-24 Yannick Moy <moy@adacore.com> + + * checks.adb (Apply_Float_Conversion_Check): Do not apply checks if + full expansion is not enabled. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Create_Extra_Formals): In Ada 2012, create extra + formals if the type does not yet have a completion, and thus + has no underlying view. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Treat an aspect + specification for Address as a reference, to suppress warnings + on entities that may be read by an external device. + +2013-04-24 Sergey Rybin <rybin@adacore.com frybin> + + * gnat_ugn.texi: Add description of '--help' and '--version' + options for ASIS tools: gnatelim, gnatmetric, gnatstub, gnatpp. + +2013-04-24 Arnaud Charlet <charlet@adacore.com> + + * gnat_rm.texi: Minor syntax fix. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_attr.adb (Expand_Loop_Entry_Attribute): Add extra comments on + what and why is being analyzed. Remove the decoration of renamings as + this simply falls out of the general analysis mechanism. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Explain_Redundancy): New routine. + (Resolve_Equality_Op): Place the error concerning a redundant + comparison to True at the "=". Try to explain the nature of the + redundant True. + +2013-04-24 Javier Miranda <miranda@adacore.com> + + + * checks.adb, exp_ch6.adb (Install_Null_Excluding_Check): No + check in interface thunks since it is performed at the caller + side. + (Expand_Simple_Function_Return): No accessibility check + needed in thunks since the check is done by the target routine. + +2013-04-24 Vincent Celier <celier@adacore.com> + + * xref_lib.adb (Add_Entity): Use the canonical file names + so that source file names with capital letters are found on + platforms where file names are case insensitive. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * par-ch4.adb (P_Name): Continue to parse the name extension when the + construct is attribute Loop_Entry. Do not convert the attribute + reference into an indexed component when there is at least one + expression / range following 'Loop_Entry. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch6.adb (Contains_Enabled_Pragmas): New routine. + (Process_PPCs): Generate procedure _Postconditions + only when the context has invariants or predicates or enabled + aspects/pragmas. + +2013-04-24 Thomas Quinot <quinot@adacore.com> + + * g-socket.adb (Host_Entry): Introduce intermediate copy of + memory location pointed to by Hostent_H_Addr, as it might not + have sufficient alignment. + +2013-04-24 Yannick Moy <moy@adacore.com> + + * repinfo.adb (List_Rep_Info): Set the value of Unit_Casing before + calling subprograms which may read it. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.adb: Remove Loop_Entry_Attributes from the usage of + nodes. Flag 260 is now used. + (Has_Loop_Entry_Attributes): New routine. + (Loop_Entry_Attributes): Removed. + (Set_Has_Loop_Entry_Attributes): New routine. + (Set_Loop_Entry_Attributes): Removed. + (Write_Entity_Flags): Write out Flag 260. + (Write_Field10_Name): Remove the output for Loop_Entry_Attributes. + * einfo.ads: Remove attribute Loop_Entry_Attributes, + its related comment and uses in nodes. Add new attribute + Has_Loop_Entry_Attributes, related comment and uses in loop nodes. + (Has_Loop_Entry_Attributes): New routine and pragma Inline. + (Loop_Entry_Attributes): Removed along with pragma Inline. + (Set_Has_Loop_Entry_Attributes): New routine and pragma Inline. + (Set_Loop_Entry_Attributes): Removed along with pragma Inline. + * exp_attr.adb (Expand_Loop_Entry_Attribute): New routine. + (Expand_N_Attribute_Reference): Expand attribute 'Loop_Entry. + * exp_ch5.adb: Remove with and use clause for Elists. + (Expand_Loop_Entry_Attributes): Removed. + (Expand_N_Loop_Statement): Add local variable Stmt. Rename local + constant Isc to Scheme. When a loop is subject to attribute + 'Loop_Entry, retrieve the nested loop from the conditional + block. Move the processing of controlled object at the end of + loop expansion. + * sem_attr.adb (Analyze_Attribute): Do not chain attribute + 'Loop_Entry to its related loop. + * sem_ch5.adb (Analyze_Loop_Statement): Add local variable + Stmt. When the iteration scheme mentions attribute 'Loop_Entry, + the entire loop is rewritten into a block. Retrieve the nested + loop in such cases to complete the analysis. + * sem_util.ads, sem_util.adb (Find_Loop_In_Conditional_Block): New + routine. + (Subject_To_Loop_Entry_Attributes): New routine. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * exp_prag.adb (Expand_Loop_Variant): Generate pragma Check + (Loop_Variant, xxx) rather than Assert (xxx). + * gnat_rm.texi: Document pragma Loop_Variant. + * sem_prag.adb (Analyze_Pragma, case Loop_Variant): Remove call + to S14_Pragma. + +2013-04-24 Yannick Moy <moy@adacore.com> + + * adabkend.adb, ali-util.adb, ali.adb, debug.adb, + errout.adb, errout.ads, erroutc.adb, exp_ch3.adb, exp_ch4.adb, + exp_ch6.adb, exp_ch7.adb, exp_dbug.adb, exp_util.adb, + expander.adb, freeze.adb, gnat1drv.adb, lib-writ.adb, + lib-writ.ads, lib-xref.adb, lib-xref.ads, opt.adb, opt.ads, + restrict.adb, sem_aggr.adb, sem_attr.adb, sem_ch3.adb, + sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, sem_eval.adb, sem_prag.adb, + sem_res.adb, sem_util.adb: Everything with name + 'Alfa' renamed in 'SPARK'. Update comments. + Renaming of units with name 'Alfa', renamed with 'SPARK' instead. + * exp_alfa.adb: renamed exp_spark.adb. + * exp_alfa.ads: renamed exp_spark.ads. + * get_alfa.adb: renamed get_spark_xrefs.adb. + * get_alfa.ads: renamed get_spark_xrefs.ads. + * lib-xref-alfa.adb: renamed lib-xref-spark_specific.adb. + * put_alfa.adb: renamed put_spark_xrefs.adb. + * put_alfa.ads: renamed put_spark_xrefs.ads. + * alfa.adb: renamed spark_xrefs.adb. + * alfa.ads: renamed spark_xrefs.ads. + * alfa_test.adb: renamed spark_xrefs_test.adb. + * gcc-interface/Make-lang.in: Update dependencies. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Document pragma Assume. + * sem_prag.adb (Analyze_Pragma, case Assume): Now processed as + part of Assert, and no longer requires -gnatd.F + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Document pragma Assert_And_Cut. + * sem_prag.adb (Analyze_Pragma, case Assert_And_Cut): Remove + S14_Pragma call. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * sem_aux.adb: Add guard in Available_View. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Depends_In_Decl_Part): Use + Find_Related_Subprogram to find the associated subprogram. + (Analyze_Global_In_Decl_List): Use Find_Related_Subprogram + to find the associated subprogram. + (Analyze_Pragma): Use Find_Related_Subprogram to find the associated + subprogram. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb: Remove with and use clause for Sem_Prag. + (Freeze_Subprogram): Call Analyze_Subprogram_Contract to analyze + the contract of a subprogram. + * sem_ch3.adb: Remove with and use clause for Sem_Prag. + (Analyze_Declarations): Call Analyze_Subprogram_Contract to + analyze the contract of a subprogram. + * sem_ch6.adb (Analyze_Subprogram_Contract): New routine. + (Check_Subprogram_Contract): Removed. + * sem_ch6.ads (Analyze_Subprogram_Contract): New routine. + (Check_Subprogram_Contract): Removed. + (Expand_Contract_Cases): Add a guard against malformed contract cases. + * sem_ch13.adb (Analyze_Aspect_Specifications): Call + Decorate_Delayed_Aspect_And_Pragma to decorate aspects + Contract_Cases, Depends and Global. Reimplement the analysis of + aspect Contract_Cases. + (Decorate_Delayed_Aspect_And_Pragma): New routine. + * sem_prag.adb (Analyze_Contract_Cases_In_Decl_Part): New routine. + (Analyze_CTC_In_Decl_Part): Removed. + (Analyze_Pragma): Reimplement the analysis of pragma Contract_Cases. + (Analyze_Test_Case_In_Decl_Part): New routine. + (Find_Related_Subprogram): New routine. + (Requires_Profile_Installation): Add new formal Prag. Update + the logic to take into account the origin of the pragma. + * sem_prag.ads (Analyze_Contract_Cases_In_Decl_Part): New routine. + (Analyze_CTC_In_Decl_Part): Removed. + (Analyze_Test_Case_In_Decl_Part): New routine. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb (Process_Convention): Move Stdcall tests to + Set_Convention_From_Pragma so that they are applied to each + entry of a homonym set. + (Process_Convention): Don't try to set convention if already set. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * gnatbind.adb: Minor reformatting. + +2013-04-24 Vincent Celier <celier@adacore.com> + + * clean.adb (Gnatclean): Add the default project search + directories in the project search path after scanning the + switches on the command line. + (Initialize): Do not put the default project search directories in the + project search path. + * gnatcmd.adb (GNATcmd): Add the default project search + directories in the project search path after scanning the switches + on the command line. + * make.adb (Initialize): Add the default project search + directories in the project search path after scanning the switches + on the command line. + +2013-04-24 Yannick Moy <moy@adacore.com> + + * restrict.ads (Restriction_Warnings): Initialize with all False value. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * checks.ads, checks.adb (Predicate_Checks_Suppressed): New function. + * exp_util.ads, exp_util.adb (Make_Predicate_Check): Check setting of + Predicate_Check. + * snames.ads-tmpl (Name_Predicate_Check): New check name. + * types.ads (Predicate_Check): New definition. + * gnat_rm.texi: Add documentation for Predicate_Check. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * exp_ch8.adb (Expand_N_Subprogram_Renaming_Declaration): If this + is a renaming of predefined equality for an untagged record, + add generated body to the freeze actions for the subprogram, to + prevent freezing issues when the record has incomplete components. + * exp_ch4.adb (Expand_Composite_Equality): If the type is a type + without completion, return a predefined comparison instead of + just False. This may happen when building the expression for + record equality, when some component has a type whose completion + has not been seen yet. The operation will be analyzed an expanded + after the type has been frozen, at which point all component + types will have been completed, or an error reported. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Do not delay + analysis of a Convention aspect. + +2013-04-24 Eric Botcazou <ebotcazou@adacore.com> + + * fe.h (Machine_Overflows_On_Target): New macro and declaration. + (Signed_Zeros_On_Target): Likewise. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb: Add with and use clause for Sem_Prag. + (Freeze_Subprogram): Analyze all delayed aspects for a null + procedure so that they are available when analyzing the + internally-generated _Postconditions routine. + * exp_ch13.adb: Remove with and use clause for Sem_Prag. + (Expand_N_Freeze_Entity): Move the code that analyzes delayed + aspects of null procedures to exp_ch6.Freeze_Subprogram. + * sem_prag.adb (Analyze_Abstract_State): Update the check on + volatile requirements. + +2013-04-24 Bob Duff <duff@adacore.com> + + * ali-util.ads (Source_Record): New component Stamp_File + to record from whence the Stamp came. + * ali-util.adb (Set_Source_Table): Set Stamp_File component. + * bcheck.adb (Check_Consistency): Print additional information in + Verbose_Mode. + * gnatbind.adb (Gnatbind): Print additional information in + Verbose_Mode. + +2013-04-24 Robert Dewar <dewar@adacore.com> + + * exp_ch13.adb, sem_prag.adb: Update comments. + * sem_ch3.adb, exp_ch9.adb, g-socket.adb, sem_ch13.adb: Minor + reformatting. + +2013-04-24 Doug Rupp <rupp@adacore.com> + + * vms_data.ads (/{NO}INHIBIT-EXEC): Document new default behavior. + +2013-04-24 Yannick Moy <moy@adacore.com> + + * sinfo.ads: Minor correction of typo. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb: Create packed array only when expander is + active. + +2013-04-24 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Depends_In_Decl_Part): Install the formals only + when the context warrants it. + (Analyze_Global_In_Decl_List): Install the formals only when + the context warrants it. + (Requires_Profile_Installation): New routine. + +2013-04-24 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Expand_N_Simple_Return_Statement): When the return + type is a discriminated private type that does not require use + of the secondary stack, a constrained subtype of the underlying + type is created to convey the proper object size to the backend. + If the return type is originally a private type, the return + expression is wrapped in an unchecked_conversion. If the return + expression is used subsequently in a call to the postcondition + function, this conversion must be undone to prevent a spurious + error on the analysis of that call. + +2013-04-23 Kai Tietz <ktietz@redhat.com> + + PR target/55445 + * raise-gcc.c (__SEH__): Additional check that SjLj isn't active. + +2013-04-23 Eric Botcazou <ebotcazou@adacore.com> + Pascal Obry <obry@adacore.com> + + * gcc-interface/Makefile.in (targ): Fix target name check. + (../../gnatmake$(exeext)): Add '+' for LTO. + (../../gnatlink$(exeext)): Likewise. + +2013-04-23 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch9.adb (Build_PPC_Wrapper): Correct the traversal of + pre- and post-conditions. + (Expand_N_Task_Type_Declaration): + Use the correct attribute to check for pre- and post-conditions. + * exp_ch13.adb (Expand_N_Freeze_Entity): Correct the traversal of + pre- and post-conditions. Analyze delayed classification items. + * freeze.adb (Freeze_Entity): Use the correct attribute to + check for pre- and post- conditions. + * sem_ch3.adb (Analyze_Declarations): Correct the traversal + of pre- and post-conditions as well as contract- and + test-cases. Analyze delayed pragmas Depends and Global. + * sem_ch6.adb (Check_Subprogram_Contract): Use the correct + attribute to check for pre- and post-conditions, as well as + contract-cases and test-cases. (List_Inherited_Pre_Post_Aspects): + Correct the traversal of pre- and post- conditions. + (Process_Contract_Cases): Update the comment on usage. Correct + the traversal of contract-cases. + (Process_Post_Conditions): Update the comment on usage. Correct the + traversal of pre- and post-conditions. + (Process_PPCs): Correct the traversal of pre- and post-conditions. + (Spec_Postconditions): Use the correct + attribute to check for pre- and post- conditions, as well as + contract-cases and test-cases. + * sem_ch13.adb (Analyze_Aspect_Specifications): Reimplement the + actions related to aspects Depends and Global. Code refactoring + for pre- and post-conditions. + (Insert_Delayed_Pragma): New routine. + * sem_prag.adb (Add_Item): New routine. + (Analyze_Depends_In_Decl_Part): New routine. + (Analyze_Global_In_Decl_Part): New routine. + (Analyze_Pragma): Reimplement the actions related to aspects Depends and + Global. Verify that a body acts as a spec for pragma Contract_Cases. + (Chain_PPC): Use Add_Contract_Item to chain a pragma. + (Chain_CTC): Correct the traversal of contract- + and test-cases. Use Add_Contract_Item to chain a pragma. + (Chain_Contract_Cases): Correct the traversal of contract- + and test-cases. Use Add_Contract_Item to chain a pragma. + (Check_Precondition_Postcondition): Update the comment on usage. + (Check_Test_Case): Update the comment on usage. + * sem_prag.ads (Analyze_Depends_In_Decl_Part): New routine. + (Analyze_Global_In_Decl_Part): New routine. + * sem_util.ads, sem_util.adb (Add_Contract_Item): New routine. + * sinfo.adb (Classifications): New routine. + (Contract_Test_Cases): New routine. + (Pre_Post_Conditions): New routine. + (Set_Classifications): New routine. + (Set_Contract_Test_Cases): New routine. + (Set_Pre_Post_Conditions): New routine. + (Set_Spec_CTC_List): Removed. + (Set_Spec_PPC_List): Removed. + (Spec_CTC_List): Removed. + (Spec_PPC_List): Removed. + * sinfo.ads: Update the structure of N_Contruct along with all + related comments. + (Classifications): New routine and pragma Inline. + (Contract_Test_Cases): New routine and pragma Inline. + (Pre_Post_Conditions): New routine and pragma Inline. + (Set_Classifications): New routine and pragma Inline. + (Set_Contract_Test_Cases): New routine and pragma Inline. + (Set_Pre_Post_Conditions): New routine and pragma Inline. + (Set_Spec_CTC_List): Removed. + (Set_Spec_PPC_List): Removed. + (Spec_CTC_List): Removed. + (Spec_PPC_List): Removed. + +2013-04-23 Doug Rupp <rupp@adacore.com> + + * init.c (GNAT$STOP) [VMS]: Bump sigargs[0] count by 2 + to account for LIB$STOP not having the chance to add the PC and + PSL fields. + +2013-04-23 Robert Dewar <dewar@adacore.com> + + * sem_ch13.adb: Minor code reorganization (remove some redundant + assignments). + * sem_ch3.adb, sem_prag.adb: Minor reformatting. + +2013-04-23 Yannick Moy <moy@adacore.com> + + * einfo.ads: Minor typo fix. + * sem_ch13.adb (Build_Predicate_Functions): Reject cases where + Static_Predicate is applied to a non-scalar or non-static type. + * sem_prag.adb: Minor typo fix. + +2013-04-23 Doug Rupp <rupp@adacore.com> + + * init.c (GNAT$STOP) [VMS]: New function. + +2013-04-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb: Add exp_pakd to context. + (Constrain_Component_Type): If the component of the parent is + packed, and the record subtype being built is already frozen, + as is the case for an itype, the component type itself will not + be frozen, and the packed array type for it must be constructed + explicitly. + +2013-04-23 Thomas Quinot <quinot@adacore.com> + + * g-socket.adb, g-socket.ads (Set_Close_On_Exec): New subprogram. + +2013-04-23 Yannick Moy <moy@adacore.com> + + * err_vars.ads (Error_Msg_Qual_Level): Set variable to zero + at declaration. + * opt.ads (Multiple_Unit_Index): Set variable to zero at declaration. + * sem_util.adb (NCT_Table_Entries): Set variable to zero at declaration. + * set_targ.ads (Num_FPT_Modes): Set variable to zero at declaration. + * stylesw.adb (Save_Style_Check_Options): Protect testing the + value of Style_Check_Comments_Spacing by a previous test that + Style_Check_Comments is True. + +2013-04-23 Thomas Quinot <quinot@adacore.com> + + * sem_prag.adb, sem_prag.ads (Effective_Name): Rename to + Original_Name, and move declaration to package body as this + subprogram is not used from outside. Also clarify documentation. + +2013-04-23 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Expand_N_Subprogram_Body): When compiling with + initialize_scalars, disable predicate checks on the generated + assignment to an out scalar parameter. + +2013-04-23 Gary Dismukes <dismukes@adacore.com> + + * sem_ch4.adb (Analyze_Allocator): Remove error + check for "constrained in partial view" constraints entirely. + +2013-04-23 Robert Dewar <dewar@adacore.com> + + * einfo.ads, sem_prag.ads: Minor reformatting. + * errout.ads: Comment update. + +2013-04-23 Yannick Moy <moy@adacore.com> + + * exp_ch5.adb: Minor typo. + +2013-04-23 Thomas Quinot <quinot@adacore.com> + + * gnat_ugn.texi: Fix typo. + +2013-04-23 Ed Schonberg <schonberg@adacore.com> + + * einfo.ads: Minor documentation clarification. + +2013-04-23 Bob Duff <duff@adacore.com> + + * types.ads: Fix incorrect comment. + +2013-04-23 Ed Schonberg <schonberg@adacore.com> + + * sem_aux.adb sem_aux.ads (Effectively_has_Constrained_Partial_View): + Rename subprogram as Object_Type_Has_Constrained_Partial_View, better + description of purpose. + * checks.adb (Apply_Discriminant_Check): Use above renaming. + * sem_ch4.adb (Analyze_Allocator): Check Has_Constrained_Partial_View + of the base type, rather than using the Object_Type predicate. + * sem_attr.adb (Analyze_Attribute, case 'Access): Use above renaming. + * sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): ditto. + * exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained): Ditto. + * exp_ch4.adb (Expand_N_Allocator): Ditto. + +2013-04-23 Robert Dewar <dewar@adacore.com> + + * exp_prag.adb (Expand_Pragma_Check): Check for Assert rather + than Assertion. + * sem_prag.adb (Is_Valid_Assertion_Kind): Moved to spec + (Effective_Name): New function (Analyze_Pragma, case Check): + Disallow [Statement_]Assertions (Check_Kind): Implement + Statement_Assertions (Check_Applicable_Policy): Use Effective_Name + (Is_Valid_Assertion_Kind): Allow Statement_Assertions. + * sem_prag.ads (Is_Valid_Assertion_Kind): Moved here from body + (Effective_Name): New function. + * sem_res.adb: Minor reformatting. + * snames.ads-tmpl (Name_Statement_Assertions): New entry. + * gnat_rm.texi: Add documentation of new assertion kind + Statement_Assertions. + +2013-04-23 Robert Dewar <dewar@adacore.com> + + * sinfo.ads, einfo.adb, sem_res.adb, exp_ch6.adb, aspects.adb: Minor + reformatting and code clean up. + +2013-04-23 Vincent Celier <celier@adacore.com> + + * prj-part.ads, prj-conf.ads: Minor comment updates. + +2013-04-23 Ed Schonberg <schonberg@adacore.com> + + * einfo.adb (Predicate_Function): For a private type, retrieve + predicate function from full view. + * aspects.adb (Find_Aspect): Ditto. + * exp_ch6.adb (Expand_Actuals): If the formal is class-wide and + the actual is a definite type, apply predicate check after call. + * sem_res.adb: Do not apply a predicate check before the call to + a generated Init_Proc. + +2013-04-23 Robert Dewar <dewar@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Significant + rewrite to make sure Is_Ignore is properly captured when aspect + is declared. + * sem_ch6.adb: Minor reformatting. + * sem_prag.adb (Analyze_Pragma): Do not test policy at time of + pragma for the case of a pragma coming from an aspect (already + tested when we analyzed the aspect). + +2013-04-23 Vincent Celier <celier@adacore.com> + + * prj-conf.adb (Parse_Project_And_Apply_Config): New + Boolean parameter Implicit_Project, defaulted to False. Call + Prj.Part.Parse with Implicit_Project. + * prj-conf.ads (Parse_Project_And_Apply_Config): New Boolean + parameter Implicit_Project, defaulted to False. + * prj-part.adb (Parse_Single_Project): New Boolean parameter + Implicit_Project, defaulted to False. When Implicit_Project is + True, change the Directory of the project node to the Current_Dir. + * prj-part.ads (Parse): New Boolean parameter, defaulted to False + +2013-04-23 Robert Dewar <dewar@adacore.com> + + * exp_util.adb: Minor reformatting. + +2013-04-23 Robert Dewar <dewar@adacore.com> + + * xoscons.adb: Minor reformatting. + +2013-04-23 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Check_Mode): Ensure that a + self-referential output appears in both input and output lists of + the subprogram as categorized by aspect Global. + (Check_Usage): Rename formal parameters to better illustrate their + function. Update all uses of the said formals. + +2013-04-23 Thomas Quinot <quinot@adacore.com> + + * exp_util.adb, exp_util.ads (Fully_Qualified_Name_String): New + parameter Append_NUL to make NUL-termination optional. + * exp_dist.adb: Consistently use the above throughout instead of + Get_Library_Unit_Name_String. + +2013-04-23 Robert Dewar <dewar@adacore.com> + + * sem_util.adb, sem_res.adb, prj-tree.adb, prj-tree.ads: Minor + reformatting. + +2013-04-23 Pascal Obry <obry@adacore.com> + + * xoscons.adb: Remove unused use clause, minor code clean-up. + +2013-04-23 Ed Schonberg <schonberg@adacore.com> + + * sem_util.ads, sem_util.adb: Code cleanup for Is_Expression_Function + (can apply to any scope entity). + * sem_res.adb (Resolve_Call): If the call is within another + expression function it does not constitute a freeze point. + +2013-04-23 Yannick Moy <moy@adacore.com> + + * exp_ch6.adb (Expand_Actuals): Test that Subp + is overloadable before testing if it's an inherited operation. + +2013-04-23 Robert Dewar <dewar@adacore.com> + + * a-envvar.adb, a-envvar.ads, exp_util.adb, sem_ch12.adb: Minor + reformatting. + +2013-04-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declarations): Undo previous patch. + * exp_util.adb (Expand_Subtype_From_Expr): If the expression + is a source entity and the declaration is for an aliased + unconstrained array, create a new subtype so that the flag + Is_Constr_Subt_For_UN_Aliased does not pollute other entities. + +2013-04-23 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb: Move tables Base_Aspect and Inherited_Aspect + from the spec to the body. + (Find_Aspect): Update the call to Get_Aspect_Id. + (Get_Aspect_Id): New version that takes an aspect specification. + * aspects.ads: Reorganize all aspect related tables. + (Get_Aspect_Id): New version that takes an aspect specification. + * par_sco.adb (Traverse_Aspects): Update the call to Get_Aspect_Id. + * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Update + the call to Get_Aspect_Id. + * sem_ch13.adb (Analyze_Aspect_At_Freeze_Point): Update the + call to Get_Aspect_Id. (Analyze_Aspect_Specifications): Update + the call to Get_Aspect_Id. Update the call to Impl_Defined_Aspect. + +2013-04-23 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb (Fix_Error): Rewrite to do more accurate job + of getting proper name in the case where pragma comes from + aspect. + * sem_ch3.adb, sinfo.ads, par-ch6.adb, exp_ch6.adb: Minor reformatting. + +2013-04-23 Yannick Moy <moy@adacore.com> + + * sem_ch6.adb (Process_PPCs): Do not filter postconditions based on + applicable policy. + +2013-04-23 Thomas Quinot <quinot@adacore.com> + + * par_sco.adb (Traverse_Aux_Decls): Minor code reorganization. + +2013-04-23 Doug Rupp <rupp@adacore.com> + + * init.c: Move facility macros outside IN_RTS. + +2013-04-23 Thomas Quinot <quinot@adacore.com> + + * freeze.adb (Freeze_Entity): For the case of a bit-packed + array time that is known at compile time to have more that + Integer'Last+1 elements, issue an error, since such arrays are + not supported. + +2013-04-23 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Dependency_Clause): Update all calls to + Analyze_Input_Output. + (Analyze_Input_List): Update all calls to Analyze_Input_Output. + (Analyze_Input_Output): Add formal parameter Self_Ref along with + comment on its usage. Update all calls to Analyze_Input_Output. + (Analyze_Pragma): Add new local variable Self_Ref to capture + the presence of a self-referential dependency clause. Update + all calls to Analyze_Input_Output. + (Check_Mode): Add formal parameter Self_Ref along with comment on its + usage. Verify the legality of a self-referential output. + +2013-04-23 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb: Add predicate checks on by-copy parameter. + +2013-04-23 Vincent Celier <celier@adacore.com> + + * a-envvar.adb, a-envvar.ads (Value): New. + +2013-04-22 Yannick Moy <moy@adacore.com> + + * exp_prag.adb (Expand_Pragma_Loop_Variant): Rewrite pragma as + null statement if ignored. + * sem_ch6.adb (Expand_Contract_Cases): Do nothing if pragma is ignored. + * sem_prag.adb (Analyze_Pragma): Keep analyzing ignored pragmas. + +2013-04-22 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Contract_Case): New routine. + (Analyze_Pragma): Aspect/pragma Contract_Cases can + now be associated with a library level subprogram. + Add circuitry to detect illegal uses of aspect/pragma Contract_Cases + in a subprogram body. + (Chain_Contract_Cases): Rename formal parameter Subp_Decl to + Subp_Id. Remove local constant Subp. The entity of the subprogram + is now obtained via the formal paramter. + +2013-04-22 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Do not set + Is_Constr_Subt_For_Unc_Aliased on the subtype of the expression, + if the expression is a source entity. + +2013-04-22 Yannick Moy <moy@adacore.com> + + * exp_prag.adb, sinfo.ads, sem_prag.ads: Minor correction of typos in + comments. + * sem_ch6.adb (Expand_Contract_Cases): Add location to message. + +2013-04-22 Thomas Quinot <quinot@adacore.com> + + * sem_prag.adb (Fix_Error): For a pragma rewritten from another + pragma, fix up error message to include original pragma name. + * par_sco.adb: Minor reformatting. + +2013-04-22 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb, sem_util.adb, sem_util.ads, sem_res.adb, exp_ch6.adb, + sem_ch6.adb, opt.ads: Minor reformatting. + +2013-04-22 Pascal Obry <obry@adacore.com> + + * gnat_ugn.texi, prj-nmsc.adb, projects.texi: Add check for + Library_Standalone and Library_Kind. + +2013-04-22 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Expand_Actuals): If the call is to an + inherited operation and the actual is a by-reference type with + predicates, add predicate call to post-call actions. + * sem_util.adb (Is_Inherited_Operation_For_Type): Fix coding + error: a type declaration has a defining identifier, not an Etype. + * sem_res.adb: Restore code removed because of above error. + +2013-04-22 Doug Rupp <rupp@adacore.com> + + * init.c (__gnat_handle_vms_condition): Also match C$_SIGINT. + +2013-04-22 Yannick Moy <moy@adacore.com> + + * gnat_rm.texi, exp_util.adb, sem_prag.adb, sem_prag.ads, par-ch2.adb, + opt.ads, sem_ch13.adb: Minor correction of typos in comments/doc. + +2013-04-22 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Check_Library_Attributes): Set Library_Dir to + No_Path_Information only when Directories_Must_Exist_In_Projects + is False. + (Get_Directories): Set Object_Directory + or Exec_Directory to No_Path_Information only when + Directories_Must_Exist_In_Projects is False. + +2013-04-22 Yannick Moy <moy@adacore.com> + + * par-prag.adb, sem_attr.adb, sem_ch6.adb, sem_prag.adb, sem_warn.adb, + snames.ads-tmpl, sinfo.ads, sem_util.ads: Remove all references to + Pragma_Contract_Case and Name_Contract_Case. + +2013-04-22 Yannick Moy <moy@adacore.com> + + * aspects.ads, aspects.adb, sem_ch13.adb: Removal of references to + Contract_Case. + * gnat_ugn.texi, gnat_rm.texi Description of Contract_Case replaced by + description of Contract_Cases. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * makeutl.adb, prj-nmsc.adb: Minor reformatting. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * exp_util.adb (Make_Invariant_Call): Use Check_Kind instead + of Check_Enabled. + * gnat_rm.texi (Check_Policy): Update documentation for new + Check_Policy syntax. + * sem_prag.adb (Check_Kind): Replaces Check_Enabled + (Analyze_Pragma, case Check_Policy): Rework to accomodate new + syntax (like Assertion_Policy). + * sem_prag.ads (Check_Kind): Replaces Check_Enabled. + +2013-04-12 Doug Rupp <rupp@adacore.com> + + * init.c (SS$_CONTROLC, SS$_CONTINUE) [VMS]: New macros. + (__gnat_handle_vms_condition) [VMS]: Dispatch on the Crtl/C user + handler if installed. + * ctrl_c.c (__gnat_install_int_handler) + [VMS]: Install a dummy sigaction handler to trigger the real + user handler dispatch in init.c/__gnat_handle_vms_condition. + (__gnat_uninstall_int_handler) [VMS]: Likewise. + +2013-04-12 Vincent Celier <celier@adacore.com> + + * clean.adb (Parse_Cmd_Line): Set Directories_Must_Exist_In_Projects + to False if switch is specified. + * makeutl.adb (Initialize_Source_Record): Do not look for the + object file if there is no object directory. + * opt.ads (Directories_Must_Exist_In_Projects): New Boolean + variable, defaulted to True. + * prj-nmsc.adb (Check_Library_Attributes): Do not fail if library + directory does not exist when Directories_Must_Exist_In_Projects is + False. + (Get_Directories): Do not fail when the object or the exec directory + do not exist when Directories_Must_Exist_In_Projects is False. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * namet.adb, namet.ads: Minor addition (7 arg version of Nam_In). + * exp_prag.adb, sem_ch3.adb, sem_intr.adb, sem_type.adb, exp_util.adb, + sem_aux.adb, exp_ch9.adb, sem_ch7.adb, sem_ch10.adb, sem_prag.adb, + par-ch2.adb, tbuild.adb, rtsfind.adb, freeze.adb, sem_util.adb, + sem_res.adb, sem_attr.adb, exp_ch2.adb, prj-makr.adb, sem_elab.adb, + exp_ch4.adb, sem_ch4.adb, sem_mech.adb, sem_ch6.adb, par-prag.adb, + prj-nmsc.adb, exp_disp.adb, sem_ch8.adb, sem_warn.adb, par-util.adb, + sem_eval.adb, exp_intr.adb, sem_ch13.adb, exp_cg.adb, lib-xref.adb, + sem_disp.adb, exp_ch3.adb: Minor code reorganization (use Nam_In). + +2013-04-12 Doug Rupp <rupp@adacore.com> + + * init.c: Don't clobber condition code on VMS. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * exp_aggr.adb: Minor reformatting. + * namet.ads, namet.adb (Nam_In): New functions. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * einfo.adb (Has_Dynamic_Predicate_Aspect): New flag. + (Has_Static_Predicate_Aspect): New flag. + * einfo.ads (Has_Dynamic_Predicate_Aspect): New flag. + (Has_Static_Predicate_Aspect): New flag. + * exp_ch9.adb: Minor reformatting. + * exp_util.adb (Make_Invariant_Call): Check_Enabled now handles + synonyms. + * gnat1drv.adb: Remove setting of Debug_Pragmas_Enabled, + since this switch is gone and control of Debug is done with + Assertions_Enabled. + * gnat_rm.texi: Update documentation for Assertion_Policy and + Check_Policy pragmas. + * opt.adb (Debug_Pragmas_Disabled[_Config]): Removed + (Debug_Pragmas_Enabled[_Config]): Removed Since debug now + controlled by Assertion_Enabled. + * opt.ads (Debug_Pragmas_Disabled[_Config]): Removed + (Debug_Pragmas_Enabled[_Config]): Removed Since debug now + controlled by Assertion_Enabled. + * par-ch2.adb (Scan_Pragma_Argument_Association): Allow new + 'Class forms. + * sem_attr.adb: Minor reformatting. + * sem_ch13.adb (Analyze_Aspect_Specification): Disable aspect + if DISABLE policy applies. + * sem_ch6.adb (Grab_PPC): Check original name of aspect for + aspect from pragma (Process_PPCs): Properly check assertion policy. + * sem_prag.adb (Check_Enabled): Rewritten for new Assertion_Policy + (Check_Appicable_Policy): New procedure. + (Is_Valid_Assertion_Kind): New function. + (Rewrite_Assertion_Kind): New procedure. + (Analyze_Pragma): Handle case of disabled assertion pragma. + (Analyze_Pragma, case Assertion_Policy): Rewritten for Ada 2012. + (Analyze_Pragma, case Check): Deal with 'Class possibilities. + (Analyze_Pragma, case Check_Policy): Deal with 'Class possibilities. + (Analyze_Pragma, case Contract_Class): New handling of ignored pragma. + (Analyze_Pragma, case Debug): New control with Assertion_Policy. + (Analyze_Pragma, case Debug_Policy): Now consistent with + Assertion_Policy. + (Analyze_Pragma, case Loop_Invariant): New handling of ignored + pragma. + (Analyze_Pragma, case Loop_Variant): New handling of ignored pragma. + (Analyze_Pragma, case Precondition): Use proper name for Check pragma. + (Analyze_Pragma, case Check_Enabled): Rewritten for new policy stuff. + * sem_prag.ads (Check_Enabled): Rewritten for new + Assertion_Policy stuff. + (Check_Appicable_Policy): New procedure. + * sinfo.adb (Is_Disabled): New flag. + (Is_Ignored): New flag. + * sinfo.ads (Is_Disabled): New flag. + (Is_Ignored): New flag. + (N_Pragma_Argument_Association): New 'Class forms. + * snames.ads-tmpl: New names Name_uPre, Name_uPost, + Name_uType_Invariant, Name_uInvariant. + * switch-c.adb: Remove setting of Debug_Pragmas_Enabled for -gnata. + * tree_io.ads (ASIS_Version_Number): Updated (remove + read write of obsolete flags Debug_Pragmas_Disabled and + Debug_Pragmas_Enabled. + +2013-04-12 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Get_Explicit_Discriminant_Value): Subsidiary + of Build_Record_Aggr_Code, used to retrieve explicit values + for inherited discriminants in an extension aggregate, when the + ancestor type is unconstrained. + +2013-04-12 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Check_Stream_Attribute): If restriction + No_Default_Stream_Attributes is active, it is illegal to use a + predefined elementary type stream attribute either by itself, + or more importantly as part of the attribute subprogram for a + composite type. However, if the broader restriction No_Streams + is active, then stream operations are not generated, and there + is no error. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * gnatbind.adb: Minor reformatting. + +2013-04-12 Bob Duff <duff@adacore.com> + + * sem_attr.adb (Analyze_Access_Attribute): Treat P'Access like a + call only in the static elaboration model. + +2013-04-12 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Input_List): Detect an illegal dependency + clause where both input and output lists are null. + (Analyze_Pragma): Update the grammar of pragma Depends. + +2013-04-12 Vincent Celier <celier@adacore.com> + + * gnatbind.adb (No_Restriction_List): Exclude restrictions that + take a parameter value, not a count. + * prj.ads, prj.adb (Remove_All_Restricted_Languages): New procedure. + * projects.texi: Complete documentation of attribute Roots. + +2013-04-12 Thomas Quinot <quinot@adacore.com> + + * exp_ch3.adb, exp_util.ads, checks.adb, freeze.adb, sem_attr.adb, + sem_ch3.adb: Minor reformatting. + * exp_ch4.adb (Size_In_Storage_Elements): Minor documentation + improvement: note that the computation is pessimistic for bit + packed arrays. + * gnat_rm.texi (Range_Length): Fix minor error in description + of attribute. + +2013-04-12 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb (Find_Aspect): New routine. + (Find_Value_Of_Aspect): New routine. + (Has_Aspect): Reimplemented. + * aspects.ads (Find_Aspect): New routine. + (Find_Value_Of_Aspect): New routine, previously known as Find_Aspect. + * exp_ch5.adb (Expand_Iterator_Loop): Update the call to Find_Aspect. + * exp_util.adb (Is_Iterated_Container): Update the call to Find_Aspect. + * sem_ch4.adb (Try_Container_Indexing): Update calls to Find_Aspect. + * sem_ch5.adb (Analyze_Iterator_Specification): Update + the call to Find_Aspect. Use function Has_Aspect for better + readability. + (Preanalyze_Range): Use function Has_Aspect for better readability. + * sem_ch13.adb (Check_One_Function): Update the call to Find_Aspect. + * sem_prag.adb (Analyze_Pragma): There is no longer need to + look at the parent to extract the corresponding pragma for + aspect Global. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * checks.adb, sem_elab.adb, repinfo.adb, sem_ch4.adb, restrict.adb, + restrict.ads: Minor reformatting. + +2013-04-12 Ed Schonberg <schonberg@adacore.com> + + * lib-xref.adb: Retrieve original name of classwide type if any. + +2013-04-12 Thomas Quinot <quinot@adacore.com> + + * exp_ch11.ads: Minor reformatting. + +2013-04-12 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.adb: Alphabetize subprogram bodies in this unit. Add + an entry for Aspect_Ghost in the table of canonical aspects. + (Has_Aspect): New routine. + * aspects.ads: Add Aspect_Ghost to all relevant + tables. Alphabetize subprograms in this unit. + (Has_Aspect): New routine. + * einfo.adb: Add with and use clauses for Aspects. + (Is_Ghost_Function): New routine. + * einfo.ads: Add new synthesized attribute Is_Ghost_Function and + update the structure of the related nodes. + (Is_Ghost_Function): New routine. + * exp_ch4.adb (Find_Enclosing_Context): Use routine + Is_Body_Or_Package_Declaration to terminate a search. + (Is_Body_Or_Unit): Removed. + * exp_util.adb (Within_Case_Or_If_Expression): Use routine + Is_Body_Or_Package_Declaration to terminate a search. + * par-prag.adb: Add pragma Ghost to the list of pragmas that do + not need special processing by the parser. + * sem_attr.adb (Analyze_Access_Attribute): Detect an + illegal use of 'Access where the prefix is a ghost function. + (Analyze_Attribute): Use routine Is_Body_Or_Package_Declaration + to terminate a search. (Check_References_In_Prefix): Use routine + Is_Body_Or_Package_Declaration to terminate a search. + * sem_ch4.adb (Analyze_Call): Mark a function when it appears + inside an assertion expression. Verify the legality of a call + to a ghost function. + (Check_Ghost_Function_Call): New routine. + * sem_ch6.adb (Analyze_Function_Call): Code reformatting. Move + the setting of attribute In_Assertion_Expression to Analyze_Call. + (Check_Overriding_Indicator): Detect an illegal attempt to + override a function with a ghost function. + * sem_ch12.adb (Preanalyze_Actuals): Detect an illegal use of + a ghost function as a generic actual. + * sem_elab.adb (Check_Internal_Call_Continue): Update the call + to In_Assertion. + * sem_prag.adb: Add an entry for pragma Ghost in the table + of significant arguments. + (Analyze_Pragma): Do not analyze + an "others" case guard. Add processing for pragma Ghost. Use + Preanalyze_Assert_Expression when analyzing the expression of + pragmas Loop_Invariant and Loop_Variant. + * sem_util.adb (Get_Subprogram_Entity): Reimplemented. + (Is_Body_Or_Package_Declaration): New routine. + * sem_util.ads: Alphabetize subprotrams in this unit. + (Is_Body_Or_Package_Declaration): New routine. + * sinfo.adb (In_Assertion): Rename to In_Assertion_Expression. + (Set_In_Assertion): Rename to Set_In_Assertion_Expression. + * sinfo.ads: Rename flag In_Assertion to In_Assertion_Expression + to better reflect its use. Update all places that mention the flag. + (In_Assertion): Rename to In_Assertion_Expression. Update + related pragma Inline. (Set_In_Assertion): Rename to + Set_In_Assertion_Expression. Update related pragma Inline. + * snames.ads-tmpl: Add new predefined name Ghost. Add new pragma + id Pragma_Ghost. + +2013-04-12 Arnaud Charlet <charlet@adacore.com> + + * sem_prag.adb (Set_Imported): Do not generate error for multiple + Import in CodePeer mode. + * s-rident.ads: Fix minor typo. + +2013-04-12 Ed Schonberg <schonberg@adacore.com> + + * checks.adb (Insert_Valid_Check): Do not insert validity check + in the body of the generated predicate function, to prevent + infinite recursion. + +2013-04-12 Ed Schonberg <schonberg@adacore.com> + + * s-rident.ads: Add various missing Ada 2012 restrictions: + No_Access_Parameter_Allocators, No_Coextensions, + No_Use_Of_Attribute, No_Use_Of_Pragma. + * snames.ads-tmpl: Add corresponding names. + * restrict.ads restrict.adb: Subprograms and data structures to + handle aspects No_Use_Of_Attribute and No_Use_Of_Pragma. + * sem_ch4.adb: Correct name of restrictions is + No_Standard_Allocators_After_Elaboration. + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Check + violation of restriction No_Use_Of_Attribute. + * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings): + Set restrictions No_Use_Of_Pragma and No_Use_Of_Attribute. + (Analyze_Pragma): Check violation of restriction No_Use_Of_Pragma. + * sem_res.adb: Check restrictions No_Access_Parameter_Allocators + and No_Coextensions. + * bcheck.adb: Correct name of restrictions is + No_Standard_Allocators_After_Elaboration. + * gnatbind.adb: Correct name of restrictions is + No_Standard_Allocators_After_Elaboration. + +2013-04-12 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Pragma, (Check_Mode_Restriction_In_Function): + Correct error message format. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * sem_attr.adb: Minor reformatting. + +2013-04-12 Ed Schonberg <schonberg@adacore.com> + + * sem_elab.adb (Within_Elaborate_All): Do not examine a context + item that has not been analyzed, because the unit may have errors, + or the context item may come from a proper unit inserted at the + point of a stub and not analyzed yet. + +2013-04-12 Thomas Quinot <quinot@adacore.com> + + * gnat1drv.adb, repinfo.adb, repinfo.ads (Repinfo.List_Array_Info, + List_Record_Info): Also include scalar storage order information in + output. + +2013-04-12 Yannick Moy <moy@adacore.com> + + * sem_ch6.adb (Process_Contract_Cases): Update code to apply to + Contract_Cases instead of Contract_Case pragma. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * a-cfdlli.ads, g-socket.adb, s-fileio.adb: Minor reformatting. + +2013-04-12 Yannick Moy <moy@adacore.com> + + * sem_attr.adb (Analyze_Attribute): Update analyse of + Attribute_Old and Attribute_Result so they are allowed in the + right-hand-side of an association in a Contract_Cases pragma. + * sem_prag.adb (Analyze_CTC_In_Decl_Part): Add pre-analysis of + the expressions in a Contract_Cases pragma. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * sem.ads, opt.ads: Minor comment edits. + * sem_warn.adb, sem_ch6.adb: Minor reformatting. + +2013-04-12 Claire Dross <dross@adacore.com> + + * a-cfdlli.adb a-cfdlli.ads (List, Not_No_Element, Iterate, + Reverse_Iterate, Query_Element, Update_Element, Read, Write): Removed, + not suitable for formal analysis. + +2013-04-12 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Analyze_Abstract_State): Use Defining entity + to locate package entity, which may be a child unit. + +2013-04-12 Thomas Quinot <quinot@adacore.com> + + * g-socket.adb, g-socket.ads (Connect_Socket, version with timeout): If + the specified timeout is 0, do not attempt to determine whether the + connection succeeded. + +2013-04-12 Doug Rupp <rupp@adacore.com> + + * s-fileio.adb (Form_RMS Context_Key): Fix some thinkos. + +2013-04-12 Doug Rupp <rupp@adacore.com> + + * s-fileio.adb: Minor reformatting. + +2013-04-12 Ed Schonberg <schonberg@adacore.com> + + * sem_warn.adb (Check_Infinite_Loop_Warning): Do not warn if + the last statement in the analyzed loop is an unconditional + exit statement. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * opt.ads (Style_Check_Main): New switch. + * sem.adb (Semantics): Set Style_Check flag properly for new + unit to be analyzed. + * sem_ch10.adb (Analyze_With_Clause): Don't reset Style_Check, + the proper setting of this flag is now part of the Semantics + procedure. + * switch-c.adb (Scan_Front_End_Switches): Set Style_Check_Main + for -gnatg and -gnaty + +2013-04-12 Doug Rupp <rupp@adacore.com> + + * s-crtl.ads (fopen, freopen): Add vms_form parameter + * i-cstrea.ads (fopen, freopen): Likewise. + * adaint.h (__gnat_fopen, __gnat_freopen): Likewise. + * adaint.c (__gnat_fopen, __gnat_freopen): Likewise. + [VMS]: Split out RMS keys and call CRTL function appropriately. + * s-fileio.adb (Form_VMS_RMS_Keys, Form_RMS_Context_Key): New + subprograms. + (Open, Reset): Call Form_VMS_RMS_Keys. Call fopen,freopen with + vms_form + * gnat_rm.texi: Document implemented RMS keys. + +2013-04-12 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): + Insert the corresponding pragma for aspect Abstract_State at + the top of the visible declarations of the related package. + Previously this was only done when the package is a compilation + unit. + +2013-04-12 Arnaud Charlet <charlet@adacore.com> + + * gnat_ugn.texi: Further menu clean ups. + * sem_prag.adb, opt.ads: Minor reformatting. + * sem_util.ads: Minor comment fix. + +2013-04-12 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Aspect + Depends is now a delayed aspect. The delay is required + due to the interplay between aspects Depends and Global. + (Check_Aspect_At_Freeze_Point): Add an entry for aspect Depends. + * sem_prag.adb: Reformat various error messages. + (Add_Item): New subsidiary routine. + (Analyze_Pragma): Add new variables + Global_Seen, Result_Seen, Subp_Inputs and Subp_Outputs. The + analysis of pragma Depends now has the capability to check + the proper mode and usage of subprogram inputs and outputs. + (Appears_In): New routine. + (Check_Function_Return): New routine. + (Check_Mode): New routine. + (Check_Usage): New routine. + (Collect_Subprogram_Inputs_Outputs): New routine. + +2013-04-12 Bob Duff <duff@adacore.com> + + * par-ch7.adb (P_Package): Initialize Sloc in the newly-pushed scope + stack entry. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * switch-c.adb: Minor fix to wording of error message for + -gnatet/eT. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * impunit.adb: Add s-multip and s-mudido to list of impl defined + system units. + * gnat_rm.texi: Add documentation for + System.Multiprocessors[.Dispatching_Domains]. + +2013-04-12 Ben Brosgol <brosgol@adacore.com> + + * gnat_ugn.texi: Completion of menu cleanups. + +2013-04-12 Arnaud Charlet <charlet@adacore.com> + + * sem_prag.adb (Diagnose_Multiple_Pragmas): Relax the rules + in Relaxed_RM_Semantics. + +2013-04-12 Arnaud Charlet <charlet@adacore.com> + + * set_targ.adb (elab code): Add support for non gcc back-ends + where save_argv is null. + +2013-04-12 Robert Dewar <dewar@adacore.com> + + * gnat1drv.adb (Gnat1drv): Test Target_Dependent_Info_Write_Name. + * opt.ads (Target_Dependent_Info_Read): Add _Name, now an access + type (Target_Dependent_Info_Write): Add _Name, now an access type. + * set_targ.adb (Write_Target_Dependent_Values): Use name + from -gnatet switch stored in Target_Dependent_Info_Write_Name + (Read_Target_Dependent_Values): Use name from -gnateT switch + stored in Target_Dependent_Info_Read_Name. + * switch-c.adb: New form of -gnatet and -gnateT switches. + * usage.adb: New form of -gnatet and -gnateT switches with + file name. + +2013-04-11 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (elaborate_expression_1): Skip only constant + arithmetics when looking for a read-only variable in the expression. + +2013-04-11 Javier Miranda <miranda@adacore.com> + + * check.ads, exp_ch6.adb (Install_Null_Excluding_Check): No check in + interface thunks since it is performed at the caller side. + (Expand_Simple_Function_Return): No accessibility check needed in thunks + since the check is done by the target routine. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Analyze_Pragma, case Priority): pre-analyze + expression with type Any_Priority. + * exp_ch9.adb (Initialize_Protection): Check that the value + of the priority expression is within the bounds of the proper + priority type. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb, prj-env.adb: Minor reformatting. + +2013-04-11 Ben Brosgol <brosgol@adacore.com> + + * gnat_ugn.texi: Clean ups. + +2013-04-11 Yannick Moy <moy@adacore.com> + + * set_targ.adb: Minor comment update. + +2013-04-11 Pascal Obry <obry@adacore.com> + + * gnat_ugn.texi: Remove obsolete comment about DLL calling + convention. + +2013-04-11 Javier Miranda <miranda@adacore.com> + + * exp_ch6.adb (Expand_Call): For the call to the target primitive + of an interface thunks do not compute the extra actuals; just + propagate the extra actuals received by the thunk. + * exp_disp.adb (Expand_Interface_Thunk): Decorate new attribute + Thunk_Entity. + * sem_ch6.adb (Create_Extra_Formals): Do not generate extra + formals in interface thunks whose target primitive has no extra + formals. + +2013-04-11 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Detect + a renaming by looking at the Renamed_Object attribute. + (Is_Renaming): Removed. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * prj-env.adb (Initialize_Default_Project_Path): Take + into account a project path file, specified by environment + variable GPR_PROJECT_PATH_FILE, before taking into account + GPR_PROJECT_PATH. + * projects.texi: Add documentation for GPR_PROJECT_PATH_FILE + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * a-cdlili.adb, a-cdlili.ads, a-cihama.adb, a-cihama.ads, a-coinve.adb, + a-coinve.ads, a-ciorse.adb, a-ciorse.ads, a-coorma.adb, a-coorma.ads, + a-cfdlli.adb, a-cfdlli.ads, a-cborma.adb, a-cborma.ads, a-cidlli.adb, + a-cidlli.ads, a-ciormu.adb, a-ciormu.ads, a-cihase.adb, a-cihase.ads, + a-cohama.adb, a-cohama.ads, a-coorse.adb, a-coorse.ads, a-cbhama.adb, + a-cbhama.ads, a-cborse.adb, a-cborse.ads, a-ciorma.adb, a-cobove.adb, + a-ciorma.ads, a-cobove.ads, a-coormu.adb, a-coormu.ads, a-cohase.adb, + a-cohase.ads, a-cbdlli.adb, a-cbdlli.ads, a-cbhase.adb, a-cbhase.ads: + Move Iterator operations from body to private part of spec. + +2013-04-11 Eric Botcazou <ebotcazou@adacore.com> + + * ttypes.ads, get_targ.ads: More minor rewording of comments. + +2013-04-11 Johannes Kanig <kanig@adacore.com> + + * debug.adb: Document use of switch -gnatd.Z. + +2013-04-11 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Both pragma Depends and Global can now + support renamings of entire objects. Legal renamings are replaced by + the object they rename. + (Is_Renaming): New routine. + +2013-04-11 Yannick Moy <moy@adacore.com> + + * set_targ.adb, opt.ads: Minor changes in comments. + +2013-04-11 Ben Brosgol <brosgol@adacore.com> + + * gnat_ugn.texi: Minor clean ups. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * nlists.ads, nlists.adb, treepr.adb, treepr.ads: Move debugging + function p from Nlists to Treepr. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_disp.adb (Check_Dispatching_Context): If the context is + a contract for a null procedure defer error reporting until + postcondition body is created. + * exp_ch13.adb (Expand_N_Freeze_Entity): If the entity is a + null procedure, complete the analysis of its contracts so that + calls within classwide conditions are properly rewritten as + dispatching calls. + +2013-04-11 Thomas Quinot <quinot@adacore.com> + + * sem_ch10.adb, sem_ch12.adb: Minor reformatting. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * exp_attr.adb, sem_res.adb, sem_attr.adb: Minor reformatting. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * atree.adb, atree.ads (Node31): New function. + (Set_Node31): New procedure. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * errout.ads: Minor typo correction. + +2013-04-11 Javier Miranda <miranda@adacore.com> + + * einfo.ad[sb] (Thunk_Entity/Set_Thunk_Entity): New attribute. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * back_end.adb (Register_Back_End_Types): Moved to Get_Targ + * back_end.ads (C_String): Moved to Get_Targ + (Register_Type_Proc): Moved to Get_Targ (Register_Back_End_Types): + Moved to Get_Targ. + * cstand.adb (Register_Float_Type): New interface + (Create_Back_End_Float_Types): Use entries in FPT_Mode_Table. + * get_targ.adb (Register_Back_End_Types): Moved here from + Back_End. + * get_targ.ads (C_String): Moved here from Back_End + (Register_Type_Proc): Moved here from Back_End + (Register_Back_End_Types): here from Back_End. + * gnat1drv.adb (GGnat11drv): Add call to + Write_Target_Dependent_Values; + * lib-writ.ads, lib-writ.adb (Write_ALI): Remove section writing + obsolete target dependent info. + * opt.ads (Generate_Target_Dependent_Info): + Removed (Target_Dependent_Info_Read): New flag + (Target_Dependent_Info_Write): New flag + * output.adb: Minor comment change + * s-os_lib.ads: Minor reformatting + * set_targ.ads, set_targ.adb: Minor reformatting. + * switch-c.adb (Scan_Switches.First_Ptr): New variable + (Scan_Front_End_Switches): Check -gnatd.b, -gnateT come first + (Scan_Front_End_Switches): Handle -gnatet, -gnateT + * ttypes.ads: Remove documentation section on target dependent + info in ali file Remove four letter codes, no longer used Instead + of using Get_Targ.Get_xxx, we use Set_Targ.xxx + * usage.adb: Add usage lines for -gnatet/-gnateT + * gcc-interface/Make-lang.in: Update dependencies. + +2013-04-11 Thomas Quinot <quinot@adacore.com> + + * sem_ch4.adb: Update documentation. + * sinfo.ads (N_Expression_With_Actions): Ditto. + +2013-04-11 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): + Add a guard to prevent the double insertion of the same aspect + into a rep item list. This previously led to a circularity. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Eval_Attribute, case 'Access): Reject attribute + reference if the prefix is the dereference of an anonymous access + to subprogram type. + * exp_attr.adb (Expand_N_Attribute_Reference, Access_Cases): Handle + properly a reference to the current instance of a protected type + from within a protected subprogram. + * sem_res.adb (Find_Unique_Access_Type): Treat + Attribute_Access_Type like Allocator_Type when resolving an + equality operator. + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * xgnatugn.adb: Remove obsolete comments. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * back_end.ads, back_end.adb: Minor reformatting. + * set_targ.ads, set_targ.adb: New files. + +2013-04-11 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_case.adb (Check_Against_Predicate): New routine. + (Check_Choices): When the type covered by the list of choices + is a static subtype with a static predicate, check all choices + agains the predicate. + (Issue_Msg): All versions removed. + (Missing_Choice): New routines. + * sem_ch4.adb: Code and comment reformatting. + (Analyze_Case_Expression): Do not check the choices when the case + expression is being preanalyzed and the type of the expression + is a subtype with a static predicate. + (Has_Static_Predicate): New routine. + * sem_ch13.adb: Code and comment reformatting. (Build_Range): + Always build a range even if the low and hi bounds denote the + same value. This is needed by the machinery in Check_Choices. + (Build_Static_Predicate): Always build a range even if the low and + hi bounds denote the same value. This is needed by the machinery + in Check_Choices. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * einfo.ads, sem_util.adb, exp_ch6.adb, xgnatugn.adb: Minor + reformatting. + +2013-04-11 Doug Rupp <rupp@adacore.com> + + * gnatlink.adb: Fold program basename to lower case on VMS for + consistency. + +2013-04-11 Matthew Heaney <heaney@adacore.com> + + * a-rbtgbo.adb (Generic_Equal): Initialize Result variable before + entering loop. + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * xgnatugn.adb: Remove dead code (handling of @ifset/@ifclear). + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * gnat_ugn.texi: Remove some use of ifset in menus. Not strictly + needed, and seems to confuse some versions of makeinfo. + +2013-04-11 Javier Miranda <miranda@adacore.com> + + * einfo.adb (Is_Thunk): Remove assertion. + (Set_Is_Thunk): Add assertion. + * einfo.ads (Is_Thunk): Complete documentation. + * exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Code cleanup. + * exp_ch3.ad[sb] (Is_Variable_Size_Array): Moved to sem_util + (Is_Variable_Size_Record): Moved to sem_util + * exp_ch6.adb (Expand_Call): Code cleanup. + (Expand_N_Extended_Return_Statement): Code cleanup. + (Expand_Simple_Function_Return): Code cleanup. + * exp_disp.adb Remove dependency on exp_ch3 + (Expand_Interface_Thunk): Add minimum decoration needed to set + attribute Is_Thunk. + * sem_ch3.ad[sb] (Is_Constant_Bound): moved to sem_util + * sem_util.ad[sb] (Is_Constant_Bound): Moved from + sem_ch3 (Is_Variable_Size_Array): Moved from exp_ch3 + (Is_Variable_Size_Record): Moved from exp_ch3 + +2013-04-11 Javier Miranda <miranda@adacore.com> + + * exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Do + not add cleanup actions in thunks associated with interface types. + * exp_ch3.ad[sb] (Is_Variable_Size_Record): Move declaration to + the package spec. + * exp_ch4.adb (Tagged_Conversion): Update call to + Expand_Interface_Conversion since the parameter Is_Static is no + longer needed. + * exp_ch6.adb (Expand_N_Extended_Return_Statement): Adding + assertion to ensure that interface thunks are never handled by + this routine. + (Expand_N_Simple_Function_Return): Do not rewrite this statement + as an extended return statement in interface thunks, and do not + perform copy in the secondary stack if the return statement is + located in a thunk. + * exp_disp.adb (Expand_Dispatching_Call): No longer displace + the pointer to the returned object in functions returning interface + types. + (Expand_Interface_Thunk): For functions returning interface types + displace the pointer to the returned object. + (Expand_Interface_Conversion): Remove formal + Is_Static since this subprogram can now evaluate it locally. + * sem_ch3.adb (Add_Internal_Interface_Entities): For functions + propagate the type returned by the covered interface primitive to + the internal interface entity. Needed by the thunk to generate + the code which displaces "this" to reference the corresponding + secondary dispatch table. + * sem_disp.adb (Propagate_Tag): Update call to + Expand_Interface_Conversion since the parameter Is_Static is no + longer needed. + * sem_res.adb (Resolve_Type_Conversion): Update calls to + Expand_Interface_Conversion since the parameter Is_Static is no + longer needed plus code cleanup. + +2013-04-11 Eric Botcazou <ebotcazou@adacore.com> + + * init.c (RETURN_ADDR_OFFSET): Delete as unused. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * a-crbtgk.adb, a-ciorse.adb, a-crbtgo.adb, a-coorse.adb, a-rbtgbo.adb, + a-cborse.adb, a-rbtgso.adb, exp_ch3.adb: Minor reformatting. + +2013-04-11 Yannick Moy <moy@adacore.com> + + * exp_ch4.adb (Expand_N_Selected_Component): Do not expand + discriminant check for Unchecked_Union. + * sem_res.adb (Resolve_Selected_Component): Set flag + Do_Discriminant_Check even when expansion is not performed. + * sinfo.ads (Do_Discriminant_Check): Update documentation for the case + of Unchecked_Union. + +2013-04-11 Thomas Quinot <quinot@adacore.com> + + * sem_ch13.adb (Same_Representation): Two types with different scalar + storage order never have the same representation. + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * xgnatugn.adb (Push_Conditional): Simplify handling, + no longer need to keep track of "excluding" sections. + (Currently_Excluding): Removed. + (Process_Source_File): + Set unw/vms flag so that texinfo can do the whole handling of + @ifset/@ifclear sections. Fix handling of nested @ifset/@ifclear + sections. + * gnat_ugn.texi: Add a section on performing unassisted install + on Windows. + +2013-04-11 Johannes Kanig <kanig@adacore.com> + + * debug.adb: Document usage of -gnatd.Q switch. + +2013-04-11 Matthew Heaney <heaney@adacore.com> + + * a-crbtgk.adb (Ceiling, Find, Floor): Adjust locks + before element comparisons. + (Generic_Conditional_Insert, Generic_Conditional_Insert_With_Hint): + Ditto. + * a-crbtgo.adb, a-rbtgbo.adb (Generic_Equal): Adjust locks before + element comparisons. + * a-rbtgso.adb (Difference, Intersection): Adjust locks + before element comparisons. + (Is_Subset, Overlap): Ditto + (Symmetric_Difference, Union): Ditto + * a-btgbso.adb (Set_Difference, Set_Intersection): Adjust locks + before element comparisons. + (Set_Subset, Set_Overlap): Ditto + (Set_Symmetric_Difference, Set_Union): Ditto + * a-coorse.adb, a-ciorse.adb, a-cborse.adb + (Update_Element_Preserving_Key): Adjust locks before element + comparisons (Replace_Element): Ditto + +2013-04-11 Pascal Obry <obry@adacore.com> + + * prj-attr.adb, projects.texi, snames.ads-tmpl: Remove Build_Slaves + attribute. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * exp_ch3.adb (Build_Equivalent_Aggregate): Subsidiary of + Expand_N_Object_Declaration, used to construct an aggregate + with static components whenever possible, so that objects of a + discriminated type can be initialized without calling the init. + proc for the type. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * prj-makr.adb (Process_Directory): On VMS, always delete, + then recreate the temporary file with Create_Output_Text_File, + otherwise the output redirection does not work properly. + +2013-04-11 Eric Botcazou <ebotcazou@adacore.com> + + * urealp.ads: Fix minor typo. + +2013-04-11 Fabien Chouteau <chouteau@adacore.com> + + * cio.c (mktemp): Don't use tmpnam function from the + system on VxWorks in kernel mode. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * make.adb (Compile): Clarify the error message reported + when gnatmake refuses to compile a runtime source. + (Start_Compile_If_Possible): Ditto. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Add documentation about -gnatc and gnatmake. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * switch-c.adb: Document internal switches. + * usage.adb: Remove lines for internal switches: -gnatea, -gnateO, + -gnatez and -gnateO. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * par-ch6.adb (P_Subprogram): Attach aspects to subprogram stub. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Allow aspects on + subprogram stubs. + * sem_ch13.adb (Analyze_Aspect_Specifications): Analyze generated + pre/post pragmas at once before analyzing the proper body. + * sem_prag.adb (Chain_PPC): Handle pragma that comes from an + aspect on a subprogram stub. + * aspects.adb: Aspect specifications can appear on a + subprogram_Body_Stub. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * gnatname.adb: Minor comment fix. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * prj-makr.adb (Process_Directory): Create a new temporary + file for each invocation of the compiler, in directory pointed + by environment variable TMPDIR if it exists. + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * gnat_ugn.texi: Minor editing/clean ups. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Null_Procedure): New subprogram, mostly + extracted from Analyze_Subprogram_Declaration, to handle null + procedure declarations that in ada 2012 can be completions of + previous declarations. + +2013-04-11 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Entity_Of): Moved to Exp_Util. + * exp_util.ads, exp_util.adb (Entity_Of): New routine. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * g-spipat.ads: Minor comment fix. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb, sem_util.adb, sem_res.adb, exp_ch4.adb: Minor + reformatting. + +2013-04-11 Thomas Quinot <quinot@adacore.com> + + * exp_util.ads (Fully_Qualified_Name_String): Document that the + constructed literal is the entity name in all upper case. + +2013-04-11 Thomas Quinot <quinot@adacore.com> + + * sem_util.adb (Set_Entity_With_Style_Check): Fix logic of + check for implementation defined identifiers. + +2013-04-11 Yannick Moy <moy@adacore.com> + + * checks.adb (Apply_Type_Conversion_Checks): Add an explanation + of why range check and length are put on different nodes. + * exp_ch4.adb (Apply_Type_Conversion_Checks): Remove check marks + when doing their expansion. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_util.ads, sem_util.adb (Get_Incomplete_View_Of_Ancestor): + New function to implement the notion introduced in RM 7.3.1 + (5.2/3): in a child unit, a derived type is within the derivation + class of an ancestor declared in a parent unit, even if there + is an intermediate derivation that does not see the full view + of that ancestor. + * sem_res.adb (Valid_Conversion): if all else fails, examine if an + incomplete view of an ancestor makes a numeric conversion legal. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb: in Ada2012 operators can only have in + parameters. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * makeutl.adb (Create_Binder_Mapping_File): Do not put into + the mapping file ALI files of sources that have been replaced. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * projects.texi: Add subsection Duplicate Sources in Projects. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Add documentation for gnatmake switch -droot_dir/** + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * init.c (__gnat_install_handler): Only set up an alternate + stack when installing a signal handler for SIGSEGV. + +2013-04-11 Thomas Quinot <quinot@adacore.com> + + * g-socket.adb (Connect_Socket, timeout version): Call + underlying connect operation directly, not through the 2-argument + Connect_Socket thick binding, in order to avoid raising a junk + exception for the EINPROGRESS return. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * a-cdlili.adb: Minor addition of pragma Warnings (Off). + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * hostparm.ads: Minor reformatting. + +2013-04-11 Hristian Kirtchev <kirtchev@adacore.com> + + * aspects.ads, aspects.adb: Add Aspect_Depends to all the relevant + tables. + * elists.ads, elists.adb (Contains): New routine. + * par-prag.adb: Pragma Depends does not need any special treatment + by the parser. + * sem_ch13.adb (Analyze_Aspect_Specifications): + Transform aspect Depends into a corresponding pragma. + (Check_Aspect_At_Freeze_Point): Aspect Depends does not need + inspection at its freeze point. + * sem_prag.adb (Analyze_Pragma): Perform analysis and + normalization of pragma Depends. Remove the use of function + Is_Duplicate_Item. Use End_Scope to uninstalle the formal + parameters of a subprogram. Add a value for pragma Depends in + table Sig_Flags. + (Is_Duplicate_Item): Removed. + * snames.ads-tmpl: Add predefined name for Depends as well as + a pragma identifier. + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * gnat1drv.adb: Minor code clean up. + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * debug.adb, sem_ch13.adb (Analyze_Enumeration_Representation_Clause): + Ignore enumeration rep clauses by default in CodePeer mode, unless + -gnatd.I is specified. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Safe_To_Capture_Value): If the node belongs to + an expression that has been attached to the else_actions of an + if-expression, the capture is not safe. + +2013-04-11 Yannick Moy <moy@adacore.com> + + * checks.adb (Apply_Type_Conversion_Checks): Put check mark on type + conversion for arrays. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb: Minor reformatting. + +2013-04-11 Johannes Kanig <kanig@adacore.com> + + * adabkend.adb: Minor comment addition. + +2013-04-11 Matthew Heaney <heaney@adacore.com> + + * a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb ("="): Increment + lock counts before entering loop. + (Find): Ditto. + (Is_Sorted, Merge, Sort): Ditto. + (Reverse_Find): Ditto. + (Splice_Internal): Internal operation to refactor splicing logic. + (Splice): Some logic moved into Splice_Internal. + +2013-04-11 Johannes Kanig <kanig@adacore.com> + + * adabkend.adb (Scan_Compiler_Arguments): Do not call + Set_Output_Object_File_Name in Alfa_Mode + * gnat1drv.adb (Adjust_Global_Switches): Take Alfa_Mode into account. + * opt.ads: Fix documentation. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * sem_res.adb: Minor code reorganization and comment fixes. + * sem_type.adb: Minor reformatting. + +2013-04-11 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Process_Transient_Object): Add new + local variable Fin_Call. Remove and explain ??? comment. Use the + Actions of logical operators "and then" and "or else" to insert + the generated finalization call. + +2013-04-11 Eric Botcazou <ebotcazou@adacore.com> + + * gnat_rm.texi: Fix typo. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb: Minor reformatting. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * atree.h: Add declarations for Flag255-Flag289 Fix declaration + of Field30 (was wrong, but no effect, since not yet referenced by + back end) Add declarations for Field31-Field35 Add declarations + for Node31-Node35. + * einfo.ads, einfo.adb (Has_Invariants): No longer applies to + procedures. + (Has_Predicates): No longer applies to functions. + (Is_Predicate_Function): New flag. + (Is_Predicate_Function_M): New flag. + (Is_Invariant_Procedure): New flag. + (Predicate_Function_M): New function. + (Set_Predicate_Function_M): New procedure. + * exp_ch11.adb (Expand_N_Raise_Expression): Take care of special + case of appearing in predicate used for membership test. + * exp_ch3.adb (Insert_Component_Invariant_Checks): Set + Is_Invariant_Procedure flag. + * exp_ch4.adb (Expand_Op_In): Call special predicate function + that takes care of raise_expression nodes in the predicate. + * exp_util.ads, exp_util.adb (Make_Predicate_Call): Add argument Mem for + membership case. + * sem_ch13.adb (Build_Predicate_Functions): New name for + Build_Predicate_Function. Major rewrite to take care of raise + expression in predicate for membership tests. + * sem_res.adb (Resolve_Actuals): Include both predicate functions + in defense against infinite predicate function loops. + * sinfo.ads, sinfo.adb (Convert_To_Return_False): New flag. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb: Minor reformatting. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * lib-xref.adb: Generate reference for component of anonymous + access type. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * stand.ads: Minor reformatting. + +2013-04-11 Matthew Heaney <heaney@adacore.com> + + * a-convec.adb, a-coinve.adb, a-cobove.adb ("="): Increment lock + counts before entering loop. + (Find, Find_Index): Ditto. + (Is_Sorted, Merge, Sort): Ditto. + (Reverse_Find, Reverse_Find_Index): Ditto. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * exp_ch11.ads, exp_ch11.adb (Expand_N_Raise_Expression): New procedure. + * exp_util.adb (Insert_Actions): Add entry for N_Raise_Expression. + * expander.adb: Add call to Expand_N_Raise_Expression. + * par-ch11.adb (P_Raise_Expression): New procedure. + * par-ch4.adb (P_Relation): Handle Raise_Expression. + * par.adb (P_Raise_Expression): New procedure. + * sem.adb: Add handling for N_Raise_Expression. + * sem_ch11.ads, sem_ch11.adb (Analyze_Raise_Expression): New procedure. + * sem_res.adb (Resolve): Add handling for N_Raise_Expression. + * sinfo.ads, sinfo.adb (N_Raise_Expression): New node. + * sprint.adb (Sprint_Node_Actual): Add handling for N_Raise_Expression. + * stand.ads (Any_Type): Document use with N_Raise_Expression. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Remove section "The Development Environments" + now that all predefined attributes are documented, including + those in package IDE. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb: Preserve parent link in copy of expression. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * projects.texi: Complete rewrite of the subsection Attributes + in section "Project file Reference". + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb: Minor reformatting. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb (Expand_Concatenate): Remove wrapping in + expression-with-actions node. No longer needed given fix to + sem_prag and caused loss of some useful warnings. + * sem.ads: Minor reformatting. + * sem_prag.adb (Check_Disabled): Removed, to be replaced by not + Check_Enabled. These two routines were curiously incompatible + causing confusion. + (Analyze_Pragma, case Check): Make sure we do + not expand the string argument if the check is disabled. Avoid + use of Check_Disabled, which resulted in missing analysis in + some cases. + * sem_prag.ads (Check_Disabled): Removed, to be replaced by not + Check_Enabled. These two routines were curiously incompatible + causing confusion. + +2013-04-11 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Process_Transient_Object): Use + an unchecked conversion when associating a transient controlled + object with its "hook". + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Analyze_Pragma, case + Preelaborable_Initialization): The pragma is legal if it comes + from an aspect on the private view of the type, even though its + analysis point takes place later at the freeze point. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb: Minor reformatting. + +2013-04-11 Yannick Moy <moy@adacore.com> + + * ali-util.adb (Read_Withed_ALIs): Do not consider it an error to + read ALI files with No_Object=True in Alfa mode. + * gnat1drv.adb: Set appropriately Back_End_Mode in Alfa mode, whether + this is during frame condition generation of translation to Why. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb: Minor code reorganization + * types.ads: Minor reformatting. + +2013-04-11 Johannes Kanig <kanig@adacore.com> + + * opt.ads New global boolean Frame_Condition_Mode to avoid + referring to command line switch. + * gnat1drv.adb (Gnat1drv) set frame condition mode when -gnatd.G + is present, and disable Code generation in that case. Disable + ALI file generation when switch is *not* present. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Expression_Function): Perform the + pre-analysis on a copy of the expression, to prevent downstream + visbility issues involving operators and instantiations. + +2013-04-11 Johannes Kanig <kanig@adacore.com> + + * debug.adb: Reservation and documentation for -gnatd.G switch. + * gnat1drv.adb (Adjust_Global_Switches) Take into account -gnatd.G + switch, and set ALI file generation accordingly. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb, exp_dist.adb: Minor reformatting. + * gnat_rm.texi, gnat_ugn.texi: -020 Add documentation clarifying that + check names introduced with pragma Check_Name are suppressed by -gnatp. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi, projects.texi: Move chapter "Tools Supporting Project + Files" from projects.texi to gnat_ugn.texi. + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in: Update dependencies. + +2013-04-11 Yannick Moy <moy@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Allow missing body in Alfa + mode. + +2013-04-11 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Expand_N_Allocator): Detect the + allocation of an anonymous controlled object where the type of + the context is named. Use the pool and finalization master of + the named access type to allocate the object. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Remove most mentions of gprbuild. + * projects.texi: Remove all mentions of asociative array + attributes. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb, sem_attr.adb, gnat1drv.adb, prj-makr.adb, + opt.ads, sem_ch13.adb: Minor reformatting. + * debug.adb: Minor comment fix (remove junk .I doc). + +2013-04-11 Thomas Quinot <quinot@adacore.com> + + * rtsfind.ads, exp_dist.adb, exp_dist.ads (Rtsfind.PCS_Version, case + PolyORB): Bump to 6. + (Exp_Dist.PolyORB_Support): Replace TC_Build with + Build_Complex_TC. + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * debug.adb, sem_prag.adb, par-ch2.adb, sem_attr.adb, gnat1drv.adb, + exp_disp.adb, opt.ads, sem_ch13.adb (Relaxed_RM_Semantics): New flag. + Enable this flag in CodePeer mode, and also via -gnatd.M. + Replace some uses of CodePeer_Mode by Relaxed_RM_Semantics. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Check_Constrained_Object): If a subtype is created + from the renamed object in an object renaming declaration with + an unconstrained nominal subtype, freeze the created subtype at + once, to prevent order of elaboration issues in the backend. + +2013-04-11 Arnaud Charlet <charlet@adacore.com> + + * exp_aggr.adb (Aggr_Size_OK): Refine setting of Max_Aggr_Size + in particular in CodePeer mode. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Add documentation for backup copies of project + files for gnatname. + +2013-04-11 Tristan Gingold <gingold@adacore.com> + + * gnat_rm.texi: Add Detect_BLocking in the ravenscar profile + pragma list. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * gnatname.adb (Scan_Args): Recognize new switch --no-backup + (Usage): Add line for --no-backup. + * opt.ads (No_Backup): New Boolean variable, initialized to False. + (Ada_Version_Default): Switch to Ada 2012 by default. + * prj-makr.adb (Initialize): Create a backup for an existing + project file if gnatname is not invoked with --no-backup. + +2013-04-11 Thomas Quinot <quinot@adacore.com> + + * exp_ch4.adb: Minor code improvement: replace various calls to + Make_If_Statement in expansion with Make_Implicit_If_Statement. + +2013-04-11 Eric Botcazou <ebotcazou@adacore.com> + + * ali.adb: Fix minor typo. + +2013-04-11 Thomas Quinot <quinot@adacore.com> + + * exp_ch4.adb (Find_Enclosing_Context): Add missing case of + N_Procedure_Call_Statement. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * debug.adb: Minor comment fix. + +2013-04-11 Johannes Kanig <kanig@adacore.com> + + * debug.adb: Remove comment for -gnatd.G. + +2013-04-11 Thomas Quinot <quinot@adacore.com> + + * exp_ch4.adb (Expand_Record_Equality.Suitable_Element): + Remove recursive routine, replace with... + (Expand_Record_Equality.Element_To_Compare): New subroutine, + implement iterative search for next element to compare. + Add explanatory comment in the tagged case. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb: remove spurious warning from non-empty loop. + * sem_ch8.adb (Enclosing_Instance): Make public to other routines + in the package, in order to suppress redundant semantic checks + on subprogram renamings in nested instantiations. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * errout.ads: Minor reformatting. + * sem_eval.adb (Why_Not_Static): Now issues continuation messages + (Why_Not_Static): Test for aggregates behind string literals. + * sem_eval.ads (Why_Not_Static): Now issues continuation messages. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb (Expand_Concatenation): Wrap expansion in + Expressions_With_Actions. + +2013-04-11 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Base_Types_Match): For an actual type in an + instance, the base type may itself be a subtype, so find true + base type to determine compatibility. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * s-osprim-mingw.adb, sem_ch3.adb, sem_prag.adb, sem_util.adb. + makeutl.adb, sem_ch8.adb: Minor reformatting. + +2013-04-11 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Minor fixes for VMS. + * ug_words: Minor addition: -gnato? => /OVERFLOW_CHECKS=?. + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * usage.adb (Usage): Minor edit to -gnatW message + +2013-04-11 Robert Dewar <dewar@adacore.com> + + * exp_aggr.adb (Expand_N_Aggregate): Add circuit for handling + others for string literal case. Also add big ??? comment about + this new code, which should be redundant, but is not. + * sem_eval.adb (Eval_Concatenation): Handle non-static case + properly (Eval_String_Literal): Handle non-static literal properly + +2013-03-20 Tobias Burnus <burnus@net-b.de> + + * i-fortra.ads: Update comment, add Ada 2012's optional + Star and Kind data types for enhanced interoperability. + +2013-03-16 Eric Botcazou <ebotcazou@adacore.com> + + * gnatvsn.ads (Library_Version): Bump to 4.9. + 2013-03-08 Cesar Strauss <cestrauss@gmail.com> PR ada/52123 diff --git a/gcc/ada/a-btgbso.adb b/gcc/ada/a-btgbso.adb index b62007aafb3..2aef270f64d 100644 --- a/gcc/ada/a-btgbso.adb +++ b/gcc/ada/a-btgbso.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -53,11 +53,19 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ---------------- procedure Set_Difference (Target : in out Set_Type; Source : Set_Type) is + BT : Natural renames Target.Busy; + LT : Natural renames Target.Lock; + + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + Tgt, Src : Count_Type; TN : Nodes_Type renames Target.Nodes; SN : Nodes_Type renames Source.Nodes; + Compare : Integer; + begin if Target'Address = Source'Address then if Target.Busy > 0 then @@ -82,17 +90,51 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is Src := Source.First; loop if Tgt = 0 then - return; + exit; end if; if Src = 0 then - return; + exit; end if; - if Is_Less (TN (Tgt), SN (Src)) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + begin + BT := BT + 1; + LT := LT + 1; + + BS := BS + 1; + LS := LS + 1; + + if Is_Less (TN (Tgt), SN (Src)) then + Compare := -1; + elsif Is_Less (SN (Src), TN (Tgt)) then + Compare := 1; + else + Compare := 0; + end if; + + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + exception + when others => + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + raise; + end; + + if Compare < 0 then Tgt := Tree_Operations.Next (Target, Tgt); - elsif Is_Less (SN (Src), TN (Tgt)) then + elsif Compare > 0 then Src := Tree_Operations.Next (Source, Src); else @@ -111,12 +153,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is end Set_Difference; function Set_Difference (Left, Right : Set_Type) return Set_Type is - L_Node : Count_Type; - R_Node : Count_Type; - - Dst_Node : Count_Type; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then return S : Set_Type (0); -- Empty set @@ -131,15 +167,51 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is end if; return Result : Set_Type (Left.Length) do - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 then - return; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if R_Node = 0 then - while L_Node /= 0 loop + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 then + exit; + end if; + + if R_Node = 0 then + while L_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + end loop; + + exit; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then Insert_With_Hint (Dst_Set => Result, Dst_Hint => 0, @@ -147,28 +219,31 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is Dst_Node => Dst_Node); L_Node := Tree_Operations.Next (Left, L_Node); - end loop; - return; - end if; + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + R_Node := Tree_Operations.Next (Right, R_Node); - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Left.Nodes (L_Node), - Dst_Node => Dst_Node); + else + L_Node := Tree_Operations.Next (Left, L_Node); + R_Node := Tree_Operations.Next (Right, R_Node); + end if; + end loop; - L_Node := Tree_Operations.Next (Left, L_Node); + BL := BL - 1; + LL := LL - 1; - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - R_Node := Tree_Operations.Next (Right, R_Node); + BR := BR - 1; + LR := LR - 1; + exception + when others => + BL := BL - 1; + LL := LL - 1; - else - L_Node := Tree_Operations.Next (Left, L_Node); - R_Node := Tree_Operations.Next (Right, R_Node); - end if; - end loop; + BR := BR - 1; + LR := LR - 1; + + raise; + end; end return; end Set_Difference; @@ -180,9 +255,17 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is (Target : in out Set_Type; Source : Set_Type) is + BT : Natural renames Target.Busy; + LT : Natural renames Target.Lock; + + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + Tgt : Count_Type; Src : Count_Type; + Compare : Integer; + begin if Target'Address = Source'Address then return; @@ -203,7 +286,41 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is while Tgt /= 0 and then Src /= 0 loop - if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + begin + BT := BT + 1; + LT := LT + 1; + + BS := BS + 1; + LS := LS + 1; + + if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then + Compare := -1; + elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then + Compare := 1; + else + Compare := 0; + end if; + + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + exception + when others => + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + raise; + end; + + if Compare < 0 then declare X : constant Count_Type := Tgt; begin @@ -213,7 +330,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is Tree_Operations.Free (Target, X); end; - elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then + elsif Compare > 0 then Src := Tree_Operations.Next (Source, Src); else @@ -235,46 +352,80 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is end Set_Intersection; function Set_Intersection (Left, Right : Set_Type) return Set_Type is - L_Node : Count_Type; - R_Node : Count_Type; - - Dst_Node : Count_Type; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then return Copy (Left); end if; return Result : Set_Type (Count_Type'Min (Left.Length, Right.Length)) do - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 then - return; - end if; - if R_Node = 0 then - return; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - L_Node := Tree_Operations.Next (Left, L_Node); + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - R_Node := Tree_Operations.Next (Right, R_Node); + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; - else - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Left.Nodes (L_Node), - Dst_Node => Dst_Node); + L_Node : Count_Type; + R_Node : Count_Type; - L_Node := Tree_Operations.Next (Left, L_Node); - R_Node := Tree_Operations.Next (Right, R_Node); - end if; - end loop; + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 then + exit; + end if; + + if R_Node = 0 then + exit; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + L_Node := Tree_Operations.Next (Left, L_Node); + + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + R_Node := Tree_Operations.Next (Right, R_Node); + + else + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + R_Node := Tree_Operations.Next (Right, R_Node); + end if; + end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; + end; end return; end Set_Intersection; @@ -286,9 +437,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is (Subset : Set_Type; Of_Set : Set_Type) return Boolean is - Subset_Node : Count_Type; - Set_Node : Count_Type; - begin if Subset'Address = Of_Set'Address then return True; @@ -298,28 +446,75 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is return False; end if; - Subset_Node := Subset.First; - Set_Node := Of_Set.First; - loop - if Set_Node = 0 then - return Subset_Node = 0; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if Subset_Node = 0 then - return True; - end if; + declare + BL : Natural renames Subset'Unrestricted_Access.Busy; + LL : Natural renames Subset'Unrestricted_Access.Lock; - if Is_Less (Subset.Nodes (Subset_Node), Of_Set.Nodes (Set_Node)) then - return False; - end if; + BR : Natural renames Of_Set'Unrestricted_Access.Busy; + LR : Natural renames Of_Set'Unrestricted_Access.Lock; - if Is_Less (Of_Set.Nodes (Set_Node), Subset.Nodes (Subset_Node)) then - Set_Node := Tree_Operations.Next (Of_Set, Set_Node); - else - Set_Node := Tree_Operations.Next (Of_Set, Set_Node); - Subset_Node := Tree_Operations.Next (Subset, Subset_Node); - end if; - end loop; + Subset_Node : Count_Type; + Set_Node : Count_Type; + + Result : Boolean; + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + Subset_Node := Subset.First; + Set_Node := Of_Set.First; + loop + if Set_Node = 0 then + Result := Subset_Node = 0; + exit; + end if; + + if Subset_Node = 0 then + Result := True; + exit; + end if; + + if Is_Less (Subset.Nodes (Subset_Node), + Of_Set.Nodes (Set_Node)) + then + Result := False; + exit; + end if; + + if Is_Less (Of_Set.Nodes (Set_Node), + Subset.Nodes (Subset_Node)) + then + Set_Node := Tree_Operations.Next (Of_Set, Set_Node); + else + Set_Node := Tree_Operations.Next (Of_Set, Set_Node); + Subset_Node := Tree_Operations.Next (Subset, Subset_Node); + end if; + end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; + end; end Set_Subset; ------------- @@ -327,33 +522,72 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is ------------- function Set_Overlap (Left, Right : Set_Type) return Boolean is - L_Node : Count_Type; - R_Node : Count_Type; - begin if Left'Address = Right'Address then return Left.Length /= 0; end if; - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 - or else R_Node = 0 - then - return False; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - L_Node := Tree_Operations.Next (Left, L_Node); + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - R_Node := Tree_Operations.Next (Right, R_Node); + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; - else - return True; - end if; - end loop; + L_Node : Count_Type; + R_Node : Count_Type; + + Result : Boolean; + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 + or else R_Node = 0 + then + Result := False; + exit; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + L_Node := Tree_Operations.Next (Left, L_Node); + + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + R_Node := Tree_Operations.Next (Right, R_Node); + + else + Result := True; + exit; + end if; + end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; + end; end Set_Overlap; -------------------------- @@ -364,18 +598,21 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is (Target : in out Set_Type; Source : Set_Type) is + BT : Natural renames Target.Busy; + LT : Natural renames Target.Lock; + + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + Tgt : Count_Type; Src : Count_Type; New_Tgt_Node : Count_Type; pragma Warnings (Off, New_Tgt_Node); - begin - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + Compare : Integer; + begin if Target'Address = Source'Address then Tree_Operations.Clear_Tree (Target); return; @@ -402,10 +639,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is return; end if; - if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + begin + BT := BT + 1; + LT := LT + 1; + + BS := BS + 1; + LS := LS + 1; + + if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then + Compare := -1; + elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then + Compare := 1; + else + Compare := 0; + end if; + + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + exception + when others => + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + raise; + end; + + if Compare < 0 then Tgt := Tree_Operations.Next (Target, Tgt); - elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then + elsif Compare > 0 then Insert_With_Hint (Dst_Set => Target, Dst_Hint => Tgt, @@ -432,12 +703,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is function Set_Symmetric_Difference (Left, Right : Set_Type) return Set_Type is - L_Node : Count_Type; - R_Node : Count_Type; - - Dst_Node : Count_Type; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then return S : Set_Type (0); -- Empty set @@ -452,25 +717,62 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is end if; return Result : Set_Type (Left.Length + Right.Length) do - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 then - while R_Node /= 0 loop - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Right.Nodes (R_Node), - Dst_Node => Dst_Node); - R_Node := Tree_Operations.Next (Right, R_Node); - end loop; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - return; - end if; + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; - if R_Node = 0 then - while L_Node /= 0 loop + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 then + while R_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Right.Nodes (R_Node), + Dst_Node => Dst_Node); + + R_Node := Tree_Operations.Next (Right, R_Node); + end loop; + + exit; + end if; + + if R_Node = 0 then + while L_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + end loop; + + exit; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then Insert_With_Hint (Dst_Set => Result, Dst_Hint => 0, @@ -478,34 +780,37 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is Dst_Node => Dst_Node); L_Node := Tree_Operations.Next (Left, L_Node); - end loop; - return; - end if; + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Right.Nodes (R_Node), + Dst_Node => Dst_Node); - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Left.Nodes (L_Node), - Dst_Node => Dst_Node); + R_Node := Tree_Operations.Next (Right, R_Node); - L_Node := Tree_Operations.Next (Left, L_Node); + else + L_Node := Tree_Operations.Next (Left, L_Node); + R_Node := Tree_Operations.Next (Right, R_Node); + end if; + end loop; - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Right.Nodes (R_Node), - Dst_Node => Dst_Node); + BL := BL - 1; + LL := LL - 1; - R_Node := Tree_Operations.Next (Right, R_Node); + BR := BR - 1; + LR := LR - 1; + exception + when others => + BL := BL - 1; + LL := LL - 1; - else - L_Node := Tree_Operations.Next (Left, L_Node); - R_Node := Tree_Operations.Next (Right, R_Node); - end if; - end loop; + BR := BR - 1; + LR := LR - 1; + + raise; + end; end return; end Set_Symmetric_Difference; @@ -541,17 +846,34 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - -- Note that there's no way to decide a priori whether the target has - -- enough capacity for the union with source. We cannot simply compare - -- the sum of the existing lengths to the capacity of the target, - -- because equivalent items from source are not included in the union. + declare + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; - Iterate (Source); + begin + BS := BS + 1; + LS := LS + 1; + + -- Note that there's no way to decide a priori whether the target has + -- enough capacity for the union with source. We cannot simply + -- compare the sum of the existing lengths to the capacity of the + -- target, because equivalent items from source are not included in + -- the union. + + Iterate (Source); + + BS := BS - 1; + LS := LS - 1; + exception + when others => + BS := BS - 1; + LS := LS - 1; + + raise; + end; end Set_Union; function Set_Union (Left, Right : Set_Type) return Set_Type is @@ -569,35 +891,65 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is end if; return Result : Set_Type (Left.Length + Right.Length) do - Assign (Target => Result, Source => Left); + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + begin + BL := BL + 1; + LL := LL + 1; - Insert_Right : declare - Hint : Count_Type := 0; + BR := BR + 1; + LR := LR + 1; - procedure Process (Node : Count_Type); - pragma Inline (Process); + Assign (Target => Result, Source => Left); - procedure Iterate is - new Tree_Operations.Generic_Iteration (Process); + Insert_Right : declare + Hint : Count_Type := 0; - ------------- - -- Process -- - ------------- + procedure Process (Node : Count_Type); + pragma Inline (Process); + + procedure Iterate is + new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Count_Type) is + begin + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => Hint, + Src_Node => Right.Nodes (Node), + Dst_Node => Hint); + end Process; + + -- Start of processing for Insert_Right - procedure Process (Node : Count_Type) is begin - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => Hint, - Src_Node => Right.Nodes (Node), - Dst_Node => Hint); - end Process; + Iterate (Right); + end Insert_Right; - -- Start of processing for Insert_Right + BL := BL - 1; + LL := LL - 1; - begin - Iterate (Right); - end Insert_Right; + BR := BR - 1; + LR := LR - 1; + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; + end; end return; end Set_Union; diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index 5db2d58f3d7..36b9b81e83b 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -27,32 +27,10 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with Ada.Finalization; use Ada.Finalization; - with System; use type System.Address; package body Ada.Containers.Bounded_Doubly_Linked_Lists is - type Iterator is new Limited_Controlled and - List_Iterator_Interfaces.Reversible_Iterator with - record - Container : List_Access; - Node : Count_Type; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -80,6 +58,18 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Before : Count_Type; New_Node : Count_Type); + procedure Splice_Internal + (Target : in out List; + Before : Count_Type; + Source : in out List); + + procedure Splice_Internal + (Target : in out List; + Before : Count_Type; + Source : in out List; + Src_Pos : Count_Type; + Tgt_Pos : out Count_Type); + function Vet (Position : Cursor) return Boolean; -- Checks invariants of the cursor and its designated container, as a -- simple way of detecting dangling references (see operation Free for a @@ -92,10 +82,19 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + LN : Node_Array renames Left.Nodes; RN : Node_Array renames Right.Nodes; - LI, RI : Count_Type; + LI : Count_Type; + RI : Count_Type; + + Result : Boolean; begin if Left'Address = Right'Address then @@ -106,18 +105,45 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return False; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + LI := Left.First; RI := Right.First; + Result := True; for J in 1 .. Left.Length loop if LN (LI).Element /= RN (RI).Element then - return False; + Result := False; + exit; end if; LI := LN (LI).Next; RI := RN (RI).Next; end loop; - return True; + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; end "="; -------------- @@ -312,20 +338,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + else + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - return (Element => N.Element'Access); - end; + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; + end if; end Constant_Reference; -------------- @@ -350,10 +376,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Capacity = 0 then C := Source.Length; - elsif Capacity >= Source.Length then C := Capacity; - else raise Capacity_Error with "Capacity value too small"; end if; @@ -461,7 +485,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is "attempt to tamper with cursors (list is busy)"; end if; - for I in 1 .. Count loop + for J in 1 .. Count loop X := Container.First; pragma Assert (N (N (X).Next).Prev = Container.First); @@ -500,7 +524,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is "attempt to tamper with cursors (list is busy)"; end if; - for I in 1 .. Count loop + for J in 1 .. Count loop X := Container.Last; pragma Assert (N (N (X).Prev).Next = Container.Last); @@ -522,11 +546,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is if Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; - end if; - pragma Assert (Vet (Position), "bad cursor in Element"); + else + pragma Assert (Vet (Position), "bad cursor in Element"); - return Position.Container.Nodes (Position.Node).Element; + return Position.Container.Nodes (Position.Node).Element; + end if; end Element; -------------- @@ -538,7 +563,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is if Object.Container /= null then declare B : Natural renames Object.Container.all.Busy; - begin B := B - 1; end; @@ -570,15 +594,44 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Find"); end if; - while Node /= 0 loop - if Nodes (Node).Element = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - Node := Nodes (Node).Next; - end loop; + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Count_Type; + + begin + B := B + 1; + L := L + 1; + + Result := 0; + while Node /= 0 loop + if Nodes (Node).Element = Item then + Result := Node; + exit; + end if; - return No_Element; + Node := Nodes (Node).Next; + end loop; + + B := B - 1; + L := L - 1; + + if Result = 0 then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); + end if; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Find; ----------- @@ -589,9 +642,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Container.First = 0 then return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.First); end if; - - return Cursor'(Container'Unrestricted_Access, Container.First); end First; function First (Object : Iterator) return Cursor is @@ -624,9 +677,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Container.First = 0 then raise Constraint_Error with "list is empty"; + else + return Container.Nodes (Container.First).Element; end if; - - return Container.Nodes (Container.First).Element; end First_Element; ---------- @@ -753,19 +806,42 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is --------------- function Is_Sorted (Container : List) return Boolean is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + Nodes : Node_Array renames Container.Nodes; - Node : Count_Type := Container.First; + Node : Count_Type; + + Result : Boolean; begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Node := Container.First; + Result := True; for J in 2 .. Container.Length loop if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then - return False; + Result := False; + exit; end if; Node := Nodes (Node).Next; end loop; - return True; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Is_Sorted; ----------- @@ -776,12 +852,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is (Target : in out List; Source : in out List) is - LN : Node_Array renames Target.Nodes; - RN : Node_Array renames Source.Nodes; - LI, RI : Cursor; - begin - -- The semantics of Merge changed slightly per AI05-0021. It was -- originally the case that if Target and Source denoted the same -- container object, then the GNAT implementation of Merge did @@ -799,6 +870,14 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is "Target and Source denote same non-empty container"; end if; + if Target.Length > Count_Type'Last - Source.Length then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + if Target.Length + Source.Length > Target.Capacity then + raise Capacity_Error with "new length exceeds target capacity"; + end if; + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; @@ -809,34 +888,70 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is "attempt to tamper with cursors of Source (list is busy)"; end if; - LI := First (Target); - RI := First (Source); - while RI.Node /= 0 loop - pragma Assert (RN (RI.Node).Next = 0 - or else not (RN (RN (RI.Node).Next).Element < - RN (RI.Node).Element)); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if LI.Node = 0 then - Splice (Target, No_Element, Source); - return; - end if; + declare + TB : Natural renames Target.Busy; + TL : Natural renames Target.Lock; - pragma Assert (LN (LI.Node).Next = 0 - or else not (LN (LN (LI.Node).Next).Element < - LN (LI.Node).Element)); + SB : Natural renames Source.Busy; + SL : Natural renames Source.Lock; - if RN (RI.Node).Element < LN (LI.Node).Element then - declare - RJ : Cursor := RI; - begin - RI.Node := RN (RI.Node).Next; - Splice (Target, LI, Source, RJ); - end; + LN : Node_Array renames Target.Nodes; + RN : Node_Array renames Source.Nodes; - else - LI.Node := LN (LI.Node).Next; - end if; - end loop; + LI, LJ, RI, RJ : Count_Type; + + begin + TB := TB + 1; + TL := TL + 1; + + SB := SB + 1; + SL := SL + 1; + + LI := Target.First; + RI := Source.First; + while RI /= 0 loop + pragma Assert (RN (RI).Next = 0 + or else not (RN (RN (RI).Next).Element < + RN (RI).Element)); + + if LI = 0 then + Splice_Internal (Target, 0, Source); + exit; + end if; + + pragma Assert (LN (LI).Next = 0 + or else not (LN (LN (LI).Next).Element < + LN (LI).Element)); + + if RN (RI).Element < LN (LI).Element then + RJ := RI; + RI := RN (RI).Next; + Splice_Internal (Target, LI, Source, RJ, LJ); + + else + LI := LN (LI).Next; + end if; + end loop; + + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + exception + when others => + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + raise; + end; end Merge; ---------- @@ -926,7 +1041,28 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is "attempt to tamper with cursors (list is busy)"; end if; - Sort (Front => 0, Back => 0); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + Sort (Front => 0, Back => 0); + + B := B - 1; + L := L - 1; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); @@ -1132,7 +1268,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Container.Nodes (Node).Next; end loop; - exception when others => B := B - 1; @@ -1160,9 +1295,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- for a reverse iterator, Container.Last is the beginning. return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => 0) + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => 0) do B := B + 1; end return; @@ -1225,9 +1360,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Container.Last = 0 then return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.Last); end if; - - return Cursor'(Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is @@ -1260,9 +1395,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Container.Last = 0 then raise Constraint_Error with "list is empty"; + else + return Container.Nodes (Container.Last).Element; end if; - - return Container.Nodes (Container.Last).Element; end Last_Element; ------------ @@ -1381,13 +1516,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is declare Nodes : Node_Array renames Position.Container.Nodes; Node : constant Count_Type := Nodes (Position.Node).Next; - begin if Node = 0 then return No_Element; + else + return Cursor'(Position.Container, Node); end if; - - return Cursor'(Position.Container, Node); end; end Next; @@ -1398,14 +1532,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong list"; + else + return Next (Position); end if; - - return Next (Position); end Next; ------------- @@ -1444,9 +1576,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Node = 0 then return No_Element; + else + return Cursor'(Position.Container, Node); end if; - - return Cursor'(Position.Container, Node); end; end Previous; @@ -1457,14 +1589,12 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong list"; + else + return Previous (Position); end if; - - return Previous (Position); end Previous; ------------------- @@ -1525,20 +1655,19 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is if N < 0 then raise Program_Error with "bad list length (corrupt stream)"; - end if; - if N = 0 then + elsif N = 0 then return; - end if; - if N > Item.Capacity then + elsif N > Item.Capacity then raise Constraint_Error with "length exceeds capacity"; - end if; - for Idx in 1 .. N loop - Allocate (Item, Stream, New_Node => X); - Insert_Internal (Item, Before => 0, New_Node => X); - end loop; + else + for Idx in 1 .. N loop + Allocate (Item, Stream, New_Node => X); + Insert_Internal (Item, Before => 0, New_Node => X); + end loop; + end if; end Read; procedure Read @@ -1576,20 +1705,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - pragma Assert (Vet (Position), "bad cursor in function Reference"); + else + pragma Assert (Vet (Position), "bad cursor in function Reference"); - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - return (Element => N.Element'Access); - end; + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return (Element => N.Element'Access); + end; + end if; end Reference; --------------------- @@ -1604,21 +1733,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unchecked_Access then + elsif Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - if Container.Lock > 0 then + elsif Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (list is locked)"; - end if; - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + else + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - Container.Nodes (Position.Node).Element := New_Item; + Container.Nodes (Position.Node).Element := New_Item; + end if; end Replace_Element; ---------------------- @@ -1733,15 +1861,44 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; - while Node /= 0 loop - if Container.Nodes (Node).Element = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - Node := Container.Nodes (Node).Prev; - end loop; + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Count_Type; + + begin + B := B + 1; + L := L + 1; + + Result := 0; + while Node /= 0 loop + if Container.Nodes (Node).Element = Item then + Result := Node; + exit; + end if; - return No_Element; + Node := Container.Nodes (Node).Prev; + end loop; + + B := B - 1; + L := L - 1; + + if Result = 0 then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); + end if; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Reverse_Find; --------------------- @@ -1765,7 +1922,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Container.Nodes (Node).Prev; end loop; - exception when others => B := B - 1; @@ -1794,37 +1950,26 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (Vet (Before), "bad cursor in Splice"); end if; - if Target'Address = Source'Address - or else Source.Length = 0 - then + if Target'Address = Source'Address or else Source.Length = 0 then return; - end if; - - pragma Assert (Source.Nodes (Source.First).Prev = 0); - pragma Assert (Source.Nodes (Source.Last).Next = 0); - if Target.Length > Count_Type'Last - Source.Length then + elsif Target.Length > Count_Type'Last - Source.Length then raise Constraint_Error with "new length exceeds maximum"; - end if; - if Target.Length + Source.Length > Target.Capacity then + elsif Target.Length + Source.Length > Target.Capacity then raise Capacity_Error with "new length exceeds target capacity"; - end if; - if Target.Busy > 0 then + elsif Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; - end if; - if Source.Busy > 0 then + elsif Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; - end if; - while not Is_Empty (Source) loop - Insert (Target, Before, Source.Nodes (Source.First).Element); - Delete_First (Source); - end loop; + else + Splice_Internal (Target, Before.Node, Source); + end if; end Splice; procedure Splice @@ -1937,7 +2082,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Source : in out List; Position : in out Cursor) is - Target_Position : Cursor; + Target_Position : Count_Type; begin if Target'Address = Source'Address then @@ -1979,16 +2124,139 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is "attempt to tamper with cursors of Source (list is busy)"; end if; - Insert - (Container => Target, - Before => Before, - New_Item => Source.Nodes (Position.Node).Element, - Position => Target_Position); + Splice_Internal + (Target => Target, + Before => Before.Node, + Source => Source, + Src_Pos => Position.Node, + Tgt_Pos => Target_Position); - Delete (Source, Position); - Position := Target_Position; + Position := Cursor'(Target'Unrestricted_Access, Target_Position); end Splice; + --------------------- + -- Splice_Internal -- + --------------------- + + procedure Splice_Internal + (Target : in out List; + Before : Count_Type; + Source : in out List) + is + N : Node_Array renames Source.Nodes; + X : Count_Type; + + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted, and corner-cases disposed of. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= 0); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (Source.Last /= 0); + pragma Assert (N (Source.Last).Next = 0); + pragma Assert (Target.Length <= Count_Type'Last - Source.Length); + pragma Assert (Target.Length + Source.Length <= Target.Capacity); + + while Source.Length > 1 loop + -- Copy first element of Source onto Target + + Allocate (Target, N (Source.First).Element, New_Node => X); + Insert_Internal (Target, Before => Before, New_Node => X); + + -- Unlink the first node from Source + + X := Source.First; + pragma Assert (N (N (X).Next).Prev = X); + + Source.First := N (X).Next; + N (Source.First).Prev := 0; + + Source.Length := Source.Length - 1; + + -- Return the Source node to its free store + + Free (Source, X); + end loop; + + -- Copy first (and only remaining) element of Source onto Target + + Allocate (Target, N (Source.First).Element, New_Node => X); + Insert_Internal (Target, Before => Before, New_Node => X); + + -- Unlink the node from Source + + X := Source.First; + pragma Assert (X = Source.Last); + + Source.First := 0; + Source.Last := 0; + + Source.Length := 0; + + -- Return the Source node to its free store + + Free (Source, X); + end Splice_Internal; + + procedure Splice_Internal + (Target : in out List; + Before : Count_Type; -- node of Target + Source : in out List; + Src_Pos : Count_Type; -- node of Source + Tgt_Pos : out Count_Type) + is + N : Node_Array renames Source.Nodes; + + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted, and corner-cases handled. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Target.Length < Target.Capacity); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= 0); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (Source.Last /= 0); + pragma Assert (N (Source.Last).Next = 0); + pragma Assert (Src_Pos /= 0); + + Allocate (Target, N (Src_Pos).Element, New_Node => Tgt_Pos); + Insert_Internal (Target, Before => Before, New_Node => Tgt_Pos); + + if Source.Length = 1 then + pragma Assert (Source.First = Source.Last); + pragma Assert (Src_Pos = Source.First); + + Source.First := 0; + Source.Last := 0; + + elsif Src_Pos = Source.First then + pragma Assert (N (N (Src_Pos).Next).Prev = Src_Pos); + + Source.First := N (Src_Pos).Next; + N (Source.First).Prev := 0; + + elsif Src_Pos = Source.Last then + pragma Assert (N (N (Src_Pos).Prev).Next = Src_Pos); + + Source.Last := N (Src_Pos).Prev; + N (Source.Last).Next := 0; + + else + pragma Assert (Source.Length >= 3); + pragma Assert (N (N (Src_Pos).Next).Prev = Src_Pos); + pragma Assert (N (N (Src_Pos).Prev).Next = Src_Pos); + + N (N (Src_Pos).Next).Prev := N (Src_Pos).Prev; + N (N (Src_Pos).Prev).Next := N (Src_Pos).Next; + end if; + + Source.Length := Source.Length - 1; + Free (Source, Src_Pos); + end Splice_Internal; + ---------- -- Swap -- ---------- @@ -2283,7 +2551,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Assert (N (Position.Node).Prev /= 0); - -- ELiminate another possibility + -- Eliminate another possibility if Position.Node = L.Last then return True; diff --git a/gcc/ada/a-cbdlli.ads b/gcc/ada/a-cbdlli.ads index a8a6ee228f1..291c1e0eb72 100644 --- a/gcc/ada/a-cbdlli.ads +++ b/gcc/ada/a-cbdlli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -34,6 +34,7 @@ with Ada.Iterator_Interfaces; private with Ada.Streams; +private with Ada.Finalization; generic type Element_Type is private; @@ -248,6 +249,7 @@ private pragma Inline (Previous); use Ada.Streams; + use Ada.Finalization; type Node_Type is record Prev : Count_Type'Base; @@ -334,4 +336,24 @@ private No_Element : constant Cursor := Cursor'(null, 0); + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Count_Type; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Bounded_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb index 314bed6142d..f4a953c1401 100644 --- a/gcc/ada/a-cbhama.adb +++ b/gcc/ada/a-cbhama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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,26 +34,11 @@ with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; -with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Hashed_Maps is - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Forward_Iterator with - record - Container : Map_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- diff --git a/gcc/ada/a-cbhama.ads b/gcc/ada/a-cbhama.ads index 71ec0e3d956..076fac240e1 100644 --- a/gcc/ada/a-cbhama.ads +++ b/gcc/ada/a-cbhama.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -35,6 +35,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; private with Ada.Streams; +private with Ada.Finalization; generic type Key_Type is private; @@ -339,6 +340,7 @@ private use HT_Types; use Ada.Streams; + use Ada.Finalization; procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -412,5 +414,18 @@ private (Hash_Table_Type with Capacity => 0, Modulus => 0); No_Element : constant Cursor := (Container => null, Node => 0); + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; end Ada.Containers.Bounded_Hashed_Maps; diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index cc60762ed15..99efc1dcf79 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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,26 +34,11 @@ with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; -with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Hashed_Sets is - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Forward_Iterator with - record - Container : Set_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- diff --git a/gcc/ada/a-cbhase.ads b/gcc/ada/a-cbhase.ads index ed47b798683..5de5d2832ec 100644 --- a/gcc/ada/a-cbhase.ads +++ b/gcc/ada/a-cbhase.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -35,6 +35,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; private with Ada.Streams; +private with Ada.Finalization; use Ada.Finalization; generic type Element_Type is private; @@ -537,4 +538,18 @@ private No_Element : constant Cursor := (Container => null, Node => 0); + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with + record + Container : Set_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Bounded_Hashed_Sets; diff --git a/gcc/ada/a-cborma.adb b/gcc/ada/a-cborma.adb index 8fca6495dc5..f508fc5642c 100644 --- a/gcc/ada/a-cborma.adb +++ b/gcc/ada/a-cborma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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,32 +35,10 @@ with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); -with Ada.Finalization; use Ada.Finalization; - with System; use type System.Address; package body Ada.Containers.Bounded_Ordered_Maps is - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Reversible_Iterator with - record - Container : Map_Access; - Node : Count_Type; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------------- -- Node Access Subprograms -- ----------------------------- diff --git a/gcc/ada/a-cborma.ads b/gcc/ada/a-cborma.ads index 6ade3e6c474..2c2a8a50e1b 100644 --- a/gcc/ada/a-cborma.ads +++ b/gcc/ada/a-cborma.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -35,6 +35,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Red_Black_Trees; private with Ada.Streams; +private with Ada.Finalization; generic type Key_Type is private; @@ -315,4 +316,26 @@ private No_Element : constant Cursor := Cursor'(null, 0); + use Ada.Finalization; + + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Count_Type; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Bounded_Ordered_Maps; diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb index 3131de13700..baeedba6534 100644 --- a/gcc/ada/a-cborse.adb +++ b/gcc/ada/a-cborse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -38,32 +38,10 @@ with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); -with Ada.Finalization; use Ada.Finalization; - with System; use type System.Address; package body Ada.Containers.Bounded_Ordered_Sets is - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Reversible_Iterator with - record - Container : Set_Access; - Node : Count_Type; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ------------------------------ -- Access to Fields of Node -- ------------------------------ @@ -979,6 +957,9 @@ package body Ada.Containers.Bounded_Ordered_Sets is pragma Assert (Vet (Container, Position.Node), "bad cursor in Update_Element_Preserving_Key"); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare N : Node_Type renames Container.Nodes (Position.Node); E : Element_Type renames N.Element; @@ -987,12 +968,15 @@ package body Ada.Containers.Bounded_Ordered_Sets is B : Natural renames Container.Busy; L : Natural renames Container.Lock; + Eq : Boolean; + begin B := B + 1; L := L + 1; begin Process (E); + Eq := Equivalent_Keys (K, Key (E)); exception when others => L := L - 1; @@ -1003,7 +987,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is L := L - 1; B := B - 1; - if Equivalent_Keys (K, Key (E)) then + if Eq then return; end if; end; @@ -1727,16 +1711,54 @@ package body Ada.Containers.Bounded_Ordered_Sets is Hint : Count_Type; Result : Count_Type; Inserted : Boolean; + Compare : Boolean; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; -- Start of processing for Replace_Element begin - if Item < Node.Element - or else Node.Element < Item - then - null; + -- Replace_Element assigns value Item to the element designated by Node, + -- per certain semantic constraints, described as follows. + + -- If Item is equivalent to the element, then element is replaced and + -- there's nothing else to do. This is the easy case. + + -- If Item is not equivalent, then the node will (possibly) have to move + -- to some other place in the tree. This is slighly more complicated, + -- because we must ensure that Item is not equivalent to some other + -- element in the tree (in which case, the replacement is not allowed). + + -- Determine whether Item is equivalent to element on the specified + -- node. + + begin + B := B + 1; + L := L + 1; + + Compare := (if Item < Node.Element then False + elsif Node.Element < Item then False + else True); + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + if Compare then + + -- Item is equivalent to the node's element, so we will not have to + -- move the node. - else if Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (set is locked)"; @@ -1746,12 +1768,67 @@ package body Ada.Containers.Bounded_Ordered_Sets is return; end if; + -- The replacement Item is not equivalent to the element on the + -- specified node, which means that it will need to be re-inserted in a + -- different position in the tree. We must now determine whether Item is + -- equivalent to some other element in the tree (which would prohibit + -- the assignment and hence the move). + + -- Ceiling returns the smallest element equivalent or greater than the + -- specified Item; if there is no such element, then it returns 0. + Hint := Element_Keys.Ceiling (Container, Item); - if Hint = 0 then - null; + if Hint /= 0 then -- Item <= Nodes (Hint).Element + begin + B := B + 1; + L := L + 1; + + Compare := Item < Nodes (Hint).Element; + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + -- Item is equivalent to Nodes (Hint).Element + + if not Compare then + + -- Ceiling returns an element that is equivalent or greater than + -- Item. If Item is "not less than" the element, then by + -- elimination we know that Item is equivalent to the element. + + -- But this means that it is not possible to assign the value of + -- Item to the specified element (on Node), because a different + -- element (on Hint) equivalent to Item already exsits. (Were we + -- to change Node's element value, we would have to move Node, but + -- we would be unable to move the Node, because its new position + -- in the tree is already occupied by an equivalent element.) + + raise Program_Error with "attempt to replace existing element"; + end if; + + -- Item is not equivalent to any other element in the tree + -- (specifically, it is less than Nodes (Hint).Element), so it is + -- safe to assign the value of Item to Node.Element. This means that + -- the node will have to move to a different position in the tree + -- (because its element will have a different value). + + -- The nearest (greater) neighbor of Item is Hint. This will be the + -- insertion position of Node (because its element will have Item as + -- its new value). + + -- If Node equals Hint, the relative position of Node does not + -- change. This allows us to perform an optimization: we need not + -- remove Node from the tree and then reinsert it with its new value, + -- because it would only be placed in the exact same position. - elsif Item < Nodes (Hint).Element then if Hint = Index then if Container.Lock > 0 then raise Program_Error with @@ -1761,12 +1838,14 @@ package body Ada.Containers.Bounded_Ordered_Sets is Node.Element := Item; return; end if; - - else - pragma Assert (not (Nodes (Hint).Element < Item)); - raise Program_Error with "attempt to replace existing element"; end if; + -- If we get here, it is because Item was greater than all elements in + -- the tree (Hint = 0), or because Item was less than some element at a + -- different place in the tree (Item < Nodes (Hint).Element and Hint /= + -- Index). In either case, we remove Node from the tree and then insert + -- Item into the tree, onto the same Node. + Tree_Operations.Delete_Node_Sans_Free (Container, Index); Local_Insert_With_Hint diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads index 16263577389..d22ef54b21b 100644 --- a/gcc/ada/a-cborse.ads +++ b/gcc/ada/a-cborse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -35,6 +35,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Red_Black_Trees; private with Ada.Streams; +private with Ada.Finalization; generic type Element_Type is private; @@ -374,4 +375,26 @@ private No_Element : constant Cursor := Cursor'(null, 0); + use Ada.Finalization; + + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Count_Type; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Bounded_Ordered_Sets; diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index 8234f327eb1..9bd8899e2dd 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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,26 +33,6 @@ with System; use type System.Address; package body Ada.Containers.Doubly_Linked_Lists is - type Iterator is new Limited_Controlled and - List_Iterator_Interfaces.Reversible_Iterator with - record - Container : List_Access; - Node : Node_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -64,6 +44,17 @@ package body Ada.Containers.Doubly_Linked_Lists is Before : Node_Access; New_Node : Node_Access); + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List); + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List; + Position : Node_Access); + function Vet (Position : Cursor) return Boolean; -- Checks invariants of the cursor and its designated container, as a -- simple way of detecting dangling references (see operation Free for a @@ -76,8 +67,15 @@ package body Ada.Containers.Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is - L : Node_Access := Left.First; - R : Node_Access := Right.First; + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + L : Node_Access; + R : Node_Access; + Result : Boolean; begin if Left'Address = Right'Address then @@ -88,16 +86,45 @@ package body Ada.Containers.Doubly_Linked_Lists is return False; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L := Left.First; + R := Right.First; + Result := True; for J in 1 .. Left.Length loop if L.Element /= R.Element then - return False; + Result := False; + exit; end if; L := L.Next; R := R.Next; end loop; - return True; + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; end "="; ------------ @@ -358,6 +385,8 @@ package body Ada.Containers.Doubly_Linked_Lists is Free (X); end loop; + -- The following comment is unacceptable, more detail needed ??? + Position := No_Element; -- Post-York behavior end Delete; @@ -386,7 +415,7 @@ package body Ada.Containers.Doubly_Linked_Lists is "attempt to tamper with cursors (list is busy)"; end if; - for I in 1 .. Count loop + for J in 1 .. Count loop X := Container.First; pragma Assert (X.Next.Prev = Container.First); @@ -424,7 +453,7 @@ package body Ada.Containers.Doubly_Linked_Lists is "attempt to tamper with cursors (list is busy)"; end if; - for I in 1 .. Count loop + for J in 1 .. Count loop X := Container.Last; pragma Assert (X.Prev.Next = Container.Last); @@ -446,11 +475,11 @@ package body Ada.Containers.Doubly_Linked_Lists is if Position.Node = null then raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Element"); + else + pragma Assert (Vet (Position), "bad cursor in Element"); - return Position.Node.Element; + return Position.Node.Element; + end if; end Element; -------------- @@ -503,20 +532,55 @@ package body Ada.Containers.Doubly_Linked_Lists is if Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; + else + pragma Assert (Vet (Position), "bad cursor in Find"); end if; - - pragma Assert (Vet (Position), "bad cursor in Find"); end if; - while Node /= null loop - if Node.Element = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - Node := Node.Next; - end loop; + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Node_Access; + + begin + B := B + 1; + L := L + 1; + + pragma Warnings (Off); + -- Deal with junk infinite loop warning from below loop + + Result := null; + while Node /= null loop + if Node.Element = Item then + Result := Node; + exit; + else + Node := Node.Next; + end if; + end loop; + + pragma Warnings (On); + -- End of section dealing with junk infinite loop warning + + B := B - 1; + L := L - 1; + + if Result = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); + end if; - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Find; ----------- @@ -527,9 +591,9 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Container.First = null then return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.First); end if; - - return Cursor'(Container'Unrestricted_Access, Container.First); end First; function First (Object : Iterator) return Cursor is @@ -562,9 +626,9 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Container.First = null then raise Constraint_Error with "list is empty"; + else + return Container.First.Element; end if; - - return Container.First.Element; end First_Element; ---------- @@ -573,7 +637,8 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Free (X : in out Node_Access) is procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin -- While a node is in use, as an active link in a list, its Previous and -- Next components must be null, or designate a different node; this is @@ -606,18 +671,40 @@ package body Ada.Containers.Doubly_Linked_Lists is --------------- function Is_Sorted (Container : List) return Boolean is - Node : Node_Access := Container.First; + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Node : Node_Access; + Result : Boolean; begin - for I in 2 .. Container.Length loop + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Node := Container.First; + Result := True; + for Idx in 2 .. Container.Length loop if Node.Next.Element < Node.Element then - return False; + Result := False; + exit; end if; Node := Node.Next; end loop; - return True; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Is_Sorted; ----------- @@ -628,10 +715,7 @@ package body Ada.Containers.Doubly_Linked_Lists is (Target : in out List; Source : in out List) is - LI, RI : Cursor; - begin - -- The semantics of Merge changed slightly per AI05-0021. It was -- originally the case that if Target and Source denoted the same -- container object, then the GNAT implementation of Merge did @@ -649,6 +733,10 @@ package body Ada.Containers.Doubly_Linked_Lists is "Target and Source denote same non-empty container"; end if; + if Target.Length > Count_Type'Last - Source.Length then + raise Constraint_Error with "new length exceeds maximum"; + end if; + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; @@ -659,35 +747,65 @@ package body Ada.Containers.Doubly_Linked_Lists is "attempt to tamper with cursors of Source (list is busy)"; end if; - LI := First (Target); - RI := First (Source); - while RI.Node /= null loop - pragma Assert (RI.Node.Next = null - or else not (RI.Node.Next.Element < - RI.Node.Element)); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if LI.Node = null then - Splice (Target, No_Element, Source); - return; - end if; + declare + TB : Natural renames Target.Busy; + TL : Natural renames Target.Lock; - pragma Assert (LI.Node.Next = null - or else not (LI.Node.Next.Element < - LI.Node.Element)); + SB : Natural renames Source.Busy; + SL : Natural renames Source.Lock; - if RI.Node.Element < LI.Node.Element then - declare - RJ : Cursor := RI; - pragma Warnings (Off, RJ); - begin - RI.Node := RI.Node.Next; - Splice (Target, LI, Source, RJ); - end; + LI, RI, RJ : Node_Access; - else - LI.Node := LI.Node.Next; - end if; - end loop; + begin + TB := TB + 1; + TL := TL + 1; + + SB := SB + 1; + SL := SL + 1; + + LI := Target.First; + RI := Source.First; + while RI /= null loop + pragma Assert (RI.Next = null + or else not (RI.Next.Element < RI.Element)); + + if LI = null then + Splice_Internal (Target, null, Source); + exit; + end if; + + pragma Assert (LI.Next = null + or else not (LI.Next.Element < LI.Element)); + + if RI.Element < LI.Element then + RJ := RI; + RI := RI.Next; + Splice_Internal (Target, LI, Source, RJ); + + else + LI := LI.Next; + end if; + end loop; + + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + exception + when others => + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + raise; + end; end Merge; ---------- @@ -705,9 +823,10 @@ package body Ada.Containers.Doubly_Linked_Lists is --------------- procedure Partition (Pivot : Node_Access; Back : Node_Access) is - Node : Node_Access := Pivot.Next; + Node : Node_Access; begin + Node := Pivot.Next; while Node /= Back loop if Node.Element < Pivot.Element then declare @@ -773,7 +892,28 @@ package body Ada.Containers.Doubly_Linked_Lists is "attempt to tamper with cursors (list is busy)"; end if; - Sort (Front => null, Back => null); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + Sort (Front => null, Back => null); + + B := B - 1; + L := L - 1; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); @@ -809,34 +949,33 @@ package body Ada.Containers.Doubly_Linked_Lists is if Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong list"; + else + pragma Assert (Vet (Before), "bad cursor in Insert"); end if; - - pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then Position := Before; return; - end if; - if Container.Length > Count_Type'Last - Count then + elsif Container.Length > Count_Type'Last - Count then raise Constraint_Error with "new length exceeds maximum"; - end if; - if Container.Busy > 0 then + elsif Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; - end if; - - New_Node := new Node_Type'(New_Item, null, null); - Insert_Internal (Container, Before.Node, New_Node); - Position := Cursor'(Container'Unchecked_Access, New_Node); - - for J in Count_Type'(2) .. Count loop + else New_Node := new Node_Type'(New_Item, null, null); Insert_Internal (Container, Before.Node, New_Node); - end loop; + + Position := Cursor'(Container'Unchecked_Access, New_Node); + + for J in 2 .. Count loop + New_Node := new Node_Type'(New_Item, null, null); + Insert_Internal (Container, Before.Node, New_Node); + end loop; + end if; end Insert; procedure Insert @@ -864,9 +1003,9 @@ package body Ada.Containers.Doubly_Linked_Lists is if Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong list"; + else + pragma Assert (Vet (Before), "bad cursor in Insert"); end if; - - pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then @@ -876,22 +1015,22 @@ package body Ada.Containers.Doubly_Linked_Lists is if Container.Length > Count_Type'Last - Count then raise Constraint_Error with "new length exceeds maximum"; - end if; - if Container.Busy > 0 then + elsif Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; - end if; - New_Node := new Node_Type; - Insert_Internal (Container, Before.Node, New_Node); - - Position := Cursor'(Container'Unchecked_Access, New_Node); - - for J in Count_Type'(2) .. Count loop + else New_Node := new Node_Type; Insert_Internal (Container, Before.Node, New_Node); - end loop; + + Position := Cursor'(Container'Unchecked_Access, New_Node); + + for J in 2 .. Count loop + New_Node := new Node_Type; + Insert_Internal (Container, Before.Node, New_Node); + end loop; + end if; end Insert; --------------------- @@ -996,9 +1135,9 @@ package body Ada.Containers.Doubly_Linked_Lists is -- for a reverse iterator, Container.Last is the beginning. return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => null) + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) do B := B + 1; end return; @@ -1024,31 +1163,31 @@ package body Ada.Containers.Doubly_Linked_Lists is if Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; - end if; - if Start.Container /= Container'Unrestricted_Access then + elsif Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong list"; - end if; - pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is non-null (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this - -- is a forward or reverse iteration. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - B := B + 1; - end return; + else + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the + -- First and Last selector functions of the iterator object. When + -- the Node component is non-null (as is the case here), it means + -- that this is a partial iteration, over a subset of the complete + -- sequence of items. The iterator object was constructed with + -- a start expression, indicating the position from which the + -- iteration begins. Note that the start position has the same value + -- irrespective of whether this is a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; + end if; end Iterate; ---------- @@ -1059,9 +1198,9 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Container.Last = null then return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.Last); end if; - - return Cursor'(Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is @@ -1094,9 +1233,9 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Container.Last = null then raise Constraint_Error with "list is empty"; + else + return Container.Last.Element; end if; - - return Container.Last.Element; end Last_Element; ------------ @@ -1119,23 +1258,23 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Target'Address = Source'Address then return; - end if; - if Source.Busy > 0 then + elsif Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; - end if; - Clear (Target); + else + Clear (Target); - Target.First := Source.First; - Source.First := null; + Target.First := Source.First; + Source.First := null; - Target.Last := Source.Last; - Source.Last := null; + Target.Last := Source.Last; + Source.Last := null; - Target.Length := Source.Length; - Source.Length := 0; + Target.Length := Source.Length; + Source.Length := 0; + end if; end Move; ---------- @@ -1151,20 +1290,20 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Node = null then return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in Next"); - - declare - Next_Node : constant Node_Access := Position.Node.Next; - begin - if Next_Node = null then - return No_Element; - end if; + else + pragma Assert (Vet (Position), "bad cursor in Next"); - return Cursor'(Position.Container, Next_Node); - end; + declare + Next_Node : constant Node_Access := Position.Node.Next; + begin + if Next_Node = null then + return No_Element; + else + return Cursor'(Position.Container, Next_Node); + end if; + end; + end if; end Next; function Next @@ -1174,14 +1313,12 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong list"; + else + return Next (Position); end if; - - return Next (Position); end Next; ------------- @@ -1210,20 +1347,20 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Node = null then return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in Previous"); - declare - Prev_Node : constant Node_Access := Position.Node.Prev; - - begin - if Prev_Node = null then - return No_Element; - end if; + else + pragma Assert (Vet (Position), "bad cursor in Previous"); - return Cursor'(Position.Container, Prev_Node); - end; + declare + Prev_Node : constant Node_Access := Position.Node.Prev; + begin + if Prev_Node = null then + return No_Element; + else + return Cursor'(Position.Container, Prev_Node); + end if; + end; + end if; end Previous; function Previous @@ -1233,14 +1370,12 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong list"; + else + return Previous (Position); end if; - - return Previous (Position); end Previous; ------------------- @@ -1369,28 +1504,28 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unchecked_Access then + elsif Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - pragma Assert (Vet (Position), "bad cursor in function Reference"); + else + pragma Assert (Vet (Position), "bad cursor in function Reference"); - declare - C : List renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; + declare + C : List renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; + end if; end Reference; --------------------- @@ -1405,21 +1540,20 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unchecked_Access then + elsif Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - if Container.Lock > 0 then + elsif Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (list is locked)"; - end if; - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + else + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - Position.Node.Element := New_Item; + Position.Node.Element := New_Item; + end if; end Replace_Element; ---------------------- @@ -1528,20 +1662,49 @@ package body Ada.Containers.Doubly_Linked_Lists is if Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; + else + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; - - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); end if; - while Node /= null loop - if Node.Element = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - Node := Node.Prev; - end loop; + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Node_Access; + + begin + B := B + 1; + L := L + 1; + + Result := null; + while Node /= null loop + if Node.Element = Item then + Result := Node; + exit; + end if; + + Node := Node.Prev; + end loop; + + B := B - 1; + L := L - 1; - return No_Element; + if Result = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); + end if; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Reverse_Find; --------------------- @@ -1565,7 +1728,6 @@ package body Ada.Containers.Doubly_Linked_Lists is Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Prev; end loop; - exception when others => B := B - 1; @@ -1589,73 +1751,28 @@ package body Ada.Containers.Doubly_Linked_Lists is if Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; + else + pragma Assert (Vet (Before), "bad cursor in Splice"); end if; - - pragma Assert (Vet (Before), "bad cursor in Splice"); end if; - if Target'Address = Source'Address - or else Source.Length = 0 - then + if Target'Address = Source'Address or else Source.Length = 0 then return; - end if; - - pragma Assert (Source.First.Prev = null); - pragma Assert (Source.Last.Next = null); - if Target.Length > Count_Type'Last - Source.Length then + elsif Target.Length > Count_Type'Last - Source.Length then raise Constraint_Error with "new length exceeds maximum"; - end if; - if Target.Busy > 0 then + elsif Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; - end if; - if Source.Busy > 0 then + elsif Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; - end if; - - if Target.Length = 0 then - pragma Assert (Target.First = null); - pragma Assert (Target.Last = null); - pragma Assert (Before = No_Element); - - Target.First := Source.First; - Target.Last := Source.Last; - - elsif Before.Node = null then - pragma Assert (Target.Last.Next = null); - - Target.Last.Next := Source.First; - Source.First.Prev := Target.Last; - - Target.Last := Source.Last; - - elsif Before.Node = Target.First then - pragma Assert (Target.First.Prev = null); - - Source.Last.Next := Target.First; - Target.First.Prev := Source.Last; - - Target.First := Source.First; else - pragma Assert (Target.Length >= 2); - - Before.Node.Prev.Next := Source.First; - Source.First.Prev := Before.Node.Prev; - - Before.Node.Prev := Source.Last; - Source.Last.Next := Before.Node; + Splice_Internal (Target, Before.Node, Source); end if; - - Source.First := null; - Source.Last := null; - - Target.Length := Target.Length + Source.Length; - Source.Length := 0; end Splice; procedure Splice @@ -1668,9 +1785,9 @@ package body Ada.Containers.Doubly_Linked_Lists is if Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor designates wrong container"; + else + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - - pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = null then @@ -1776,40 +1893,124 @@ package body Ada.Containers.Doubly_Linked_Lists is if Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; + else + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; - - pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Source'Unrestricted_Access then + elsif Position.Container /= Source'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - pragma Assert (Vet (Position), "bad Position cursor in Splice"); + else + pragma Assert (Vet (Position), "bad Position cursor in Splice"); - if Target.Length = Count_Type'Last then - raise Constraint_Error with "Target is full"; - end if; + if Target.Length = Count_Type'Last then + raise Constraint_Error with "Target is full"; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; + elsif Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Target (list is busy)"; + + elsif Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors of Source (list is busy)"; + + else + Splice_Internal (Target, Before.Node, Source, Position.Node); + Position.Container := Target'Unchecked_Access; + end if; end if; + end Splice; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; + --------------------- + -- Splice_Internal -- + --------------------- + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List) + is + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted, and corner-cases disposed of. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= null); + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last /= null); + pragma Assert (Source.Last.Next = null); + pragma Assert (Target.Length <= Count_Type'Last - Source.Length); + + if Target.Length = 0 then + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + pragma Assert (Before = null); + + Target.First := Source.First; + Target.Last := Source.Last; + + elsif Before = null then + pragma Assert (Target.Last.Next = null); + + Target.Last.Next := Source.First; + Source.First.Prev := Target.Last; + + Target.Last := Source.Last; + + elsif Before = Target.First then + pragma Assert (Target.First.Prev = null); + + Source.Last.Next := Target.First; + Target.First.Prev := Source.Last; + + Target.First := Source.First; + + else + pragma Assert (Target.Length >= 2); + + Before.Prev.Next := Source.First; + Source.First.Prev := Before.Prev; + + Before.Prev := Source.Last; + Source.Last.Next := Before; end if; - if Position.Node = Source.First then - Source.First := Position.Node.Next; + Source.First := null; + Source.Last := null; + + Target.Length := Target.Length + Source.Length; + Source.Length := 0; + end Splice_Internal; - if Position.Node = Source.Last then + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; -- node of Target + Source : in out List; + Position : Node_Access) -- node of Source + is + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Target.Length < Count_Type'Last); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= null); + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last /= null); + pragma Assert (Source.Last.Next = null); + pragma Assert (Position /= null); + + if Position = Source.First then + Source.First := Position.Next; + + if Position = Source.Last then pragma Assert (Source.First = null); pragma Assert (Source.Length = 1); Source.Last := null; @@ -1818,58 +2019,56 @@ package body Ada.Containers.Doubly_Linked_Lists is Source.First.Prev := null; end if; - elsif Position.Node = Source.Last then + elsif Position = Source.Last then pragma Assert (Source.Length >= 2); - Source.Last := Position.Node.Prev; + Source.Last := Position.Prev; Source.Last.Next := null; else pragma Assert (Source.Length >= 3); - Position.Node.Prev.Next := Position.Node.Next; - Position.Node.Next.Prev := Position.Node.Prev; + Position.Prev.Next := Position.Next; + Position.Next.Prev := Position.Prev; end if; if Target.Length = 0 then pragma Assert (Target.First = null); pragma Assert (Target.Last = null); - pragma Assert (Before = No_Element); + pragma Assert (Before = null); - Target.First := Position.Node; - Target.Last := Position.Node; + Target.First := Position; + Target.Last := Position; Target.First.Prev := null; Target.Last.Next := null; - elsif Before.Node = null then + elsif Before = null then pragma Assert (Target.Last.Next = null); - Target.Last.Next := Position.Node; - Position.Node.Prev := Target.Last; + Target.Last.Next := Position; + Position.Prev := Target.Last; - Target.Last := Position.Node; + Target.Last := Position; Target.Last.Next := null; - elsif Before.Node = Target.First then + elsif Before = Target.First then pragma Assert (Target.First.Prev = null); - Target.First.Prev := Position.Node; - Position.Node.Next := Target.First; + Target.First.Prev := Position; + Position.Next := Target.First; - Target.First := Position.Node; + Target.First := Position; Target.First.Prev := null; else pragma Assert (Target.Length >= 2); - Before.Node.Prev.Next := Position.Node; - Position.Node.Prev := Before.Node.Prev; + Before.Prev.Next := Position; + Position.Prev := Before.Prev; - Before.Node.Prev := Position.Node; - Position.Node.Next := Before.Node; + Before.Prev := Position; + Position.Next := Before; end if; Target.Length := Target.Length + 1; Source.Length := Source.Length - 1; - - Position.Container := Target'Unchecked_Access; - end Splice; + end Splice_Internal; ---------- -- Swap -- @@ -1995,35 +2194,35 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Node = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unchecked_Access then + elsif Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; + else + pragma Assert (Vet (Position), "bad cursor in Update_Element"); - begin - B := B + 1; - L := L + 1; + declare + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin - Process (Position.Node.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + B := B + 1; + L := L + 1; - L := L - 1; - B := B - 1; - end; + begin + Process (Position.Node.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end if; end Update_Element; --------- @@ -2090,8 +2289,7 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; pragma Assert - (Position.Node.Prev /= null - or else Position.Node = L.First); + (Position.Node.Prev /= null or else Position.Node = L.First); if Position.Node.Next = null and then Position.Node /= L.Last then return False; diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index d1707c757a2..c99e7350afc 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -358,4 +358,24 @@ private No_Element : constant Cursor := Cursor'(null, null); + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Node_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Doubly_Linked_Lists; diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb index ee9484077de..34668bdd2d5 100644 --- a/gcc/ada/a-cfdlli.adb +++ b/gcc/ada/a-cfdlli.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- -- @@ -26,30 +26,9 @@ ------------------------------------------------------------------------------ with System; use type System.Address; -with Ada.Finalization; package body Ada.Containers.Formal_Doubly_Linked_Lists is - type Iterator is new Ada.Finalization.Limited_Controlled and - List_Iterator_Interfaces.Reversible_Iterator with - record - Container : List_Access; - Node : Count_Type; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -197,8 +176,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is if Container.Length = 0 then pragma Assert (Container.First = 0); pragma Assert (Container.Last = 0); - pragma Assert (Container.Busy = 0); - pragma Assert (Container.Lock = 0); return; end if; @@ -207,11 +184,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; - while Container.Length > 1 loop X := Container.First; @@ -318,11 +290,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; - for Index in 1 .. Count loop pragma Assert (Container.Length >= 2); @@ -371,11 +338,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; - for J in 1 .. Count loop X := Container.First; pragma Assert (N (N (X).Next).Prev = Container.First); @@ -410,11 +372,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; - for J in 1 .. Count loop X := Container.Last; pragma Assert (N (N (X).Prev).Next = Container.Last); @@ -445,21 +402,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return Container.Nodes (Position.Node).Element; end Element; - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - declare - B : Natural renames Object.Container.all.Busy; - begin - B := B - 1; - end; - end if; - end Finalize; - ---------- -- Find -- ---------- @@ -511,28 +453,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return (Node => Container.First); end First; - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First, for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = 0 then - return First (Object.Container.all); - else - return (Node => Object.Node); - end if; - end First; - ------------------- -- First_Element -- ------------------- @@ -634,16 +554,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - LI := First (Target); RI := First (Source); while RI.Node /= 0 loop @@ -760,11 +670,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; - Sort (Front => 0, Back => 0); pragma Assert (N (Container.First).Prev = 0); @@ -813,11 +718,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is raise Constraint_Error with "new length exceeds capacity"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; - Allocate (Container, New_Item, New_Node => J); Insert_Internal (Container, Before.Node, New_Node => J); Position := (Node => J); @@ -861,11 +761,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is raise Constraint_Error with "new length exceeds capacity"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; - Allocate (Container, New_Node => J); Insert_Internal (Container, Before.Node, New_Node => J); Position := (Node => J); @@ -940,103 +835,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return Length (Container) = 0; end Is_Empty; - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : List; - Process : - not null access procedure (Container : List; Position : Cursor)) - is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - Node : Count_Type; - - begin - B := B + 1; - - begin - Node := Container.First; - while Node /= 0 loop - Process (Container, (Node => Node)); - Node := Container.Nodes (Node).Next; - end loop; - - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - - function Iterate (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'Class - is - B : Natural renames Container'Unrestricted_Access.all.Busy; - - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is null (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a - -- complete iterator, meaning that the iteration starts from the - -- (logical) beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - Iterator'(Ada.Finalization.Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => 0) - do - B := B + 1; - end return; - end Iterate; - - function Iterate (Container : List; Start : Cursor) - return List_Iterator_Interfaces.Reversible_Iterator'Class - is - B : Natural renames Container'Unrestricted_Access.all.Busy; - - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if not Has_Element (Container, Start) then - raise Constraint_Error with - "Start position for iterator is not a valid cursor"; - end if; - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is non-null (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this - -- is a forward or reverse iteration. - - return It : constant Iterator := - Iterator'(Ada.Finalization.Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - B := B + 1; - end return; - end Iterate; - ---------- -- Last -- ---------- @@ -1049,28 +847,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return (Node => Container.Last); end Last; - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = 0 then - return Last (Object.Container.all); - else - return (Node => Object.Node); - end if; - end Last; - ------------------ -- Last_Element -- ------------------ @@ -1142,11 +918,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is "Source length exceeds Target capacity"; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - Clear (Target); while Source.Length > 1 loop @@ -1229,23 +1000,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return (Node => Container.Nodes (Position.Node).Next); end Next; - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - return Next (Object.Container.all, Position); - end Next; - - -------------------- - -- Not_No_Element -- - -------------------- - - function Not_No_Element (Position : Cursor) return Boolean is - begin - return Position /= No_Element; - end Not_No_Element; - ------------- -- Prepend -- ------------- @@ -1281,106 +1035,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return (Node => Container.Nodes (Position.Node).Prev); end Previous; - function Previous - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - return Previous (Object.Container.all, Position); - end Previous; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : List; Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames C.Nodes (Position.Node); - begin - Process (N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out List) - is - N : Count_Type'Base; - - begin - Clear (Item); - - Count_Type'Base'Read (Stream, N); - - if N < 0 then - raise Program_Error with "bad list length"; - end if; - - if N = 0 then - return; - end if; - - if N > Item.Capacity then - raise Constraint_Error with "length exceeds capacity"; - end if; - - for J in 1 .. N loop - Item.Append (Element_Type'Input (Stream)); -- ??? - end loop; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream list cursor"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Constant_Reference - (Container : List; - Position : Cursor) return Constant_Reference_Type - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return (Element => Container.Nodes (Position.Node).Element'Access); - end Constant_Reference; - --------------------- -- Replace_Element -- --------------------- @@ -1395,11 +1049,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is raise Constraint_Error with "Position cursor has no element"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is locked)"; - end if; - pragma Assert (Vet (Container, Position), "bad cursor in Replace_Element"); @@ -1465,11 +1114,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is pragma Assert (N (Container.First).Prev = 0); pragma Assert (N (Container.Last).Next = 0); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; - Container.First := J; Container.Last := I; loop @@ -1524,39 +1168,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return No_Element; end Reverse_Find; - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : List; - Process : - not null access procedure (Container : List; Position : Cursor)) - is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - - Node : Count_Type; - - begin - B := B + 1; - - begin - Node := Container.Last; - while Node /= 0 loop - Process (Container, (Node => Node)); - Node := Container.Nodes (Node).Prev; - end loop; - - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Reverse_Iterate; - ----------- -- Right -- ----------- @@ -1618,16 +1229,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is raise Constraint_Error; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - loop Insert (Target, Before, SN (Source.Last).Element); Delete_Last (Source); @@ -1659,16 +1260,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is raise Constraint_Error; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Target (list is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - Insert (Container => Target, Before => Before, @@ -1707,11 +1298,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is pragma Assert (Container.Length >= 2); - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; - if Before.Node = 0 then pragma Assert (Position.Node /= Container.Last); @@ -1821,11 +1407,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (list is locked)"; - end if; - pragma Assert (Vet (Container, I), "bad I cursor in Swap"); pragma Assert (Vet (Container, J), "bad J cursor in Swap"); @@ -1865,11 +1446,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (list is busy)"; - end if; - pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links"); pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links"); @@ -1892,47 +1468,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is end if; end Swap_Links; - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out List; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in Update_Element"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - Process (N.Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Update_Element; - --------- -- Vet -- --------- @@ -2068,33 +1603,4 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is return True; end Vet; - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : List) - is - N : Node_Array renames Item.Nodes; - Node : Count_Type; - - begin - Count_Type'Base'Write (Stream, Item.Length); - - Node := Item.First; - while Node /= 0 loop - Element_Type'Write (Stream, N (Node).Element); - Node := N (Node).Next; - end loop; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream list cursor"; - end Write; - end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads index 67ff3af8f48..1078c1f5a34 100644 --- a/gcc/ada/a-cfdlli.ads +++ b/gcc/ada/a-cfdlli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -49,11 +49,7 @@ -- function Left (Container : List; Position : Cursor) return List; -- function Right (Container : List; Position : Cursor) return List; --- See detailed specifications for these subprograms - -private with Ada.Streams; -with Ada.Containers; -with Ada.Iterator_Interfaces; +-- See subprogram specifications that follow for details generic type Element_Type is private; @@ -64,11 +60,8 @@ generic package Ada.Containers.Formal_Doubly_Linked_Lists is pragma Pure; - type List (Capacity : Count_Type) is tagged private with - Constant_Indexing => Constant_Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - -- pragma Preelaborable_Initialization (List); + type List (Capacity : Count_Type) is private; + pragma Preelaborable_Initialization (List); type Cursor is private; pragma Preelaborable_Initialization (Cursor); @@ -77,17 +70,6 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is No_Element : constant Cursor; - function Not_No_Element (Position : Cursor) return Boolean; - - package List_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor => Cursor, Has_Element => Not_No_Element); - - function Iterate (Container : List; Start : Cursor) - return List_Iterator_Interfaces.Reversible_Iterator'Class; - - function Iterate (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'Class; - function "=" (Left, Right : List) return Boolean; function Length (Container : List) return Count_Type; @@ -107,15 +89,6 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is Position : Cursor; New_Item : Element_Type); - procedure Query_Element - (Container : List; Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out List; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - procedure Move (Target : in out List; Source : in out List); procedure Insert @@ -218,16 +191,6 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is function Has_Element (Container : List; Position : Cursor) return Boolean; - procedure Iterate - (Container : List; - Process : - not null access procedure (Container : List; Position : Cursor)); - - procedure Reverse_Iterate - (Container : List; - Process : - not null access procedure (Container : List; Position : Cursor)); - generic with function "<" (Left, Right : Element_Type) return Boolean is <>; package Generic_Sorting is @@ -240,15 +203,6 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is end Generic_Sorting; - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : List; -- SHOULD BE ALIASED ??? - Position : Cursor) return Constant_Reference_Type; - function Strict_Equal (Left, Right : List) return Boolean; -- Strict_Equal returns True if the containers are physically equal, i.e. -- they are structurally equal (function "=" returns True) and that they @@ -268,7 +222,7 @@ private type Node_Type is record Prev : Count_Type'Base := -1; Next : Count_Type; - Element : aliased Element_Type; + Element : Element_Type; end record; function "=" (L, R : Node_Type) return Boolean is abstract; @@ -279,49 +233,15 @@ private type List (Capacity : Count_Type) is tagged record Nodes : Node_Array (1 .. Capacity) := (others => <>); Free : Count_Type'Base := -1; - Busy : Natural := 0; - Lock : Natural := 0; Length : Count_Type := 0; First : Count_Type := 0; Last : Count_Type := 0; end record; - use Ada.Streams; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out List); - - for List'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : List); - - for List'Write use Write; - - type List_Access is access all List; - for List_Access'Storage_Size use 0; - type Cursor is record Node : Count_Type := 0; end record; - type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - Empty_List : constant List := (0, others => <>); No_Element : constant Cursor := (Node => 0); diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb index c692cb66674..fc5c986ec2a 100644 --- a/gcc/ada/a-cfhama.adb +++ b/gcc/ada/a-cfhama.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- -- @@ -159,8 +159,6 @@ package body Ada.Containers.Formal_Hashed_Maps is "Source length exceeds Target capacity"; end if; - -- Check busy bits - Clear (Target); Insert_Elements (Source); @@ -266,11 +264,6 @@ package body Ada.Containers.Formal_Hashed_Maps is "Position cursor of Delete has no element"; end if; - if Container.Busy > 0 then - raise Program_Error with - "Delete attempted to tamper with elements (map is busy)"; - end if; - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); @@ -495,10 +488,6 @@ package body Ada.Containers.Formal_Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "Include attempted to tamper with cursors (map is locked)"; - end if; declare N : Node_Type renames Container.Nodes (Position.Node); @@ -516,54 +505,6 @@ package body Ada.Containers.Formal_Hashed_Maps is procedure Insert (Container : in out Map; Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean) - is - procedure Assign_Key (Node : in out Node_Type); - pragma Inline (Assign_Key); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new Generic_Allocate (Assign_Key); - - ----------------- - -- Assign_Key -- - ----------------- - - procedure Assign_Key (Node : in out Node_Type) is - begin - Node.Key := Key; - - -- What is following commented out line doing here ??? - -- Node.Element := New_Item; - end Assign_Key; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - -- Start of processing for Insert - - begin - - Local_Insert (Container, Key, Position.Node, Inserted); - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; New_Item : Element_Type; Position : out Cursor; Inserted : out Boolean) @@ -635,47 +576,6 @@ package body Ada.Containers.Formal_Hashed_Maps is return Length (Container) = 0; end Is_Empty; - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Map; - Process : not null - access procedure (Container : Map; Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of processing for Iterate - - begin - B := B + 1; - - begin - Local_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - --------- -- Key -- --------- @@ -752,11 +652,6 @@ package body Ada.Containers.Formal_Hashed_Maps is "Source length exceeds Target capacity"; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - Clear (Target); if Source.Length = 0 then @@ -849,105 +744,6 @@ package body Ada.Containers.Formal_Hashed_Maps is return False; end Overlap; - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : Element_Type)) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Query_Element has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Query_Element"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames N.Key; - E : Element_Type renames N.Element; - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map) - is - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Count_Type; - - procedure Read_Nodes is - new HT_Ops.Generic_Read (Read_Node); - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Count_Type - is - procedure Read_Element (Node : in out Node_Type); - pragma Inline (Read_Element); - - procedure Allocate is - new Generic_Allocate (Read_Element); - - procedure Read_Element (Node : in out Node_Type) is - begin - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - Node : Count_Type; - - -- Start of processing for Read_Node - - begin - Allocate (Container, Node); - return Node; - end Read_Node; - - -- Start of processing for Read - - begin - Read_Nodes (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - ------------- -- Replace -- ------------- @@ -965,11 +761,6 @@ package body Ada.Containers.Formal_Hashed_Maps is "attempt to replace key not in map"; end if; - if Container.Lock > 0 then - raise Program_Error with - "Replace attempted to tamper with cursors (map is locked)"; - end if; - declare N : Node_Type renames Container.Nodes (Node); begin @@ -993,11 +784,6 @@ package body Ada.Containers.Formal_Hashed_Maps is "Position cursor of Replace_Element has no element"; end if; - if Container.Lock > 0 then - raise Program_Error with - "Replace_Element attempted to tamper with cursors (map is locked)"; - end if; - pragma Assert (Vet (Container, Position), "bad cursor in Replace_Element"); @@ -1085,52 +871,6 @@ package body Ada.Containers.Formal_Hashed_Maps is return True; end Strict_Equal; - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Update_Element has no element"; - end if; - - pragma Assert (Vet (Container, Position), - "bad cursor in Update_Element"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames Container.Nodes (Position.Node); - K : Key_Type renames N.Key; - E : Element_Type renames N.Element; - - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Update_Element; - --------- -- Vet -- --------- @@ -1191,46 +931,4 @@ package body Ada.Containers.Formal_Hashed_Maps is end; end Vet; - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Node); - - procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Key_Type'Write (Stream, Node.Key); - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write_Nodes (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Write; - end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/a-cfhama.ads index c076d4072d5..fdbd7a0a8a4 100644 --- a/gcc/ada/a-cfhama.ads +++ b/gcc/ada/a-cfhama.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -52,7 +52,6 @@ -- See detailed specifications for these subprograms private with Ada.Containers.Hash_Tables; -private with Ada.Streams; generic type Key_Type is private; @@ -87,14 +86,15 @@ package Ada.Containers.Formal_Hashed_Maps is function Is_Empty (Container : Map) return Boolean; - -- ??? what does clear do to active elements? procedure Clear (Container : in out Map); procedure Assign (Target : in out Map; Source : Map); - -- ??? - -- capacity=0 means use container.length as cap of tgt - -- modulos=0 means use default_modulous(container.length) + -- Copy returns a container stricty equal to Source + -- It must have the same cursors associated to each element + -- Therefore: + -- - capacity=0 means use container.capacity as cap of tgt + -- - the modulus cannot be changed. function Copy (Source : Map; Capacity : Count_Type := 0) return Map; @@ -108,18 +108,6 @@ package Ada.Containers.Formal_Hashed_Maps is Position : Cursor; New_Item : Element_Type); - procedure Query_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : Element_Type)); - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : in out Element_Type)); - procedure Move (Target : in out Map; Source : in out Map); procedure Insert @@ -132,12 +120,6 @@ package Ada.Containers.Formal_Hashed_Maps is procedure Insert (Container : in out Map; Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Map; - Key : Key_Type; New_Item : Element_Type); procedure Include @@ -186,11 +168,6 @@ package Ada.Containers.Formal_Hashed_Maps is Right : Map; CRight : Cursor) return Boolean; - procedure Iterate - (Container : Map; - Process : not null access - procedure (Container : Map; Position : Cursor)); - function Default_Modulus (Capacity : Count_Type) return Hash_Type; function Strict_Equal (Left, Right : Map) return Boolean; @@ -237,39 +214,11 @@ private new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; use HT_Types; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map); - - for Map'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map); - - for Map'Read use Read; - - type Map_Access is access all Map; - for Map_Access'Storage_Size use 0; type Cursor is record Node : Count_Type; end record; - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>); No_Element : constant Cursor := (Node => 0); diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb index d5d73e2a1e8..539a0a88fe6 100644 --- a/gcc/ada/a-cfhase.adb +++ b/gcc/ada/a-cfhase.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- -- @@ -295,11 +295,6 @@ package body Ada.Containers.Formal_Hashed_Sets is raise Constraint_Error with "Position cursor has no element"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - end if; - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); @@ -333,11 +328,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - end if; - if Src_Length >= Target.Length then Tgt_Node := HT_Ops.First (Target); while Tgt_Node /= 0 loop @@ -572,9 +562,6 @@ package body Ada.Containers.Formal_Hashed_Sets is end; end Equivalent_Elements; - -- What does the following comment signify??? - -- NOT MODIFIED - --------------------- -- Equivalent_Keys -- --------------------- @@ -700,10 +687,6 @@ package body Ada.Containers.Formal_Hashed_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; Container.Nodes (Position.Node).Element := New_Item; end if; @@ -804,11 +787,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - end if; - Tgt_Node := HT_Ops.First (Target); while Tgt_Node /= 0 loop if Find (Source, TN (Tgt_Node).Element).Node /= 0 then @@ -930,48 +908,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return True; end Is_Subset; - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : - not null access procedure (Container : Set; Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of processing for Iterate - - begin - B := B + 1; - - begin - Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - ---------- -- Left -- ---------- @@ -1029,11 +965,6 @@ package body Ada.Containers.Formal_Hashed_Sets is "Source length exceeds Target capacity"; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - Clear (Target); if Source.Length = 0 then @@ -1117,103 +1048,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return False; end Overlap; - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Query_Element has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Query_Element"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (Container.Nodes (Position.Node).Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Count_Type; - - procedure Read_Nodes is - new HT_Ops.Generic_Read (Read_Node); - - --------------- - -- Read_Node -- - --------------- - - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Count_Type - is - procedure Read_Element (Node : in out Node_Type); - pragma Inline (Read_Element); - - procedure Allocate is new Generic_Allocate (Read_Element); - - ------------------ - -- Read_Element -- - ------------------ - - procedure Read_Element (Node : in out Node_Type) is - begin - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - Node : Count_Type; - - -- Start of processing for Read_Node - - begin - Allocate (Container, Node); - return Node; - end Read_Node; - - -- Start of processing for Read - - begin - Read_Nodes (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - ------------- -- Replace -- ------------- @@ -1230,11 +1064,6 @@ package body Ada.Containers.Formal_Hashed_Sets is "attempt to replace element not in set"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - Container.Nodes (Node).Element := New_Item; end Replace; @@ -1391,11 +1220,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - end if; - Iterate (Source); end Symmetric_Difference; @@ -1475,10 +1299,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - end if; Iterate (Source); end Union; @@ -1557,47 +1377,6 @@ package body Ada.Containers.Formal_Hashed_Sets is end; end Vet; - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Node); - - procedure Write_Nodes is - new HT_Ops.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write_Nodes (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; package body Generic_Keys is ----------------------- @@ -1752,90 +1531,6 @@ package body Ada.Containers.Formal_Hashed_Sets is Replace_Element (Container, Node, New_Item); end Replace; - ----------------------------------- - -- Update_Element_Preserving_Key -- - ----------------------------------- - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)) - is - Indx : Hash_Type; - N : Nodes_Type renames Container.Nodes; - - begin - if Position.Node = 0 then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), - "bad cursor in Update_Element_Preserving_Key"); - - -- Record bucket now, in case key is changed - - Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); - - declare - E : Element_Type renames N (Position.Node).Element; - K : constant Key_Type := Key (E); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - - if Equivalent_Keys (K, Key (E)) then - pragma Assert (Hash (K) = Hash (E)); - return; - end if; - end; - - -- Key was modified, so remove this node from set - - if Container.Buckets (Indx) = Position.Node then - Container.Buckets (Indx) := N (Position.Node).Next; - - else - declare - Prev : Count_Type := Container.Buckets (Indx); - - begin - while N (Prev).Next /= Position.Node loop - Prev := N (Prev).Next; - - if Prev = 0 then - raise Program_Error with - "Position cursor is bad (node not found)"; - end if; - end loop; - - N (Prev).Next := N (Position.Node).Next; - end; - end if; - - Container.Length := Container.Length - 1; - Free (Container, Position.Node); - - raise Program_Error with "key was modified"; - end Update_Element_Preserving_Key; - end Generic_Keys; end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads index ad6c72fe151..a9278dcdbf0 100644 --- a/gcc/ada/a-cfhase.ads +++ b/gcc/ada/a-cfhase.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -52,7 +52,6 @@ -- See detailed specifications for these subprograms private with Ada.Containers.Hash_Tables; -private with Ada.Streams; generic type Element_Type is private; @@ -68,8 +67,7 @@ package Ada.Containers.Formal_Hashed_Sets is pragma Pure; type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private; - -- why is this commented out ??? - -- pragma Preelaborable_Initialization (Set); + pragma Preelaborable_Initialization (Set); type Cursor is private; pragma Preelaborable_Initialization (Cursor); @@ -108,11 +106,6 @@ package Ada.Containers.Formal_Hashed_Sets is Position : Cursor; New_Item : Element_Type); - procedure Query_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - procedure Move (Target : in out Set; Source : in out Set); procedure Insert @@ -187,11 +180,6 @@ package Ada.Containers.Formal_Hashed_Sets is (Left : Element_Type; Right : Set; CRight : Cursor) return Boolean; - procedure Iterate - (Container : Set; - Process : - not null access procedure (Container : Set; Position : Cursor)); - function Default_Modulus (Capacity : Count_Type) return Hash_Type; generic @@ -222,12 +210,6 @@ package Ada.Containers.Formal_Hashed_Sets is function Contains (Container : Set; Key : Key_Type) return Boolean; - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - end Generic_Keys; function Strict_Equal (Left, Right : Set) return Boolean; @@ -262,38 +244,13 @@ private new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; use HT_Types; - use Ada.Streams; type Cursor is record Node : Count_Type; end record; - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - No_Element : constant Cursor := (Node => 0); - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - Empty_Set : constant Set := (Capacity => 0, Modulus => 0, others => <>); end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb index 6b45ad60369..ac763918283 100644 --- a/gcc/ada/a-cforma.adb +++ b/gcc/ada/a-cforma.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- -- @@ -558,11 +558,6 @@ package body Ada.Containers.Formal_Ordered_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (map is locked)"; - end if; - declare N : Node_Type renames Container.Nodes (Position.Node); begin @@ -635,56 +630,6 @@ package body Ada.Containers.Formal_Ordered_Maps is end if; end Insert; - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node return Node_Access; - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - procedure Initialize (Node : in out Node_Type); - procedure Allocate_Node is new Generic_Allocate (Initialize); - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Node : in out Node_Type) is - begin - Node.Key := Key; - end Initialize; - - X : Node_Access; - - -- Start of processing for New_Node - - begin - Allocate_Node (Container, X); - return X; - end New_Node; - - -- Start of processing for Insert - - begin - Insert_Sans_Hint (Container, Key, Position.Node, Inserted); - end Insert; - -------------- -- Is_Empty -- -------------- @@ -720,48 +665,6 @@ package body Ada.Containers.Formal_Ordered_Maps is return Left < Right.Key; end Is_Less_Key_Node; - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Map; - Process : - not null access procedure (Container : Map; Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of processing for Iterate - - begin - B := B + 1; - - begin - Local_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - --------- -- Key -- --------- @@ -881,11 +784,6 @@ package body Ada.Containers.Formal_Ordered_Maps is "Source length exceeds Target capacity"; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - Clear (Target); loop @@ -1014,93 +912,6 @@ package body Ada.Containers.Formal_Ordered_Maps is end; end Previous; - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : Element_Type)) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Query_Element has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor of Query_Element is bad"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames Container.Nodes (Position.Node); - K : Key_Type renames N.Key; - E : Element_Type renames N.Element; - - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map) - is - procedure Read_Element (Node : in out Node_Type); - pragma Inline (Read_Element); - - procedure Allocate is - new Generic_Allocate (Read_Element); - - procedure Read_Elements is - new Tree_Operations.Generic_Read (Allocate); - - ------------------ - -- Read_Element -- - ------------------ - - procedure Read_Element (Node : in out Node_Type) is - begin - Key_Type'Read (Stream, Node.Key); - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - -- Start of processing for Read - - begin - Read_Elements (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Read; - ------------- -- Replace -- ------------- @@ -1119,11 +930,6 @@ package body Ada.Containers.Formal_Ordered_Maps is raise Constraint_Error with "key not in map"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (map is locked)"; - end if; - declare N : Node_Type renames Container.Nodes (Node); begin @@ -1148,59 +954,12 @@ package body Ada.Containers.Formal_Ordered_Maps is "Position cursor of Replace_Element has no element"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (map is locked)"; - end if; - pragma Assert (Vet (Container, Position.Node), "Position cursor of Replace_Element is bad"); Container.Nodes (Position.Node).Element := New_Item; end Replace_Element; - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Map; - Process : not null access procedure (Container : Map; - Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of processing for Reverse_Iterate - - begin - B := B + 1; - - begin - Local_Reverse_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Reverse_Iterate; - ----------- -- Right -- ----------- @@ -1305,93 +1064,4 @@ package body Ada.Containers.Formal_Ordered_Maps is return False; end Strict_Equal; - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Update_Element has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor of Update_Element is bad"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames Container.Nodes (Position.Node); - K : Key_Type renames N.Key; - E : Element_Type renames N.Element; - - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Node); - - procedure Write_Nodes is - new Tree_Operations.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Key_Type'Write (Stream, Node.Key); - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write_Nodes (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Write; - end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/a-cforma.ads b/gcc/ada/a-cforma.ads index 145ff513d3d..c96fee02d51 100644 --- a/gcc/ada/a-cforma.ads +++ b/gcc/ada/a-cforma.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -54,7 +54,6 @@ -- See detailed specifications for these subprograms private with Ada.Containers.Red_Black_Trees; -private with Ada.Streams; generic type Key_Type is private; @@ -99,18 +98,6 @@ package Ada.Containers.Formal_Ordered_Maps is Position : Cursor; New_Item : Element_Type); - procedure Query_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : Element_Type)); - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : in out Element_Type)); - procedure Move (Target : in out Map; Source : in out Map); procedure Insert @@ -123,12 +110,6 @@ package Ada.Containers.Formal_Ordered_Maps is procedure Insert (Container : in out Map; Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Map; - Key : Key_Type; New_Item : Element_Type); procedure Include @@ -183,16 +164,6 @@ package Ada.Containers.Formal_Ordered_Maps is function Has_Element (Container : Map; Position : Cursor) return Boolean; - procedure Iterate - (Container : Map; - Process : - not null access procedure (Container : Map; Position : Cursor)); - - procedure Reverse_Iterate - (Container : Map; - Process : not null access - procedure (Container : Map; Position : Cursor)); - function Strict_Equal (Left, Right : Map) return Boolean; -- Strict_Equal returns True if the containers are physically equal, i.e. -- they are structurally equal (function "=" returns True) and that they @@ -234,38 +205,12 @@ private type Map (Capacity : Count_Type) is new Tree_Types.Tree_Type (Capacity) with null record; - use Ada.Streams; - type Cursor is record Node : Node_Access; end record; - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; + Empty_Map : constant Map := (Capacity => 0, others => <>); No_Element : constant Cursor := (Node => 0); - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map); - - for Map'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map); - - for Map'Read use Read; - - Empty_Map : constant Map := (Capacity => 0, others => <>); - end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb index 0707d74d0e8..22e92220b9d 100644 --- a/gcc/ada/a-cforse.adb +++ b/gcc/ada/a-cforse.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- -- @@ -807,64 +807,6 @@ package body Ada.Containers.Formal_Ordered_Sets is end if; end Replace; - ----------------------------------- - -- Update_Element_Preserving_Key -- - ----------------------------------- - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Update_Element_Preserving_Key"); - - declare - N : Tree_Types.Nodes_Type renames Container.Nodes; - - E : Element_Type renames N (Position.Node).Element; - K : constant Key_Type := Key (E); - - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - - if Equivalent_Keys (K, Key (E)) then - return; - end if; - end; - - declare - X : constant Count_Type := Position.Node; - begin - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Sets.Free (Container, X); - end; - - raise Program_Error with "key was modified"; - end Update_Element_Preserving_Key; - end Generic_Keys; ----------------- @@ -892,11 +834,6 @@ package body Ada.Containers.Formal_Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - declare N : Tree_Types.Nodes_Type renames Container.Nodes; begin @@ -1122,50 +1059,6 @@ package body Ada.Containers.Formal_Ordered_Sets is return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set); end Is_Subset; - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : not null access procedure (Container : Set; - Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - -- Local variables - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of prccessing for Iterate - - begin - B := B + 1; - - begin - Local_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - ---------- -- Last -- ---------- @@ -1257,11 +1150,6 @@ package body Ada.Containers.Formal_Ordered_Sets is "Source length exceeds Target capacity"; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - Clear (Target); loop @@ -1347,85 +1235,6 @@ package body Ada.Containers.Formal_Ordered_Sets is Position := Previous (Container, Position); end Previous; - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Query_Element"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (Container.Nodes (Position.Node).Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - procedure Read_Element (Node : in out Node_Type); - pragma Inline (Read_Element); - - procedure Allocate is - new Generic_Allocate (Read_Element); - - procedure Read_Elements is - new Tree_Operations.Generic_Read (Allocate); - - ------------------ - -- Read_Element -- - ------------------ - - procedure Read_Element (Node : in out Node_Type) is - begin - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - -- Start of processing for Read - - begin - Read_Elements (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - ------------- -- Replace -- ------------- @@ -1439,11 +1248,6 @@ package body Ada.Containers.Formal_Ordered_Sets is "attempt to replace element not in set"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - Container.Nodes (Node).Element := New_Item; end Replace; @@ -1502,11 +1306,6 @@ package body Ada.Containers.Formal_Ordered_Sets is null; else - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - NN (Node).Element := Item; return; end if; @@ -1518,11 +1317,6 @@ package body Ada.Containers.Formal_Ordered_Sets is elsif Item < NN (Hint).Element then if Hint = Node then - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - NN (Node).Element := Item; return; end if; @@ -1532,7 +1326,7 @@ package body Ada.Containers.Formal_Ordered_Sets is raise Program_Error with "attempt to replace existing element"; end if; - Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); Local_Insert_With_Hint (Tree => Tree, @@ -1562,48 +1356,6 @@ package body Ada.Containers.Formal_Ordered_Sets is Replace_Element (Container, Position.Node, New_Item); end Replace_Element; - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Container : Set; - Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of processing for Reverse_Iterate - - begin - B := B + 1; - - begin - Local_Reverse_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Reverse_Iterate; - ----------- -- Right -- ----------- @@ -1781,46 +1533,4 @@ package body Ada.Containers.Formal_Ordered_Sets is end return; end Union; - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - procedure Write_Element - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Element); - - procedure Write_Elements is - new Tree_Operations.Generic_Write (Write_Element); - - ------------------- - -- Write_Element -- - ------------------- - - procedure Write_Element - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Element_Type'Write (Stream, Node.Element); - end Write_Element; - - -- Start of processing for Write - - begin - Write_Elements (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; - end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads index 03203cdbd7b..77862a6df34 100644 --- a/gcc/ada/a-cforse.ads +++ b/gcc/ada/a-cforse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -53,7 +53,6 @@ -- See detailed specifications for these subprograms private with Ada.Containers.Red_Black_Trees; -private with Ada.Streams; generic type Element_Type is private; @@ -100,11 +99,6 @@ package Ada.Containers.Formal_Ordered_Sets is Position : Cursor; New_Item : Element_Type); - procedure Query_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - procedure Move (Target : in out Set; Source : in out Set); procedure Insert @@ -195,16 +189,6 @@ package Ada.Containers.Formal_Ordered_Sets is function Has_Element (Container : Set; Position : Cursor) return Boolean; - procedure Iterate - (Container : Set; - Process : - not null access procedure (Container : Set; Position : Cursor)); - - procedure Reverse_Iterate - (Container : Set; - Process : not null access - procedure (Container : Set; Position : Cursor)); - generic type Key_Type (<>) is private; @@ -237,12 +221,6 @@ package Ada.Containers.Formal_Ordered_Sets is function Contains (Container : Set; Key : Key_Type) return Boolean; - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - end Generic_Keys; function Strict_Equal (Left, Right : Set) return Boolean; @@ -280,41 +258,13 @@ private new Tree_Types.Tree_Type (Capacity) with null record; use Red_Black_Trees; - use Ada.Streams; - - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; type Cursor is record Node : Count_Type; end record; - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - No_Element : constant Cursor := (Node => 0); - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - Empty_Set : constant Set := (Capacity => 0, others => <>); end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index 7d5e22ee80e..04d0597a22c 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -36,26 +36,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is new Limited_Controlled and - List_Iterator_Interfaces.Reversible_Iterator with - record - Container : List_Access; - Node : Node_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -67,6 +47,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Before : Node_Access; New_Node : Node_Access); + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List); + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List; + Position : Node_Access); + function Vet (Position : Cursor) return Boolean; -- Checks invariants of the cursor and its designated container, as a -- simple way of detecting dangling references (see operation Free for a @@ -79,8 +70,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is --------- function "=" (Left, Right : List) return Boolean is - L : Node_Access; - R : Node_Access; + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + L : Node_Access; + R : Node_Access; + Result : Boolean; begin if Left'Address = Right'Address then @@ -91,18 +89,45 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return False; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + L := Left.First; R := Right.First; + Result := True; for J in 1 .. Left.Length loop if L.Element.all /= R.Element.all then - return False; + Result := False; + exit; end if; L := L.Next; R := R.Next; end loop; - return True; + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; end "="; ------------ @@ -203,15 +228,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Target'Address = Source'Address then return; - end if; - Target.Clear; + else + Target.Clear; - Node := Source.First; - while Node /= null loop - Target.Append (Node.Element.all); - Node := Node.Next; - end loop; + Node := Source.First; + while Node /= null loop + Target.Append (Node.Element.all); + Node := Node.Next; + end loop; + end if; end Assign; ----------- @@ -272,32 +298,30 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - - if Position.Node.Element = null then + elsif Position.Node.Element = null then raise Program_Error with "Node has no element"; - end if; - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + else + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - declare - C : List renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; + declare + C : List renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; + end if; end Constant_Reference; -------------- @@ -390,6 +414,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Free (X); end loop; + -- Fix this junk comment ??? + Position := No_Element; -- Post-York behavior end Delete; @@ -407,28 +433,27 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Count >= Container.Length then Clear (Container); return; - end if; - if Count = 0 then + elsif Count = 0 then return; - end if; - if Container.Busy > 0 then + elsif Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; - end if; - for I in 1 .. Count loop - X := Container.First; - pragma Assert (X.Next.Prev = Container.First); + else + for J in 1 .. Count loop + X := Container.First; + pragma Assert (X.Next.Prev = Container.First); - Container.First := X.Next; - Container.First.Prev := null; + Container.First := X.Next; + Container.First.Prev := null; - Container.Length := Container.Length - 1; + Container.Length := Container.Length - 1; - Free (X); - end loop; + Free (X); + end loop; + end if; end Delete_First; ----------------- @@ -445,28 +470,27 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Count >= Container.Length then Clear (Container); return; - end if; - if Count = 0 then + elsif Count = 0 then return; - end if; - if Container.Busy > 0 then + elsif Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (list is busy)"; - end if; - for I in 1 .. Count loop - X := Container.Last; - pragma Assert (X.Prev.Next = Container.Last); + else + for J in 1 .. Count loop + X := Container.Last; + pragma Assert (X.Prev.Next = Container.Last); - Container.Last := X.Prev; - Container.Last.Next := null; + Container.Last := X.Prev; + Container.Last.Next := null; - Container.Length := Container.Length - 1; + Container.Length := Container.Length - 1; - Free (X); - end loop; + Free (X); + end loop; + end if; end Delete_Last; ------------- @@ -478,16 +502,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Position.Node = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Node.Element = null then + elsif Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; - end if; - pragma Assert (Vet (Position), "bad cursor in Element"); + else + pragma Assert (Vet (Position), "bad cursor in Element"); - return Position.Node.Element.all; + return Position.Node.Element.all; + end if; end Element; -------------- @@ -539,25 +563,54 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is else if Node.Element = null then raise Program_Error; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - pragma Assert (Vet (Position), "bad cursor in Find"); + else + pragma Assert (Vet (Position), "bad cursor in Find"); + end if; end if; - while Node /= null loop - if Node.Element.all = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - Node := Node.Next; - end loop; + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Node_Access; + + begin + B := B + 1; + L := L + 1; + + Result := null; + while Node /= null loop + if Node.Element.all = Item then + Result := Node; + exit; + end if; - return No_Element; + Node := Node.Next; + end loop; + + B := B - 1; + L := L - 1; + + if Result = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); + end if; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Find; ----------- @@ -568,9 +621,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Container.First = null then return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.First); end if; - - return Cursor'(Container'Unrestricted_Access, Container.First); end First; function First (Object : Iterator) return Cursor is @@ -603,9 +656,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Container.First = null then raise Constraint_Error with "list is empty"; + else + return Container.First.Element.all; end if; - - return Container.First.Element.all; end First_Element; ---------- @@ -660,18 +713,40 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is --------------- function Is_Sorted (Container : List) return Boolean is - Node : Node_Access := Container.First; + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Node : Node_Access; + Result : Boolean; begin - for I in 2 .. Container.Length loop + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Node := Container.First; + Result := True; + for J in 2 .. Container.Length loop if Node.Next.Element.all < Node.Element.all then - return False; + Result := False; + exit; end if; Node := Node.Next; end loop; - return True; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Is_Sorted; ----------- @@ -682,10 +757,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Target : in out List; Source : in out List) is - LI, RI : Cursor; - begin - -- The semantics of Merge changed slightly per AI05-0021. It was -- originally the case that if Target and Source denoted the same -- container object, then the GNAT implementation of Merge did @@ -696,52 +768,81 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Source.Is_Empty then return; - end if; - if Target'Address = Source'Address then + elsif Target'Address = Source'Address then raise Program_Error with "Target and Source denote same non-empty container"; - end if; - if Target.Busy > 0 then + elsif Target.Length > Count_Type'Last - Source.Length then + raise Constraint_Error with "new length exceeds maximum"; + + elsif Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; - end if; - if Source.Busy > 0 then + elsif Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; end if; - LI := First (Target); - RI := First (Source); - while RI.Node /= null loop - pragma Assert (RI.Node.Next = null - or else not (RI.Node.Next.Element.all < - RI.Node.Element.all)); + declare + TB : Natural renames Target.Busy; + TL : Natural renames Target.Lock; - if LI.Node = null then - Splice (Target, No_Element, Source); - return; - end if; + SB : Natural renames Source.Busy; + SL : Natural renames Source.Lock; - pragma Assert (LI.Node.Next = null - or else not (LI.Node.Next.Element.all < - LI.Node.Element.all)); + LI, RI, RJ : Node_Access; - if RI.Node.Element.all < LI.Node.Element.all then - declare - RJ : Cursor := RI; - pragma Warnings (Off, RJ); - begin - RI.Node := RI.Node.Next; - Splice (Target, LI, Source, RJ); - end; + begin + TB := TB + 1; + TL := TL + 1; + + SB := SB + 1; + SL := SL + 1; + + LI := Target.First; + RI := Source.First; + while RI /= null loop + pragma Assert (RI.Next = null + or else not (RI.Next.Element.all < + RI.Element.all)); + + if LI = null then + Splice_Internal (Target, null, Source); + exit; + end if; - else - LI.Node := LI.Node.Next; - end if; - end loop; + pragma Assert (LI.Next = null + or else not (LI.Next.Element.all < + LI.Element.all)); + + if RI.Element.all < LI.Element.all then + RJ := RI; + RI := RI.Next; + Splice_Internal (Target, LI, Source, RJ); + + else + LI := LI.Next; + end if; + end loop; + + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + exception + when others => + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + raise; + end; end Merge; ---------- @@ -750,22 +851,26 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Sort (Container : in out List) is procedure Partition (Pivot : Node_Access; Back : Node_Access); + -- Comment ??? procedure Sort (Front, Back : Node_Access); + -- Comment??? Confusing name??? change name??? --------------- -- Partition -- --------------- procedure Partition (Pivot : Node_Access; Back : Node_Access) is - Node : Node_Access := Pivot.Next; + Node : Node_Access; begin + Node := Pivot.Next; while Node /= Back loop if Node.Element.all < Pivot.Element.all then declare Prev : constant Node_Access := Node.Prev; Next : constant Node_Access := Node.Next; + begin Prev.Next := Next; @@ -825,7 +930,27 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is "attempt to tamper with cursors (list is busy)"; end if; - Sort (Front => null, Back => null); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + Sort (Front => null, Back => null); + + B := B - 1; + L := L - 1; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); @@ -861,16 +986,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Before.Container /= Container'Unrestricted_Access then raise Program_Error with "attempt to tamper with cursors (list is busy)"; - end if; - if Before.Node = null - or else Before.Node.Element = null - then + elsif Before.Node = null or else Before.Node.Element = null then raise Program_Error with "Before cursor has no element"; - end if; - pragma Assert (Vet (Before), "bad cursor in Insert"); + else + pragma Assert (Vet (Before), "bad cursor in Insert"); + end if; end if; if Count = 0 then @@ -910,8 +1033,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Insert_Internal (Container, Before.Node, New_Node); Position := Cursor'(Container'Unchecked_Access, New_Node); - for J in Count_Type'(2) .. Count loop - + for J in 2 .. Count loop declare Element : Element_Access := new Element_Type'(New_Item); begin @@ -1041,9 +1163,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is -- for a reverse iterator, Container.Last is the beginning. return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => null) + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) do B := B + 1; end return; @@ -1071,31 +1193,31 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Start = No_Element then raise Constraint_Error with "Start position for iterator equals No_Element"; - end if; - if Start.Container /= Container'Unrestricted_Access then + elsif Start.Container /= Container'Unrestricted_Access then raise Program_Error with "Start cursor of Iterate designates wrong list"; - end if; - - pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is non-null (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this - -- is a forward or reverse iteration. - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - B := B + 1; - end return; + else + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the + -- First and Last selector functions of the iterator object. When + -- the Node component is non-null (as is the case here), it means + -- that this is a partial iteration, over a subset of the complete + -- sequence of items. The iterator object was constructed with + -- a start expression, indicating the position from which the + -- iteration begins. Note that the start position has the same value + -- irrespective of whether this is a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; + end if; end Iterate; ---------- @@ -1106,9 +1228,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Container.Last = null then return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.Last); end if; - - return Cursor'(Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is @@ -1141,9 +1263,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Container.Last = null then raise Constraint_Error with "list is empty"; + else + return Container.Last.Element.all; end if; - - return Container.Last.Element.all; end Last_Element; ------------ @@ -1163,23 +1285,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Target'Address = Source'Address then return; - end if; - if Source.Busy > 0 then + elsif Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; - end if; - Clear (Target); + else + Clear (Target); - Target.First := Source.First; - Source.First := null; + Target.First := Source.First; + Source.First := null; - Target.Last := Source.Last; - Source.Last := null; + Target.Last := Source.Last; + Source.Last := null; - Target.Length := Source.Length; - Source.Length := 0; + Target.Length := Source.Length; + Source.Length := 0; + end if; end Move; ---------- @@ -1195,33 +1317,32 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Position.Node = null then return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in Next"); - declare - Next_Node : constant Node_Access := Position.Node.Next; - begin - if Next_Node = null then - return No_Element; - end if; + else + pragma Assert (Vet (Position), "bad cursor in Next"); - return Cursor'(Position.Container, Next_Node); - end; + declare + Next_Node : constant Node_Access := Position.Node.Next; + begin + if Next_Node = null then + return No_Element; + else + return Cursor'(Position.Container, Next_Node); + end if; + end; + end if; end Next; function Next (Object : Iterator; Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong list"; + else + return Next (Position); end if; - - return Next (Position); end Next; ------------- @@ -1250,33 +1371,32 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Position.Node = null then return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in Previous"); - declare - Prev_Node : constant Node_Access := Position.Node.Prev; - begin - if Prev_Node = null then - return No_Element; - end if; + else + pragma Assert (Vet (Position), "bad cursor in Previous"); - return Cursor'(Position.Container, Prev_Node); - end; + declare + Prev_Node : constant Node_Access := Position.Node.Prev; + begin + if Prev_Node = null then + return No_Element; + else + return Cursor'(Position.Container, Prev_Node); + end if; + end; + end if; end Previous; function Previous (Object : Iterator; Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong list"; + else + return Previous (Position); end if; - - return Previous (Position); end Previous; ------------------- @@ -1291,36 +1411,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Position.Node = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Node.Element = null then + elsif Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; - end if; - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + else + pragma Assert (Vet (Position), "bad cursor in Query_Element"); - begin - B := B + 1; - L := L + 1; + declare + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; begin - Process (Position.Node.Element.all); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + B := B + 1; + L := L + 1; - L := L - 1; - B := B - 1; - end; + begin + Process (Position.Node.Element.all); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; + end if; end Query_Element; ---------- @@ -1345,7 +1465,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is declare Element : Element_Access := - new Element_Type'(Element_Type'Input (Stream)); + new Element_Type'(Element_Type'Input (Stream)); begin Dst := new Node_Type'(Element, null, null); exception @@ -1361,7 +1481,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is while Item.Length < N loop declare Element : Element_Access := - new Element_Type'(Element_Type'Input (Stream)); + new Element_Type'(Element_Type'Input (Stream)); begin Dst := new Node_Type'(Element, Next => null, Prev => Item.Last); exception @@ -1411,32 +1531,31 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - if Position.Node.Element = null then + elsif Position.Node.Element = null then raise Program_Error with "Node has no element"; - end if; - pragma Assert (Vet (Position), "bad cursor in function Reference"); + else + pragma Assert (Vet (Position), "bad cursor in function Reference"); - declare - C : List renames Position.Container.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with Position.Container)) - do - B := B + 1; - L := L + 1; - end return; - end; + declare + C : List renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; + end if; end Reference; --------------------- @@ -1451,38 +1570,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unchecked_Access then + elsif Position.Container /= Container'Unchecked_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - if Container.Lock > 0 then + elsif Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (list is locked)"; - end if; - if Position.Node.Element = null then + elsif Position.Node.Element = null then raise Program_Error with "Position cursor has no element"; - end if; - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + else + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - declare - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). - pragma Unsuppress (Accessibility_Check); + pragma Unsuppress (Accessibility_Check); - X : Element_Access := Position.Node.Element; + X : Element_Access := Position.Node.Element; - begin - Position.Node.Element := new Element_Type'(New_Item); - Free (X); - end; + begin + Position.Node.Element := new Element_Type'(New_Item); + Free (X); + end; + end if; end Replace_Element; ---------------------- @@ -1590,25 +1707,54 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is else if Node.Element = null then raise Program_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor designates wrong container"; - end if; - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); + else + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); + end if; end if; - while Node /= null loop - if Node.Element.all = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - Node := Node.Prev; - end loop; + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Node_Access; + + begin + B := B + 1; + L := L + 1; + + Result := null; + while Node /= null loop + if Node.Element.all = Item then + Result := Node; + exit; + end if; + + Node := Node.Prev; + end loop; - return No_Element; + B := B - 1; + L := L - 1; + + if Result = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); + end if; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Reverse_Find; --------------------- @@ -1655,79 +1801,33 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Before.Container /= Target'Unrestricted_Access then raise Program_Error with "Before cursor designates wrong container"; - end if; - if Before.Node = null - or else Before.Node.Element = null - then + elsif Before.Node = null or else Before.Node.Element = null then raise Program_Error with "Before cursor has no element"; - end if; - pragma Assert (Vet (Before), "bad cursor in Splice"); + else + pragma Assert (Vet (Before), "bad cursor in Splice"); + end if; end if; - if Target'Address = Source'Address - or else Source.Length = 0 - then + if Target'Address = Source'Address or else Source.Length = 0 then return; - end if; - pragma Assert (Source.First.Prev = null); - pragma Assert (Source.Last.Next = null); - - if Target.Length > Count_Type'Last - Source.Length then + elsif Target.Length > Count_Type'Last - Source.Length then raise Constraint_Error with "new length exceeds maximum"; - end if; - if Target.Busy > 0 then + elsif Target.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Target (list is busy)"; - end if; - if Source.Busy > 0 then + elsif Source.Busy > 0 then raise Program_Error with "attempt to tamper with cursors of Source (list is busy)"; - end if; - - if Target.Length = 0 then - pragma Assert (Before = No_Element); - pragma Assert (Target.First = null); - pragma Assert (Target.Last = null); - - Target.First := Source.First; - Target.Last := Source.Last; - - elsif Before.Node = null then - pragma Assert (Target.Last.Next = null); - - Target.Last.Next := Source.First; - Source.First.Prev := Target.Last; - - Target.Last := Source.Last; - - elsif Before.Node = Target.First then - pragma Assert (Target.First.Prev = null); - - Source.Last.Next := Target.First; - Target.First.Prev := Source.Last; - - Target.First := Source.First; else - pragma Assert (Target.Length >= 2); - Before.Node.Prev.Next := Source.First; - Source.First.Prev := Before.Node.Prev; - - Before.Node.Prev := Source.Last; - Source.Last.Next := Before.Node; + Splice_Internal (Target, Before.Node, Source); end if; - - Source.First := null; - Source.Last := null; - - Target.Length := Target.Length + Source.Length; - Source.Length := 0; end Splice; procedure Splice @@ -1740,16 +1840,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Before.Container /= Container'Unchecked_Access then raise Program_Error with "Before cursor designates wrong container"; - end if; - if Before.Node = null - or else Before.Node.Element = null - then + elsif Before.Node = null or else Before.Node.Element = null then raise Program_Error with "Before cursor has no element"; - end if; - pragma Assert (Vet (Before), "bad Before cursor in Splice"); + else + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + end if; end if; if Position.Node = null then @@ -1901,10 +1999,94 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is "attempt to tamper with cursors of Source (list is busy)"; end if; - if Position.Node = Source.First then - Source.First := Position.Node.Next; + Splice_Internal (Target, Before.Node, Source, Position.Node); + Position.Container := Target'Unchecked_Access; + end Splice; - if Position.Node = Source.Last then + --------------------- + -- Splice_Internal -- + --------------------- + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List) + is + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted, and corner-cases disposed of. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= null); + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last /= null); + pragma Assert (Source.Last.Next = null); + pragma Assert (Target.Length <= Count_Type'Last - Source.Length); + + if Target.Length = 0 then + pragma Assert (Before = null); + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + + Target.First := Source.First; + Target.Last := Source.Last; + + elsif Before = null then + pragma Assert (Target.Last.Next = null); + + Target.Last.Next := Source.First; + Source.First.Prev := Target.Last; + + Target.Last := Source.Last; + + elsif Before = Target.First then + pragma Assert (Target.First.Prev = null); + + Source.Last.Next := Target.First; + Target.First.Prev := Source.Last; + + Target.First := Source.First; + + else + pragma Assert (Target.Length >= 2); + Before.Prev.Next := Source.First; + Source.First.Prev := Before.Prev; + + Before.Prev := Source.Last; + Source.Last.Next := Before; + end if; + + Source.First := null; + Source.Last := null; + + Target.Length := Target.Length + Source.Length; + Source.Length := 0; + end Splice_Internal; + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; -- node of Target + Source : in out List; + Position : Node_Access) -- node of Source + is + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Target.Length < Count_Type'Last); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= null); + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last /= null); + pragma Assert (Source.Last.Next = null); + pragma Assert (Position /= null); + + if Position = Source.First then + Source.First := Position.Next; + + if Position = Source.Last then pragma Assert (Source.First = null); pragma Assert (Source.Length = 1); Source.Last := null; @@ -1913,58 +2095,56 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Source.First.Prev := null; end if; - elsif Position.Node = Source.Last then + elsif Position = Source.Last then pragma Assert (Source.Length >= 2); - Source.Last := Position.Node.Prev; + Source.Last := Position.Prev; Source.Last.Next := null; else pragma Assert (Source.Length >= 3); - Position.Node.Prev.Next := Position.Node.Next; - Position.Node.Next.Prev := Position.Node.Prev; + Position.Prev.Next := Position.Next; + Position.Next.Prev := Position.Prev; end if; if Target.Length = 0 then - pragma Assert (Before = No_Element); + pragma Assert (Before = null); pragma Assert (Target.First = null); pragma Assert (Target.Last = null); - Target.First := Position.Node; - Target.Last := Position.Node; + Target.First := Position; + Target.Last := Position; Target.First.Prev := null; Target.Last.Next := null; - elsif Before.Node = null then + elsif Before = null then pragma Assert (Target.Last.Next = null); - Target.Last.Next := Position.Node; - Position.Node.Prev := Target.Last; + Target.Last.Next := Position; + Position.Prev := Target.Last; - Target.Last := Position.Node; + Target.Last := Position; Target.Last.Next := null; - elsif Before.Node = Target.First then + elsif Before = Target.First then pragma Assert (Target.First.Prev = null); - Target.First.Prev := Position.Node; - Position.Node.Next := Target.First; + Target.First.Prev := Position; + Position.Next := Target.First; - Target.First := Position.Node; + Target.First := Position; Target.First.Prev := null; else pragma Assert (Target.Length >= 2); - Before.Node.Prev.Next := Position.Node; - Position.Node.Prev := Before.Node.Prev; + Before.Prev.Next := Position; + Position.Prev := Before.Prev; - Before.Node.Prev := Position.Node; - Position.Node.Next := Before.Node; + Before.Prev := Position; + Position.Next := Before; end if; Target.Length := Target.Length + 1; Source.Length := Source.Length - 1; - - Position.Container := Target'Unchecked_Access; - end Splice; + end Splice_Internal; ---------- -- Swap -- diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index af57af11ae9..a7e133c303d 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -352,4 +352,24 @@ private No_Element : constant Cursor := Cursor'(null, null); + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Node_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 2d889cdfb1b..e3e3d5ee43d 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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,20 +45,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Free_Element is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Forward_Iterator with - record - Container : Map_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index feef181b65b..6e2df212a22 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -418,4 +418,18 @@ private No_Element : constant Cursor := (Container => null, Node => null); + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Indefinite_Hashed_Maps; diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index bae3ecc3897..7a70bf65a87 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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,20 +41,6 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Hashed_Sets is - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Forward_Iterator with - record - Container : Set_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads index b300186f6db..2c4dec59996 100644 --- a/gcc/ada/a-cihase.ads +++ b/gcc/ada/a-cihase.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -541,4 +541,18 @@ private No_Element : constant Cursor := (Container => null, Node => null); + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with + record + Container : Set_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Indefinite_Hashed_Sets; diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index 7f2b2491eeb..b836dc69fd0 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -40,26 +40,6 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Maps is pragma Suppress (All_Checks); - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Reversible_Iterator with - record - Container : Map_Access; - Node : Node_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------------- -- Node Access Subprograms -- ----------------------------- diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads index 5c3a776c4aa..e414d39cf71 100644 --- a/gcc/ada/a-ciorma.ads +++ b/gcc/ada/a-ciorma.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -353,4 +353,24 @@ private No_Element : constant Cursor := Cursor'(null, null); + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Node_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Indefinite_Ordered_Maps; diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb index 4fce4754c78..2bc1200014b 100644 --- a/gcc/ada/a-ciormu.adb +++ b/gcc/ada/a-ciormu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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,26 +42,6 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Multisets is - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Reversible_Iterator with - record - Container : Set_Access; - Node : Node_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------------- -- Node Access Subprograms -- ----------------------------- diff --git a/gcc/ada/a-ciormu.ads b/gcc/ada/a-ciormu.ads index cfd1676aa5f..575d5d8321e 100644 --- a/gcc/ada/a-ciormu.ads +++ b/gcc/ada/a-ciormu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -508,4 +508,24 @@ private Busy => 0, Lock => 0)); + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index a6538665a1b..2f8820cb952 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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,26 +42,6 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Sets is - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Reversible_Iterator with - record - Container : Set_Access; - Node : Node_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -494,14 +474,13 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Delete (Container : in out Set; Item : Element_Type) is X : Node_Access := Element_Keys.Find (Container.Tree, Item); - begin if X = null then raise Constraint_Error with "attempt to delete element not in set"; + else + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); end if; - - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); end Delete; ------------------ @@ -1088,12 +1067,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is B : Natural renames Tree.Busy; L : Natural renames Tree.Lock; + Eq : Boolean; + begin B := B + 1; L := L + 1; begin Process (E); + Eq := Equivalent_Keys (K, Key (E)); exception when others => L := L - 1; @@ -1104,7 +1086,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is L := L - 1; B := B - 1; - if Equivalent_Keys (K, Key (E)) then + if Eq then return; end if; end; @@ -1884,16 +1866,55 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Hint : Node_Access; Result : Node_Access; Inserted : Boolean; + Compare : Boolean; X : Element_Access := Node.Element; - -- Start of processing for Replace_Element + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + -- Start of processing for Replace_Element begin - if Item < Node.Element.all or else Node.Element.all < Item then - null; + -- Replace_Element assigns value Item to the element designated by Node, + -- per certain semantic constraints, described as follows. + + -- If Item is equivalent to the element, then element is replaced and + -- there's nothing else to do. This is the easy case. + + -- If Item is not equivalent, then the node will (possibly) have to move + -- to some other place in the tree. This is slighly more complicated, + -- because we must ensure that Item is not equivalent to some other + -- element in the tree (in which case, the replacement is not allowed). + + -- Determine whether Item is equivalent to element on the specified + -- node. + + begin + B := B + 1; + L := L + 1; + + Compare := (if Item < Node.Element.all then False + elsif Node.Element.all < Item then False + else True); + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + if Compare then + -- Item is equivalent to the node's element, so we will not have to + -- move the node. - else if Tree.Lock > 0 then raise Program_Error with "attempt to tamper with elements (set is locked)"; @@ -1914,12 +1935,66 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return; end if; + -- The replacement Item is not equivalent to the element on the + -- specified node, which means that it will need to be re-inserted in a + -- different position in the tree. We must now determine whether Item is + -- equivalent to some other element in the tree (which would prohibit + -- the assignment and hence the move). + + -- Ceiling returns the smallest element equivalent or greater than the + -- specified Item; if there is no such element, then it returns null. + Hint := Element_Keys.Ceiling (Tree, Item); - if Hint = null then - null; + if Hint /= null then + begin + B := B + 1; + L := L + 1; + + Compare := Item < Hint.Element.all; + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + -- Item >= Hint.Element + + if not Compare then + + -- Ceiling returns an element that is equivalent or greater + -- than Item. If Item is "not less than" the element, then + -- by elimination we know that Item is equivalent to the element. + + -- But this means that it is not possible to assign the value of + -- Item to the specified element (on Node), because a different + -- element (on Hint) equivalent to Item already exsits. (Were we + -- to change Node's element value, we would have to move Node, but + -- we would be unable to move the Node, because its new position + -- in the tree is already occupied by an equivalent element.) + + raise Program_Error with "attempt to replace existing element"; + end if; + + -- Item is not equivalent to any other element in the tree, so it is + -- safe to assign the value of Item to Node.Element. This means that + -- the node will have to move to a different position in the tree + -- (because its element will have a different value). + + -- The nearest (greater) neighbor of Item is Hint. This will be the + -- insertion position of Node (because its element will have Item as + -- its new value). + + -- If Node equals Hint, the relative position of Node does not + -- change. This allows us to perform an optimization: we need not + -- remove Node from the tree and then reinsert it with its new value, + -- because it would only be placed in the exact same position. - elsif Item < Hint.Element.all then if Hint = Node then if Tree.Lock > 0 then raise Program_Error with @@ -1940,12 +2015,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return; end if; - - else - pragma Assert (not (Hint.Element.all < Item)); - raise Program_Error with "attempt to replace existing element"; end if; + -- If we get here, it is because Item was greater than all elements in + -- the tree (Hint = null), or because Item was less than some element at + -- a different place in the tree (Item < Hint.Element.all). In either + -- case, we remove Node from the tree (without actually deallocating + -- it), and then insert Item into the tree, onto the same Node (so no + -- new node is actually allocated). + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit Local_Insert_With_Hint diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index 87ba353e9e8..0dba13e42ed 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -416,4 +416,24 @@ private No_Element : constant Cursor := Cursor'(null, null); + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Indefinite_Ordered_Sets; diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb index 8ca958f0b71..c2790517e01 100644 --- a/gcc/ada/a-cobove.adb +++ b/gcc/ada/a-cobove.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -28,32 +28,11 @@ ------------------------------------------------------------------------------ with Ada.Containers.Generic_Array_Sort; -with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Vectors is - type Iterator is new Limited_Controlled and - Vector_Iterator_Interfaces.Reversible_Iterator with - record - Container : Vector_Access; - Index : Index_Type'Base; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- @@ -112,8 +91,8 @@ package body Ada.Containers.Bounded_Vectors is raise Constraint_Error with "new length is out of range"; end if; - -- It is now safe compute the length of the new vector, without fear of - -- overflow. + -- It is now safe to compute the length of the new vector, without fear + -- of overflow. N := LN + RN; @@ -122,6 +101,7 @@ package body Ada.Containers.Bounded_Vectors is -- Count_Type'Base as the type for intermediate values. if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the -- computed Last value lies in the base range of the type, and then -- determine whether it lies in the range of the index (sub)type. @@ -150,6 +130,7 @@ package body Ada.Containers.Bounded_Vectors is end if; elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that -- No_Index is less than 0, so there is no danger of overflow when -- adding the (positive) value of length. @@ -280,6 +261,14 @@ package body Ada.Containers.Bounded_Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + Result : Boolean; + begin if Left'Address = Right'Address then return True; @@ -289,13 +278,40 @@ package body Ada.Containers.Bounded_Vectors is return False; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + Result := True; for J in Count_Type range 1 .. Left.Length loop if Left.Elements (J) /= Right.Elements (J) then - return False; + Result := False; + exit; end if; end loop; - return True; + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; end "="; ------------ @@ -543,7 +559,6 @@ package body Ada.Containers.Bounded_Vectors is if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else Count2 := Count_Type'Base (Old_Last - Index + 1); end if; @@ -567,7 +582,6 @@ package body Ada.Containers.Bounded_Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Off := Count_Type'Base (Index - Index_Type'First); New_Last := Old_Last - Index_Type'Base (Count); - else Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); @@ -579,7 +593,6 @@ package body Ada.Containers.Bounded_Vectors is declare EA : Elements_Array renames Container.Elements; Idx : constant Count_Type := EA'First + Off; - begin EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); Container.Last := New_Last; @@ -621,14 +634,14 @@ package body Ada.Containers.Bounded_Vectors is begin if Count = 0 then return; - end if; - if Count >= Length (Container) then + elsif Count >= Length (Container) then Clear (Container); return; - end if; - Delete (Container, Index_Type'First, Count); + else + Delete (Container, Index_Type'First, Count); + end if; end Delete_First; ----------------- @@ -738,13 +751,42 @@ package body Ada.Containers.Bounded_Vectors is end if; end if; - for J in Position.Index .. Container.Last loop - if Container.Elements (To_Array_Index (J)) = Item then - return (Container'Unrestricted_Access, J); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + + begin + B := B + 1; + L := L + 1; + + Result := No_Index; + for J in Position.Index .. Container.Last loop + if Container.Elements (To_Array_Index (J)) = Item then + Result := J; + exit; + end if; + end loop; + + B := B - 1; + L := L - 1; + + if Result = No_Index then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); end if; - end loop; - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Find; ---------------- @@ -756,14 +798,36 @@ package body Ada.Containers.Bounded_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Result := No_Index; for Indx in Index .. Container.Last loop if Container.Elements (To_Array_Index (Indx)) = Item then - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Find_Index; ----------- @@ -841,17 +905,40 @@ package body Ada.Containers.Bounded_Vectors is return True; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare EA : Elements_Array renames Container.Elements; + + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Boolean; + begin + B := B + 1; + L := L + 1; + + Result := True; for J in 1 .. Container.Length - 1 loop if EA (J + 1) < EA (J) then - return False; + Result := False; + exit; end if; end loop; - end; - return True; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Is_Sorted; ----------- @@ -862,7 +949,6 @@ package body Ada.Containers.Bounded_Vectors is I, J : Count_Type; begin - -- The semantics of Merge changed slightly per AI05-0021. It was -- originally the case that if Target and Source denoted the same -- container object, then the GNAT implementation of Merge did @@ -893,21 +979,35 @@ package body Ada.Containers.Bounded_Vectors is I := Target.Length; Target.Set_Length (I + Source.Length); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare TA : Elements_Array renames Target.Elements; SA : Elements_Array renames Source.Elements; + TB : Natural renames Target.Busy; + TL : Natural renames Target.Lock; + + SB : Natural renames Source.Busy; + SL : Natural renames Source.Lock; + begin + TB := TB + 1; + TL := TL + 1; + + SB := SB + 1; + SL := SL + 1; + J := Target.Length; while not Source.Is_Empty loop pragma Assert (Source.Length <= 1 - or else not (SA (Source.Length) < - SA (Source.Length - 1))); + or else not (SA (Source.Length) < SA (Source.Length - 1))); if I = 0 then TA (1 .. J) := SA (1 .. Source.Length); Source.Last := No_Index; - return; + exit; end if; pragma Assert (I <= 1 @@ -924,6 +1024,22 @@ package body Ada.Containers.Bounded_Vectors is J := J - 1; end loop; + + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + exception + when others => + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + raise; end; end Merge; @@ -960,7 +1076,28 @@ package body Ada.Containers.Bounded_Vectors is "attempt to tamper with cursors (vector is busy)"; end if; - Sort (Container.Elements (1 .. Container.Length)); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + Sort (Container.Elements (1 .. Container.Length)); + + B := B - 1; + L := L - 1; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Sort; end Generic_Sorting; @@ -1056,10 +1193,12 @@ package body Ada.Containers.Bounded_Vectors is -- acceptable, then we compute the new last index from that. if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We have to handle the case when there might be more values in the -- range of Index_Type than in the range of Count_Type. if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is -- less than 0, so it is safe to compute the following sum without -- fear of overflow. @@ -1067,6 +1206,7 @@ package body Ada.Containers.Bounded_Vectors is Index := No_Index + Index_Type'Base (Count_Type'Last); if Index <= Index_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. @@ -1091,6 +1231,7 @@ package body Ada.Containers.Bounded_Vectors is end if; elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less -- than 0, so it is safe to compute the following sum without fear of -- overflow. @@ -1098,6 +1239,7 @@ package body Ada.Containers.Bounded_Vectors is J := Count_Type'Base (No_Index) + Count_Type'Last; if J <= Count_Type'Base (Index_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. @@ -1151,6 +1293,7 @@ package body Ada.Containers.Bounded_Vectors is J := To_Array_Index (Before); if Before > Container.Last then + -- The new items are being appended to the vector, so no -- sliding of existing elements is required. @@ -1508,10 +1651,12 @@ package body Ada.Containers.Bounded_Vectors is -- acceptable, then we compute the new last index from that. if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We have to handle the case when there might be more values in the -- range of Index_Type than in the range of Count_Type. if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is -- less than 0, so it is safe to compute the following sum without -- fear of overflow. @@ -1519,6 +1664,7 @@ package body Ada.Containers.Bounded_Vectors is Index := No_Index + Index_Type'Base (Count_Type'Last); if Index <= Index_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. @@ -1543,6 +1689,7 @@ package body Ada.Containers.Bounded_Vectors is end if; elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less -- than 0, so it is safe to compute the following sum without fear of -- overflow. @@ -1550,6 +1697,7 @@ package body Ada.Containers.Bounded_Vectors is J := Count_Type'Base (No_Index) + Count_Type'Last; if J <= Count_Type'Base (Index_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. @@ -1608,6 +1756,7 @@ package body Ada.Containers.Bounded_Vectors is -- unused storage for the new items. if Before <= Container.Last then + -- The space is being inserted before some existing elements, -- so we must slide the existing elements up to their new home. @@ -1927,36 +2076,30 @@ package body Ada.Containers.Bounded_Vectors is begin if Position.Container = null then return No_Element; - end if; - - if Position.Index < Position.Container.Last then + elsif Position.Index < Position.Container.Last then return (Position.Container, Position.Index + 1); + else + return No_Element; end if; - - return No_Element; end Next; function Next (Object : Iterator; Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; + else + return Next (Position); end if; - - return Next (Position); end Next; procedure Next (Position : in out Cursor) is begin if Position.Container = null then return; - end if; - - if Position.Index < Position.Container.Last then + elsif Position.Index < Position.Container.Last then Position.Index := Position.Index + 1; else Position := No_Element; @@ -1992,9 +2135,7 @@ package body Ada.Containers.Bounded_Vectors is begin if Position.Container = null then return; - end if; - - if Position.Index > Index_Type'First then + elsif Position.Index > Index_Type'First then Position.Index := Position.Index - 1; else Position := No_Element; @@ -2005,27 +2146,23 @@ package body Ada.Containers.Bounded_Vectors is begin if Position.Container = null then return No_Element; - end if; - - if Position.Index > Index_Type'First then + elsif Position.Index > Index_Type'First then return (Position.Container, Position.Index - 1); + else + return No_Element; end if; - - return No_Element; end Previous; function Previous (Object : Iterator; Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; + else + return Previous (Position); end if; - - return Previous (Position); end Previous; ------------------- @@ -2069,9 +2206,9 @@ package body Ada.Containers.Bounded_Vectors is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + else + Query_Element (Position.Container.all, Position.Index, Process); end if; - - Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; ---------- @@ -2146,9 +2283,9 @@ package body Ada.Containers.Bounded_Vectors is declare A : Elements_Array renames Container.Elements; - I : constant Count_Type := To_Array_Index (Position.Index); + J : constant Count_Type := To_Array_Index (Position.Index); begin - return (Element => A (I)'Access); + return (Element => A (J)'Access); end; end Reference; @@ -2163,9 +2300,9 @@ package body Ada.Containers.Bounded_Vectors is declare A : Elements_Array renames Container.Elements; - I : constant Count_Type := To_Array_Index (Index); + J : constant Count_Type := To_Array_Index (Index); begin - return (Element => A (I)'Access); + return (Element => A (J)'Access); end; end Reference; @@ -2181,14 +2318,12 @@ package body Ada.Containers.Bounded_Vectors is begin if Index > Container.Last then raise Constraint_Error with "Index is out of range"; - end if; - - if Container.Lock > 0 then + elsif Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (vector is locked)"; + else + Container.Elements (To_Array_Index (Index)) := New_Item; end if; - - Container.Elements (To_Array_Index (Index)) := New_Item; end Replace_Element; procedure Replace_Element @@ -2199,22 +2334,20 @@ package body Ada.Containers.Bounded_Vectors is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; - end if; - if Position.Index > Container.Last then + elsif Position.Index > Container.Last then raise Constraint_Error with "Position cursor is out of range"; - end if; - if Container.Lock > 0 then + elsif Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (vector is locked)"; - end if; - Container.Elements (To_Array_Index (Position.Index)) := New_Item; + else + Container.Elements (To_Array_Index (Position.Index)) := New_Item; + end if; end Replace_Element; ---------------------- @@ -2300,13 +2433,41 @@ package body Ada.Containers.Bounded_Vectors is then Container.Last else Position.Index); - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements (To_Array_Index (Indx)) = Item then - return (Container'Unrestricted_Access, Indx); - end if; - end loop; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + + begin + B := B + 1; + L := L + 1; + + Result := No_Index; + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (To_Array_Index (Indx)) = Item then + Result := Indx; + exit; + end if; + end loop; - return No_Element; + B := B - 1; + L := L - 1; + + if Result = No_Index then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); + end if; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Reverse_Find; ------------------------ @@ -2318,17 +2479,39 @@ package body Ada.Containers.Bounded_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + Last : constant Index_Type'Base := Index_Type'Min (Container.Last, Index); + Result : Index_Type'Base; + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements (To_Array_Index (Indx)) = Item then - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Reverse_Find_Index; --------------------- @@ -2375,10 +2558,8 @@ package body Ada.Containers.Bounded_Vectors is if Count >= 0 then Container.Delete_Last (Count); - elsif Container.Last >= Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; - else Container.Insert_Space (Container.Last + 1, -Count); end if; @@ -2451,11 +2632,11 @@ package body Ada.Containers.Bounded_Vectors is -- hence we also know that -- Index - Index_Type'First >= 0 - -- The issue is that even though 0 is guaranteed to be a value - -- in the type Index_Type'Base, there's no guarantee that the - -- difference is a value in that type. To prevent overflow we - -- use the wider of Count_Type'Base and Index_Type'Base to - -- perform intermediate calculations. + -- The issue is that even though 0 is guaranteed to be a value in + -- the type Index_Type'Base, there's no guarantee that the difference + -- is a value in that type. To prevent overflow we use the wider + -- of Count_Type'Base and Index_Type'Base to perform intermediate + -- calculations. if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Offset := Count_Type'Base (Index - Index_Type'First); diff --git a/gcc/ada/a-cobove.ads b/gcc/ada/a-cobove.ads index 932aafb886b..267c64de425 100644 --- a/gcc/ada/a-cobove.ads +++ b/gcc/ada/a-cobove.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -34,6 +34,7 @@ with Ada.Iterator_Interfaces; private with Ada.Streams; +private with Ada.Finalization; generic type Index_Type is range <>; @@ -364,6 +365,7 @@ private pragma Inline (Previous); use Ada.Streams; + use Ada.Finalization; type Elements_Array is array (Count_Type range <>) of aliased Element_Type; function "=" (L, R : Elements_Array) return Boolean is abstract; @@ -441,4 +443,24 @@ private No_Element : constant Cursor := Cursor'(null, Index_Type'First); + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record + Container : Vector_Access; + Index : Index_Type'Base; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Bounded_Vectors; diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index 548512d5536..69de29db5d4 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.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- -- @@ -37,6 +37,11 @@ package body Ada.Containers.Formal_Vectors is (Container : Vector; Position : Count_Type) return Element_Type; + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + --------- -- "&" -- --------- @@ -256,7 +261,7 @@ package body Ada.Containers.Formal_Vectors is -- Capacity -- -------------- - function Capacity (Container : Vector) return Capacity_Subtype is + function Capacity (Container : Vector) return Count_Type is begin return Container.Elements'Length; end Capacity; @@ -267,11 +272,6 @@ package body Ada.Containers.Formal_Vectors is procedure Clear (Container : in out Vector) is begin - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - Container.Last := No_Index; end Clear; @@ -293,10 +293,10 @@ package body Ada.Containers.Formal_Vectors is function Copy (Source : Vector; - Capacity : Capacity_Subtype := 0) return Vector + Capacity : Count_Type := 0) return Vector is LS : constant Count_Type := Length (Source); - C : Capacity_Subtype; + C : Count_Type; begin if Capacity = 0 then @@ -339,11 +339,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - declare I_As_Int : constant Int := Int (Index); Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last); @@ -437,11 +432,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - Index := Int'Base (Container.Last) - Int'Base (Count); if Index < Index_Type'Pos (Index_Type'First) then @@ -607,7 +597,7 @@ package body Ada.Containers.Formal_Vectors is end if; declare - L : constant Capacity_Subtype := Length (Container); + L : constant Count_Type := Length (Container); begin for J in Count_Type range 1 .. L - 1 loop if Get_Element (Container, J + 1) < @@ -650,16 +640,6 @@ package body Ada.Containers.Formal_Vectors is -- I think we're missing this check in a-convec.adb... ??? - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - I := Length (Target); Target.Set_Length (I + Length (Source)); @@ -709,11 +689,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is locked)"; - end if; - Sort (Container.Elements (1 .. Length (Container))); end Sort; @@ -807,11 +782,6 @@ package body Ada.Containers.Formal_Vectors is -- Resolve issue of capacity vs. max index ??? end; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - declare EA : Elements_Array renames Container.Elements; @@ -1055,30 +1025,6 @@ package body Ada.Containers.Formal_Vectors is Position := Cursor'(True, Index); end Insert; - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - New_Item : Element_Type; -- Default-initialized value - pragma Warnings (Off, New_Item); - - begin - Insert (Container, Before, New_Item, Count); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - New_Item : Element_Type; -- Default-initialized value - pragma Warnings (Off, New_Item); - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - ------------------ -- Insert_Space -- ------------------ @@ -1138,11 +1084,6 @@ package body Ada.Containers.Formal_Vectors is -- Resolve issue of capacity vs. max index ??? end; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - declare EA : Elements_Array renames Container.Elements; @@ -1166,46 +1107,6 @@ package body Ada.Containers.Formal_Vectors is Container.Last := New_Last; end Insert_Space; - procedure Insert_Space - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Count = 0 then - if not Before.Valid - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (True, Before.Index); - end if; - - return; - end if; - - if not Before.Valid - or else Before.Index > Container.Last - then - if Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert_Space (Container, Index, Count => Count); - - Position := Cursor'(True, Index); - end Insert_Space; - -------------- -- Is_Empty -- -------------- @@ -1215,34 +1116,6 @@ package body Ada.Containers.Formal_Vectors is return Last_Index (Container) < Index_Type'First; end Is_Empty; - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Vector; - Process : - not null access procedure (Container : Vector; Position : Cursor)) - is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - - begin - B := B + 1; - - begin - for Indx in Index_Type'First .. Last_Index (Container) loop - Process (Container, Cursor'(True, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - ---------- -- Last -- ---------- @@ -1282,13 +1155,13 @@ package body Ada.Containers.Formal_Vectors is -- Length -- ------------ - function Length (Container : Vector) return Capacity_Subtype is + function Length (Container : Vector) return Count_Type is L : constant Int := Int (Last_Index (Container)); F : constant Int := Int (Index_Type'First); N : constant Int'Base := L - F + 1; begin - return Capacity_Subtype (N); + return Count_Type (N); end Length; ---------- @@ -1328,16 +1201,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (Target is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (Source is busy)"; - end if; - if N > Target.Capacity then raise Constraint_Error with -- correct exception here??? "length of Source is greater than capacity of Target"; @@ -1440,96 +1303,6 @@ package body Ada.Containers.Formal_Vectors is return No_Element; end Previous; - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : Vector; - Index : Index_Type; - Process : not null access procedure (Element : Element_Type)) - is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - L : Natural renames V.Lock; - - begin - if Index > Last_Index (Container) then - raise Constraint_Error with "Index is out of range"; - end if; - - B := B + 1; - L := L + 1; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Count_Type := Count_Type (II); - - begin - Process (Get_Element (V, I)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end Query_Element; - - procedure Query_Element - (Container : Vector; - Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if not Position.Valid then - raise Constraint_Error with "Position cursor has no element"; - end if; - - Query_Element (Container, Position.Index, Process); - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Vector) - is - Length : Count_Type'Base; - Last : Index_Type'Base := No_Index; - - begin - Clear (Container); - - Count_Type'Base'Read (Stream, Length); - - if Length < 0 then - raise Program_Error with "stream appears to be corrupt"; - end if; - - if Length > Container.Capacity then - raise Storage_Error with "not enough capacity"; -- ??? - end if; - - for J in Count_Type range 1 .. Length loop - Last := Last + 1; - Element_Type'Read (Stream, Container.Elements (J)); - Container.Last := Last; - end loop; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Read; - --------------------- -- Replace_Element -- --------------------- @@ -1544,11 +1317,6 @@ package body Ada.Containers.Formal_Vectors is raise Constraint_Error with "Index is out of range"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is locked)"; - end if; - declare II : constant Int'Base := Int (Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); @@ -1572,11 +1340,6 @@ package body Ada.Containers.Formal_Vectors is raise Constraint_Error with "Position cursor is out of range"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is locked)"; - end if; - declare II : constant Int'Base := Int (Position.Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); @@ -1591,11 +1354,11 @@ package body Ada.Containers.Formal_Vectors is procedure Reserve_Capacity (Container : in out Vector; - Capacity : Capacity_Subtype) + Capacity : Count_Type) is begin if Capacity > Container.Capacity then - raise Constraint_Error; -- ??? + raise Constraint_Error with "Capacity is out of range"; end if; end Reserve_Capacity; @@ -1609,11 +1372,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is locked)"; - end if; - declare I, J : Count_Type; E : Elements_Array renames Container.Elements; @@ -1699,34 +1457,6 @@ package body Ada.Containers.Formal_Vectors is return No_Index; end Reverse_Find_Index; - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Vector; - Process : not null access procedure (Container : Vector; - Position : Cursor)) - is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - - begin - B := B + 1; - - begin - for Indx in reverse Index_Type'First .. Last_Index (Container) loop - Process (Container, Cursor'(True, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Reverse_Iterate; - ----------- -- Right -- ----------- @@ -1757,18 +1487,13 @@ package body Ada.Containers.Formal_Vectors is procedure Set_Length (Container : in out Vector; - Length : Capacity_Subtype) + Length : Count_Type) is begin if Length = Formal_Vectors.Length (Container) then return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - if Length > Container.Capacity then raise Constraint_Error; -- ??? end if; @@ -1799,11 +1524,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is locked)"; - end if; - declare II : constant Int'Base := Int (I) - Int (No_Index); JJ : constant Int'Base := Int (J) - Int (No_Index); @@ -1865,32 +1585,9 @@ package body Ada.Containers.Formal_Vectors is -- To_Vector -- --------------- - function To_Vector (Length : Capacity_Subtype) return Vector is - begin - if Length = 0 then - return Empty_Vector; - end if; - - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; -- ??? - end if; - - Last := Index_Type (Last_As_Int); - - return (Length, (others => <>), Last => Last, - others => <>); - end; - end To_Vector; - function To_Vector (New_Item : Element_Type; - Length : Capacity_Subtype) return Vector + Length : Count_Type) return Vector is begin if Length = 0 then @@ -1914,78 +1611,4 @@ package body Ada.Containers.Formal_Vectors is end; end To_Vector; - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Vector; - Index : Index_Type; - Process : not null access procedure (Element : in out Element_Type)) - is - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - B := B + 1; - L := L + 1; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Count_Type := Count_Type (II); - - begin - Process (Container.Elements (I)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end Update_Element; - - procedure Update_Element - (Container : in out Vector; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if not Position.Valid then - raise Constraint_Error with "Position cursor has no element"; - end if; - - Update_Element (Container, Position.Index, Process); - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Vector) - is - begin - Count_Type'Base'Write (Stream, Length (Container)); - - for J in 1 .. Length (Container) loop - Element_Type'Write (Stream, Container.Elements (J)); - end loop; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Write; - end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index 24e2944fb7e..4d943837b82 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -55,7 +55,6 @@ -- iterate over containers. Left returns the part of the container already -- scanned and Right the part not scanned yet. -private with Ada.Streams; with Ada.Containers; use Ada.Containers; @@ -72,21 +71,9 @@ package Ada.Containers.Formal_Vectors is range Index_Type'First - 1 .. Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; - -- ??? i don't think we can do this... - -- TODO: we need the ARG to either figure out how to declare this subtype, - -- or eliminate the requirement that it be present. - -- subtype Capacity_Subtype is Count_Type -- correct name??? - -- range 0 .. Count_Type'Max (0, - -- Index_Type'Pos (Index_Type'Last) - - -- Index_Type'Pos (Index_Type'First) + 1); - -- - -- so for now: - subtype Capacity_Subtype is Count_Type; - No_Index : constant Extended_Index := Extended_Index'First; - type Vector (Capacity : Capacity_Subtype) is tagged private; - -- pragma Preelaborable_Initialization (Vector); + type Vector (Capacity : Count_Type) is tagged private; type Cursor is private; pragma Preelaborable_Initialization (Cursor); @@ -97,11 +84,9 @@ package Ada.Containers.Formal_Vectors is function "=" (Left, Right : Vector) return Boolean; - function To_Vector (Length : Capacity_Subtype) return Vector; - function To_Vector (New_Item : Element_Type; - Length : Capacity_Subtype) return Vector; + Length : Count_Type) return Vector; function "&" (Left, Right : Vector) return Vector; @@ -111,17 +96,17 @@ package Ada.Containers.Formal_Vectors is function "&" (Left, Right : Element_Type) return Vector; - function Capacity (Container : Vector) return Capacity_Subtype; + function Capacity (Container : Vector) return Count_Type; procedure Reserve_Capacity (Container : in out Vector; - Capacity : Capacity_Subtype); + Capacity : Count_Type); - function Length (Container : Vector) return Capacity_Subtype; + function Length (Container : Vector) return Count_Type; procedure Set_Length (Container : in out Vector; - Length : Capacity_Subtype); + Length : Count_Type); function Is_Empty (Container : Vector) return Boolean; @@ -131,7 +116,7 @@ package Ada.Containers.Formal_Vectors is function Copy (Source : Vector; - Capacity : Capacity_Subtype := 0) return Vector; + Capacity : Count_Type := 0) return Vector; function To_Cursor (Container : Vector; @@ -157,26 +142,6 @@ package Ada.Containers.Formal_Vectors is Position : Cursor; New_Item : Element_Type); - procedure Query_Element - (Container : Vector; - Index : Index_Type; - Process : not null access procedure (Element : Element_Type)); - - procedure Query_Element - (Container : Vector; - Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out Vector; - Index : Index_Type; - Process : not null access procedure (Element : in out Element_Type)); - - procedure Update_Element - (Container : in out Vector; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - procedure Move (Target : in out Vector; Source : in out Vector); procedure Insert @@ -214,17 +179,6 @@ package Ada.Containers.Formal_Vectors is Position : out Cursor; Count : Count_Type := 1); - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - procedure Prepend (Container : in out Vector; New_Item : Vector); @@ -243,17 +197,6 @@ package Ada.Containers.Formal_Vectors is New_Item : Element_Type; Count : Count_Type := 1); - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - procedure Insert_Space - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - procedure Delete (Container : in out Vector; Index : Extended_Index; @@ -324,16 +267,6 @@ package Ada.Containers.Formal_Vectors is function Has_Element (Container : Vector; Position : Cursor) return Boolean; - procedure Iterate - (Container : Vector; - Process : not null access - procedure (Container : Vector; Position : Cursor)); - - procedure Reverse_Iterate - (Container : Vector; - Process : not null access - procedure (Container : Vector; Position : Cursor)); - generic with function "<" (Left, Right : Element_Type) return Boolean is <>; package Generic_Sorting is @@ -357,8 +290,6 @@ private pragma Inline (Element); pragma Inline (First_Element); pragma Inline (Last_Element); - pragma Inline (Query_Element); - pragma Inline (Update_Element); pragma Inline (Replace_Element); pragma Inline (Contains); pragma Inline (Next); @@ -367,44 +298,16 @@ private type Elements_Array is array (Count_Type range <>) of Element_Type; function "=" (L, R : Elements_Array) return Boolean is abstract; - type Vector (Capacity : Capacity_Subtype) is tagged record + type Vector (Capacity : Count_Type) is tagged record Elements : Elements_Array (1 .. Capacity); Last : Extended_Index := No_Index; - Busy : Natural := 0; - Lock : Natural := 0; end record; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Vector); - - for Vector'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Vector); - - for Vector'Read use Read; - type Cursor is record Valid : Boolean := True; Index : Index_Type := Index_Type'First; end record; - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor); - - for Cursor'Read use Read; - Empty_Vector : constant Vector := (Capacity => 0, others => <>); No_Element : constant Cursor := (Valid => False, Index => Index_Type'First); diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 5eee4b302c1..6af16eec227 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -39,20 +39,6 @@ with System; use type System.Address; package body Ada.Containers.Hashed_Maps is - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Forward_Iterator with - record - Container : Map_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 98b2cb3c5a8..540e24af19d 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -424,4 +424,18 @@ private No_Element : constant Cursor := (Container => null, Node => null); + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Hashed_Maps; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index 6180168a1da..f9e1b2aa8c0 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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,17 +41,6 @@ with System; use type System.Address; package body Ada.Containers.Hashed_Sets is - type Iterator is limited new - Set_Iterator_Interfaces.Forward_Iterator with record - Container : Set_Access; - end record; - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------- -- Local Subprograms -- ----------------------- diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index de62cd96a5f..2931800aaf8 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -543,4 +543,15 @@ private No_Element : constant Cursor := (Container => null, Node => null); + type Iterator is limited new + Set_Iterator_Interfaces.Forward_Iterator with record + Container : Set_Access; + end record; + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Hashed_Sets; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 5b59c019da5..cff3a286edb 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -40,26 +40,6 @@ package body Ada.Containers.Indefinite_Vectors is procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is new Limited_Controlled and - Vector_Iterator_Interfaces.Reversible_Iterator with - record - Container : Vector_Access; - Index : Index_Type'Base; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - --------- -- "&" -- --------- @@ -117,7 +97,6 @@ package body Ada.Containers.Indefinite_Vectors is return (Controlled with Elements, Right.Last, 0, 0); end; - end if; if RN = 0 then @@ -243,7 +222,6 @@ package body Ada.Containers.Indefinite_Vectors is declare LE : Elements_Array renames Left.Elements.EA (Index_Type'First .. Left.Last); - RE : Elements_Array renames Right.Elements.EA (Index_Type'First .. Right.Last); @@ -514,6 +492,14 @@ package body Ada.Containers.Indefinite_Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + Result : Boolean; + begin if Left'Address = Right'Address then return True; @@ -523,21 +509,49 @@ package body Ada.Containers.Indefinite_Vectors is return False; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + Result := True; for J in Index_Type'First .. Left.Last loop if Left.Elements.EA (J) = null then if Right.Elements.EA (J) /= null then - return False; + Result := False; + exit; end if; elsif Right.Elements.EA (J) = null then - return False; + Result := False; + exit; elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then - return False; + Result := False; + exit; end if; end loop; - return True; + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; end "="; ------------ @@ -564,12 +578,12 @@ package body Ada.Containers.Indefinite_Vectors is Container.Elements := new Elements_Type (L); - for I in E'Range loop - if E (I) /= null then - Container.Elements.EA (I) := new Element_Type'(E (I).all); + for J in E'Range loop + if E (J) /= null then + Container.Elements.EA (J) := new Element_Type'(E (J).all); end if; - Container.Last := I; + Container.Last := J; end loop; end; end Adjust; @@ -596,16 +610,11 @@ package body Ada.Containers.Indefinite_Vectors is begin if Is_Empty (New_Item) then return; - end if; - - if Container.Last = Index_Type'Last then + elsif Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; + else + Insert (Container, Container.Last + 1, New_Item); end if; - - Insert - (Container, - Container.Last + 1, - New_Item); end Append; procedure Append @@ -616,17 +625,11 @@ package body Ada.Containers.Indefinite_Vectors is begin if Count = 0 then return; - end if; - - if Container.Last = Index_Type'Last then + elsif Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; + else + Insert (Container, Container.Last + 1, New_Item, Count); end if; - - Insert - (Container, - Container.Last + 1, - New_Item, - Count); end Append; ------------ @@ -637,10 +640,10 @@ package body Ada.Containers.Indefinite_Vectors is begin if Target'Address = Source'Address then return; + else + Target.Clear; + Target.Append (Source); end if; - - Target.Clear; - Target.Append (Source); end Assign; -------------- @@ -651,9 +654,9 @@ package body Ada.Containers.Indefinite_Vectors is begin if Container.Elements = null then return 0; + else + return Container.Elements.EA'Length; end if; - - return Container.Elements.EA'Length; end Capacity; ----------- @@ -665,17 +668,18 @@ package body Ada.Containers.Indefinite_Vectors is if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (vector is busy)"; - end if; - while Container.Last >= Index_Type'First loop - declare - X : Element_Access := Container.Elements.EA (Container.Last); - begin - Container.Elements.EA (Container.Last) := null; - Container.Last := Container.Last - 1; - Free (X); - end; - end loop; + else + while Container.Last >= Index_Type'First loop + declare + X : Element_Access := Container.Elements.EA (Container.Last); + begin + Container.Elements.EA (Container.Last) := null; + Container.Last := Container.Last - 1; + Free (X); + end; + end loop; + end if; end Clear; ------------------------ @@ -840,9 +844,9 @@ package body Ada.Containers.Indefinite_Vectors is if Index > Old_Last then if Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; + else + return; end if; - - return; end if; -- Here and elsewhere we treat deleting 0 items from the container as a @@ -934,7 +938,6 @@ package body Ada.Containers.Indefinite_Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then New_Last := Old_Last - Index_Type'Base (Count); J := Index + Index_Type'Base (Count); - else New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); J := Index_Type'Base (Count_Type'Base (Index) + Count); @@ -987,19 +990,17 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; - end if; - if Position.Index > Container.Last then + elsif Position.Index > Container.Last then raise Program_Error with "Position index is out of range"; - end if; - Delete (Container, Position.Index, Count); - - Position := No_Element; + else + Delete (Container, Position.Index, Count); + Position := No_Element; + end if; end Delete; ------------------ @@ -1013,14 +1014,14 @@ package body Ada.Containers.Indefinite_Vectors is begin if Count = 0 then return; - end if; - if Count >= Length (Container) then + elsif Count >= Length (Container) then Clear (Container); return; - end if; - Delete (Container, Index_Type'First, Count); + else + Delete (Container, Index_Type'First, Count); + end if; end Delete_First; ----------------- @@ -1110,13 +1111,12 @@ package body Ada.Containers.Indefinite_Vectors is declare EA : constant Element_Access := Container.Elements.EA (Index); - begin if EA = null then raise Constraint_Error with "element is empty"; + else + return EA.all; end if; - - return EA.all; end; end Element; @@ -1132,14 +1132,13 @@ package body Ada.Containers.Indefinite_Vectors is declare EA : constant Element_Access := - Position.Container.Elements.EA (Position.Index); - + Position.Container.Elements.EA (Position.Index); begin if EA = null then raise Constraint_Error with "element is empty"; + else + return EA.all; end if; - - return EA.all; end; end Element; @@ -1201,15 +1200,44 @@ package body Ada.Containers.Indefinite_Vectors is end if; end if; - for J in Position.Index .. Container.Last loop - if Container.Elements.EA (J) /= null - and then Container.Elements.EA (J).all = Item - then - return (Container'Unrestricted_Access, J); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + + begin + B := B + 1; + L := L + 1; + + Result := No_Index; + for J in Position.Index .. Container.Last loop + if Container.Elements.EA (J) /= null + and then Container.Elements.EA (J).all = Item + then + Result := J; + exit; + end if; + end loop; + + B := B - 1; + L := L - 1; + + if Result = No_Index then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); end if; - end loop; - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Find; ---------------- @@ -1221,16 +1249,38 @@ package body Ada.Containers.Indefinite_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Result := No_Index; for Indx in Index .. Container.Last loop if Container.Elements.EA (Indx) /= null and then Container.Elements.EA (Indx).all = Item then - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Find_Index; ----------- @@ -1281,14 +1331,13 @@ package body Ada.Containers.Indefinite_Vectors is declare EA : constant Element_Access := - Container.Elements.EA (Index_Type'First); - + Container.Elements.EA (Index_Type'First); begin if EA = null then raise Constraint_Error with "first element is empty"; + else + return EA.all; end if; - - return EA.all; end; end First_Element; @@ -1340,17 +1389,40 @@ package body Ada.Containers.Indefinite_Vectors is return True; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare E : Elements_Array renames Container.Elements.EA; + + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Boolean; + begin + B := B + 1; + L := L + 1; + + Result := True; for I in Index_Type'First .. Container.Last - 1 loop if Is_Less (E (I + 1), E (I)) then - return False; + Result := False; + exit; end if; end loop; - end; - return True; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Is_Sorted; ----------- @@ -1361,7 +1433,6 @@ package body Ada.Containers.Indefinite_Vectors is I, J : Index_Type'Base; begin - -- The semantics of Merge changed slightly per AI05-0021. It was -- originally the case that if Target and Source denoted the same -- container object, then the GNAT implementation of Merge did @@ -1392,53 +1463,86 @@ package body Ada.Containers.Indefinite_Vectors is I := Target.Last; -- original value (before Set_Length) Target.Set_Length (Length (Target) + Length (Source)); - J := Target.Last; -- new value (after Set_Length) - while Source.Last >= Index_Type'First loop - pragma Assert - (Source.Last <= Index_Type'First - or else not (Is_Less - (Source.Elements.EA (Source.Last), - Source.Elements.EA (Source.Last - 1)))); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + TA : Elements_Array renames Target.Elements.EA; + SA : Elements_Array renames Source.Elements.EA; + + TB : Natural renames Target.Busy; + TL : Natural renames Target.Lock; + + SB : Natural renames Source.Busy; + SL : Natural renames Source.Lock; + + begin + TB := TB + 1; + TL := TL + 1; + + SB := SB + 1; + SL := SL + 1; + + J := Target.Last; -- new value (after Set_Length) + while Source.Last >= Index_Type'First loop + pragma Assert + (Source.Last <= Index_Type'First + or else not (Is_Less (SA (Source.Last), + SA (Source.Last - 1)))); + + if I < Index_Type'First then + declare + Src : Elements_Array renames + SA (Index_Type'First .. Source.Last); + begin + TA (Index_Type'First .. J) := Src; + Src := (others => null); + end; + + Source.Last := No_Index; + exit; + end if; + + pragma Assert + (I <= Index_Type'First + or else not (Is_Less (TA (I), TA (I - 1)))); - if I < Index_Type'First then declare - Src : Elements_Array renames - Source.Elements.EA (Index_Type'First .. Source.Last); + Src : Element_Access renames SA (Source.Last); + Tgt : Element_Access renames TA (I); begin - Target.Elements.EA (Index_Type'First .. J) := Src; - Src := (others => null); + if Is_Less (Src, Tgt) then + Target.Elements.EA (J) := Tgt; + Tgt := null; + I := I - 1; + + else + Target.Elements.EA (J) := Src; + Src := null; + Source.Last := Source.Last - 1; + end if; end; - Source.Last := No_Index; - return; - end if; + J := J - 1; + end loop; - pragma Assert - (I <= Index_Type'First - or else not (Is_Less - (Target.Elements.EA (I), - Target.Elements.EA (I - 1)))); + TB := TB - 1; + TL := TL - 1; - declare - Src : Element_Access renames Source.Elements.EA (Source.Last); - Tgt : Element_Access renames Target.Elements.EA (I); + SB := SB - 1; + SL := SL - 1; - begin - if Is_Less (Src, Tgt) then - Target.Elements.EA (J) := Tgt; - Tgt := null; - I := I - 1; + exception + when others => + TB := TB - 1; + TL := TL - 1; - else - Target.Elements.EA (J) := Src; - Src := null; - Source.Last := Source.Last - 1; - end if; - end; + SB := SB - 1; + SL := SL - 1; - J := J - 1; - end loop; + raise; + end; end Merge; ---------- @@ -1475,7 +1579,28 @@ package body Ada.Containers.Indefinite_Vectors is "attempt to tamper with cursors (vector is busy)"; end if; - Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); + + B := B - 1; + L := L - 1; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Sort; end Generic_Sorting; @@ -1488,9 +1613,9 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container = null then return False; + else + return Position.Index <= Position.Container.Last; end if; - - return Position.Index <= Position.Container.Last; end Has_Element; ------------ @@ -1663,7 +1788,6 @@ package body Ada.Containers.Indefinite_Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then New_Last := No_Index + Index_Type'Base (New_Length); - else New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); end if; @@ -1859,7 +1983,6 @@ package body Ada.Containers.Indefinite_Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else Dst_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); @@ -1888,9 +2011,8 @@ package body Ada.Containers.Indefinite_Vectors is -- The new items are being appended to the vector, so no -- sliding of existing elements is required. - -- We have copied the elements from to the old, source array to - -- the new, destination array, so we can now deallocate the old - -- array. + -- We have copied the elements from to the old source array to the + -- new destination array, so we can now deallocate the old array. Container.Elements := Dst; Free (Src); @@ -1899,11 +2021,11 @@ package body Ada.Containers.Indefinite_Vectors is for Idx in Before .. New_Last loop - -- In order to preserve container invariants, we always - -- attempt the element allocation first, before setting the - -- Last index value, in case the allocation fails (either - -- because there is no storage available, or because element - -- initialization fails). + -- In order to preserve container invariants, we always attempt + -- the element allocation first, before setting the Last index + -- value, in case the allocation fails (either because there + -- is no storage available, or because element initialization + -- fails). declare -- The element allocator may need an accessibility check in @@ -1928,24 +2050,21 @@ package body Ada.Containers.Indefinite_Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); - -- We have copied the elements from to the old, source array to - -- the new, destination array, so we can now deallocate the old - -- array. + -- We have copied the elements from to the old source array to the + -- new destination array, so we can now deallocate the old array. Container.Elements := Dst; Container.Last := New_Last; Free (Src); -- The new array has a range in the middle containing null access - -- values. We now fill in that partition of the array with the new - -- items. + -- values. Fill in that partition of the array with the new items. for Idx in Before .. Index - 1 loop @@ -2081,7 +2200,6 @@ package body Ada.Containers.Indefinite_Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then J := Before + Index_Type'Base (N); - else J := Index_Type'Base (Count_Type'Base (Before) + N); end if; @@ -2105,7 +2223,6 @@ package body Ada.Containers.Indefinite_Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Dst_Index := J - Index_Type'Base (Src'Length); - else Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length); end if; @@ -2138,9 +2255,7 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -2172,9 +2287,7 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Is_Empty (New_Item) then - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then Position := No_Element; else Position := (Container'Unrestricted_Access, Before.Index); @@ -2183,9 +2296,7 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -2221,9 +2332,7 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -2266,9 +2375,7 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -2330,9 +2437,7 @@ package body Ada.Containers.Indefinite_Vectors is -- deeper flaw in the caller's algorithm, so that case is treated as a -- proper error.) - if Before > Container.Last - and then Before > Container.Last + 1 - then + if Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; end if; @@ -2453,7 +2558,6 @@ package body Ada.Containers.Indefinite_Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then New_Last := No_Index + Index_Type'Base (New_Length); - else New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); end if; @@ -2490,7 +2594,8 @@ package body Ada.Containers.Indefinite_Vectors is end if; if New_Length <= Container.Elements.EA'Length then - -- In this case, we're inserting elements into a vector that has + + -- In this case, we are inserting elements into a vector that has -- already allocated an internal array, and the existing array has -- enough unused storage for the new items. @@ -2501,13 +2606,12 @@ package body Ada.Containers.Indefinite_Vectors is if Before <= Container.Last then -- The new space is being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. We use the wider of Index_Type'Base and + -- elements, so we must slide the existing elements up to + -- their new home. We use the wider of Index_Type'Base and -- Count_Type'Base as the type for intermediate index values. if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; @@ -2554,7 +2658,6 @@ package body Ada.Containers.Indefinite_Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else Dst_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); @@ -2585,7 +2688,6 @@ package body Ada.Containers.Indefinite_Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; @@ -2619,9 +2721,7 @@ package body Ada.Containers.Indefinite_Vectors is end if; if Count = 0 then - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then Position := No_Element; else Position := (Container'Unrestricted_Access, Before.Index); @@ -2810,14 +2910,13 @@ package body Ada.Containers.Indefinite_Vectors is declare EA : constant Element_Access := - Container.Elements.EA (Container.Last); - + Container.Elements.EA (Container.Last); begin if EA = null then raise Constraint_Error with "last element is empty"; + else + return EA.all; end if; - - return EA.all; end; end Last_Element; @@ -2903,36 +3002,30 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container = null then return No_Element; - end if; - - if Position.Index < Position.Container.Last then + elsif Position.Index < Position.Container.Last then return (Position.Container, Position.Index + 1); + else + return No_Element; end if; - - return No_Element; end Next; function Next (Object : Iterator; Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; + else + return Next (Position); end if; - - return Next (Position); end Next; procedure Next (Position : in out Cursor) is begin if Position.Container = null then return; - end if; - - if Position.Index < Position.Container.Last then + elsif Position.Index < Position.Container.Last then Position.Index := Position.Index + 1; else Position := No_Element; @@ -2954,10 +3047,7 @@ package body Ada.Containers.Indefinite_Vectors is Count : Count_Type := 1) is begin - Insert (Container, - Index_Type'First, - New_Item, - Count); + Insert (Container, Index_Type'First, New_Item, Count); end Prepend; -------------- @@ -2968,9 +3058,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container = null then return; - end if; - - if Position.Index > Index_Type'First then + elsif Position.Index > Index_Type'First then Position.Index := Position.Index - 1; else Position := No_Element; @@ -2981,27 +3069,23 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container = null then return No_Element; - end if; - - if Position.Index > Index_Type'First then + elsif Position.Index > Index_Type'First then return (Position.Container, Position.Index - 1); + else + return No_Element; end if; - - return No_Element; end Previous; function Previous (Object : Iterator; Position : Cursor) return Cursor is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; + else + return Previous (Position); end if; - - return Previous (Position); end Previous; ------------------- @@ -3049,9 +3133,9 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + else + Query_Element (Position.Container.all, Position.Index, Process); end if; - - Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; ---------- @@ -3064,8 +3148,7 @@ package body Ada.Containers.Indefinite_Vectors is is Length : Count_Type'Base; Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); - - B : Boolean; + B : Boolean; begin Clear (Container); @@ -3616,23 +3699,50 @@ package body Ada.Containers.Indefinite_Vectors is raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Container = null - or else Position.Index > Container.Last - then + if Position.Container = null or else Position.Index > Container.Last then Last := Container.Last; else Last := Position.Index; end if; - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements.EA (Indx) /= null - and then Container.Elements.EA (Indx).all = Item - then - return (Container'Unrestricted_Access, Indx); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + + begin + B := B + 1; + L := L + 1; + + Result := No_Index; + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements.EA (Indx) /= null + and then Container.Elements.EA (Indx).all = Item + then + Result := Indx; + exit; + end if; + end loop; + + B := B - 1; + L := L - 1; + + if Result = No_Index then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); end if; - end loop; - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Reverse_Find; ------------------------ @@ -3644,18 +3754,41 @@ package body Ada.Containers.Indefinite_Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + Last : constant Index_Type'Base := (if Index > Container.Last then Container.Last else Index); + + Result : Index_Type'Base; + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) /= null and then Container.Elements.EA (Indx).all = Item then - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Reverse_Find_Index; --------------------- @@ -3800,13 +3933,11 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container = null then return No_Index; - end if; - - if Position.Index <= Position.Container.Last then + elsif Position.Index <= Position.Container.Last then return Position.Index; + else + return No_Index; end if; - - return No_Index; end To_Index; --------------- @@ -4072,13 +4203,13 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; - end if; - Update_Element (Container, Position.Index, Process); + else + Update_Element (Container, Position.Index, Process); + end if; end Update_Element; ----------- diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index c9a64989be5..2c841671af4 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -463,4 +463,24 @@ private No_Element : constant Cursor := Cursor'(null, Index_Type'First); + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record + Container : Vector_Access; + Index : Index_Type'Base; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Indefinite_Vectors; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index a67c156c2bc..5b722fe8a72 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -84,12 +84,10 @@ package body Ada.Containers.Vectors is end if; declare - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); Elements : constant Elements_Access := - new Elements_Type'(Right.Last, RE); - + new Elements_Type'(Right.Last, RE); begin return (Controlled with Elements, Right.Last, 0, 0); end; @@ -97,12 +95,10 @@ package body Ada.Containers.Vectors is if RN = 0 then declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); Elements : constant Elements_Access := - new Elements_Type'(Left.Last, LE); - + new Elements_Type'(Left.Last, LE); begin return (Controlled with Elements, Left.Last, 0, 0); end; @@ -197,15 +193,12 @@ package body Ada.Containers.Vectors is end if; declare - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); - + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); Elements : constant Elements_Access := - new Elements_Type'(Last, LE & RE); - + new Elements_Type'(Last, LE & RE); begin return (Controlled with Elements, Last, 0, 0); end; @@ -247,14 +240,11 @@ package body Ada.Containers.Vectors is end if; declare - Last : constant Index_Type := Left.Last + 1; - - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); - + Last : constant Index_Type := Left.Last + 1; + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); Elements : constant Elements_Access := - new Elements_Type'(Last => Last, EA => LE & Right); - + new Elements_Type'(Last => Last, EA => LE & Right); begin return (Controlled with Elements, Last, 0, 0); end; @@ -275,7 +265,6 @@ package body Ada.Containers.Vectors is new Elements_Type' (Last => Index_Type'First, EA => (others => Left)); - begin return (Controlled with Elements, Index_Type'First, 0, 0); end; @@ -346,6 +335,14 @@ package body Ada.Containers.Vectors is --------- overriding function "=" (Left, Right : Vector) return Boolean is + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + Result : Boolean; + begin if Left'Address = Right'Address then return True; @@ -355,13 +352,40 @@ package body Ada.Containers.Vectors is return False; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + Result := True; for J in Index_Type range Index_Type'First .. Left.Last loop if Left.Elements.EA (J) /= Right.Elements.EA (J) then - return False; + Result := False; + exit; end if; end loop; - return True; + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; end "="; ------------ @@ -418,16 +442,11 @@ package body Ada.Containers.Vectors is begin if Is_Empty (New_Item) then return; - end if; - - if Container.Last = Index_Type'Last then + elsif Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; + else + Insert (Container, Container.Last + 1, New_Item); end if; - - Insert - (Container, - Container.Last + 1, - New_Item); end Append; procedure Append @@ -438,17 +457,11 @@ package body Ada.Containers.Vectors is begin if Count = 0 then return; - end if; - - if Container.Last = Index_Type'Last then + elsif Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; + else + Insert (Container, Container.Last + 1, New_Item, Count); end if; - - Insert - (Container, - Container.Last + 1, - New_Item, - Count); end Append; ------------ @@ -459,10 +472,10 @@ package body Ada.Containers.Vectors is begin if Target'Address = Source'Address then return; + else + Target.Clear; + Target.Append (Source); end if; - - Target.Clear; - Target.Append (Source); end Assign; -------------- @@ -638,9 +651,9 @@ package body Ada.Containers.Vectors is if Index > Old_Last then if Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; + else + return; end if; - - return; end if; -- Here and elsewhere we treat deleting 0 items from the container as a @@ -668,7 +681,6 @@ package body Ada.Containers.Vectors is if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else Count2 := Count_Type'Base (Old_Last - Index + 1); end if; @@ -694,7 +706,6 @@ package body Ada.Containers.Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then New_Last := Old_Last - Index_Type'Base (Count); J := Index + Index_Type'Base (Count); - else New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); J := Index_Type'Base (Count_Type'Base (Index) + Count); @@ -708,7 +719,6 @@ package body Ada.Containers.Vectors is declare EA : Elements_Array renames Container.Elements.EA; - begin EA (Index .. New_Last) := EA (J .. Old_Last); Container.Last := New_Last; @@ -725,18 +735,17 @@ package body Ada.Containers.Vectors is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; - end if; - if Position.Index > Container.Last then + elsif Position.Index > Container.Last then raise Program_Error with "Position index is out of range"; - end if; - Delete (Container, Position.Index, Count); - Position := No_Element; + else + Delete (Container, Position.Index, Count); + Position := No_Element; + end if; end Delete; ------------------ @@ -750,14 +759,14 @@ package body Ada.Containers.Vectors is begin if Count = 0 then return; - end if; - if Count >= Length (Container) then + elsif Count >= Length (Container) then Clear (Container); return; - end if; - Delete (Container, Index_Type'First, Count); + else + Delete (Container, Index_Type'First, Count); + end if; end Delete_First; ----------------- @@ -823,9 +832,9 @@ package body Ada.Containers.Vectors is begin if Index > Container.Last then raise Constraint_Error with "Index is out of range"; + else + return Container.Elements.EA (Index); end if; - - return Container.Elements.EA (Index); end Element; function Element (Position : Cursor) return Element_Type is @@ -850,11 +859,12 @@ package body Ada.Containers.Vectors is if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (vector is busy)"; - end if; - Container.Elements := null; - Container.Last := No_Index; - Free (X); + else + Container.Elements := null; + Container.Last := No_Index; + Free (X); + end if; end Finalize; procedure Finalize (Object : in out Iterator) is @@ -899,13 +909,42 @@ package body Ada.Containers.Vectors is end if; end if; - for J in Position.Index .. Container.Last loop - if Container.Elements.EA (J) = Item then - return (Container'Unrestricted_Access, J); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + + begin + B := B + 1; + L := L + 1; + + Result := No_Index; + for J in Position.Index .. Container.Last loop + if Container.Elements.EA (J) = Item then + Result := J; + exit; + end if; + end loop; + + B := B - 1; + L := L - 1; + + if Result = No_Index then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); end if; - end loop; - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Find; ---------------- @@ -917,14 +956,36 @@ package body Ada.Containers.Vectors is Item : Element_Type; Index : Index_Type := Index_Type'First) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Result := No_Index; for Indx in Index .. Container.Last loop if Container.Elements.EA (Indx) = Item then - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Find_Index; ----------- @@ -1002,17 +1063,40 @@ package body Ada.Containers.Vectors is return True; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare EA : Elements_Array renames Container.Elements.EA; + + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Boolean; + begin + B := B + 1; + L := L + 1; + + Result := True; for J in Index_Type'First .. Container.Last - 1 loop if EA (J + 1) < EA (J) then - return False; + Result := False; + exit; end if; end loop; - end; - return True; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Is_Sorted; ----------- @@ -1053,23 +1137,38 @@ package body Ada.Containers.Vectors is Target.Set_Length (Length (Target) + Length (Source)); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare TA : Elements_Array renames Target.Elements.EA; SA : Elements_Array renames Source.Elements.EA; + TB : Natural renames Target.Busy; + TL : Natural renames Target.Lock; + + SB : Natural renames Source.Busy; + SL : Natural renames Source.Lock; + begin + TB := TB + 1; + TL := TL + 1; + + SB := SB + 1; + SL := SL + 1; + J := Target.Last; while Source.Last >= Index_Type'First loop pragma Assert (Source.Last <= Index_Type'First - or else not (SA (Source.Last) < - SA (Source.Last - 1))); + or else not (SA (Source.Last) < + SA (Source.Last - 1))); if I < Index_Type'First then TA (Index_Type'First .. J) := SA (Index_Type'First .. Source.Last); Source.Last := No_Index; - return; + exit; end if; pragma Assert (I <= Index_Type'First @@ -1086,6 +1185,22 @@ package body Ada.Containers.Vectors is J := J - 1; end loop; + + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + exception + when others => + TB := TB - 1; + TL := TL - 1; + + SB := SB - 1; + SL := SL - 1; + + raise; end; end Merge; @@ -1122,7 +1237,28 @@ package body Ada.Containers.Vectors is "attempt to tamper with cursors (vector is busy)"; end if; - Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + + begin + B := B + 1; + L := L + 1; + + Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); + + B := B - 1; + L := L - 1; + + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Sort; end Generic_Sorting; @@ -1182,9 +1318,7 @@ package body Ada.Containers.Vectors is -- deeper flaw in the caller's algorithm, so that case is treated as a -- proper error.) - if Before > Container.Last - and then Before > Container.Last + 1 - then + if Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; end if; @@ -1374,7 +1508,6 @@ package body Ada.Containers.Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; @@ -1402,9 +1535,9 @@ package body Ada.Containers.Vectors is if New_Capacity > Count_Type'Last / 2 then New_Capacity := Count_Type'Last; exit; + else + New_Capacity := 2 * New_Capacity; end if; - - New_Capacity := 2 * New_Capacity; end loop; if New_Capacity > Max_Length then @@ -1421,7 +1554,6 @@ package body Ada.Containers.Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else Dst_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); @@ -1455,7 +1587,6 @@ package body Ada.Containers.Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; @@ -1475,6 +1606,7 @@ package body Ada.Containers.Vectors is declare X : Elements_Access := Container.Elements; + begin -- We first isolate the old internal array, removing it from the -- container and replacing it with the new internal array, before we @@ -1518,7 +1650,6 @@ package body Ada.Containers.Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then J := (Before - 1) + Index_Type'Base (N); - else J := Index_Type'Base (Count_Type'Base (Before - 1) + N); end if; @@ -1549,7 +1680,7 @@ package body Ada.Containers.Vectors is Index_Type'First .. L; Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + Container.Elements.EA (Src_Index_Subtype); K : Index_Type'Base; @@ -1562,7 +1693,6 @@ package body Ada.Containers.Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then K := L + Index_Type'Base (Src'Length); - else K := Index_Type'Base (Count_Type'Base (L) + Src'Length); end if; @@ -1594,7 +1724,7 @@ package body Ada.Containers.Vectors is F .. Container.Last; Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + Container.Elements.EA (Src_Index_Subtype); K : Index_Type'Base; @@ -1606,7 +1736,6 @@ package body Ada.Containers.Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then K := F - Index_Type'Base (Src'Length); - else K := Index_Type'Base (Count_Type'Base (F) - Src'Length); end if; @@ -1633,9 +1762,7 @@ package body Ada.Containers.Vectors is return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -1666,9 +1793,7 @@ package body Ada.Containers.Vectors is end if; if Is_Empty (New_Item) then - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then Position := No_Element; else Position := (Container'Unrestricted_Access, Before.Index); @@ -1677,9 +1802,7 @@ package body Ada.Containers.Vectors is return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -1715,9 +1838,7 @@ package body Ada.Containers.Vectors is return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -1749,9 +1870,7 @@ package body Ada.Containers.Vectors is end if; if Count = 0 then - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then Position := No_Element; else Position := (Container'Unrestricted_Access, Before.Index); @@ -1760,9 +1879,7 @@ package body Ada.Containers.Vectors is return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -1799,7 +1916,6 @@ package body Ada.Containers.Vectors is is New_Item : Element_Type; -- Default-initialized value pragma Warnings (Off, New_Item); - begin Insert (Container, Before, New_Item, Position, Count); end Insert; @@ -1849,9 +1965,7 @@ package body Ada.Containers.Vectors is -- deeper flaw in the caller's algorithm, so that case is treated as a -- proper error.) - if Before > Container.Last - and then Before > Container.Last + 1 - then + if Before > Container.Last and then Before > Container.Last + 1 then raise Constraint_Error with "Before index is out of range (too large)"; end if; @@ -1973,7 +2087,6 @@ package body Ada.Containers.Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then New_Last := No_Index + Index_Type'Base (New_Length); - else New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); end if; @@ -2081,7 +2194,6 @@ package body Ada.Containers.Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else Dst_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); @@ -2113,7 +2225,6 @@ package body Ada.Containers.Vectors is if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Index := Before + Index_Type'Base (Count); - else Index := Index_Type'Base (Count_Type'Base (Before) + Count); end if; @@ -2166,9 +2277,7 @@ package body Ada.Containers.Vectors is end if; if Count = 0 then - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then Position := No_Element; else Position := (Container'Unrestricted_Access, Before.Index); @@ -2177,9 +2286,7 @@ package body Ada.Containers.Vectors is return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then + if Before.Container = null or else Before.Index > Container.Last then if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; @@ -2250,9 +2357,9 @@ package body Ada.Containers.Vectors is -- for a reverse iterator, Container.Last is the beginning. return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => No_Index) + (Limited_Controlled with + Container => V, + Index => No_Index) do B := B + 1; end return; @@ -2303,9 +2410,9 @@ package body Ada.Containers.Vectors is -- is a forward or reverse iteration. return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => Start.Index) + (Limited_Controlled with + Container => V, + Index => Start.Index) do B := B + 1; end return; @@ -2455,14 +2562,12 @@ package body Ada.Containers.Vectors is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Next designates wrong vector"; + else + return Next (Position); end if; - - return Next (Position); end Next; procedure Next (Position : in out Cursor) is @@ -2491,10 +2596,7 @@ package body Ada.Containers.Vectors is Count : Count_Type := 1) is begin - Insert (Container, - Index_Type'First, - New_Item, - Count); + Insert (Container, Index_Type'First, New_Item, Count); end Prepend; -------------- @@ -2516,14 +2618,12 @@ package body Ada.Containers.Vectors is begin if Position.Container = null then return No_Element; - end if; - - if Position.Container /= Object.Container then + elsif Position.Container /= Object.Container then raise Program_Error with "Position cursor of Previous designates wrong vector"; + else + return Previous (Position); end if; - - return Previous (Position); end Previous; procedure Previous (Position : in out Cursor) is @@ -2578,9 +2678,9 @@ package body Ada.Containers.Vectors is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; + else + Query_Element (Position.Container.all, Position.Index, Process); end if; - - Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; ---------- @@ -2677,6 +2777,7 @@ package body Ada.Containers.Vectors is begin if Index > Container.Last then raise Constraint_Error with "Index is out of range"; + else declare C : Vector renames Container'Unrestricted_Access.all; @@ -2706,14 +2807,12 @@ package body Ada.Containers.Vectors is begin if Index > Container.Last then raise Constraint_Error with "Index is out of range"; - end if; - - if Container.Lock > 0 then + elsif Container.Lock > 0 then raise Program_Error with "attempt to tamper with elements (vector is locked)"; + else + Container.Elements.EA (Index) := New_Item; end if; - - Container.Elements.EA (Index) := New_Item; end Replace_Element; procedure Replace_Element @@ -2724,22 +2823,21 @@ package body Ada.Containers.Vectors is begin if Position.Container = null then raise Constraint_Error with "Position cursor has no element"; - end if; - if Position.Container /= Container'Unrestricted_Access then + elsif Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; - end if; - if Position.Index > Container.Last then + elsif Position.Index > Container.Last then raise Constraint_Error with "Position cursor is out of range"; - end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is locked)"; - end if; + else + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is locked)"; + end if; - Container.Elements.EA (Position.Index) := New_Item; + Container.Elements.EA (Position.Index) := New_Item; + end if; end Replace_Element; ---------------------- @@ -3126,13 +3224,42 @@ package body Ada.Containers.Vectors is then Container.Last else Position.Index); - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements.EA (Indx) = Item then - return (Container'Unrestricted_Access, Indx); + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + + Result : Index_Type'Base; + + begin + B := B + 1; + L := L + 1; + + Result := No_Index; + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements.EA (Indx) = Item then + Result := Indx; + exit; + end if; + end loop; + + B := B - 1; + L := L - 1; + + if Result = No_Index then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Result); end if; - end loop; - return No_Element; + exception + when others => + B := B - 1; + L := L - 1; + raise; + end; end Reverse_Find; ------------------------ @@ -3144,17 +3271,39 @@ package body Ada.Containers.Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is + B : Natural renames Container'Unrestricted_Access.Busy; + L : Natural renames Container'Unrestricted_Access.Lock; + Last : constant Index_Type'Base := Index_Type'Min (Container.Last, Index); + Result : Index_Type'Base; + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + + Result := No_Index; for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then - return Indx; + Result := Indx; + exit; end if; end loop; - return No_Index; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Reverse_Find_Index; --------------------- @@ -3245,21 +3394,19 @@ package body Ada.Containers.Vectors is begin if I.Container = null then raise Constraint_Error with "I cursor has no element"; - end if; - if J.Container = null then + elsif J.Container = null then raise Constraint_Error with "J cursor has no element"; - end if; - if I.Container /= Container'Unrestricted_Access then + elsif I.Container /= Container'Unrestricted_Access then raise Program_Error with "I cursor denotes wrong container"; - end if; - if J.Container /= Container'Unrestricted_Access then + elsif J.Container /= Container'Unrestricted_Access then raise Program_Error with "J cursor denotes wrong container"; - end if; - Swap (Container, I.Index, J.Index); + else + Swap (Container, I.Index, J.Index); + end if; end Swap; --------------- @@ -3286,13 +3433,11 @@ package body Ada.Containers.Vectors is begin if Position.Container = null then return No_Index; - end if; - - if Position.Index <= Position.Container.Last then + elsif Position.Index <= Position.Container.Last then return Position.Index; + else + return No_Index; end if; - - return No_Index; end To_Index; --------------- diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index aa8fa91a8c5..52025bb5c2c 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -39,26 +39,6 @@ with System; use type System.Address; package body Ada.Containers.Ordered_Maps is - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Reversible_Iterator with - record - Container : Map_Access; - Node : Node_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------------- -- Node Access Subprograms -- ----------------------------- diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads index d9281faccc3..2a642ac47cb 100644 --- a/gcc/ada/a-coorma.ads +++ b/gcc/ada/a-coorma.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -354,4 +354,24 @@ private No_Element : constant Cursor := Cursor'(null, null); + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Node_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb index 2cc76319747..a3c5ab5c97e 100644 --- a/gcc/ada/a-coormu.adb +++ b/gcc/ada/a-coormu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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,26 +42,6 @@ with System; use type System.Address; package body Ada.Containers.Ordered_Multisets is - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Reversible_Iterator with - record - Container : Set_Access; - Node : Node_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ----------------------------- -- Node Access Subprograms -- ----------------------------- diff --git a/gcc/ada/a-coormu.ads b/gcc/ada/a-coormu.ads index a832cac77f0..8d684741e94 100644 --- a/gcc/ada/a-coormu.ads +++ b/gcc/ada/a-coormu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -512,4 +512,24 @@ private Busy => 0, Lock => 0)); + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Ordered_Multisets; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index f92760f573d..e7ac52b2325 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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,26 +42,6 @@ with System; use type System.Address; package body Ada.Containers.Ordered_Sets is - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Reversible_Iterator with - record - Container : Set_Access; - Node : Node_Access; - end record; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - ------------------------------ -- Access to Fields of Node -- ------------------------------ @@ -987,12 +967,15 @@ package body Ada.Containers.Ordered_Sets is B : Natural renames Tree.Busy; L : Natural renames Tree.Lock; + Eq : Boolean; + begin B := B + 1; L := L + 1; begin Process (E); + Eq := Equivalent_Keys (K, Key (E)); exception when others => L := L - 1; @@ -1003,7 +986,7 @@ package body Ada.Containers.Ordered_Sets is L := L - 1; B := B - 1; - if Equivalent_Keys (K, Key (E)) then + if Eq then return; end if; end; @@ -1716,17 +1699,56 @@ package body Ada.Containers.Ordered_Sets is return Node; end New_Node; - Hint : Node_Access; - Result : Node_Access; - Inserted : Boolean; + Hint : Node_Access; + Result : Node_Access; + Inserted : Boolean; + Compare : Boolean; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - -- Start of processing for Replace_Element + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + -- Start of processing for Replace_Element begin - if Item < Node.Element or else Node.Element < Item then - null; + -- Replace_Element assigns value Item to the element designated by Node, + -- per certain semantic constraints. + + -- If Item is equivalent to the element, then element is replaced and + -- there's nothing else to do. This is the easy case. + + -- If Item is not equivalent, then the node will (possibly) have to move + -- to some other place in the tree. This is slighly more complicated, + -- because we must ensure that Item is not equivalent to some other + -- element in the tree (in which case, the replacement is not allowed). + + -- Determine whether Item is equivalent to element on the specified + -- node. + + begin + B := B + 1; + L := L + 1; + + Compare := (if Item < Node.Element then False + elsif Node.Element < Item then False + else True); + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + if Compare then + -- Item is equivalent to the node's element, so we will not have to + -- move the node. - else if Tree.Lock > 0 then raise Program_Error with "attempt to tamper with elements (set is locked)"; @@ -1736,12 +1758,66 @@ package body Ada.Containers.Ordered_Sets is return; end if; + -- The replacement Item is not equivalent to the element on the + -- specified node, which means that it will need to be re-inserted in a + -- different position in the tree. We must now determine whether Item is + -- equivalent to some other element in the tree (which would prohibit + -- the assignment and hence the move). + + -- Ceiling returns the smallest element equivalent or greater than the + -- specified Item; if there is no such element, then it returns null. + Hint := Element_Keys.Ceiling (Tree, Item); - if Hint = null then - null; + if Hint /= null then + begin + B := B + 1; + L := L + 1; + + Compare := Item < Hint.Element; + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + -- Item >= Hint.Element + + if not Compare then + + -- Ceiling returns an element that is equivalent or greater + -- than Item. If Item is "not less than" the element, then + -- by elimination we know that Item is equivalent to the element. + + -- But this means that it is not possible to assign the value of + -- Item to the specified element (on Node), because a different + -- element (on Hint) equivalent to Item already exsits. (Were we + -- to change Node's element value, we would have to move Node, but + -- we would be unable to move the Node, because its new position + -- in the tree is already occupied by an equivalent element.) + + raise Program_Error with "attempt to replace existing element"; + end if; + + -- Item is not equivalent to any other element in the tree, so it is + -- safe to assign the value of Item to Node.Element. This means that + -- the node will have to move to a different position in the tree + -- (because its element will have a different value). + + -- The nearest (greater) neighbor of Item is Hint. This will be the + -- insertion position of Node (because its element will have Item as + -- its new value). + + -- If Node equals Hint, the relative position of Node does not + -- change. This allows us to perform an optimization: we need not + -- remove Node from the tree and then reinsert it with its new value, + -- because it would only be placed in the exact same position. - elsif Item < Hint.Element then if Hint = Node then if Tree.Lock > 0 then raise Program_Error with @@ -1751,15 +1827,18 @@ package body Ada.Containers.Ordered_Sets is Node.Element := Item; return; end if; - - else - pragma Assert (not (Hint.Element < Item)); - raise Program_Error with "attempt to replace existing element"; end if; + -- If we get here, it is because Item was greater than all elements in + -- the tree (Hint = null), or because Item was less than some element at + -- a different place in the tree (Item < Hint.Element). In either case, + -- we remove Node from the tree (without actually deallocating it), and + -- then insert Item into the tree, onto the same Node (so no new node is + -- actually allocated). + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit - Local_Insert_With_Hint + Local_Insert_With_Hint -- use unconditional insert here instead??? (Tree => Tree, Position => Hint, Key => Item, diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index e28a71bc299..cf0110c74c2 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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 -- @@ -399,4 +399,24 @@ private No_Element : constant Cursor := Cursor'(null, null); + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + end Ada.Containers.Ordered_Sets; diff --git a/gcc/ada/a-crbtgk.adb b/gcc/ada/a-crbtgk.adb index 713e5426948..7cc3b250c5a 100644 --- a/gcc/ada/a-crbtgk.adb +++ b/gcc/ada/a-crbtgk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -38,10 +38,26 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- AKA Lower_Bound function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is + B : Natural renames Tree'Unrestricted_Access.Busy; + L : Natural renames Tree'Unrestricted_Access.Lock; + Y : Node_Access; X : Node_Access; begin + -- If the container is empty, return a result immediately, so that we do + -- not manipulate the tamper bits unnecessarily. + + if Tree.Root = null then + return null; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + X := Tree.Root; while X /= null loop if Is_Greater_Key_Node (Key, X) then @@ -52,18 +68,45 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end if; end loop; + B := B - 1; + L := L - 1; + return Y; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Ceiling; ---------- -- Find -- ---------- - function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is + function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is + B : Natural renames Tree'Unrestricted_Access.Busy; + L : Natural renames Tree'Unrestricted_Access.Lock; + Y : Node_Access; X : Node_Access; + Result : Node_Access; + begin + -- If the container is empty, return a result immediately, so that we do + -- not manipulate the tamper bits unnecessarily. + + if Tree.Root = null then + return null; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + X := Tree.Root; while X /= null loop if Is_Greater_Key_Node (Key, X) then @@ -75,25 +118,52 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end loop; if Y = null then - return null; - end if; + Result := null; - if Is_Less_Key_Node (Key, Y) then - return null; + elsif Is_Less_Key_Node (Key, Y) then + Result := null; + + else + Result := Y; end if; - return Y; + B := B - 1; + L := L - 1; + + return Result; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Find; ----------- -- Floor -- ----------- - function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is + function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is + B : Natural renames Tree'Unrestricted_Access.Busy; + L : Natural renames Tree'Unrestricted_Access.Lock; + Y : Node_Access; X : Node_Access; begin + -- If the container is empty, return a result immediately, so that we do + -- not manipulate the tamper bits unnecessarily. + + if Tree.Root = null then + return null; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B := B + 1; + L := L + 1; + X := Tree.Root; while X /= null loop if Is_Less_Key_Node (Key, X) then @@ -104,7 +174,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end if; end loop; + B := B - 1; + L := L - 1; + return Y; + + exception + when others => + B := B - 1; + L := L - 1; + raise; end Floor; -------------------------------- @@ -117,8 +196,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Node : out Node_Access; Inserted : out Boolean) is - Y : Node_Access := null; - X : Node_Access := Tree.Root; + X : Node_Access; + Y : Node_Access; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + Compare : Boolean; begin -- This is a "conditional" insertion, meaning that the insertion request @@ -132,22 +219,47 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- its previous neighbor, in order for the conditional insertion to -- succeed. + -- Handle insertion into an empty container as a special case, so that + -- we do not manipulate the tamper bits unnecessarily. + + if Tree.Root = null then + Insert_Post (Tree, null, True, Node); + Inserted := True; + return; + end if; + -- We search the tree to find the nearest neighbor of Key, which is -- either the smallest node greater than Key (Inserted is True), or the -- largest node less or equivalent to Key (Inserted is False). - Inserted := True; - while X /= null loop - Y := X; - Inserted := Is_Less_Key_Node (Key, X); - X := (if Inserted then Ops.Left (X) else Ops.Right (X)); - end loop; + begin + B := B + 1; + L := L + 1; + + X := Tree.Root; + Y := null; + Inserted := True; + while X /= null loop + Y := X; + Inserted := Is_Less_Key_Node (Key, X); + X := (if Inserted then Ops.Left (X) else Ops.Right (X)); + end loop; + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; if Inserted then - -- Either Tree is empty, or Key is less than Y. If Y is the first - -- node in the tree, then there are no other nodes that we need to - -- search for, and we insert a new node into the tree. + -- Key is less than Y. If Y is the first node in the tree, then there + -- are no other nodes that we need to search for, and we insert a new + -- node into the tree. if Y = Tree.First then Insert_Post (Tree, Y, True, Node); @@ -172,7 +284,23 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- Key is equivalent to or greater than Node. We must resolve which is -- the case, to determine whether the conditional insertion succeeds. - if Is_Greater_Key_Node (Key, Node) then + begin + B := B + 1; + L := L + 1; + + Compare := Is_Greater_Key_Node (Key, Node); + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + if Compare then -- Key is strictly greater than Node, which means that Key is not -- equivalent to Node. In this case, the insertion succeeds, and we @@ -201,6 +329,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Node : out Node_Access; Inserted : out Boolean) is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + Test : Node_Access; + Compare : Boolean; + begin -- The purpose of a hint is to avoid a search from the root of -- tree. If we have it hint it means we only need to traverse the @@ -209,15 +346,38 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- is not a search and the only comparisons that occur are with -- the hint and its neighbor. - -- If Position is null, this is interpreted to mean that Key is - -- large relative to the nodes in the tree. If the tree is empty, - -- or Key is greater than the last node in the tree, then we're - -- done; otherwise the hint was "wrong" and we must search. + -- Handle insertion into an empty container as a special case, so that + -- we do not manipulate the tamper bits unnecessarily. + + if Tree.Root = null then + Insert_Post (Tree, null, True, Node); + Inserted := True; + return; + end if; + + -- If Position is null, this is interpreted to mean that Key is large + -- relative to the nodes in the tree. If Key is greater than the last + -- node in the tree, then we're done; otherwise the hint was "wrong" and + -- we must search. if Position = null then -- largest - if Tree.Last = null - or else Is_Greater_Key_Node (Key, Tree.Last) - then + begin + B := B + 1; + L := L + 1; + + Compare := Is_Greater_Key_Node (Key, Tree.Last); + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + if Compare then Insert_Post (Tree, Tree.Last, False, Node); Inserted := True; else @@ -246,68 +406,131 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- then its neighbor must be anterior and so we insert before the -- hint. - if Is_Less_Key_Node (Key, Position) then - declare - Before : constant Node_Access := Ops.Previous (Position); + begin + B := B + 1; + L := L + 1; + + Compare := Is_Less_Key_Node (Key, Position); + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + if Compare then + Test := Ops.Previous (Position); -- "before" + + if Test = null then -- new first node + Insert_Post (Tree, Tree.First, True, Node); + + Inserted := True; + return; + end if; begin - if Before = null then - Insert_Post (Tree, Tree.First, True, Node); - Inserted := True; + B := B + 1; + L := L + 1; + + Compare := Is_Greater_Key_Node (Key, Test); - elsif Is_Greater_Key_Node (Key, Before) then - if Ops.Right (Before) = null then - Insert_Post (Tree, Before, False, Node); - else - Insert_Post (Tree, Position, True, Node); - end if; + L := L - 1; + B := B - 1; - Inserted := True; + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + if Compare then + if Ops.Right (Test) = null then + Insert_Post (Tree, Test, False, Node); else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + Insert_Post (Tree, Position, True, Node); end if; - end; + + Inserted := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; return; end if; - -- We know that Key isn't less than the hint so we try again, - -- this time to see if it's greater than the hint. If so we - -- compare Key to the node that follows the hint. If Key is both - -- greater than the hint and less than the hint's next neighbor, - -- then we're done; otherwise we must search. + -- We know that Key isn't less than the hint so we try again, this time + -- to see if it's greater than the hint. If so we compare Key to the + -- node that follows the hint. If Key is both greater than the hint and + -- less than the hint's next neighbor, then we're done; otherwise we + -- must search. - if Is_Greater_Key_Node (Key, Position) then - declare - After : constant Node_Access := Ops.Next (Position); + begin + B := B + 1; + L := L + 1; + + Compare := Is_Greater_Key_Node (Key, Position); + + L := L - 1; + B := B - 1; + + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + if Compare then + Test := Ops.Next (Position); -- "after" + + if Test = null then -- new last node + Insert_Post (Tree, Tree.Last, False, Node); + + Inserted := True; + return; + end if; begin - if After = null then - Insert_Post (Tree, Tree.Last, False, Node); - Inserted := True; + B := B + 1; + L := L + 1; + + Compare := Is_Less_Key_Node (Key, Test); - elsif Is_Less_Key_Node (Key, After) then - if Ops.Right (Position) = null then - Insert_Post (Tree, Position, False, Node); - else - Insert_Post (Tree, After, True, Node); - end if; + L := L - 1; + B := B - 1; - Inserted := True; + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + if Compare then + if Ops.Right (Position) = null then + Insert_Post (Tree, Position, False, Node); else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + Insert_Post (Tree, Test, True, Node); end if; - end; + + Inserted := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; return; end if; - -- We know that Key is neither less than the hint nor greater - -- than the hint, and that's the definition of equivalence. - -- There's nothing else we need to do, since a search would just - -- reach the same conclusion. + -- We know that Key is neither less than the hint nor greater than the + -- hint, and that's the definition of equivalence. There's nothing else + -- we need to do, since a search would just reach the same conclusion. Node := Position; Inserted := False; diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb index c8ddcff02a5..1255ff59155 100644 --- a/gcc/ada/a-crbtgo.adb +++ b/gcc/ada/a-crbtgo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -626,9 +626,17 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ------------------- function Generic_Equal (Left, Right : Tree_Type) return Boolean is + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + L_Node : Node_Access; R_Node : Node_Access; + Result : Boolean; + begin if Left'Address = Right'Address then return True; @@ -638,18 +646,52 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is return False; end if; + -- If the containers are empty, return a result immediately, so as to + -- not manipulate the tamper bits unnecessarily. + + if Left.Length = 0 then + return True; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + L_Node := Left.First; R_Node := Right.First; + Result := True; while L_Node /= null loop if not Is_Equal (L_Node, R_Node) then - return False; + Result := False; + exit; end if; L_Node := Next (L_Node); R_Node := Next (R_Node); end loop; - return True; + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; end Generic_Equal; ----------------------- diff --git a/gcc/ada/a-envvar.adb b/gcc/ada/a-envvar.adb index d0caa25cf51..edcbeb86039 100644 --- a/gcc/ada/a-envvar.adb +++ b/gcc/ada/a-envvar.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -223,4 +223,9 @@ package body Ada.Environment_Variables is end if; end Value; + function Value (Name : String; Default : String) return String is + begin + return (if Exists (Name) then Value (Name) else Default); + end Value; + end Ada.Environment_Variables; diff --git a/gcc/ada/a-envvar.ads b/gcc/ada/a-envvar.ads index 9769c9bb1ee..406aee388bb 100644 --- a/gcc/ada/a-envvar.ads +++ b/gcc/ada/a-envvar.ads @@ -13,6 +13,9 @@ -- -- ------------------------------------------------------------------------------ +-- The implementation of this package is as defined in the Ada 2012 RM, but +-- it is available in Ada 95 and Ada 2005 modes as well. + package Ada.Environment_Variables is pragma Preelaborate (Environment_Variables); @@ -23,6 +26,11 @@ package Ada.Environment_Variables is -- Constraint_Error is propagated. If the execution environment does not -- support environment variables, then Program_Error is propagated. + function Value (Name : String; Default : String) return String; + -- If the external execution environment supports environment variables and + -- an environment variable with the given name currently exists, then Value + -- returns its value; otherwise, it returns Default. + function Exists (Name : String) return Boolean; -- If the external execution environment supports environment variables and -- an environment variable with the given name currently exists, then @@ -33,9 +41,11 @@ package Ada.Environment_Variables is -- then Set first clears any existing environment variable with the given -- name, and then defines a single new environment variable with the given -- name and value. Otherwise Program_Error is propagated. + -- -- If implementation-defined circumstances prohibit the definition of an - -- environment variable with the given name and value, then + -- environment variable with the given name and value, then exception -- Constraint_Error is propagated. + -- -- It is implementation defined whether there exist values for which the -- call Set (Name, Value) has the same effect as Clear (Name). diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb index d66571396c7..ddf3fe2262a 100644 --- a/gcc/ada/a-rbtgbo.adb +++ b/gcc/ada/a-rbtgbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -606,9 +606,17 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is ------------------- function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + L_Node : Count_Type; R_Node : Count_Type; + Result : Boolean; + begin if Left'Address = Right'Address then return True; @@ -618,18 +626,52 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is return False; end if; + -- If the containers are empty, return a result immediately, so as to + -- not manipulate the tamper bits unnecessarily. + + if Left.Length = 0 then + return True; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + L_Node := Left.First; R_Node := Right.First; + Result := True; while L_Node /= 0 loop if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - return False; + Result := False; + exit; end if; L_Node := Next (Left, L_Node); R_Node := Next (Right, R_Node); end loop; - return True; + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; end Generic_Equal; ----------------------- diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb index 2b9b5402435..06a78e922c3 100644 --- a/gcc/ada/a-rbtgso.adb +++ b/gcc/ada/a-rbtgso.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -84,8 +84,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ---------------- procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is - Tgt : Node_Access := Target.First; - Src : Node_Access := Source.First; + BT : Natural renames Target.Busy; + LT : Natural renames Target.Lock; + + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + + Tgt : Node_Access; + Src : Node_Access; + + Compare : Integer; begin if Target'Address = Source'Address then @@ -107,19 +115,56 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is "attempt to tamper with cursors (container is busy)"; end if; + Tgt := Target.First; + Src := Source.First; loop if Tgt = null then - return; + exit; end if; if Src = null then - return; + exit; end if; - if Is_Less (Tgt, Src) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + begin + BT := BT + 1; + LT := LT + 1; + + BS := BS + 1; + LS := LS + 1; + + if Is_Less (Tgt, Src) then + Compare := -1; + elsif Is_Less (Src, Tgt) then + Compare := 1; + else + Compare := 0; + end if; + + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + exception + when others => + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + raise; + end; + + if Compare < 0 then Tgt := Tree_Operations.Next (Tgt); - elsif Is_Less (Src, Tgt) then + elsif Compare > 0 then Src := Tree_Operations.Next (Src); else @@ -137,34 +182,66 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end Difference; function Difference (Left, Right : Tree_Type) return Tree_Type is - Tree : Tree_Type; - - L_Node : Node_Access := Left.First; - R_Node : Node_Access := Right.First; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then - return Tree; -- Empty set + return Tree_Type'(others => <>); -- Empty set end if; if Left.Length = 0 then - return Tree; -- Empty set + return Tree_Type'(others => <>); -- Empty set end if; if Right.Length = 0 then return Copy (Left); end if; - loop - if L_Node = null then - return Tree; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; - if R_Node = null then - while L_Node /= null loop + Tree : Tree_Type; + + L_Node : Node_Access; + R_Node : Node_Access; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null then + exit; + end if; + + if R_Node = null then + while L_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + end loop; + + exit; + end if; + + if Is_Less (L_Node, R_Node) then Insert_With_Hint (Dst_Tree => Tree, Dst_Hint => null, @@ -173,33 +250,34 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is L_Node := Tree_Operations.Next (L_Node); - end loop; + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); - return Tree; - end if; + else + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; - if Is_Less (L_Node, R_Node) then - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => L_Node, - Dst_Node => Dst_Node); + BL := BL - 1; + LL := LL - 1; - L_Node := Tree_Operations.Next (L_Node); + BR := BR - 1; + LR := LR - 1; - elsif Is_Less (R_Node, L_Node) then - R_Node := Tree_Operations.Next (R_Node); + return Tree; - else - L_Node := Tree_Operations.Next (L_Node); - R_Node := Tree_Operations.Next (R_Node); - end if; - end loop; + exception + when others => + BL := BL - 1; + LL := LL - 1; - exception - when others => - Delete_Tree (Tree.Root); - raise; + BR := BR - 1; + LR := LR - 1; + + Delete_Tree (Tree.Root); + raise; + end; end Difference; ------------------ @@ -210,8 +288,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is (Target : in out Tree_Type; Source : Tree_Type) is - Tgt : Node_Access := Target.First; - Src : Node_Access := Source.First; + BT : Natural renames Target.Busy; + LT : Natural renames Target.Lock; + + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + + Tgt : Node_Access; + Src : Node_Access; + + Compare : Integer; begin if Target'Address = Source'Address then @@ -228,10 +314,47 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return; end if; + Tgt := Target.First; + Src := Source.First; while Tgt /= null and then Src /= null loop - if Is_Less (Tgt, Src) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + begin + BT := BT + 1; + LT := LT + 1; + + BS := BS + 1; + LS := LS + 1; + + if Is_Less (Tgt, Src) then + Compare := -1; + elsif Is_Less (Src, Tgt) then + Compare := 1; + else + Compare := 0; + end if; + + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + exception + when others => + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + raise; + end; + + if Compare < 0 then declare X : Node_Access := Tgt; begin @@ -240,7 +363,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Free (X); end; - elsif Is_Less (Src, Tgt) then + elsif Compare > 0 then Src := Tree_Operations.Next (Src); else @@ -261,50 +384,84 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end Intersection; function Intersection (Left, Right : Tree_Type) return Tree_Type is - Tree : Tree_Type; - - L_Node : Node_Access := Left.First; - R_Node : Node_Access := Right.First; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then return Copy (Left); end if; - loop - if L_Node = null then - return Tree; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if R_Node = null then - return Tree; - end if; + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; - if Is_Less (L_Node, R_Node) then - L_Node := Tree_Operations.Next (L_Node); + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; - elsif Is_Less (R_Node, L_Node) then - R_Node := Tree_Operations.Next (R_Node); + Tree : Tree_Type; - else - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => L_Node, - Dst_Node => Dst_Node); + L_Node : Node_Access; + R_Node : Node_Access; - L_Node := Tree_Operations.Next (L_Node); - R_Node := Tree_Operations.Next (R_Node); - end if; - end loop; + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null then + exit; + end if; - exception - when others => - Delete_Tree (Tree.Root); - raise; + if R_Node = null then + exit; + end if; + + if Is_Less (L_Node, R_Node) then + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Tree; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + Delete_Tree (Tree.Root); + raise; + end; end Intersection; --------------- @@ -324,22 +481,44 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return False; end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + declare - Subset_Node : Node_Access := Subset.First; - Set_Node : Node_Access := Of_Set.First; + BL : Natural renames Subset'Unrestricted_Access.Busy; + LL : Natural renames Subset'Unrestricted_Access.Lock; + + BR : Natural renames Of_Set'Unrestricted_Access.Busy; + LR : Natural renames Of_Set'Unrestricted_Access.Lock; + + Subset_Node : Node_Access; + Set_Node : Node_Access; + + Result : Boolean; begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + Subset_Node := Subset.First; + Set_Node := Of_Set.First; loop if Set_Node = null then - return Subset_Node = null; + Result := Subset_Node = null; + exit; end if; if Subset_Node = null then - return True; + Result := True; + exit; end if; if Is_Less (Subset_Node, Set_Node) then - return False; + Result := False; + exit; end if; if Is_Less (Set_Node, Subset_Node) then @@ -349,6 +528,24 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Subset_Node := Tree_Operations.Next (Subset_Node); end if; end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; end; end Is_Subset; @@ -357,31 +554,73 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is ------------- function Overlap (Left, Right : Tree_Type) return Boolean is - L_Node : Node_Access := Left.First; - R_Node : Node_Access := Right.First; - begin if Left'Address = Right'Address then return Left.Length /= 0; end if; - loop - if L_Node = null - or else R_Node = null - then - return False; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. - if Is_Less (L_Node, R_Node) then - L_Node := Tree_Operations.Next (L_Node); + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; - elsif Is_Less (R_Node, L_Node) then - R_Node := Tree_Operations.Next (R_Node); + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; - else - return True; - end if; - end loop; + L_Node : Node_Access; + R_Node : Node_Access; + + Result : Boolean; + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null + or else R_Node = null + then + Result := False; + exit; + end if; + + if Is_Less (L_Node, R_Node) then + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + Result := True; + exit; + end if; + end loop; + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + return Result; + + exception + when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + + raise; + end; end Overlap; -------------------------- @@ -392,23 +631,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is (Target : in out Tree_Type; Source : Tree_Type) is - Tgt : Node_Access := Target.First; - Src : Node_Access := Source.First; + BT : Natural renames Target.Busy; + LT : Natural renames Target.Lock; + + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + + Tgt : Node_Access; + Src : Node_Access; New_Tgt_Node : Node_Access; pragma Warnings (Off, New_Tgt_Node); - begin - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + Compare : Integer; + begin if Target'Address = Source'Address then Clear (Target); return; end if; + Tgt := Target.First; + Src := Source.First; loop if Tgt = null then while Src /= null loop @@ -428,10 +672,45 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return; end if; - if Is_Less (Tgt, Src) then + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + begin + BT := BT + 1; + LT := LT + 1; + + BS := BS + 1; + LS := LS + 1; + + if Is_Less (Tgt, Src) then + Compare := -1; + elsif Is_Less (Src, Tgt) then + Compare := 1; + else + Compare := 0; + end if; + + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + exception + when others => + BT := BT - 1; + LT := LT - 1; + + BS := BS - 1; + LS := LS - 1; + + raise; + end; + + if Compare < 0 then Tgt := Tree_Operations.Next (Tgt); - elsif Is_Less (Src, Tgt) then + elsif Compare > 0 then Insert_With_Hint (Dst_Tree => Target, Dst_Hint => Tgt, @@ -455,17 +734,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end Symmetric_Difference; function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is - Tree : Tree_Type; - - L_Node : Node_Access := Left.First; - R_Node : Node_Access := Right.First; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - begin if Left'Address = Right'Address then - return Tree; -- Empty set + return Tree_Type'(others => <>); -- Empty set end if; if Right.Length = 0 then @@ -476,70 +747,111 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return Copy (Right); end if; - loop - if L_Node = null then - while R_Node /= null loop + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + + Tree : Tree_Type; + + L_Node : Node_Access; + R_Node : Node_Access; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null then + while R_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => R_Node, + Dst_Node => Dst_Node); + R_Node := Tree_Operations.Next (R_Node); + end loop; + + exit; + end if; + + if R_Node = null then + while L_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + end loop; + + exit; + end if; + + if Is_Less (L_Node, R_Node) then Insert_With_Hint (Dst_Tree => Tree, Dst_Hint => null, - Src_Node => R_Node, + Src_Node => L_Node, Dst_Node => Dst_Node); - R_Node := Tree_Operations.Next (R_Node); - end loop; - return Tree; - end if; + L_Node := Tree_Operations.Next (L_Node); - if R_Node = null then - while L_Node /= null loop + elsif Is_Less (R_Node, L_Node) then Insert_With_Hint (Dst_Tree => Tree, Dst_Hint => null, - Src_Node => L_Node, + Src_Node => R_Node, Dst_Node => Dst_Node); - L_Node := Tree_Operations.Next (L_Node); - end loop; + R_Node := Tree_Operations.Next (R_Node); - return Tree; - end if; + else + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; - if Is_Less (L_Node, R_Node) then - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => L_Node, - Dst_Node => Dst_Node); + BL := BL - 1; + LL := LL - 1; - L_Node := Tree_Operations.Next (L_Node); + BR := BR - 1; + LR := LR - 1; - elsif Is_Less (R_Node, L_Node) then - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => R_Node, - Dst_Node => Dst_Node); + return Tree; - R_Node := Tree_Operations.Next (R_Node); + exception + when others => + BL := BL - 1; + LL := LL - 1; - else - L_Node := Tree_Operations.Next (L_Node); - R_Node := Tree_Operations.Next (R_Node); - end if; - end loop; + BR := BR - 1; + LR := LR - 1; - exception - when others => - Delete_Tree (Tree.Root); - raise; + Delete_Tree (Tree.Root); + raise; + end; end Symmetric_Difference; ----------- -- Union -- ----------- - procedure Union (Target : in out Tree_Type; Source : Tree_Type) - is + procedure Union (Target : in out Tree_Type; Source : Tree_Type) is Hint : Node_Access; procedure Process (Node : Node_Access); @@ -555,7 +867,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is begin Insert_With_Hint (Dst_Tree => Target, - Dst_Hint => Hint, + Dst_Hint => Hint, -- use node most recently inserted as hint Src_Node => Node, Dst_Node => Hint); end Process; @@ -567,12 +879,29 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors (container is busy)"; - end if; + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + BS : Natural renames Source'Unrestricted_Access.Busy; + LS : Natural renames Source'Unrestricted_Access.Lock; + + begin + BS := BS + 1; + LS := LS + 1; + + Iterate (Source); - Iterate (Source); + BS := BS - 1; + LS := LS - 1; + + exception + when others => + BS := BS - 1; + LS := LS - 1; + + raise; + end; end Union; function Union (Left, Right : Tree_Type) return Tree_Type is @@ -590,6 +919,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end if; declare + BL : Natural renames Left'Unrestricted_Access.Busy; + LL : Natural renames Left'Unrestricted_Access.Lock; + + BR : Natural renames Right'Unrestricted_Access.Busy; + LR : Natural renames Right'Unrestricted_Access.Lock; + Tree : Tree_Type := Copy (Left); Hint : Node_Access; @@ -608,7 +943,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is begin Insert_With_Hint (Dst_Tree => Tree, - Dst_Hint => Hint, + Dst_Hint => Hint, -- use node most recently inserted as hint Src_Node => Node, Dst_Node => Hint); end Process; @@ -616,15 +951,33 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- Start of processing for Union begin + BL := BL + 1; + LL := LL + 1; + + BR := BR + 1; + LR := LR + 1; + Iterate (Right); + + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + return Tree; exception when others => + BL := BL - 1; + LL := LL - 1; + + BR := BR - 1; + LR := LR - 1; + Delete_Tree (Tree.Root); raise; end; - end Union; end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; diff --git a/gcc/ada/a-stzunb-shared.ads b/gcc/ada/a-stzunb-shared.ads index f8d3816a623..66c0427d8ac 100644 --- a/gcc/ada/a-stzunb-shared.ads +++ b/gcc/ada/a-stzunb-shared.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 -- @@ -477,7 +477,7 @@ private -- reallocation when all of the following requirements are meat: -- - shared data object don't used anywhere longer; -- - its size is sufficient to store new value; - -- - the gap after reuse is less then some threshold. + -- - the gap after reuse is less than some threshold. -- - memory preallocation. Most of used memory allocation algorithms -- aligns allocated segment on the some boundary, thus some amount of diff --git a/gcc/ada/adabkend.adb b/gcc/ada/adabkend.adb index 96bd00d99df..4a77920a2d6 100644 --- a/gcc/ada/adabkend.adb +++ b/gcc/ada/adabkend.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- -- @@ -234,6 +234,15 @@ package body Adabkend is then if Is_Switch (Argv) then Fail ("Object file name missing after -gnatO"); + + -- In SPARK_Mode, such an object file is never written, and the + -- call to Set_Output_Object_File_Name may fail (e.g. when the + -- object file name does not have the expected suffix). So we + -- skip that call when SPARK_Mode is set. + + elsif SPARK_Mode then + Output_File_Name_Seen := True; + else Set_Output_Object_File_Name (Argv); Output_File_Name_Seen := True; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index dc94d63d556..c4bb7540c52 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.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- * @@ -213,6 +213,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)); #else #include <utime.h> @@ -820,7 +822,8 @@ __gnat_rmdir (char *path) } FILE * -__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED) +__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED, + char *vms_form ATTRIBUTE_UNUSED) { #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) TCHAR wpath[GNAT_MAX_PATH_LEN]; @@ -837,7 +840,37 @@ __gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED) return _tfopen (wpath, wmode); #elif defined (VMS) - return decc$fopen (path, mode); + if (vms_form == 0) + return decc$fopen (path, mode); + else + { + char *local_form = (char *) alloca (strlen (vms_form) + 1); + /* Allocate an argument list of guaranteed ample length. */ + unsigned long long *arg_list = + (unsigned long long *) alloca (strlen (vms_form) + 3); + char *ptrb, *ptre; + int i; + + arg_list [1] = (unsigned long long) path; + arg_list [2] = (unsigned long long) mode; + strcpy (local_form, vms_form); + + /* Given a string such as "\"rfm=udf\",\"rat=cr\"" + Split it into an argument list as "rfm=udf","rat=cr". */ + ptrb = local_form; + for (i = 0; *ptrb; i++) + { + ptrb = strchr (ptrb, '"'); + ptre = strchr (ptrb + 1, '"'); + *ptre = 0; + arg_list [i + 3] = (unsigned long long) (ptrb + 1); + ptrb = ptre + 1; + } + arg_list [0] = i + 2; + /* CALLG_64 returns int , fortunately (FILE *) on VMS is a + always a 32bit pointer. */ + return LIB$CALLG_64 (arg_list, &decc$fopen); + } #else return GNAT_FOPEN (path, mode); #endif @@ -847,7 +880,8 @@ FILE * __gnat_freopen (char *path, char *mode, FILE *stream, - int encoding ATTRIBUTE_UNUSED) + int encoding ATTRIBUTE_UNUSED, + char *vms_form ATTRIBUTE_UNUSED) { #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) TCHAR wpath[GNAT_MAX_PATH_LEN]; @@ -864,7 +898,38 @@ __gnat_freopen (char *path, return _tfreopen (wpath, wmode, stream); #elif defined (VMS) - return decc$freopen (path, mode, stream); + if (vms_form == 0) + return decc$freopen (path, mode, stream); + else + { + char *local_form = (char *) alloca (strlen (vms_form) + 1); + /* Allocate an argument list of guaranteed ample length. */ + unsigned long long *arg_list = + (unsigned long long *) alloca (strlen (vms_form) + 4); + char *ptrb, *ptre; + int i; + + arg_list [1] = (unsigned long long) path; + arg_list [2] = (unsigned long long) mode; + arg_list [3] = (unsigned long long) stream; + strcpy (local_form, vms_form); + + /* Given a string such as "\"rfm=udf\",\"rat=cr\"" + Split it into an argument list as "rfm=udf","rat=cr". */ + ptrb = local_form; + for (i = 0; *ptrb; i++) + { + ptrb = strchr (ptrb, '"'); + ptre = strchr (ptrb + 1, '"'); + *ptre = 0; + arg_list [i + 4] = (unsigned long long) (ptrb + 1); + ptrb = ptre + 1; + } + arg_list [0] = i + 3; + /* CALLG_64 returns int , fortunately (FILE *) on VMS is a + always a 32bit pointer. */ + return LIB$CALLG_64 (arg_list, &decc$freopen); + } #else return freopen (path, mode, stream); #endif diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 7956e27a709..78af57c9dae 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.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- * @@ -128,9 +128,10 @@ extern int __gnat_rename (char *, char *); extern int __gnat_chdir (char *); extern int __gnat_rmdir (char *); -extern FILE *__gnat_fopen (char *, char *, int); +extern FILE *__gnat_fopen (char *, char *, int, + char *); extern FILE *__gnat_freopen (char *, char *, FILE *, - int); + int, char *); extern int __gnat_open_read (char *, int); extern int __gnat_open_rw (char *, int); extern int __gnat_open_create (char *, int); diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index 0c2e87d5111..92380f8eb35 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.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- -- @@ -35,6 +35,8 @@ with Snames; use Snames; with Stringt; with Styleg; +with System.OS_Lib; use System.OS_Lib; + package body ALI.Util is -- Empty procedures needed to instantiate Scng. Error procedures are @@ -272,7 +274,11 @@ package body ALI.Util is Error_Msg ("{ had errors, must be fixed, and recompiled"); Set_Name_Table_Info (Afile, Int (No_Unit_Id)); + -- In formal verification mode, object files are never + -- generated, so No_Object=True is not considered an error. + elsif ALIs.Table (Idread).No_Object + and then not SPARK_Mode and then not Ignore_Errors then Error_Msg_File_1 := Withs.Table (W).Sfile; @@ -355,6 +361,7 @@ package body ALI.Util is if Stamp (Stamp'First) /= ' ' then Source.Table (S).Stamp := Stamp; Source.Table (S).Source_Found := True; + Source.Table (S).Stamp_File := F; -- If we could not find the file, then the stamp is set -- from the dependency table entry (to be possibly reset @@ -363,6 +370,7 @@ package body ALI.Util is else Source.Table (S).Stamp := Sdep.Table (D).Stamp; Source.Table (S).Source_Found := False; + Source.Table (S).Stamp_File := ALIs.Table (A).Afile; -- In All_Sources mode, flag error of file not found @@ -376,8 +384,9 @@ package body ALI.Util is -- is off, so simply initialize the stamp from the Sdep entry else - Source.Table (S).Source_Found := False; Source.Table (S).Stamp := Sdep.Table (D).Stamp; + Source.Table (S).Source_Found := False; + Source.Table (S).Stamp_File := ALIs.Table (A).Afile; end if; -- Here if this is not the first time for this source file, @@ -403,13 +412,19 @@ package body ALI.Util is -- source file even if Check_Source_Files is false, since -- if we find it, then we can use it to resolve which of the -- two timestamps in the ALI files is likely to be correct. + -- We only look in the current directory, because when + -- Check_Source_Files is false, other search directories are + -- likely to be incorrect. - if not Check_Source_Files then + if not Check_Source_Files + and then Is_Regular_File (Get_Name_String (F)) + then Stamp := Source_File_Stamp (F); if Stamp (Stamp'First) /= ' ' then Source.Table (S).Stamp := Stamp; Source.Table (S).Source_Found := True; + Source.Table (S).Stamp_File := F; end if; end if; @@ -428,6 +443,7 @@ package body ALI.Util is else if Sdep.Table (D).Stamp > Source.Table (S).Stamp then Source.Table (S).Stamp := Sdep.Table (D).Stamp; + Source.Table (S).Stamp_File := ALIs.Table (A).Afile; end if; end if; end if; diff --git a/gcc/ada/ali-util.ads b/gcc/ada/ali-util.ads index 707fec7f1f6..251f3e7c5af 100644 --- a/gcc/ada/ali-util.ads +++ b/gcc/ada/ali-util.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- -- @@ -57,6 +57,13 @@ package ALI.Util is -- located and the Stamp value was set from the actual source file. -- It is always false if Check_Source_Files is not set. + Stamp_File : File_Name_Type; + -- File that Stamp came from. If Source_Found is True, then Stamp is the + -- timestamp of the source file, and this is the name of the source + -- file. If Source_Found is False, then Stamp comes from a dependency + -- line in an ALI file, this is the name of that ALI file. Used only in + -- verbose mode, for messages. + All_Timestamps_Match : Boolean; -- This flag is set only if all files referencing this source file -- have a matching time stamp, and also, if Source_Found is True, diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 0386c05fe5a..6c2f8187a92 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.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- -- @@ -57,7 +57,7 @@ package body ALI is 'Y' => True, -- limited_with 'Z' => True, -- implicit with from instantiation 'C' => True, -- SCO information - 'F' => True, -- Alfa information + 'F' => True, -- SPARK cross-reference information others => False); -------------------- @@ -1331,9 +1331,9 @@ package body ALI is when Constraint_Error => -- A constraint error comes from the - -- additionh. We reset to the maximum - -- and indicate that the real value is - -- now unknown. + -- addition. We reset to the maximum + -- and indicate that the real value + -- is now unknown. Cumulative_Restrictions.Value (R) := Integer'Last; @@ -2670,7 +2670,7 @@ package body ALI is -- Here after dealing with xref sections -- Ignore remaining lines, which belong to an additional section of the - -- ALI file not considered here (like SCO or Alfa). + -- ALI file not considered here (like SCO or SPARK information). Check_Unknown_Line; diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 523deaaa0ac..71f74939ca4 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.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- -- @@ -39,6 +39,36 @@ with GNAT.HTable; use GNAT.HTable; package body Aspects is + -- The following array indicates aspects that a subtype inherits from its + -- base type. True means that the subtype inherits the aspect from its base + -- type. False means it is not inherited. + + Base_Aspect : constant array (Aspect_Id) of Boolean := + (Aspect_Atomic => True, + Aspect_Atomic_Components => True, + Aspect_Constant_Indexing => True, + Aspect_Default_Iterator => True, + Aspect_Discard_Names => True, + Aspect_Independent_Components => True, + Aspect_Iterator_Element => True, + Aspect_Type_Invariant => True, + Aspect_Unchecked_Union => True, + Aspect_Variable_Indexing => True, + Aspect_Volatile => True, + others => False); + + -- The following array indicates type aspects that are inherited and apply + -- to the class-wide type as well. + + Inherited_Aspect : constant array (Aspect_Id) of Boolean := + (Aspect_Constant_Indexing => True, + Aspect_Default_Iterator => True, + Aspect_Implicit_Dereference => True, + Aspect_Iterator_Element => True, + Aspect_Remote_Types => True, + Aspect_Variable_Indexing => True, + others => False); + procedure Set_Aspect_Specifications_No_Check (N : Node_Id; L : List_Id); -- Same as Set_Aspect_Specifications, but does not contain the assertion -- that checks that N does not already have aspect specifications. This @@ -110,65 +140,123 @@ package body Aspects is end if; end Aspect_Specifications; - ------------------- - -- Get_Aspect_Id -- - ------------------- - - function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is - begin - return Aspect_Id_Hash_Table.Get (Name); - end Get_Aspect_Id; - ----------------- -- Find_Aspect -- ----------------- - function Find_Aspect (Ent : Entity_Id; A : Aspect_Id) return Node_Id is - Ritem : Node_Id; - Typ : Entity_Id; + function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id is + Decl : Node_Id; + Item : Node_Id; + Owner : Entity_Id; + Spec : Node_Id; begin + Owner := Id; - -- If the aspect is an inherited one and the entity is a class-wide - -- type, use the aspect of the specific type. If the type is a base - -- aspect, examine the rep. items of the base type. + -- Handle various cases of base or inherited aspects for types - if Is_Type (Ent) then + if Is_Type (Id) then if Base_Aspect (A) then - Typ := Base_Type (Ent); - else - Typ := Ent; + Owner := Base_Type (Owner); end if; - if Is_Class_Wide_Type (Typ) - and then Inherited_Aspect (A) - then - Ritem := First_Rep_Item (Etype (Typ)); - else - Ritem := First_Rep_Item (Typ); + if Is_Class_Wide_Type (Owner) and then Inherited_Aspect (A) then + Owner := Root_Type (Owner); end if; - else - Ritem := First_Rep_Item (Ent); + if Is_Private_Type (Owner) and then Present (Full_View (Owner)) then + Owner := Full_View (Owner); + end if; end if; - while Present (Ritem) loop - if Nkind (Ritem) = N_Aspect_Specification - and then Get_Aspect_Id (Chars (Identifier (Ritem))) = A + -- Search the representation items for the desired aspect + + Item := First_Rep_Item (Owner); + while Present (Item) loop + if Nkind (Item) = N_Aspect_Specification + and then Get_Aspect_Id (Item) = A then - if A = Aspect_Default_Iterator then - return Expression (Aspect_Rep_Item (Ritem)); - else - return Expression (Ritem); - end if; + return Item; end if; - Next_Rep_Item (Ritem); + Next_Rep_Item (Item); end loop; + -- Note that not all aspects are added to the chain of representation + -- items. In such cases, search the list of aspect specifications. First + -- find the declaration node where the aspects reside. This is usually + -- the parent or the parent of the parent. + + Decl := Parent (Owner); + if not Permits_Aspect_Specifications (Decl) then + Decl := Parent (Decl); + end if; + + -- Search the list of aspect specifications for the desired aspect + + if Permits_Aspect_Specifications (Decl) then + Spec := First (Aspect_Specifications (Decl)); + while Present (Spec) loop + if Get_Aspect_Id (Spec) = A then + return Spec; + end if; + + Next (Spec); + end loop; + end if; + + -- The entity does not carry any aspects or the desired aspect was not + -- found. + return Empty; end Find_Aspect; + -------------------------- + -- Find_Value_Of_Aspect -- + -------------------------- + + function Find_Value_Of_Aspect + (Id : Entity_Id; + A : Aspect_Id) return Node_Id + is + Spec : constant Node_Id := Find_Aspect (Id, A); + + begin + if Present (Spec) then + if A = Aspect_Default_Iterator then + return Expression (Aspect_Rep_Item (Spec)); + else + return Expression (Spec); + end if; + end if; + + return Empty; + end Find_Value_Of_Aspect; + + ------------------- + -- Get_Aspect_Id -- + ------------------- + + function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is + begin + return Aspect_Id_Hash_Table.Get (Name); + end Get_Aspect_Id; + + function Get_Aspect_Id (Aspect : Node_Id) return Aspect_Id is + begin + pragma Assert (Nkind (Aspect) = N_Aspect_Specification); + return Aspect_Id_Hash_Table.Get (Chars (Identifier (Aspect))); + end Get_Aspect_Id; + + ---------------- + -- Has_Aspect -- + ---------------- + + function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean is + begin + return Present (Find_Aspect (Id, A)); + end Has_Aspect; + ------------------ -- Move_Aspects -- ------------------ @@ -220,6 +308,7 @@ package body Aspects is N_Subprogram_Body => 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_Type_Declaration => True, @@ -252,13 +341,13 @@ package body Aspects is Aspect_Compiler_Unit => Aspect_Compiler_Unit, Aspect_Component_Size => Aspect_Component_Size, Aspect_Constant_Indexing => Aspect_Constant_Indexing, - Aspect_Contract_Case => Aspect_Contract_Case, Aspect_Contract_Cases => Aspect_Contract_Cases, Aspect_Convention => Aspect_Convention, Aspect_CPU => Aspect_CPU, Aspect_Default_Component_Value => Aspect_Default_Component_Value, Aspect_Default_Iterator => Aspect_Default_Iterator, Aspect_Default_Value => Aspect_Default_Value, + Aspect_Depends => Aspect_Depends, Aspect_Dimension => Aspect_Dimension, Aspect_Dimension_System => Aspect_Dimension_System, Aspect_Discard_Names => Aspect_Discard_Names, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index c3199cc0d4b..6941cc1c666 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -81,13 +81,13 @@ package Aspects is Aspect_Bit_Order, Aspect_Component_Size, Aspect_Constant_Indexing, - Aspect_Contract_Case, -- GNAT Aspect_Contract_Cases, -- GNAT Aspect_Convention, Aspect_CPU, Aspect_Default_Component_Value, Aspect_Default_Iterator, Aspect_Default_Value, + Aspect_Depends, -- GNAT Aspect_Dimension, -- GNAT Aspect_Dimension_System, -- GNAT Aspect_Dispatching_Domain, @@ -186,7 +186,7 @@ package Aspects is -- Aspects that have a static boolean value but don't correspond to -- pragmas - Aspect_Lock_Free); + Aspect_Lock_Free); -- GNAT subtype Aspect_Id_Exclude_No_Aspect is Aspect_Id range Aspect_Id'Succ (No_Aspect) .. Aspect_Id'Last; @@ -195,89 +195,58 @@ package Aspects is -- The following array indicates aspects that accept 'Class Class_Aspect_OK : constant array (Aspect_Id) of Boolean := - (Aspect_Invariant => True, - Aspect_Pre => True, - Aspect_Predicate => True, - Aspect_Post => True, - Aspect_Type_Invariant => True, - others => False); - - -- The following array indicates aspects that a subtype inherits from - -- its base type. True means that the subtype inherits the aspect from - -- its base type. False means it is not inherited. - - Base_Aspect : constant array (Aspect_Id) of Boolean := - (Aspect_Atomic => True, - Aspect_Atomic_Components => True, - Aspect_Discard_Names => True, - Aspect_Independent_Components => True, - Aspect_Iterator_Element => True, - Aspect_Constant_Indexing => True, - Aspect_Default_Iterator => True, - Aspect_Type_Invariant => True, - Aspect_Unchecked_Union => True, - Aspect_Variable_Indexing => True, - Aspect_Volatile => True, - others => False); + (Aspect_Invariant => True, + Aspect_Pre => True, + Aspect_Predicate => True, + Aspect_Post => True, + Aspect_Type_Invariant => True, + others => False); -- The following array identifies all implementation defined aspects - Impl_Defined_Aspects : constant array (Aspect_Id) of Boolean := - (Aspect_Abstract_State => True, - Aspect_Ada_2005 => True, - Aspect_Ada_2012 => True, - Aspect_Compiler_Unit => True, - Aspect_Contract_Case => True, - Aspect_Contract_Cases => True, - Aspect_Dimension => True, - Aspect_Dimension_System => True, - Aspect_Favor_Top_Level => True, - Aspect_Global => True, - Aspect_Inline_Always => True, - Aspect_Invariant => True, - Aspect_Lock_Free => True, - Aspect_Object_Size => True, - Aspect_Persistent_BSS => True, - Aspect_Predicate => True, - Aspect_Preelaborate_05 => True, - Aspect_Pure_05 => True, - Aspect_Pure_12 => True, - Aspect_Pure_Function => True, - Aspect_Remote_Access_Type => True, - Aspect_Scalar_Storage_Order => True, - Aspect_Shared => True, - Aspect_Simple_Storage_Pool => True, - Aspect_Simple_Storage_Pool_Type => True, - Aspect_Suppress_Debug_Info => True, - Aspect_Test_Case => True, - Aspect_Universal_Aliasing => True, - Aspect_Universal_Data => True, - Aspect_Unmodified => True, - Aspect_Unreferenced => True, - Aspect_Unreferenced_Objects => True, - Aspect_Value_Size => True, - Aspect_Warnings => True, - others => False); + Implementation_Defined_Aspect : constant array (Aspect_Id) of Boolean := + (Aspect_Abstract_State => True, + Aspect_Ada_2005 => True, + Aspect_Ada_2012 => True, + Aspect_Compiler_Unit => True, + Aspect_Contract_Cases => True, + Aspect_Depends => True, + Aspect_Dimension => True, + Aspect_Dimension_System => True, + Aspect_Favor_Top_Level => True, + Aspect_Global => True, + Aspect_Inline_Always => True, + Aspect_Invariant => True, + Aspect_Lock_Free => True, + Aspect_Object_Size => True, + Aspect_Persistent_BSS => True, + Aspect_Predicate => True, + Aspect_Preelaborate_05 => True, + Aspect_Pure_05 => True, + Aspect_Pure_12 => True, + Aspect_Pure_Function => True, + Aspect_Remote_Access_Type => True, + Aspect_Scalar_Storage_Order => True, + Aspect_Shared => True, + Aspect_Simple_Storage_Pool => True, + Aspect_Simple_Storage_Pool_Type => True, + Aspect_Suppress_Debug_Info => True, + Aspect_Test_Case => True, + Aspect_Universal_Aliasing => True, + Aspect_Universal_Data => True, + Aspect_Unmodified => True, + Aspect_Unreferenced => True, + Aspect_Unreferenced_Objects => True, + Aspect_Value_Size => True, + Aspect_Warnings => True, + others => False); -- The following array indicates aspects for which multiple occurrences of -- the same aspect attached to the same declaration are allowed. No_Duplicates_Allowed : constant array (Aspect_Id) of Boolean := - (Aspect_Contract_Case => False, - Aspect_Test_Case => False, - others => True); - - -- The following array indicates type aspects that are inherited and apply - -- to the class-wide type as well. - - Inherited_Aspect : constant array (Aspect_Id) of Boolean := - (Aspect_Constant_Indexing => True, - Aspect_Default_Iterator => True, - Aspect_Implicit_Dereference => True, - Aspect_Iterator_Element => True, - Aspect_Remote_Types => True, - Aspect_Variable_Indexing => True, - others => False); + (Aspect_Test_Case => False, + others => True); -- The following subtype defines aspects corresponding to library unit -- pragmas, these can only validly appear as aspects for library units, @@ -310,65 +279,65 @@ package Aspects is -- The following array indicates what argument type is required Aspect_Argument : constant array (Aspect_Id) of Aspect_Expression := - (No_Aspect => Optional, - Aspect_Abstract_State => Expression, - Aspect_Address => Expression, - Aspect_Alignment => Expression, - Aspect_Attach_Handler => Expression, - Aspect_Bit_Order => Expression, - Aspect_Component_Size => Expression, - Aspect_Constant_Indexing => Name, - Aspect_Contract_Case => Expression, - Aspect_Contract_Cases => Expression, - Aspect_Convention => Name, - Aspect_CPU => Expression, - Aspect_Default_Component_Value => Expression, - Aspect_Default_Iterator => Name, - Aspect_Default_Value => Expression, - Aspect_Dimension => Expression, - Aspect_Dimension_System => Expression, - Aspect_Dispatching_Domain => Expression, - Aspect_Dynamic_Predicate => Expression, - Aspect_External_Name => Expression, - Aspect_External_Tag => Expression, - Aspect_Global => Expression, - Aspect_Implicit_Dereference => Name, - Aspect_Input => Name, - Aspect_Interrupt_Priority => Expression, - Aspect_Invariant => Expression, - Aspect_Iterator_Element => Name, - Aspect_Link_Name => Expression, - Aspect_Machine_Radix => Expression, - Aspect_Object_Size => Expression, - Aspect_Output => Name, - Aspect_Post => Expression, - Aspect_Postcondition => Expression, - Aspect_Pre => Expression, - Aspect_Precondition => Expression, - Aspect_Predicate => Expression, - Aspect_Priority => Expression, - Aspect_Read => Name, - Aspect_Relative_Deadline => Expression, - Aspect_Scalar_Storage_Order => Expression, - Aspect_Simple_Storage_Pool => Name, - Aspect_Size => Expression, - Aspect_Small => Expression, - Aspect_Static_Predicate => Expression, - Aspect_Storage_Pool => Name, - Aspect_Storage_Size => Expression, - Aspect_Stream_Size => Expression, - Aspect_Suppress => Name, - Aspect_Synchronization => Name, - Aspect_Test_Case => Expression, - Aspect_Type_Invariant => Expression, - Aspect_Unsuppress => Name, - Aspect_Value_Size => Expression, - Aspect_Variable_Indexing => Name, - Aspect_Warnings => Name, - Aspect_Write => Name, - - Library_Unit_Aspects => Optional, - Boolean_Aspects => Optional); + (No_Aspect => Optional, + Aspect_Abstract_State => Expression, + Aspect_Address => Expression, + Aspect_Alignment => Expression, + Aspect_Attach_Handler => Expression, + Aspect_Bit_Order => Expression, + Aspect_Component_Size => Expression, + Aspect_Constant_Indexing => Name, + Aspect_Contract_Cases => Expression, + Aspect_Convention => Name, + Aspect_CPU => Expression, + Aspect_Default_Component_Value => Expression, + Aspect_Default_Iterator => Name, + Aspect_Default_Value => Expression, + Aspect_Depends => Expression, + Aspect_Dimension => Expression, + Aspect_Dimension_System => Expression, + Aspect_Dispatching_Domain => Expression, + Aspect_Dynamic_Predicate => Expression, + Aspect_External_Name => Expression, + Aspect_External_Tag => Expression, + Aspect_Global => Expression, + Aspect_Implicit_Dereference => Name, + Aspect_Input => Name, + Aspect_Interrupt_Priority => Expression, + Aspect_Invariant => Expression, + Aspect_Iterator_Element => Name, + Aspect_Link_Name => Expression, + Aspect_Machine_Radix => Expression, + Aspect_Object_Size => Expression, + Aspect_Output => Name, + Aspect_Post => Expression, + Aspect_Postcondition => Expression, + Aspect_Pre => Expression, + Aspect_Precondition => Expression, + Aspect_Predicate => Expression, + Aspect_Priority => Expression, + Aspect_Read => Name, + Aspect_Relative_Deadline => Expression, + Aspect_Scalar_Storage_Order => Expression, + Aspect_Simple_Storage_Pool => Name, + Aspect_Size => Expression, + Aspect_Small => Expression, + Aspect_Static_Predicate => Expression, + Aspect_Storage_Pool => Name, + Aspect_Storage_Size => Expression, + Aspect_Stream_Size => Expression, + Aspect_Suppress => Name, + Aspect_Synchronization => Name, + Aspect_Test_Case => Expression, + Aspect_Type_Invariant => Expression, + Aspect_Unsuppress => Name, + Aspect_Value_Size => Expression, + Aspect_Variable_Indexing => Name, + Aspect_Warnings => Name, + Aspect_Write => Name, + + Boolean_Aspects => Optional, + Library_Unit_Aspects => Optional); ----------------------------------------- -- Table Linking Names and Aspect_Id's -- @@ -376,112 +345,117 @@ package Aspects is -- Table linking aspect names and id's - Aspect_Names : constant array (Aspect_Id) of Name_Id := ( - No_Aspect => No_Name, - Aspect_Abstract_State => Name_Abstract_State, - Aspect_Ada_2005 => Name_Ada_2005, - Aspect_Ada_2012 => Name_Ada_2012, - Aspect_Address => Name_Address, - Aspect_Alignment => Name_Alignment, - Aspect_All_Calls_Remote => Name_All_Calls_Remote, - Aspect_Asynchronous => Name_Asynchronous, - Aspect_Atomic => Name_Atomic, - Aspect_Atomic_Components => Name_Atomic_Components, - Aspect_Attach_Handler => Name_Attach_Handler, - Aspect_Bit_Order => Name_Bit_Order, - Aspect_Compiler_Unit => Name_Compiler_Unit, - Aspect_Component_Size => Name_Component_Size, - Aspect_Constant_Indexing => Name_Constant_Indexing, - Aspect_Contract_Case => Name_Contract_Case, - Aspect_Contract_Cases => Name_Contract_Cases, - Aspect_Convention => Name_Convention, - Aspect_CPU => Name_CPU, - Aspect_Default_Iterator => Name_Default_Iterator, - Aspect_Default_Value => Name_Default_Value, - Aspect_Default_Component_Value => Name_Default_Component_Value, - Aspect_Dimension => Name_Dimension, - Aspect_Dimension_System => Name_Dimension_System, - Aspect_Discard_Names => Name_Discard_Names, - Aspect_Dispatching_Domain => Name_Dispatching_Domain, - Aspect_Dynamic_Predicate => Name_Dynamic_Predicate, - Aspect_Elaborate_Body => Name_Elaborate_Body, - Aspect_External_Name => Name_External_Name, - Aspect_External_Tag => Name_External_Tag, - Aspect_Export => Name_Export, - Aspect_Favor_Top_Level => Name_Favor_Top_Level, - Aspect_Global => Name_Global, - Aspect_Implicit_Dereference => Name_Implicit_Dereference, - Aspect_Import => Name_Import, - Aspect_Independent => Name_Independent, - Aspect_Independent_Components => Name_Independent_Components, - Aspect_Inline => Name_Inline, - Aspect_Inline_Always => Name_Inline_Always, - Aspect_Input => Name_Input, - Aspect_Interrupt_Handler => Name_Interrupt_Handler, - Aspect_Interrupt_Priority => Name_Interrupt_Priority, - Aspect_Invariant => Name_Invariant, - Aspect_Iterator_Element => Name_Iterator_Element, - Aspect_Link_Name => Name_Link_Name, - Aspect_Lock_Free => Name_Lock_Free, - Aspect_Machine_Radix => Name_Machine_Radix, - Aspect_No_Return => Name_No_Return, - Aspect_Object_Size => Name_Object_Size, - Aspect_Output => Name_Output, - Aspect_Pack => Name_Pack, - Aspect_Persistent_BSS => Name_Persistent_BSS, - Aspect_Post => Name_Post, - Aspect_Postcondition => Name_Postcondition, - Aspect_Pre => Name_Pre, - Aspect_Precondition => Name_Precondition, - Aspect_Predicate => Name_Predicate, - Aspect_Preelaborable_Initialization => Name_Preelaborable_Initialization, - Aspect_Preelaborate => Name_Preelaborate, - Aspect_Preelaborate_05 => Name_Preelaborate_05, - Aspect_Priority => Name_Priority, - Aspect_Pure => Name_Pure, - Aspect_Pure_05 => Name_Pure_05, - Aspect_Pure_12 => Name_Pure_12, - Aspect_Pure_Function => Name_Pure_Function, - Aspect_Read => Name_Read, - Aspect_Relative_Deadline => Name_Relative_Deadline, - Aspect_Remote_Access_Type => Name_Remote_Access_Type, - Aspect_Remote_Call_Interface => Name_Remote_Call_Interface, - Aspect_Remote_Types => Name_Remote_Types, - Aspect_Scalar_Storage_Order => Name_Scalar_Storage_Order, - Aspect_Shared => Name_Shared, - Aspect_Shared_Passive => Name_Shared_Passive, - Aspect_Simple_Storage_Pool => Name_Simple_Storage_Pool, - Aspect_Simple_Storage_Pool_Type => Name_Simple_Storage_Pool_Type, - Aspect_Size => Name_Size, - Aspect_Small => Name_Small, - Aspect_Static_Predicate => Name_Static_Predicate, - Aspect_Storage_Pool => Name_Storage_Pool, - Aspect_Storage_Size => Name_Storage_Size, - Aspect_Stream_Size => Name_Stream_Size, - Aspect_Suppress => Name_Suppress, - Aspect_Suppress_Debug_Info => Name_Suppress_Debug_Info, - Aspect_Synchronization => Name_Synchronization, - Aspect_Test_Case => Name_Test_Case, - Aspect_Type_Invariant => Name_Type_Invariant, - Aspect_Unchecked_Union => Name_Unchecked_Union, - Aspect_Universal_Aliasing => Name_Universal_Aliasing, - Aspect_Universal_Data => Name_Universal_Data, - Aspect_Unmodified => Name_Unmodified, - Aspect_Unreferenced => Name_Unreferenced, - Aspect_Unreferenced_Objects => Name_Unreferenced_Objects, - Aspect_Unsuppress => Name_Unsuppress, - Aspect_Value_Size => Name_Value_Size, - Aspect_Variable_Indexing => Name_Variable_Indexing, - Aspect_Volatile => Name_Volatile, - Aspect_Volatile_Components => Name_Volatile_Components, - Aspect_Warnings => Name_Warnings, - Aspect_Write => Name_Write); + Aspect_Names : constant array (Aspect_Id) of Name_Id := + (No_Aspect => No_Name, + Aspect_Abstract_State => Name_Abstract_State, + Aspect_Ada_2005 => Name_Ada_2005, + Aspect_Ada_2012 => Name_Ada_2012, + Aspect_Address => Name_Address, + Aspect_Alignment => Name_Alignment, + Aspect_All_Calls_Remote => Name_All_Calls_Remote, + Aspect_Asynchronous => Name_Asynchronous, + Aspect_Atomic => Name_Atomic, + Aspect_Atomic_Components => Name_Atomic_Components, + Aspect_Attach_Handler => Name_Attach_Handler, + Aspect_Bit_Order => Name_Bit_Order, + Aspect_Compiler_Unit => Name_Compiler_Unit, + Aspect_Component_Size => Name_Component_Size, + Aspect_Constant_Indexing => Name_Constant_Indexing, + Aspect_Contract_Cases => Name_Contract_Cases, + Aspect_Convention => Name_Convention, + Aspect_CPU => Name_CPU, + Aspect_Default_Iterator => Name_Default_Iterator, + Aspect_Default_Value => Name_Default_Value, + Aspect_Default_Component_Value => Name_Default_Component_Value, + Aspect_Depends => Name_Depends, + Aspect_Dimension => Name_Dimension, + Aspect_Dimension_System => Name_Dimension_System, + Aspect_Discard_Names => Name_Discard_Names, + Aspect_Dispatching_Domain => Name_Dispatching_Domain, + Aspect_Dynamic_Predicate => Name_Dynamic_Predicate, + Aspect_Elaborate_Body => Name_Elaborate_Body, + Aspect_External_Name => Name_External_Name, + Aspect_External_Tag => Name_External_Tag, + Aspect_Export => Name_Export, + Aspect_Favor_Top_Level => Name_Favor_Top_Level, + Aspect_Global => Name_Global, + Aspect_Implicit_Dereference => Name_Implicit_Dereference, + Aspect_Import => Name_Import, + Aspect_Independent => Name_Independent, + Aspect_Independent_Components => Name_Independent_Components, + Aspect_Inline => Name_Inline, + Aspect_Inline_Always => Name_Inline_Always, + Aspect_Input => Name_Input, + Aspect_Interrupt_Handler => Name_Interrupt_Handler, + Aspect_Interrupt_Priority => Name_Interrupt_Priority, + Aspect_Invariant => Name_Invariant, + Aspect_Iterator_Element => Name_Iterator_Element, + Aspect_Link_Name => Name_Link_Name, + Aspect_Lock_Free => Name_Lock_Free, + Aspect_Machine_Radix => Name_Machine_Radix, + Aspect_No_Return => Name_No_Return, + Aspect_Object_Size => Name_Object_Size, + Aspect_Output => Name_Output, + Aspect_Pack => Name_Pack, + Aspect_Persistent_BSS => Name_Persistent_BSS, + Aspect_Post => Name_Post, + Aspect_Postcondition => Name_Postcondition, + Aspect_Pre => Name_Pre, + Aspect_Precondition => Name_Precondition, + Aspect_Predicate => Name_Predicate, + Aspect_Preelaborable_Initialization => Name_Preelaborable_Initialization, + Aspect_Preelaborate => Name_Preelaborate, + Aspect_Preelaborate_05 => Name_Preelaborate_05, + Aspect_Priority => Name_Priority, + Aspect_Pure => Name_Pure, + Aspect_Pure_05 => Name_Pure_05, + Aspect_Pure_12 => Name_Pure_12, + Aspect_Pure_Function => Name_Pure_Function, + Aspect_Read => Name_Read, + Aspect_Relative_Deadline => Name_Relative_Deadline, + Aspect_Remote_Access_Type => Name_Remote_Access_Type, + Aspect_Remote_Call_Interface => Name_Remote_Call_Interface, + Aspect_Remote_Types => Name_Remote_Types, + Aspect_Scalar_Storage_Order => Name_Scalar_Storage_Order, + Aspect_Shared => Name_Shared, + Aspect_Shared_Passive => Name_Shared_Passive, + Aspect_Simple_Storage_Pool => Name_Simple_Storage_Pool, + Aspect_Simple_Storage_Pool_Type => Name_Simple_Storage_Pool_Type, + Aspect_Size => Name_Size, + Aspect_Small => Name_Small, + Aspect_Static_Predicate => Name_Static_Predicate, + Aspect_Storage_Pool => Name_Storage_Pool, + Aspect_Storage_Size => Name_Storage_Size, + Aspect_Stream_Size => Name_Stream_Size, + Aspect_Suppress => Name_Suppress, + Aspect_Suppress_Debug_Info => Name_Suppress_Debug_Info, + Aspect_Synchronization => Name_Synchronization, + Aspect_Test_Case => Name_Test_Case, + Aspect_Type_Invariant => Name_Type_Invariant, + Aspect_Unchecked_Union => Name_Unchecked_Union, + Aspect_Universal_Aliasing => Name_Universal_Aliasing, + Aspect_Universal_Data => Name_Universal_Data, + Aspect_Unmodified => Name_Unmodified, + Aspect_Unreferenced => Name_Unreferenced, + Aspect_Unreferenced_Objects => Name_Unreferenced_Objects, + Aspect_Unsuppress => Name_Unsuppress, + Aspect_Value_Size => Name_Value_Size, + Aspect_Variable_Indexing => Name_Variable_Indexing, + Aspect_Volatile => Name_Volatile, + Aspect_Volatile_Components => Name_Volatile_Components, + Aspect_Warnings => Name_Warnings, + Aspect_Write => Name_Write); function Get_Aspect_Id (Name : Name_Id) return Aspect_Id; pragma Inline (Get_Aspect_Id); -- Given a name Nam, returns the corresponding aspect id value. If the name -- does not match any aspect, then No_Aspect is returned as the result. + function Get_Aspect_Id (Aspect : Node_Id) return Aspect_Id; + pragma Inline (Get_Aspect_Id); + -- Given an aspect specification, return the corresponding aspect_id value. + -- If the name does not match any aspect, return No_Aspect. + --------------------------------------------------- -- Handling of Aspect Specifications in the Tree -- --------------------------------------------------- @@ -496,11 +470,6 @@ package Aspects is -- implemented internally with a hash table in the body, that provides -- access to aspect specifications. - function Permits_Aspect_Specifications (N : Node_Id) return Boolean; - -- Returns True if the node N is a declaration node that permits aspect - -- specifications in the grammar. It is possible for other nodes to have - -- aspect specifications as a result of Rewrite or Replace calls. - function Aspect_Specifications (N : Node_Id) return List_Id; -- Given a node N, returns the list of N_Aspect_Specification nodes that -- are attached to this declaration node. If the node is in the class of @@ -515,18 +484,18 @@ package Aspects is -- Replace calls, and this function may be used to retrieve the aspect -- specifications for the original rewritten node in such cases. - procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id); - -- The node N must be in the class of declaration nodes that permit aspect - -- specifications and the Has_Aspects flag must be False on entry. L must - -- be a non-empty list of N_Aspect_Specification nodes. This procedure sets - -- the Has_Aspects flag to True, and makes an entry that can be retrieved - -- by a subsequent Aspect_Specifications call. It is an error to call this - -- procedure with a node that does not permit aspect specifications, or a - -- node that has its Has_Aspects flag set True on entry, or with L being an - -- empty list or No_List. + function Find_Aspect (Id : Entity_Id; A : Aspect_Id) return Node_Id; + -- Find the aspect specification of aspect A associated with entity I. + -- Return Empty if Id does not have the requested aspect. - function Find_Aspect (Ent : Entity_Id; A : Aspect_Id) return Node_Id; - -- Find value of a given aspect from aspect list of entity + function Find_Value_Of_Aspect + (Id : Entity_Id; + A : Aspect_Id) return Node_Id; + -- Find the value of aspect A associated with entity Id. Return Empty if + -- Id does not have the requested aspect. + + function Has_Aspect (Id : Entity_Id; A : Aspect_Id) return Boolean; + -- Determine whether entity Id has aspect A procedure Move_Aspects (From : Node_Id; To : Node_Id); -- Moves aspects from 'From' node to 'To' node. Has_Aspects (To) must be @@ -534,15 +503,30 @@ package Aspects is -- Otherwise the aspects are moved and on return Has_Aspects (To) is True, -- and Has_Aspects (From) is False. + function Permits_Aspect_Specifications (N : Node_Id) return Boolean; + -- Returns True if the node N is a declaration node that permits aspect + -- specifications in the grammar. It is possible for other nodes to have + -- aspect specifications as a result of Rewrite or Replace calls. + function Same_Aspect (A1 : Aspect_Id; A2 : Aspect_Id) return Boolean; -- Returns True if A1 and A2 are (essentially) the same aspect. This is not -- a simple equality test because e.g. Post and Postcondition are the same. -- This is used for detecting duplicate aspects. - procedure Tree_Write; - -- Writes contents of Aspect_Specifications hash table to the tree file + procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id); + -- The node N must be in the class of declaration nodes that permit aspect + -- specifications and the Has_Aspects flag must be False on entry. L must + -- be a non-empty list of N_Aspect_Specification nodes. This procedure sets + -- the Has_Aspects flag to True, and makes an entry that can be retrieved + -- by a subsequent Aspect_Specifications call. It is an error to call this + -- procedure with a node that does not permit aspect specifications, or a + -- node that has its Has_Aspects flag set True on entry, or with L being an + -- empty list or No_List. procedure Tree_Read; -- Reads contents of Aspect_Specifications hash table from the tree file + procedure Tree_Write; + -- Writes contents of Aspect_Specifications hash table to the tree file + end Aspects; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index b287b57302d..40a27a1fb74 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.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- -- @@ -2526,6 +2526,12 @@ package body Atree is return Node_Id (Nodes.Table (N + 5).Field6); end Node30; + function Node31 (N : Node_Id) return Node_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return Node_Id (Nodes.Table (N + 5).Field7); + end Node31; + function List1 (N : Node_Id) return List_Id is begin pragma Assert (N <= Nodes.Last); @@ -5231,6 +5237,12 @@ package body Atree is Nodes.Table (N + 5).Field6 := Union_Id (Val); end Set_Node30; + procedure Set_Node31 (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 5).Field7 := Union_Id (Val); + end Set_Node31; + procedure Set_List1 (N : Node_Id; Val : List_Id) is begin pragma Assert (N <= Nodes.Last); diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index fc60293d65b..07e8e512a57 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.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- -- @@ -1171,6 +1171,9 @@ package Atree is function Node30 (N : Node_Id) return Node_Id; pragma Inline (Node30); + function Node31 (N : Node_Id) return Node_Id; + pragma Inline (Node31); + function List1 (N : Node_Id) return List_Id; pragma Inline (List1); @@ -2453,6 +2456,9 @@ package Atree is procedure Set_Node30 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node30); + procedure Set_Node31 (N : Node_Id; Val : Node_Id); + pragma Inline (Set_Node31); + procedure Set_List1 (N : Node_Id; Val : List_Id); pragma Inline (Set_List1); diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index 7d88c4d102c..c9fd5e0481b 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.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- * @@ -259,6 +259,45 @@ struct Flag_Word4 Boolean flag215 : 1; }; +/* Structure used for extra flags in sixth component overlaying Field12 */ +struct Flag_Word5 +{ + Boolean flag255 : 1; + Boolean flag256 : 1; + Boolean flag257 : 1; + Boolean flag258 : 1; + Boolean flag259 : 1; + Boolean flag260 : 1; + Boolean flag261 : 1; + Boolean flag262 : 1; + + Boolean flag263 : 1; + Boolean flag264 : 1; + Boolean flag265 : 1; + Boolean flag266 : 1; + Boolean flag267 : 1; + Boolean flag268 : 1; + Boolean flag269 : 1; + Boolean flag270 : 1; + + Boolean flag271 : 1; + Boolean flag272 : 1; + Boolean flag273 : 1; + Boolean flag274 : 1; + Boolean flag275 : 1; + Boolean flag276 : 1; + Boolean flag277 : 1; + Boolean flag278 : 1; + + Boolean flag279 : 1; + Boolean flag280 : 1; + Boolean flag281 : 1; + Boolean flag282 : 1; + Boolean flag283 : 1; + Boolean flag284 : 1; + Boolean flag285 : 1; + Boolean flag286 : 1; +}; struct Non_Extended { Source_Ptr sloc; @@ -290,6 +329,7 @@ struct Extended struct Flag_Word fw; struct Flag_Word2 fw2; struct Flag_Word4 fw4; + struct Flag_Word5 fw5; } U; }; @@ -387,7 +427,12 @@ extern Node_Id Current_Error_Node; #define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field9) #define Field28(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field10) #define Field29(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.field11) -#define Field30(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field6) +#define Field30(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field6) +#define Field31(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field7) +#define Field32(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field8) +#define Field33(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field9) +#define Field34(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field10) +#define Field35(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.X.field11) #define Node1(N) Field1 (N) #define Node2(N) Field2 (N) @@ -419,6 +464,12 @@ extern Node_Id Current_Error_Node; #define Node28(N) Field28 (N) #define Node29(N) Field29 (N) #define Node30(N) Field30 (N) +#define Node31(N) Field31 (N) +#define Node32(N) Field32 (N) +#define Node33(N) Field33 (N) +#define Node34(N) Field34 (N) +#define Node35(N) Field35 (N) +#define Node36(N) Field36 (N) #define List1(N) Field1 (N) #define List2(N) Field2 (N) @@ -742,6 +793,39 @@ extern Node_Id Current_Error_Node; #define Flag253(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag71) #define Flag254(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.NK.flag72) +#define Flag255(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag255) +#define Flag256(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag256) +#define Flag257(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag257) +#define Flag258(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag258) +#define Flag259(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag259) +#define Flag260(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag260) +#define Flag261(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag261) +#define Flag262(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag262) +#define Flag263(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag263) +#define Flag264(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag264) +#define Flag265(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag265) +#define Flag266(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag266) +#define Flag267(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag267) +#define Flag268(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag268) +#define Flag269(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag269) +#define Flag270(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag270) +#define Flag271(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag271) +#define Flag272(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag272) +#define Flag273(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag273) +#define Flag274(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag274) +#define Flag275(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag275) +#define Flag276(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag276) +#define Flag277(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag277) +#define Flag278(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag278) +#define Flag279(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag279) +#define Flag280(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag280) +#define Flag281(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag281) +#define Flag282(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag282) +#define Flag283(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag283) +#define Flag284(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag284) +#define Flag285(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag285) +#define Flag286(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.U.fw5.flag286) + #ifdef __cplusplus } #endif diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index f23230ecf9d..577d004c719 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.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- -- @@ -340,18 +340,6 @@ package body Back_End is end loop; end Scan_Compiler_Arguments; - ----------------------------- - -- Register_Back_End_Types -- - ----------------------------- - - procedure Register_Back_End_Types (Call_Back : Register_Type_Proc) is - procedure Enumerate_Modes (Call_Back : Register_Type_Proc); - pragma Import (C, Enumerate_Modes, "enumerate_modes"); - - begin - Enumerate_Modes (Call_Back); - end Register_Back_End_Types; - ------------------------------- -- Gen_Or_Update_Object_File -- ------------------------------- diff --git a/gcc/ada/back_end.ads b/gcc/ada/back_end.ads index bfa2eb5b440..ba25a83fb7e 100644 --- a/gcc/ada/back_end.ads +++ b/gcc/ada/back_end.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- -- @@ -23,10 +23,7 @@ -- -- ------------------------------------------------------------------------------ --- Call the back end with all the information needed. Also contains other --- back-end specific interfaces required by the front end. - -with Einfo; use Einfo; +-- Call the back end with all the information needed package Back_End is @@ -46,30 +43,11 @@ package Back_End is pragma Convention (C, Back_End_Mode_Type); for Back_End_Mode_Type use (0, 1, 2); - type C_String is array (0 .. 255) of aliased Character; - pragma Convention (C, C_String); - - type Register_Type_Proc is access procedure - (C_Name : C_String; -- Nul-terminated string with name of type - Digs : Natural; -- Nr or digits for floating point, 0 otherwise - Complex : Boolean; -- True iff type has real and imaginary parts - Count : Natural; -- Number of elements in vector, 0 otherwise - Float_Rep : Float_Rep_Kind; -- Representation used for fpt type - Size : Positive; -- Size of representation in bits - Alignment : Natural); -- Required alignment in bits - pragma Convention (C, Register_Type_Proc); - -- Call back procedure for Register_Back_End_Types. This is to be used by - -- Create_Standard to create predefined types for all types supported by - -- the back end. - - procedure Register_Back_End_Types (Call_Back : Register_Type_Proc); - -- Calls the Call_Back function with information for each supported type. - procedure Call_Back_End (Mode : Back_End_Mode_Type); -- Call back end, i.e. make call to driver traversing the tree and - -- outputting code. This call is made with all tables locked. - -- The back end is responsible for unlocking any tables it may need - -- to change, and locking them again before returning. + -- outputting code. This call is made with all tables locked. The back + -- end is responsible for unlocking any tables it may need to change, + -- and locking them again before returning. procedure Scan_Compiler_Arguments; -- Acquires command-line parameters passed to the compiler and processes diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb index 09354ecbcbb..fc2b9b62035 100644 --- a/gcc/ada/bcheck.adb +++ b/gcc/ada/bcheck.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- -- @@ -218,16 +218,27 @@ package body Bcheck is end if; if (not Tolerate_Consistency_Errors) and Verbose_Mode then - Error_Msg_File_1 := Sdep.Table (D).Sfile; + Error_Msg_File_1 := Source.Table (Src).Stamp_File; + + if Source.Table (Src).Source_Found then + Error_Msg_File_1 := + Osint.Full_Source_Name (Error_Msg_File_1); + else + Error_Msg_File_1 := + Osint.Full_Lib_File_Name (Error_Msg_File_1); + end if; + Error_Msg - ("{ time stamp " & String (Source.Table (Src).Stamp)); + ("time stamp from { " & String (Source.Table (Src).Stamp)); Error_Msg_File_1 := Sdep.Table (D).Sfile; - -- Something wrong here, should be different file ??? - Error_Msg (" conflicts with { timestamp " & String (Sdep.Table (D).Stamp)); + + Error_Msg_File_1 := + Osint.Full_Lib_File_Name (ALIs.Table (A).Afile); + Error_Msg (" from {"); end if; -- Exit from the loop through Sdep entries once we find one @@ -923,9 +934,9 @@ package body Bcheck is and then ALIs.Table (ALIs.First).Allocator_In_Body then Cumulative_Restrictions.Violated - (No_Allocators_After_Elaboration) := True; + (No_Standard_Allocators_After_Elaboration) := True; ALIs.Table (ALIs.First).Restrictions.Violated - (No_Allocators_After_Elaboration) := True; + (No_Standard_Allocators_After_Elaboration) := True; end if; -- Loop through all restriction violations diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 7afabd1c2c6..570bfbc8a14 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -996,7 +996,7 @@ package body Checks is elsif Dsiz <= Standard_Long_Long_Integer_Size then Ctyp := Standard_Long_Long_Integer; - -- No check type exists, use runtime call + -- No check type exists, use runtime call else if Nkind (N) = N_Op_Add then @@ -1479,7 +1479,7 @@ package body Checks is -- partial view that is constrained. elsif Ada_Version >= Ada_2005 - and then Effectively_Has_Constrained_Partial_View + and then Object_Type_Has_Constrained_Partial_View (Typ => Base_Type (T_Typ), Scop => Current_Scope) then @@ -1907,6 +1907,15 @@ package body Checks is Reason : RT_Exception_Code; begin + -- We do not need checks if we are not generating code (i.e. the full + -- expander is not active). In SPARK mode, we specifically don't want + -- the frontend to expand these checks, which are dealt with directly + -- in the formal verification backend. + + if not Full_Expander_Active then + return; + end if; + if not Compile_Time_Known_Value (LB) or not Compile_Time_Known_Value (HB) then @@ -2490,28 +2499,13 @@ package body Checks is Make_Raise_Storage_Error (Sloc (N), Reason => SE_Infinite_Recursion)); - -- Here for normal case of predicate active. + -- Here for normal case of predicate active else - -- If the predicate is a static predicate and the operand is - -- static, the predicate must be evaluated statically. If the - -- evaluation fails this is a static constraint error. This check - -- is disabled in -gnatc mode, because the compiler is incapable - -- of evaluating static expressions in that case. - - if Is_OK_Static_Expression (N) then - if Present (Static_Predicate (Typ)) then - if Operating_Mode < Generate_Code - or else Eval_Static_Predicate_Check (N, Typ) - then - return; - else - Error_Msg_NE - ("static expression fails static predicate check on&", - N, Typ); - end if; - end if; - end if; + -- If the type has a static predicate and the expression is known + -- at compile time, see if the expression satisfies the predicate. + + Check_Expression_Against_Static_Predicate (N, Typ); Insert_Action (N, Make_Predicate_Check (Typ, Duplicate_Subexpr (N))); @@ -3244,13 +3238,20 @@ package body Checks is Reason => CE_Discriminant_Check_Failed)); end; - -- For arrays, conversions are applied during expansion, to take into - -- accounts changes of representation. The checks become range checks on - -- the base type or length checks on the subtype, depending on whether - -- the target type is unconstrained or constrained. - - else - null; + -- For arrays, checks are set now, but conversions are applied during + -- expansion, to take into accounts changes of representation. The + -- checks become range checks on the base type or length checks on the + -- subtype, depending on whether the target type is unconstrained or + -- constrained. Note that the range check is put on the expression of a + -- type conversion, while the length check is put on the type conversion + -- itself. + + elsif Is_Array_Type (Target_Type) then + if Is_Constrained (Target_Type) then + Set_Do_Length_Check (N); + else + Set_Do_Range_Check (Expr); + end if; end if; end Apply_Type_Conversion_Checks; @@ -6221,6 +6222,7 @@ package body Checks is procedure Insert_Valid_Check (Expr : Node_Id) is Loc : constant Source_Ptr := Sloc (Expr); + Typ : constant Entity_Id := Etype (Expr); Exp : Node_Id; begin @@ -6234,6 +6236,16 @@ package body Checks is return; end if; + -- Do not insert checks within a predicate function. This will arise + -- if the current unit and the predicate function are being compiled + -- with validity checks enabled. + + if Present (Predicate_Function (Typ)) + and then Current_Scope = Predicate_Function (Typ) + then + return; + end if; + -- If we have a checked conversion, then validity check applies to -- the expression inside the conversion, not the result, since if -- the expression inside is valid, then so is the conversion result. @@ -6576,6 +6588,13 @@ package body Checks is return; end if; + -- No check needed in interface thunks since the runtime check is + -- already performed at the caller side. + + if Is_Thunk (Current_Scope) then + return; + end if; + -- No check needed for the Get_Current_Excep.all.all idiom generated by -- the expander within exception handlers, since we know that the value -- can never be null. @@ -7725,6 +7744,19 @@ package body Checks is end if; end Overflow_Checks_Suppressed; + --------------------------------- + -- Predicate_Checks_Suppressed -- + --------------------------------- + + function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean is + begin + if Present (E) and then Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Predicate_Check); + else + return Scope_Suppress.Suppress (Predicate_Check); + end if; + end Predicate_Checks_Suppressed; + ----------------------------- -- Range_Checks_Suppressed -- ----------------------------- diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index fb7370628ab..2d9c25e31ae 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.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- -- @@ -56,6 +56,7 @@ package Checks is function Index_Checks_Suppressed (E : Entity_Id) return Boolean; function Length_Checks_Suppressed (E : Entity_Id) return Boolean; function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean; + function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean; function Range_Checks_Suppressed (E : Entity_Id) return Boolean; function Storage_Checks_Suppressed (E : Entity_Id) return Boolean; function Tag_Checks_Suppressed (E : Entity_Id) return Boolean; diff --git a/gcc/ada/cio.c b/gcc/ada/cio.c index ac23519ae9b..fd85df96923 100644 --- a/gcc/ada/cio.c +++ b/gcc/ada/cio.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- * @@ -40,6 +40,9 @@ #include "adaint.h" +/* We need L_tmpnam definition */ +#include <stdio.h> + #ifdef __cplusplus extern "C" { #endif @@ -135,7 +138,18 @@ put_char_stderr (int c) char * mktemp (char *template) { +#if !(defined (__RTP__) || defined (VTHREADS)) + static char buf[L_tmpnam]; /* Internal buffer for name */ + + /* If parameter is NULL use internal buffer */ + if (template == NULL) + template = buf; + + __gnat_tmp_name (template); + return template; +#else return tmpnam (NULL); +#endif } #endif diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 9d9c4d457df..cbaaa61c7d0 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -98,8 +98,6 @@ package body Clean is Project_Node_Tree : Project_Node_Tree_Ref; - Root_Environment : Prj.Tree.Environment; - Main_Project : Prj.Project_Id := Prj.No_Project; All_Projects : Boolean := False; @@ -1377,6 +1375,13 @@ package body Clean is Parse_Cmd_Line; + -- Add the default project search directories now, after the directories + -- that have been specified by switches -aP<dir>. + + Prj.Env.Initialize_Default_Project_Path + (Root_Environment.Project_Path, + Target_Name => Sdefault.Target_Name.all); + if Verbose_Mode then Display_Copyright; end if; @@ -1550,9 +1555,6 @@ package body Clean is Snames.Initialize; Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags); - Prj.Env.Initialize_Default_Project_Path - (Root_Environment.Project_Path, - Target_Name => Sdefault.Target_Name.all); Project_Node_Tree := new Project_Node_Tree_Data; Prj.Tree.Initialize (Project_Node_Tree); @@ -1729,6 +1731,7 @@ package body Clean is when 'f' => Force_Deletions := True; + Directories_Must_Exist_In_Projects := False; when 'F' => Full_Path_Name_For_Brief_Errors := True; diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 82f8697bcb3..09c125dfdce 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.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- -- @@ -24,7 +24,6 @@ ------------------------------------------------------------------------------ with Atree; use Atree; -with Back_End; use Back_End; with Csets; use Csets; with Debug; use Debug; with Einfo; use Einfo; @@ -35,6 +34,7 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; +with Set_Targ; use Set_Targ; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; @@ -146,18 +146,19 @@ package body CStand is -- Print representation of package Standard if switch set procedure Register_Float_Type - (Name : C_String; -- Nul-terminated string with name of type - Digs : Natural; -- Nr or digits for floating point, 0 otherwise - Complex : Boolean; -- True iff type has real and imaginary parts - Count : Natural; -- Number of elements in vector, 0 otherwise - Float_Rep : Float_Rep_Kind; -- Representation used for fpt type - Size : Positive; -- Size of representation in bits - Alignment : Natural); -- Required alignment in bits - pragma Convention (C, Register_Float_Type); - -- Call back to allow the back end to register available types. - -- This call back currently creates predefined floating point base types - -- for any floating point types reported by the back end, and adds them - -- to the list of predefined float types. + (Name : String; + Digs : Positive; + Float_Rep : Float_Rep_Kind; + Size : Positive; + Alignment : Natural); + -- Registers a single back end floating-point type (from FPT_Mode_Table in + -- Set_Targ). This will create a predefined floating-point base type for + -- one of the floating point types reported by the back end, and add it + -- to the list of predefined float types. Name is the name of the type + -- as a normal format (non-null-terminated) string. Digs is the number of + -- digits, which is always non-zero, since non-floating-point types were + -- filtered out earlier. Float_Rep indicates the kind of floating-point + -- type, and Size and Alignment are the size and alignment in bits. procedure Set_Integer_Bounds (Id : Entity_Id; @@ -424,14 +425,20 @@ package body CStand is Append (Decl, Decl_S); end Build_Exception; - --------------------------- + --------------------------------- -- Create_Back_End_Float_Types -- - --------------------------- + --------------------------------- procedure Create_Back_End_Float_Types is begin - Back_End_Float_Types := No_Elist; - Register_Back_End_Types (Register_Float_Type'Access); + for J in 1 .. Num_FPT_Modes loop + declare + E : FPT_Mode_Entry renames FPT_Mode_Table (J); + begin + Register_Float_Type + (E.NAME.all, E.DIGS, E.FLOAT_REP, E.SIZE, E.ALIGNMENT); + end; + end loop; end Create_Back_End_Float_Types; ------------------------ @@ -2009,107 +2016,29 @@ package body CStand is ------------------------- procedure Register_Float_Type - (Name : C_String; - Digs : Natural; - Complex : Boolean; - Count : Natural; + (Name : String; + Digs : Positive; Float_Rep : Float_Rep_Kind; Size : Positive; Alignment : Natural) is - T : String (1 .. Name'Length); - Last : Natural := 0; - - procedure Dump; - -- Dump information given by the back end for the type to register - - procedure Dump is - begin - Write_Str ("type " & T (1 .. Last) & " is "); - - if Count > 0 then - Write_Str ("array (1 .. "); - Write_Int (Int (Count)); - - if Complex then - Write_Str (", 1 .. 2"); - end if; - - Write_Str (") of "); - - elsif Complex then - Write_Str ("array (1 .. 2) of "); - end if; - - if Digs > 0 then - Write_Str ("digits "); - Write_Int (Int (Digs)); - Write_Line (";"); - - Write_Str ("pragma Float_Representation ("); - - case Float_Rep is - when IEEE_Binary => Write_Str ("IEEE"); - when VAX_Native => - case Digs is - when 6 => Write_Str ("VAXF"); - when 9 => Write_Str ("VAXD"); - when 15 => Write_Str ("VAXG"); - when others => Write_Str ("VAX_"); Write_Int (Int (Digs)); - end case; - when AAMP => Write_Str ("AAMP"); - end case; - Write_Line (", " & T & ");"); - - else - Write_Str ("mod 2**"); - Write_Int (Int (Size / Positive'Max (1, Count))); - Write_Line (";"); - end if; - - Write_Str ("for " & T & "'Size use "); - Write_Int (Int (Size)); - Write_Line (";"); - - Write_Str ("for " & T & "'Alignment use "); - Write_Int (Int (Alignment / 8)); - Write_Line (";"); - end Dump; + Ent : constant Entity_Id := New_Standard_Entity; + Esize : constant Pos := + Pos ((Size + Alignment - 1) / Alignment * Alignment); begin - for J in T'Range loop - T (J) := Name (Name'First + J - 1); - if T (J) = ASCII.NUL then - Last := J - 1; - exit; - end if; - end loop; - - if Debug_Flag_Dot_B then - Dump; + Set_Defining_Identifier (New_Node (N_Full_Type_Declaration, Stloc), Ent); + Make_Name (Ent, Name); + Set_Scope (Ent, Standard_Standard); + Build_Float_Type (Ent, Esize, Float_Rep, Pos (Digs)); + Set_RM_Size (Ent, UI_From_Int (Int (Size))); + Set_Alignment (Ent, UI_From_Int (Int (Alignment / 8))); + + if No (Back_End_Float_Types) then + Back_End_Float_Types := New_Elmt_List; end if; - if Digs > 0 and then not Complex and then Count = 0 then - declare - Ent : constant Entity_Id := New_Standard_Entity; - Esize : constant Pos := Pos ((Size + Alignment - 1) - / Alignment * Alignment); - begin - Set_Defining_Identifier - (New_Node (N_Full_Type_Declaration, Stloc), Ent); - Make_Name (Ent, T (1 .. Last)); - Set_Scope (Ent, Standard_Standard); - Build_Float_Type (Ent, Esize, Float_Rep, Pos (Digs)); - Set_RM_Size (Ent, UI_From_Int (Int (Size))); - Set_Alignment (Ent, UI_From_Int (Int (Alignment / 8))); - - if No (Back_End_Float_Types) then - Back_End_Float_Types := New_Elmt_List; - end if; - - Append_Elmt (Ent, Back_End_Float_Types); - end; - end if; + Append_Elmt (Ent, Back_End_Float_Types); end Register_Float_Type; ---------------------- @@ -2118,10 +2047,8 @@ package body CStand is procedure Set_Float_Bounds (Id : Entity_Id) is L : Node_Id; - -- Low bound of literal value - H : Node_Id; - -- High bound of literal value + -- Low and high bounds of literal value R : Node_Id; -- Range specification @@ -2166,9 +2093,12 @@ package body CStand is Lb : Uint; Hb : Uint) is - L : Node_Id; -- Low bound of literal value - H : Node_Id; -- High bound of literal value - R : Node_Id; -- Range specification + L : Node_Id; + H : Node_Id; + -- Low and high bounds of literal value + + R : Node_Id; + -- Range specification begin L := Make_Integer (Lb); diff --git a/gcc/ada/ctrl_c.c b/gcc/ada/ctrl_c.c index a860b767cba..7f8d177d17c 100644 --- a/gcc/ada/ctrl_c.c +++ b/gcc/ada/ctrl_c.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * 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- * @@ -50,7 +50,24 @@ void __gnat_uninstall_int_handler (void); /* POSIX implementation */ #if (defined (__unix__) || defined (_AIX) || defined (__APPLE__)) \ - && !defined (__vxworks) + || defined (VMS) && !defined (__vxworks) + +#ifdef VMS +/* On VMS _gnat_handle_vms_condition gets control first, and it has to + resignal the Ctrl/C in order for sigaction to gain control and execute + the user handler routine, but in doing so propagates the condition + causing the program to terminate. So instead we install a dummy handler + routine and put the real user handler in a special global variable so + that __gnat_handle_vms_condition can declare an AST to asynchronously + execute the Ctrl/C user handler at some future time and allow + __gnat_handle_vms_condition to return and not be held up waiting for + the potentially unbounded time required to execute the Crtl/C handler. */ +void +dummy_handler () {} + +/* Lives in init.c. */ +extern void (*__gnat_ctrl_c_handler) (void); +#endif #include <signal.h> @@ -75,8 +92,8 @@ __gnat_install_int_handler (void (*proc) (void)) if (sigint_intercepted == 0) { act.sa_handler = __gnat_int_handler; -#if defined (__Lynx__) - /* LynxOS does not support SA_RESTART. */ +#if defined (__Lynx__) || defined (VMS) + /* LynxOS and VMS do not support SA_RESTART. */ act.sa_flags = 0; #else act.sa_flags = SA_RESTART; @@ -85,7 +102,12 @@ __gnat_install_int_handler (void (*proc) (void)) sigaction (SIGINT, &act, &original_act); } +#ifdef VMS + sigint_intercepted = &dummy_handler; + __gnat_ctrl_c_handler = proc; +#else sigint_intercepted = proc; +#endif } /* Restore original handler */ @@ -98,6 +120,10 @@ __gnat_uninstall_int_handler (void) sigaction (SIGINT, &original_act, 0); sigint_intercepted = 0; } +#ifdef VMS + if (__gnat_ctrl_c_handler) + __gnat_ctrl_c_handler = 0; +#endif } /* Windows implementation */ diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index bcb6ee3322c..01624792c61 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.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- -- @@ -121,29 +121,29 @@ package body Debug is -- d.A Read/write Aspect_Specifications hash table to tree -- d.B -- d.C Generate concatenation call, do not generate inline code - -- d.D Strict Alfa mode - -- d.E Force Alfa mode for gnat2why - -- d.F Alfa mode - -- d.G Precondition only mode for gnat2why + -- d.D SPARK strict mode + -- d.E Force SPARK mode for gnat2why + -- d.F SPARK mode + -- d.G Frame condition mode for gnat2why -- d.H Standard package only mode for gnat2why - -- d.I SCIL generation mode + -- d.I Do not ignore enum representation clauses in CodePeer mode -- d.J Disable parallel SCIL generation mode - -- d.K Alfa detection only mode for gnat2why + -- d.K SPARK detection only mode for gnat2why -- d.L Depend on back end for limited types in if and case expressions - -- d.M + -- 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 + -- d.Q Flow Analysis mode for gnat2why -- d.R Restrictions in ali files in positional form -- d.S Force Optimize_Alignment (Space) -- d.T Force Optimize_Alignment (Time) -- d.U Ignore indirect calls for static elaboration -- d.V Extensions for formal verification -- d.W Print out debugging information for Walk_Library_Items - -- d.X Use Expression_With_Actions - -- d.Y Do not use Expression_With_Actions - -- d.Z + -- d.X + -- d.Y + -- d.Z Dump flow analysis graphs, for debugging purposes (gnat2why) -- d1 Error msgs have node numbers where possible -- d2 Eliminate error flags in verbose form error messages @@ -594,41 +594,47 @@ package body Debug is -- d.C Generate call to System.Concat_n.Str_Concat_n routines in cases -- where we would normally generate inline concatenation code. - -- d.D Strict Alfa mode. Interpret compiler permissions as strictly as - -- possible in Alfa mode. + -- d.D SPARK strict mode. Interpret compiler permissions as strictly as + -- possible in SPARK mode. - -- d.E Force Alfa mode for gnat2why. In this mode, errors are issued for - -- all violations of Alfa in user code, and warnings are issued for + -- 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.F Alfa mode. Generate AST in a form suitable for formal verification, - -- as well as additional cross reference information in ALI files to - -- compute effects of subprograms. + -- d.F SPARK mode. Generate AST in a form suitable for formal + -- verification, as well as additional cross reference information in + -- ALI files to compute effects of subprograms. Note that ALI files + -- are only written when option d.G is also given. - -- d.G Precondition only mode for gnat2why. In this mode, gnat2why will - -- only generate Why code that checks for the well-guardedness of - -- preconditions. + -- d.G Frame condition mode for gnat2why. In this mode, gnat2why will not + -- 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 Generate SCIL mode. Generate intermediate code for the sake of - -- of static analysis tools, and ensure additional tree consistency - -- between different compilations of specs. + -- 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 + -- cases being able to change this default might be useful to remove + -- some false positives. -- d.J Disable parallel SCIL generation. Normally SCIL file generation is -- done in parallel to speed processing. This switch disables this -- behavior. - -- d.K Alfa detection only mode for gnat2why. In this mode, gnat2why - -- will only generate the .alfa file, but no Why code. + -- 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 -- expressions correctly. + -- d.M Relaxed RM semantics. This flag sets Opt.Relaxed_RM_Semantics + -- See Opt.Relaxed_RM_Semantics for more details. + -- d.N Enlarge entities by one node (but don't attempt to use this extra -- node for storage of any flags or fields). This can be used to do -- experiments on the impact of increasing entity sizes. @@ -642,6 +648,9 @@ 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 @@ -666,13 +675,10 @@ package body Debug is -- the order in which units are walked. This is primarily for use in -- debugging CodePeer mode. - -- d.X By default, the compiler uses an elaborate rewriting framework for - -- short-circuited forms where the right hand condition generates - -- actions to be inserted. With the gcc backend, we now use the new - -- N_Expression_With_Actions node for this expansion, but we still use - -- the old method for other backends and in SCIL mode. This debug flag - -- forces use of the new N_Expression_With_Actions node in these other - -- cases and is intended for transitional use. + -- 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 diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 934dd27e25b..bfe5b37dad1 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -32,12 +32,12 @@ pragma Style_Checks (All_Checks); -- Turn off subprogram ordering, not used for this unit -with Atree; use Atree; -with Namet; use Namet; -with Nlists; use Nlists; -with Output; use Output; -with Sinfo; use Sinfo; -with Stand; use Stand; +with Atree; use Atree; +with Namet; use Namet; +with Nlists; use Nlists; +with Output; use Output; +with Sinfo; use Sinfo; +with Stand; use Stand; package body Einfo is @@ -92,7 +92,6 @@ package body Einfo is -- Discriminal_Link Node10 -- Float_Rep Uint10 (but returns Float_Rep_Kind) -- Handler_Records List10 - -- Loop_Entry_Attributes Elist10 -- Normalized_Position_Max Uint10 -- Component_Bit_Offset Uint11 @@ -245,7 +244,7 @@ package body Einfo is -- Corresponding_Equality Node30 -- Static_Initialization Node30 - -- (unused) Node31 + -- Thunk_Entity Node31 -- (unused) Node32 @@ -542,13 +541,12 @@ package body Einfo is -- Is_Processed_Transient Flag252 -- Has_Anonymous_Master Flag253 -- Is_Implementation_Defined Flag254 - - -- (unused) Flag255 - -- (unused) Flag256 - -- (unused) Flag257 - -- (unused) Flag258 - -- (unused) Flag259 - -- (unused) Flag260 + -- Is_Predicate_Function Flag255 + -- Is_Predicate_Function_M Flag256 + -- Is_Invariant_Procedure Flag257 + -- Has_Dynamic_Predicate_Aspect Flag258 + -- Has_Static_Predicate_Aspect Flag259 + -- Has_Loop_Entry_Attributes Flag260 -- (unused) Flag261 -- (unused) Flag262 @@ -578,40 +576,8 @@ package body Einfo is -- (unused) Flag284 -- (unused) Flag285 -- (unused) Flag286 - -- (unused) Flag287 - -- (unused) Flag288 - -- (unused) Flag289 - -- (unused) Flag290 - - -- (unused) Flag291 - -- (unused) Flag292 - -- (unused) Flag293 - -- (unused) Flag294 - -- (unused) Flag295 - -- (unused) Flag296 - -- (unused) Flag297 - -- (unused) Flag298 - -- (unused) Flag299 - -- (unused) Flag300 - - -- (unused) Flag301 - -- (unused) Flag302 - -- (unused) Flag303 - -- (unused) Flag304 - -- (unused) Flag305 - -- (unused) Flag306 - -- (unused) Flag307 - -- (unused) Flag308 - -- (unused) Flag309 - -- (unused) Flag310 - - -- (unused) Flag311 - -- (unused) Flag312 - -- (unused) Flag313 - -- (unused) Flag314 - -- (unused) Flag315 - -- (unused) Flag316 - -- (unused) Flag317 + + -- Note: Flag287-317 are defined in atree.ads/adb, but not yet in atree.h ----------------------- -- Local subprograms -- @@ -700,7 +666,7 @@ package body Einfo is function Abstract_States (Id : E) return L is begin - pragma Assert (Ekind (Id) = E_Package); + pragma Assert (Ekind_In (Id, E_Generic_Package, E_Package)); return Elist25 (Id); end Abstract_States; @@ -1426,6 +1392,12 @@ package body Einfo is return Flag220 (Id); end Has_Dispatch_Table; + function Has_Dynamic_Predicate_Aspect (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag258 (Id); + end Has_Dynamic_Predicate_Aspect; + function Has_Enumeration_Rep_Clause (Id : E) return B is begin pragma Assert (Is_Enumeration_Type (Id)); @@ -1488,12 +1460,16 @@ package body Einfo is function Has_Invariants (Id : E) return B is begin - pragma Assert (Is_Type (Id) - or else Ekind (Id) = E_Procedure - or else Ekind (Id) = E_Generic_Procedure); + pragma Assert (Is_Type (Id)); return Flag232 (Id); end Has_Invariants; + function Has_Loop_Entry_Attributes (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Loop); + return Flag260 (Id); + end Has_Loop_Entry_Attributes; + function Has_Machine_Radix_Clause (Id : E) return B is begin pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); @@ -1614,6 +1590,7 @@ package body Einfo is function Has_Predicates (Id : E) return B is begin + pragma Assert (Is_Type (Id)); return Flag250 (Id); end Has_Predicates; @@ -1702,6 +1679,12 @@ package body Einfo is return Flag211 (Id); end Has_Static_Discriminants; + function Has_Static_Predicate_Aspect (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag259 (Id); + end Has_Static_Predicate_Aspect; + function Has_Storage_Size_Clause (Id : E) return B is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); @@ -2076,6 +2059,12 @@ package body Einfo is return Flag64 (Id); end Is_Intrinsic_Subprogram; + function Is_Invariant_Procedure (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + return Flag257 (Id); + end Is_Invariant_Procedure; + function Is_Itype (Id : E) return B is begin return Flag91 (Id); @@ -2167,6 +2156,18 @@ package body Einfo is return Flag9 (Id); end Is_Potentially_Use_Visible; + function Is_Predicate_Function (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + return Flag255 (Id); + end Is_Predicate_Function; + + function Is_Predicate_Function_M (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + return Flag256 (Id); + end Is_Predicate_Function_M; + function Is_Preelaborated (Id : E) return B is begin return Flag59 (Id); @@ -2286,7 +2287,6 @@ package body Einfo is function Is_Thunk (Id : E) return B is begin - pragma Assert (Is_Subprogram (Id)); return Flag225 (Id); end Is_Thunk; @@ -2399,12 +2399,6 @@ package body Einfo is return Node16 (Id); end Lit_Strings; - function Loop_Entry_Attributes (Id : E) return L is - begin - pragma Assert (Ekind (Id) = E_Loop); - return Elist10 (Id); - end Loop_Entry_Attributes; - function Low_Bound_Tested (Id : E) return B is begin return Flag205 (Id); @@ -2923,6 +2917,13 @@ package body Einfo is return Node25 (Id); end Task_Body_Procedure; + function Thunk_Entity (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + and then Is_Thunk (Id)); + return Node31 (Id); + end Thunk_Entity; + function Treat_As_Volatile (Id : E) return B is begin return Flag41 (Id); @@ -3232,7 +3233,7 @@ package body Einfo is procedure Set_Abstract_States (Id : E; V : L) is begin - pragma Assert (Ekind (Id) = E_Package); + pragma Assert (Ekind_In (Id, E_Generic_Package, E_Package)); Set_Elist25 (Id, V); end Set_Abstract_States; @@ -3975,6 +3976,12 @@ package body Einfo is Set_Flag220 (Id, V); end Set_Has_Dispatch_Table; + procedure Set_Has_Dynamic_Predicate_Aspect (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag258 (Id, V); + end Set_Has_Dynamic_Predicate_Aspect; + procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True) is begin pragma Assert (Is_Enumeration_Type (Id)); @@ -4037,12 +4044,16 @@ package body Einfo is procedure Set_Has_Invariants (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id) - or else Ekind (Id) = E_Procedure - or else Ekind (Id) = E_Void); + pragma Assert (Is_Type (Id)); Set_Flag232 (Id, V); end Set_Has_Invariants; + procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Loop); + Set_Flag260 (Id, V); + end Set_Has_Loop_Entry_Attributes; + procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True) is begin pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); @@ -4172,6 +4183,7 @@ package body Einfo is procedure Set_Has_Predicates (Id : E; V : B := True) is begin + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Void); Set_Flag250 (Id, V); end Set_Has_Predicates; @@ -4260,6 +4272,12 @@ package body Einfo is Set_Flag211 (Id, V); end Set_Has_Static_Discriminants; + procedure Set_Has_Static_Predicate_Aspect (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag259 (Id, V); + end Set_Has_Static_Predicate_Aspect; + procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); @@ -4658,6 +4676,12 @@ package body Einfo is Set_Flag64 (Id, V); end Set_Is_Intrinsic_Subprogram; + procedure Set_Is_Invariant_Procedure (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + Set_Flag257 (Id, V); + end Set_Is_Invariant_Procedure; + procedure Set_Is_Itype (Id : E; V : B := True) is begin Set_Flag91 (Id, V); @@ -4752,6 +4776,18 @@ package body Einfo is Set_Flag9 (Id, V); end Set_Is_Potentially_Use_Visible; + procedure Set_Is_Predicate_Function (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + Set_Flag255 (Id, V); + end Set_Is_Predicate_Function; + + procedure Set_Is_Predicate_Function_M (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + Set_Flag256 (Id, V); + end Set_Is_Predicate_Function_M; + procedure Set_Is_Preelaborated (Id : E; V : B := True) is begin Set_Flag59 (Id, V); @@ -4878,6 +4914,7 @@ package body Einfo is procedure Set_Is_Thunk (Id : E; V : B := True) is begin + pragma Assert (Is_Subprogram (Id)); Set_Flag225 (Id, V); end Set_Is_Thunk; @@ -4988,12 +5025,6 @@ package body Einfo is Set_Node16 (Id, V); end Set_Lit_Strings; - procedure Set_Loop_Entry_Attributes (Id : E; V : L) is - begin - pragma Assert (Ekind (Id) = E_Loop); - Set_Elist10 (Id, V); - end Set_Loop_Entry_Attributes; - procedure Set_Low_Bound_Tested (Id : E; V : B := True) is begin pragma Assert (Is_Formal (Id)); @@ -5537,6 +5568,13 @@ package body Einfo is Set_Node25 (Id, V); end Set_Task_Body_Procedure; + procedure Set_Thunk_Entity (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + and then Is_Thunk (Id)); + Set_Node31 (Id, V); + end Set_Thunk_Entity; + procedure Set_Treat_As_Volatile (Id : E; V : B := True) is begin Set_Flag41 (Id, V); @@ -6207,6 +6245,29 @@ package body Einfo is end if; end Get_Full_View; + ---------------- + -- Get_Pragma -- + ---------------- + + function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id + is + N : Node_Id; + + begin + N := First_Rep_Item (E); + while Present (N) loop + if Nkind (N) = N_Pragma + and then Get_Pragma_Id (Pragma_Name (N)) = Id + then + return N; + else + Next_Rep_Item (N); + end if; + end loop; + + return Empty; + end Get_Pragma; + -------------------------------------- -- Get_Record_Representation_Clause -- -------------------------------------- @@ -6403,7 +6464,7 @@ package body Einfo is else S := Subprograms_For_Type (Id); while Present (S) loop - if Has_Invariants (S) then + if Is_Invariant_Procedure (S) then return S; else S := Subprograms_For_Type (S); @@ -6533,10 +6594,35 @@ package body Einfo is function Is_Finalizer (Id : E) return B is begin - return Ekind (Id) = E_Procedure - and then Chars (Id) = Name_uFinalizer; + return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; end Is_Finalizer; + --------------------- + -- Is_Ghost_Entity -- + --------------------- + + function Is_Ghost_Entity (Id : E) return B is + begin + if Present (Id) and then Ekind (Id) = E_Variable then + return Convention (Id) = Convention_Ghost; + else + return Is_Ghost_Subprogram (Id); + end if; + end Is_Ghost_Entity; + + ------------------------- + -- Is_Ghost_Subprogram -- + ------------------------- + + function Is_Ghost_Subprogram (Id : E) return B is + begin + if Present (Id) and then Ekind_In (Id, E_Function, E_Procedure) then + return Convention (Id) = Convention_Ghost; + else + return False; + end if; + end Is_Ghost_Subprogram; + -------------------- -- Is_Input_State -- -------------------- @@ -6554,8 +6640,7 @@ package body Einfo is function Is_Null_State (Id : E) return B is begin return - Ekind (Id) = E_Abstract_State - and then Nkind (Parent (Id)) = N_Null; + Ekind (Id) = E_Abstract_State and then Nkind (Parent (Id)) = N_Null; end Is_Null_State; --------------------- @@ -6574,10 +6659,7 @@ package body Einfo is function Is_Package_Or_Generic_Package (Id : E) return B is begin - return - Ekind (Id) = E_Package - or else - Ekind (Id) = E_Generic_Package; + return Ekind_In (Id, E_Generic_Package, E_Package); end Is_Package_Or_Generic_Package; --------------- @@ -6596,8 +6678,7 @@ package body Einfo is function Is_Protected_Component (Id : E) return B is begin - return Ekind (Id) = E_Component - and then Is_Protected_Type (Scope (Id)); + return Ekind (Id) = E_Component and then Is_Protected_Type (Scope (Id)); end Is_Protected_Component; ---------------------------- @@ -6728,8 +6809,7 @@ package body Einfo is function Is_Wrapper_Package (Id : E) return B is begin - return (Ekind (Id) = E_Package - and then Present (Related_Instance (Id))); + return (Ekind (Id) = E_Package and then Present (Related_Instance (Id))); end Is_Wrapper_Package; ----------------- @@ -7111,17 +7191,27 @@ package body Einfo is function Predicate_Function (Id : E) return E is S : Entity_Id; + T : Entity_Id; begin pragma Assert (Is_Type (Id)); - if No (Subprograms_For_Type (Id)) then + -- If type is private and has a completion, predicate may be defined + -- on the full view. + + if Is_Private_Type (Id) and then Present (Full_View (Id)) then + T := Full_View (Id); + else + T := Id; + end if; + + if No (Subprograms_For_Type (T)) then return Empty; else - S := Subprograms_For_Type (Id); + S := Subprograms_For_Type (T); while Present (S) loop - if Has_Predicates (S) then + if Is_Predicate_Function (S) then return S; else S := Subprograms_For_Type (S); @@ -7132,6 +7222,43 @@ package body Einfo is end if; end Predicate_Function; + -------------------------- + -- Predicate_Function_M -- + -------------------------- + + function Predicate_Function_M (Id : E) return E is + S : Entity_Id; + T : Entity_Id; + + begin + pragma Assert (Is_Type (Id)); + + -- If type is private and has a completion, predicate may be defined + -- on the full view. + + if Is_Private_Type (Id) and then Present (Full_View (Id)) then + T := Full_View (Id); + else + T := Id; + end if; + + if No (Subprograms_For_Type (T)) then + return Empty; + + else + S := Subprograms_For_Type (T); + while Present (S) loop + if Is_Predicate_Function_M (S) then + return S; + else + S := Subprograms_For_Type (S); + end if; + end loop; + + return Empty; + end if; + end Predicate_Function_M; + ------------------------- -- Present_In_Rep_Item -- ------------------------- @@ -7365,8 +7492,10 @@ package body Einfo is Set_Subprograms_For_Type (Id, V); Set_Subprograms_For_Type (V, S); + -- Check for duplicate entry + while Present (S) loop - if Has_Invariants (S) then + if Is_Invariant_Procedure (S) then raise Program_Error; else S := Subprograms_For_Type (S); @@ -7389,7 +7518,7 @@ package body Einfo is Set_Subprograms_For_Type (V, S); while Present (S) loop - if Has_Predicates (S) then + if Is_Predicate_Function (S) then raise Program_Error; else S := Subprograms_For_Type (S); @@ -7397,6 +7526,31 @@ package body Einfo is end loop; end Set_Predicate_Function; + ------------------------------ + -- Set_Predicate_Function_M -- + ------------------------------ + + procedure Set_Predicate_Function_M (Id : E; V : E) is + S : Entity_Id; + + begin + pragma Assert (Is_Type (Id) and then Has_Predicates (Id)); + + S := Subprograms_For_Type (Id); + Set_Subprograms_For_Type (Id, V); + Set_Subprograms_For_Type (V, S); + + -- Check for duplicates + + while Present (S) loop + if Is_Predicate_Function_M (S) then + raise Program_Error; + else + S := Subprograms_For_Type (S); + end if; + end loop; + end Set_Predicate_Function_M; + ----------------- -- Size_Clause -- ----------------- @@ -7672,6 +7826,8 @@ package body Einfo is W ("Has_Delayed_Aspects", Flag200 (Id)); W ("Has_Delayed_Freeze", Flag18 (Id)); W ("Has_Discriminants", Flag5 (Id)); + W ("Has_Dispatch_Table", Flag220 (Id)); + W ("Has_Dynamic_Predicate_Aspect", Flag258 (Id)); W ("Has_Enumeration_Rep_Clause", Flag66 (Id)); W ("Has_Exit", Flag47 (Id)); W ("Has_External_Tag_Rep_Clause", Flag110 (Id)); @@ -7683,6 +7839,7 @@ package body Einfo is W ("Has_Inheritable_Invariants", Flag248 (Id)); W ("Has_Initial_Value", Flag219 (Id)); W ("Has_Invariants", Flag232 (Id)); + W ("Has_Loop_Entry_Attributes", Flag260 (Id)); W ("Has_Machine_Radix_Clause", Flag83 (Id)); W ("Has_Master_Entity", Flag21 (Id)); W ("Has_Missing_Return", Flag142 (Id)); @@ -7721,6 +7878,7 @@ package body Einfo is W ("Has_Specified_Stream_Read", Flag192 (Id)); W ("Has_Specified_Stream_Write", Flag193 (Id)); W ("Has_Static_Discriminants", Flag211 (Id)); + W ("Has_Static_Predicate_Aspect", Flag259 (Id)); W ("Has_Storage_Size_Clause", Flag23 (Id)); W ("Has_Stream_Size_Clause", Flag184 (Id)); W ("Has_Task", Flag30 (Id)); @@ -7783,6 +7941,7 @@ package body Einfo is W ("Is_Internal", Flag17 (Id)); W ("Is_Interrupt_Handler", Flag89 (Id)); W ("Is_Intrinsic_Subprogram", Flag64 (Id)); + W ("Is_Invariant_Procedure", Flag257 (Id)); W ("Is_Itype", Flag91 (Id)); W ("Is_Known_Non_Null", Flag37 (Id)); W ("Is_Known_Null", Flag204 (Id)); @@ -7800,6 +7959,8 @@ package body Einfo is W ("Is_Packed", Flag51 (Id)); W ("Is_Packed_Array_Type", Flag138 (Id)); W ("Is_Potentially_Use_Visible", Flag9 (Id)); + W ("Is_Predicate_Function", Flag255 (Id)); + W ("Is_Predicate_Function_M", Flag256 (Id)); W ("Is_Preelaborated", Flag59 (Id)); W ("Is_Primitive", Flag218 (Id)); W ("Is_Primitive_Wrapper", Flag195 (Id)); @@ -8131,9 +8292,6 @@ package body Einfo is E_Procedure => Write_Str ("Handler_Records"); - when E_Loop => - Write_Str ("Loop_Entry_Attributes"); - when E_Component | E_Discriminant => Write_Str ("Normalized_Position_Max"); @@ -8900,7 +9058,8 @@ package body Einfo is E_Variable => Write_Str ("Related_Type"); - when E_Procedure => + when E_Procedure | + E_Function => Write_Str ("Wrapped_Entity"); when others => @@ -8974,6 +9133,10 @@ package body Einfo is procedure Write_Field31_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Procedure | + E_Function => + Write_Str ("Thunk_Entity"); + when others => Write_Str ("Field31??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 8616333a0a8..a3d05d8c8a0 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1230,7 +1230,7 @@ package Einfo is -- the same structure for constrained and unconstrained arrays, subtype -- marks and discrete ranges are both represented by a subtype. This -- function returns the tree node corresponding to an occurrence of the --- first index (NOT the entity for the type). Subsequent indexes are +-- first index (NOT the entity for the type). Subsequent indices are -- obtained using Next_Index. Note that this field is defined for the -- case of string literal subtypes, but is always Empty. @@ -1429,11 +1429,12 @@ package Einfo is -- type has no discriminants and the full view has discriminants with -- defaults. In Ada 2005 heap-allocated objects of such types are not -- constrained, and can change their discriminants with full assignment. --- Sem_Aux.Effectively_Has_Constrained_Partial_View should be always --- used by callers, rather than reading this attribute directly because, --- according to RM 3.10.2 (27/2), untagged generic formal private types --- and subtypes are also considered to have a constrained partial view --- [when in a generic body]. +-- +-- Ada 2012 has an additional rule (3.3. (23/10.3)) concerning objects +-- declared in a generic package body. Objects whose type is an untagged +-- generic formal private type are considered to have a constrained +-- partial view. The predicate Object_Type_Has_Constrained_Partial_View +-- 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 @@ -1487,6 +1488,14 @@ package Einfo is -- of the table); otherwise the code that builds the table is added at -- the end of the list of declarations of the package. +-- Has_Dynamic_Predicate_Aspect (Flag258) +-- Defined in all types and subtypes. Set if a Dynamic_Predicate aspect +-- applies to the type. Note that we can tell if a dynamic predicate is +-- present by looking at Has_Predicates and Static_Predicate, but that +-- could have come from a Predicate aspect or pragma, and we need to +-- record the difference so that we can use the right set of check +-- policies to figure out if the predicate is active. + -- Has_Entries (synthesized) -- Applies to concurrent types. True if any entries are declared -- within the task or protected definition for the type. @@ -1587,9 +1596,12 @@ package Einfo is -- True, then usually the Invariant_Procedure attribute is set once the -- type is frozen, however this may not be true in some error situations. -- Note that it might be the full type which has inheritable invariants, --- and then the flag will also be set in the private type. Also set in --- the invariant procedure entity, to distinguish it among entries in the --- Subprograms_For_Type. +-- and then the flag will also be set in the private type. + +-- Has_Loop_Entry_Attributes (Flag260) +-- Defined in E_Loop entities. Set when the loop is subject to at least +-- one attribute 'Loop_Entry. The flag also implies that the loop has +-- already been transformed. See Expand_Loop_Entry_Attribute for details. -- Has_Machine_Radix_Clause (Flag83) -- Defined in decimal types and subtypes, set if a Machine_Radix @@ -1731,23 +1743,23 @@ package Einfo is -- such an object and no warning is generated. -- Has_Predicates (Flag250) --- Defined in all entities. Set in type and subtype entities if a pragma --- Predicate or Predicate aspect applies to the type, or if it inherits a --- Predicate aspect from its parent or progenitor types. Also set in the --- predicate function entity, to distinguish it among entries in the --- Subprograms_For_Type. +-- Defined in type and subtype entities. Set if a pragma Predicate or +-- Predicate aspect applies to the type or subtype, or if it inherits a +-- Predicate aspect from its parent or progenitor types. -- Has_Primitive_Operations (Flag120) [base type only] -- Defined in all type entities. Set if at least one primitive operation -- is defined for the type. -- Has_Private_Ancestor (Flag151) --- Applies to type extensions. True if some ancestor is derived from a --- private type, making some components invisible and aggregates illegal. --- This flag is set at the point of derivation. The legality of the --- aggregate must be rechecked because it also depends on the visibility --- at the point the aggregate is resolved. See sem_aggr.adb. --- This is part of AI05-0115. +-- Applies to untagged derived types and to type extensions. True when +-- 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. -- Has_Private_Declaration (Flag155) -- Defined in all entities. Returns True if it is the defining entity @@ -1821,6 +1833,14 @@ package Einfo is -- case of a variant record, the component list can be trimmed down to -- include only the components corresponding to these discriminants. +-- Has_Static_Predicate_Aspect (Flag259) +-- Defined in all types and subtypes. Set if a Dynamic_Predicate aspect +-- applies to the type. Note that we can tell if a static predicate is +-- present by looking at Has_Predicates and Static_Predicate, but that +-- could have come from a Predicate aspect or pragma, and we need to +-- record the difference so that we can use the right set of check +-- policies to figure out if the predicate is active. + -- Has_Storage_Size_Clause (Flag23) [implementation base type only] -- Defined in task types and access types. It is set if a Storage_Size -- clause is present for the type. Used to prevent multiple clauses for @@ -2296,6 +2316,14 @@ package Einfo is -- package, generic function, generic procedure), and False for all -- other entities. +-- Is_Ghost_Entity (synthesized) +-- Applies to all entities. Yields True for a subprogram or a whole +-- object that has convention Ghost. + +-- Is_Ghost_Subprogram (synthesized) +-- Applies to all entities. Yields True for a subprogram that has a Ghost +-- convention. + -- Is_Hidden (Flag57) -- Defined in all entities. Set true for all entities declared in the -- private part or body of a package. Also marks generic formals of a @@ -2406,6 +2434,10 @@ package Einfo is -- setting of Is_Intrinsic_Subprogram, NOT simply having convention set -- to intrinsic, which causes intrinsic code to be generated. +-- Is_Invariant_Procedure (Flag257) +-- Defined in functions an procedures. Set for a generated invariant +-- procedure to identify it easily in the + -- Is_Itype (Flag91) -- Defined in all entities. Set to indicate that a type is an Itype, -- which means that the declaration for the type does not appear @@ -2523,7 +2555,7 @@ package Einfo is -- entirely synthesized, by looking at the bounds, and the immediate -- subtype parent. However, this method does not work for some Itypes -- that have no parent set (and the only way to find the immediate --- subtype parent is to go through the tree). For now, this flay is set +-- subtype parent is to go through the tree). For now, this flag is set -- conservatively, i.e. if it is set then for sure the subtype is non- -- static, but if it is not set, then the type may or may not be static. -- Thus the test for a static subtype is that this flag is clear AND that @@ -2637,6 +2669,15 @@ package Einfo is -- use clause (RM 8.4(8)). Note that potentially use visible entities -- are not necessarily use visible (RM 8.4(9-11)). +-- Is_Predicate_Function (Flag255) +-- Present in functions and procedures. Set for generated predicate +-- functions. + +-- Is_Predicate_Function_M (Flag256) +-- Present in functions and procedures. Set for special version of +-- predicate function generated for use in membership tests, where +-- raise expressions are transformed to return False. + -- Is_Preelaborated (Flag59) -- Defined in all entities, set in E_Package and E_Generic_Package -- entities to which a pragma Preelaborate is applied, and also in @@ -2834,14 +2875,17 @@ package Einfo is -- Applies to all entities. True for task types and subtypes -- Is_Thunk (Flag225) --- Defined in all entities for subprograms (functions, procedures, and --- operators). True for subprograms that are thunks, that is small --- subprograms built by the expander for tagged types that cover --- interface types. At run-time thunks displace the pointer to the object --- (pointer named "this" in the C++ terminology) from a secondary --- dispatch table to the primary dispatch table associated with a given --- tagged type. Set by Expand_Interface_Thunk and used by Expand_Call to --- handle extra actuals associated with accessibility level. +-- Defined in all entities. True for subprograms that are thunks: that is +-- small subprograms built by the expander for tagged types that cover +-- interface types. As part of the runtime call to an interface, thunks +-- displace the pointer to the object (pointer named "this" in the C++ +-- terminology) from a secondary dispatch table to the primary dispatch +-- table associated with a given tagged type; if the thunk is a function +-- that returns an object which covers an interface type then the thunk +-- displaces the pointer to the object from the primary dispatch table to +-- the secondary dispatch table associated with the interface type. Set +-- by Expand_Interface_Thunk and used by Expand_Call to handle extra +-- actuals associated with accessibility level. -- Is_Trivial_Subprogram (Flag235) -- Defined in all entities. Set in subprograms where either the body @@ -3000,10 +3044,6 @@ package Einfo is -- the nature and use of this entity for implementing the Image and -- Value attributes for the enumeration type in question. --- Loop_Entry_Attributes (Elist10) --- Defined for loop statement scopes. The list contains all Loop_Entry --- attribute references related to the target loop. - -- 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 @@ -3384,6 +3424,12 @@ package Einfo is -- Note: the reason this is marked as a synthesized attribute is that the -- way this is stored is as an element of the Subprograms_For_Type field. +-- Predicate_Function_M (synthesized) +-- Defined in all types. Present only if Predicate_Function is present, +-- and only if the predicate function has Raise_Expression nodes. It +-- is the special version created for membership tests, where if one of +-- these raise expressions is executed, the result is to return False. + -- Primitive_Operations (synthesized) -- Defined in concurrent types, tagged record types and subtypes, tagged -- private types and tagged incomplete types. For concurrent types whose @@ -3835,6 +3881,10 @@ package Einfo is -- The last sentence is odd??? Why not have Task_Body_Procedure go to the -- Underlying_Type of the Root_Type??? +-- Thunk_Entity (Node31) +-- Defined in functions and procedures which have been classified as +-- Is_Thunk. Set to the target entity called by the thunk. + -- Treat_As_Volatile (Flag41) -- Defined in all type entities, and also in constants, components and -- variables. Set if this entity is to be treated as volatile for code @@ -4175,6 +4225,7 @@ package Einfo is -- floating point subtype created by a floating point type declaration. E_Floating_Point_Subtype, + -- Floating point subtype, created by either a floating point subtype -- or floating point type declaration (in the latter case a floating -- point type is created for the base type, and this is the first @@ -4813,7 +4864,7 @@ package Einfo is -- non-synthesized attributes, of the corresponding set procedures) are -- in the Einfo body. - -- The following attributes apply to all entities + -- The following attributes are defined in all entities -- Ekind (Ekind) @@ -4844,7 +4895,6 @@ package Einfo is -- Has_Pragma_Thread_Local_Storage (Flag169) -- Has_Pragma_Unmodified (Flag233) -- Has_Pragma_Unreferenced (Flag180) - -- Has_Predicates (Flag250) -- Has_Private_Declaration (Flag155) -- Has_Qualified_Name (Flag161) -- Has_Stream_Size_Clause (Flag184) @@ -4895,6 +4945,7 @@ package Einfo is -- Is_Shared_Passive (Flag60) -- Is_Statically_Allocated (Flag28) -- Is_Tagged_Type (Flag55) + -- Is_Thunk (Flag225) -- Is_Trivial_Subprogram (Flag235) -- Is_Unchecked_Union (Flag117) -- Is_Visible_Formal (Flag206) @@ -4954,6 +5005,7 @@ package Einfo is -- Has_Controlled_Component (Flag43) (base type only) -- Has_Default_Aspect (Flag39) (base type only) -- Has_Discriminants (Flag5) + -- Has_Dynamic_Predicate_Aspect (Flag258) -- Has_Independent_Components (Flag34) (base type only) -- Has_Inheritable_Invariants (Flag248) -- Has_Invariants (Flag232) @@ -4961,6 +5013,7 @@ package Einfo is -- Has_Object_Size_Clause (Flag172) -- Has_Pragma_Preelab_Init (Flag221) -- Has_Pragma_Unreferenced_Objects (Flag212) + -- Has_Predicates (Flag250) -- Has_Primitive_Operations (Flag120) (base type only) -- Has_Size_Clause (Flag29) -- Has_Specified_Layout (Flag100) (base type only) @@ -4968,6 +5021,7 @@ package Einfo is -- Has_Specified_Stream_Output (Flag191) -- Has_Specified_Stream_Read (Flag192) -- Has_Specified_Stream_Write (Flag193) + -- Has_Static_Predicate_Aspect (Flag259) -- Has_Task (Flag30) (base type only) -- Has_Unchecked_Union (Flag123) (base type only) -- Has_Volatile_Components (Flag87) (base type only) @@ -5006,6 +5060,7 @@ package Einfo is -- Invariant_Procedure (synth) -- Is_Access_Protected_Subprogram_Type (synth) -- Predicate_Function (synth) + -- Predicate_Function_M (synth) -- Root_Type (synth) -- Size_Clause (synth) @@ -5338,6 +5393,7 @@ package Einfo is -- Extra_Formals (Node28) -- Subprograms_For_Type (Node29) -- Corresponding_Equality (Node30) (implicit /= only) + -- Thunk_Entity (Node31) (thunk case only) -- Body_Needed_For_SAL (Flag40) -- Elaboration_Entity_Required (Flag174) -- Default_Expressions_Processed (Flag108) @@ -5360,13 +5416,15 @@ package Einfo is -- Is_Eliminated (Flag124) -- Is_Instantiated (Flag126) (generic case only) -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Invariant_Procedure (Flag257) (non-generic case only) -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) + -- Is_Predicate_Function (Flag255) (non-generic case only) + -- Is_Predicate_Function_M (Flag256) (non-generic case only) -- Is_Primitive (Flag218) -- Is_Primitive_Wrapper (Flag195) (non-generic case only) -- Is_Private_Descendant (Flag53) -- Is_Private_Primitive (Flag245) (non-generic case only) -- Is_Pure (Flag44) - -- Is_Thunk (Flag225) -- Is_Visible_Lib_Unit (Flag116) -- Needs_No_Actuals (Flag22) -- Requires_Overriding (Flag213) (non-generic case only) @@ -5377,6 +5435,8 @@ package Einfo is -- Address_Clause (synth) -- First_Formal (synth) -- First_Formal_With_Extras (synth) + -- Is_Ghost_Entity (synth) (non-generic case only) + -- Is_Ghost_Subprogram (synth) (non-generic case only) -- Last_Formal (synth) -- Number_Formals (synth) -- Scope_Depth (synth) @@ -5456,8 +5516,8 @@ package Einfo is -- E_Loop -- First_Exit_Statement (Node8) - -- Loop_Entry_Attributes (Elist10) -- Has_Exit (Flag47) + -- Has_Loop_Entry_Attributes (Flag260) -- Has_Master_Entity (Flag21) -- Has_Nested_Block_With_Handler (Flag101) @@ -5491,7 +5551,6 @@ package Einfo is -- Is_Pure (Flag44) -- Is_Intrinsic_Subprogram (Flag64) -- Is_Primitive (Flag218) - -- Is_Thunk (Flag225) -- Default_Expressions_Processed (Flag108) -- Aren't there more flags and fields? seems like this list should be -- more similar to the E_Function list, which is much longer ??? @@ -5607,6 +5666,7 @@ package Einfo is -- Wrapped_Entity (Node27) (non-generic case only) -- Extra_Formals (Node28) -- Static_Initialization (Node30) (init_proc only) + -- Thunk_Entity (Node31) (thunk case only) -- Body_Needed_For_SAL (Flag40) -- Delay_Cleanups (Flag114) -- Discard_Names (Flag88) @@ -5629,14 +5689,16 @@ package Einfo is -- Is_Instantiated (Flag126) (generic case only) -- Is_Interrupt_Handler (Flag89) -- Is_Intrinsic_Subprogram (Flag64) + -- Is_Invariant_Procedure (Flag257) (non-generic case only) -- Is_Machine_Code_Subprogram (Flag137) (non-generic case only) -- Is_Null_Init_Proc (Flag178) + -- Is_Predicate_Function (Flag255) (non-generic case only) + -- Is_Predicate_Function_M (Flag256) (non-generic case only) -- Is_Primitive (Flag218) -- Is_Primitive_Wrapper (Flag195) (non-generic case only) -- Is_Private_Descendant (Flag53) -- Is_Private_Primitive (Flag245) (non-generic case only) -- Is_Pure (Flag44) - -- Is_Thunk (Flag225) -- Is_Valued_Procedure (Flag127) -- Is_Visible_Lib_Unit (Flag116) -- Needs_No_Actuals (Flag22) @@ -5647,6 +5709,8 @@ package Einfo is -- First_Formal (synth) -- First_Formal_With_Extras (synth) -- Is_Finalizer (synth) + -- Is_Ghost_Entity (synth) (non-generic case only) + -- Is_Ghost_Subprogram (synth) (non-generic case only) -- Last_Formal (synth) -- Number_Formals (synth) @@ -5853,6 +5917,7 @@ package Einfo is -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) -- Alignment_Clause (synth) + -- Is_Ghost_Entity (synth) -- Size_Clause (synth) -- E_Void @@ -6213,6 +6278,7 @@ package Einfo is function Has_Delayed_Freeze (Id : E) return B; function Has_Discriminants (Id : E) return B; function Has_Dispatch_Table (Id : E) return B; + function Has_Dynamic_Predicate_Aspect (Id : E) return B; function Has_Enumeration_Rep_Clause (Id : E) return B; function Has_Exit (Id : E) return B; function Has_External_Tag_Rep_Clause (Id : E) return B; @@ -6226,6 +6292,7 @@ package Einfo is function Has_Initial_Value (Id : E) return B; function Has_Interrupt_Handler (Id : E) return B; function Has_Invariants (Id : E) return B; + function Has_Loop_Entry_Attributes (Id : E) return B; function Has_Machine_Radix_Clause (Id : E) return B; function Has_Master_Entity (Id : E) return B; function Has_Missing_Return (Id : E) return B; @@ -6251,6 +6318,7 @@ package Einfo is function Has_Predicates (Id : E) return B; function Has_Primitive_Operations (Id : E) return B; function Has_Private_Ancestor (Id : E) return B; + function Has_Private_Declaration (Id : E) return B; function Has_Qualified_Name (Id : E) return B; function Has_RACW (Id : E) return B; function Has_Record_Rep_Clause (Id : E) return B; @@ -6263,6 +6331,7 @@ package Einfo is function Has_Specified_Stream_Read (Id : E) return B; function Has_Specified_Stream_Write (Id : E) return B; function Has_Static_Discriminants (Id : E) return B; + function Has_Static_Predicate_Aspect (Id : E) return B; function Has_Storage_Size_Clause (Id : E) return B; function Has_Stream_Size_Clause (Id : E) return B; function Has_Task (Id : E) return B; @@ -6327,6 +6396,7 @@ package Einfo is function Is_Internal (Id : E) return B; function Is_Interrupt_Handler (Id : E) return B; function Is_Intrinsic_Subprogram (Id : E) return B; + function Is_Invariant_Procedure (Id : E) return B; function Is_Itype (Id : E) return B; function Is_Known_Non_Null (Id : E) return B; function Is_Known_Null (Id : E) return B; @@ -6344,6 +6414,8 @@ package Einfo is function Is_Packed (Id : E) return B; function Is_Packed_Array_Type (Id : E) return B; function Is_Potentially_Use_Visible (Id : E) return B; + function Is_Predicate_Function (Id : E) return B; + function Is_Predicate_Function_M (Id : E) return B; function Is_Preelaborated (Id : E) return B; function Is_Primitive (Id : E) return B; function Is_Primitive_Wrapper (Id : E) return B; @@ -6385,7 +6457,6 @@ package Einfo is function Limited_View (Id : E) return E; function Lit_Indexes (Id : E) return E; function Lit_Strings (Id : E) return E; - function Loop_Entry_Attributes (Id : E) return L; function Low_Bound_Tested (Id : E) return B; function Machine_Radix_10 (Id : E) return B; function Master_Id (Id : E) return E; @@ -6476,6 +6547,7 @@ package Einfo is function Suppress_Style_Checks (Id : E) return B; function Suppress_Value_Tracking_On_Call (Id : E) return B; function Task_Body_Procedure (Id : E) return N; + function Thunk_Entity (Id : E) return E; function Treat_As_Volatile (Id : E) return B; function Underlying_Full_View (Id : E) return E; function Underlying_Record_View (Id : E) return E; @@ -6570,7 +6642,6 @@ 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_Private_Declaration (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; @@ -6578,6 +6649,8 @@ package Einfo is function Is_Discriminal (Id : E) return B; function Is_Dynamic_Scope (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_Null_State (Id : E) return B; function Is_Output_State (Id : E) return B; @@ -6814,6 +6887,7 @@ package Einfo is procedure Set_Has_Delayed_Freeze (Id : E; V : B := True); procedure Set_Has_Discriminants (Id : E; V : B := True); procedure Set_Has_Dispatch_Table (Id : E; V : B := True); + procedure Set_Has_Dynamic_Predicate_Aspect (Id : E; V : B := True); procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True); procedure Set_Has_Exit (Id : E; V : B := True); procedure Set_Has_External_Tag_Rep_Clause (Id : E; V : B := True); @@ -6826,6 +6900,7 @@ package Einfo is procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True); procedure Set_Has_Initial_Value (Id : E; V : B := True); procedure Set_Has_Invariants (Id : E; V : B := True); + procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True); procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True); procedure Set_Has_Master_Entity (Id : E; V : B := True); procedure Set_Has_Missing_Return (Id : E; V : B := True); @@ -6864,6 +6939,7 @@ package Einfo is procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True); procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True); procedure Set_Has_Static_Discriminants (Id : E; V : B := True); + procedure Set_Has_Static_Predicate_Aspect (Id : E; V : B := True); procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True); procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True); procedure Set_Has_Task (Id : E; V : B := True); @@ -6933,6 +7009,7 @@ package Einfo is procedure Set_Is_Internal (Id : E; V : B := True); procedure Set_Is_Interrupt_Handler (Id : E; V : B := True); procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True); + procedure Set_Is_Invariant_Procedure (Id : E; V : B := True); procedure Set_Is_Itype (Id : E; V : B := True); procedure Set_Is_Known_Non_Null (Id : E; V : B := True); procedure Set_Is_Known_Null (Id : E; V : B := True); @@ -6951,6 +7028,8 @@ package Einfo is procedure Set_Is_Packed (Id : E; V : B := True); procedure Set_Is_Packed_Array_Type (Id : E; V : B := True); procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True); + procedure Set_Is_Predicate_Function (Id : E; V : B := True); + procedure Set_Is_Predicate_Function_M (Id : E; V : B := True); procedure Set_Is_Preelaborated (Id : E; V : B := True); procedure Set_Is_Primitive (Id : E; V : B := True); procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True); @@ -6992,7 +7071,6 @@ package Einfo is procedure Set_Limited_View (Id : E; V : E); procedure Set_Lit_Indexes (Id : E; V : E); procedure Set_Lit_Strings (Id : E; V : E); - procedure Set_Loop_Entry_Attributes (Id : E; V : L); procedure Set_Low_Bound_Tested (Id : E; V : B := True); procedure Set_Machine_Radix_10 (Id : E; V : B := True); procedure Set_Master_Id (Id : E; V : E); @@ -7083,6 +7161,7 @@ package Einfo is procedure Set_Suppress_Style_Checks (Id : E; V : B := True); procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True); procedure Set_Task_Body_Procedure (Id : E; V : N); + procedure Set_Thunk_Entity (Id : E; V : E); procedure Set_Treat_As_Volatile (Id : E; V : B := True); procedure Set_Underlying_Full_View (Id : E; V : E); procedure Set_Underlying_Record_View (Id : E; V : E); @@ -7104,9 +7183,11 @@ package Einfo is function Invariant_Procedure (Id : E) return N; function Predicate_Function (Id : E) return N; + function Predicate_Function_M (Id : E) return N; procedure Set_Invariant_Procedure (Id : E; V : E); procedure Set_Predicate_Function (Id : E; V : E); + procedure Set_Predicate_Function_M (Id : E; V : E); ----------------------------------- -- Field Initialization Routines -- @@ -7280,6 +7361,11 @@ package Einfo is -- value returned is the N_Attribute_Definition_Clause node, otherwise -- 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. + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id; -- Searches the Rep_Item chain for a given entity E, for a record -- representation clause, and if found, returns it. Returns Empty @@ -7505,6 +7591,7 @@ package Einfo is pragma Inline (Has_Delayed_Freeze); pragma Inline (Has_Discriminants); pragma Inline (Has_Dispatch_Table); + pragma Inline (Has_Dynamic_Predicate_Aspect); pragma Inline (Has_Enumeration_Rep_Clause); pragma Inline (Has_Exit); pragma Inline (Has_External_Tag_Rep_Clause); @@ -7517,6 +7604,7 @@ package Einfo is pragma Inline (Has_Inheritable_Invariants); pragma Inline (Has_Initial_Value); pragma Inline (Has_Invariants); + pragma Inline (Has_Loop_Entry_Attributes); pragma Inline (Has_Machine_Radix_Clause); pragma Inline (Has_Master_Entity); pragma Inline (Has_Missing_Return); @@ -7555,6 +7643,7 @@ package Einfo is pragma Inline (Has_Specified_Stream_Read); pragma Inline (Has_Specified_Stream_Write); pragma Inline (Has_Static_Discriminants); + pragma Inline (Has_Static_Predicate_Aspect); pragma Inline (Has_Storage_Size_Clause); pragma Inline (Has_Stream_Size_Clause); pragma Inline (Has_Task); @@ -7649,6 +7738,7 @@ package Einfo is pragma Inline (Is_Internal); pragma Inline (Is_Interrupt_Handler); pragma Inline (Is_Intrinsic_Subprogram); + pragma Inline (Is_Invariant_Procedure); pragma Inline (Is_Itype); pragma Inline (Is_Known_Non_Null); pragma Inline (Is_Known_Null); @@ -7673,6 +7763,8 @@ package Einfo is pragma Inline (Is_Packed); pragma Inline (Is_Packed_Array_Type); pragma Inline (Is_Potentially_Use_Visible); + pragma Inline (Is_Predicate_Function); + pragma Inline (Is_Predicate_Function_M); pragma Inline (Is_Preelaborated); pragma Inline (Is_Primitive); pragma Inline (Is_Primitive_Wrapper); @@ -7722,7 +7814,6 @@ package Einfo is pragma Inline (Limited_View); pragma Inline (Lit_Indexes); pragma Inline (Lit_Strings); - pragma Inline (Loop_Entry_Attributes); pragma Inline (Low_Bound_Tested); pragma Inline (Machine_Radix_10); pragma Inline (Master_Id); @@ -7816,6 +7907,7 @@ package Einfo is pragma Inline (Suppress_Style_Checks); pragma Inline (Suppress_Value_Tracking_On_Call); pragma Inline (Task_Body_Procedure); + pragma Inline (Thunk_Entity); pragma Inline (Treat_As_Volatile); pragma Inline (Underlying_Full_View); pragma Inline (Underlying_Record_View); @@ -7956,6 +8048,7 @@ package Einfo is pragma Inline (Set_Has_Delayed_Freeze); pragma Inline (Set_Has_Discriminants); pragma Inline (Set_Has_Dispatch_Table); + pragma Inline (Set_Has_Dynamic_Predicate_Aspect); pragma Inline (Set_Has_Enumeration_Rep_Clause); pragma Inline (Set_Has_Exit); pragma Inline (Set_Has_External_Tag_Rep_Clause); @@ -7968,6 +8061,7 @@ package Einfo is pragma Inline (Set_Has_Inheritable_Invariants); pragma Inline (Set_Has_Initial_Value); pragma Inline (Set_Has_Invariants); + pragma Inline (Set_Has_Loop_Entry_Attributes); pragma Inline (Set_Has_Machine_Radix_Clause); pragma Inline (Set_Has_Master_Entity); pragma Inline (Set_Has_Missing_Return); @@ -8006,6 +8100,7 @@ package Einfo is pragma Inline (Set_Has_Specified_Stream_Read); pragma Inline (Set_Has_Specified_Stream_Write); pragma Inline (Set_Has_Static_Discriminants); + pragma Inline (Set_Has_Static_Predicate_Aspect); pragma Inline (Set_Has_Storage_Size_Clause); pragma Inline (Set_Has_Stream_Size_Clause); pragma Inline (Set_Has_Task); @@ -8074,6 +8169,7 @@ package Einfo is pragma Inline (Set_Is_Internal); pragma Inline (Set_Is_Interrupt_Handler); pragma Inline (Set_Is_Intrinsic_Subprogram); + pragma Inline (Set_Is_Invariant_Procedure); pragma Inline (Set_Is_Itype); pragma Inline (Set_Is_Known_Non_Null); pragma Inline (Set_Is_Known_Null); @@ -8092,6 +8188,8 @@ package Einfo is pragma Inline (Set_Is_Packed); pragma Inline (Set_Is_Packed_Array_Type); pragma Inline (Set_Is_Potentially_Use_Visible); + pragma Inline (Set_Is_Predicate_Function); + pragma Inline (Set_Is_Predicate_Function_M); pragma Inline (Set_Is_Preelaborated); pragma Inline (Set_Is_Primitive); pragma Inline (Set_Is_Primitive_Wrapper); @@ -8133,7 +8231,6 @@ package Einfo is pragma Inline (Set_Limited_View); pragma Inline (Set_Lit_Indexes); pragma Inline (Set_Lit_Strings); - pragma Inline (Set_Loop_Entry_Attributes); pragma Inline (Set_Low_Bound_Tested); pragma Inline (Set_Machine_Radix_10); pragma Inline (Set_Master_Id); @@ -8224,6 +8321,7 @@ package Einfo is pragma Inline (Set_Suppress_Style_Checks); pragma Inline (Set_Suppress_Value_Tracking_On_Call); pragma Inline (Set_Task_Body_Procedure); + pragma Inline (Set_Thunk_Entity); pragma Inline (Set_Treat_As_Volatile); pragma Inline (Set_Underlying_Full_View); pragma Inline (Set_Underlying_Record_View); diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb index 58beb00d572..6170585272e 100644 --- a/gcc/ada/elists.adb +++ b/gcc/ada/elists.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- -- @@ -158,6 +158,28 @@ package body Elists is end loop; end Append_Unique_Elmt; + -------------- + -- Contains -- + -------------- + + function Contains (List : Elist_Id; N : Node_Or_Entity_Id) return Boolean is + Elmt : Elmt_Id; + + begin + if Present (List) then + Elmt := First_Elmt (List); + while Present (Elmt) loop + if Node (Elmt) = N then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + return False; + end Contains; + -------------------- -- Elists_Address -- -------------------- diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads index 0e9a2a2f33f..8f66e0553bf 100644 --- a/gcc/ada/elists.ads +++ b/gcc/ada/elists.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -153,6 +153,10 @@ package Elists is -- affected, but the space used by the list element may be (but is not -- required to be) freed for reuse in a subsequent Append_Elmt call. + function Contains (List : Elist_Id; N : Node_Or_Entity_Id) return Boolean; + -- Perform a sequential search to determine whether the given list contains + -- a node or an entity. + function No (List : Elist_Id) return Boolean; pragma Inline (No); -- Tests given Id for equality with No_Elist. This allows notations like diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads index ecfbc54ce81..bc43cb15230 100644 --- a/gcc/ada/err_vars.ads +++ b/gcc/ada/err_vars.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- -- @@ -54,7 +54,7 @@ package Err_Vars is -- variables are not reset by calls to the error message routines, so the -- caller is responsible for resetting the default behavior after use. - Error_Msg_Qual_Level : Int; + Error_Msg_Qual_Level : Int := 0; -- Number of levels of qualification required for type name (see the -- description of the } insertion character. Note that this value does -- note get reset by any Error_Msg call, so the caller is responsible diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index d9973eb2cd5..b8d044e3d34 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2920,10 +2920,10 @@ package body Errout is elsif Msg = "size for& too small, minimum allowed is ^" then - -- Suppress "size too small" errors in CodePeer mode and Alfa mode, + -- Suppress "size too small" errors in CodePeer mode and SPARK mode, -- since pragma Pack is also ignored in these configurations. - if CodePeer_Mode or Alfa_Mode then + if CodePeer_Mode or SPARK_Mode then return True; -- When a size is wrong for a frozen type there is no explicit size diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 1dd232bed6e..4b30a0663a0 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -222,7 +222,7 @@ package Errout is -- A second ^ may occur in the message, in which case it is replaced -- by the decimal conversion of the Uint value in Error_Msg_Uint_2. - -- Insertion character > (Right bracket, run time name) + -- Insertion character > (Greater Than, run time name) -- The character > is replaced by a string of the form (name) if -- Targparm scanned out a Run_Time_Name (see package Targparm for -- details). The name is enclosed in parentheses and output in mixed @@ -242,7 +242,7 @@ package Errout is -- messages starting with the \ insertion character). The effect of the -- use of ! in a parent message automatically applies to all of its -- continuation messages (since we clearly don't want any case in which - -- continuations are separated from the parent message. It is allowable + -- continuations are separated from the main message). It is allowable -- to put ! in continuation messages, and the usual style is to include -- it, since it makes it clear that the continuation is part of an -- unconditional message. @@ -280,24 +280,27 @@ package Errout is -- which is being continued. It is allowable to put ? in continuation -- messages, and the usual style is to include it, since it makes it -- clear that the continuation is part of a warning message. + -- + -- Note: this usage is obsolete, use ??, ?x? or ?X? instead to specify + -- the string to be added when Warn_Doc_Switch is set to True. If this + -- switch is True, then for simple ? messages it has no effect. This + -- simple form is to ease transition and will be removed later. - -- Insertion character ?? (two question marks) + -- Insertion character ?? (Two question marks: default warning) -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string - -- "[enabled by default]" at the end of the warning message. In the - -- case of continuations, use this in each continuation message. + -- "[enabled by default]" at the end of the warning message. For + -- continuations, use this in each continuation message. -- Insertion character ?x? (warning with switch) -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string -- "[-gnatwx]" at the end of the warning message. x is a lower case - -- letter. In the case of continuations, use this on each continuation - -- message. + -- letter. For continuations, use this on each continuation message. -- Insertion character ?X? (warning with dot switch) -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string -- "[-gnatw.x]" at the end of the warning message. X is an upper case - -- letter corresponding to the lower case letter x in the message. In - -- the case of continuations, use this on each continuation - -- message. + -- letter corresponding to the lower case letter x in the message. + -- For continuations, use this on each continuation message. -- Insertion character < (Less Than: conditional warning message) -- The character < appearing anywhere in a message is used for a @@ -321,9 +324,8 @@ package Errout is -- Insertion character ' (Quote: literal character) -- Precedes a character which is placed literally into the message. -- Used to insert characters into messages that are one of the - -- insertion characters defined here. Also useful in inserting - -- sequences of upper case letters which are not to be treated as - -- keywords. + -- insertion characters defined here. Also used when insertion + -- upper case letter sequences not to be treated as keywords. -- Insertion character \ (Backslash: continuation message) -- Indicates that the message is a continuation of a message @@ -505,8 +507,8 @@ package Errout is -- Note: a special exception is that RM is never treated as a keyword -- but instead is copied literally into the message, this avoids the -- need for writing 'R'M for all reference manual quotes. A similar - -- exception is applied to the occurrence of the string Alfa used in - -- error messages about the Alfa subset of Ada. + -- exception is applied to the occurrence of the string SPARK used in + -- error messages about the SPARK subset of Ada. -- In the case of names, the default mode for the error text processor -- is to surround the name by quotation marks automatically. The case diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 8a1050fdd8a..a0da2304bc4 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -986,12 +986,12 @@ package body Erroutc is if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then Set_Msg_Name_Buffer; - -- We make a similar exception for Alfa + -- We make a similar exception for SPARK - elsif Name_Len = 4 and then Name_Buffer (1 .. 4) = "Alfa" then + elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then Set_Msg_Name_Buffer; - -- Neither RM nor Alfa: case appropriately and add surrounding quotes + -- Neither RM nor SPARK: case appropriately and add surrounding quotes else Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 3b9d06febac..e0a91324a80 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.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- -- @@ -59,6 +59,7 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -312,31 +313,11 @@ package body Exp_Aggr is Lov : Uint; Hiv : Uint; - -- The following constant determines the maximum size of an array - -- aggregate produced by converting named to positional notation (e.g. - -- from others clauses). This avoids running away with attempts to - -- convert huge aggregates, which hit memory limits in the backend. - - -- The normal limit is 5000, 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 limit. We also - -- increase the limit when Static_Elaboration_Desired, given that this - -- means that objects are intended to be placed in data memory. - - -- We also increase the limit if the aggregate is for a packed two- - -- dimensional array, because if components are static it is much more - -- efficient to construct a one-dimensional equivalent array with static - -- components. - - Max_Aggr_Size : constant Nat := - 5000 + (2 ** 24 - 5000) * - Boolean'Pos - (Restriction_Active (No_Elaboration_Code) - or else Restriction_Active (No_Implicit_Loops) - or else Is_Two_Dim_Packed_Array (Typ) - or else ((Ekind (Current_Scope) = E_Package - and then Static_Elaboration_Desired (Current_Scope)))); + Max_Aggr_Size : Nat; + -- Determines the maximum size of an array aggregate produced by + -- converting named to positional notation (e.g. from others clauses). + -- This avoids running away with attempts to convert huge aggregates, + -- which hit memory limits in the backend. function Component_Count (T : Entity_Id) return Int; -- The limit is applied to the total number of components that the @@ -395,6 +376,36 @@ 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 + -- 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 + -- limit. We also increase the limit when Static_Elaboration_Desired, + -- given that this means that objects are intended to be placed in data + -- memory. + + -- We also increase the limit if the aggregate is for a packed two- + -- dimensional array, because if components are static it is much more + -- efficient to construct a one-dimensional equivalent array with static + -- components. + + -- 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; + + if CodePeer_Mode then + Max_Aggr_Size := 100; + + elsif Restriction_Active (No_Elaboration_Code) + or else Restriction_Active (No_Implicit_Loops) + or else Is_Two_Dim_Packed_Array (Typ) + or else ((Ekind (Current_Scope) = E_Package + and then Static_Elaboration_Desired (Current_Scope))) + then + Max_Aggr_Size := 2 ** 24; + end if; + Siz := Component_Count (Component_Type (Typ)); Indx := First_Index (Typ); @@ -1830,6 +1841,11 @@ package body Exp_Aggr is -- these discriminants are not components of the aggregate, and must be -- initialized. The assignments are appended to List. + function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id; + -- If the ancestor part is an unconstrained type and further ancestors + -- do not provide discriminants for it, check aggregate components for + -- values of the discriminants. + function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean; -- Check whether Bounds is a range node and its lower and higher bounds -- are integers literals. @@ -2048,6 +2064,37 @@ package body Exp_Aggr is return Empty; end Get_Constraint_Association; + ------------------------------------- + -- Get_Explicit_Discriminant_Value -- + ------------------------------------- + + function Get_Explicit_Discriminant_Value + (D : Entity_Id) return Node_Id + is + Assoc : Node_Id; + Choice : Node_Id; + Val : Node_Id; + + begin + -- The aggregate has been normalized and all associations have a + -- single choice. + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + + if Chars (Choice) = Chars (D) then + Val := Expression (Assoc); + Remove (Assoc); + return Val; + end if; + + Next (Assoc); + end loop; + + return Empty; + end Get_Explicit_Discriminant_Value; + ------------------------------- -- Init_Hidden_Discriminants -- ------------------------------- @@ -2285,6 +2332,15 @@ package body Exp_Aggr is Discrim := First_Discriminant (Anc_Typ); while Present (Discrim) loop Disc_Value := Ancestor_Discriminant_Value (Discrim); + + -- If no usable discriminant in ancestors, check + -- whether aggregate has an explicit value for it. + + if No (Disc_Value) then + Disc_Value := + Get_Explicit_Discriminant_Value (Discrim); + end if; + Append_To (Anc_Constr, Disc_Value); Next_Discriminant (Discrim); end loop; @@ -5160,9 +5216,102 @@ package body Exp_Aggr is procedure Expand_N_Aggregate (N : Node_Id) is begin + -- Record aggregate case + if Is_Record_Type (Etype (N)) then Expand_Record_Aggregate (N); + + -- Array aggregate case + else + -- A special case, if we have a string subtype with bounds 1 .. N, + -- where N is known at compile time, and the aggregate is of the + -- form (others => 'x'), with a single choice and no expressions, + -- and N is less than 80 (an arbitrary limit for now), then replace + -- the aggregate by the equivalent string literal (but do not mark + -- it as static since it is not!) + + -- Note: this entire circuit is redundant with respect to code in + -- Expand_Array_Aggregate that collapses others choices to positional + -- form, but there are two problems with that circuit: + + -- a) It is limited to very small cases due to ill-understood + -- interations with bootstrapping. That limit is removed by + -- use of the No_Implicit_Loops restriction. + + -- b) It erroneously ends up with the resulting expressions being + -- considered static when they are not. For example, the + -- following test should fail: + + -- pragma Restrictions (No_Implicit_Loops); + -- package NonSOthers4 is + -- B : constant String (1 .. 6) := (others => 'A'); + -- DH : constant String (1 .. 8) := B & "BB"; + -- X : Integer; + -- pragma Export (C, X, Link_Name => DH); + -- end; + + -- But it succeeds (DH looks static to pragma Export) + + -- To be sorted out! ??? + + if Present (Component_Associations (N)) then + declare + CA : constant Node_Id := First (Component_Associations (N)); + MX : constant := 80; + + begin + if Nkind (First (Choices (CA))) = N_Others_Choice + and then Nkind (Expression (CA)) = N_Character_Literal + and then No (Expressions (N)) + then + declare + T : constant Entity_Id := Etype (N); + X : constant Node_Id := First_Index (T); + EC : constant Node_Id := Expression (CA); + CV : constant Uint := Char_Literal_Value (EC); + CC : constant Int := UI_To_Int (CV); + + begin + if Nkind (X) = N_Range + and then Compile_Time_Known_Value (Low_Bound (X)) + and then Expr_Value (Low_Bound (X)) = 1 + and then Compile_Time_Known_Value (High_Bound (X)) + then + declare + Hi : constant Uint := Expr_Value (High_Bound (X)); + + begin + if Hi <= MX then + Start_String; + + for J in 1 .. UI_To_Int (Hi) loop + Store_String_Char (Char_Code (CC)); + end loop; + + Rewrite (N, + Make_String_Literal (Sloc (N), + Strval => End_String)); + + if CC >= Int (2 ** 16) then + Set_Has_Wide_Wide_Character (N); + elsif CC >= Int (2 ** 8) then + Set_Has_Wide_Character (N); + end if; + + Analyze_And_Resolve (N, T); + Set_Is_Static_Expression (N, False); + return; + end if; + end; + end if; + end; + end if; + end; + end if; + + -- Not that special case, so normal expansion of array aggregate + Expand_Array_Aggregate (N); end if; exception diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 54442db72b4..9e48afe8882 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -136,6 +136,10 @@ package body Exp_Attr is -- that takes two floating-point arguments. The function to be called -- is always the same as the attribute name. + procedure Expand_Loop_Entry_Attribute (Attr : Node_Id); + -- Handle the expansion of attribute 'Loop_Entry. As a result, the related + -- loop may be converted into a conditional block. See body for details. + procedure Expand_Pred_Succ (N : Node_Id); -- Handles expansion of Pred or Succ attributes for case of non-real -- operand with overflow checking required. @@ -635,10 +639,11 @@ package body Exp_Attr is -- by Expand_Fpt_Attribute procedure Expand_Fpt_Attribute_RR (N : Node_Id) is - E1 : constant Node_Id := First (Expressions (N)); + E1 : constant Node_Id := First (Expressions (N)); + E2 : constant Node_Id := Next (E1); Ftp : Entity_Id; Pkg : RE_Id; - E2 : constant Node_Id := Next (E1); + begin Find_Fat_Info (Etype (E1), Ftp, Pkg); Expand_Fpt_Attribute @@ -648,6 +653,388 @@ package body Exp_Attr is Unchecked_Convert_To (Ftp, Relocate_Node (E2)))); end Expand_Fpt_Attribute_RR; + --------------------------------- + -- Expand_Loop_Entry_Attribute -- + --------------------------------- + + procedure Expand_Loop_Entry_Attribute (Attr : Node_Id) is + procedure Build_Conditional_Block + (Loc : Source_Ptr; + Cond : Node_Id; + Loop_Stmt : Node_Id; + If_Stmt : out Node_Id; + Blk_Stmt : out Node_Id); + -- Create a block Blk_Stmt with an empty declarative list and a single + -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with + -- condition Cond. If_Stmt is Empty when there is no condition provided. + + function Is_Array_Iteration (N : Node_Id) return Boolean; + -- Determine whether loop statement N denotes an Ada 2012 iteration over + -- an array object. + + ----------------------------- + -- Build_Conditional_Block -- + ----------------------------- + + procedure Build_Conditional_Block + (Loc : Source_Ptr; + Cond : Node_Id; + Loop_Stmt : Node_Id; + If_Stmt : out Node_Id; + Blk_Stmt : out Node_Id) + is + begin + -- Do not reanalyze the original loop statement because it is simply + -- being relocated. + + Set_Analyzed (Loop_Stmt); + + Blk_Stmt := + Make_Block_Statement (Loc, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Loop_Stmt))); + + if Present (Cond) then + If_Stmt := + Make_If_Statement (Loc, + Condition => Cond, + Then_Statements => New_List (Blk_Stmt)); + else + If_Stmt := Empty; + end if; + end Build_Conditional_Block; + + ------------------------ + -- Is_Array_Iteration -- + ------------------------ + + function Is_Array_Iteration (N : Node_Id) return Boolean is + Stmt : constant Node_Id := Original_Node (N); + Iter : Node_Id; + + begin + if Nkind (Stmt) = N_Loop_Statement + and then Present (Iteration_Scheme (Stmt)) + and then Present (Iterator_Specification (Iteration_Scheme (Stmt))) + then + Iter := Iterator_Specification (Iteration_Scheme (Stmt)); + + return + Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter))); + end if; + + return False; + end Is_Array_Iteration; + + -- Local variables + + Exprs : constant List_Id := Expressions (Attr); + Pref : constant Node_Id := Prefix (Attr); + Typ : constant Entity_Id := Etype (Pref); + Blk : Node_Id; + Decls : List_Id; + Installed : Boolean; + Loc : Source_Ptr; + Loop_Id : Entity_Id; + Loop_Stmt : Node_Id; + Result : Node_Id; + Scheme : Node_Id; + Temp_Decl : Node_Id; + Temp_Id : Entity_Id; + + -- Start of processing for Expand_Loop_Entry_Attribute + + begin + -- Step 1: Find the related loop + + -- The loop label variant of attribute 'Loop_Entry already has all the + -- information in its expression. + + if Present (Exprs) then + Loop_Id := Entity (First (Exprs)); + Loop_Stmt := Label_Construct (Parent (Loop_Id)); + + -- Climb the parent chain to find the nearest enclosing loop. Skip all + -- internally generated loops for quantified expressions. + + else + Loop_Stmt := Attr; + while Present (Loop_Stmt) loop + if Nkind (Loop_Stmt) = N_Loop_Statement + and then Present (Identifier (Loop_Stmt)) + then + exit; + end if; + + Loop_Stmt := Parent (Loop_Stmt); + end loop; + + Loop_Id := Entity (Identifier (Loop_Stmt)); + end if; + + Loc := Sloc (Loop_Stmt); + + -- Step 2: Transform the loop + + -- The loop has already been transformed during the expansion of a prior + -- 'Loop_Entry attribute. Retrieve the declarative list of the block. + + if Has_Loop_Entry_Attributes (Loop_Id) then + + -- When the related loop name appears as the argument of attribute + -- Loop_Entry, the corresponding label construct is the generated + -- block statement. This is because the expander reuses the label. + + if Nkind (Loop_Stmt) = N_Block_Statement then + Decls := Declarations (Loop_Stmt); + + -- In all other cases, the loop must appear in the handled sequence + -- of statements of the generated block. + + else + pragma Assert + (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (Parent (Loop_Stmt))) = + N_Block_Statement); + + Decls := Declarations (Parent (Parent (Loop_Stmt))); + end if; + + Result := Empty; + + -- Transform the loop into a conditional block + + else + Set_Has_Loop_Entry_Attributes (Loop_Id); + Scheme := Iteration_Scheme (Loop_Stmt); + + -- Infinite loops are transformed into: + + -- declare + -- Temp1 : constant <type of Pref1> := <Pref1>; + -- . . . + -- TempN : constant <type of PrefN> := <PrefN>; + -- begin + -- loop + -- <original source statements with attribute rewrites> + -- end loop; + -- end; + + if No (Scheme) then + Build_Conditional_Block (Loc, + Cond => Empty, + Loop_Stmt => Relocate_Node (Loop_Stmt), + If_Stmt => Result, + Blk_Stmt => Blk); + + Result := Blk; + + -- While loops are transformed into: + + -- if <Condition> then + -- declare + -- Temp1 : constant <type of Pref1> := <Pref1>; + -- . . . + -- TempN : constant <type of PrefN> := <PrefN>; + -- begin + -- loop + -- <original source statements with attribute rewrites> + -- exit when not <Condition>; + -- end loop; + -- end; + -- end if; + + -- Note that loops over iterators and containers are already + -- converted into while loops. + + elsif Present (Condition (Scheme)) then + declare + Cond : constant Node_Id := Condition (Scheme); + + begin + -- Transform the original while loop into an infinite loop + -- where the last statement checks the negated condition. This + -- placement ensures that the condition will not be evaluated + -- twice on the first iteration. + + -- Generate: + -- exit when not <Cond>: + + Append_To (Statements (Loop_Stmt), + Make_Exit_Statement (Loc, + Condition => Make_Op_Not (Loc, New_Copy_Tree (Cond)))); + + Build_Conditional_Block (Loc, + Cond => Relocate_Node (Cond), + Loop_Stmt => Relocate_Node (Loop_Stmt), + If_Stmt => Result, + Blk_Stmt => Blk); + end; + + -- Ada 2012 iteration over an array is transformed into: + + -- if <Array_Nam>'Length (1) > 0 + -- and then <Array_Nam>'Length (N) > 0 + -- then + -- declare + -- Temp1 : constant <type of Pref1> := <Pref1>; + -- . . . + -- TempN : constant <type of PrefN> := <PrefN>; + -- begin + -- for X in ... loop -- multiple loops depending on dims + -- <original source statements with attribute rewrites> + -- end loop; + -- end; + -- end if; + + elsif Is_Array_Iteration (Loop_Stmt) then + declare + Array_Nam : constant Entity_Id := + Entity (Name (Iterator_Specification + (Iteration_Scheme (Original_Node (Loop_Stmt))))); + Num_Dims : constant Pos := + Number_Dimensions (Etype (Array_Nam)); + Cond : Node_Id := Empty; + Check : Node_Id; + + begin + -- Generate a check which determines whether all dimensions of + -- the array are non-null. + + for Dim in 1 .. Num_Dims loop + Check := + Make_Op_Gt (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Array_Nam, Loc), + Attribute_Name => Name_Length, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))), + Right_Opnd => + Make_Integer_Literal (Loc, 0)); + + if No (Cond) then + Cond := Check; + else + Cond := + Make_And_Then (Loc, + Left_Opnd => Cond, + Right_Opnd => Check); + end if; + end loop; + + Build_Conditional_Block (Loc, + Cond => Cond, + Loop_Stmt => Relocate_Node (Loop_Stmt), + If_Stmt => Result, + Blk_Stmt => Blk); + end; + + -- For loops are transformed into: + + -- if <Low> <= <High> then + -- declare + -- Temp1 : constant <type of Pref1> := <Pref1>; + -- . . . + -- TempN : constant <type of PrefN> := <PrefN>; + -- begin + -- for <Def_Id> in <Low> .. <High> loop + -- <original source statements with attribute rewrites> + -- end loop; + -- end; + -- end if; + + elsif Present (Loop_Parameter_Specification (Scheme)) then + declare + Loop_Spec : constant Node_Id := + Loop_Parameter_Specification (Scheme); + Cond : Node_Id; + Subt_Def : Node_Id; + + begin + Subt_Def := Discrete_Subtype_Definition (Loop_Spec); + + -- When the loop iterates over a subtype indication with a + -- range, use the low and high bounds of the subtype itself. + + if Nkind (Subt_Def) = N_Subtype_Indication then + Subt_Def := Scalar_Range (Etype (Subt_Def)); + end if; + + pragma Assert (Nkind (Subt_Def) = N_Range); + + -- Generate + -- Low <= High + + Cond := + Make_Op_Le (Loc, + Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)), + Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def))); + + Build_Conditional_Block (Loc, + Cond => Cond, + Loop_Stmt => Relocate_Node (Loop_Stmt), + If_Stmt => Result, + Blk_Stmt => Blk); + end; + end if; + + Decls := Declarations (Blk); + end if; + + -- Step 3: Create a constant to capture the value of the prefix at the + -- entry point into the loop. + + -- Generate: + -- Temp : constant <type of Pref> := <Pref>; + + Temp_Id := Make_Temporary (Loc, 'P'); + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Constant_Present => True, + Object_Definition => New_Reference_To (Typ, Loc), + Expression => Relocate_Node (Pref)); + Append_To (Decls, Temp_Decl); + + -- Step 4: Analyze all bits + + Rewrite (Attr, New_Reference_To (Temp_Id, Loc)); + + Installed := Current_Scope = Scope (Loop_Id); + + -- Depending on the pracement of attribute 'Loop_Entry relative to the + -- associated loop, ensure the proper visibility for analysis. + + if not Installed then + Push_Scope (Scope (Loop_Id)); + end if; + + -- The analysis of the conditional block takes care of the constant + -- declaration. + + if Present (Result) then + Rewrite (Loop_Stmt, Result); + Analyze (Loop_Stmt); + + -- The conditional block was analyzed when a previous 'Loop_Entry was + -- expanded. There is no point in reanalyzing the block, simply analyze + -- the declaration of the constant. + + else + Analyze (Temp_Decl); + end if; + + Analyze (Attr); + + if not Installed then + Pop_Scope; + end if; + end Expand_Loop_Entry_Attribute; + ---------------------------------- -- Expand_N_Attribute_Reference -- ---------------------------------- @@ -1060,14 +1447,44 @@ package body Exp_Attr is -- match in cases of expander-generated calls (e.g. init -- procs). + -- The code may be nested in a block, so find enclosing + -- scope that is a protected operation. + else - Formal := - First_Entity - (Protected_Body_Subprogram (Current_Scope)); - Rewrite (N, - Unchecked_Convert_To (Typ, - New_Occurrence_Of (Formal, Loc))); - Set_Etype (N, Typ); + declare + Subp : Entity_Id; + + begin + Subp := Current_Scope; + while Ekind_In (Subp, E_Loop, E_Block) loop + Subp := Scope (Subp); + end loop; + + Formal := + First_Entity + (Protected_Body_Subprogram (Subp)); + + -- For a protected subprogram the _Object parameter + -- is the protected record, so we create an access + -- to it. The _Object parameter of an entry is an + -- address. + + if Ekind (Subp) = E_Entry then + Rewrite (N, + Unchecked_Convert_To (Typ, + New_Occurrence_Of (Formal, Loc))); + Set_Etype (N, Typ); + + else + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unrestricted_Access, + Prefix => + New_Occurrence_Of (Formal, Loc)))); + Analyze_And_Resolve (N); + end if; + end; end if; -- The expression must appear in a default expression, @@ -1761,7 +2178,7 @@ package body Exp_Attr is or else (Nkind (Obj) = N_Explicit_Dereference and then - not Effectively_Has_Constrained_Partial_View + not Object_Type_Has_Constrained_Partial_View (Typ => Base_Type (Etype (Obj)), Scop => Current_Scope))); end if; @@ -1885,7 +2302,7 @@ package body Exp_Attr is or else (Nkind (Pref) = N_Explicit_Dereference and then - not Effectively_Has_Constrained_Partial_View + not Object_Type_Has_Constrained_Partial_View (Typ => Base_Type (Ptyp), Scop => Current_Scope)) or else Is_Constrained (Underlying_Type (Ptyp)) @@ -2324,20 +2741,20 @@ package body Exp_Attr is CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin - -- In Ada 2005 (or later) if we have the standard nondefault - -- bit order, then we return the original value as given in - -- the component clause (RM 2005 13.5.2(3/2)). + -- In Ada 2005 (or later) if we have the non-default bit order, then + -- we return the original value as given in the component clause + -- (RM 2005 13.5.2(3/2)). if Present (Component_Clause (CE)) and then Ada_Version >= Ada_2005 - and then not Reverse_Bit_Order (Scope (CE)) + and then Reverse_Bit_Order (Scope (CE)) then Rewrite (N, Make_Integer_Literal (Loc, Intval => Expr_Value (First_Bit (Component_Clause (CE))))); Analyze_And_Resolve (N, Typ); - -- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order), + -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order), -- rewrite with normalized value if we know it statically. elsif Known_Static_Component_Bit_Offset (CE) then @@ -2904,20 +3321,20 @@ package body Exp_Attr is CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin - -- In Ada 2005 (or later) if we have the standard nondefault - -- bit order, then we return the original value as given in - -- the component clause (RM 2005 13.5.2(4/2)). + -- In Ada 2005 (or later) if we have the non-default bit order, then + -- we return the original value as given in the component clause + -- (RM 2005 13.5.2(3/2)). if Present (Component_Clause (CE)) and then Ada_Version >= Ada_2005 - and then not Reverse_Bit_Order (Scope (CE)) + and then Reverse_Bit_Order (Scope (CE)) then Rewrite (N, Make_Integer_Literal (Loc, Intval => Expr_Value (Last_Bit (Component_Clause (CE))))); Analyze_And_Resolve (N, Typ); - -- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order), + -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order), -- rewrite with normalized value if we know it statically. elsif Known_Static_Component_Bit_Offset (CE) @@ -3108,11 +3525,12 @@ package body Exp_Attr is end if; end Length; - -- The expansion of this attribute is carried out when the target loop - -- is processed. See Expand_Loop_Entry_Attributes for details. + -- Attribute Loop_Entry is replaced with a reference to a constant value + -- which captures the prefix at the entry point of the related loop. The + -- loop itself may be transformed into a conditional block. when Attribute_Loop_Entry => - null; + Expand_Loop_Entry_Attribute (N); ------------- -- Machine -- @@ -3825,18 +4243,18 @@ package body Exp_Attr is begin if Present (Component_Clause (CE)) then - -- In Ada 2005 (or later) if we have the standard nondefault - -- bit order, then we return the original value as given in - -- the component clause (RM 2005 13.5.2(2/2)). + -- In Ada 2005 (or later) if we have the non-default bit order, + -- then we return the original value as given in the component + -- clause (RM 2005 13.5.2(2/2)). if Ada_Version >= Ada_2005 - and then not Reverse_Bit_Order (Scope (CE)) + and then Reverse_Bit_Order (Scope (CE)) then Rewrite (N, Make_Integer_Literal (Loc, Intval => Expr_Value (Position (Component_Clause (CE))))); - -- Otherwise (Ada 83 or 95, or reverse bit order specified in + -- Otherwise (Ada 83 or 95, or default bit order specified in -- later Ada version), return the normalized value. else diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb index 076783f7113..d8a7022e504 100644 --- a/gcc/ada/exp_cg.adb +++ b/gcc/ada/exp_cg.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- -- @@ -261,12 +261,10 @@ package body Exp_CG is return True; elsif not Has_Fully_Qualified_Name (E) then - if Chars (E) = Name_uSize - or else Chars (E) = Name_uAlignment + if Nam_In (Chars (E), Name_uSize, Name_uAlignment, Name_uAssign) or else (Chars (E) = Name_Op_Eq - and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) - or else Chars (E) = Name_uAssign + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else Is_Predefined_Interface_Primitive (E) then return True; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 64a53e36cda..2f2506918e8 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.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- -- @@ -1402,10 +1402,15 @@ package body Exp_Ch11 is -- Add clean up actions if required - if Nkind (Parent (N)) /= N_Package_Body - and then Nkind (Parent (N)) /= N_Accept_Statement - and then Nkind (Parent (N)) /= N_Extended_Return_Statement + if not Nkind_In (Parent (N), N_Package_Body, + N_Accept_Statement, + N_Extended_Return_Statement) and then not Delay_Cleanups (Current_Scope) + + -- No cleanup action needed in thunks associated with interfaces + -- because they only displace the pointer to the object. + + and then not Is_Thunk (Current_Scope) then Expand_Cleanup_Actions (Parent (N)); else @@ -1431,6 +1436,62 @@ package body Exp_Ch11 is Possible_Local_Raise (N, Standard_Constraint_Error); end Expand_N_Raise_Constraint_Error; + ------------------------------- + -- Expand_N_Raise_Expression -- + ------------------------------- + + procedure Expand_N_Raise_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + RCE : Node_Id; + + begin + Possible_Local_Raise (N, 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 + -- the node to: + + -- do + -- raise X [with string] + -- in + -- raise Constraint_Error; + + -- unless the flag Convert_To_Return_False is set, in which case + -- the transformation is to: + + -- do + -- return False; + -- in + -- raise Constraint_Error; + + -- The raise constraint error can never be executed. It is just a dummy + -- node that can be labeled with an arbitrary type. + + RCE := Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise); + Set_Etype (RCE, Typ); + + if Convert_To_Return_False (N) then + Rewrite (N, + Make_Expression_With_Actions (Loc, + Actions => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc))), + Expression => RCE)); + + else + Rewrite (N, + Make_Expression_With_Actions (Loc, + Actions => New_List ( + Make_Raise_Statement (Loc, + Name => Name (N), + Expression => Expression (N))), + Expression => RCE)); + end if; + + Analyze_And_Resolve (N, Typ); + end Expand_N_Raise_Expression; + ---------------------------------- -- Expand_N_Raise_Program_Error -- ---------------------------------- diff --git a/gcc/ada/exp_ch11.ads b/gcc/ada/exp_ch11.ads index d715a27c4e7..5f2f6b5f0a8 100644 --- a/gcc/ada/exp_ch11.ads +++ b/gcc/ada/exp_ch11.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- -- @@ -31,6 +31,7 @@ package Exp_Ch11 is procedure Expand_N_Exception_Declaration (N : Node_Id); procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id); procedure Expand_N_Raise_Constraint_Error (N : Node_Id); + procedure Expand_N_Raise_Expression (N : Node_Id); procedure Expand_N_Raise_Program_Error (N : Node_Id); procedure Expand_N_Raise_Statement (N : Node_Id); procedure Expand_N_Raise_Storage_Error (N : Node_Id); @@ -95,4 +96,5 @@ package Exp_Ch11 is -- handler (and restriction No_Exception_Propagation is set), or if there -- is a local handler marking that it has a local raise. E is the entity -- of the corresponding exception. + end Exp_Ch11; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 141e144ab5b..295d4ade56a 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.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- -- @@ -184,8 +184,19 @@ package body Exp_Ch13 is Expression => Convert_To (RTE (RE_Size_Type), Expression (N))); - Insert_After - (Parent (Storage_Size_Variable (Entity (N))), Assign); + -- If the clause is not generated by an aspect, insert + -- the assignment here. Freezing rules ensure that this + -- is safe, or clause will have been rejected already. + + if Is_List_Member (N) then + Insert_After (N, Assign); + + -- Otherwise, insert assignment after task declaration. + + else + Insert_After + (Parent (Storage_Size_Variable (Entity (N))), Assign); + end if; Analyze (Assign); end; @@ -552,6 +563,8 @@ package body Exp_Ch13 is Force_Validity_Checks := Save_Force; end; + -- All other freezing actions + else Analyze (Decl, Suppress => All_Checks); end if; diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index b93f832441c..af35113b7b9 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.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- -- @@ -162,12 +162,11 @@ package body Exp_Ch2 is -- lvalue references in the arguments. and then not (Nkind (Parent (N)) = N_Attribute_Reference - and then - (Attribute_Name (Parent (N)) = Name_Asm_Input - or else - Attribute_Name (Parent (N)) = Name_Asm_Output - or else - Prefix (Parent (N)) = N)) + and then + (Nam_In (Attribute_Name (Parent (N)), + Name_Asm_Input, + Name_Asm_Output) + or else Prefix (Parent (N)) = N)) then -- Case of Current_Value is a compile time known value diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 15d5de0bd20..1e500367625 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.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- -- @@ -229,12 +229,6 @@ package body Exp_Ch3 is function Is_User_Defined_Equality (Prim : Node_Id) return Boolean; -- Returns true if Prim is a user defined equality function - function Is_Variable_Size_Array (E : Entity_Id) return Boolean; - -- Returns true if E has variable size components - - function Is_Variable_Size_Record (E : Entity_Id) return Boolean; - -- Returns true if E has variable size components - function Make_Eq_Body (Typ : Entity_Id; Eq_Name : Name_Id) return Node_Id; @@ -1835,9 +1829,8 @@ package body Exp_Ch3 is -- traversing the expression. ??? if Kind = N_Attribute_Reference - and then (Attribute_Name (N) = Name_Unchecked_Access - or else - Attribute_Name (N) = Name_Unrestricted_Access) + and then Nam_In (Attribute_Name (N), Name_Unchecked_Access, + Name_Unrestricted_Access) and then Is_Entity_Name (Prefix (N)) and then Is_Type (Entity (Prefix (N))) and then Entity (Prefix (N)) = Rec_Type @@ -2786,8 +2779,8 @@ package body Exp_Ch3 is -- Loop through components, skipping pragmas, in 2 steps. The first -- step deals with regular components. The second step deals with - -- components have per object constraints, and no explicit initia- - -- lization. + -- components that have per object constraints and no explicit + -- initialization. Has_POC := False; @@ -2805,9 +2798,7 @@ package body Exp_Ch3 is -- Leave any processing of per-object constrained component for -- the second pass. - if Has_Access_Constraint (Id) - and then No (Expression (Decl)) - then + if Has_Access_Constraint (Id) and then No (Expression (Decl)) then Has_POC := True; -- Regular component cases @@ -2841,9 +2832,9 @@ package body Exp_Ch3 is elsif Ekind (Scope (Id)) = E_Record_Type and then Present (Corresponding_Concurrent_Type (Scope (Id))) - and then (Chars (Id) = Name_uCPU or else - Chars (Id) = Name_uDispatching_Domain or else - Chars (Id) = Name_uPriority) + and then Nam_In (Chars (Id), Name_uCPU, + Name_uDispatching_Domain, + Name_uPriority) then declare Exp : Node_Id; @@ -4190,7 +4181,7 @@ package body Exp_Ch3 is Eq_Op := Empty; while Present (Prim) loop if Chars (Node (Prim)) = Name_Op_Eq - and then Comes_From_Source (Node (Prim)) + and then Comes_From_Source (Node (Prim)) -- Don't we also need to check formal types and return type as in -- User_Defined_Eq above??? @@ -4825,10 +4816,145 @@ package body Exp_Ch3 is -- which case the init proc call must be inserted only after the bodies -- of the shared variable procedures have been seen. + function Build_Equivalent_Aggregate return Boolean; + -- If the object has a constrained discriminated type and no initial + -- value, it may be possible to build an equivalent aggregate instead, + -- and prevent an actual call to the initialization procedure. + function Rewrite_As_Renaming return Boolean; -- Indicate whether to rewrite a declaration with initialization into an -- object renaming declaration (see below). + -------------------------------- + -- Build_Equivalent_Aggregate -- + -------------------------------- + + function Build_Equivalent_Aggregate return Boolean is + Aggr : Node_Id; + Comp : Entity_Id; + Discr : Elmt_Id; + Full_Type : Entity_Id; + + begin + Full_Type := Typ; + + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Full_Type := Full_View (Typ); + end if; + + -- Only perform this transformation if Elaboration_Code is forbidden + -- or undesirable, and if this is a global entity of a constrained + -- record type. + + -- If Initialize_Scalars might be active this transformation cannot + -- be performed either, because it will lead to different semantics + -- or because elaboration code will in fact be created. + + if Ekind (Full_Type) /= E_Record_Subtype + or else not Has_Discriminants (Full_Type) + or else not Is_Constrained (Full_Type) + or else Is_Controlled (Full_Type) + or else Is_Limited_Type (Full_Type) + or else not Restriction_Active (No_Initialize_Scalars) + then + return False; + end if; + + if Ekind (Current_Scope) = E_Package + and then + (Restriction_Active (No_Elaboration_Code) + or else Is_Preelaborated (Current_Scope)) + then + + -- Building a static aggregate is possible if the discriminants + -- have static values and the other components have static + -- defaults or none. + + Discr := First_Elmt (Discriminant_Constraint (Full_Type)); + while Present (Discr) loop + if not Is_OK_Static_Expression (Node (Discr)) then + return False; + end if; + + Next_Elmt (Discr); + end loop; + + -- Check that initialized components are OK, and that non- + -- initialized components do not require a call to their own + -- initialization procedure. + + Comp := First_Component (Full_Type); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Present (Expression (Parent (Comp))) + and then + not Is_OK_Static_Expression (Expression (Parent (Comp))) + then + return False; + + elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then + return False; + + end if; + + Next_Component (Comp); + end loop; + + -- Everything is static, assemble the aggregate, discriminant + -- values first. + + Aggr := + Make_Aggregate (Loc, + Expressions => New_List, + Component_Associations => New_List); + + Discr := First_Elmt (Discriminant_Constraint (Full_Type)); + while Present (Discr) loop + Append_To (Expressions (Aggr), New_Copy (Node (Discr))); + Next_Elmt (Discr); + end loop; + + -- Now collect values of initialized components. + + Comp := First_Component (Full_Type); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Present (Expression (Parent (Comp))) + then + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List (New_Occurrence_Of (Comp, Loc)), + Expression => New_Copy_Tree + (Expression (Parent (Comp))))); + end if; + + Next_Component (Comp); + end loop; + + -- Finally, box-initialize remaining components. + + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List (Make_Others_Choice (Loc)), + Expression => Empty)); + Set_Box_Present (Last (Component_Associations (Aggr))); + Set_Expression (N, Aggr); + + if Typ /= Full_Type then + Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type))); + Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr)); + Analyze_And_Resolve (Aggr, Typ); + else + Analyze_And_Resolve (Aggr, Full_Type); + end if; + + return True; + + else + return False; + end if; + end Build_Equivalent_Aggregate; + ------------------------- -- Rewrite_As_Renaming -- ------------------------- @@ -4909,10 +5035,14 @@ package body Exp_Ch3 is -- with invariants, and invariant checks are enabled, then insert an -- invariant check after the object declaration. Note that it is OK -- to clobber the object with an invalid value since if the exception - -- is raised, then the object will go out of scope. + -- is raised, then the object will go out of scope. In the case where + -- an array object is initialized with an aggregate, the expression + -- is removed. Check flag Has_Init_Expression to avoid generating a + -- junk invariant check. - if Has_Invariants (Typ) - and then Present (Invariant_Procedure (Typ)) + if Has_Invariants (Base_Typ) + and then Present (Invariant_Procedure (Base_Typ)) + and then not Has_Init_Expression (N) then Insert_After (N, Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); @@ -4926,18 +5056,14 @@ package body Exp_Ch3 is -- Initialize call as it is required but one for each ancestor of -- its type. This processing is suppressed if No_Initialization set. - if not Needs_Finalization (Typ) - or else No_Initialization (N) - then + if not Needs_Finalization (Typ) or else No_Initialization (N) then null; - elsif not Abort_Allowed - or else not Comes_From_Source (N) - then + elsif not Abort_Allowed or else not Comes_From_Source (N) then Insert_Action_After (Init_After, Make_Init_Call (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), - Typ => Base_Type (Typ))); + Typ => Base_Typ)); -- Abort allowed @@ -4960,7 +5086,7 @@ package body Exp_Ch3 is L : constant List_Id := New_List ( Make_Init_Call (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), - Typ => Base_Type (Typ))); + Typ => Base_Typ)); Blk : constant Node_Id := Make_Block_Statement (Loc, @@ -5033,6 +5159,14 @@ package body Exp_Ch3 is (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope)); return; + -- If type has discriminants, try to build equivalent aggregate + -- using discriminant values from the declaration. This + -- is a useful optimization, in particular if restriction + -- No_Elaboration_Code is active. + + elsif Build_Equivalent_Aggregate then + return; + else Initialization_Warning (Id_Ref); @@ -5424,7 +5558,7 @@ package body Exp_Ch3 is Insert_Action_After (Init_After, Make_Adjust_Call ( Obj_Ref => New_Reference_To (Def_Id, Loc), - Typ => Base_Type (Typ))); + Typ => Base_Typ)); end if; -- For tagged types, when an init value is given, the tag has to @@ -5997,10 +6131,10 @@ package body Exp_Ch3 is elsif CodePeer_Mode then return; - -- Do not create TSS routine Finalize_Address when compiling in Alfa + -- Do not create TSS routine Finalize_Address when compiling in SPARK -- mode because it is not necessary and results in useless expansion. - elsif Alfa_Mode then + elsif SPARK_Mode then return; end if; @@ -6749,9 +6883,9 @@ package body Exp_Ch3 is -- 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 Alfa mode since it is not needed. + -- Finalize_Address in SPARK mode since it is not needed. - if not Alfa_Mode then + if not SPARK_Mode then Make_Finalize_Address_Body (Def_Id); end if; @@ -7675,7 +7809,7 @@ package body Exp_Ch3 is if not Has_Invariants (Typ) then Set_Has_Invariants (Typ); - Set_Has_Invariants (Proc_Id); + Set_Is_Invariant_Procedure (Proc_Id); Set_Invariant_Procedure (Typ, Proc_Id); Insert_After (N, Proc); Analyze (Proc); @@ -8171,69 +8305,6 @@ package body Exp_Ch3 is and then Base_Type (Etype (Prim)) = Standard_Boolean; end Is_User_Defined_Equality; - ---------------------------- - -- Is_Variable_Size_Array -- - ---------------------------- - - function Is_Variable_Size_Array (E : Entity_Id) return Boolean is - Idx : Node_Id; - - begin - pragma Assert (Is_Array_Type (E)); - - -- Check if some index is initialized with a non-constant value - - Idx := First_Index (E); - while Present (Idx) loop - if Nkind (Idx) = N_Range then - if not Is_Constant_Bound (Low_Bound (Idx)) - or else not Is_Constant_Bound (High_Bound (Idx)) - then - return True; - end if; - end if; - - Idx := Next_Index (Idx); - end loop; - - return False; - end Is_Variable_Size_Array; - - ----------------------------- - -- Is_Variable_Size_Record -- - ----------------------------- - - function Is_Variable_Size_Record (E : Entity_Id) return Boolean is - Comp : Entity_Id; - Comp_Typ : Entity_Id; - - begin - pragma Assert (Is_Record_Type (E)); - - Comp := First_Entity (E); - while Present (Comp) loop - Comp_Typ := Etype (Comp); - - -- Recursive call if the record type has discriminants - - if Is_Record_Type (Comp_Typ) - and then Has_Discriminants (Comp_Typ) - and then Is_Variable_Size_Record (Comp_Typ) - then - return True; - - elsif Is_Array_Type (Comp_Typ) - and then Is_Variable_Size_Array (Comp_Typ) - then - return True; - end if; - - Next_Entity (Comp); - end loop; - - return False; - end Is_Variable_Size_Record; - ---------------------------------------- -- Make_Controlling_Function_Wrappers -- ---------------------------------------- diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index d43366812ec..de767fcaa6b 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.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- -- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index f8d37a5530f..70dfce97e1d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -355,6 +355,7 @@ package body Exp_Ch4 is if Nkind (Op1) = N_Op_Not then Arg1 := Right_Opnd (Op1); Arg2 := Right_Opnd (Op2); + if Kind = N_Op_And then Proc_Name := RTE (RE_Vector_Nor); elsif Kind = N_Op_Or then @@ -601,9 +602,8 @@ package body Exp_Ch4 is Dtyp := Available_View (Designated_Type (PtrT)); Etyp := Etype (Expression (Orig_Node)); - if Is_Class_Wide_Type (Dtyp) - and then Is_Interface (Dtyp) - then + if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then + -- If the type of the allocator expression is not an interface type -- we can generate code to reference the record component containing -- the pointer to the secondary dispatch table. @@ -641,7 +641,7 @@ package body Exp_Ch4 is -- generate a run-time call to displace "this" to reference the -- component containing the pointer to the secondary dispatch table -- or else raise Constraint_Error if the actual object does not - -- implement the target interface. This case corresponds with the + -- implement the target interface. This case corresponds to the -- following example: -- function Op (Obj : Iface_1'Class) return access Iface_2'Class is @@ -842,7 +842,7 @@ package body Exp_Ch4 is -- if statement instead of the regular Program_Error circuitry. Insert_Action (N, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Cond, Then_Statements => Stmts)); end if; @@ -1204,9 +1204,8 @@ package body Exp_Ch4 is Insert_Action (N, Tag_Assign); end if; - if Needs_Finalization (DesigT) - and then Needs_Finalization (T) - then + if Needs_Finalization (DesigT) and then Needs_Finalization (T) then + -- Generate an Adjust call if the object will be moved. In Ada -- 2005, the object may be inherently limited, in which case -- there is no Adjust procedure, and the object is built in @@ -1220,17 +1219,17 @@ package body Exp_Ch4 is and then not Is_Immutably_Limited_Type (T) then Insert_Action (N, - Make_Adjust_Call ( - Obj_Ref => - -- An unchecked conversion is needed in the classwide - -- case because the designated type can be an ancestor - -- of the subtype mark of the allocator. + -- An unchecked conversion is needed in the classwide case + -- because the designated type can be an ancestor of the + -- subtype mark of the allocator. - Unchecked_Convert_To (T, - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Temp, Loc))), - Typ => T)); + Make_Adjust_Call + (Obj_Ref => + Unchecked_Convert_To (T, + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc))), + Typ => T)); end if; -- Generate: @@ -1241,14 +1240,14 @@ package body Exp_Ch4 is -- * .NET/JVM - these targets do not support address arithmetic -- and unchecked conversion, key elements of Finalize_Address. - -- * Alfa mode - the call is useless and results in unwanted + -- * 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 Alfa_Mode + and then not SPARK_Mode and then not CodePeer_Mode and then Present (Finalization_Master (PtrT)) and then Present (Temp_Decl) @@ -1315,9 +1314,7 @@ package body Exp_Ch4 is Rewrite (N, New_Reference_To (Temp, Loc)); Analyze_And_Resolve (N, PtrT); - elsif Is_Access_Type (T) - and then Can_Never_Be_Null (T) - then + elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then Install_Null_Excluding_Check (Exp); elsif Is_Access_Type (DesigT) @@ -1870,9 +1867,9 @@ package body Exp_Ch4 is X := First_Index (T); while Present (X) loop - if Denotes_Discriminant (Type_Low_Bound (Etype (X))) - or else - Denotes_Discriminant (Type_High_Bound (Etype (X))) + if Denotes_Discriminant (Type_Low_Bound (Etype (X))) + or else + Denotes_Discriminant (Type_High_Bound (Etype (X))) then T := Base_Type (T); exit; @@ -1894,8 +1891,7 @@ package body Exp_Ch4 is Index : Node_Id) return Node_Id is Need_Separate_Indexes : constant Boolean := - Ltyp /= Rtyp - or else not Is_Constrained (Ltyp); + Ltyp /= Rtyp or else not Is_Constrained (Ltyp); -- If the index types are identical, and we are working with -- constrained types, then we can use the same index for both -- of the arrays. @@ -2572,11 +2568,14 @@ package body Exp_Ch4 is Full_Type := Typ; end if; - -- Defense against malformed private types with no completion the error - -- will be diagnosed later by check_completion + -- If the private type has no completion the context may be the + -- expansion of a composite equality for a composite type with some + -- still incomplete components. The expression will not be analyzed + -- until the enclosing type is completed, at which point this will be + -- properly expanded, unless there is a bona fide completion error. if No (Full_Type) then - return New_Reference_To (Standard_False, Loc); + return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); end if; Full_Type := Base_Type (Full_Type); @@ -2701,8 +2700,8 @@ package body Exp_Ch4 is -- discriminant(s). if Nkind (Lhs) = N_Selected_Component - and then Has_Per_Object_Constraint ( - Entity (Selector_Name (Lhs))) + and then Has_Per_Object_Constraint + (Entity (Selector_Name (Lhs))) then Lhs_Discr_Val := Make_Selected_Component (Loc, @@ -3233,7 +3232,6 @@ package body Exp_Ch4 is Prefix => Duplicate_Subexpr (Opnd, Name_Req => True), Attribute_Name => Name_First); - Set_Parent (Opnd_Low_Bound (NN), Opnd); -- Capture last operand bounds if result could be null @@ -3244,7 +3242,6 @@ package body Exp_Ch4 is Prefix => Duplicate_Subexpr (Opnd, Name_Req => True), Attribute_Name => Name_First)); - Set_Parent (Last_Opnd_Low_Bound, Opnd); Last_Opnd_High_Bound := Convert_To (Ityp, @@ -3252,7 +3249,6 @@ package body Exp_Ch4 is Prefix => Duplicate_Subexpr (Opnd, Name_Req => True), Attribute_Name => Name_Last)); - Set_Parent (Last_Opnd_High_Bound, Opnd); end if; -- Capture length of operand in entity @@ -3339,9 +3335,7 @@ package body Exp_Ch4 is -- converted to an array, and the easiest way of doing that is to go -- through the normal general circuit. - if NN = 1 - and then Base_Type (Etype (Operands (1))) /= Ctyp - then + if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then Result := Operands (1); goto Done; end if; @@ -3966,7 +3960,7 @@ package body Exp_Ch4 is Name => New_Occurrence_Of (Nnn, Loc), Expression => Relocate_Node (Lop)), - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Op_Not (Loc, Right_Opnd => @@ -4091,14 +4085,9 @@ package body Exp_Ch4 is ------------------------ procedure Expand_N_Allocator (N : Node_Id) is - PtrT : constant Entity_Id := Etype (N); - Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT)); - Etyp : constant Entity_Id := Etype (Expression (N)); - Loc : constant Source_Ptr := Sloc (N); - Desig : Entity_Id; - Nod : Node_Id; - Pool : Entity_Id; - Temp : Entity_Id; + Etyp : constant Entity_Id := Etype (Expression (N)); + Loc : constant Source_Ptr := Sloc (N); + PtrT : constant Entity_Id := Etype (N); procedure Rewrite_Coextension (N : Node_Id); -- Static coextensions have the same lifetime as the entity they @@ -4163,6 +4152,10 @@ package body Exp_Ch4 is -- are too large, and which in the absence of a check results in -- undetected chaos ??? + -- Note in particular that this is a pessimistic estimate in the + -- case of packed array types, where an array element might occupy + -- just a fraction of a storage element??? + declare Len : Node_Id; Res : Node_Id; @@ -4196,6 +4189,15 @@ package body Exp_Ch4 is end; end Size_In_Storage_Elements; + -- Local variables + + Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT)); + Desig : Entity_Id; + Nod : Node_Id; + Pool : Entity_Id; + Rel_Typ : Entity_Id; + Temp : Entity_Id; + -- Start of processing for Expand_N_Allocator begin @@ -4213,26 +4215,55 @@ package body Exp_Ch4 is -- Expand_Allocator_Expression inherit the proper type attributes. if (Ekind (PtrT) = E_Anonymous_Access_Type - or else - (Is_Itype (PtrT) and then No (Finalization_Master (PtrT)))) + or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT)))) and then Needs_Finalization (Dtyp) then + -- Detect the allocation of an anonymous controlled object where the + -- type of the context is named. For example: + + -- procedure Proc (Ptr : Named_Access_Typ); + -- Proc (new Designated_Typ); + + -- Regardless of the anonymous-to-named access type conversion, the + -- lifetime of the object must be associated with the named access + -- type. Use the finalization-related attributes of this type. + + if Nkind_In (Parent (N), N_Type_Conversion, + N_Unchecked_Type_Conversion) + and then Ekind_In (Etype (Parent (N)), E_Access_Subtype, + E_Access_Type, + E_General_Access_Type) + then + Rel_Typ := Etype (Parent (N)); + else + Rel_Typ := Empty; + end if; + -- Anonymous access-to-controlled types allocate on the global pool. -- Do not set this attribute on .NET/JVM since those targets do not -- support pools. if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then - Set_Associated_Storage_Pool - (PtrT, Get_Global_Pool_For_Access_Type (PtrT)); + if Present (Rel_Typ) then + Set_Associated_Storage_Pool (PtrT, + Associated_Storage_Pool (Rel_Typ)); + else + Set_Associated_Storage_Pool (PtrT, + Get_Global_Pool_For_Access_Type (PtrT)); + end if; 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 Alfa mode because it is useless. Note that the master is + -- out in SPARK mode because it is useless. Note that the master is -- updated when analysis changes current units. - if not Alfa_Mode then - Set_Finalization_Master (PtrT, Current_Anonymous_Master); + 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; end if; end if; @@ -4546,9 +4577,19 @@ package body Exp_Ch4 is -- access type did not get expanded. Salvage it now. if not Restriction_Active (No_Task_Hierarchy) then - pragma Assert (Present (Parent (Base_Type (PtrT)))); - Expand_N_Full_Type_Declaration - (Parent (Base_Type (PtrT))); + if Present (Parent (Base_Type (PtrT))) then + Expand_N_Full_Type_Declaration + (Parent (Base_Type (PtrT))); + + -- The only other possibility is an itype. For this + -- case, the master must exist in the context. This is + -- the case when the allocator initializes an access + -- component in an init-proc. + + else + pragma Assert (Is_Itype (PtrT)); + Build_Master_Renaming (PtrT, N); + end if; end if; end if; @@ -4645,9 +4686,8 @@ package body Exp_Ch4 is (First_Discriminant (Typ))) and then (Ada_Version < Ada_2005 or else not - Effectively_Has_Constrained_Partial_View - (Typ => Typ, - Scop => Current_Scope)) + Object_Type_Has_Constrained_Partial_View + (Typ, Current_Scope)) then Typ := Build_Default_Subtype (Typ, N); Set_Expression (N, New_Reference_To (Typ, Loc)); @@ -4760,15 +4800,13 @@ package body Exp_Ch4 is -- Do not generate this call in the following cases: -- - -- * Alfa mode - the call is useless and results in + -- * SPARK mode - the call is useless and results in -- unwanted expansion. -- -- * CodePeer mode - TSS primitive Finalize_Address is -- not created in this mode. - elsif not Alfa_Mode - and then not CodePeer_Mode - then + elsif not (SPARK_Mode or CodePeer_Mode) then Insert_Action (N, Make_Set_Finalize_Address_Call (Loc => Loc, @@ -4788,9 +4826,7 @@ package body Exp_Ch4 is -- object that has been rewritten as a reference, we displace "this" -- to reference properly its secondary dispatch table. - if Nkind (N) = N_Identifier - and then Is_Interface (Dtyp) - then + if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then Displace_Allocator_Pointer (N); end if; @@ -5013,30 +5049,9 @@ package body Exp_Ch4 is ---------------------------- function Find_Enclosing_Context return Node_Id is - function Is_Body_Or_Unit (N : Node_Id) return Boolean; - -- Determine whether N denotes a body or unit declaration - - --------------------- - -- Is_Body_Or_Unit -- - --------------------- - - function Is_Body_Or_Unit (N : Node_Id) return Boolean is - begin - return Nkind_In (N, N_Entry_Body, - N_Package_Body, - N_Package_Declaration, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body); - end Is_Body_Or_Unit; - - -- Local variables - Par : Node_Id; Top : Node_Id; - -- Start of processing for Find_Enclosing_Context - begin -- The expression_with_actions is in a case/if expression and -- the lifetime of any temporary controlled object is therefore @@ -5054,7 +5069,7 @@ package body Exp_Ch4 is -- Prevent the search from going too far - elsif Is_Body_Or_Unit (Par) then + elsif Is_Body_Or_Package_Declaration (Par) then exit; end if; @@ -5070,16 +5085,16 @@ package body Exp_Ch4 is while Present (Par) loop if Is_List_Member (Par) and then - not Nkind_In (Par, N_Component_Association, - N_Discriminant_Association, - N_Parameter_Association, - N_Pragma_Argument_Association) + not Nkind_In (Par, N_Component_Association, + N_Discriminant_Association, + N_Parameter_Association, + N_Pragma_Argument_Association) then return Par; -- Prevent the search from going too far - elsif Is_Body_Or_Unit (Par) then + elsif Is_Body_Or_Package_Declaration (Par) then exit; end if; @@ -5138,15 +5153,22 @@ package body Exp_Ch4 is -- return ... and then Ctrl_Func_Call ...; + -- Yet another case: a formal in a procedure call statement: + + -- Proc (... and then Ctrl_Func_Call ...); + while Present (Par) loop if Nkind_In (Par, N_Assignment_Statement, N_Object_Declaration, N_Pragma, + N_Procedure_Call_Statement, N_Simple_Return_Statement) then return Par; - elsif Is_Body_Or_Unit (Par) then + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then exit; end if; @@ -5167,6 +5189,7 @@ package body Exp_Ch4 is Obj_Typ : constant Node_Id := Etype (Obj_Id); Desig_Typ : Entity_Id; Expr : Node_Id; + Fin_Call : Node_Id; Ptr_Id : Entity_Id; Temp_Id : Entity_Id; @@ -5182,6 +5205,8 @@ package body Exp_Ch4 is Desig_Typ := Obj_Typ; end if; + Desig_Typ := Base_Type (Desig_Typ); + -- Generate: -- Ann : access [all] <Desig_Typ>; @@ -5217,8 +5242,14 @@ package body Exp_Ch4 is -- Step 3: Hook the transient object to the temporary + -- 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 points to an existing object. + if Is_Access_Type (Obj_Typ) then - Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc)); + Expr := + Unchecked_Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc)); else Expr := Make_Attribute_Reference (Loc, @@ -5252,8 +5283,8 @@ package body Exp_Ch4 is -- the return statement as this would make it unreachable. if Nkind (Context) /= N_Simple_Return_Statement then - Insert_Action_After (Context, - Make_If_Statement (Loc, + Fin_Call := + Make_Implicit_If_Statement (Obj_Decl, Condition => Make_Op_Ne (Loc, Left_Opnd => New_Reference_To (Temp_Id, Loc), @@ -5268,7 +5299,17 @@ package body Exp_Ch4 is Make_Assignment_Statement (Loc, Name => New_Reference_To (Temp_Id, Loc), - Expression => Make_Null (Loc))))); + Expression => Make_Null (Loc)))); + + -- Use the Actions list of logical operators when inserting the + -- finalization call. This ensures that all transient objects + -- are finalized after the operators are evaluated. + + if Nkind_In (Context, N_And_Then, N_Or_Else) then + Insert_Action (Context, Fin_Call); + else + Insert_Action_After (Context, Fin_Call); + end if; end if; end Process_Transient_Object; @@ -5428,20 +5469,11 @@ package body Exp_Ch4 is Remove (Expr); if Present (Actions) then - - -- If we are not allowed to use Expression_With_Actions, just skip - -- the optimization, it is not critical for correctness. - - if not Use_Expression_With_Actions then - goto Skip_Optimization; - end if; - Rewrite (N, Make_Expression_With_Actions (Loc, Expression => Relocate_Node (Expr), Actions => Actions)); Analyze_And_Resolve (N, Typ); - else Rewrite (N, Relocate_Node (Expr)); end if; @@ -5453,8 +5485,6 @@ package body Exp_Ch4 is return; end if; - <<Skip_Optimization>> - -- If the type is limited or unconstrained, we expand as follows to -- avoid any possibility of improper copies. @@ -5549,73 +5579,28 @@ package body Exp_Ch4 is elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then - -- We have two approaches to handling this. If we are allowed to use - -- N_Expression_With_Actions, then we can just wrap the actions into - -- the appropriate expression. - - if Use_Expression_With_Actions then - if Present (Then_Actions (N)) then - Rewrite (Thenx, - Make_Expression_With_Actions (Sloc (Thenx), - Actions => Then_Actions (N), - Expression => Relocate_Node (Thenx))); - Set_Then_Actions (N, No_List); - Analyze_And_Resolve (Thenx, Typ); - end if; - - if Present (Else_Actions (N)) then - Rewrite (Elsex, - Make_Expression_With_Actions (Sloc (Elsex), - Actions => Else_Actions (N), - Expression => Relocate_Node (Elsex))); - Set_Else_Actions (N, No_List); - Analyze_And_Resolve (Elsex, Typ); - end if; - - return; - - -- if we can't use N_Expression_With_Actions nodes, then we insert - -- the following sequence of actions (using Insert_Actions): - - -- Cnn : typ; - -- if cond then - -- <<then actions>> - -- Cnn := then-expr; - -- else - -- <<else actions>> - -- Cnn := else-expr - -- end if; + -- We now wrap the actions into the appropriate expression - -- and replace the if expression by a reference to Cnn - - else - Cnn := Make_Temporary (Loc, 'C', N); - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Cnn, - Object_Definition => New_Occurrence_Of (Typ, Loc)); - - New_If := - Make_Implicit_If_Statement (N, - Condition => Relocate_Node (Cond), - - Then_Statements => New_List ( - Make_Assignment_Statement (Sloc (Thenx), - Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), - Expression => Relocate_Node (Thenx))), - - Else_Statements => New_List ( - Make_Assignment_Statement (Sloc (Elsex), - Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), - Expression => Relocate_Node (Elsex)))); - - Set_Assignment_OK (Name (First (Then_Statements (New_If)))); - Set_Assignment_OK (Name (First (Else_Statements (New_If)))); + if Present (Then_Actions (N)) then + Rewrite (Thenx, + Make_Expression_With_Actions (Sloc (Thenx), + Actions => Then_Actions (N), + Expression => Relocate_Node (Thenx))); + Set_Then_Actions (N, No_List); + Analyze_And_Resolve (Thenx, Typ); + end if; - New_N := New_Occurrence_Of (Cnn, Loc); + if Present (Else_Actions (N)) then + Rewrite (Elsex, + Make_Expression_With_Actions (Sloc (Elsex), + Actions => Else_Actions (N), + Expression => Relocate_Node (Elsex))); + Set_Else_Actions (N, No_List); + Analyze_And_Resolve (Elsex, Typ); end if; + return; + -- If no actions then no expansion needed, gigi will handle it using -- the same approach as a C conditional expression. @@ -5629,9 +5614,7 @@ package body Exp_Ch4 is -- change it to the SLOC of the expression which, after expansion, will -- correspond to what is being evaluated. - if Present (Parent (N)) - and then Nkind (Parent (N)) = N_If_Statement - then + if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then Set_Sloc (New_If, Sloc (Parent (N))); Set_Sloc (Parent (N), Loc); end if; @@ -6310,7 +6293,7 @@ package body Exp_Ch4 is Rewrite (N, Make_And_Then (Loc, Left_Opnd => Relocate_Node (N), - Right_Opnd => Make_Predicate_Call (Rtyp, Lop))); + Right_Opnd => Make_Predicate_Call (Rtyp, Lop, Mem => True))); -- Analyze new expression, mark left operand as analyzed to -- avoid infinite recursion adding predicate calls. Similarly, @@ -6458,11 +6441,9 @@ package body Exp_Ch4 is return; elsif Nkind (Parnt) = N_Attribute_Reference - and then (Attribute_Name (Parnt) = Name_Address - or else - Attribute_Name (Parnt) = Name_Bit - or else - Attribute_Name (Parnt) = Name_Size) + and then Nam_In (Attribute_Name (Parnt), Name_Address, + Name_Bit, + Name_Size) and then Prefix (Parnt) = Child then return; @@ -6493,7 +6474,7 @@ package body Exp_Ch4 is return; elsif Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component) - and then Prefix (Parnt) = Child + and then Prefix (Parnt) = Child then null; @@ -6605,8 +6586,8 @@ package body Exp_Ch4 is -- Deal with software overflow checking if not Backend_Overflow_Checks_On_Target - and then Is_Signed_Integer_Type (Etype (N)) - and then Do_Overflow_Check (N) + and then Is_Signed_Integer_Type (Etype (N)) + and then Do_Overflow_Check (N) then -- The only case to worry about is when the argument is equal to the -- largest negative number, so what we do is to insert the check: @@ -6671,9 +6652,7 @@ package body Exp_Ch4 is -- Arithmetic overflow checks for signed integer/fixed point types - if Is_Signed_Integer_Type (Typ) - or else Is_Fixed_Point_Type (Typ) - then + if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then Apply_Arithmetic_Overflow_Check (N); return; @@ -6748,7 +6727,6 @@ package body Exp_Ch4 is -- Now Cnode is the deepest concatenation, and its parents are the -- concatenation nodes above, so now we process bottom up, doing the - -- operations. We gather a string that is as long as possible up to five -- operands. -- The outer loop runs more than once if more than one concatenation @@ -6824,9 +6802,7 @@ package body Exp_Ch4 is -- We cannot do this transformation in configurable run time mode if we -- have 64-bit integers and long shifts are not available. - and then - (Esize (Ltyp) <= 32 - or else Support_Long_Shifts_On_Target) + and then (Esize (Ltyp) <= 32 or else Support_Long_Shifts_On_Target) then Rewrite (N, Make_Op_Shift_Right (Loc, @@ -6863,8 +6839,7 @@ package body Exp_Ch4 is -- Other cases of division of fixed-point operands. Again we exclude the -- case where Treat_Fixed_As_Integer is set. - elsif (Is_Fixed_Point_Type (Ltyp) or else - Is_Fixed_Point_Type (Rtyp)) + elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp)) and then not Treat_Fixed_As_Integer (N) then if Is_Integer_Type (Typ) then @@ -6877,17 +6852,13 @@ package body Exp_Ch4 is -- Mixed-mode operations can appear in a non-static universal context, -- in which case the integer argument must be converted explicitly. - elsif Typ = Universal_Real - and then Is_Integer_Type (Rtyp) - then + elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then Rewrite (Ropnd, Convert_To (Universal_Real, Relocate_Node (Ropnd))); Analyze_And_Resolve (Ropnd, Universal_Real); - elsif Typ = Universal_Real - and then Is_Integer_Type (Ltyp) - then + elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then Rewrite (Lopnd, Convert_To (Universal_Real, Relocate_Node (Lopnd))); @@ -7020,8 +6991,8 @@ package body Exp_Ch4 is -- Lhs of equality if Nkind (Lhs) = N_Selected_Component - and then Has_Per_Object_Constraint - (Entity (Selector_Name (Lhs))) + and then + Has_Per_Object_Constraint (Entity (Selector_Name (Lhs))) then -- Enclosing record is an Unchecked_Union, use formal A @@ -7061,8 +7032,8 @@ package body Exp_Ch4 is -- Rhs of equality if Nkind (Rhs) = N_Selected_Component - and then Has_Per_Object_Constraint - (Entity (Selector_Name (Rhs))) + and then + Has_Per_Object_Constraint (Entity (Selector_Name (Rhs))) then if Is_Unchecked_Union (Scope (Entity (Selector_Name (Rhs)))) @@ -7540,7 +7511,7 @@ package body Exp_Ch4 is -- CodePeer and GNATprove want to see the unexpanded N_Op_Expon node - if CodePeer_Mode or Alfa_Mode then + if CodePeer_Mode or SPARK_Mode then return; end if; @@ -7707,10 +7678,10 @@ package body Exp_Ch4 is and then not Do_Overflow_Check (P)) or else (Nkind (P) = N_Op_Divide - and then Is_Integer_Type (Etype (L)) - and then Is_Unsigned_Type (Etype (L)) - and then R = N - and then not Do_Overflow_Check (P)) + and then Is_Integer_Type (Etype (L)) + and then Is_Unsigned_Type (Etype (L)) + and then R = N + and then not Do_Overflow_Check (P)) then Set_Is_Power_Of_2_For_Shift (N); return; @@ -7791,9 +7762,9 @@ package body Exp_Ch4 is elsif Rtyp = Base_Type (Standard_Long_Long_Integer) or else (Rtyp = Base_Type (Standard_Long_Integer) - and then - Esize (Standard_Long_Integer) > Esize (Standard_Integer)) - or else (Rtyp = Universal_Integer) + and then + Esize (Standard_Long_Integer) > Esize (Standard_Integer)) + or else Rtyp = Universal_Integer then Etyp := Standard_Long_Long_Integer; @@ -8152,10 +8123,7 @@ package body Exp_Ch4 is -- (the operation now corresponds to the hardware remainder), and it -- does not seem likely that it could be harmful. - if LOK and then Llo >= 0 - and then - ROK and then Rlo >= 0 - then + if LOK and then Llo >= 0 and then ROK and then Rlo >= 0 then Rewrite (N, Make_Op_Rem (Sloc (N), Left_Opnd => Left_Opnd (N), @@ -8223,8 +8191,7 @@ package body Exp_Ch4 is (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left))))); if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) - and then - ((not LOK) or else (Llo = LLB)) + and then ((not LOK) or else (Llo = LLB)) then Rewrite (N, Make_If_Expression (Loc, @@ -8255,12 +8222,9 @@ package body Exp_Ch4 is Rop : constant Node_Id := Right_Opnd (N); Lp2 : constant Boolean := - Nkind (Lop) = N_Op_Expon - and then Is_Power_Of_2_For_Shift (Lop); - + Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop); Rp2 : constant Boolean := - Nkind (Rop) = N_Op_Expon - and then Is_Power_Of_2_For_Shift (Rop); + Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop); Ltyp : constant Entity_Id := Etype (Lop); Rtyp : constant Entity_Id := Etype (Rop); @@ -8419,18 +8383,12 @@ package body Exp_Ch4 is -- Mixed-mode operations can appear in a non-static universal context, -- in which case the integer argument must be converted explicitly. - elsif Typ = Universal_Real - and then Is_Integer_Type (Rtyp) - then + elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop))); - Analyze_And_Resolve (Rop, Universal_Real); - elsif Typ = Universal_Real - and then Is_Integer_Type (Ltyp) - then + elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop))); - Analyze_And_Resolve (Lop, Universal_Real); -- Non-fixed point cases, check software overflow checking required @@ -8992,10 +8950,7 @@ package body Exp_Ch4 is -- Arithmetic overflow checks for signed integer/fixed point types - if Is_Signed_Integer_Type (Typ) - or else - Is_Fixed_Point_Type (Typ) - then + if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then Apply_Arithmetic_Overflow_Check (N); -- VAX floating-point types case @@ -9048,7 +9003,7 @@ package body Exp_Ch4 is begin -- Do validity check if validity checking operands - if Validity_Checks_On and then Validity_Check_Operands then + if Validity_Checks_On and Validity_Check_Operands then Ensure_Valid (Operand); end if; @@ -9182,6 +9137,7 @@ package body Exp_Ch4 is Loc : constant Source_Ptr := Sloc (N); Par : constant Node_Id := Parent (N); P : constant Node_Id := Prefix (N); + S : constant Node_Id := Selector_Name (N); Ptyp : Entity_Id := Underlying_Type (Etype (P)); Disc : Entity_Id; New_N : Node_Id; @@ -9257,18 +9213,27 @@ package body Exp_Ch4 is -- Deal with discriminant check required if Do_Discriminant_Check (N) then + if Present (Discriminant_Checking_Func + (Original_Record_Component (Entity (S)))) + then + -- Present the discriminant checking function to the backend, so + -- that it can inline the call to the function. - -- Present the discriminant checking function to the backend, so that - -- it can inline the call to the function. + Add_Inlined_Body + (Discriminant_Checking_Func + (Original_Record_Component (Entity (S)))); - Add_Inlined_Body - (Discriminant_Checking_Func - (Original_Record_Component (Entity (Selector_Name (N))))); + -- Now reset the flag and generate the call - -- Now reset the flag and generate the call + Set_Do_Discriminant_Check (N, False); + Generate_Discriminant_Check (N); - Set_Do_Discriminant_Check (N, False); - Generate_Discriminant_Check (N); + -- In the case of Unchecked_Union, no discriminant checking is + -- actually performed. + + else + Set_Do_Discriminant_Check (N, False); + end if; end if; -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place @@ -9326,7 +9291,7 @@ package body Exp_Ch4 is -- contexts where we do not want the value anyway. elsif (Nkind (Par) = N_Attribute_Reference - and then Prefix (Par) = N) + and then Prefix (Par) = N) or else Is_Renamed_Object (N) then null; @@ -9395,11 +9360,11 @@ package body Exp_Ch4 is -- fact incorrect. elsif Is_Entity_Name (Dval) - and then Nkind (Parent (Entity (Dval))) = - N_Object_Declaration - and then Present (Expression (Parent (Entity (Dval)))) and then - not Is_Static_Expression + Nkind (Parent (Entity (Dval))) = N_Object_Declaration + and then Present (Expression (Parent (Entity (Dval)))) + and then not + Is_Static_Expression (Expression (Parent (Entity (Dval)))) then exit Discr_Loop; @@ -9668,7 +9633,7 @@ package body Exp_Ch4 is elsif Nkind (Parent (N)) = N_Assignment_Statement or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement - and then Parent (N) = Name (Parent (Parent (N)))) + and then Parent (N) = Name (Parent (Parent (N)))) then return; @@ -9901,7 +9866,7 @@ package body Exp_Ch4 is -- range as the base type (or is the base type). if Range_Checks_Suppressed (Target_Type) - or else (Lo = Type_Low_Bound (Btyp) + or else (Lo = Type_Low_Bound (Btyp) and then Hi = Type_High_Bound (Btyp)) then @@ -10037,6 +10002,20 @@ package body Exp_Ch4 is -- Start of processing for Expand_N_Type_Conversion begin + -- First remove check marks put by the semantic analysis on the type + -- conversion between array types. We need these checks, and they will + -- be generated by this expansion routine, but we do not depend on these + -- flags being set, and since we do intend to expand the checks in the + -- front end, we don't want them on the tree passed to the back end. + + if Is_Array_Type (Target_Type) then + if Is_Constrained (Target_Type) then + Set_Do_Length_Check (N, False); + else + Set_Do_Range_Check (Operand, False); + end if; + end if; + -- Nothing at all to do if conversion is to the identical type so remove -- the conversion completely, it is useless, except that it may carry -- an Assignment_OK attribute, which must be propagated to the operand. @@ -10165,9 +10144,7 @@ package body Exp_Ch4 is -- Do validity check if validity checking operands - if Validity_Checks_On - and then Validity_Check_Operands - then + if Validity_Checks_On and Validity_Check_Operands then Ensure_Valid (Operand); end if; @@ -10338,7 +10315,7 @@ package body Exp_Ch4 is -- Ada 2005 (AI-251): Handle interface type conversion if Is_Interface (Actual_Op_Typ) then - Expand_Interface_Conversion (N, Is_Static => False); + Expand_Interface_Conversion (N); goto Done; end if; @@ -10865,53 +10842,60 @@ package body Exp_Ch4 is First_Time : Boolean := True; - function Suitable_Element (C : Entity_Id) return Entity_Id; - -- Return the first field to compare beginning with C, skipping the - -- inherited components. + function Element_To_Compare (C : Entity_Id) return Entity_Id; + -- Return the next discriminant or component to compare, starting with + -- C, skipping inherited components. - ---------------------- - -- Suitable_Element -- - ---------------------- + ------------------------ + -- Element_To_Compare -- + ------------------------ + + function Element_To_Compare (C : Entity_Id) return Entity_Id is + Comp : Entity_Id; - function Suitable_Element (C : Entity_Id) return Entity_Id is begin - if No (C) then - return Empty; + Comp := C; + loop + -- Exit loop when the next element to be compared is found, or + -- there is no more such element. - elsif Ekind (C) /= E_Discriminant - and then Ekind (C) /= E_Component - then - return Suitable_Element (Next_Entity (C)); + exit when No (Comp); - -- Below test for C /= Original_Record_Component (C) is dubious - -- if Typ is a constrained record subtype??? + exit when Ekind_In (Comp, E_Discriminant, E_Component) + and then not ( - elsif Is_Tagged_Type (Typ) - and then C /= Original_Record_Component (C) - then - return Suitable_Element (Next_Entity (C)); + -- Skip inherited components - elsif Chars (C) = Name_uTag then - return Suitable_Element (Next_Entity (C)); + -- Note: for a tagged type, we always generate the "=" primitive + -- for the base type (not on the first subtype), so the test for + -- Comp /= Original_Record_Component (Comp) is True for + -- inherited components only. - -- The .NET/JVM version of type Root_Controlled contains two fields - -- which should not be considered part of the object. To achieve - -- proper equiality between two controlled objects on .NET/JVM, skip - -- field _parent whenever it is of type Root_Controlled. + (Is_Tagged_Type (Typ) + and then Comp /= Original_Record_Component (Comp)) - elsif Chars (C) = Name_uParent - and then VM_Target /= No_VM - and then Etype (C) = RTE (RE_Root_Controlled) - then - return Suitable_Element (Next_Entity (C)); + -- Skip _Tag - elsif Is_Interface (Etype (C)) then - return Suitable_Element (Next_Entity (C)); + or else Chars (Comp) = Name_uTag - else - return C; - end if; - end Suitable_Element; + -- The .NET/JVM version of type Root_Controlled contains two + -- fields which should not be considered part of the object. To + -- achieve proper equiality between two controlled objects on + -- .NET/JVM, skip _Parent whenever it has type Root_Controlled. + + or else (Chars (Comp) = Name_uParent + and then VM_Target /= No_VM + and then Etype (Comp) = RTE (RE_Root_Controlled)) + + -- Skip interface elements (secondary tags???) + + or else Is_Interface (Etype (Comp))); + + Next_Entity (Comp); + end loop; + + return Comp; + end Element_To_Compare; -- Start of processing for Expand_Record_Equality @@ -10927,7 +10911,7 @@ package body Exp_Ch4 is -- and then Lhs.Cmpn = Rhs.Cmpn Result := New_Reference_To (Standard_True, Loc); - C := Suitable_Element (First_Entity (Typ)); + C := Element_To_Compare (First_Entity (Typ)); while Present (C) loop declare New_Lhs : Node_Id; @@ -10971,7 +10955,7 @@ package body Exp_Ch4 is end if; end; - C := Suitable_Element (Next_Entity (C)); + C := Element_To_Compare (Next_Entity (C)); end loop; return Result; @@ -11058,29 +11042,6 @@ package body Exp_Ch4 is Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value); -- If Left = Shortcut_Value then Right need not be evaluated - function Make_Test_Expr (Opnd : Node_Id) return Node_Id; - -- For Opnd a boolean expression, return a Boolean expression equivalent - -- to Opnd /= Shortcut_Value. - - -------------------- - -- Make_Test_Expr -- - -------------------- - - function Make_Test_Expr (Opnd : Node_Id) return Node_Id is - begin - if Shortcut_Value then - return Make_Op_Not (Sloc (Opnd), Opnd); - else - return Opnd; - end if; - end Make_Test_Expr; - - Op_Var : Entity_Id; - -- Entity for a temporary variable holding the value of the operator, - -- used for expansion in the case where actions are present. - - -- Start of processing for Expand_Short_Circuit_Operator - begin -- Deal with non-standard booleans @@ -11132,77 +11093,19 @@ package body Exp_Ch4 is -- must only be executed if the right operand of the short circuit is -- executed and not otherwise. - -- the temporary variable C. - if Present (Actions (N)) then Actlist := Actions (N); - -- The old approach is to expand: - - -- left AND THEN right + -- We now use an Expression_With_Actions node for the right operand + -- of the short-circuit form. Note that this solves the traceability + -- problems for coverage analysis. - -- into - - -- C : Boolean := False; - -- IF left THEN - -- Actions; - -- IF right THEN - -- C := True; - -- END IF; - -- END IF; - - -- and finally rewrite the operator into a reference to C. Similarly - -- for left OR ELSE right, with negated values. Note that this - -- rewrite causes some difficulties for coverage analysis because - -- of the introduction of the new variable C, which obscures the - -- structure of the test. - - -- We use this "old approach" if use of N_Expression_With_Actions - -- is False (see description in Opt of when this is or is not set). - - if not Use_Expression_With_Actions then - Op_Var := Make_Temporary (Loc, 'C', Related_Node => N); - - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => - Op_Var, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc), - Expression => - New_Occurrence_Of (Shortcut_Ent, Loc))); - - Append_To (Actlist, - Make_Implicit_If_Statement (Right, - Condition => Make_Test_Expr (Right), - Then_Statements => New_List ( - Make_Assignment_Statement (LocR, - Name => New_Occurrence_Of (Op_Var, LocR), - Expression => - New_Occurrence_Of - (Boolean_Literals (not Shortcut_Value), LocR))))); - - Insert_Action (N, - Make_Implicit_If_Statement (Left, - Condition => Make_Test_Expr (Left), - Then_Statements => Actlist)); - - Rewrite (N, New_Occurrence_Of (Op_Var, Loc)); - Analyze_And_Resolve (N, Standard_Boolean); - - -- The new approach, activated for now by the use of debug flag - -- -gnatd.X is to use the new Expression_With_Actions node for the - -- right operand of the short-circuit form. This should solve the - -- traceability problems for coverage analysis. - - else - Rewrite (Right, - Make_Expression_With_Actions (LocR, - Expression => Relocate_Node (Right), - Actions => Actlist)); - Set_Actions (N, No_List); - Analyze_And_Resolve (Right, Standard_Boolean); - end if; + Rewrite (Right, + Make_Expression_With_Actions (LocR, + Expression => Relocate_Node (Right), + Actions => Actlist)); + Set_Actions (N, No_List); + Analyze_And_Resolve (Right, Standard_Boolean); Adjust_Result_Type (N, Typ); return; @@ -11516,7 +11419,7 @@ package body Exp_Ch4 is Set_Has_Dereference_Action (Deref); Stmt := - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Function_Call (Loc, Name => @@ -11583,7 +11486,7 @@ package body Exp_Ch4 is and then (Root_Operand_Type = Base_Type (Standard_Short_Integer) - or else + or else Root_Operand_Type = Base_Type (Standard_Short_Short_Integer)) -- Test for interesting operation, which includes addition, @@ -12711,8 +12614,8 @@ package body Exp_Ch4 is if not Is_Class_Wide_Type (Left_Type) and then (Is_Ancestor (Etype (Right_Type), Left_Type, Use_Full_View => True) - or else (Is_Interface (Etype (Right_Type)) - and then Interface_Present_In_Ancestor + or else (Is_Interface (Etype (Right_Type)) + and then Interface_Present_In_Ancestor (Typ => Left_Type, Iface => Etype (Right_Type)))) then diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 243279b00fc..95e649a13e9 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -28,7 +28,6 @@ with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; -with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; @@ -111,10 +110,6 @@ package body Exp_Ch5 is procedure Expand_Iterator_Loop_Over_Array (N : Node_Id); -- Expand loop over arrays that uses the form "for X of C" - procedure Expand_Loop_Entry_Attributes (N : Node_Id); - -- Given a loop statement subject to at least one Loop_Entry attribute, - -- expand both the loop and all related Loop_Entry references. - procedure Expand_Predicated_Loop (N : Node_Id); -- Expand for loop over predicated subtype @@ -1527,347 +1522,6 @@ package body Exp_Ch5 is end; end Expand_Assign_Record; - ---------------------------------- - -- Expand_Loop_Entry_Attributes -- - ---------------------------------- - - procedure Expand_Loop_Entry_Attributes (N : Node_Id) is - procedure Build_Conditional_Block - (Loc : Source_Ptr; - Cond : Node_Id; - Stmt : Node_Id; - If_Stmt : out Node_Id; - Blk_Stmt : out Node_Id); - -- Create a block Blk_Stmt with an empty declarative list and a single - -- statement Stmt. The block is encased in an if statement If_Stmt with - -- condition Cond. If_Stmt is Empty when there is no condition provided. - - function Is_Array_Iteration (N : Node_Id) return Boolean; - -- Determine whether loop statement N denotes an Ada 2012 iteration over - -- an array object. - - ----------------------------- - -- Build_Conditional_Block -- - ----------------------------- - - procedure Build_Conditional_Block - (Loc : Source_Ptr; - Cond : Node_Id; - Stmt : Node_Id; - If_Stmt : out Node_Id; - Blk_Stmt : out Node_Id) - is - begin - Blk_Stmt := - Make_Block_Statement (Loc, - Declarations => New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Stmt))); - - if Present (Cond) then - If_Stmt := - Make_If_Statement (Loc, - Condition => Cond, - Then_Statements => New_List (Blk_Stmt)); - else - If_Stmt := Empty; - end if; - end Build_Conditional_Block; - - ------------------------ - -- Is_Array_Iteration -- - ------------------------ - - function Is_Array_Iteration (N : Node_Id) return Boolean is - Stmt : constant Node_Id := Original_Node (N); - Iter : Node_Id; - - begin - if Nkind (Stmt) = N_Loop_Statement - and then Present (Iteration_Scheme (Stmt)) - and then Present (Iterator_Specification (Iteration_Scheme (Stmt))) - then - Iter := Iterator_Specification (Iteration_Scheme (Stmt)); - - return - Of_Present (Iter) - and then Is_Array_Type (Etype (Name (Iter))); - end if; - - return False; - end Is_Array_Iteration; - - -- Local variables - - Loc : constant Source_Ptr := Sloc (N); - Loop_Id : constant Entity_Id := Identifier (N); - Scheme : constant Node_Id := Iteration_Scheme (N); - Blk : Node_Id; - LE : Node_Id; - LE_Elmt : Elmt_Id; - Result : Node_Id; - Temp : Entity_Id; - Typ : Entity_Id; - - -- Start of processing for Expand_Loop_Entry_Attributes - - begin - -- The loop will never execute after it has been expanded, no point in - -- processing it. - - if Is_Null_Loop (N) then - return; - - -- A loop without an identifier cannot be referenced in 'Loop_Entry - - elsif No (Loop_Id) then - return; - - -- The loop is not subject to 'Loop_Entry - - elsif No (Loop_Entry_Attributes (Entity (Loop_Id))) then - return; - - -- Step 1: Loop transformations - - -- While loops are transformed into: - - -- if <Condition> then - -- declare - -- Temp1 : constant <type of Pref1> := <Pref1>; - -- . . . - -- TempN : constant <type of PrefN> := <PrefN>; - -- begin - -- loop - -- <original source statements with attribute rewrites> - -- exit when not <Condition>; - -- end loop; - -- end; - -- end if; - - -- Note that loops over iterators and containers are already converted - -- into while loops. - - elsif Present (Condition (Scheme)) then - declare - Cond : constant Node_Id := Condition (Scheme); - - begin - -- Transform the original while loop into an infinite loop where - -- the last statement checks the negated condition. This placement - -- ensures that the condition will not be evaluated twice on the - -- first iteration. - - -- Generate: - -- exit when not <Cond>: - - Append_To (Statements (N), - Make_Exit_Statement (Loc, - Condition => Make_Op_Not (Loc, New_Copy_Tree (Cond)))); - - Build_Conditional_Block (Loc, - Cond => Relocate_Node (Cond), - Stmt => Relocate_Node (N), - If_Stmt => Result, - Blk_Stmt => Blk); - end; - - -- Ada 2012 iteration over an array is transformed into: - - -- if <Array_Nam>'Length (1) > 0 - -- and then <Array_Nam>'Length (N) > 0 - -- then - -- declare - -- Temp1 : constant <type of Pref1> := <Pref1>; - -- . . . - -- TempN : constant <type of PrefN> := <PrefN>; - -- begin - -- for X in ... loop -- multiple loops depending on dims - -- <original source statements with attribute rewrites> - -- end loop; - -- end; - -- end if; - - elsif Is_Array_Iteration (N) then - declare - Array_Nam : constant Entity_Id := - Entity (Name (Iterator_Specification - (Iteration_Scheme (Original_Node (N))))); - Num_Dims : constant Pos := - Number_Dimensions (Etype (Array_Nam)); - Cond : Node_Id := Empty; - Check : Node_Id; - Top_Loop : Node_Id; - - begin - -- Generate a check which determines whether all dimensions of - -- the array are non-null. - - for Dim in 1 .. Num_Dims loop - Check := - Make_Op_Gt (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Array_Nam, Loc), - Attribute_Name => Name_Length, - Expressions => New_List ( - Make_Integer_Literal (Loc, Dim))), - Right_Opnd => - Make_Integer_Literal (Loc, 0)); - - if No (Cond) then - Cond := Check; - else - Cond := - Make_And_Then (Loc, - Left_Opnd => Cond, - Right_Opnd => Check); - end if; - end loop; - - Top_Loop := Relocate_Node (N); - Set_Analyzed (Top_Loop); - - Build_Conditional_Block (Loc, - Cond => Cond, - Stmt => Top_Loop, - If_Stmt => Result, - Blk_Stmt => Blk); - end; - - -- For loops are transformed into: - - -- if <Low> <= <High> then - -- declare - -- Temp1 : constant <type of Pref1> := <Pref1>; - -- . . . - -- TempN : constant <type of PrefN> := <PrefN>; - -- begin - -- for <Def_Id> in <Low> .. <High> loop - -- <original source statements with attribute rewrites> - -- end loop; - -- end; - -- end if; - - elsif Present (Loop_Parameter_Specification (Scheme)) then - declare - Loop_Spec : constant Node_Id := - Loop_Parameter_Specification (Scheme); - Cond : Node_Id; - Subt_Def : Node_Id; - - begin - Subt_Def := Discrete_Subtype_Definition (Loop_Spec); - - -- When the loop iterates over a subtype indication with a range, - -- use the low and high bounds of the subtype itself. - - if Nkind (Subt_Def) = N_Subtype_Indication then - Subt_Def := Scalar_Range (Etype (Subt_Def)); - end if; - - pragma Assert (Nkind (Subt_Def) = N_Range); - - -- Generate - -- Low <= High - - Cond := - Make_Op_Le (Loc, - Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)), - Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def))); - - Build_Conditional_Block (Loc, - Cond => Cond, - Stmt => Relocate_Node (N), - If_Stmt => Result, - Blk_Stmt => Blk); - end; - - -- Infinite loops are transformed into: - - -- declare - -- Temp1 : constant <type of Pref1> := <Pref1>; - -- . . . - -- TempN : constant <type of PrefN> := <PrefN>; - -- begin - -- loop - -- <original source statements with attribute rewrites> - -- end loop; - -- end; - - else - Build_Conditional_Block (Loc, - Cond => Empty, - Stmt => Relocate_Node (N), - If_Stmt => Result, - Blk_Stmt => Blk); - - Result := Blk; - end if; - - -- Step 2: Loop_Entry attribute transformations - - -- At this point the various loops have been augmented to contain a - -- block. Populate the declarative list of the block with constants - -- which store the value of their relative prefixes at the point of - -- entry in the loop. - - LE_Elmt := First_Elmt (Loop_Entry_Attributes (Entity (Loop_Id))); - while Present (LE_Elmt) loop - LE := Node (LE_Elmt); - Typ := Etype (Prefix (LE)); - - -- Declare a constant to capture the value of the previx of each - -- Loop_Entry attribute. - - -- Generate: - -- Temp : constant <type of Pref> := <Pref>; - - Temp := Make_Temporary (Loc, 'P'); - - Append_To (Declarations (Blk), - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Constant_Present => True, - Object_Definition => New_Reference_To (Typ, Loc), - Expression => Relocate_Node (Prefix (LE)))); - - -- Perform minor decoration as this information will be needed for - -- the creation of index checks (if applicable). - - Set_Ekind (Temp, E_Constant); - Set_Etype (Temp, Typ); - - -- Replace the original attribute with a reference to the constant - - Rewrite (LE, New_Reference_To (Temp, Loc)); - Set_Etype (LE, Typ); - - -- Analysis converts attribute references of the following form - - -- Prefix'Loop_Entry (Expr) - -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN) - - -- into indexed components for error detection purposes. Generate - -- index checks now that 'Loop_Entry has been properly expanded. - - if Nkind (Parent (LE)) = N_Indexed_Component then - Generate_Index_Checks (Parent (LE)); - end if; - - Next_Elmt (LE_Elmt); - end loop; - - -- Destroy the list of Loop_Entry attributes to prevent the infinite - -- expansion when analyzing and expanding the newly generated loops. - - Set_Loop_Entry_Attributes (Entity (Loop_Id), No_Elist); - - Rewrite (N, Result); - Analyze (N); - end Expand_Loop_Entry_Attributes; - ----------------------------------- -- Expand_N_Assignment_Statement -- ----------------------------------- @@ -3377,7 +3031,7 @@ package body Exp_Ch5 is declare Default_Iter : constant Entity_Id := Entity - (Find_Aspect + (Find_Value_Of_Aspect (Etype (Container), Aspect_Default_Iterator)); @@ -3777,8 +3431,9 @@ package body Exp_Ch5 is -- 7. Insert polling call if required procedure Expand_N_Loop_Statement (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Isc : constant Node_Id := Iteration_Scheme (N); + Loc : constant Source_Ptr := Sloc (N); + Scheme : constant Node_Id := Iteration_Scheme (N); + Stmt : Node_Id; begin -- Delete null loop @@ -3788,12 +3443,10 @@ package body Exp_Ch5 is return; end if; - Process_Statements_For_Controlled_Objects (N); - -- Deal with condition for C/Fortran Boolean - if Present (Isc) then - Adjust_Condition (Condition (Isc)); + if Present (Scheme) then + Adjust_Condition (Condition (Scheme)); end if; -- Generate polling call @@ -3804,7 +3457,7 @@ package body Exp_Ch5 is -- Nothing more to do for plain loop with no iteration scheme - if No (Isc) then + if No (Scheme) then null; -- Case of for loop (Loop_Parameter_Specification present) @@ -3813,9 +3466,10 @@ package body Exp_Ch5 is -- range bounds here, since they were frozen with constant declarations -- and it is during that process that the validity checking is done. - elsif Present (Loop_Parameter_Specification (Isc)) then + elsif Present (Loop_Parameter_Specification (Scheme)) then declare - LPS : constant Node_Id := Loop_Parameter_Specification (Isc); + LPS : constant Node_Id := + Loop_Parameter_Specification (Scheme); Loop_Id : constant Entity_Id := Defining_Identifier (LPS); Ltype : constant Entity_Id := Etype (Loop_Id); Btype : constant Entity_Id := Base_Type (Ltype); @@ -3990,22 +3644,22 @@ package body Exp_Ch5 is -- ... -- end loop - elsif Present (Isc) - and then Present (Condition_Actions (Isc)) - and then Present (Condition (Isc)) + elsif Present (Scheme) + and then Present (Condition_Actions (Scheme)) + and then Present (Condition (Scheme)) then declare ES : Node_Id; begin ES := - Make_Exit_Statement (Sloc (Condition (Isc)), + Make_Exit_Statement (Sloc (Condition (Scheme)), Condition => - Make_Op_Not (Sloc (Condition (Isc)), - Right_Opnd => Condition (Isc))); + Make_Op_Not (Sloc (Condition (Scheme)), + Right_Opnd => Condition (Scheme))); Prepend (ES, Statements (N)); - Insert_List_Before (ES, Condition_Actions (Isc)); + Insert_List_Before (ES, Condition_Actions (Scheme)); -- This is not an implicit loop, since it is generated in response -- to the loop statement being processed. If this is itself @@ -4023,18 +3677,24 @@ package body Exp_Ch5 is -- Here to deal with iterator case - elsif Present (Isc) - and then Present (Iterator_Specification (Isc)) + elsif Present (Scheme) + and then Present (Iterator_Specification (Scheme)) then Expand_Iterator_Loop (N); end if; - -- If the loop is subject to at least one Loop_Entry attribute, it - -- requires additional processing. + -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop + -- is transformed into a conditional block where the original loop is + -- the sole statement. Inspect the statements of the nested loop for + -- controlled objects. + + Stmt := N; - if Nkind (N) = N_Loop_Statement then - Expand_Loop_Entry_Attributes (N); + if Subject_To_Loop_Entry_Attributes (Stmt) then + Stmt := Find_Loop_In_Conditional_Block (Stmt); end if; + + Process_Statements_For_Controlled_Objects (Stmt); end Expand_N_Loop_Statement; ---------------------------- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 9288e847734..34f61c894d6 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -73,6 +74,7 @@ with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -942,6 +944,7 @@ package body Exp_Ch6 is Formal : Entity_Id; N_Node : Node_Id; Post_Call : List_Id; + E_Actual : Entity_Id; E_Formal : Entity_Id; procedure Add_Call_By_Copy_Code; @@ -1508,6 +1511,7 @@ package body Exp_Ch6 is Actual := First_Actual (N); while Present (Formal) loop E_Formal := Etype (Formal); + E_Actual := Etype (Actual); if Is_Scalar_Type (E_Formal) or else Nkind (Actual) = N_Slice @@ -1645,7 +1649,7 @@ package body Exp_Ch6 is -- conversion" errors. elsif Is_Access_Type (E_Formal) - and then not Same_Type (E_Formal, Etype (Actual)) + and then not Same_Type (E_Formal, E_Actual) and then not Is_Tagged_Type (Designated_Type (E_Formal)) then Add_Call_By_Copy_Code; @@ -1661,7 +1665,7 @@ package body Exp_Ch6 is elsif Is_Entity_Name (Actual) and then Is_Volatile (Entity (Actual)) - and then not Is_By_Reference_Type (Etype (Actual)) + and then not Is_By_Reference_Type (E_Actual) and then not Is_Scalar_Type (Etype (Entity (Actual))) and then not Is_Volatile (E_Formal) then @@ -1682,10 +1686,10 @@ package body Exp_Ch6 is elsif Is_Scalar_Type (E_Formal) and then - (not In_Subrange_Of (E_Formal, Etype (Actual)) + (not In_Subrange_Of (E_Formal, E_Actual) or else (Ekind (Formal) = E_In_Out_Parameter - and then not In_Subrange_Of (Etype (Actual), E_Formal))) + and then not In_Subrange_Of (E_Actual, E_Formal))) then -- Perhaps the setting back to False should be done within -- Add_Call_By_Copy_Code, since it could get set on other @@ -1698,6 +1702,58 @@ package body Exp_Ch6 is Add_Call_By_Copy_Code; end if; + -- RM 3.2.4 (23/3) : A predicate is checked on in-out and out + -- by-reference parameters on exit from the call. If the actual + -- is a derived type and the operation is inherited, the body + -- of the operation will not contain a call to the predicate + -- function, so it must be done explicitly after the call. Ditto + -- if the actual is an entity of a predicated subtype. + + -- The rule refers to by-reference types, but a check is needed + -- for by-copy types as well. That check is subsumed by the rule + -- for subtype conversion on assignment, but we can generate the + -- required check now. + + -- Note that this is needed only if the subtype of the actual has + -- an explicit predicate aspect, not if it inherits them from a + -- base type or ancestor. The check is also superfluous if the + -- subtype is elaborated before the body of the subprogram, but + -- this is harder to verify, and there may be a redundant check. + + -- Note also that Subp may be either a subprogram entity for + -- direct calls, or a type entity for indirect calls, which must + -- be handled separately because the name does not denote an + -- overloadable entity. + + -- If the formal is class-wide the corresponding postcondition + -- procedure does not include a predicate call, so it has to be + -- generated explicitly. + + if not Is_Init_Proc (Subp) + and then (Has_Aspect (E_Actual, Aspect_Predicate) + or else + Has_Aspect (E_Actual, Aspect_Dynamic_Predicate) + or else + Has_Aspect (E_Actual, Aspect_Static_Predicate)) + and then Present (Predicate_Function (E_Actual)) + then + if Is_Entity_Name (Actual) + or else + (Is_Derived_Type (E_Actual) + and then Is_Overloadable (Subp) + and then Is_Inherited_Operation_For_Type (Subp, E_Actual)) + then + Append_To (Post_Call, + Make_Predicate_Check (E_Actual, Actual)); + + elsif Is_Class_Wide_Type (E_Formal) + and then not Is_Class_Wide_Type (E_Actual) + then + Append_To (Post_Call, + Make_Predicate_Check (E_Actual, Actual)); + end if; + end if; + -- Processing for IN parameters else @@ -2559,6 +2615,39 @@ package body Exp_Ch6 is -- as we go through the loop, since this is a convenient place to do it. -- (Though it seems that this would be better done in Expand_Actuals???) + -- Special case: Thunks must not compute the extra actuals; they must + -- just propagate to the target primitive their extra actuals. + + if Is_Thunk (Current_Scope) + and then Thunk_Entity (Current_Scope) = Subp + and then Present (Extra_Formals (Subp)) + then + pragma Assert (Present (Extra_Formals (Current_Scope))); + + declare + Target_Formal : Entity_Id; + Thunk_Formal : Entity_Id; + + begin + Target_Formal := Extra_Formals (Subp); + Thunk_Formal := Extra_Formals (Current_Scope); + while Present (Target_Formal) loop + Add_Extra_Actual + (New_Occurrence_Of (Thunk_Formal, Loc), Thunk_Formal); + + Target_Formal := Extra_Formal (Target_Formal); + Thunk_Formal := Extra_Formal (Thunk_Formal); + end loop; + + while Is_Non_Empty_List (Extra_Actuals) loop + Add_Actual_Parameter (Remove_Head (Extra_Actuals)); + end loop; + + Expand_Actuals (Call_Node, Subp); + return; + end; + end if; + Formal := First_Formal (Subp); Actual := First_Actual (Call_Node); Param_Count := 1; @@ -2691,9 +2780,7 @@ package body Exp_Ch6 is -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of -- accessibility levels. - if Ekind (Current_Scope) in Subprogram_Kind - and then Is_Thunk (Current_Scope) - then + if Is_Thunk (Current_Scope) then declare Parm_Ent : Entity_Id; @@ -4031,6 +4118,476 @@ package body Exp_Ch6 is end if; end Expand_Call; + --------------------------- + -- Expand_Contract_Cases -- + --------------------------- + + -- Pragma Contract_Cases is expanded in the following manner: + + -- subprogram S is + -- Flag_1 : Boolean := False; + -- . . . + -- Flag_N : Boolean := False; + -- Flag_N+1 : Boolean := False; -- when "others" present + -- Count : Natural := 0; + + -- <preconditions (if any)> + + -- if Case_Guard_1 then + -- Flag_1 := True; + -- Count := Count + 1; + -- end if; + -- . . . + -- if Case_Guard_N then + -- Flag_N := True; + -- Count := Count + 1; + -- end if; + + -- if Count = 0 then + -- raise Assertion_Error with "xxx contract cases incomplete"; + -- <or> + -- Flag_N+1 := True; -- when "others" present + + -- elsif Count > 1 then + -- declare + -- Str0 : constant String := + -- "contract cases overlap for subprogram ABC"; + -- Str1 : constant String := + -- (if Flag_1 then + -- Str0 & "case guard at xxx evaluates to True" + -- else Str0); + -- StrN : constant String := + -- (if Flag_N then + -- StrN-1 & "case guard at xxx evaluates to True" + -- else StrN-1); + -- begin + -- raise Assertion_Error with StrN; + -- end; + -- end if; + + -- procedure _Postconditions is + -- begin + -- <postconditions (if any)> + + -- if Flag_1 and then not Consequence_1 then + -- raise Assertion_Error with "failed contract case at xxx"; + -- end if; + -- . . . + -- if Flag_N[+1] and then not Consequence_N[+1] then + -- raise Assertion_Error with "failed contract case at xxx"; + -- end if; + -- end _Postconditions; + -- begin + -- . . . + -- end S; + + procedure Expand_Contract_Cases + (CCs : Node_Id; + Subp_Id : Entity_Id; + Decls : List_Id; + Stmts : in out List_Id) + is + Loc : constant Source_Ptr := Sloc (CCs); + + procedure Case_Guard_Error + (Decls : List_Id; + Flag : Entity_Id; + Error_Loc : Source_Ptr; + Msg : in out Entity_Id); + -- Given a declarative list Decls, status flag Flag, the location of the + -- error and a string Msg, construct the following check: + -- Msg : constant String := + -- (if Flag then + -- Msg & "case guard at Error_Loc evaluates to True" + -- else Msg); + -- The resulting code is added to Decls + + procedure Consequence_Error + (Checks : in out Node_Id; + Flag : Entity_Id; + Conseq : Node_Id); + -- Given an if statement Checks, status flag Flag and a consequence + -- Conseq, construct the following check: + -- [els]if Flag and then not Conseq then + -- raise Assertion_Error + -- with "failed contract case at Sloc (Conseq)"; + -- [end if;] + -- The resulting code is added to Checks + + function Declaration_Of (Id : Entity_Id) return Node_Id; + -- Given the entity Id of a boolean flag, generate: + -- Id : Boolean := False; + + function Increment (Id : Entity_Id) return Node_Id; + -- Given the entity Id of a numerical variable, generate: + -- Id := Id + 1; + + function Set (Id : Entity_Id) return Node_Id; + -- Given the entity Id of a boolean variable, generate: + -- Id := True; + + ---------------------- + -- Case_Guard_Error -- + ---------------------- + + procedure Case_Guard_Error + (Decls : List_Id; + Flag : Entity_Id; + Error_Loc : Source_Ptr; + Msg : in out Entity_Id) + is + New_Line : constant Character := Character'Val (10); + New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S'); + + begin + Start_String; + Store_String_Char (New_Line); + Store_String_Chars (" case guard at "); + Store_String_Chars (Build_Location_String (Error_Loc)); + Store_String_Chars (" evaluates to True"); + + -- Generate: + -- New_Msg : constant String := + -- (if Flag then + -- Msg & "case guard at Error_Loc evaluates to True" + -- else Msg); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => New_Msg, + Constant_Present => True, + Object_Definition => New_Reference_To (Standard_String, Loc), + Expression => + Make_If_Expression (Loc, + Expressions => New_List ( + New_Reference_To (Flag, Loc), + + Make_Op_Concat (Loc, + Left_Opnd => New_Reference_To (Msg, Loc), + Right_Opnd => Make_String_Literal (Loc, End_String)), + + New_Reference_To (Msg, Loc))))); + + Msg := New_Msg; + end Case_Guard_Error; + + ----------------------- + -- Consequence_Error -- + ----------------------- + + procedure Consequence_Error + (Checks : in out Node_Id; + Flag : Entity_Id; + Conseq : Node_Id) + is + Cond : Node_Id; + Error : Node_Id; + + begin + -- Generate: + -- Flag and then not Conseq + + Cond := + Make_And_Then (Loc, + Left_Opnd => New_Reference_To (Flag, Loc), + Right_Opnd => + Make_Op_Not (Loc, + Right_Opnd => Relocate_Node (Conseq))); + + -- Generate: + -- raise Assertion_Error + -- with "failed contract case at Sloc (Conseq)"; + + Start_String; + Store_String_Chars ("failed contract case at "); + Store_String_Chars (Build_Location_String (Sloc (Conseq))); + + Error := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, End_String))); + + if No (Checks) then + Checks := + Make_If_Statement (Loc, + Condition => Cond, + Then_Statements => New_List (Error)); + + else + if No (Elsif_Parts (Checks)) then + Set_Elsif_Parts (Checks, New_List); + end if; + + Append_To (Elsif_Parts (Checks), + Make_Elsif_Part (Loc, + Condition => Cond, + Then_Statements => New_List (Error))); + end if; + end Consequence_Error; + + -------------------- + -- Declaration_Of -- + -------------------- + + function Declaration_Of (Id : Entity_Id) return Node_Id is + begin + return + Make_Object_Declaration (Loc, + Defining_Identifier => Id, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_False, Loc)); + end Declaration_Of; + + --------------- + -- Increment -- + --------------- + + function Increment (Id : Entity_Id) return Node_Id is + begin + return + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Id, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Reference_To (Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + end Increment; + + --------- + -- Set -- + --------- + + function Set (Id : Entity_Id) return Node_Id is + begin + return + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Id, Loc), + Expression => New_Reference_To (Standard_True, Loc)); + end Set; + + -- Local variables + + Aggr : constant Node_Id := + Expression (First + (Pragma_Argument_Associations (CCs))); + Case_Guard : Node_Id; + CG_Checks : Node_Id; + CG_Stmts : List_Id; + Conseq : Node_Id; + Conseq_Checks : Node_Id := Empty; + Count : Entity_Id; + Error_Decls : List_Id; + Flag : Entity_Id; + Msg_Str : Entity_Id; + Multiple_PCs : Boolean; + Others_Flag : Entity_Id := Empty; + Post_Case : Node_Id; + + -- Start of processing for Expand_Contract_Cases + + begin + -- Do nothing if pragma is not enabled. If pragma is disabled, it has + -- already been rewritten as a Null statement. + + if Is_Ignored (CCs) then + return; + + -- Guard against malformed contract cases + + elsif Nkind (Aggr) /= N_Aggregate then + return; + end if; + + Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1; + + -- Create the counter which tracks the number of case guards that + -- evaluate to True. + + -- Count : Natural := 0; + + Count := Make_Temporary (Loc, 'C'); + + Prepend_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Count, + Object_Definition => New_Reference_To (Standard_Natural, Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + -- Create the base error message for multiple overlapping case guards + + -- Msg_Str : constant String := + -- "contract cases overlap for subprogram Subp_Id"; + + if Multiple_PCs then + Msg_Str := Make_Temporary (Loc, 'S'); + + Start_String; + Store_String_Chars ("contract cases overlap for subprogram "); + Store_String_Chars (Get_Name_String (Chars (Subp_Id))); + + Error_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Msg_Str, + Constant_Present => True, + Object_Definition => New_Reference_To (Standard_String, Loc), + Expression => Make_String_Literal (Loc, End_String))); + end if; + + -- Process individual post cases + + Post_Case := First (Component_Associations (Aggr)); + while Present (Post_Case) loop + Case_Guard := First (Choices (Post_Case)); + Conseq := Expression (Post_Case); + + -- The "others" choice requires special processing + + if Nkind (Case_Guard) = N_Others_Choice then + Others_Flag := Make_Temporary (Loc, 'F'); + Prepend_To (Decls, Declaration_Of (Others_Flag)); + + -- Check possible overlap between a case guard and "others" + + if Multiple_PCs and Exception_Extra_Info then + Case_Guard_Error + (Decls => Error_Decls, + Flag => Others_Flag, + Error_Loc => Sloc (Case_Guard), + Msg => Msg_Str); + end if; + + -- Check the corresponding consequence of "others" + + Consequence_Error + (Checks => Conseq_Checks, + Flag => Others_Flag, + Conseq => Conseq); + + -- Regular post case + + else + -- Create the flag which tracks the state of its associated case + -- guard. + + Flag := Make_Temporary (Loc, 'F'); + Prepend_To (Decls, Declaration_Of (Flag)); + + -- The flag is set when the case guard is evaluated to True + -- if Case_Guard then + -- Flag := True; + -- Count := Count + 1; + -- end if; + + Append_To (Decls, + Make_If_Statement (Loc, + Condition => Relocate_Node (Case_Guard), + Then_Statements => New_List ( + Set (Flag), + Increment (Count)))); + + -- Check whether this case guard overlaps with another one + + if Multiple_PCs and Exception_Extra_Info then + Case_Guard_Error + (Decls => Error_Decls, + Flag => Flag, + Error_Loc => Sloc (Case_Guard), + Msg => Msg_Str); + end if; + + -- The corresponding consequence of the case guard which evaluated + -- to True must hold on exit from the subprogram. + + Consequence_Error + (Checks => Conseq_Checks, + Flag => Flag, + Conseq => Conseq); + end if; + + Next (Post_Case); + end loop; + + -- Raise Assertion_Error when none of the case guards evaluate to True. + -- The only exception is when we have "others", in which case there is + -- no error because "others" acts as a default True. + + -- Generate: + -- Flag := True; + + if Present (Others_Flag) then + CG_Stmts := New_List (Set (Others_Flag)); + + -- Generate: + -- raise Assertion_Error with "xxx contract cases incomplete"; + + else + Start_String; + Store_String_Chars (Build_Location_String (Loc)); + Store_String_Chars (" contract cases incomplete"); + + CG_Stmts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, End_String)))); + end if; + + CG_Checks := + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Reference_To (Count, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + Then_Statements => CG_Stmts); + + -- Detect a possible failure due to several case guards evaluating to + -- True. + + -- Generate: + -- elsif Count > 0 then + -- declare + -- <Error_Decls> + -- begin + -- raise Assertion_Error with <Msg_Str>; + -- end if; + + if Multiple_PCs then + Set_Elsif_Parts (CG_Checks, New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => New_Reference_To (Count, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)), + + Then_Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => Error_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Msg_Str, Loc)))))))))); + end if; + + Append_To (Decls, CG_Checks); + + -- Raise Assertion_Error when the corresponding consequence of a case + -- guard that evaluated to True fails. + + if No (Stmts) then + Stmts := New_List; + end if; + + Append_To (Stmts, Conseq_Checks); + end Expand_Contract_Cases; + ------------------------------- -- Expand_Ctrl_Function_Call -- ------------------------------- @@ -5489,6 +6046,12 @@ package body Exp_Ch6 is -- Start of processing for Expand_N_Extended_Return_Statement begin + -- Given that functionality of interface thunks is simple (just displace + -- the pointer to the object) they are always handled by means of + -- simple return statements. + + pragma Assert (not Is_Thunk (Current_Scope)); + if Nkind (Ret_Obj_Decl) = N_Object_Declaration then Exp := Expression (Ret_Obj_Decl); else @@ -6460,6 +7023,7 @@ package body Exp_Ch6 is if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then declare F : Entity_Id; + A : Node_Id; begin -- Loop through formals @@ -6474,12 +7038,15 @@ package body Exp_Ch6 is -- Insert the initialization. We turn off validity checks -- for this assignment, since we do not want any check on -- the initial value itself (which may well be invalid). + -- Predicate checks are disabled as well (RM 6.4.1 (13/3)) - Insert_Before_And_Analyze (First (L), - Make_Assignment_Statement (Loc, + A := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (F, Loc), - Expression => Get_Simple_Init_Val (Etype (F), N)), - Suppress => Validity_Check); + Expression => Get_Simple_Init_Val (Etype (F), N)); + Set_Suppress_Assignment_Checks (A); + + Insert_Before_And_Analyze (First (L), + A, Suppress => Validity_Check); end if; Next_Formal (F); @@ -7132,18 +7699,26 @@ package body Exp_Ch6 is and then Is_Immutably_Limited_Type (Etype (Expression (N))) and then Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L + + -- The functionality of interface thunks is simple and it is always + -- handled by means of simple return statements. This leaves their + -- expansion simple and clean. + + and then not Is_Thunk (Current_Scope) then declare Return_Object_Entity : constant Entity_Id := Make_Temporary (Loc, 'R', Exp); + Obj_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Return_Object_Entity, Object_Definition => Subtype_Ind, Expression => Exp); - Ext : constant Node_Id := Make_Extended_Return_Statement (Loc, - Return_Object_Declarations => New_List (Obj_Decl)); + Ext : constant Node_Id := + Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Obj_Decl)); -- Do not perform this high-level optimization if the result type -- is an interface because the "this" pointer must be displaced. @@ -7205,6 +7780,13 @@ package body Exp_Ch6 is then null; + -- No copy needed for thunks returning interface type objects since + -- the object is returned by reference and the maximum functionality + -- required is just to displace the pointer. + + elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then + null; + elsif not Requires_Transient_Scope (R_Type) then -- Mutable records with no variable length components are not @@ -7433,12 +8015,16 @@ package body Exp_Ch6 is -- return expression has a specific type whose level is known not to -- be statically deeper than the function's result type. + -- No runtime check needed in interface thunks since it is performed + -- by the target primitive associated with the thunk. + -- Note: accessibility check is skipped in the VM case, since there -- does not seem to be any practical way to implement this check. elsif Ada_Version >= Ada_2005 and then Tagged_Type_Expansion and then Is_Class_Wide_Type (R_Type) + and then not Is_Thunk (Current_Scope) and then not Scope_Suppress.Suppress (Accessibility_Check) and then (Is_Class_Wide_Type (Etype (Exp)) @@ -7789,10 +8375,23 @@ package body Exp_Ch6 is else declare - ExpR : constant Node_Id := Relocate_Node (Exp); + ExpR : Node_Id := Relocate_Node (Exp); Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); begin + -- In the case of discriminated objects, we have created a + -- constrained subtype above, and used the underlying type. + -- This transformation is post-analysis and harmless, except + -- that now the call to the post-condition will be analyzed and + -- type kinds have to match. + + if Nkind (ExpR) = N_Unchecked_Type_Conversion + and then + Is_Private_Type (R_Type) /= Is_Private_Type (Etype (ExpR)) + then + ExpR := Expression (ExpR); + end if; + -- For a complex expression of an elementary type, capture -- value in the temporary and use it as the reference. @@ -7966,11 +8565,11 @@ package body Exp_Ch6 is return False; else - -- In Alfa mode, build-in-place calls are not expanded, so that we + -- 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 Alfa_Mode then + if SPARK_Mode then return False; elsif Is_Entity_Name (Name (Exp_Node)) then @@ -7982,6 +8581,11 @@ package body Exp_Ch6 is elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then Function_Id := Etype (Name (Exp_Node)); + -- This may be a call to a protected function. + + elsif Nkind (Name (Exp_Node)) = N_Selected_Component then + Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node)))); + else raise Program_Error; end if; @@ -8167,6 +8771,18 @@ package body Exp_Ch6 is Set_Returns_By_Ref (Subp); end if; end; + + -- Wnen freezing a null procedure, analyze its delayed aspects now + -- because we may not have reached the end of the declarative list when + -- delayed aspects are normally analyzed. This ensures that dispatching + -- calls are properly rewritten when the generated _Postcondition + -- procedure is analyzed in the null procedure body. + + if Nkind (Parent (Subp)) = N_Procedure_Specification + and then Null_Present (Parent (Subp)) + then + Analyze_Subprogram_Contract (Subp); + end if; end Freeze_Subprogram; ----------------------- @@ -8425,12 +9041,12 @@ package body Exp_Ch6 is then null; - -- Do not generate the call to Set_Finalize_Address in Alfa mode + -- 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. - elsif not Alfa_Mode + elsif not SPARK_Mode and then not CodePeer_Mode then Insert_Action (Allocator, diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 0f65a5bf786..f9829f52b34 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.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- -- @@ -71,6 +71,17 @@ package Exp_Ch6 is -- This procedure contains common processing for Expand_N_Function_Call, -- Expand_N_Procedure_Statement, and Expand_N_Entry_Call. + procedure Expand_Contract_Cases + (CCs : Node_Id; + Subp_Id : Entity_Id; + Decls : List_Id; + Stmts : in out List_Id); + -- Given pragma Contract_Cases CCs, create the circuitry needed to evaluate + -- case guards and trigger consequence expressions. Subp_Id is the related + -- subprogram for which the pragma applies. Decls are the declarations of + -- Subp_Id's body. All generated code is added to list Stmts. If Stmts is + -- empty, a new list is created. + 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 72892828b61..fdaf213ff86 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.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- -- @@ -929,10 +929,10 @@ package body Exp_Ch7 is then return; - -- Do not create finalization masters in Alfa mode because they result + -- Do not create finalization masters in SPARK mode because they result -- in unwanted expansion. - elsif Alfa_Mode then + elsif SPARK_Mode then return; end if; @@ -2805,10 +2805,10 @@ package body Exp_Ch7 is begin Fin_Id := Empty; - -- Do not perform this expansion in Alfa mode because it is not + -- Do not perform this expansion in SPARK mode because it is not -- necessary. - if Alfa_Mode then + if SPARK_Mode then return; end if; @@ -2967,10 +2967,10 @@ package body Exp_Ch7 is HSS : Node_Id; begin - -- Do not perform this expansion in Alfa mode because we do not create + -- Do not perform this expansion in SPARK mode because we do not create -- finalizers in the first place. - if Alfa_Mode then + if SPARK_Mode then return; end if; @@ -3653,7 +3653,7 @@ package body Exp_Ch7 is -- this node and enclosed expression are not expanded, so do not apply -- any transformations here. - elsif Alfa_Mode + elsif SPARK_Mode and then Nkind (Wrap_Node) = N_Pragma and then Get_Pragma_Id (Wrap_Node) = Pragma_Check then diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 3b5c7d3ae64..97bfac46539 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.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- -- @@ -328,8 +328,8 @@ package body Exp_Ch8 is -- meaning. It may be redefined later, but the renaming is -- elaborated where it occurs. This is technically known as -- Squirreling semantics. Renaming is rewritten as a subprogram - -- declaration, and the body is inserted at the end of the - -- current declaration list to prevent premature freezing. + -- declaration, and the generated body is inserted into the + -- freeze actions for the subprogram. Decl := Build_Body_For_Renaming; @@ -345,7 +345,7 @@ package body Exp_Ch8 is Rhs => Make_Identifier (Loc, Chars (Right)), Bodies => Declarations (Decl)))))); - Append (Decl, List_Containing (N)); + Append_Freeze_Action (Id, Decl); end if; end; end if; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 49e7efeba6e..20a346ceec2 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.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- -- @@ -1925,7 +1925,8 @@ package body Exp_Ch9 is P : Node_Id; begin - P := Spec_PPC_List (Contract (E)); + P := Pre_Post_Conditions (Contract (E)); + if No (P) then return; end if; @@ -1933,8 +1934,8 @@ package body Exp_Ch9 is -- Transfer ppc pragmas to the declarations of the wrapper while Present (P) loop - if Pragma_Name (P) = Name_Precondition - or else Pragma_Name (P) = Name_Postcondition + if Nam_In (Pragma_Name (P), Name_Precondition, + Name_Postcondition) then Append (Relocate_Node (P), Decls); Set_Analyzed (Last (Decls), False); @@ -11840,7 +11841,7 @@ package body Exp_Ch9 is Ent := First_Entity (Tasktyp); while Present (Ent) loop if Ekind_In (Ent, E_Entry, E_Entry_Family) - and then Present (Spec_PPC_List (Contract (Ent))) + and then Present (Pre_Post_Conditions (Contract (Ent))) then Build_PPC_Wrapper (Ent, N); end if; @@ -13388,6 +13389,7 @@ package body Exp_Ch9 is Args : List_Id; L : constant List_Id := New_List; Has_Entry : constant Boolean := Has_Entries (Ptyp); + Prio_Type : Entity_Id; Restricted : constant Boolean := Restricted_Profile; begin @@ -13456,18 +13458,37 @@ package body Exp_Ch9 is Expression (First (Pragma_Argument_Associations (Prio_Clause))); + -- Get_Rep_Item returns either priority pragma. + + if Pragma_Name (Prio_Clause) = Name_Priority then + Prio_Type := RTE (RE_Any_Priority); + else + Prio_Type := RTE (RE_Interrupt_Priority); + end if; + -- Attribute definition clause Priority else + if Chars (Prio_Clause) = Name_Priority then + Prio_Type := RTE (RE_Any_Priority); + else + Prio_Type := RTE (RE_Interrupt_Priority); + end if; + Prio := Expression (Prio_Clause); end if; -- If priority is a static expression, then we can duplicate it -- with no problem and simply append it to the argument list. + -- However, it has only be pre-analyzed, so we need to check + -- now that it is in the bounds of the priority type. if Is_Static_Expression (Prio) then + Set_Analyzed (Prio, False); Append_To (Args, - Duplicate_Subexpr_No_Checks (Prio)); + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Prio_Type, Loc), + Expression => Duplicate_Subexpr (Prio))); -- Otherwise, the priority may be a per-object expression, if -- it depends on a discriminant of the type. In this case, @@ -13477,18 +13498,13 @@ package body Exp_Ch9 is -- appropriate approach, but that could generate declarations -- improperly placed in the enclosing scope. - -- Note: Use System.Any_Priority as the expected type for the - -- non-static priority expression, in case the expression has - -- not been analyzed yet (as occurs for example with pragma - -- Interrupt_Priority). - else Temp := Make_Temporary (Loc, 'R', Prio); Append_To (L, Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => - New_Occurrence_Of (RTE (RE_Any_Priority), Loc), + New_Occurrence_Of (Prio_Type, Loc), Expression => Relocate_Node (Prio))); Append_To (Args, New_Occurrence_Of (Temp, Loc)); @@ -14071,11 +14087,10 @@ package body Exp_Ch9 is and then (Nkind_In (Stmt, N_Null_Statement, N_Label) or else (Nkind (Stmt) = N_Pragma - and then (Pragma_Name (Stmt) = Name_Unreferenced - or else - Pragma_Name (Stmt) = Name_Unmodified - or else - Pragma_Name (Stmt) = Name_Warnings))) + and then + Nam_In (Pragma_Name (Stmt), Name_Unreferenced, + Name_Unmodified, + Name_Warnings))) loop Next (Stmt); end loop; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index c034fe5cf6b..cc5ff4fc8fb 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.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. -- -- -- -- 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- -- @@ -1315,7 +1315,7 @@ package body Exp_Dbug is -- name as being qualified, as Qualify_Entity_Name may be called more -- than once on the same entity. - elsif Alfa_Mode then + elsif SPARK_Mode then if Has_Homonym (Ent) then Get_Name_String (Chars (Ent)); Append_Homonym_Number (Ent); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index bf530cb4769..7490e9df7bf 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1072,89 +1072,93 @@ package body Exp_Disp is -- to avoid the generation of spurious warnings under ZFP run-time. Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); - - -- For functions returning interface types add implicit conversion to - -- force the displacement of the pointer to the object to reference - -- the corresponding secondary dispatch table. This is needed to - -- handle well nested calls through secondary dispatch tables - -- (for example Obj.Prim1.Prim2). - - if Is_Interface (Res_Typ) then - Rewrite (Call_Node, - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Res_Typ, Loc), - Expression => Relocate_Node (Call_Node))); - Set_Etype (Call_Node, Res_Typ); - Expand_Interface_Conversion (Call_Node, Is_Static => False); - Force_Evaluation (Call_Node); - - pragma Assert (Nkind (Call_Node) = N_Explicit_Dereference - and then Nkind (Prefix (Call_Node)) = N_Identifier - and then Nkind (Parent (Entity (Prefix (Call_Node)))) - = N_Object_Declaration); - Set_Assignment_OK (Parent (Entity (Prefix (Call_Node)))); - - if Nkind (Parent (Call_Node)) = N_Object_Declaration then - Set_Assignment_OK (Parent (Call_Node)); - end if; - end if; end Expand_Dispatching_Call; --------------------------------- -- Expand_Interface_Conversion -- --------------------------------- - procedure Expand_Interface_Conversion - (N : Node_Id; - Is_Static : Boolean := True) - is - Loc : constant Source_Ptr := Sloc (N); - Etyp : constant Entity_Id := Etype (N); - Operand : constant Node_Id := Expression (N); - Operand_Typ : Entity_Id := Etype (Operand); - Func : Node_Id; - Iface_Typ : Entity_Id := Etype (N); - Iface_Tag : Entity_Id; + procedure Expand_Interface_Conversion (N : Node_Id) is + function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id; + -- Return the underlying record type of Typ. - begin - -- Ada 2005 (AI-345): Handle synchronized interface type derivations + ---------------------------- + -- Underlying_Record_Type -- + ---------------------------- - if Is_Concurrent_Type (Operand_Typ) then - Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ)); - end if; + function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id is + E : Entity_Id := Typ; - -- Handle access to class-wide interface types + begin + -- Handle access to class-wide interface types - if Is_Access_Type (Iface_Typ) then - Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ)); - end if; + if Is_Access_Type (E) then + E := Etype (Directly_Designated_Type (E)); + end if; - -- Handle class-wide interface types. This conversion can appear - -- explicitly in the source code. Example: I'Class (Obj) + -- Handle class-wide types. This conversion can appear explicitly in + -- the source code. Example: I'Class (Obj) - if Is_Class_Wide_Type (Iface_Typ) then - Iface_Typ := Root_Type (Iface_Typ); - end if; + if Is_Class_Wide_Type (E) then + E := Root_Type (E); + end if; - -- If the target type is a tagged synchronized type, the dispatch table - -- info is in the corresponding record type. + -- If the target type is a tagged synchronized type, the dispatch + -- table info is in the corresponding record type. - if Is_Concurrent_Type (Iface_Typ) then - Iface_Typ := Corresponding_Record_Type (Iface_Typ); - end if; + if Is_Concurrent_Type (E) then + E := Corresponding_Record_Type (E); + end if; - -- Handle private types + -- Handle private types + + E := Underlying_Type (E); + + -- Handle subtypes + + return Base_Type (E); + end Underlying_Record_Type; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (N); + Etyp : constant Entity_Id := Etype (N); + Operand : constant Node_Id := Expression (N); + Operand_Typ : Entity_Id := Etype (Operand); + Func : Node_Id; + Iface_Typ : constant Entity_Id := Underlying_Record_Type (Etype (N)); + Iface_Tag : Entity_Id; + Is_Static : Boolean; - Iface_Typ := Underlying_Type (Iface_Typ); + -- Start of processing for Expand_Interface_Conversion + begin -- Freeze the entity associated with the target interface to have -- available the attribute Access_Disp_Table. Freeze_Before (N, Iface_Typ); - pragma Assert (not Is_Static - or else (not Is_Class_Wide_Type (Iface_Typ) - and then Is_Interface (Iface_Typ))); + -- Ada 2005 (AI-345): Handle synchronized interface type derivations + + if Is_Concurrent_Type (Operand_Typ) then + Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ)); + end if; + + -- Evaluate if we can statically displace the pointer to the object + + declare + Opnd_Typ : constant Node_Id := Underlying_Record_Type (Operand_Typ); + + begin + Is_Static := + not Is_Interface (Opnd_Typ) + and then Interface_Present_In_Ancestor + (Typ => Opnd_Typ, + Iface => Iface_Typ) + and then (Etype (Opnd_Typ) = Opnd_Typ + or else not + Is_Variable_Size_Record (Etype (Opnd_Typ))); + end; if not Tagged_Type_Expansion then if VM_Target /= No_VM then @@ -1166,16 +1170,14 @@ package body Exp_Disp is Operand_Typ := Root_Type (Operand_Typ); end if; - if not Is_Static - and then Operand_Typ /= Iface_Typ - then + if not Is_Static and then Operand_Typ /= Iface_Typ then Insert_Action (N, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Check_Interface_Conversion), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Expression (N)), + Prefix => Duplicate_Subexpr (Expression (N)), Attribute_Name => Name_Tag), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Iface_Typ, Loc), @@ -1881,8 +1883,10 @@ package body Exp_Disp is end loop; Thunk_Id := Make_Temporary (Loc, 'T'); + Set_Ekind (Thunk_Id, Ekind (Prim)); Set_Is_Thunk (Thunk_Id); Set_Convention (Thunk_Id, Convention (Prim)); + Set_Thunk_Entity (Thunk_Id, Target); -- Procedure case @@ -1904,22 +1908,69 @@ package body Exp_Disp is -- Function case else pragma Assert (Ekind (Target) = E_Function); - Thunk_Code := - Make_Subprogram_Body (Loc, - Specification => - Make_Function_Specification (Loc, - Defining_Unit_Name => Thunk_Id, - Parameter_Specifications => Formals, - Result_Definition => - New_Copy (Result_Definition (Parent (Target)))), - Declarations => Decl, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Target, Loc), - Parameter_Associations => Actuals))))); + declare + Result_Def : Node_Id; + Call_Node : Node_Id; + + begin + Call_Node := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Target, Loc), + Parameter_Associations => Actuals); + + if not Is_Interface (Etype (Prim)) then + Result_Def := New_Copy (Result_Definition (Parent (Target))); + + -- Thunk of function returning a class-wide interface object. No + -- extra displacement needed since the displacement is generated + -- in the return statement of Prim. Example: + + -- type Iface is interface ... + -- function F (O : Iface) return Iface'Class; + + -- type T is new ... and Iface with ... + -- function F (O : T) return Iface'Class; + + elsif Is_Class_Wide_Type (Etype (Prim)) then + Result_Def := New_Occurrence_Of (Etype (Prim), Loc); + + -- Thunk of function returning an interface object. Displacement + -- needed. Example: + + -- type Iface is interface ... + -- function F (O : Iface) return Iface; + + -- type T is new ... and Iface with ... + -- function F (O : T) return T; + + else + Result_Def := + New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc); + + -- Adding implicit conversion to force the displacement of + -- the pointer to the object to reference the corresponding + -- secondary dispatch table. + + Call_Node := + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc), + Expression => Relocate_Node (Call_Node)); + end if; + + Thunk_Code := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Thunk_Id, + Parameter_Specifications => Formals, + Result_Definition => Result_Def), + Declarations => Decl, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, Call_Node)))); + end; end if; end Expand_Interface_Thunk; @@ -2055,11 +2106,10 @@ package body Exp_Disp is TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); - if Chars (E) = Name_uSize + if Nam_In (Chars (E), Name_uSize, Name_uAssign) or else (Chars (E) = Name_Op_Eq - and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) - or else Chars (E) = Name_uAssign + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize or else Is_Predefined_Interface_Primitive (E) @@ -8382,10 +8432,10 @@ package body Exp_Disp is -- excluded from this check because interfaces must be visible in -- the public and private part (RM 7.3 (7.3/2)) - -- We disable this check in CodePeer mode, to accommodate legacy - -- Ada code. + -- We disable this check in Relaxed_RM_Semantics mode, to + -- accommodate legacy Ada code. - if not CodePeer_Mode + if not Relaxed_RM_Semantics and then Is_Abstract_Type (Typ) and then Is_Abstract_Subprogram (Prim) and then Present (Alias (Prim)) diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index f95fba5adfe..67b8be0d4b5 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.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- -- @@ -222,12 +222,10 @@ package Exp_Disp is -- Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide -- interfaces to reference the interface tag of the actual object - procedure Expand_Interface_Conversion - (N : Node_Id; - Is_Static : Boolean := True); - -- Ada 2005 (AI-251): N is a type-conversion node. Reference the base of - -- the object to give access to the interface tag associated with the - -- secondary dispatch table. + procedure Expand_Interface_Conversion (N : Node_Id); + -- Ada 2005 (AI-251): N is a type-conversion node. Displace the pointer + -- to the object to give access to the interface tag associated with the + -- dispatch table of the target type. procedure Expand_Interface_Thunk (Prim : Node_Id; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index e0e7250a3b7..364330339fe 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -2318,7 +2318,7 @@ package body Exp_Dist is procedure Build_Passive_Partition_Stub (U : Node_Id) is Pkg_Spec : Node_Id; - Pkg_Name : String_Id; + Pkg_Ent : Entity_Id; L : List_Id; Reg : Node_Id; Loc : constant Source_Ptr := Sloc (U); @@ -2343,18 +2343,17 @@ package body Exp_Dist is Pkg_Spec := Parent (Corresponding_Spec (U)); L := Declarations (U); end if; + Pkg_Ent := Defining_Entity (Pkg_Spec); - Get_Library_Unit_Name_String (Pkg_Spec); - Pkg_Name := String_From_Name_Buffer; Reg := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), Parameter_Associations => New_List ( - Make_String_Literal (Loc, Pkg_Name), + Make_String_Literal (Loc, + Fully_Qualified_Name_String (Pkg_Ent, Append_NUL => False)), Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Prefix => New_Occurrence_Of (Pkg_Ent, Loc), Attribute_Name => Name_Version))); Append_To (L, Reg); Analyze (Reg); @@ -4111,13 +4110,13 @@ package body Exp_Dist is Append_To (Decls, Pkg_RPC_Receiver_Body); Analyze (Last (Decls)); - Get_Library_Unit_Name_String (Pkg_Spec); - -- Name Append_To (Register_Pkg_Actuals, Make_String_Literal (Loc, - Strval => String_From_Name_Buffer)); + Strval => + Fully_Qualified_Name_String + (Defining_Entity (Pkg_Spec), Append_NUL => False))); -- Receiver @@ -5591,7 +5590,7 @@ package body Exp_Dist is -- Name Make_String_Literal (Loc, - Fully_Qualified_Name_String (Desig)), + Fully_Qualified_Name_String (Desig, Append_NUL => False)), -- Handler @@ -5938,7 +5937,8 @@ package body Exp_Dist is New_Occurrence_Of (RACW_Parameter, Loc)), Make_String_Literal (Loc, Strval => Fully_Qualified_Name_String - (Etype (Designated_Type (RACW_Type)))), + (Etype (Designated_Type (RACW_Type)), + Append_NUL => False)), Build_Stub_Tag (Loc, RACW_Type), New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), Make_Attribute_Reference (Loc, @@ -6134,7 +6134,8 @@ package body Exp_Dist is Unchecked_Convert_To (RTE (RE_Address), Object), Make_String_Literal (Loc, Strval => Fully_Qualified_Name_String - (Etype (Designated_Type (RACW_Type)))), + (Etype (Designated_Type (RACW_Type)), + Append_NUL => False)), Build_Stub_Tag (Loc, RACW_Type), New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), Make_Attribute_Reference (Loc, @@ -6630,9 +6631,10 @@ package body Exp_Dist is Make_Simple_Return_Statement (Loc, Expression => Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc), + Name => + New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc), Parameter_Associations => New_List ( - New_Occurrence_Of (RTE (RE_TC_Object), Loc), + New_Occurrence_Of (RTE (RE_Tk_Objref), Loc), Make_Aggregate (Loc, Expressions => New_List ( @@ -7068,13 +7070,13 @@ package body Exp_Dist is Append_To (Decls, Pkg_RPC_Receiver_Object); Analyze (Last (Decls)); - Get_Library_Unit_Name_String (Pkg_Spec); - -- Name Append_To (Register_Pkg_Actuals, Make_String_Literal (Loc, - Strval => String_From_Name_Buffer)); + Strval => + Fully_Qualified_Name_String + (Defining_Entity (Pkg_Spec), Append_NUL => False))); -- Version @@ -9209,20 +9211,12 @@ package body Exp_Dist is Repo_Id_Str : out String_Id) is begin + Name_Str := Fully_Qualified_Name_String (E, Append_NUL => False); Start_String; Store_String_Chars ("DSA:"); - Get_Library_Unit_Name_String (Scope (E)); - Store_String_Chars - (Name_Buffer (Name_Buffer'First .. - Name_Buffer'First + Name_Len - 1)); - Store_String_Char ('.'); - Get_Name_String (Chars (E)); - Store_String_Chars - (Name_Buffer (Name_Buffer'First .. - Name_Buffer'First + Name_Len - 1)); + Store_String_Chars (Name_Str); Store_String_Chars (":1.0"); Repo_Id_Str := End_String; - Name_Str := String_From_Name_Buffer; end Build_Name_And_Repository_Id; ----------------------- @@ -10207,11 +10201,11 @@ package body Exp_Dist is function Make_Constructed_TypeCode (Kind : Entity_Id; Parameters : List_Id) return Node_Id; - -- Call TC_Build with the given kind and parameters + -- Call Build_Complex_TC with the given kind and parameters procedure Return_Constructed_TypeCode (Kind : Entity_Id); - -- Make a return statement that calls TC_Build with the given - -- typecode kind, and the constructed parameters list. + -- Make a return statement that calls Build_Complex_TC with the + -- given typecode kind, and the constructed parameters list. procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id); -- Return a typecode that is a TC_Alias for the given typecode @@ -10285,7 +10279,7 @@ package body Exp_Dist is procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id) is begin Add_TypeCode_Parameter (Base_TypeCode, Parameters); - Return_Constructed_TypeCode (RTE (RE_TC_Alias)); + Return_Constructed_TypeCode (RTE (RE_Tk_Alias)); end Return_Alias_TypeCode; ------------------------------- @@ -10298,12 +10292,12 @@ package body Exp_Dist is is Constructed_TC : constant Node_Id := Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_TC_Build), Loc), + Name => + New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Kind, Loc), Make_Aggregate (Loc, - Expressions => Parameters))); + Expressions => Parameters))); begin Set_Etype (Constructed_TC, RTE (RE_TypeCode)); return Constructed_TC; @@ -10420,7 +10414,7 @@ package body Exp_Dist is Add_TypeCode_Parameter (Make_Constructed_TypeCode - (RTE (RE_TC_Struct), Struct_TC_Params), + (RTE (RE_Tk_Struct), Struct_TC_Params), Union_TC_Params); Add_String_Parameter (Name_Str, Union_TC_Params); @@ -10439,7 +10433,7 @@ package body Exp_Dist is Add_TypeCode_Parameter (Make_Constructed_TypeCode - (RTE (RE_TC_Union), Union_TC_Params), + (RTE (RE_Tk_Union), Union_TC_Params), Params); Add_String_Parameter (Name_Str, Params); @@ -10687,7 +10681,7 @@ package body Exp_Dist is TC_Append_Record_Traversal (Parameters, Component_List (Rdef), Empty, Dummy_Counter); - Return_Constructed_TypeCode (RTE (RE_TC_Struct)); + Return_Constructed_TypeCode (RTE (RE_Tk_Struct)); end; end if; @@ -10705,7 +10699,7 @@ package body Exp_Dist is for J in 1 .. Ndim loop if Constrained then Inner_TypeCode := Make_Constructed_TypeCode - (RTE (RE_TC_Array), New_List ( + (RTE (RE_Tk_Array), New_List ( Build_To_Any_Call (Loc, OK_Convert_To (RTE (RE_Unsigned_32), Make_Attribute_Reference (Loc, @@ -10731,7 +10725,7 @@ package body Exp_Dist is Next_Index (Indx); Inner_TypeCode := Make_Constructed_TypeCode - (RTE (RE_TC_Sequence), New_List ( + (RTE (RE_Tk_Sequence), New_List ( Build_To_Any_Call (Loc, OK_Convert_To (RTE (RE_Unsigned_32), Make_Integer_Literal (Loc, 0)), @@ -10747,7 +10741,7 @@ package body Exp_Dist is Start_String; Store_String_Char ('V'); Add_String_Parameter (End_String, Parameters); - Return_Constructed_TypeCode (RTE (RE_TC_Struct)); + Return_Constructed_TypeCode (RTE (RE_Tk_Struct)); end if; end; @@ -11133,11 +11127,11 @@ package body Exp_Dist is Package_Spec : Node_Id) return Node_Id is Inst : Node_Id; - Pkg_Name : String_Id; + Pkg_Name : constant String_Id := + Fully_Qualified_Name_String + (Defining_Entity (Package_Spec), Append_NUL => False); begin - Get_Library_Unit_Name_String (Package_Spec); - Pkg_Name := String_From_Name_Buffer; Inst := Make_Package_Instantiation (Loc, Defining_Unit_Name => Make_Temporary (Loc, 'R'), diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads index a0bb6c113db..53f59f4757f 100644 --- a/gcc/ada/exp_dist.ads +++ b/gcc/ada/exp_dist.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- -- @@ -35,7 +35,7 @@ package Exp_Dist is PCS_Version_Number : constant array (PCS_Names) of Int := (Name_No_DSA => 1, Name_GARLIC_DSA => 1, - Name_PolyORB_DSA => 5); + Name_PolyORB_DSA => 6); -- PCS interface version. This is used to check for consistency between the -- compiler used to generate distribution stubs and the PCS implementation. -- It must be incremented whenever a change is made to the generated code diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 2d0d817fc8a..7302f077012 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -518,11 +518,9 @@ package body Exp_Intr is elsif Nam = Name_Generic_Dispatching_Constructor then Expand_Dispatching_Constructor_Call (N); - elsif Nam = Name_Import_Address - or else - Nam = Name_Import_Largest_Value - or else - Nam = Name_Import_Value + elsif Nam_In (Nam, Name_Import_Address, + Name_Import_Largest_Value, + Name_Import_Value) then Expand_Import_Call (N); @@ -556,10 +554,10 @@ package body Exp_Intr is elsif Nam = Name_To_Pointer then Expand_To_Pointer (N); - elsif Nam = Name_File - or else Nam = Name_Line - or else Nam = Name_Source_Location - or else Nam = Name_Enclosing_Entity + elsif Nam_In (Nam, Name_File, + Name_Line, + Name_Source_Location, + Name_Enclosing_Entity) then Expand_Source_Info (N, Nam); diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 2ae1b561907..fba371e2b95 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -377,7 +377,7 @@ package body Exp_Prag is -- For Assert, we just use the location - if Nam = Name_Assertion then + if Nam = Name_Assert then null; -- For predicate, we generate the string "predicate failed @@ -392,10 +392,7 @@ package body Exp_Prag is -- that the failure is not at the point of occurrence of the -- pragma, unlike the other Check cases. - elsif Nam = Name_Precondition - or else - Nam = Name_Postcondition - then + elsif Nam_In (Nam, Name_Precondition, Name_Postcondition) then Get_Name_String (Nam); Insert_Str_In_Name_Buffer ("failed ", 1); Add_Str_To_Name_Buffer (" from "); @@ -449,7 +446,7 @@ package body Exp_Prag is then return; - elsif Nam = Name_Assertion then + elsif Nam = Name_Assert then Error_Msg_N ("?A?assertion will fail at run time", N); else @@ -833,9 +830,9 @@ package body Exp_Prag is -- if Flag then -- if Curr_1 /= Old_1 then - -- pragma Assert (Curr_1 > Old_1); + -- pragma Check (Loop_Variant, Curr_1 > Old_1); -- else - -- pragma Assert (Curr_2 < Old_2); + -- pragma Check (Loop_Variant, Curr_2 < Old_2); -- end if; -- else -- Flag := True; @@ -1002,13 +999,15 @@ package body Exp_Prag is -- Step 5: Create corresponding assertion to verify change of value -- Generate: - -- pragma Assert (Curr <|> Old); + -- pragma Check (Loop_Variant, Curr <|> Old); Prag := Make_Pragma (Loc, - Chars => Name_Assert, + Chars => Name_Check, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Loop_Variant)), + Make_Pragma_Argument_Association (Loc, Expression => Make_Op (Loc, Curr_Val => New_Reference_To (Curr_Id, Loc), @@ -1062,9 +1061,18 @@ package body Exp_Prag is end if; end Process_Variant; - -- Start of processing for Expand_Pragma_Loop_Assertion + -- Start of processing for Expand_Pragma_Loop_Variant begin + -- If pragma is not enabled, rewrite as Null statement. If pragma is + -- disabled, it has already been rewritten as a Null statement. + + if Is_Ignored (N) then + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + return; + end if; + -- Locate the enclosing loop for which this assertion applies. In the -- case of Ada 2012 array iteration, we might be dealing with nested -- loops. Only the outermost loop has an identifier. diff --git a/gcc/ada/exp_alfa.adb b/gcc/ada/exp_spark.adb index 69a6e2b0cec..0050799a104 100644 --- a/gcc/ada/exp_alfa.adb +++ b/gcc/ada/exp_spark.adb @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- E X P _ A L F A -- +-- E X P _ S P A R K -- -- -- -- 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- -- @@ -30,7 +30,6 @@ 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 Nlists; use Nlists; with Rtsfind; use Rtsfind; with Sem_Aux; use Sem_Aux; with Sem_Res; use Sem_Res; @@ -40,46 +39,43 @@ with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; -package body Exp_Alfa is +package body Exp_SPARK is ----------------------- -- Local Subprograms -- ----------------------- - procedure Expand_Alfa_Call (N : Node_Id); + 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_Alfa_N_Attribute_Reference (N : Node_Id); + procedure Expand_SPARK_N_Attribute_Reference (N : Node_Id); -- Expand attributes 'Old and 'Result only - procedure Expand_Alfa_N_In (N : Node_Id); - -- Expand set membership into individual ones - - procedure Expand_Alfa_N_Object_Renaming_Declaration (N : Node_Id); + procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id); -- Perform name evaluation for a renamed object - procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id); + procedure Expand_SPARK_N_Simple_Return_Statement (N : Node_Id); -- Insert conversion on function return if necessary - procedure Expand_Alfa_Simple_Function_Return (N : Node_Id); + 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. - ----------------- - -- Expand_Alfa -- - ----------------- + ------------------ + -- Expand_SPARK -- + ------------------ - procedure Expand_Alfa (N : Node_Id) is + procedure Expand_SPARK (N : Node_Id) is begin case Nkind (N) is when N_Attribute_Reference => - Expand_Alfa_N_Attribute_Reference (N); + 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 @@ -96,15 +92,12 @@ package body Exp_Alfa is Qualify_Entity_Names (N); when N_Subprogram_Call => - Expand_Alfa_Call (N); + Expand_SPARK_Call (N); when N_Expanded_Name | N_Identifier => Expand_Potential_Renaming (N); - when N_In => - Expand_Alfa_N_In (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. @@ -112,23 +105,23 @@ package body Exp_Alfa is Expand_N_Not_In (N); when N_Object_Renaming_Declaration => - Expand_Alfa_N_Object_Renaming_Declaration (N); + Expand_SPARK_N_Object_Renaming_Declaration (N); when N_Simple_Return_Statement => - Expand_Alfa_N_Simple_Return_Statement (N); + Expand_SPARK_N_Simple_Return_Statement (N); - -- In Alfa mode, no other constructs require expansion + -- In SPARK mode, no other constructs require expansion when others => null; end case; - end Expand_Alfa; + end Expand_SPARK; - ---------------------- - -- Expand_Alfa_Call -- - ---------------------- + ----------------------- + -- Expand_SPARK_Call -- + ----------------------- - procedure Expand_Alfa_Call (N : Node_Id) is + procedure Expand_SPARK_Call (N : Node_Id) is Call_Node : constant Node_Id := N; Parent_Subp : Entity_Id; Subp : Entity_Id; @@ -184,13 +177,13 @@ package body Exp_Alfa is Set_Entity (Name (Call_Node), Parent_Subp); end if; - end Expand_Alfa_Call; + end Expand_SPARK_Call; - --------------------------------------- - -- Expand_Alfa_N_Attribute_Reference -- - --------------------------------------- + ---------------------------------------- + -- Expand_SPARK_N_Attribute_Reference -- + ---------------------------------------- - procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id) is + procedure Expand_SPARK_N_Attribute_Reference (N : Node_Id) is Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); begin @@ -202,35 +195,24 @@ package body Exp_Alfa is when others => null; end case; - end Expand_Alfa_N_Attribute_Reference; + end Expand_SPARK_N_Attribute_Reference; - ---------------------- - -- Expand_Alfa_N_In -- - ---------------------- + ------------------------------------------------ + -- Expand_SPARK_N_Object_Renaming_Declaration -- + ------------------------------------------------ - procedure Expand_Alfa_N_In (N : Node_Id) is - begin - if Present (Alternatives (N)) then - Expand_Set_Membership (N); - end if; - end Expand_Alfa_N_In; - - ----------------------------------------------- - -- Expand_Alfa_N_Object_Renaming_Declaration -- - ----------------------------------------------- - - procedure Expand_Alfa_N_Object_Renaming_Declaration (N : Node_Id) is + procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id) is begin -- Unconditionally remove all side effects from the name Evaluate_Name (Name (N)); - end Expand_Alfa_N_Object_Renaming_Declaration; + end Expand_SPARK_N_Object_Renaming_Declaration; - ------------------------------------------- - -- Expand_Alfa_N_Simple_Return_Statement -- - ------------------------------------------- + -------------------------------------------- + -- Expand_SPARK_N_Simple_Return_Statement -- + -------------------------------------------- - procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id) is + 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). @@ -247,7 +229,7 @@ package body Exp_Alfa is when E_Function | E_Generic_Function => - Expand_Alfa_Simple_Function_Return (N); + Expand_SPARK_Simple_Function_Return (N); when E_Procedure | E_Generic_Procedure | @@ -263,13 +245,13 @@ package body Exp_Alfa is exception when RE_Not_Available => return; - end Expand_Alfa_N_Simple_Return_Statement; + end Expand_SPARK_N_Simple_Return_Statement; - ---------------------------------------- - -- Expand_Alfa_Simple_Function_Return -- - ---------------------------------------- + ----------------------------------------- + -- Expand_SPARK_Simple_Function_Return -- + ----------------------------------------- - procedure Expand_Alfa_Simple_Function_Return (N : Node_Id) is + 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 @@ -298,7 +280,7 @@ package body Exp_Alfa is Analyze_And_Resolve (Exp, R_Type); end if; - end Expand_Alfa_Simple_Function_Return; + end Expand_SPARK_Simple_Function_Return; ------------------------------- -- Expand_Potential_Renaming -- @@ -318,4 +300,4 @@ package body Exp_Alfa is end if; end Expand_Potential_Renaming; -end Exp_Alfa; +end Exp_SPARK; diff --git a/gcc/ada/exp_alfa.ads b/gcc/ada/exp_spark.ads index 7b67c8d3cc4..726b69ac014 100644 --- a/gcc/ada/exp_alfa.ads +++ b/gcc/ada/exp_spark.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- E X P _ A L F A -- +-- E X P _ S P A R K -- -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2012, 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- -- @@ -24,13 +24,13 @@ ------------------------------------------------------------------------------ -- This package implements a light expansion which is used in formal --- verification mode (Alfa_Mode = True). Instead of a complete expansion --- of nodes for code generation, this Alfa expansion targets generation +-- verification mode (SPARK_Mode = True). Instead of a complete expansion +-- of nodes for code generation, this SPARK expansion targets generation -- of intermediate code for formal verification. --- Expand_Alfa is called directly by Expander.Expand. +-- Expand_SPARK is called directly by Expander.Expand. --- Alfa expansion has three main objectives: +-- 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 @@ -44,9 +44,9 @@ -- formally, as typically done in the full expansion for high-level -- constructs (tasking, dispatching) --- To fulfill objective 1, Expand_Alfa selectively expands some constructs. +-- To fulfill objective 1, Expand_SPARK selectively expands some constructs. --- To fulfill objective 2, the tree after Alfa expansion should be fully +-- 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 @@ -56,21 +56,22 @@ -- N_Expression_Function: absent (rewitten) -- N_Expression_With_Actions: absent (not generated) --- Alfa 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 Alfa --- cross-references are output in a separate section of ALI files, as --- described in alfa.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. +-- 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_Alfa does not expand features that are not +-- 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 @@ -79,8 +80,8 @@ with Types; use Types; -package Exp_Alfa is +package Exp_SPARK is - procedure Expand_Alfa (N : Node_Id); + procedure Expand_SPARK (N : Node_Id); -end Exp_Alfa; +end Exp_SPARK; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 1900a9fd7ea..0473bfafc1d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -46,7 +46,6 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; -with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; @@ -561,10 +560,10 @@ package body Exp_Util is -- Start of processing for Build_Allocate_Deallocate_Proc begin - -- Do not perform this expansion in Alfa mode because it is not + -- Do not perform this expansion in SPARK mode because it is not -- necessary. - if Alfa_Mode then + if SPARK_Mode then return; end if; @@ -1774,6 +1773,35 @@ 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 -- -------------------- @@ -2011,8 +2039,19 @@ package body Exp_Util is Make_Literal_Range (Loc, Literal_Typ => Exp_Typ))))); + -- If the type of the expression is an internally generated type it + -- may not be necessary to create a new subtype. However there are two + -- exceptions: references to the current instances, and aliased array + -- object declarations for which the backend needs to create a template. + elsif Is_Constrained (Exp_Typ) and then not Is_Class_Wide_Type (Unc_Type) + and then + (Nkind (N) /= N_Object_Declaration + or else not Is_Entity_Name (Expression (N)) + or else not Comes_From_Source (Entity (Expression (N))) + or else not Is_Array_Type (Exp_Typ) + or else not Aliased_Present (N)) then if Is_Itype (Exp_Typ) then @@ -2037,7 +2076,7 @@ package body Exp_Util is end if; end; - -- No need to generate a new one (new what???) + -- No need to generate a new subtype else T := Exp_Typ; @@ -2192,8 +2231,7 @@ package body Exp_Util is return First_Elmt (Access_Disp_Table (Typ)); else - ADT := - Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); + ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))); while Present (ADT) and then Present (Related_Type (Node (ADT))) and then Related_Type (Node (ADT)) /= Iface @@ -2496,7 +2534,10 @@ package body Exp_Util is -- Fully_Qualified_Name_String -- --------------------------------- - function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is + function Fully_Qualified_Name_String + (E : Entity_Id; + Append_NUL : Boolean := True) return String_Id + is procedure Internal_Full_Qualified_Name (E : Entity_Id); -- Compute recursively the qualified name without NUL at the end, adding -- it to the currently started string being generated @@ -2544,7 +2585,11 @@ package body Exp_Util is begin Start_String; Internal_Full_Qualified_Name (E); - Store_String_Char (Get_Char_Code (ASCII.NUL)); + + if Append_NUL then + Store_String_Char (Get_Char_Code (ASCII.NUL)); + end if; + return End_String; end Fully_Qualified_Name_String; @@ -3674,6 +3719,7 @@ package body Exp_Util is N_Push_Storage_Error_Label | N_Qualified_Expression | N_Quantified_Expression | + N_Raise_Expression | N_Range | N_Range_Constraint | N_Real_Literal | @@ -4268,7 +4314,7 @@ package body Exp_Util is -- Look for aspect Default_Iterator if Has_Aspects (Parent (Typ)) then - Aspect := Find_Aspect (Typ, Aspect_Default_Iterator); + Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator); if Present (Aspect) then Iter := Entity (Aspect); @@ -5159,11 +5205,9 @@ package body Exp_Util is -- True if access attribute elsif Nkind (N) = N_Attribute_Reference - and then (Attribute_Name (N) = Name_Access - or else - Attribute_Name (N) = Name_Unchecked_Access - or else - Attribute_Name (N) = Name_Unrestricted_Access) + and then Nam_In (Attribute_Name (N), Name_Access, + Name_Unchecked_Access, + Name_Unrestricted_Access) then return True; @@ -5422,26 +5466,29 @@ package body Exp_Util is function Make_Invariant_Call (Expr : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Expr); - Typ : constant Entity_Id := Etype (Expr); + Typ : Entity_Id; begin - pragma Assert - (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ))); + Typ := Etype (Expr); - if Check_Enabled (Name_Invariant) - or else - Check_Enabled (Name_Assertion) - then - return - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Invariant_Procedure (Typ), Loc), - Parameter_Associations => New_List (Relocate_Node (Expr))); + -- Subtypes may be subject to invariants coming from their respective + -- base types. - else - return - Make_Null_Statement (Loc); + if Ekind_In (Typ, E_Array_Subtype, + E_Private_Subtype, + E_Record_Subtype) + then + Typ := Base_Type (Typ); end if; + + pragma Assert + (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ))); + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Invariant_Procedure (Typ), Loc), + Parameter_Associations => New_List (Relocate_Node (Expr))); end Make_Invariant_Call; ------------------------ @@ -5519,18 +5566,36 @@ package body Exp_Util is function Make_Predicate_Call (Typ : Entity_Id; - Expr : Node_Id) return Node_Id + Expr : Node_Id; + Mem : Boolean := False) return Node_Id is Loc : constant Source_Ptr := Sloc (Expr); begin pragma Assert (Present (Predicate_Function (Typ))); + -- Call special membership version if requested and available + + if Mem then + declare + PFM : constant Entity_Id := Predicate_Function_M (Typ); + begin + if Present (PFM) then + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (PFM, Loc), + Parameter_Associations => New_List (Relocate_Node (Expr))); + end if; + end; + end if; + + -- Case of calling normal predicate function + return - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (Predicate_Function (Typ), Loc), - Parameter_Associations => New_List (Relocate_Node (Expr))); + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Predicate_Function (Typ), Loc), + Parameter_Associations => New_List (Relocate_Node (Expr))); end Make_Predicate_Call; -------------------------- @@ -5542,14 +5607,34 @@ package body Exp_Util is Expr : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Expr); + Nam : Name_Id; begin + -- If predicate checks are suppressed, then return a null statement. + -- For this call, we check only the scope setting. If the caller wants + -- to check a specific entity's setting, they must do it manually. + + if Predicate_Checks_Suppressed (Empty) then + return Make_Null_Statement (Loc); + end if; + + -- Compute proper name to use, we need to get this right so that the + -- right set of check policies apply to the Check pragma we are making. + + if Has_Dynamic_Predicate_Aspect (Typ) then + Nam := Name_Dynamic_Predicate; + elsif Has_Static_Predicate_Aspect (Typ) then + Nam := Name_Static_Predicate; + else + Nam := Name_Predicate; + end if; + return Make_Pragma (Loc, Pragma_Identifier => Make_Identifier (Loc, Name_Check), Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Predicate)), + Expression => Make_Identifier (Loc, Nam)), Make_Pragma_Argument_Association (Loc, Expression => Make_Predicate_Call (Typ, Expr)))); end Make_Predicate_Check; @@ -6914,10 +6999,13 @@ package body Exp_Util is -- Otherwise we generate a reference to the value else - -- An expression which is in Alfa mode is considered side effect free - -- if the resulting value is captured by a variable or a constant. + -- An expression which is in SPARK mode is considered side effect + -- free if the resulting value is captured by a variable or a + -- constant. - if Alfa_Mode and then Nkind (Parent (Exp)) = N_Object_Declaration then + if SPARK_Mode + and then Nkind (Parent (Exp)) = N_Object_Declaration + then goto Leave; end if; @@ -6957,11 +7045,11 @@ package body Exp_Util is -- The regular expansion of functions with side effects involves the -- generation of an access type to capture the return value found on - -- the secondary stack. Since Alfa (and why) cannot process access + -- the secondary stack. Since SPARK (and why) cannot process access -- types, use a different approach which ignores the secondary stack -- and "copies" the returned object. - if Alfa_Mode then + if SPARK_Mode then Res := New_Reference_To (Def_Id, Loc); Ref_Type := Exp_Type; @@ -6995,10 +7083,10 @@ package body Exp_Util is else E := Relocate_Node (E); - -- Do not generate a 'reference in Alfa mode since the access type - -- is not created in the first place. + -- Do not generate a 'reference in SPARK mode since the access + -- type is not created in the first place. - if Alfa_Mode then + if SPARK_Mode then New_Exp := E; -- Otherwise generate reference, marking the value as non-null @@ -7965,13 +8053,7 @@ package body Exp_Util is -- Prevent the search from going too far - elsif Nkind_In (Par, N_Entry_Body, - N_Package_Body, - N_Package_Declaration, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) - then + elsif Is_Body_Or_Package_Declaration (Par) then return False; end if; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index e0b0e09f88b..568b9f7d5c1 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -345,10 +345,14 @@ package Exp_Util is -- This procedure ensures that type referenced by Typ is defined. For the -- case of a type other than an Itype, nothing needs to be done, since -- all such types have declaration nodes. For Itypes, an N_Itype_Reference - -- node is generated and inserted at the given node N. This is typically + -- node is generated and inserted as an action on node N. This is typically -- 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 @@ -438,9 +442,12 @@ package Exp_Util is -- Force_Evaluation further guarantees that all evaluations will yield -- the same result. - function Fully_Qualified_Name_String (E : Entity_Id) return String_Id; + function Fully_Qualified_Name_String + (E : Entity_Id; + Append_NUL : Boolean := True) return String_Id; -- Generates the string literal corresponding to the fully qualified name - -- of entity E with an ASCII.NUL appended at the end of the name. + -- of entity E, in all upper case, with an ASCII.NUL appended at the end + -- of the name if Append_NUL is True. procedure Generate_Poll_Call (N : Node_Id); -- If polling is active, then a call to the Poll routine is built, @@ -647,16 +654,20 @@ package Exp_Util is function Make_Predicate_Call (Typ : Entity_Id; - Expr : Node_Id) return Node_Id; + Expr : Node_Id; + Mem : Boolean := False) return Node_Id; -- Typ is a type with Predicate_Function set. This routine builds a call to -- this function passing Expr as the argument, and returns it unanalyzed. + -- If Mem is set True, this is the special call for the membership case, + -- and the function called is the Predicate_Function_M if present. function Make_Predicate_Check (Typ : Entity_Id; Expr : Node_Id) return Node_Id; -- Typ is a type with Predicate_Function set. This routine builds a Check - -- pragma whose first argument is Predicate, and the second argument is a - -- call to the this predicate function with Expr as the argument. + -- pragma whose first argument is Predicate, and the second argument is + -- a call to the predicate function of Typ with Expr as the argument. If + -- Predicate_Check is suppressed then a null statement is returned instead. function Make_Subtype_From_Expr (E : Node_Id; diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 83a692067cf..a037dd3790c 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.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- -- @@ -23,29 +23,29 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; -with Debug_A; use Debug_A; -with Exp_Aggr; use Exp_Aggr; -with Exp_Alfa; use Exp_Alfa; -with Exp_Attr; use Exp_Attr; -with Exp_Ch2; use Exp_Ch2; -with Exp_Ch3; use Exp_Ch3; -with Exp_Ch4; use Exp_Ch4; -with Exp_Ch5; use Exp_Ch5; -with Exp_Ch6; use Exp_Ch6; -with Exp_Ch7; use Exp_Ch7; -with Exp_Ch8; use Exp_Ch8; -with Exp_Ch9; use Exp_Ch9; -with Exp_Ch11; use Exp_Ch11; -with Exp_Ch12; use Exp_Ch12; -with Exp_Ch13; use Exp_Ch13; -with Exp_Prag; use Exp_Prag; -with Opt; use Opt; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Ch8; use Sem_Ch8; -with Sem_Util; use Sem_Util; -with Sinfo; use Sinfo; +with Atree; use Atree; +with Debug_A; use Debug_A; +with Exp_Aggr; use Exp_Aggr; +with Exp_SPARK; use Exp_SPARK; +with Exp_Attr; use Exp_Attr; +with Exp_Ch2; use Exp_Ch2; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch4; use Exp_Ch4; +with Exp_Ch5; use Exp_Ch5; +with Exp_Ch6; use Exp_Ch6; +with Exp_Ch7; use Exp_Ch7; +with Exp_Ch8; use Exp_Ch8; +with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; +with Exp_Ch12; use Exp_Ch12; +with Exp_Ch13; use Exp_Ch13; +with Exp_Prag; use Exp_Prag; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; with Table; package body Expander is @@ -127,13 +127,13 @@ package body Expander is Debug_A_Entry ("expanding ", N); begin - -- In Alfa mode we only need a very limited subset of the usual - -- expansions. This limited subset is implemented in Expand_Alfa. + -- In SPARK mode we only need a very limited subset of the usual + -- expansions. This limited subset is implemented in Expand_SPARK. - if Alfa_Mode then - Expand_Alfa (N); + if SPARK_Mode then + Expand_SPARK (N); - -- Here for normal non-Alfa mode + -- Here for normal non-SPARK mode else -- Processing depends on node kind. For full details on the @@ -388,6 +388,9 @@ package body Expander is when N_Raise_Constraint_Error => Expand_N_Raise_Constraint_Error (N); + when N_Raise_Expression => + Expand_N_Raise_Expression (N); + when N_Raise_Program_Error => Expand_N_Raise_Program_Error (N); diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 552a8bf1ae9..1c5aac42b14 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.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- * @@ -263,10 +263,14 @@ extern void Set_Has_No_Elaboration_Code (Node_Id, Boolean); /* targparm: */ #define Backend_Overflow_Checks_On_Target targparm__backend_overflow_checks_on_target +#define Machine_Overflows_On_Target targparm__machine_overflows_on_target +#define Signed_Zeros_On_Target targparm__signed_zeros_on_target #define Stack_Check_Probes_On_Target targparm__stack_check_probes_on_target #define Stack_Check_Limits_On_Target targparm__stack_check_limits_on_target extern Boolean Backend_Overflow_Checks_On_Target; +extern Boolean Machine_Overflows_On_Target; +extern Boolean Signed_Zeros_On_Target; extern Boolean Stack_Check_Probes_On_Target; extern Boolean Stack_Check_Limits_On_Target; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 234cdd2cb42..88a8f6df656 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.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- -- @@ -249,12 +249,13 @@ package body Freeze is -- has an interface name, or if it is one of the shift/rotate -- operations known to the compiler. - and then (Present (Interface_Name (Renamed_Subp)) - or else Chars (Renamed_Subp) = Name_Rotate_Left - or else Chars (Renamed_Subp) = Name_Rotate_Right - or else Chars (Renamed_Subp) = Name_Shift_Left - or else Chars (Renamed_Subp) = Name_Shift_Right - or else Chars (Renamed_Subp) = Name_Shift_Right_Arithmetic) + and then + (Present (Interface_Name (Renamed_Subp)) + or else Nam_In (Chars (Renamed_Subp), Name_Rotate_Left, + Name_Rotate_Right, + Name_Shift_Left, + Name_Shift_Right, + Name_Shift_Right_Arithmetic)) then Set_Interface_Name (Ent, Interface_Name (Renamed_Subp)); @@ -1834,9 +1835,8 @@ package body Freeze is begin case Nkind (N) is when N_Attribute_Reference => - if (Attribute_Name (N) = Name_Access - or else - Attribute_Name (N) = Name_Unchecked_Access) + if Nam_In (Attribute_Name (N), Name_Access, + Name_Unchecked_Access) and then Is_Entity_Name (Prefix (N)) and then Is_Type (Entity (Prefix (N))) and then Entity (Prefix (N)) = E @@ -2584,13 +2584,13 @@ package body Freeze is and then RM_Size (Rec) >= Scalar_Component_Total_RM_Size - -- Never do implicit packing in CodePeer or Alfa modes since + -- Never do implicit packing in CodePeer or SPARK modes since -- we don't do any packing in these modes, since this generates -- over-complex code that confuses static analysis, and in -- general, neither CodePeer not GNATprove care about the -- internal representation of objects. - and then not (CodePeer_Mode or Alfa_Mode) + and then not (CodePeer_Mode or SPARK_Mode) then -- If implicit packing enabled, do it @@ -3119,11 +3119,11 @@ package body Freeze is if Is_Subprogram (E) and then Is_Imported (E) and then Present (Contract (E)) - and then Present (Spec_PPC_List (Contract (E))) + and then Present (Pre_Post_Conditions (Contract (E))) then Error_Msg_NE - ("pre/post conditions on imported subprogram " - & "are not enforced??", E, Spec_PPC_List (Contract (E))); + ("pre/post conditions on imported subprogram are not " + & "enforced??", E, Pre_Post_Conditions (Contract (E))); end if; end if; @@ -3442,7 +3442,7 @@ package body Freeze is and then not Is_Limited_Composite (E) and then not Is_Packed (Root_Type (E)) and then not Has_Component_Size_Clause (Root_Type (E)) - and then not (CodePeer_Mode or Alfa_Mode) + and then not (CodePeer_Mode or SPARK_Mode) then Get_Index_Bounds (First_Index (E), Lo, Hi); @@ -3484,7 +3484,7 @@ package body Freeze is Set_Is_Packed (Btyp); Set_Has_Non_Standard_Rep (Btyp); - -- Otherwise give an error message + -- Otherwise give an error message else Error_Msg_NE @@ -3913,27 +3913,92 @@ package body Freeze is end if; end if; - -- For bit-packed arrays, check the size + -- Specific checks for bit-packed arrays - if Is_Bit_Packed_Array (E) and then Known_RM_Size (E) then - declare - SizC : constant Node_Id := Size_Clause (E); + if Is_Bit_Packed_Array (E) then - Discard : Boolean; - pragma Warnings (Off, Discard); + -- 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. - 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. + -- For the case where this is not compile time known, a + -- run-time check should be generated??? - 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; + 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 @@ -4550,9 +4615,9 @@ package body Freeze is begin pragma Assert - (Op_Name = Name_Allocate - or else Op_Name = Name_Deallocate - or else Op_Name = Name_Storage_Size); + (Nam_In (Op_Name, Name_Allocate, + Name_Deallocate, + Name_Storage_Size)); Error_Msg_Name_1 := Op_Name; @@ -4601,7 +4666,8 @@ package body Freeze is if Op_Name = Name_Allocate then Validate_Simple_Pool_Op_Formal (Op, Formal, E_Out_Parameter, - Address_Type, "Storage_Address", Is_OK); + Address_Type, "Storage_Address", Is_OK); + elsif Op_Name = Name_Deallocate then Validate_Simple_Pool_Op_Formal (Op, Formal, E_In_Parameter, diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 749e94875d7..7c56ac9789f 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.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- -- @@ -56,6 +56,7 @@ with Sem_Ch8; use Sem_Ch8; with Sem_SCIL; with Sem_Elab; use Sem_Elab; with Sem_Prag; use Sem_Prag; +with Sem_VFpt; use Sem_VFpt; with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Sinput; use Sinput; @@ -181,6 +182,21 @@ begin Config_Pragmas := Empty_List; end if; + -- Check for VAX Float + + if Targparm.VAX_Float_On_Target then + + -- pragma Float_Representation (VAX_Float); + + Opt.Float_Format := 'V'; + + -- pragma Long_Float (G_Float); + + Opt.Float_Format_Long := 'G'; + + Set_Standard_Fpt_Formats; + end if; + -- Now deal with specified config pragmas files if there are any if Opt.Config_File_Names /= null then diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index c7b71208ff0..bafd224f5b9 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2012, 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- -- @@ -200,6 +200,12 @@ package body GNAT.Sockets is -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to -- FD_SETSIZE, on platforms where fd_set is a bitmap. + function Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type) return C.int; + pragma Inline (Connect_Socket); + -- Underlying implementation for the Connect_Socket procedures + -- Types needed for Datagram_Socket_Stream_Type type Datagram_Socket_Stream_Type is new Root_Stream_Type with record @@ -510,10 +516,6 @@ package body GNAT.Sockets is (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout); end Check_Selector; - -------------------- - -- Check_Selector -- - -------------------- - procedure Check_Selector (Selector : Selector_Type; R_Socket_Set : in out Socket_Set_Type; @@ -662,11 +664,10 @@ package body GNAT.Sockets is -- Connect_Socket -- -------------------- - procedure Connect_Socket + function Connect_Socket (Socket : Socket_Type; - Server : Sock_Addr_Type) + Server : Sock_Addr_Type) return C.int is - Res : C.int; Sin : aliased Sockaddr_In; Len : constant C.int := Sin'Size / 8; @@ -681,17 +682,19 @@ package body GNAT.Sockets is (Sin'Unchecked_Access, Short_To_Network (C.unsigned_short (Server.Port))); - Res := C_Connect (C.int (Socket), Sin'Address, Len); + return C_Connect (C.int (Socket), Sin'Address, Len); + end Connect_Socket; - if Res = Failure then + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type) + is + begin + if Connect_Socket (Socket, Server) = Failure then Raise_Socket_Error (Socket_Errno); end if; end Connect_Socket; - -------------------- - -- Connect_Socket -- - -------------------- - procedure Connect_Socket (Socket : Socket_Type; Server : Sock_Addr_Type; @@ -719,28 +722,32 @@ package body GNAT.Sockets is Req := (Name => Non_Blocking_IO, Enabled => True); Control_Socket (Socket, Request => Req); - -- Start operation (non-blocking), will raise Socket_Error with - -- EINPROGRESS. + -- Start operation (non-blocking), will return Failure with errno set + -- to EINPROGRESS. - begin - Connect_Socket (Socket, Server); - exception - when E : Socket_Error => - if Resolve_Exception (E) = Operation_Now_In_Progress then - null; - else - raise; - end if; - end; + Res := Connect_Socket (Socket, Server); + if Res = Failure then + Conn_Err := Socket_Errno; + if Conn_Err /= SOSC.EINPROGRESS then + Raise_Socket_Error (Conn_Err); + end if; + end if; - -- Wait for socket to become available for writing + -- Wait for socket to become available for writing (unless the Timeout + -- is zero, in which case we consider that it has already expired, and + -- we do not need to wait at all). - Wait_On_Socket - (Socket => Socket, - For_Read => False, - Timeout => Timeout, - Selector => Selector, - Status => Status); + if Timeout = 0.0 then + Status := Expired; + + else + Wait_On_Socket + (Socket => Socket, + For_Read => False, + Timeout => Timeout, + Selector => Selector, + Status => Status); + end if; -- Check error condition (the asynchronous connect may have terminated -- with an error, e.g. ECONNREFUSED) if select(2) completed. @@ -2204,6 +2211,22 @@ package body GNAT.Sockets is Insert_Socket_In_Set (Item.Set'Access, C.int (Socket)); end Set; + ----------------------- + -- Set_Close_On_Exec -- + ----------------------- + + procedure Set_Close_On_Exec + (Socket : Socket_Type; + Close_On_Exec : Boolean; + Status : out Boolean) + is + function C_Set_Close_On_Exec + (Socket : Socket_Type; Close_On_Exec : C.int) return C.int; + pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); + begin + Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0; + end Set_Close_On_Exec; + ---------------------- -- Set_Forced_Flags -- ---------------------- @@ -2462,8 +2485,8 @@ package body GNAT.Sockets is Aliases_Count, Addresses_Count : Natural; - -- H_Length is not used because it is currently only set to 4 - -- H_Addrtype is always AF_INET + -- H_Length is not used because it is currently only ever set to 4, as + -- H_Addrtype is always AF_INET. begin Aliases_Count := 0; @@ -2491,10 +2514,24 @@ package body GNAT.Sockets is for J in Result.Addresses'Range loop declare Addr : In_Addr; - for Addr'Address use - Hostent_H_Addr (E, C.int (J - Result.Addresses'First)); - pragma Import (Ada, Addr); + + -- Hostent_H_Addr (E, <index>) may return an address that is + -- not correctly aligned for In_Addr, so we need to use + -- an intermediate copy operation on a type with an alignemnt + -- of 1 to recover the value. + + subtype Addr_Buf_T is C.char_array (1 .. Addr'Size / 8); + Unaligned_Addr : Addr_Buf_T; + for Unaligned_Addr'Address + use Hostent_H_Addr (E, C.int (J - Result.Addresses'First)); + pragma Import (Ada, Unaligned_Addr); + + Aligned_Addr : Addr_Buf_T; + for Aligned_Addr'Address use Addr'Address; + pragma Import (Ada, Aligned_Addr); + begin + Aligned_Addr := Unaligned_Addr; To_Inet_Addr (Addr, Result.Addresses (J)); end; end loop; diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 462556265a6..c543707097a 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -858,7 +858,9 @@ package GNAT.Sockets is -- whether the operation completed successfully, timed out, or was aborted. -- If Selector is not null, the designated selector is used to wait for the -- socket to become available, else a private selector object is created - -- by this procedure and destroyed before it returns. + -- by this procedure and destroyed before it returns. If Timeout is 0.0, + -- no attempt is made to detect whether the connection has succeeded; it + -- is up to the user to determine this using Check_Selector later on. procedure Control_Socket (Socket : Socket_Type; @@ -977,6 +979,17 @@ package GNAT.Sockets is -- socket. Count is set to the count of transmitted stream elements. Flags -- allow control over transmission. + procedure Set_Close_On_Exec + (Socket : Socket_Type; + Close_On_Exec : Boolean; + Status : out Boolean); + -- When Close_On_Exec is True, mark Socket to be closed automatically when + -- a new program is executed by the calling process (i.e. prevent Socket + -- from being inherited by child processes). When Close_On_Exec is False, + -- mark Socket to not be closed on exec (i.e. allow it to be inherited). + -- Status is False if the operation could not be performed, or is not + -- supported on the target platform. + procedure Set_Socket_Option (Socket : Socket_Type; Level : Level_Type := Socket_Level; diff --git a/gcc/ada/g-spipat.ads b/gcc/ada/g-spipat.ads index 5ba0bdd811d..27cd8d564e1 100644 --- a/gcc/ada/g-spipat.ads +++ b/gcc/ada/g-spipat.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2010, AdaCore -- +-- Copyright (C) 1997-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- -- @@ -729,7 +729,7 @@ package GNAT.Spitbol.Patterns is function "*" (P : PString; Var : VString_Var) return Pattern; function "*" (P : PChar; Var : VString_Var) return Pattern; -- Matches P, and if the match succeeds, assigns the matched substring - -- to the given VString variable S. This assignment happens as soon as + -- to the given VString variable Var. This assignment happens as soon as -- the substring is matched, and if the pattern P1 is matched more than -- once during the course of the match, then the assignment will occur -- more than once. diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 57f90090dcf..4fed34fc524 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -185,6 +185,7 @@ endif GCC_LINKERFLAGS = $(filter-out -Werror, $(ALL_LINKERFLAGS)) GCC_LINK=$(LINKER) $(GCC_LINKERFLAGS) $(LDFLAGS) +GCC_LLINK=$(LLINKER) $(GCC_LINKERFLAGS) $(LDFLAGS) # Lists of files for various purposes. @@ -204,7 +205,7 @@ GNAT_ADA_OBJS = \ ada/a-except.o \ ada/a-ioexce.o \ ada/ada.o \ - ada/alfa.o \ + ada/spark_xrefs.o \ ada/ali.o \ ada/alloc.o \ ada/aspects.o \ @@ -224,7 +225,7 @@ GNAT_ADA_OBJS = \ ada/erroutc.o \ ada/eval_fat.o \ ada/exp_aggr.o \ - ada/exp_alfa.o \ + ada/exp_spark.o \ ada/exp_atag.o \ ada/exp_attr.o \ ada/exp_cg.o \ @@ -266,7 +267,7 @@ GNAT_ADA_OBJS = \ ada/g-spchge.o \ ada/g-speche.o \ ada/g-u3spch.o \ - ada/get_alfa.o \ + ada/get_spark_xrefs.o \ ada/get_targ.o \ ada/gnat.o \ ada/gnatvsn.o \ @@ -295,7 +296,7 @@ GNAT_ADA_OBJS = \ ada/par_sco.o \ ada/prep.o \ ada/prepcomp.o \ - ada/put_alfa.o \ + ada/put_spark_xrefs.o \ ada/put_scos.o \ ada/repinfo.o \ ada/restrict.o \ @@ -386,6 +387,7 @@ GNAT_ADA_OBJS = \ ada/sem_util.o \ ada/sem_vfpt.o \ ada/sem_warn.o \ + ada/set_targ.o \ ada/sinfo-cn.o \ ada/sinfo.o \ ada/sinput-d.o \ @@ -561,7 +563,8 @@ TARGET_ADA_SRCS = # Since the RTL should be built with the latest compiler, remove the # stamp target in the parent directory whenever gnat1 is rebuilt gnat1$(exeext): $(TARGET_ADA_SRCS) $(GNAT1_OBJS) $(ADA_BACKEND) libcommon-target.a $(LIBDEPS) - +$(GCC_LINK) -o $@ $(GNAT1_OBJS) $(ADA_BACKEND) libcommon-target.a $(LIBS) $(SYSLIBS) $(BACKENDLIBS) $(CFLAGS) + +$(GCC_LLINK) -o $@ $(GNAT1_OBJS) $(ADA_BACKEND) \ + libcommon-target.a $(LIBS) $(SYSLIBS) $(BACKENDLIBS) $(CFLAGS) $(RM) stamp-gnatlib2-rts stamp-tools gnatbind$(exeext): ada/b_gnatb.o $(CONFIG_H) $(GNATBIND_OBJS) ggc-none.o libcommon-target.a $(LIBDEPS) @@ -1076,15 +1079,6 @@ ada/a-ioexce.o : ada/ada.ads ada/a-except.ads ada/a-ioexce.ads \ ada/ada.o : ada/ada.ads ada/system.ads -ada/alfa.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alfa.ads ada/alfa.adb ada/gnat.ads ada/g-table.ads \ - ada/g-table.adb ada/hostparm.ads ada/output.ads ada/output.adb \ - ada/put_alfa.ads ada/put_alfa.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/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 \ @@ -1268,24 +1262,25 @@ ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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_alfa.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_prag.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/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/widechar.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/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/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 \ @@ -1313,31 +1308,32 @@ ada/csets.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/csets.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/back_end.ads 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_alfa.ads ada/restrict.ads ada/rident.ads ada/rtsfind.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/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/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 @@ -1447,42 +1443,25 @@ ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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_alfa.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_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.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/validsw.ads \ - ada/widechar.ads - -ada/exp_alfa.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_alfa.ads ada/exp_alfa.adb ada/exp_attr.ads ada/exp_ch4.ads \ - ada/exp_ch6.ads ada/exp_dbug.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - 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/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/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 \ @@ -1522,42 +1501,44 @@ ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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_alfa.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/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/widechar.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/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/lib.ads ada/namet.ads \ - 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/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 \ @@ -1628,16 +1609,17 @@ ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/namet.ads 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-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/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 \ @@ -1652,25 +1634,26 @@ ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/itypes.ads ada/layout.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/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_mech.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_scil.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/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/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/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 \ @@ -1684,50 +1667,50 @@ ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/output.ads ada/par_sco.ads \ - ada/put_alfa.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_prag.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.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/widechar.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/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/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_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_alfa.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_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.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 \ @@ -1757,27 +1740,28 @@ ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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_alfa.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/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/validsw.ads ada/widechar.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/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/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 \ @@ -1793,25 +1777,25 @@ ada/exp_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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_alfa.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/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/widechar.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/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 \ @@ -1824,8 +1808,8 @@ ada/exp_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_prag.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + 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 \ @@ -1850,24 +1834,25 @@ ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.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_prag.ads ada/sem_res.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_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/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/widechar.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/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 \ @@ -1880,23 +1865,23 @@ ada/exp_code.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.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/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/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 \ @@ -1926,27 +1911,28 @@ ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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/itypes.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/opt.adb ada/output.ads ada/put_alfa.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_prag.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb 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/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/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 \ @@ -1961,16 +1947,17 @@ ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/widechar.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/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 \ @@ -2005,8 +1992,8 @@ ada/exp_imgv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.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 \ @@ -2030,23 +2017,24 @@ ada/exp_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.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_prag.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - 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/widechar.ads + 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/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 \ @@ -2062,8 +2050,8 @@ ada/exp_pakd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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_prag.ads 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/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 \ @@ -2082,21 +2070,21 @@ ada/exp_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/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/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 \ @@ -2128,6 +2116,23 @@ ada/exp_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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/nlists.adb \ + 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 \ @@ -2136,15 +2141,15 @@ ada/exp_strm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/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 \ @@ -2175,17 +2180,18 @@ ada/exp_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/itypes.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/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/sinfo.ads ada/sinfo.adb ada/sinput.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 \ @@ -2217,10 +2223,10 @@ 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_alfa.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_tss.ads ada/expander.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 \ @@ -2280,31 +2286,32 @@ ada/freeze.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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_alfa.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/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/widechar.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/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 \ @@ -2321,18 +2328,18 @@ ada/frontend.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_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/widechar.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/widechar.ads ada/g-byorma.o : ada/gnat.ads ada/g-byorma.ads ada/g-byorma.adb \ ada/system.ads @@ -2353,16 +2360,22 @@ 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_alfa.o : ada/ada.ads ada/a-ioexce.ads ada/a-unccon.ads \ - ada/alfa.ads ada/get_alfa.ads ada/get_alfa.adb ada/gnat.ads \ - ada/g-table.ads ada/g-table.adb 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-unccon.ads ada/get_targ.ads \ - ada/get_targ.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.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-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 \ @@ -2377,21 +2390,22 @@ ada/gnat1drv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.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/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/widechar.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/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 \ @@ -2485,12 +2499,12 @@ ada/layout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.ads ada/repinfo.ads ada/repinfo.adb \ + 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/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.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 \ @@ -2541,58 +2555,58 @@ ada/lib-writ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/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_alfa.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/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-xref.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alfa.ads ada/alfa.adb 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/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-xref.ads ada/lib-xref.adb \ - ada/lib-xref-alfa.adb ada/namet.ads 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_alfa.ads ada/put_alfa.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/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + 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/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/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 \ @@ -2739,25 +2753,26 @@ ada/par.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ 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_alfa.ads ada/restrict.ads ada/rident.ads \ + 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/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/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 \ @@ -2813,12 +2828,6 @@ ada/prepcomp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.o : ada/ada.ads ada/a-unccon.ads ada/alfa.ads ada/gnat.ads \ - ada/g-table.ads ada/g-table.adb ada/put_alfa.ads ada/put_alfa.adb \ - 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/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-table.ads ada/g-table.adb ada/hostparm.ads ada/namet.ads \ @@ -2829,6 +2838,12 @@ ada/put_scos.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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-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 \ @@ -2836,16 +2851,16 @@ ada/repinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/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 \ @@ -3147,13 +3162,13 @@ ada/sem_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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_alfa.ads ada/restrict.ads ada/rident.ads ada/rtsfind.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_prag.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.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 \ @@ -3178,20 +3193,21 @@ ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.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-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/output.ads \ - ada/put_alfa.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/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-load.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/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 \ @@ -3247,22 +3263,22 @@ ada/sem_cat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.ads \ + 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/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_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 \ @@ -3273,29 +3289,30 @@ ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/par_sco.ads ada/put_alfa.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/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/widechar.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/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 \ @@ -3304,7 +3321,7 @@ ada/sem_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.ads ada/restrict.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 \ @@ -3331,28 +3348,29 @@ ada/sem_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.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/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/widechar.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/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/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 \ @@ -3363,30 +3381,31 @@ ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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_alfa.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/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/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 \ @@ -3413,31 +3432,32 @@ ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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_alfa.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/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/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/widechar.ads @@ -3450,28 +3470,29 @@ ada/sem_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/output.ads ada/put_alfa.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/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/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 \ @@ -3488,7 +3509,7 @@ ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.ads ada/restrict.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/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 \ @@ -3499,18 +3520,18 @@ ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/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/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 \ @@ -3522,20 +3543,21 @@ ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/opt.adb ada/output.ads \ - ada/put_alfa.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/sinfo.ads ada/sinfo.adb ada/sinfo-cn.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 \ @@ -3557,27 +3579,27 @@ ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/output.ads ada/put_alfa.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/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/widechar.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/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 \ @@ -3588,21 +3610,22 @@ ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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_alfa.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/sinfo.ads ada/sinfo.adb \ + 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 \ @@ -3629,27 +3652,28 @@ ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.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/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/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/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 \ @@ -3662,24 +3686,24 @@ ada/sem_dim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.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/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_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 \ @@ -3690,15 +3714,16 @@ ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/itypes.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/opt.adb ada/output.ads ada/put_alfa.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/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 \ @@ -3708,7 +3733,8 @@ ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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 \ @@ -3735,26 +3761,27 @@ ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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_alfa.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/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/widechar.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/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 \ @@ -3784,17 +3811,18 @@ ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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_alfa.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/sinfo.ads ada/sinfo.adb \ + 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 \ @@ -3805,41 +3833,43 @@ ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/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/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/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/namet.ads 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-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/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 \ @@ -3858,7 +3888,7 @@ ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.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 \ @@ -3870,21 +3900,21 @@ ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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_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 \ @@ -3897,11 +3927,12 @@ ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_alfa.ads ada/restrict.ads ada/restrict.adb \ + 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 \ @@ -3911,19 +3942,20 @@ ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/widechar.ads + 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/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 \ @@ -3958,26 +3990,27 @@ ada/sem_type.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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/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_alfa.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/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/widechar.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/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 \ @@ -3992,27 +4025,27 @@ ada/sem_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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_alfa.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/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/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/widechar.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/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 \ @@ -4033,15 +4066,16 @@ ada/sem_warn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/par_sco.ads \ - ada/put_alfa.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/sinfo.ads ada/sinfo.adb \ + 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 \ @@ -4054,6 +4088,16 @@ ada/sem_warn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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 \ @@ -4149,6 +4193,16 @@ ada/snames.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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-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 \ @@ -4229,16 +4283,17 @@ ada/switch-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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/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/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/unchconv.ads ada/unchdeal.ads \ - ada/validsw.ads ada/warnsw.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 \ @@ -4353,9 +4408,15 @@ ada/treeprs.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ 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-unccon.ads ada/get_targ.ads \ - ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \ - ada/ttypes.ads ada/types.ads ada/unchconv.ads ada/unchdeal.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 \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 0ddde729425..6aa93c4655a 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -259,7 +259,7 @@ TOOLS_LIBS = targext.o link.o ../../ggc-none.o ../../libcommon-target.a \ # manufacturer, and operating system and assign each of those to its own # variable. host:=$(subst -, ,$(host_canonical)) -targ:=$(subst -, ,$(target)) +targ:=$(subst -, ,$(subst -gnu, ,$(target_alias))) arch:=$(word 1,$(targ)) ifeq ($(words $(targ)),2) manu:= @@ -995,7 +995,7 @@ ifeq ($(strip $(filter-out mips% wrs vx%,$(targ))),) EXTRA_LIBGNAT_OBJS+=vx_stack_info.o endif -ifeq ($(strip $(filter-out arm% linux-androideabi,$(arch) $(osys)-$(word 4,$(targ)))),) +ifeq ($(strip $(filter-out arm% androideabi,$(arch) $(osys))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-linux.ads \ s-inmaop.adb<s-inmaop-posix.adb \ @@ -1098,7 +1098,7 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(targ))),) endif # x86 and x86-64 solaris -ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(arch) $(osys))),) +ifeq ($(strip $(filter-out %86 %x86_64 %amd64 solaris2%,$(arch) $(osys))),) LIBGNAT_TARGET_PAIRS_COMMON = \ a-intnam.ads<a-intnam-solaris.ads \ s-inmaop.adb<s-inmaop-posix.adb \ @@ -1592,7 +1592,7 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ))) endif # *-elf -ifeq ($(strip $(filter-out avr none powerpc% eabispe leon% erc32% unknown elf,$(targ))),) +ifeq ($(strip $(filter-out lmp avr none powerpc% eabispe leon% erc32% unknown elf,$(targ))),) TOOLS_TARGET_PAIRS=\ mlib-tgt-specific.adb<mlib-tgt-specific-xi.adb \ indepsw.adb<indepsw-gnu.adb @@ -2363,6 +2363,7 @@ ADA_EXCLUDE_SRCS =\ s-bbsuer.ads s-bbsule.ads s-bbthqu.adb s-bbthqu.ads s-bbthre.adb \ s-bbthre.ads s-bbtiev.adb s-bbtiev.ads s-bbtime.adb s-bbtime.ads \ s-bcprmu.adb s-bcprmu.ads s-btstch.adb s-btstch.ads \ + s-init.ads s-init.adb \ s-po32gl.adb s-po32gl.ads \ s-stache.adb s-stache.ads \ s-thread.ads \ @@ -2519,11 +2520,11 @@ gnatlink-re: ../stamp-tools link.o targext.o gnatmake-re # Likewise for the tools ../../gnatmake$(exeext): $(P) b_gnatm.o link.o targext.o $(GNATMAKE_OBJS) - $(GCC_LINK) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatm.o $(GNATMAKE_OBJS) \ + +$(GCC_LINK) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatm.o $(GNATMAKE_OBJS) \ $(TOOLS_LIBS) ../../gnatlink$(exeext): $(P) b_gnatl.o link.o targext.o $(GNATLINK_OBJS) - $(GCC_LINK) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatl.o $(GNATLINK_OBJS) \ + +$(GCC_LINK) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatl.o $(GNATLINK_OBJS) \ $(TOOLS_LIBS) ../stamp-gnatlib-$(RTSDIR): diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index ec00cc4775f..c1b45effcdb 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.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- * @@ -360,10 +360,6 @@ do { \ constant CONSTRUCTOR. */ #define DECL_CONST_ADDRESS_P(NODE) DECL_LANG_FLAG_0 (CONST_DECL_CHECK (NODE)) -/* Nonzero in a PARM_DECL if it is always used by double reference, i.e. a - pair of INDIRECT_REFs is needed to access the object. */ -#define DECL_BY_DOUBLE_REF_P(NODE) DECL_LANG_FLAG_0 (PARM_DECL_CHECK (NODE)) - /* Nonzero in a FIELD_DECL if it is declared as aliased. */ #define DECL_ALIASED_P(NODE) DECL_LANG_FLAG_0 (FIELD_DECL_CHECK (NODE)) @@ -507,5 +503,11 @@ do { \ #define LOOP_STMT_BOTTOM_COND_P(NODE) TREE_LANG_FLAG_0 (LOOP_STMT_CHECK (NODE)) #define LOOP_STMT_TOP_UPDATE_P(NODE) TREE_LANG_FLAG_1 (LOOP_STMT_CHECK (NODE)) +/* Optimization hints on loops. */ +#define LOOP_STMT_NO_UNROLL(NODE) TREE_LANG_FLAG_2 (LOOP_STMT_CHECK (NODE)) +#define LOOP_STMT_UNROLL(NODE) TREE_LANG_FLAG_3 (LOOP_STMT_CHECK (NODE)) +#define LOOP_STMT_NO_VECTOR(NODE) TREE_LANG_FLAG_4 (LOOP_STMT_CHECK (NODE)) +#define LOOP_STMT_VECTOR(NODE) TREE_LANG_FLAG_5 (LOOP_STMT_CHECK (NODE)) + #define EXIT_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 0) #define EXIT_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 1) diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 7342fa3c9ed..f632a3164e7 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -145,7 +145,7 @@ static bool array_type_has_nonaliased_component (tree, Entity_Id); static bool compile_time_known_address_p (Node_Id); static bool cannot_be_superflat_p (Node_Id); static bool constructor_address_p (tree); -static void components_to_record (tree, Node_Id, tree, int, bool, bool, bool, +static bool components_to_record (tree, Node_Id, tree, int, bool, bool, bool, bool, bool, bool, bool, bool, tree, tree *); static Uint annotate_value (tree); static void annotate_rep (Entity_Id, tree); @@ -288,7 +288,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) If we are defining the node, we should not have already processed it. In that case, we will abort below when we try to save a new GCC tree for this object. We also need to handle the case of getting a dummy - type when a Full_View exists. */ + type when a Full_View exists but be careful so as not to trigger its + premature elaboration. */ if ((!definition || (is_type && imported_p)) && present_gnu_tree (gnat_entity)) { @@ -297,7 +298,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (TREE_CODE (gnu_decl) == TYPE_DECL && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)) && IN (kind, Incomplete_Or_Private_Kind) - && Present (Full_View (gnat_entity))) + && Present (Full_View (gnat_entity)) + && (present_gnu_tree (Full_View (gnat_entity)) + || No (Freeze_Node (Full_View (gnat_entity))))) { gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0); @@ -308,8 +311,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) return gnu_decl; } - /* If this is a numeric or enumeral type, or an access type, a nonzero - Esize must be specified unless it was specified by the programmer. */ + /* If this is a numeric or enumeral type, or an access type, a nonzero Esize + must be specified unless it was specified by the programmer. Exceptions + are for access-to-protected-subprogram types and all access subtypes, as + another GNAT type is used to lay out the GCC type for them. */ gcc_assert (!Unknown_Esize (gnat_entity) || Has_Size_Clause (gnat_entity) || (!IN (kind, Numeric_Kind) @@ -317,7 +322,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && (!IN (kind, Access_Kind) || kind == E_Access_Protected_Subprogram_Type || kind == E_Anonymous_Access_Protected_Subprogram_Type - || kind == E_Access_Subtype))); + || kind == E_Access_Subtype + || type_annotate_only))); /* The RM size must be specified for all discrete and fixed-point types. */ gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind) @@ -689,7 +695,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) never be declared otherwise. This is necessary to ensure that its subtrees are properly marked. */ if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type))) - create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true, + create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p, gnat_entity); } } @@ -937,7 +943,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) never be declared otherwise. This is necessary to ensure that its subtrees are properly marked. */ if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type))) - create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true, + create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p, gnat_entity); } @@ -1019,7 +1025,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) save_gnu_tree (gnat_entity, gnu_decl, true); saved = true; annotate_object (gnat_entity, gnu_type, NULL_TREE, - false, false); + false); /* This assertion will fail if the renamed object isn't aligned enough as to make it possible to honor the alignment set on the renaming. */ @@ -1365,7 +1371,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) tree gnu_new_type = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type), TYPE_SIZE_UNIT (gnu_type), - BIGGEST_ALIGNMENT, 0); + BIGGEST_ALIGNMENT, 0, gnat_entity); tree gnu_new_var = create_var_decl (create_concat_name (gnat_entity, "ALIGN"), NULL_TREE, gnu_new_type, NULL_TREE, false, @@ -1411,26 +1417,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) just above, we have nothing to do here. */ if (!TYPE_IS_THIN_POINTER_P (gnu_type)) { - gnu_size = NULL_TREE; - used_by_ref = true; + tree gnu_unc_var + = create_var_decl (concat_name (gnu_entity_name, "UNC"), + NULL_TREE, gnu_type, gnu_expr, + const_flag, Is_Public (gnat_entity), + imported_p || !definition, static_p, + NULL, gnat_entity); + gnu_expr + = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var); + TREE_CONSTANT (gnu_expr) = 1; - if (definition && !imported_p) - { - tree gnu_unc_var - = create_var_decl (concat_name (gnu_entity_name, "UNC"), - NULL_TREE, gnu_type, gnu_expr, - const_flag, Is_Public (gnat_entity), - false, static_p, NULL, gnat_entity); - gnu_expr - = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var); - TREE_CONSTANT (gnu_expr) = 1; - const_flag = true; - } - else - { - gnu_expr = NULL_TREE; - const_flag = false; - } + gnu_size = NULL_TREE; + used_by_ref = true; + const_flag = true; } gnu_type @@ -1605,7 +1604,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) type of the object and not on the object directly, and makes it possible to support all confirming representation clauses. */ annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size, - used_by_ref, false); + used_by_ref); } break; @@ -1617,7 +1616,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) case E_Enumeration_Type: /* A special case: for the types Character and Wide_Character in Standard, we do not list all the literals. So if the literals - are not specified, make this an unsigned type. */ + are not specified, make this an unsigned integer type. */ if (No (First_Literal (gnat_entity))) { gnu_type = make_unsigned_type (esize); @@ -1627,52 +1626,54 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) This is needed by the DWARF-2 back-end to distinguish between unsigned integer types and character types. */ TYPE_STRING_FLAG (gnu_type) = 1; - break; } + else + { + /* We have a list of enumeral constants in First_Literal. We make a + CONST_DECL for each one and build into GNU_LITERAL_LIST the list + to be placed into TYPE_FIELDS. Each node is itself a TREE_LIST + whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the + value of the literal. But when we have a regular boolean type, we + simplify this a little by using a BOOLEAN_TYPE. */ + const bool is_boolean = Is_Boolean_Type (gnat_entity) + && !Has_Non_Standard_Rep (gnat_entity); + const bool is_unsigned = Is_Unsigned_Type (gnat_entity); + tree gnu_list = NULL_TREE; + Entity_Id gnat_literal; + + gnu_type = make_node (is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE); + TYPE_PRECISION (gnu_type) = esize; + TYPE_UNSIGNED (gnu_type) = is_unsigned; + set_min_and_max_values_for_integral_type (gnu_type, esize, + is_unsigned); + process_attributes (&gnu_type, &attr_list, true, gnat_entity); + layout_type (gnu_type); + + for (gnat_literal = First_Literal (gnat_entity); + Present (gnat_literal); + gnat_literal = Next_Literal (gnat_literal)) + { + tree gnu_value + = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type); + tree gnu_literal + = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, + gnu_type, gnu_value, true, false, false, + false, NULL, gnat_literal); + /* Do not generate debug info for individual enumerators. */ + DECL_IGNORED_P (gnu_literal) = 1; + save_gnu_tree (gnat_literal, gnu_literal, false); + gnu_list + = tree_cons (DECL_NAME (gnu_literal), gnu_value, gnu_list); + } - { - /* We have a list of enumeral constants in First_Literal. We make a - CONST_DECL for each one and build into GNU_LITERAL_LIST the list to - be placed into TYPE_FIELDS. Each node in the list is a TREE_LIST - whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the - value of the literal. But when we have a regular boolean type, we - simplify this a little by using a BOOLEAN_TYPE. */ - bool is_boolean = Is_Boolean_Type (gnat_entity) - && !Has_Non_Standard_Rep (gnat_entity); - tree gnu_literal_list = NULL_TREE; - Entity_Id gnat_literal; - - if (Is_Unsigned_Type (gnat_entity)) - gnu_type = make_unsigned_type (esize); - else - gnu_type = make_signed_type (esize); - - TREE_SET_CODE (gnu_type, is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE); - - for (gnat_literal = First_Literal (gnat_entity); - Present (gnat_literal); - gnat_literal = Next_Literal (gnat_literal)) - { - tree gnu_value - = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type); - tree gnu_literal - = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, - gnu_type, gnu_value, true, false, false, - false, NULL, gnat_literal); - /* Do not generate debug info for individual enumerators. */ - DECL_IGNORED_P (gnu_literal) = 1; - save_gnu_tree (gnat_literal, gnu_literal, false); - gnu_literal_list = tree_cons (DECL_NAME (gnu_literal), - gnu_value, gnu_literal_list); - } - - if (!is_boolean) - TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list); + if (!is_boolean) + TYPE_VALUES (gnu_type) = nreverse (gnu_list); - /* Note that the bounds are updated at the end of this function - to avoid an infinite recursion since they refer to the type. */ - } - goto discrete_type; + /* Note that the bounds are updated at the end of this function + to avoid an infinite recursion since they refer to the type. */ + goto discrete_type; + } + break; case E_Signed_Integer_Type: case E_Ordinary_Fixed_Point_Type: @@ -1780,6 +1781,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) definition, true, Needs_Debug_Info (gnat_entity)))); + TYPE_BIASED_REPRESENTATION_P (gnu_type) + = Has_Biased_Representation (gnat_entity); + + /* Inherit our alias set from what we're a subtype of. Subtypes + are not different types and a pointer can designate any instance + within a subtype hierarchy. */ + relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY); + /* One of the above calls might have caused us to be elaborated, so don't blow up if so. */ if (present_gnu_tree (gnat_entity)) @@ -1788,18 +1797,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) break; } - TYPE_BIASED_REPRESENTATION_P (gnu_type) - = Has_Biased_Representation (gnat_entity); - /* Attach the TYPE_STUB_DECL in case we have a parallel type. */ TYPE_STUB_DECL (gnu_type) = create_type_stub_decl (gnu_entity_name, gnu_type); - /* Inherit our alias set from what we're a subtype of. Subtypes - are not different types and a pointer can designate any instance - within a subtype hierarchy. */ - relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY); - /* For a packed array, make the original array type a parallel type. */ if (debug_info_p && Is_Packed_Array_Type (gnat_entity) @@ -1840,8 +1841,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1; /* Create a stripped-down declaration, mainly for debugging. */ - create_type_decl (gnu_entity_name, gnu_type, NULL, true, - debug_info_p, gnat_entity); + create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p, + gnat_entity); /* Now save it and build the enclosing record type. */ gnu_field_type = gnu_type; @@ -1901,8 +1902,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) UI_To_gnu (RM_Size (gnat_entity), bitsizetype)); /* Create a stripped-down declaration, mainly for debugging. */ - create_type_decl (gnu_entity_name, gnu_type, NULL, true, - debug_info_p, gnat_entity); + create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p, + gnat_entity); /* Now save it and build the enclosing record type. */ gnu_field_type = gnu_type; @@ -1958,53 +1959,47 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) break; } - { - if (!definition - && Present (Ancestor_Subtype (gnat_entity)) - && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) - && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) - || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) - gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), - gnu_expr, 0); - - gnu_type = make_node (REAL_TYPE); - TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); - TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); - TYPE_GCC_MIN_VALUE (gnu_type) - = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type)); - TYPE_GCC_MAX_VALUE (gnu_type) - = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type)); - layout_type (gnu_type); - - SET_TYPE_RM_MIN_VALUE - (gnu_type, - convert (TREE_TYPE (gnu_type), - elaborate_expression (Type_Low_Bound (gnat_entity), - gnat_entity, get_identifier ("L"), - definition, true, - Needs_Debug_Info (gnat_entity)))); - - SET_TYPE_RM_MAX_VALUE - (gnu_type, - convert (TREE_TYPE (gnu_type), - elaborate_expression (Type_High_Bound (gnat_entity), - gnat_entity, get_identifier ("U"), - definition, true, - Needs_Debug_Info (gnat_entity)))); - - /* One of the above calls might have caused us to be elaborated, - so don't blow up if so. */ - if (present_gnu_tree (gnat_entity)) - { - maybe_present = true; - break; - } + /* See the E_Signed_Integer_Subtype case for the rationale. */ + if (!definition + && Present (Ancestor_Subtype (gnat_entity)) + && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) + && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) + || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) + gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0); - /* Inherit our alias set from what we're a subtype of, as for - integer subtypes. */ - relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY); - } - break; + gnu_type = make_node (REAL_TYPE); + TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); + TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); + TYPE_GCC_MIN_VALUE (gnu_type) + = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type)); + TYPE_GCC_MAX_VALUE (gnu_type) + = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type)); + layout_type (gnu_type); + + SET_TYPE_RM_MIN_VALUE + (gnu_type, + convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_Low_Bound (gnat_entity), + gnat_entity, get_identifier ("L"), + definition, true, + Needs_Debug_Info (gnat_entity)))); + + SET_TYPE_RM_MAX_VALUE + (gnu_type, + convert (TREE_TYPE (gnu_type), + elaborate_expression (Type_High_Bound (gnat_entity), + gnat_entity, get_identifier ("U"), + definition, true, + Needs_Debug_Info (gnat_entity)))); + + /* Inherit our alias set from what we're a subtype of, as for + integer subtypes. */ + relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY); + + /* One of the above calls might have caused us to be elaborated, + so don't blow up if so. */ + maybe_present = true; + break; /* Array and String Types and Subtypes @@ -2300,9 +2295,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_SIZE_UNIT (tem)); } - create_type_decl (create_concat_name (gnat_entity, "XUA"), - tem, NULL, !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); + create_type_decl (create_concat_name (gnat_entity, "XUA"), tem, + !Comes_From_Source (gnat_entity), debug_info_p, + gnat_entity); /* Give the fat pointer type a name. If this is a packed type, tell the debugger how to interpret the underlying bits. */ @@ -2310,9 +2305,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnat_name = Packed_Array_Type (gnat_entity); else gnat_name = gnat_entity; - create_type_decl (create_concat_name (gnat_name, "XUP"), - gnu_fat_type, NULL, !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); + create_type_decl (create_concat_name (gnat_name, "XUP"), gnu_fat_type, + !Comes_From_Source (gnat_entity), debug_info_p, + gnat_entity); /* Create the type to be designated by thin pointers: a record type for the array and its template. We used to shift the fields to have the @@ -2447,15 +2442,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_orig_max, gnu_orig_min), gnu_min, - size_binop (PLUS_EXPR, gnu_max, - size_one_node)); + int_const_binop (PLUS_EXPR, gnu_max, + size_one_node)); } /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound in all the other cases. Note that, here as well as above, the condition used in the comparison must be equivalent to the condition (length != 0). This is relied upon in order - to optimize array comparisons in compare_arrays. */ + to optimize array comparisons in compare_arrays. Moreover + we use int_const_binop for the shift by 1 if the bound is + constant to avoid any unwanted overflow. */ else gnu_high = build_cond_expr (sizetype, @@ -2464,8 +2461,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_orig_max, gnu_orig_min), gnu_max, - size_binop (MINUS_EXPR, gnu_min, - size_one_node)); + TREE_CODE (gnu_min) == INTEGER_CST + ? int_const_binop (MINUS_EXPR, gnu_min, + size_one_node) + : size_binop (MINUS_EXPR, gnu_min, + size_one_node)); /* Reuse the index type for the range type. Then make an index type with the size range in sizetype. */ @@ -2733,18 +2733,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* First finish the type we had been making so that we output debugging information for it. */ + process_attributes (&gnu_type, &attr_list, false, gnat_entity); if (Treat_As_Volatile (gnat_entity)) gnu_type = build_qualified_type (gnu_type, TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE); - /* Make it artificial only if the base type was artificial too. That's sort of "morally" true and will make it possible for the debugger to look it up by name in DWARF, which is needed in order to decode the packed array type. */ gnu_decl - = create_type_decl (gnu_entity_name, gnu_type, attr_list, + = create_type_decl (gnu_entity_name, gnu_type, !Comes_From_Source (Etype (gnat_entity)) && !Comes_From_Source (gnat_entity), debug_info_p, gnat_entity); @@ -2908,10 +2908,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { Node_Id full_definition = Declaration_Node (gnat_entity); Node_Id record_definition = Type_Definition (full_definition); + Node_Id gnat_constr; Entity_Id gnat_field; - tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent; + tree gnu_field, gnu_field_list = NULL_TREE; + tree gnu_get_parent; /* Set PACKED in keeping with gnat_to_gnu_field. */ - int packed + const int packed = Is_Packed (gnat_entity) ? 1 : Component_Alignment (gnat_entity) == Calign_Storage_Unit @@ -2921,13 +2923,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && Known_RM_Size (gnat_entity))) ? -2 : 0; - bool has_discr = Has_Discriminants (gnat_entity); - bool has_rep = Has_Specified_Layout (gnat_entity); - bool all_rep = has_rep; - bool is_extension + const bool has_discr = Has_Discriminants (gnat_entity); + const bool has_rep = Has_Specified_Layout (gnat_entity); + const bool is_extension = (Is_Tagged_Type (gnat_entity) && Nkind (record_definition) == N_Derived_Type_Definition); - bool is_unchecked_union = Is_Unchecked_Union (gnat_entity); + const bool is_unchecked_union = Is_Unchecked_Union (gnat_entity); + bool all_rep = has_rep; /* See if all fields have a rep clause. Stop when we find one that doesn't. */ @@ -2962,6 +2964,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_PACKED (gnu_type) = (packed != 0) || has_rep; if (Reverse_Storage_Order (gnat_entity)) sorry ("non-default Scalar_Storage_Order"); + process_attributes (&gnu_type, &attr_list, true, gnat_entity); if (!definition) { @@ -3166,6 +3169,51 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } } + /* If we have a derived untagged type that renames discriminants in + the root type, the (stored) discriminants are a just copy of the + discriminants of the root type. This means that any constraints + added by the renaming in the derivation are disregarded as far + as the layout of the derived type is concerned. To rescue them, + we change the type of the (stored) discriminants to a subtype + with the bounds of the type of the visible discriminants. */ + if (has_discr + && !is_extension + && Stored_Constraint (gnat_entity) != No_Elist) + for (gnat_constr = First_Elmt (Stored_Constraint (gnat_entity)); + gnat_constr != No_Elmt; + gnat_constr = Next_Elmt (gnat_constr)) + if (Nkind (Node (gnat_constr)) == N_Identifier + /* Ignore access discriminants. */ + && !Is_Access_Type (Etype (Node (gnat_constr))) + && Ekind (Entity (Node (gnat_constr))) == E_Discriminant) + { + Entity_Id gnat_discr = Entity (Node (gnat_constr)); + tree gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr)); + tree gnu_ref + = gnat_to_gnu_entity (Original_Record_Component (gnat_discr), + NULL_TREE, 0); + + /* GNU_REF must be an expression using a PLACEHOLDER_EXPR built + just above for one of the stored discriminants. */ + gcc_assert (TREE_TYPE (TREE_OPERAND (gnu_ref, 0)) == gnu_type); + + if (gnu_discr_type != TREE_TYPE (gnu_ref)) + { + const unsigned prec = TYPE_PRECISION (TREE_TYPE (gnu_ref)); + tree gnu_subtype + = TYPE_UNSIGNED (TREE_TYPE (gnu_ref)) + ? make_unsigned_type (prec) : make_signed_type (prec); + TREE_TYPE (gnu_subtype) = TREE_TYPE (gnu_ref); + TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; + SET_TYPE_RM_MIN_VALUE (gnu_subtype, + TYPE_MIN_VALUE (gnu_discr_type)); + SET_TYPE_RM_MAX_VALUE (gnu_subtype, + TYPE_MAX_VALUE (gnu_discr_type)); + TREE_TYPE (gnu_ref) + = TREE_TYPE (TREE_OPERAND (gnu_ref, 1)) = gnu_subtype; + } + } + /* Add the fields into the record type and finish it up. */ components_to_record (gnu_type, Component_List (record_definition), gnu_field_list, packed, definition, false, @@ -3307,6 +3355,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_type = make_node (RECORD_TYPE); TYPE_NAME (gnu_type) = gnu_entity_name; TYPE_PACKED (gnu_type) = TYPE_PACKED (gnu_base_type); + process_attributes (&gnu_type, &attr_list, true, gnat_entity); /* Set the size, alignment and alias set of the new type to match that of the old one, doing required substitutions. */ @@ -3647,7 +3696,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_type = build_pointer_type (make_dummy_type (Directly_Designated_Type (gnat_entity))); - gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list, + gnu_decl = create_type_decl (gnu_entity_name, gnu_type, !Comes_From_Source (gnat_entity), debug_info_p, gnat_entity); this_made_decl = true; @@ -3903,7 +3952,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) else gnu_old_desig_type = TREE_TYPE (gnu_type); - gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list, + process_attributes (&gnu_type, &attr_list, false, gnat_entity); + gnu_decl = create_type_decl (gnu_entity_name, gnu_type, !Comes_From_Source (gnat_entity), debug_info_p, gnat_entity); this_made_decl = true; @@ -4078,7 +4128,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE; tree gnu_ext_name = create_concat_name (gnat_entity, NULL); Entity_Id gnat_param; - bool inline_flag = Is_Inlined (gnat_entity); + enum inline_status_t inline_status + = Has_Pragma_No_Inline (gnat_entity) + ? is_suppressed + : (Is_Inlined (gnat_entity) ? is_enabled : is_disabled); bool public_flag = Is_Public (gnat_entity) || imported_p; bool extern_flag = (Is_Public (gnat_entity) && !definition) || imported_p; @@ -4237,8 +4290,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (gnu_return_type != orig_type && !DECL_P (TYPE_NAME (gnu_return_type))) create_type_decl (TYPE_NAME (gnu_return_type), - gnu_return_type, NULL, true, - debug_info_p, gnat_entity); + gnu_return_type, true, debug_info_p, + gnat_entity); return_by_invisi_ref_p = true; } @@ -4619,9 +4672,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } else if (kind == E_Subprogram_Type) - gnu_decl - = create_type_decl (gnu_entity_name, gnu_type, attr_list, - artificial_flag, debug_info_p, gnat_entity); + { + process_attributes (&gnu_type, &attr_list, false, gnat_entity); + gnu_decl + = create_type_decl (gnu_entity_name, gnu_type, artificial_flag, + debug_info_p, gnat_entity); + } else { if (has_stub) @@ -4634,15 +4690,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type, - gnu_param_list, inline_flag, public_flag, - extern_flag, artificial_flag, attr_list, - gnat_entity); + gnu_param_list, inline_status, + public_flag, extern_flag, artificial_flag, + attr_list, gnat_entity); if (has_stub) { tree gnu_stub_decl = create_subprog_decl (gnu_entity_name, gnu_stub_name, gnu_stub_type, gnu_stub_param_list, - inline_flag, true, extern_flag, + inline_status, true, extern_flag, false, attr_list, gnat_entity); SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl); } @@ -4773,6 +4829,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) handling alignment and possible padding. */ if (is_type && (!gnu_decl || this_made_decl)) { + /* Process the attributes, if not already done. Note that the type is + already defined so we cannot pass True for IN_PLACE here. */ + process_attributes (&gnu_type, &attr_list, false, gnat_entity); + /* Tell the middle-end that objects of tagged types are guaranteed to be properly aligned. This is necessary because conversions to the class-wide type are translated into conversions to the root type, @@ -5017,7 +5077,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1; if (!gnu_decl) - gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list, + gnu_decl = create_type_decl (gnu_entity_name, gnu_type, !Comes_From_Source (gnat_entity), debug_info_p, gnat_entity); else @@ -5375,7 +5435,7 @@ get_minimal_subprog_decl (Entity_Id gnat_entity) return create_subprog_decl (gnu_entity_name, gnu_ext_name, void_ftype, NULL_TREE, - false, true, true, true, attr_list, gnat_entity); + is_disabled, true, true, true, attr_list, gnat_entity); } /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is @@ -5557,8 +5617,8 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, declared otherwise. This is necessary to ensure that its subtrees are properly marked. */ if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type))) - create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true, - debug_info_p, gnat_array); + create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p, + gnat_array); } if (Has_Volatile_Components (gnat_array)) @@ -5590,7 +5650,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, /* The parameter can be indirectly modified if its address is taken. */ bool ro_param = in_param && !Address_Taken (gnat_param); bool by_return = false, by_component_ptr = false; - bool by_ref = false, by_double_ref = false; + bool by_ref = false; tree gnu_param; /* Copy-return is used only for the first parameter of a valued procedure. @@ -5715,19 +5775,6 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, gnu_param_type = build_qualified_type (gnu_param_type, TYPE_QUAL_RESTRICT); by_ref = true; - - /* In some ABIs, e.g. SPARC 32-bit, fat pointer types are themselves - passed by reference. Pass them by explicit reference, this will - generate more debuggable code at -O0. */ - if (TYPE_IS_FAT_POINTER_P (gnu_param_type) - && targetm.calls.pass_by_reference (pack_cumulative_args (NULL), - TYPE_MODE (gnu_param_type), - gnu_param_type, - true)) - { - gnu_param_type = build_reference_type (gnu_param_type); - by_double_ref = true; - } } /* Pass In Out or Out parameters using copy-in copy-out mechanism. */ @@ -5770,7 +5817,6 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, gnu_param = create_param_decl (gnu_param_name, gnu_param_type, ro_param || by_ref || by_component_ptr); DECL_BY_REF_P (gnu_param) = by_ref; - DECL_BY_DOUBLE_REF_P (gnu_param) = by_double_ref; DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr; DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor || mech == By_Short_Descriptor); @@ -5964,7 +6010,7 @@ elaborate_entity (Entity_Id gnat_entity) Present (gnat_field); gnat_field = Next_Discriminant (gnat_field), gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr)) - /* ??? For now, ignore access discriminants. */ + /* Ignore access discriminants. */ if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr)))) elaborate_expression (Node (gnat_discriminant_expr), gnat_entity, get_entity_name (gnat_field), @@ -6186,12 +6232,13 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, expr_variable_p = false; else { - /* Skip any conversions and simple arithmetics to see if the expression - is based on a read-only variable. + /* Skip any conversions and simple constant arithmetics to see if the + expression is based on a read-only variable. ??? This really should remain read-only, but we have to think about the typing of the tree here. */ - tree inner - = skip_simple_arithmetic (remove_conversions (gnu_expr, true)); + tree inner = remove_conversions (gnu_expr, true); + + inner = skip_simple_constant_arithmetic (inner); if (handled_component_p (inner)) { @@ -6639,8 +6686,8 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, are properly marked. */ if (gnu_field_type != orig_field_type && !DECL_P (TYPE_NAME (gnu_field_type))) - create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, NULL, - true, debug_info_p, gnat_field); + create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, true, + debug_info_p, gnat_field); } /* Otherwise (or if there was an error), don't specify a position. */ @@ -6783,9 +6830,30 @@ compare_field_bitpos (const PTR rt1, const PTR rt2) return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2)); } -/* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set - the result as the field list of GNU_RECORD_TYPE and finish it up. When - called from gnat_to_gnu_entity during the processing of a record type +/* Structure holding information for a given variant. */ +typedef struct vinfo +{ + /* The record type of the variant. */ + tree type; + + /* The name of the variant. */ + tree name; + + /* The qualifier of the variant. */ + tree qual; + + /* Whether the variant has a rep clause. */ + bool has_rep; + + /* Whether the variant is packed. */ + bool packed; + +} vinfo_t; + +/* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set the + result as the field list of GNU_RECORD_TYPE and finish it up. Return true + if GNU_RECORD_TYPE has a rep clause which affects the layout (see below). + When called from gnat_to_gnu_entity during the processing of a record type definition, the GCC node for the parent, if any, will be the single field of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the GNU_FIELD_LIST. The other calls to this function are recursive calls for @@ -6822,9 +6890,9 @@ compare_field_bitpos (const PTR rt1, const PTR rt2) P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field with a rep clause is to be added; in this case, that is all that should - be done with such fields. */ + be done with such fields and the return value will be false. */ -static void +static bool components_to_record (tree gnu_record_type, Node_Id gnat_component_list, tree gnu_field_list, int packed, bool definition, bool cancel_alignment, bool all_rep, @@ -6833,12 +6901,12 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, tree first_free_pos, tree *p_gnu_rep_list) { bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type); + bool variants_have_rep = all_rep; bool layout_with_rep = false; bool has_self_field = false; bool has_aliased_after_self_field = false; Node_Id component_decl, variant_part; tree gnu_field, gnu_next, gnu_last; - tree gnu_rep_part = NULL_TREE; tree gnu_variant_part = NULL_TREE; tree gnu_rep_list = NULL_TREE; tree gnu_var_list = NULL_TREE; @@ -6920,6 +6988,12 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, tree gnu_union_type, gnu_union_name; tree this_first_free_pos, gnu_variant_list = NULL_TREE; bool union_field_needs_strict_alignment = false; + vec <vinfo_t, va_stack> variant_types; + vinfo_t *gnu_variant; + unsigned int variants_align = 0; + unsigned int i; + + vec_stack_alloc (vinfo_t, variant_types, 16); if (TREE_CODE (gnu_name) == TYPE_DECL) gnu_name = DECL_NAME (gnu_name); @@ -6965,13 +7039,20 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, } } + /* We build the variants in two passes. The bulk of the work is done in + the first pass, that is to say translating the GNAT nodes, building + the container types and computing the associated properties. However + we cannot finish up the container types during this pass because we + don't know where the variant part will be placed until the end. */ for (variant = First_Non_Pragma (Variants (variant_part)); Present (variant); variant = Next_Non_Pragma (variant)) { tree gnu_variant_type = make_node (RECORD_TYPE); - tree gnu_inner_name; - tree gnu_qual; + tree gnu_inner_name, gnu_qual; + bool has_rep; + int field_packed; + vinfo_t vinfo; Get_Variant_Encoding (variant); gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len); @@ -6996,70 +7077,122 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, /* Add the fields into the record type for the variant. Note that we aren't sure to really use it at this point, see below. */ - components_to_record (gnu_variant_type, Component_List (variant), - NULL_TREE, packed, definition, - !all_rep_and_size, all_rep, unchecked_union, - true, debug_info, true, reorder, - this_first_free_pos, - all_rep || this_first_free_pos - ? NULL : &gnu_rep_list); - + has_rep + = components_to_record (gnu_variant_type, Component_List (variant), + NULL_TREE, packed, definition, + !all_rep_and_size, all_rep, + unchecked_union, + true, debug_info, true, reorder, + this_first_free_pos, + all_rep || this_first_free_pos + ? NULL : &gnu_rep_list); + + /* Translate the qualifier and annotate the GNAT node. */ gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant)); Set_Present_Expr (variant, annotate_value (gnu_qual)); + /* Deal with packedness like in gnat_to_gnu_field. */ + if (components_need_strict_alignment (Component_List (variant))) + { + field_packed = 0; + union_field_needs_strict_alignment = true; + } + else + field_packed + = adjust_packed (gnu_variant_type, gnu_record_type, packed); + + /* Push this variant onto the stack for the second pass. */ + vinfo.type = gnu_variant_type; + vinfo.name = gnu_inner_name; + vinfo.qual = gnu_qual; + vinfo.has_rep = has_rep; + vinfo.packed = field_packed; + variant_types.safe_push (vinfo); + + /* Compute the global properties that will determine the placement of + the variant part. */ + variants_have_rep |= has_rep; + if (!field_packed && TYPE_ALIGN (gnu_variant_type) > variants_align) + variants_align = TYPE_ALIGN (gnu_variant_type); + } + + /* Round up the first free position to the alignment of the variant part + for the variants without rep clause. This will guarantee a consistent + layout independently of the placement of the variant part. */ + if (variants_have_rep && variants_align > 0 && this_first_free_pos) + this_first_free_pos = round_up (this_first_free_pos, variants_align); + + /* In the second pass, the container types are adjusted if necessary and + finished up, then the corresponding fields of the variant part are + built with their qualifier, unless this is an unchecked union. */ + FOR_EACH_VEC_ELT (variant_types, i, gnu_variant) + { + tree gnu_variant_type = gnu_variant->type; + tree gnu_field_list = TYPE_FIELDS (gnu_variant_type); + /* If this is an Unchecked_Union whose fields are all in the variant part and we have a single field with no representation clause or placed at offset zero, use the field directly to match the layout of C unions. */ if (TREE_CODE (gnu_record_type) == UNION_TYPE - && (gnu_field = TYPE_FIELDS (gnu_variant_type)) != NULL_TREE - && !DECL_CHAIN (gnu_field) - && (!DECL_FIELD_OFFSET (gnu_field) - || integer_zerop (bit_position (gnu_field)))) - DECL_CONTEXT (gnu_field) = gnu_union_type; + && gnu_field_list + && !DECL_CHAIN (gnu_field_list) + && (!DECL_FIELD_OFFSET (gnu_field_list) + || integer_zerop (bit_position (gnu_field_list)))) + { + gnu_field = gnu_field_list; + DECL_CONTEXT (gnu_field) = gnu_record_type; + } else { - /* Deal with packedness like in gnat_to_gnu_field. */ - bool field_needs_strict_alignment - = components_need_strict_alignment (Component_List (variant)); - int field_packed; - - if (field_needs_strict_alignment) + /* Finalize the variant type now. We used to throw away empty + record types but we no longer do that because we need them to + generate complete debug info for the variant; otherwise, the + union type definition will be lacking the fields associated + with these empty variants. */ + if (gnu_field_list && variants_have_rep && !gnu_variant->has_rep) { - field_packed = 0; - union_field_needs_strict_alignment = true; + /* The variant part will be at offset 0 so we need to ensure + that the fields are laid out starting from the first free + position at this level. */ + tree gnu_rep_type = make_node (RECORD_TYPE); + tree gnu_rep_part; + finish_record_type (gnu_rep_type, NULL_TREE, 0, debug_info); + gnu_rep_part + = create_rep_part (gnu_rep_type, gnu_variant_type, + this_first_free_pos); + DECL_CHAIN (gnu_rep_part) = gnu_field_list; + gnu_field_list = gnu_rep_part; + finish_record_type (gnu_variant_type, gnu_field_list, 0, + false); } - else - field_packed - = adjust_packed (gnu_variant_type, gnu_record_type, packed); - - /* Finalize the record type now. We used to throw away - empty records but we no longer do that because we need - them to generate complete debug info for the variant; - otherwise, the union type definition will be lacking - the fields associated with these empty variants. */ - rest_of_record_type_compilation (gnu_variant_type); + + if (debug_info) + rest_of_record_type_compilation (gnu_variant_type); create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type, - NULL, true, debug_info, gnat_component_list); + true, debug_info, gnat_component_list); gnu_field - = create_field_decl (gnu_inner_name, gnu_variant_type, + = create_field_decl (gnu_variant->name, gnu_variant_type, gnu_union_type, all_rep_and_size ? TYPE_SIZE (gnu_variant_type) : 0, - all_rep ? bitsize_zero_node : 0, - field_packed, 0); + variants_have_rep ? bitsize_zero_node : 0, + gnu_variant->packed, 0); DECL_INTERNAL_P (gnu_field) = 1; if (!unchecked_union) - DECL_QUALIFIER (gnu_field) = gnu_qual; + DECL_QUALIFIER (gnu_field) = gnu_variant->qual; } DECL_CHAIN (gnu_field) = gnu_variant_list; gnu_variant_list = gnu_field; } + /* We are done with the variants. */ + variant_types.release (); + /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */ if (gnu_variant_list) { @@ -7083,11 +7216,11 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, gcc_assert (unchecked_union && !gnu_field_list && !gnu_rep_list); - return; + return variants_have_rep; } - create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type, - NULL, true, debug_info, gnat_component_list); + create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type, true, + debug_info, gnat_component_list); /* Deal with packedness like in gnat_to_gnu_field. */ if (union_field_needs_strict_alignment) @@ -7100,18 +7233,13 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type, all_rep_and_size ? TYPE_SIZE (gnu_union_type) : 0, - all_rep || this_first_free_pos - ? bitsize_zero_node : 0, + variants_have_rep ? bitsize_zero_node : 0, union_field_packed, 0); DECL_INTERNAL_P (gnu_variant_part) = 1; } } - /* From now on, a zero FIRST_FREE_POS is totally useless. */ - if (first_free_pos && integer_zerop (first_free_pos)) - first_free_pos = NULL_TREE; - /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are permitted to reorder components, self-referential sizes or variable sizes. If they do, pull them out and put them onto the appropriate list. We have @@ -7161,6 +7289,8 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, #undef MOVE_FROM_FIELD_LIST_TO + gnu_field_list = nreverse (gnu_field_list); + /* If permitted, we reorder the fields as follows: 1) all fixed length fields, @@ -7171,14 +7301,13 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, within the record and within each variant recursively. */ if (reorder) gnu_field_list - = chainon (nreverse (gnu_self_list), - chainon (nreverse (gnu_var_list), gnu_field_list)); + = chainon (gnu_field_list, chainon (gnu_var_list, gnu_self_list)); /* Otherwise, if there is an aliased field placed after a field whose length depends on discriminants, we put all the fields of the latter sort, last. We need to do this in case an object of this record type is mutable. */ else if (has_aliased_after_self_field) - gnu_field_list = chainon (nreverse (gnu_self_list), gnu_field_list); + gnu_field_list = chainon (gnu_field_list, gnu_self_list); /* If P_REP_LIST is nonzero, this means that we are asked to move the fields in our REP list to the previous level because this level needs them in @@ -7190,11 +7319,16 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, record, before the others, if we also have fields without rep clause. */ else if (gnu_rep_list) { - tree gnu_rep_type - = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type); + tree gnu_rep_type, gnu_rep_part; int i, len = list_length (gnu_rep_list); tree *gnu_arr = XALLOCAVEC (tree, len); + /* If all the fields have a rep clause, we can do a flat layout. */ + layout_with_rep = !gnu_field_list + && (!gnu_variant_part || variants_have_rep); + gnu_rep_type + = layout_with_rep ? gnu_record_type : make_node (RECORD_TYPE); + for (gnu_field = gnu_rep_list, i = 0; gnu_field; gnu_field = DECL_CHAIN (gnu_field), i++) @@ -7212,7 +7346,9 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type; } - if (gnu_field_list) + if (layout_with_rep) + gnu_field_list = gnu_rep_list; + else { finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info); @@ -7221,44 +7357,26 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, Therefore, we force it as a minimal size on the REP part. */ gnu_rep_part = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos); - } - else - { - layout_with_rep = true; - gnu_field_list = nreverse (gnu_rep_list); - } - } - /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields without - rep clause are laid out starting from this position. Therefore, if we - have not already done so, we create a fake REP part with this size. */ - if (first_free_pos && !layout_with_rep && !gnu_rep_part) - { - tree gnu_rep_type = make_node (RECORD_TYPE); - finish_record_type (gnu_rep_type, NULL_TREE, 0, debug_info); - gnu_rep_part - = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos); + /* Chain the REP part at the beginning of the field list. */ + DECL_CHAIN (gnu_rep_part) = gnu_field_list; + gnu_field_list = gnu_rep_part; + } } - /* Now chain the REP part at the end of the reversed field list. */ - if (gnu_rep_part) - gnu_field_list = chainon (gnu_field_list, gnu_rep_part); - - /* And the variant part at the beginning. */ + /* Chain the variant part at the end of the field list. */ if (gnu_variant_part) - { - DECL_CHAIN (gnu_variant_part) = gnu_field_list; - gnu_field_list = gnu_variant_part; - } + gnu_field_list = chainon (gnu_field_list, gnu_variant_part); if (cancel_alignment) TYPE_ALIGN (gnu_record_type) = 0; - finish_record_type (gnu_record_type, nreverse (gnu_field_list), - layout_with_rep ? 1 : 0, false); TYPE_ARTIFICIAL (gnu_record_type) = artificial; - if (debug_info && !maybe_unused) - rest_of_record_type_compilation (gnu_record_type); + + finish_record_type (gnu_record_type, gnu_field_list, layout_with_rep ? 1 : 0, + debug_info && !maybe_unused); + + return (gnu_rep_list && !p_gnu_rep_list) || variants_have_rep; } /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be @@ -7422,18 +7540,13 @@ annotate_value (tree gnu_size) /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception) and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null. - BY_REF is true if the object is used by reference and BY_DOUBLE_REF is - true if the object is used by double reference. */ + BY_REF is true if the object is used by reference. */ void -annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref, - bool by_double_ref) +annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref) { if (by_ref) { - if (by_double_ref) - gnu_type = TREE_TYPE (gnu_type); - if (TYPE_IS_FAT_POINTER_P (gnu_type)) gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type); else @@ -7617,20 +7730,20 @@ build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition) { vec<subst_pair> gnu_list = vNULL; Entity_Id gnat_discrim; - Node_Id gnat_value; + Node_Id gnat_constr; for (gnat_discrim = First_Stored_Discriminant (gnat_type), - gnat_value = First_Elmt (Stored_Constraint (gnat_subtype)); + gnat_constr = First_Elmt (Stored_Constraint (gnat_subtype)); Present (gnat_discrim); gnat_discrim = Next_Stored_Discriminant (gnat_discrim), - gnat_value = Next_Elmt (gnat_value)) + gnat_constr = Next_Elmt (gnat_constr)) /* Ignore access discriminants. */ - if (!Is_Access_Type (Etype (Node (gnat_value)))) + if (!Is_Access_Type (Etype (Node (gnat_constr)))) { tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim); tree replacement = convert (TREE_TYPE (gnu_field), elaborate_expression - (Node (gnat_value), gnat_subtype, + (Node (gnat_constr), gnat_subtype, get_entity_name (gnat_discrim), definition, true, false)); subst_pair s = {gnu_field, replacement}; @@ -8289,7 +8402,7 @@ create_rep_part (tree rep_type, tree record_type, tree min_size) min_size = NULL_TREE; field = create_field_decl (get_identifier ("REP"), rep_type, record_type, - min_size, bitsize_zero_node, 0, 1); + min_size, NULL_TREE, 0, 1); DECL_INTERNAL_P (field) = 1; return field; @@ -8406,8 +8519,8 @@ create_variant_part_from (tree old_variant_part, info thanks to the XVS type. */ finish_record_type (new_variant, nreverse (field_list), 2, false); compute_record_mode (new_variant); - create_type_decl (TYPE_NAME (new_variant), new_variant, NULL, - true, false, Empty); + create_type_decl (TYPE_NAME (new_variant), new_variant, true, false, + Empty); new_field = create_field_decl_from (old_field, new_variant, new_union_type, @@ -8424,8 +8537,8 @@ create_variant_part_from (tree old_variant_part, because VARIANT_LIST has been traversed in reverse order. */ finish_record_type (new_union_type, union_field_list, 2, false); compute_record_mode (new_union_type); - create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL, - true, false, Empty); + create_type_decl (TYPE_NAME (new_union_type), new_union_type, true, false, + Empty); new_variant_part = create_field_decl_from (old_variant_part, new_union_type, record_type, diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 6fc3f347ed3..8ee666059a9 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -123,9 +123,10 @@ extern bool is_cplusplus_method (Entity_Id gnat_entity); /* Create a record type that contains a SIZE bytes long field of TYPE with a starting bit position so that it is aligned to ALIGN bits, and leaving at least ROOM bytes free before the field. BASE_ALIGN is the alignment the - record is guaranteed to get. */ + record is guaranteed to get. GNAT_NODE is used for the position of the + associated TYPE_DECL. */ extern tree make_aligning_type (tree type, unsigned int align, tree size, - unsigned int base_align, int room); + unsigned int base_align, int room, Node_Id); /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used as the field type of a packed record if IN_RECORD is true, or as the @@ -177,10 +178,9 @@ extern tree choices_to_gnu (tree operand, Node_Id choices); /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception) and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null. - BY_REF is true if the object is used by reference and BY_DOUBLE_REF is - true if the object is used by double reference. */ + BY_REF is true if the object is used by reference. */ extern void annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, - bool by_ref, bool by_double_ref); + bool by_ref); /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */ extern tree get_variant_part (tree record_type); @@ -430,6 +430,17 @@ enum exception_info_kind exception_column }; +/* Define the inline status of a subprogram. */ +enum inline_status_t +{ + /* Inlining is suppressed for the subprogram. */ + is_suppressed, + /* No inlining is requested for the subprogram. */ + is_disabled, + /* Inlining is requested for the subprogram. */ + is_enabled +}; + extern GTY(()) tree gnat_std_decls[(int) ADT_LAST]; extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; extern GTY(()) tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1]; @@ -491,7 +502,13 @@ extern tree get_block_jmpbuf_decl (void); for location information and flag propagation. */ extern void gnat_pushdecl (tree decl, Node_Id gnat_node); +/* Initialize the GCC support for exception handling. */ extern void gnat_init_gcc_eh (void); + +/* Initialize the GCC support for floating-point operations. */ +extern void gnat_init_gcc_fp (void); + +/* Install the builtin functions we might need. */ extern void gnat_install_builtins (void); /* Return an integer type with the number of bits of precision given by @@ -635,10 +652,8 @@ extern tree create_type_stub_decl (tree type_name, tree type); is a declaration that was generated by the compiler. DEBUG_INFO_P is true if we need to write debug information about this type. GNAT_NODE is used for the position of the decl. */ -extern tree create_type_decl (tree type_name, tree type, - struct attrib *attr_list, - bool artificial_p, bool debug_info_p, - Node_Id gnat_node); +extern tree create_type_decl (tree type_name, tree type, bool artificial_p, + bool debug_info_p, Node_Id gnat_node); /* Return a VAR_DECL or CONST_DECL node. @@ -711,22 +726,29 @@ extern tree create_param_decl (tree param_name, tree param_type, /* Return a LABEL_DECL with LABEL_NAME. GNAT_NODE is used for the position of the decl. */ -extern tree create_label_decl (tree, Node_Id); +extern tree create_label_decl (tree label_name, Node_Id gnat_node); /* Return a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram, ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of PARM_DECL nodes chained through the DECL_CHAIN field). - INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, ARTIFICIAL_FLAG and ATTR_LIST are + INLINE_STATUS, PUBLIC_FLAG, EXTERN_FLAG, ARTIFICIAL_FLAG and ATTR_LIST are used to set the appropriate fields in the FUNCTION_DECL. GNAT_NODE is used for the position of the decl. */ extern tree create_subprog_decl (tree subprog_name, tree asm_name, tree subprog_type, tree param_decl_list, - bool inline_flag, bool public_flag, - bool extern_flag, bool artificial_flag, + enum inline_status_t inline_status, + bool public_flag, bool extern_flag, + bool artificial_flag, struct attrib *attr_list, Node_Id gnat_node); +/* Process the attributes in ATTR_LIST for NODE, which is either a DECL or + a TYPE. If IN_PLACE is true, the tree pointed to by NODE should not be + changed. GNAT_NODE is used for the position of error messages. */ +extern void process_attributes (tree *node, struct attrib **attr_list, + bool in_place, Node_Id gnat_node); + /* Set up the framework for generating code for SUBPROG_DECL, a subprogram body. This routine needs to be invoked before processing the declarations appearing in the subprogram. */ @@ -930,11 +952,10 @@ extern tree fill_vms_descriptor (tree gnu_type, tree gnu_expr, /* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit) - pointer type of GNU_EXPR. BY_REF is true if the result is to be used by - reference. GNAT_SUBPROG is the subprogram to which the VMS descriptor is - passed. */ + pointer type of GNU_EXPR. GNAT_SUBPROG is the subprogram to which the + descriptor is passed. */ extern tree convert_vms_descriptor (tree gnu_type, tree gnu_expr, - tree gnu_expr_alt_type, bool by_ref, + tree gnu_expr_alt_type, Entity_Id gnat_subprog); /* Indicate that we need to take the address of T and that it therefore diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 2fd2743bbe1..7b168df4e03 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.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- * @@ -346,9 +346,7 @@ gnat_init (void) return true; } -/* If we are using the GCC mechanism to process exception handling, we - have to register the personality routine for Ada and to initialize - various language dependent hooks. */ +/* Initialize the GCC support for exception handling. */ void gnat_init_gcc_eh (void) @@ -381,6 +379,28 @@ gnat_init_gcc_eh (void) init_eh (); } +/* Initialize the GCC support for floating-point operations. */ + +void +gnat_init_gcc_fp (void) +{ + /* Disable FP optimizations that ignore the signedness of zero if + S'Signed_Zeros is True, but don't override the user if not. */ + if (Signed_Zeros_On_Target) + flag_signed_zeros = 1; + else if (!global_options_set.x_flag_signed_zeros) + flag_signed_zeros = 0; + + /* Assume that FP operations can trap if S'Machine_Overflow is True, + but don't override the user if not. + + ??? Alpha/VMS enables FP traps without declaring it. */ + if (Machine_Overflows_On_Target || TARGET_ABI_OPEN_VMS) + flag_trapping_math = 1; + else if (!global_options_set.x_flag_trapping_math) + flag_trapping_math = 0; +} + /* Print language-specific items in declaration NODE. */ static void diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 39e455b83ea..4b224abb398 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -36,6 +36,8 @@ #include "gimple.h" #include "bitmap.h" #include "cgraph.h" +#include "diagnostic.h" +#include "opts.h" #include "target.h" #include "common/common-target.h" @@ -210,7 +212,7 @@ typedef struct range_check_info_d *range_check_info; /* Structure used to record information for a loop. */ struct GTY(()) loop_info_d { - tree label; + tree stmt; tree loop_var; vec<range_check_info, va_gc> *checks; }; @@ -411,16 +413,16 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, memory. */ malloc_decl = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE, - ftype, NULL_TREE, false, true, true, true, NULL, - Empty); + ftype, NULL_TREE, is_disabled, true, true, true, + NULL, Empty); DECL_IS_MALLOC (malloc_decl) = 1; /* malloc32 is a function declaration tree for a function to allocate 32-bit memory on a 64-bit system. Needed only on 64-bit VMS. */ malloc32_decl = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE, - ftype, NULL_TREE, false, true, true, true, NULL, - Empty); + ftype, NULL_TREE, is_disabled, true, true, true, + NULL, Empty); DECL_IS_MALLOC (malloc32_decl) = 1; /* free is a function declaration tree for a function to free memory. */ @@ -429,14 +431,16 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, build_function_type_list (void_type_node, ptr_void_type_node, NULL_TREE), - NULL_TREE, false, true, true, true, NULL, Empty); + NULL_TREE, is_disabled, true, true, true, NULL, + Empty); /* This is used for 64-bit multiplication with overflow checking. */ mulv64_decl = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE, build_function_type_list (int64_type, int64_type, int64_type, NULL_TREE), - NULL_TREE, false, true, true, true, NULL, Empty); + NULL_TREE, is_disabled, true, true, true, NULL, + Empty); /* Name of the _Parent field in tagged record types. */ parent_name_id = get_identifier (Get_Name_String (Name_uParent)); @@ -457,7 +461,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, = create_subprog_decl (get_identifier ("system__soft_links__get_jmpbuf_address_soft"), NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE), - NULL_TREE, false, true, true, true, NULL, Empty); + NULL_TREE, is_disabled, true, true, true, NULL, Empty); DECL_IGNORED_P (get_jmpbuf_decl) = 1; set_jmpbuf_decl @@ -465,7 +469,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, (get_identifier ("system__soft_links__set_jmpbuf_address_soft"), NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE), - NULL_TREE, false, true, true, true, NULL, Empty); + NULL_TREE, is_disabled, true, true, true, NULL, Empty); DECL_IGNORED_P (set_jmpbuf_decl) = 1; /* setjmp returns an integer and has one operand, which is a pointer to @@ -475,7 +479,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, (get_identifier ("__builtin_setjmp"), NULL_TREE, build_function_type_list (integer_type_node, jmpbuf_ptr_type, NULL_TREE), - NULL_TREE, false, true, true, true, NULL, Empty); + NULL_TREE, is_disabled, true, true, true, NULL, Empty); DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL; DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP; @@ -485,7 +489,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, = create_subprog_decl (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE), - NULL_TREE, false, true, true, true, NULL, Empty); + NULL_TREE, is_disabled, true, true, true, NULL, Empty); DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL; DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF; @@ -495,27 +499,27 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, begin_handler_decl = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE, - ftype, NULL_TREE, false, true, true, true, NULL, - Empty); + ftype, NULL_TREE, is_disabled, true, true, true, + NULL, Empty); DECL_IGNORED_P (begin_handler_decl) = 1; end_handler_decl = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE, - ftype, NULL_TREE, false, true, true, true, NULL, - Empty); + ftype, NULL_TREE, is_disabled, true, true, true, + NULL, Empty); DECL_IGNORED_P (end_handler_decl) = 1; unhandled_except_decl = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"), NULL_TREE, - ftype, NULL_TREE, false, true, true, true, NULL, - Empty); + ftype, NULL_TREE, is_disabled, true, true, true, + NULL, Empty); DECL_IGNORED_P (unhandled_except_decl) = 1; reraise_zcx_decl = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE, - ftype, NULL_TREE, false, true, true, true, NULL, - Empty); + ftype, NULL_TREE, is_disabled, true, true, true, + NULL, Empty); /* Indicate that these never return. */ DECL_IGNORED_P (reraise_zcx_decl) = 1; TREE_THIS_VOLATILE (reraise_zcx_decl) = 1; @@ -535,7 +539,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, build_pointer_type (unsigned_char_type_node), integer_type_node, NULL_TREE), - NULL_TREE, false, true, true, true, NULL, Empty); + NULL_TREE, is_disabled, true, true, true, NULL, Empty); TREE_THIS_VOLATILE (decl) = 1; TREE_SIDE_EFFECTS (decl) = 1; TREE_TYPE (decl) @@ -568,7 +572,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE, build_function_type_list (build_pointer_type (except_type_node), NULL_TREE), - NULL_TREE, false, true, true, true, NULL, Empty); + NULL_TREE, is_disabled, true, true, true, NULL, Empty); DECL_IGNORED_P (get_excptr_decl) = 1; raise_nodefer_decl @@ -577,7 +581,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, build_function_type_list (void_type_node, build_pointer_type (except_type_node), NULL_TREE), - NULL_TREE, false, true, true, true, NULL, Empty); + NULL_TREE, is_disabled, true, true, true, NULL, Empty); /* Indicate that it never returns. */ TREE_THIS_VOLATILE (raise_nodefer_decl) = 1; @@ -673,6 +677,9 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, if (Exception_Mechanism == Back_End_Exceptions) gnat_init_gcc_eh (); + /* Initialize the GCC support for FP operations. */ + gnat_init_gcc_fp (); + /* Now translate the compilation unit proper. */ Compilation_Unit_to_gnu (gnat_root); @@ -750,7 +757,7 @@ build_raise_check (int check, enum exception_info_kind kind) result = create_subprog_decl (get_identifier (Name_Buffer), NULL_TREE, ftype, NULL_TREE, - false, true, true, true, NULL, Empty); + is_disabled, true, true, true, NULL, Empty); /* Indicate that it never returns. */ TREE_THIS_VOLATILE (result) = 1; @@ -1075,19 +1082,6 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) { const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result); - /* First do the first dereference if needed. */ - if (TREE_CODE (gnu_result) == PARM_DECL - && DECL_BY_DOUBLE_REF_P (gnu_result)) - { - gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); - if (TREE_CODE (gnu_result) == INDIRECT_REF) - TREE_THIS_NOTRAP (gnu_result) = 1; - - /* The first reference, in case of a double reference, always points - to read-only, see gnat_to_gnu_param for the rationale. */ - TREE_READONLY (gnu_result) = 1; - } - /* If it's a PARM_DECL to foreign convention subprogram, convert it. */ if (TREE_CODE (gnu_result) == PARM_DECL && DECL_BY_COMPONENT_PTR_P (gnu_result)) @@ -1184,11 +1178,11 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) static tree Pragma_to_gnu (Node_Id gnat_node) { - Node_Id gnat_temp; tree gnu_result = alloc_stmt_list (); + Node_Id gnat_temp; - /* Check for (and ignore) unrecognized pragma and do nothing if we are just - annotating types. */ + /* Do nothing if we are just annotating types and check for (and ignore) + unrecognized pragmas. */ if (type_annotate_only || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node)))) return gnu_result; @@ -1250,6 +1244,37 @@ Pragma_to_gnu (Node_Id gnat_node) } break; + case Pragma_Loop_Optimize: + for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); + Present (gnat_temp); + gnat_temp = Next (gnat_temp)) + { + tree gnu_loop_stmt = gnu_loop_stack ->last ()->stmt; + + switch (Chars (Expression (gnat_temp))) + { + case Name_No_Unroll: + LOOP_STMT_NO_UNROLL (gnu_loop_stmt) = 1; + break; + + case Name_Unroll: + LOOP_STMT_UNROLL (gnu_loop_stmt) = 1; + break; + + case Name_No_Vector: + LOOP_STMT_NO_VECTOR (gnu_loop_stmt) = 1; + break; + + case Name_Vector: + LOOP_STMT_VECTOR (gnu_loop_stmt) = 1; + break; + + default: + gcc_unreachable (); + } + } + break; + case Pragma_Optimize: switch (Chars (Expression (First (Pragma_Argument_Associations (gnat_node))))) @@ -1278,6 +1303,92 @@ Pragma_to_gnu (Node_Id gnat_node) if (write_symbols == NO_DEBUG) post_error ("must specify -g?", gnat_node); break; + + case Pragma_Warnings: + { + Node_Id gnat_expr; + /* Preserve the location of the pragma. */ + const location_t location = input_location; + struct cl_option_handlers handlers; + unsigned int option_index; + diagnostic_t kind; + bool imply; + + gnat_temp = First (Pragma_Argument_Associations (gnat_node)); + + /* This is the String form: pragma Warnings (String). */ + if (Nkind (Expression (gnat_temp)) == N_String_Literal) + { + kind = DK_WARNING; + gnat_expr = Expression (gnat_temp); + imply = true; + } + + /* This is the On/Off form: pragma Warnings (On | Off [,String]). */ + else if (Nkind (Expression (gnat_temp)) == N_Identifier) + { + switch (Chars (Expression (gnat_temp))) + { + case Name_Off: + kind = DK_IGNORED; + break; + + case Name_On: + kind = DK_WARNING; + break; + + default: + gcc_unreachable (); + } + + if (Present (Next (gnat_temp))) + { + /* pragma Warnings (On | Off, Name) is handled differently. */ + if (Nkind (Expression (Next (gnat_temp))) != N_String_Literal) + break; + + gnat_expr = Expression (Next (gnat_temp)); + } + else + gnat_expr = Empty; + + imply = false; + } + + else + gcc_unreachable (); + + /* This is the same implementation as in the C family of compilers. */ + if (Present (gnat_expr)) + { + tree gnu_expr = gnat_to_gnu (gnat_expr); + const char *opt_string = TREE_STRING_POINTER (gnu_expr); + const int len = TREE_STRING_LENGTH (gnu_expr); + if (len < 3 || opt_string[0] != '-' || opt_string[1] != 'W') + break; + for (option_index = 0; + option_index < cl_options_count; + option_index++) + if (strcmp (cl_options[option_index].opt_text, opt_string) == 0) + break; + if (option_index == cl_options_count) + { + post_error ("unknown -W switch", gnat_node); + break; + } + } + else + option_index = 0; + + set_default_handlers (&handlers); + control_warning_option (option_index, (int) kind, imply, location, + CL_Ada, &handlers, &global_options, + &global_options_set, global_dc); + } + break; + + default: + break; } return gnu_result; @@ -1956,14 +2067,19 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) gnu_result = bitsize_int (bitpos % BITS_PER_UNIT); gnu_result = size_binop (PLUS_EXPR, gnu_result, TYPE_SIZE (TREE_TYPE (gnu_prefix))); - gnu_result = size_binop (MINUS_EXPR, gnu_result, - bitsize_one_node); + /* ??? Avoid a large unsigned result that will overflow when + converted to the signed universal_integer. */ + if (integer_zerop (gnu_result)) + gnu_result = integer_minus_one_node; + else + gnu_result + = size_binop (MINUS_EXPR, gnu_result, bitsize_one_node); break; case Attr_Bit_Position: gnu_result = gnu_field_bitpos; break; - } + } /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are handling. */ @@ -2339,8 +2455,8 @@ Loop_Statement_to_gnu (Node_Id gnat_node) &DECL_SOURCE_LOCATION (gnu_loop_label)); LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label; - /* Save the label so that a corresponding N_Exit_Statement can find it. */ - gnu_loop_info->label = gnu_loop_label; + /* Save the statement for later reuse. */ + gnu_loop_info->stmt = gnu_loop_stmt; /* Set the condition under which the loop must keep going. For the case "LOOP .... END LOOP;" the condition is always true. */ @@ -2694,7 +2810,7 @@ establish_gnat_vms_condition_handler (void) ptr_void_type_node, ptr_void_type_node, NULL_TREE), - NULL_TREE, false, true, true, true, NULL, + NULL_TREE, is_disabled, true, true, true, NULL, Empty); /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL. */ @@ -3246,7 +3362,6 @@ build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog) = convert_vms_descriptor (TREE_TYPE (gnu_subprog_param), gnu_stub_param, DECL_PARM_ALT_TYPE (gnu_stub_param), - DECL_BY_DOUBLE_REF_P (gnu_subprog_param), gnat_subprog); } else @@ -3541,8 +3656,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL); annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE, - DECL_BY_REF_P (gnu_param), - !is_var_decl && DECL_BY_DOUBLE_REF_P (gnu_param)); + DECL_BY_REF_P (gnu_param)); if (is_var_decl) save_gnu_tree (gnat_param, NULL_TREE, false); @@ -4004,12 +4118,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, /* The symmetry of the paths to the type of an entity is broken here since arguments don't know that they will be passed by ref. */ gnu_formal_type = TREE_TYPE (gnu_formal); - - if (DECL_BY_DOUBLE_REF_P (gnu_formal)) - gnu_actual - = build_unary_op (ADDR_EXPR, TREE_TYPE (gnu_formal_type), - gnu_actual); - gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); } else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal)) @@ -4748,7 +4856,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) tree gnu_elab_proc_decl = create_subprog_decl (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"), - NULL_TREE, void_ftype, NULL_TREE, false, true, false, true, NULL, + NULL_TREE, void_ftype, NULL_TREE, is_disabled, true, false, true, NULL, gnat_unit); struct elab_info *info; @@ -5676,7 +5784,7 @@ gnat_to_gnu (Node_Id gnat_node) create_subprog_decl (create_concat_name (Entity (Prefix (gnat_node)), attr == Attr_Elab_Body ? "elabb" : "elabs"), - NULL_TREE, void_ftype, NULL_TREE, false, + NULL_TREE, void_ftype, NULL_TREE, is_disabled, true, true, true, NULL, gnat_node); gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr); @@ -6285,7 +6393,7 @@ gnat_to_gnu (Node_Id gnat_node) ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE), (Present (Name (gnat_node)) ? get_gnu_tree (Entity (Name (gnat_node))) - : gnu_loop_stack->last ()->label)); + : LOOP_STMT_LABEL (gnu_loop_stack->last ()->stmt))); break; case N_Simple_Return_Statement: @@ -8599,7 +8707,7 @@ process_type (Entity_Id gnat_entity) if (Present (Freeze_Node (gnat_entity)) || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) && Present (Full_View (gnat_entity)) - && Freeze_Node (Full_View (gnat_entity)) + && Present (Freeze_Node (Full_View (gnat_entity))) && !present_gnu_tree (Full_View (gnat_entity)))) { elaborate_entity (gnat_entity); diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 309cff6ad32..409c0dee94f 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.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- * @@ -233,7 +233,6 @@ 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 bool potential_alignment_gap (tree, tree, tree); -static void process_attributes (tree, struct attrib *); /* Initialize data structures of the utils.c module. */ @@ -653,11 +652,12 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) /* Create a record type that contains a SIZE bytes long field of TYPE with a starting bit position so that it is aligned to ALIGN bits, and leaving at least ROOM bytes free before the field. BASE_ALIGN is the alignment the - record is guaranteed to get. */ + record is guaranteed to get. GNAT_NODE is used for the position of the + associated TYPE_DECL. */ tree make_aligning_type (tree type, unsigned int align, tree size, - unsigned int base_align, int room) + unsigned int base_align, int room, Node_Id gnat_node) { /* We will be crafting a record type with one field at a position set to be the next multiple of ALIGN past record'address + room bytes. We use a @@ -739,7 +739,7 @@ make_aligning_type (tree type, unsigned int align, tree size, /* Declare it now since it will never be declared otherwise. This is necessary to ensure that its subtrees are properly marked. */ - create_type_decl (name, record_type, NULL, true, false, Empty); + create_type_decl (name, record_type, true, false, gnat_node); return record_type; } @@ -1074,7 +1074,7 @@ maybe_pad_type (tree type, tree size, unsigned int align, /* If requested, complete the original type and give it a name. */ if (is_user_type) create_type_decl (get_entity_name (gnat_entity), type, - NULL, !Comes_From_Source (gnat_entity), + !Comes_From_Source (gnat_entity), !(TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL && DECL_IGNORED_P (TYPE_NAME (type))), @@ -2024,7 +2024,7 @@ create_index_type (tree min, tree max, tree index, Node_Id gnat_node) /* Then set the index type. */ SET_TYPE_INDEX_TYPE (type, index); - create_type_decl (NULL_TREE, type, NULL, true, false, gnat_node); + create_type_decl (NULL_TREE, type, true, false, gnat_node); return type; } @@ -2075,8 +2075,8 @@ create_type_stub_decl (tree type_name, tree type) is used for the position of the decl. */ tree -create_type_decl (tree type_name, tree type, struct attrib *attr_list, - bool artificial_p, bool debug_info_p, Node_Id gnat_node) +create_type_decl (tree type_name, tree type, bool artificial_p, + bool debug_info_p, Node_Id gnat_node) { enum tree_code code = TREE_CODE (type); bool named = TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL; @@ -2093,8 +2093,7 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list, DECL_NAME (type_decl) = type_name; } else - type_decl = build_decl (input_location, - TYPE_DECL, type_name, type); + type_decl = build_decl (input_location, TYPE_DECL, type_name, type); DECL_ARTIFICIAL (type_decl) = artificial_p; TYPE_ARTIFICIAL (type) = artificial_p; @@ -2102,8 +2101,6 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list, /* Add this decl to the current binding level. */ gnat_pushdecl (type_decl, gnat_node); - process_attributes (type_decl, attr_list); - /* If we're naming the type, equate the TYPE_STUB_DECL to the name. This causes the name to be also viewed as a "tag" by the debug back-end, with the advantage that no DW_TAG_typedef is emitted @@ -2224,17 +2221,21 @@ create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init, != null_pointer_node) DECL_IGNORED_P (var_decl) = 1; - /* Add this decl to the current binding level. */ - gnat_pushdecl (var_decl, gnat_node); - if (TREE_SIDE_EFFECTS (var_decl)) TREE_ADDRESSABLE (var_decl) = 1; + /* ??? Some attributes cannot be applied to CONST_DECLs. */ + if (TREE_CODE (var_decl) == VAR_DECL) + process_attributes (&var_decl, &attr_list, true, gnat_node); + + /* Add this decl to the current binding level. */ + gnat_pushdecl (var_decl, gnat_node); + if (TREE_CODE (var_decl) == VAR_DECL) { if (asm_name) SET_DECL_ASSEMBLER_NAME (var_decl, asm_name); - process_attributes (var_decl, attr_list); + if (global_bindings_p ()) rest_of_decl_compilation (var_decl, true, 0); } @@ -2450,65 +2451,71 @@ create_param_decl (tree param_name, tree param_type, bool readonly) return param_decl; } -/* Given a DECL and ATTR_LIST, process the listed attributes. */ +/* Process the attributes in ATTR_LIST for NODE, which is either a DECL or + a TYPE. If IN_PLACE is true, the tree pointed to by NODE should not be + changed. GNAT_NODE is used for the position of error messages. */ -static void -process_attributes (tree decl, struct attrib *attr_list) +void +process_attributes (tree *node, struct attrib **attr_list, bool in_place, + Node_Id gnat_node) { - for (; attr_list; attr_list = attr_list->next) - switch (attr_list->type) + struct attrib *attr; + + for (attr = *attr_list; attr; attr = attr->next) + switch (attr->type) { case ATTR_MACHINE_ATTRIBUTE: - input_location = DECL_SOURCE_LOCATION (decl); - decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args, - NULL_TREE), - ATTR_FLAG_TYPE_IN_PLACE); + Sloc_to_locus (Sloc (gnat_node), &input_location); + decl_attributes (node, tree_cons (attr->name, attr->args, NULL_TREE), + in_place ? ATTR_FLAG_TYPE_IN_PLACE : 0); break; case ATTR_LINK_ALIAS: - if (! DECL_EXTERNAL (decl)) + if (!DECL_EXTERNAL (*node)) { - TREE_STATIC (decl) = 1; - assemble_alias (decl, attr_list->name); + TREE_STATIC (*node) = 1; + assemble_alias (*node, attr->name); } break; case ATTR_WEAK_EXTERNAL: if (SUPPORTS_WEAK) - declare_weak (decl); + declare_weak (*node); else post_error ("?weak declarations not supported on this target", - attr_list->error_point); + attr->error_point); break; case ATTR_LINK_SECTION: if (targetm_common.have_named_sections) { - DECL_SECTION_NAME (decl) - = build_string (IDENTIFIER_LENGTH (attr_list->name), - IDENTIFIER_POINTER (attr_list->name)); - DECL_COMMON (decl) = 0; + DECL_SECTION_NAME (*node) + = build_string (IDENTIFIER_LENGTH (attr->name), + IDENTIFIER_POINTER (attr->name)); + DECL_COMMON (*node) = 0; } else post_error ("?section attributes are not supported for this target", - attr_list->error_point); + attr->error_point); break; case ATTR_LINK_CONSTRUCTOR: - DECL_STATIC_CONSTRUCTOR (decl) = 1; - TREE_USED (decl) = 1; + DECL_STATIC_CONSTRUCTOR (*node) = 1; + TREE_USED (*node) = 1; break; case ATTR_LINK_DESTRUCTOR: - DECL_STATIC_DESTRUCTOR (decl) = 1; - TREE_USED (decl) = 1; + DECL_STATIC_DESTRUCTOR (*node) = 1; + TREE_USED (*node) = 1; break; case ATTR_THREAD_LOCAL_STORAGE: - DECL_TLS_MODEL (decl) = decl_default_tls_model (decl); - DECL_COMMON (decl) = 0; + DECL_TLS_MODEL (*node) = decl_default_tls_model (*node); + DECL_COMMON (*node) = 0; break; } + + *attr_list = NULL; } /* Record DECL as a global renaming pointer. */ @@ -2621,14 +2628,14 @@ create_label_decl (tree label_name, Node_Id gnat_node) node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of PARM_DECL nodes chained through the DECL_CHAIN field). - INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, ARTIFICIAL_FLAG and ATTR_LIST are + INLINE_STATUS, PUBLIC_FLAG, EXTERN_FLAG, ARTIFICIAL_FLAG and ATTR_LIST are used to set the appropriate fields in the FUNCTION_DECL. GNAT_NODE is used for the position of the decl. */ tree create_subprog_decl (tree subprog_name, tree asm_name, tree subprog_type, - tree param_decl_list, bool inline_flag, bool public_flag, - bool extern_flag, bool artificial_flag, + tree param_decl_list, enum inline_status_t inline_status, + bool public_flag, bool extern_flag, bool artificial_flag, struct attrib *attr_list, Node_Id gnat_node) { tree subprog_decl = build_decl (input_location, FUNCTION_DECL, subprog_name, @@ -2642,7 +2649,7 @@ create_subprog_decl (tree subprog_name, tree asm_name, tree subprog_type, function in the current unit since it is private to the other unit. We could inline the nested function as well but it's probably better to err on the side of too little inlining. */ - if (!inline_flag + if (inline_status != is_enabled && !public_flag && current_function_decl && DECL_DECLARED_INLINE_P (current_function_decl) @@ -2651,8 +2658,24 @@ create_subprog_decl (tree subprog_name, tree asm_name, tree subprog_type, DECL_ARTIFICIAL (subprog_decl) = artificial_flag; DECL_EXTERNAL (subprog_decl) = extern_flag; - DECL_DECLARED_INLINE_P (subprog_decl) = inline_flag; - DECL_NO_INLINE_WARNING_P (subprog_decl) = inline_flag && artificial_flag; + + switch (inline_status) + { + case is_suppressed: + DECL_UNINLINABLE (subprog_decl) = 1; + break; + + case is_disabled: + break; + + case is_enabled: + DECL_DECLARED_INLINE_P (subprog_decl) = 1; + DECL_NO_INLINE_WARNING_P (subprog_decl) = artificial_flag; + break; + + default: + gcc_unreachable (); + } TREE_PUBLIC (subprog_decl) = public_flag; TREE_READONLY (subprog_decl) = TYPE_READONLY (subprog_type); @@ -2678,11 +2701,11 @@ create_subprog_decl (tree subprog_name, tree asm_name, tree subprog_type, DECL_NAME (subprog_decl) = main_identifier_node; } + process_attributes (&subprog_decl, &attr_list, true, gnat_node); + /* Add this decl to the current binding level. */ gnat_pushdecl (subprog_decl, gnat_node); - process_attributes (subprog_decl, attr_list); - /* Output the assembler code and/or RTL for the declaration. */ rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0); @@ -4073,33 +4096,25 @@ convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) /* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit) - pointer type of GNU_EXPR. BY_REF is true if the result is to be used by - reference. GNAT_SUBPROG is the subprogram to which the VMS descriptor is - passed. */ + pointer type of GNU_EXPR. GNAT_SUBPROG is the subprogram to which the + descriptor is passed. */ tree convert_vms_descriptor (tree gnu_type, tree gnu_expr, tree gnu_expr_alt_type, - bool by_ref, Entity_Id gnat_subprog) + Entity_Id gnat_subprog) { tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); tree mbo = TYPE_FIELDS (desc_type); const char *mbostr = IDENTIFIER_POINTER (DECL_NAME (mbo)); tree mbmo = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (mbo))); - tree real_type, is64bit, gnu_expr32, gnu_expr64; - - if (by_ref) - real_type = TREE_TYPE (gnu_type); - else - real_type = gnu_type; + tree is64bit, gnu_expr32, gnu_expr64; /* If the field name is not MBO, it must be 32-bit and no alternate. Otherwise primary must be 64-bit and alternate 32-bit. */ if (strcmp (mbostr, "MBO") != 0) { - tree ret = convert_vms_descriptor32 (real_type, gnu_expr, gnat_subprog); - if (by_ref) - ret = build_unary_op (ADDR_EXPR, gnu_type, ret); + tree ret = convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog); return ret; } @@ -4116,14 +4131,9 @@ convert_vms_descriptor (tree gnu_type, tree gnu_expr, tree gnu_expr_alt_type, integer_minus_one_node)); /* Build the 2 possible end results. */ - gnu_expr64 = convert_vms_descriptor64 (real_type, gnu_expr, gnat_subprog); - if (by_ref) - gnu_expr64 = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr64); + gnu_expr64 = convert_vms_descriptor64 (gnu_type, gnu_expr, gnat_subprog); gnu_expr = fold_convert (gnu_expr_alt_type, gnu_expr); - gnu_expr32 = convert_vms_descriptor32 (real_type, gnu_expr, gnat_subprog); - if (by_ref) - gnu_expr32 = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr32); - + gnu_expr32 = convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog); return build3 (COND_EXPR, gnu_type, is64bit, gnu_expr64, gnu_expr32); } @@ -4153,7 +4163,7 @@ build_unc_object_type (tree template_type, tree object_type, tree name, /* Declare it now since it will never be declared otherwise. This is necessary to ensure that its subtrees are properly marked. */ - create_type_decl (name, type, NULL, true, debug_info_p, Empty); + create_type_decl (name, type, true, debug_info_p, Empty); return type; } @@ -6341,7 +6351,6 @@ handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args), /* Vector representative type and size. */ tree rep_type = *node; tree rep_size = TYPE_SIZE_UNIT (rep_type); - tree rep_name; /* Vector size in bytes and number of units. */ unsigned HOST_WIDE_INT vec_bytes, vec_units; @@ -6352,12 +6361,6 @@ handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args), *no_add_attrs = true; - /* Get the representative array type, possibly nested within a - padding record e.g. for alignment purposes. */ - - if (TYPE_IS_PADDING_P (rep_type)) - rep_type = TREE_TYPE (TYPE_FIELDS (rep_type)); - if (TREE_CODE (rep_type) != ARRAY_TYPE) { error ("attribute %qs applies to array types only", @@ -6418,10 +6421,6 @@ handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args), /* Build the vector type and replace. */ *node = build_vector_type (elem_type, vec_units); - rep_name = TYPE_NAME (rep_type); - if (TREE_CODE (rep_name) == TYPE_DECL) - rep_name = DECL_NAME (rep_name); - TYPE_NAME (*node) = rep_name; TYPE_REPRESENTATIVE_ARRAY (*node) = rep_type; return NULL_TREE; diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 71dd8e56513..3f39a432696 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.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- * @@ -2101,7 +2101,8 @@ maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node) = ((data_align > system_allocator_alignment) ? make_aligning_type (data_type, data_align, data_size, system_allocator_alignment, - POINTER_SIZE / BITS_PER_UNIT) + POINTER_SIZE / BITS_PER_UNIT, + gnat_node) : NULL_TREE); tree size_to_malloc diff --git a/gcc/ada/get_alfa.adb b/gcc/ada/get_spark_xrefs.adb index a10637cd360..92964b31379 100644 --- a/gcc/ada/get_alfa.adb +++ b/gcc/ada/get_spark_xrefs.adb @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- G E T _ A L F A -- +-- G E T _ S P A R K _ X R E F S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2012, 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- -- @@ -23,12 +23,12 @@ -- -- ------------------------------------------------------------------------------ -with Alfa; use Alfa; -with Types; use Types; +with SPARK_Xrefs; use SPARK_Xrefs; +with Types; use Types; with Ada.IO_Exceptions; use Ada.IO_Exceptions; -procedure Get_Alfa is +procedure Get_SPARK_Xrefs is C : Character; use ASCII; @@ -41,10 +41,10 @@ procedure Get_Alfa is -- Scope number for the current scope entity Cur_File_Idx : File_Index; - -- Index in Alfa_File_Table of the current file + -- Index in SPARK_File_Table of the current file Cur_Scope_Idx : Scope_Index; - -- Index in Alfa_Scope_Table of the current scope + -- Index in SPARK_Scope_Table of the current scope Name_Str : String (1 .. 32768); Name_Len : Natural := 0; @@ -196,17 +196,17 @@ procedure Get_Alfa is end loop; end Skip_Spaces; --- Start of processing for Get_Alfa +-- Start of processing for Get_SPARK_Xrefs begin - Initialize_Alfa_Tables; + Initialize_SPARK_Tables; Cur_File := 0; Cur_Scope := 0; Cur_File_Idx := 1; Cur_Scope_Idx := 0; - -- Loop through lines of Alfa information + -- Loop through lines of SPARK cross-reference information while Nextc = 'F' loop Skipc; @@ -215,7 +215,7 @@ begin -- Make sure first line is a File line - if Alfa_File_Table.Last = 0 and then C /= 'D' then + if SPARK_File_Table.Last = 0 and then C /= 'D' then raise Data_Error; end if; @@ -229,9 +229,9 @@ begin -- Complete previous entry if any - if Alfa_File_Table.Last /= 0 then - Alfa_File_Table.Table (Alfa_File_Table.Last).To_Scope := - Alfa_Scope_Table.Last; + if SPARK_File_Table.Last /= 0 then + SPARK_File_Table.Table (SPARK_File_Table.Last).To_Scope := + SPARK_Scope_Table.Last; end if; -- Scan out dependency number and file name @@ -259,11 +259,11 @@ begin -- Make new File table entry (will fill in To_Scope later) - Alfa_File_Table.Append ( + SPARK_File_Table.Append ( (File_Name => File_Name, Unit_File_Name => Unit_File_Name, File_Num => Cur_File, - From_Scope => Alfa_Scope_Table.Last + 1, + From_Scope => SPARK_Scope_Table.Last + 1, To_Scope => 0)); -- Initialize counter for scopes @@ -320,7 +320,7 @@ begin -- To_Xref later). Initial range (From_Xref .. To_Xref) is -- empty for scopes without entities. - Alfa_Scope_Table.Append ( + SPARK_Scope_Table.Append ( (Scope_Entity => Empty, Scope_Name => new String'(Name_Str (1 .. Name_Len)), File_Num => Cur_File, @@ -352,7 +352,7 @@ begin -- Update component From_Xref of current file if first reference -- in this file. - while Alfa_File_Table.Table (Cur_File_Idx).File_Num /= Cur_File + while SPARK_File_Table.Table (Cur_File_Idx).File_Num /= Cur_File loop Cur_File_Idx := Cur_File_Idx + 1; end loop; @@ -368,21 +368,22 @@ begin -- Update component To_Xref of previous scope if Cur_Scope_Idx /= 0 then - Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := - Alfa_Xref_Table.Last; + SPARK_Scope_Table.Table (Cur_Scope_Idx).To_Xref := + SPARK_Xref_Table.Last; end if; -- Update component From_Xref of current scope - Cur_Scope_Idx := Alfa_File_Table.Table (Cur_File_Idx).From_Scope; + Cur_Scope_Idx := SPARK_File_Table.Table (Cur_File_Idx).From_Scope; - while Alfa_Scope_Table.Table (Cur_Scope_Idx).Scope_Num /= Cur_Scope + while SPARK_Scope_Table.Table (Cur_Scope_Idx).Scope_Num /= + Cur_Scope loop Cur_Scope_Idx := Cur_Scope_Idx + 1; end loop; - Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := - Alfa_Xref_Table.Last + 1; + SPARK_Scope_Table.Table (Cur_Scope_Idx).From_Xref := + SPARK_Xref_Table.Last + 1; -- Cross reference entry @@ -457,7 +458,7 @@ begin Rtype = 'm' or else Rtype = 's'); - Alfa_Xref_Table.Append ( + SPARK_Xref_Table.Append ( (Entity_Name => XR_Entity, Entity_Line => XR_Entity_Line, Etype => XR_Entity_Typ, @@ -473,7 +474,7 @@ begin end loop; end; - -- No other Alfa lines are possible + -- No other SPARK lines are possible when others => raise Data_Error; @@ -488,12 +489,12 @@ begin -- Here with all Xrefs stored, complete last entries in File/Scope tables - if Alfa_File_Table.Last /= 0 then - Alfa_File_Table.Table (Alfa_File_Table.Last).To_Scope := - Alfa_Scope_Table.Last; + if SPARK_File_Table.Last /= 0 then + SPARK_File_Table.Table (SPARK_File_Table.Last).To_Scope := + SPARK_Scope_Table.Last; end if; if Cur_Scope_Idx /= 0 then - Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := Alfa_Xref_Table.Last; + SPARK_Scope_Table.Table (Cur_Scope_Idx).To_Xref := SPARK_Xref_Table.Last; end if; -end Get_Alfa; +end Get_SPARK_Xrefs; diff --git a/gcc/ada/get_alfa.ads b/gcc/ada/get_spark_xrefs.ads index e8c6a17aa13..22af7edccc2 100644 --- a/gcc/ada/get_alfa.ads +++ b/gcc/ada/get_spark_xrefs.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- G E T _ A L F A -- +-- G E T _ S P A R K _ X R E F S -- -- -- -- S p e c -- -- -- --- 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- -- @@ -23,8 +23,9 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the function used to read Alfa information from an --- ALI file and populate the tables defined in package Alfa with the result. +-- This package contains the function used to read SPARK cross-reference +-- information from an ALI file and populate the tables defined in package +-- SPARK_Xrefs with the result. generic -- These subprograms provide access to the ALI file. Locating, opening and @@ -46,12 +47,13 @@ generic -- and position to the next character, which will be returned by the next -- call to Getc or Nextc. -procedure Get_Alfa; --- Load Alfa information from ALI file text format into internal Alfa tables --- (Alfa.Alfa_Xref_Table, Alfa.Alfa_Scope_Table and Alfa.Alfa_File_Table). On --- entry the input file is positioned to the initial 'F' of the first Alfa +procedure Get_SPARK_Xrefs; +-- Load SPARK cross-reference information from ALI file text format into +-- internal SPARK tables (SPARK_Xrefs.SPARK_Xref_Table, +-- SPARK_Xrefs.SPARK_Scope_Table and SPARK_Xrefs.SPARK_File_Table). On entry +-- the input file is positioned to the initial 'F' of the first SPARK specific -- line in the ALI file. On return, the file is positioned either to the end --- of file, or to the first character of the line following the Alfa +-- of file, or to the first character of the line following the SPARK specific -- information (which will never start with an 'F'). -- -- If a format error is detected in the input, then an exception is raised diff --git a/gcc/ada/get_targ.adb b/gcc/ada/get_targ.adb index 9eb588dd522..a2f7370f8e5 100644 --- a/gcc/ada/get_targ.adb +++ b/gcc/ada/get_targ.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, 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- -- @@ -25,6 +25,261 @@ package body Get_Targ is + -- Functions returning individual runtime. For the standard (GCC) back + -- end these come from C interface functions (one for each value). + + ----------------------- + -- Get_Bits_Per_Unit -- + ----------------------- + + function Get_Bits_Per_Unit return Pos is + function C_Get_Bits_Per_Unit return Pos; + pragma Import (C, C_Get_Bits_Per_Unit, + "get_target_bits_per_unit"); + begin + return C_Get_Bits_Per_Unit; + end Get_Bits_Per_Unit; + + ----------------------- + -- Get_Bits_Per_Word -- + ----------------------- + + function Get_Bits_Per_Word return Pos is + function C_Get_Bits_Per_Word return Pos; + pragma Import (C, C_Get_Bits_Per_Word, + "get_target_bits_per_word"); + begin + return C_Get_Bits_Per_Word; + end Get_Bits_Per_Word; + + ------------------- + -- Get_Char_Size -- + ------------------- + + function Get_Char_Size return Pos is + function C_Get_Char_Size return Pos; + pragma Import (C, C_Get_Char_Size, + "get_target_char_size"); + begin + return C_Get_Char_Size; + end Get_Char_Size; + + ---------------------- + -- Get_Wchar_T_Size -- + ---------------------- + + function Get_Wchar_T_Size return Pos is + function C_Get_Wchar_T_Size return Pos; + pragma Import (C, C_Get_Wchar_T_Size, + "get_target_wchar_t_size"); + begin + return C_Get_Wchar_T_Size; + end Get_Wchar_T_Size; + + -------------------- + -- Get_Short_Size -- + -------------------- + + function Get_Short_Size return Pos is + function C_Get_Short_Size return Pos; + pragma Import (C, C_Get_Short_Size, + "get_target_short_size"); + begin + return C_Get_Short_Size; + end Get_Short_Size; + + ------------------ + -- Get_Int_Size -- + ------------------ + + function Get_Int_Size return Pos is + function C_Get_Int_Size return Pos; + pragma Import (C, C_Get_Int_Size, + "get_target_int_size"); + begin + return C_Get_Int_Size; + end Get_Int_Size; + + ------------------- + -- Get_Long_Size -- + ------------------- + + function Get_Long_Size return Pos is + function C_Get_Long_Size return Pos; + pragma Import (C, C_Get_Long_Size, + "get_target_long_size"); + begin + return C_Get_Long_Size; + end Get_Long_Size; + + ------------------------ + -- Get_Long_Long_Size -- + ------------------------ + + function Get_Long_Long_Size return Pos is + function C_Get_Long_Long_Size return Pos; + pragma Import (C, C_Get_Long_Long_Size, + "get_target_long_long_size"); + begin + return C_Get_Long_Long_Size; + end Get_Long_Long_Size; + + -------------------- + -- Get_Float_Size -- + -------------------- + + function Get_Float_Size return Pos is + function C_Get_Float_Size return Pos; + pragma Import (C, C_Get_Float_Size, + "get_target_float_size"); + begin + return C_Get_Float_Size; + end Get_Float_Size; + + --------------------- + -- Get_Double_Size -- + --------------------- + + function Get_Double_Size return Pos is + function C_Get_Double_Size return Pos; + pragma Import (C, C_Get_Double_Size, + "get_target_double_size"); + begin + return C_Get_Double_Size; + end Get_Double_Size; + + -------------------------- + -- Get_Long_Double_Size -- + -------------------------- + + function Get_Long_Double_Size return Pos is + function C_Get_Long_Double_Size return Pos; + pragma Import (C, C_Get_Long_Double_Size, + "get_target_long_double_size"); + begin + return C_Get_Long_Double_Size; + end Get_Long_Double_Size; + + ---------------------- + -- Get_Pointer_Size -- + ---------------------- + + function Get_Pointer_Size return Pos is + function C_Get_Pointer_Size return Pos; + pragma Import (C, C_Get_Pointer_Size, + "get_target_pointer_size"); + begin + return C_Get_Pointer_Size; + end Get_Pointer_Size; + + --------------------------- + -- Get_Maximum_Alignment -- + --------------------------- + + function Get_Maximum_Alignment return Pos is + function C_Get_Maximum_Alignment return Pos; + pragma Import (C, C_Get_Maximum_Alignment, + "get_target_maximum_alignment"); + begin + return C_Get_Maximum_Alignment; + end Get_Maximum_Alignment; + + ------------------------ + -- Get_Float_Words_BE -- + ------------------------ + + function Get_Float_Words_BE return Nat is + function C_Get_Float_Words_BE return Nat; + pragma Import (C, C_Get_Float_Words_BE, + "get_float_words_be"); + begin + return C_Get_Float_Words_BE; + end Get_Float_Words_BE; + + ------------------ + -- Get_Words_BE -- + ------------------ + + function Get_Words_BE return Nat is + function C_Get_Words_BE return Nat; + pragma Import (C, C_Get_Words_BE, + "get_words_be"); + begin + return C_Get_Words_BE; + end Get_Words_BE; + + ------------------ + -- Get_Bytes_BE -- + ------------------ + + function Get_Bytes_BE return Nat is + function C_Get_Bytes_BE return Nat; + pragma Import (C, C_Get_Bytes_BE, + "get_bytes_be"); + begin + return C_Get_Bytes_BE; + end Get_Bytes_BE; + + ----------------- + -- Get_Bits_BE -- + ----------------- + + function Get_Bits_BE return Nat is + function C_Get_Bits_BE return Nat; + pragma Import (C, C_Get_Bits_BE, + "get_bits_be"); + begin + return C_Get_Bits_BE; + end Get_Bits_BE; + + -------------------------- + -- Get_Strict_Alignment -- + -------------------------- + + function Get_Strict_Alignment return Nat is + function C_Get_Strict_Alignment return Nat; + pragma Import (C, C_Get_Strict_Alignment, + "get_target_strict_alignment"); + begin + return C_Get_Strict_Alignment; + end Get_Strict_Alignment; + + ------------------------------------ + -- Get_System_Allocator_Alignment -- + ------------------------------------ + + function Get_System_Allocator_Alignment return Nat is + function C_Get_System_Allocator_Alignment return Nat; + pragma Import (C, C_Get_System_Allocator_Alignment, + "get_target_system_allocator_alignment"); + begin + return C_Get_System_Allocator_Alignment; + end Get_System_Allocator_Alignment; + + -------------------------------- + -- Get_Double_Float_Alignment -- + -------------------------------- + + function Get_Double_Float_Alignment return Nat is + function C_Get_Double_Float_Alignment return Nat; + pragma Import (C, C_Get_Double_Float_Alignment, + "get_target_double_float_alignment"); + begin + return C_Get_Double_Float_Alignment; + end Get_Double_Float_Alignment; + + --------------------------------- + -- Get_Double_Scalar_Alignment -- + --------------------------------- + + function Get_Double_Scalar_Alignment return Nat is + function C_Get_Double_Scalar_Alignment return Nat; + pragma Import (C, C_Get_Double_Scalar_Alignment, + "get_target_double_scalar_alignment"); + begin + return C_Get_Double_Scalar_Alignment; + end Get_Double_Scalar_Alignment; + ---------------------- -- Digits_From_Size -- ---------------------- @@ -55,6 +310,17 @@ package body Get_Targ is return 64; -- Can be different on some targets (e.g., AAMP) end Get_Max_Unaligned_Field; + ----------------------------- + -- Register_Back_End_Types -- + ----------------------------- + + procedure Register_Back_End_Types (Call_Back : Register_Type_Proc) is + procedure Enumerate_Modes (Call_Back : Register_Type_Proc); + pragma Import (C, Enumerate_Modes, "enumerate_modes"); + begin + Enumerate_Modes (Call_Back); + end Register_Back_End_Types; + --------------------- -- Width_From_Size -- --------------------- diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads index 6cdbf7509a4..08af7f33855 100644 --- a/gcc/ada/get_targ.ads +++ b/gcc/ada/get_targ.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- -- @@ -25,87 +25,90 @@ -- This package provides an Import to the C functions which provide -- values related to types on the target system. It is only needed for --- exp_dbug and the elaboration of ttypes. +-- exp_dbug and the elaboration of ttypes, via the Set_Targs package. +-- It also contains the routine for registering floating-point types. -- NOTE: Any changes in this package must be reflected in jgettarg.ads --- and aa_getta.ads! +-- and aa_getta.ads and any other versions of this package. -- Note that all these values return sizes of C types with corresponding -- names. This allows GNAT to define the corresponding Ada types to have --- the same representation. There is one exception to this: the --- Wide_Character_Type uses twice the size of a C char, instead of the +-- the same representation. There is one exception to this general rule: +-- the Wide_Character_Type uses twice the size of a C char, instead of the -- size of wchar_t. +with Einfo; use Einfo; with Types; use Types; package Get_Targ is - pragma Preelaborate; - function Get_Bits_Per_Unit return Pos; - pragma Import (C, Get_Bits_Per_Unit, "get_target_bits_per_unit"); + -- Functions returning individual runtime values - function Get_Bits_Per_Word return Pos; - pragma Import (C, Get_Bits_Per_Word, "get_target_bits_per_word"); + function Get_Bits_Per_Unit return Pos; + -- System.Storage_Unit - function Get_Char_Size return Pos; -- Standard.Character'Size - pragma Import (C, Get_Char_Size, "get_target_char_size"); + function Get_Bits_Per_Word return Pos; + -- System.Word_Size - function Get_Wchar_T_Size return Pos; -- Interfaces.C.wchar_t'Size - pragma Import (C, Get_Wchar_T_Size, "get_target_wchar_t_size"); + function Get_Char_Size return Pos; + -- Size of Standard.Character - function Get_Short_Size return Pos; -- Standard.Short_Integer'Size - pragma Import (C, Get_Short_Size, "get_target_short_size"); + function Get_Wchar_T_Size return Pos; + -- Size of Interfaces.C.wchar_t - function Get_Int_Size return Pos; -- Standard.Integer'Size - pragma Import (C, Get_Int_Size, "get_target_int_size"); + function Get_Short_Size return Pos; + -- Size of Standard.Short_Integer - function Get_Long_Size return Pos; -- Standard.Long_Integer'Size - pragma Import (C, Get_Long_Size, "get_target_long_size"); + function Get_Int_Size return Pos; + -- Size of Standard.Integer - function Get_Long_Long_Size return Pos; -- Standard.Long_Long_Integer'Size - pragma Import (C, Get_Long_Long_Size, "get_target_long_long_size"); + function Get_Long_Size return Pos; + -- Size of Standard.Long_Integer - function Get_Float_Size return Pos; -- Standard.Float'Size - pragma Import (C, Get_Float_Size, "get_target_float_size"); + function Get_Long_Long_Size return Pos; + -- Size of Standard.Long_Long_Integer - function Get_Double_Size return Pos; -- Standard.Long_Float'Size - pragma Import (C, Get_Double_Size, "get_target_double_size"); + function Get_Float_Size return Pos; + -- Size of Standard.Float - function Get_Long_Double_Size return Pos; -- Standard.Long_Long_Float'Size - pragma Import (C, Get_Long_Double_Size, "get_target_long_double_size"); + function Get_Double_Size return Pos; + -- Size of Standard.Long_Float - function Get_Pointer_Size return Pos; -- System.Address'Size - pragma Import (C, Get_Pointer_Size, "get_target_pointer_size"); + function Get_Long_Double_Size return Pos; + -- Size of Standard.Long_Long_Float - function Get_Maximum_Alignment return Pos; - pragma Import (C, Get_Maximum_Alignment, "get_target_maximum_alignment"); + function Get_Pointer_Size return Pos; + -- Size of System.Address - function Get_Float_Words_BE return Nat; - pragma Import (C, Get_Float_Words_BE, "get_float_words_be"); + function Get_Maximum_Alignment return Pos; + -- Maximum supported alignment - function Get_Words_BE return Nat; - pragma Import (C, Get_Words_BE, "get_words_be"); + function Get_Float_Words_BE return Nat; + -- Non-zero iff float words big endian - function Get_Bytes_BE return Nat; - pragma Import (C, Get_Bytes_BE, "get_bytes_be"); + function Get_Words_BE return Nat; + -- Non-zero iff integer words big endian - function Get_Bits_BE return Nat; - pragma Import (C, Get_Bits_BE, "get_bits_be"); + function Get_Bytes_BE return Nat; + -- Non-zero iff bytes big-endian - function Get_Strict_Alignment return Nat; - pragma Import (C, Get_Strict_Alignment, "get_target_strict_alignment"); + function Get_Bits_BE return Nat; + -- Non-zero iff bit order big endian + + function Get_Strict_Alignment return Nat; + -- Non-zero if target requires strict alignent function Get_System_Allocator_Alignment return Nat; - pragma Import (C, Get_System_Allocator_Alignment, - "get_target_system_allocator_alignment"); + -- Alignment guaranteed by malloc falls + + function Get_Double_Float_Alignment return Nat; + -- Alignment required for Long_Float or 0 if no special requirement - function Get_Double_Float_Alignment return Nat; - pragma Import (C, Get_Double_Float_Alignment, - "get_target_double_float_alignment"); + function Get_Double_Scalar_Alignment return Nat; + -- Alignment required for Long_Long_Integer or larger integer types + -- or 0 if no special requirement. - function Get_Double_Scalar_Alignment return Nat; - pragma Import (C, Get_Double_Scalar_Alignment, - "get_target_double_scalar_alignment"); + -- Other subprograms function Get_Max_Unaligned_Field return Pos; -- Returns the maximum supported size in bits for a field that is @@ -115,4 +118,23 @@ package Get_Targ is function Digits_From_Size (Size : Pos) return Pos; -- Calculate values for 'Width or 'Digits from 'Size + type C_String is array (0 .. 255) of aliased Character; + pragma Convention (C, C_String); + + type Register_Type_Proc is access procedure + (C_Name : C_String; -- Nul-terminated string with name of type + Digs : Natural; -- Digits for floating point, 0 otherwise + Complex : Boolean; -- True iff type has real and imaginary parts + Count : Natural; -- Number of elements in vector, 0 otherwise + Float_Rep : Float_Rep_Kind; -- Representation used for fpt type + Size : Positive; -- Size of representation in bits + Alignment : Natural); -- Required alignment in bits + pragma Convention (C, Register_Type_Proc); + -- Call back procedure for Register_Back_End_Types. This is to be used by + -- Create_Standard to create predefined types for all types supported by + -- the back end. + + procedure Register_Back_End_Types (Call_Back : Register_Type_Proc); + -- Calls the Call_Back function with information for each supported type + end Get_Targ; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 4cfc3392f24..fa959df7407 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.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- -- @@ -61,6 +61,7 @@ with Sem_Ch13; with Sem_Elim; with Sem_Eval; with Sem_Type; +with Set_Targ; with Sinfo; use Sinfo; with Sinput.L; use Sinput.L; with Snames; @@ -110,11 +111,10 @@ procedure Gnat1drv is procedure Adjust_Global_Switches is begin - -- Debug flag -gnatd.I is a synonym for Generate_SCIL and requires code - -- generation. + -- -gnatd.M enables Relaxed_RM_Semantics - if Debug_Flag_Dot_II and then Operating_Mode = Generate_Code then - Generate_SCIL := True; + if Debug_Flag_Dot_MM then + Relaxed_RM_Semantics := True; end if; -- Disable CodePeer_Mode in Check_Syntax, since we need front-end @@ -240,11 +240,9 @@ procedure Gnat1drv is Generate_SCIL := True; - -- Enable assertions and debug pragmas, since they give CodePeer - -- valuable extra information. + -- Enable assertions, since they give CodePeer valuable extra info Assertions_Enabled := True; - Debug_Pragmas_Enabled := True; -- Disable all simple value propagation. This is an optimization -- which is valuable for code optimization, and also for generation @@ -275,6 +273,17 @@ procedure Gnat1drv is Force_ALI_Tree_File := True; Try_Semantics := True; + + -- Make the Ada front-end more liberal so that the compiler will + -- allow illegal code that is allowed by other compilers. CodePeer + -- is in the business of finding problems, not enforcing rules! + -- This is useful when using CodePeer mode with other compilers. + + Relaxed_RM_Semantics := True; + end if; + + if Relaxed_RM_Semantics then + Overriding_Renamings := True; end if; -- Set switches for formal verification mode @@ -283,13 +292,32 @@ procedure Gnat1drv is Formal_Extensions := True; end if; + -- Enable SPARK_Mode when using -gnatd.F switch + if Debug_Flag_Dot_FF then - Alfa_Mode := True; + SPARK_Mode := True; + end if; + + -- SPARK_Mode is also activated by default in the gnat2why executable + + if SPARK_Mode then -- Set strict standard interpretation of compiler permissions if Debug_Flag_Dot_DD then - Strict_Alfa_Mode := True; + SPARK_Strict_Mode := True; + end if; + + -- Distinguish between the two modes of gnat2why: frame condition + -- generation (generation of ALI files) and translation of Why (no + -- ALI files generated). This is done with the switch -gnatd.G, + -- which activates frame condition mode. The other changes in + -- behavior depending on this switch are done in gnat2why directly. + + if Debug_Flag_Dot_GG then + Frame_Condition_Mode := True; + else + Opt.Disable_ALI_File := True; end if; -- Turn off inlining, which would confuse formal verification output @@ -306,7 +334,7 @@ procedure Gnat1drv is -- Enable some restrictions systematically to simplify the generated -- code (and ease analysis). Note that restriction checks are also - -- disabled in Alfa mode, see Restrict.Check_Restriction, and user + -- disabled in SPARK mode, see Restrict.Check_Restriction, and user -- specified Restrictions pragmas are ignored, see -- Sem_Prag.Process_Restrictions_Or_Restriction_Warnings. @@ -318,7 +346,7 @@ procedure Gnat1drv is -- points at which potential checks are required semantically). We -- don't want the expansion associated with these checks, but that -- happens anyway because this expansion is simply not done in the - -- Alfa version of the expander. + -- SPARK version of the expander. -- Turn off dynamic elaboration checks: generates inconsistencies in -- trees between specs compiled as part of a main unit or as part of @@ -350,7 +378,7 @@ procedure Gnat1drv is Polling_Required := False; -- Set operating mode to Generate_Code, but full front-end expansion - -- is not desirable in Alfa mode, so a light expansion is performed + -- is not desirable in SPARK mode, so a light expansion is performed -- instead. Operating_Mode := Generate_Code; @@ -359,26 +387,13 @@ procedure Gnat1drv is Debug_Flag_HH := True; - -- Disable Expressions_With_Actions nodes - - -- The gnat2why backend does not deal with Expressions_With_Actions - -- in all places (in particular assertions). It is difficult to - -- determine in the frontend which cases are allowed, so we disable - -- Expressions_With_Actions entirely. Even in the cases where - -- gnat2why deals with Expressions_With_Actions, it is easier to - -- deal with the original constructs (quantified, conditional and - -- case expressions) instead of the rewritten ones. + -- Enable assertions, since they give valuable extra information for + -- formal verification. - Use_Expression_With_Actions := False; - - -- Enable assertions and debug pragmas, since they give valuable - -- extra information for formal verification. - - Assertions_Enabled := True; - Debug_Pragmas_Enabled := True; + Assertions_Enabled := True; -- Turn off style check options since we are not interested in any - -- front-end warnings when we are getting Alfa output. + -- front-end warnings when we are getting SPARK output. Reset_Style_Check_Options; @@ -388,16 +403,17 @@ procedure Gnat1drv is Warning_Mode := Suppress; -- Suppress the generation of name tables for enumerations, which are - -- not needed for formal verification, and fall outside the Alfa + -- not needed for formal verification, and fall outside the SPARK -- subset (use of pointers). Global_Discard_Names := True; -- Suppress the expansion of tagged types and dispatching calls, - -- which lead to the generation of non-Alfa code (use of pointers), + -- which lead to the generation of non-SPARK code (use of pointers), -- which is more complex to formally verify than the original source. Tagged_Type_Expansion := False; + end if; -- Set Configurable_Run_Time mode if system.ads flag set @@ -467,7 +483,7 @@ procedure Gnat1drv is -- Set proper status for overflow check mechanism - -- If already set (by -gnato or above in Alfa or CodePeer mode) then we + -- If already set (by -gnato or above in SPARK or CodePeer mode) then we -- have nothing to do. if Opt.Suppress_Options.Overflow_Mode_General /= Not_Set then @@ -520,24 +536,6 @@ procedure Gnat1drv is Suppress_Options.Suppress (Atomic_Synchronization) := not Atomic_Sync_Default_On_Target; - -- Set switch indicating if we can use N_Expression_With_Actions - - -- Debug flag -gnatd.X decisively sets usage on - - if Debug_Flag_Dot_XX then - Use_Expression_With_Actions := True; - - -- Debug flag -gnatd.Y decisively sets usage off - - elsif Debug_Flag_Dot_YY then - Use_Expression_With_Actions := False; - - -- Otherwise this feature is implemented, so we allow its use - - else - Use_Expression_With_Actions := True; - end if; - -- Set switch indicating if back end can handle limited types, and -- guarantee that no incorrect copies are made (e.g. in the context -- of an if or case expression). @@ -848,6 +846,14 @@ begin Usage; end if; + -- Generate target dependent output file if requested + + if Target_Dependent_Info_Write_Name /= null then + Set_Targ.Write_Target_Dependent_Values; + end if; + + -- Call the front end + Original_Operating_Mode := Operating_Mode; Frontend; @@ -1020,11 +1026,24 @@ begin elsif Main_Kind in N_Generic_Renaming_Declaration then Back_End_Mode := Generate_Object; - -- It's not an error to generate SCIL for e.g. a spec which has a body + -- It is not an error to analyze in CodePeer mode a spec which requires + -- a body, in order to generate SCIL for this spec. elsif CodePeer_Mode then Back_End_Mode := Generate_Object; + -- It is not an error to analyze in SPARK mode a spec which requires a + -- body, when the body is not available. During frame condition + -- generation, the corresponding ALI file is generated. During + -- translation to Why, Why code is generated for the spec. + + elsif SPARK_Mode then + if Frame_Condition_Mode then + Back_End_Mode := Declarations_Only; + else + Back_End_Mode := Generate_Object; + end if; + -- In all other cases (specs which have bodies, generics, and bodies -- where subunits are missing), we cannot generate code and we generate -- a warning message. Note that generic instantiations are gone at this @@ -1207,7 +1226,7 @@ begin Errout.Finalize (Last_Call => True); Errout.Output_Messages; - List_Rep_Info; + List_Rep_Info (Ttypes.Bytes_Big_Endian); List_Inlining_Info; -- Only write the library if the backend did not generate any error diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 3ef8a524544..7f3596bdeb5 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -70,6 +70,7 @@ AdaCore @menu * About This Guide:: * Implementation Defined Pragmas:: +* Implementation Defined Aspects:: * Implementation Defined Attributes:: * Standard and Implementation Defined Restrictions:: * Implementation Advice:: @@ -105,7 +106,9 @@ Implementation Defined Pragmas * Pragma Ada_2012:: * Pragma Annotate:: * Pragma Assert:: +* Pragma Assert_And_Cut:: * Pragma Assertion_Policy:: +* Pragma Assume:: * Pragma Assume_No_Invalid_Values:: * Pragma Attribute_Definition:: * Pragma Ast_Entry:: @@ -122,7 +125,7 @@ Implementation Defined Pragmas * Pragma Complete_Representation:: * Pragma Complex_Representation:: * Pragma Component_Alignment:: -* Pragma Contract_Case:: +* Pragma Contract_Cases:: * Pragma Convention_Identifier:: * Pragma CPP_Class:: * Pragma CPP_Constructor:: @@ -177,7 +180,9 @@ Implementation Defined Pragmas * Pragma Linker_Destructor:: * Pragma Linker_Section:: * Pragma Long_Float:: +* Pragma Loop_Invariant:: * Pragma Loop_Optimize:: +* Pragma Loop_Variant:: * Pragma Machine_Attribute:: * Pragma Main:: * Pragma Main_Storage:: @@ -244,68 +249,106 @@ Implementation Defined Pragmas * Pragma Weak_External:: * Pragma Wide_Character_Encoding:: +Implementation Defined Aspects + +* Aspect Abstract_State:: +* Aspect Ada_2005:: +* Aspect Ada_2012:: +* Aspect Compiler_Unit:: +* Aspect Contract_Cases:: +* Aspect Depends:: +* Aspect Dimension:: +* Aspect Dimension_System:: +* Aspect Favor_Top_Level:: +* Aspect Global:: +* Aspect Inline_Always:: +* Aspect Invariant:: +* Aspect Object_Size:: +* Aspect Persistent_BSS:: +* Aspect Predicate:: +* Aspect Preelaborate_05:: +* Aspect Pure_05:: +* Aspect Pure_12:: +* Aspect Pure_Function:: +* Aspect Remote_Access_Type:: +* Aspect Scalar_Storage_Order:: +* Aspect Shared:: +* Aspect Simple_Storage_Pool:: +* Aspect Simple_Storage_Pool_Type:: +* Aspect Suppress_Debug_Info:: +* Aspect Test_Case:: +* Aspect Universal_Aliasing:: +* Aspect Universal_Data:: +* Aspect Unmodified:: +* Aspect Unreferenced:: +* Aspect Unreferenced_Objects:: +* Aspect Value_Size:: +* Aspect Warnings:: + Implementation Defined Attributes -* Abort_Signal:: -* Address_Size:: -* Asm_Input:: -* Asm_Output:: -* AST_Entry:: -* Bit:: -* Bit_Position:: -* Compiler_Version:: -* Code_Address:: -* Default_Bit_Order:: -* Descriptor_Size:: -* Elaborated:: -* Elab_Body:: -* Elab_Spec:: -* Elab_Subp_Body:: -* Emax:: -* Enabled:: -* Enum_Rep:: -* Enum_Val:: -* Epsilon:: -* Fixed_Value:: -* Has_Access_Values:: -* Has_Discriminants:: -* Img:: -* Integer_Value:: -* Invalid_Value:: -* Large:: -* Machine_Size:: -* Mantissa:: -* Max_Interrupt_Priority:: -* Max_Priority:: -* Maximum_Alignment:: -* Mechanism_Code:: -* Null_Parameter:: -* Object_Size:: -* Passed_By_Reference:: -* Pool_Address:: -* Range_Length:: -* Result:: -* Safe_Emax:: -* Safe_Large:: -* Scalar_Storage_Order:: -* Simple_Storage_Pool:: -* Small:: -* Storage_Unit:: -* Stub_Type:: -* System_Allocator_Alignment:: -* Target_Name:: -* Tick:: -* To_Address:: -* Type_Class:: -* UET_Address:: -* Unconstrained_Array:: -* Universal_Literal_String:: -* Unrestricted_Access:: -* Valid_Scalars:: -* VADS_Size:: -* Value_Size:: -* Wchar_T_Size:: -* Word_Size:: +* Attribute Abort_Signal:: +* Attribute Address_Size:: +* Attribute Asm_Input:: +* Attribute Asm_Output:: +* Attribute AST_Entry:: +* Attribute Bit:: +* Attribute Bit_Position:: +* Attribute Compiler_Version:: +* Attribute Code_Address:: +* Attribute Default_Bit_Order:: +* Attribute Descriptor_Size:: +* Attribute Elaborated:: +* Attribute Elab_Body:: +* Attribute Elab_Spec:: +* Attribute Elab_Subp_Body:: +* Attribute Emax:: +* Attribute Enabled:: +* Attribute Enum_Rep:: +* Attribute Enum_Val:: +* Attribute Epsilon:: +* Attribute Fixed_Value:: +* Attribute Has_Access_Values:: +* Attribute Has_Discriminants:: +* Attribute Img:: +* Attribute Integer_Value:: +* Attribute Invalid_Value:: +* Attribute Large:: +* Attribute Loop_Entry:: +* Attribute Machine_Size:: +* Attribute Mantissa:: +* Attribute Max_Interrupt_Priority:: +* Attribute Max_Priority:: +* Attribute Maximum_Alignment:: +* Attribute Mechanism_Code:: +* Attribute Null_Parameter:: +* Attribute Object_Size:: +* Attribute Passed_By_Reference:: +* Attribute Pool_Address:: +* Attribute Range_Length:: +* Attribute Result:: +* Attribute Safe_Emax:: +* Attribute Safe_Large:: +* Attribute Scalar_Storage_Order:: +* Attribute Simple_Storage_Pool:: +* Attribute Small:: +* Attribute Storage_Unit:: +* Attribute Stub_Type:: +* Attribute System_Allocator_Alignment:: +* Attribute Target_Name:: +* Attribute Tick:: +* Attribute To_Address:: +* Attribute Type_Class:: +* Attribute UET_Address:: +* Attribute Unconstrained_Array:: +* Attribute Universal_Literal_String:: +* Attribute Unrestricted_Access:: +* Attribute Update:: +* Attribute Valid_Scalars:: +* Attribute VADS_Size:: +* Attribute Value_Size:: +* Attribute Wchar_T_Size:: +* Attribute Word_Size:: Standard and Implementation Defined Restrictions @@ -548,6 +591,8 @@ The GNAT Library * System.Address_Image (s-addima.ads):: * System.Assertions (s-assert.ads):: * System.Memory (s-memory.ads):: +* System.Multiprocessors (s-multip.ads):: +* System.Multiprocessors.Dispatching_Domains (s-mudido.ads):: * System.Partition_Interface (s-parint.ads):: * System.Pool_Global (s-pooglo.ads):: * System.Pool_Local (s-pooloc.ads):: @@ -858,7 +903,9 @@ consideration, the use of these pragmas should be minimized. * Pragma Ada_2012:: * Pragma Annotate:: * Pragma Assert:: +* Pragma Assert_And_Cut:: * Pragma Assertion_Policy:: +* Pragma Assume:: * Pragma Assume_No_Invalid_Values:: * Pragma Attribute_Definition:: * Pragma Ast_Entry:: @@ -875,7 +922,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Complete_Representation:: * Pragma Complex_Representation:: * Pragma Component_Alignment:: -* Pragma Contract_Case:: +* Pragma Contract_Cases:: * Pragma Convention_Identifier:: * Pragma CPP_Class:: * Pragma CPP_Constructor:: @@ -930,7 +977,9 @@ consideration, the use of these pragmas should be minimized. * Pragma Linker_Destructor:: * Pragma Linker_Section:: * Pragma Long_Float:: +* Pragma Loop_Invariant:: * Pragma Loop_Optimize:: +* Pragma Loop_Variant:: * Pragma Machine_Attribute:: * Pragma Main:: * Pragma Main_Storage:: @@ -943,6 +992,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Optimize_Alignment:: * Pragma Ordered:: * Pragma Overflow_Mode:: +* Pragma Overriding_Renamings:: * Pragma Partition_Elaboration_Policy:: * Pragma Passive:: * Pragma Persistent_BSS:: @@ -1200,13 +1250,18 @@ Note that, as with the @code{if} statement to which it is equivalent, the type of the expression is either @code{Standard.Boolean}, or any type derived from this standard type. -If assertions are disabled (switch @option{-gnata} not used), then there +Assert checks can be either checked or ignored. By default they are ignored. +They will be checked if either the command line switch @option{-gnata} is +used, or if an @code{Assertion_Policy} or @code{Check_Policy} pragma is used +to enable @code{Assert_Checks}. + +If assertions are ignored, then there is no run-time effect (and in particular, any side effects from the expression will not occur at run time). (The expression is still analyzed at compile time, and may cause types to be frozen if they are mentioned here for the first time). -If assertions are enabled, then the given expression is tested, and if +If assertions are checked, then the given expression is tested, and if it is @code{False} then @code{System.Assertions.Raise_Assert_Failure} is called which results in the raising of @code{Assert_Failure} with the given message. @@ -1218,55 +1273,148 @@ semantic correctness whether or not assertions are enabled, so turning assertions on and off cannot affect the legality of a program. Note that the implementation defined policy @code{DISABLE}, given in a -pragma Assertion_Policy, can be used to suppress this semantic analysis. +pragma @code{Assertion_Policy}, can be used to suppress this semantic analysis. Note: this is a standard language-defined pragma in versions of Ada from 2005 on. In GNAT, it is implemented in all versions of Ada, and the DISABLE policy is an implementation-defined addition. +@node Pragma Assert_And_Cut +@unnumberedsec Pragma Assert_And_Cut +@findex Assert_And_Cut +@noindent +Syntax: +@smallexample @c ada +pragma Assert_And_Cut ( + boolean_EXPRESSION + [, string_EXPRESSION]); +@end smallexample + +@noindent +The effect of this pragma is identical to that of pragma @code{Assert}, +except that in an @code{Assertion_Policy} pragma, the identifier +@code{Assert_And_Cut} is used to control whether it is ignored or checked +(or disabled). + +The intention is that this be used within a subprogram when the +given test expresion sums up all the work done so far in the +subprogram, so that the rest of the subprogram can be verified +(informally or formally) using only the entry preconditions, +and the expression in this pragma. This allows dividing up +a subprogram into sections for the purposes of testing or +formal verification. The pragma also serves as useful +documentation. + @node Pragma Assertion_Policy @unnumberedsec Pragma Assertion_Policy -@findex Debug_Policy +@findex Assertion_Policy @noindent Syntax: - @smallexample @c ada pragma Assertion_Policy (CHECK | DISABLE | IGNORE); -@end smallexample -@noindent -This is a standard Ada 2005 pragma that is available as an +pragma Assertion_Policy ( + ASSERTION_KIND => POLICY_IDENTIFIER + @{, ASSERTION_KIND => POLICY_IDENTIFIER@}); + +ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND + +RM_ASSERTION_KIND ::= Assert | + Static_Predicate | + Dynamic_Predicate | + Pre | + Pre'Class | + Post | + Post'Class | + Type_Invariant | + Type_Invariant'Class + +ID_ASSERTION_KIND ::= Assertions | + Assert_And_Cut | + Assume | + Contract_Cases | + Debug | + Invariant | + Invariant'Class | + Loop_Invariant | + Loop_Variant | + Postcondition | + Precondition | + Predicate + Statement_Assertions + +POLICY_IDENTIFIER ::= Check | Disable | Ignore +@end smallexample + +@noindent +This is a standard Ada 2012 pragma that is available as an implementation-defined pragma in earlier versions of Ada. - -If the argument is @code{CHECK}, then assertions are enabled. -If the argument is @code{IGNORE}, then assertions are ignored. +The assertion kinds @code{RM_ASSERTION_KIND} are those defined in +the Ada standard. The assertion kinds @code{ID_ASSERTION_KIND} +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}. + +If the policy is @code{CHECK}, then assertions are enabled, i.e. +the corresponding pragma or aspect is activated. +If the policy is @code{IGNORE}, then assertions are ignored, i.e. +the corresponding pragma or aspect is deactivated. This pragma overrides the effect of the @option{-gnata} switch on the command line. -Assertions are of three kinds: - -@itemize @bullet -@item -Pragma @code{Assert}. -@item -In Ada 2012, all assertions defined in the RM as aspects: preconditions, -postconditions, type invariants and (sub)type predicates. -@item -Corresponding pragmas for type invariants and (sub)type predicates. -@end itemize - The implementation defined policy @code{DISABLE} is like @code{IGNORE} except that it completely disables semantic -checking of the argument to @code{pragma Assert}. This may -be useful when the pragma argument references subprograms +checking of the corresponding pragma or aspect. This is +useful when the pragma or aspect argument references subprograms in a with'ed package which is replaced by a dummy package for the final build. -Note: this is a standard language-defined pragma in versions -of Ada from 2005 on. In GNAT, it is implemented in all versions -of Ada, and the DISABLE policy is an implementation-defined -addition. +The implementation defined policy @code{Assertions} applies to all +assertion kinds. The form with no assertion kind given implies this +choice, so it applies to all assertion kinds (RM defined, and +implementation defined). + +The implementation defined policy @code{Statement_Assertions} +applies to @code{Assert}, @code{Assert_And_Cut}, +@code{Assume}, and @code{Loop_Invariant}. + +@node Pragma Assume +@unnumberedsec Pragma Assume +@findex Assume +@noindent +Syntax: +@smallexample @c ada +pragma Assume ( + boolean_EXPRESSION + [, string_EXPRESSION]); +@end smallexample + +@noindent +The effect of this pragma is identical to that of pragma @code{Assert}, +except that in an @code{Assertion_Policy} pragma, the identifier +@code{Assume} is used to control whether it is ignored or checked +(or disabled). + +The intention is that this be used for assumptions about the +external environment. So you cannot expect to verify formally +or informally that the condition is met, this must be +established by examining things outside the program itself. +For example, we may have code that depends on the size of +@code{Long_Long_Integer} being at least 64. So we could write: + +@smallexample @c ada +pragma Assume (Long_Long_Integer'Size >= 64); +@end smallexample + +@noindent +This assumption cannot be proved from the program itself, +but it acts as a useful run-time check that the assumption +is met, and documents the need to ensure that it is met by +reference to information outside the program. @node Pragma Assume_No_Invalid_Values @unnumberedsec Pragma Assume_No_Invalid_Values @@ -1414,9 +1562,15 @@ passing mechanisms on a parameter by parameter basis. Syntax: @smallexample @c ada pragma Check ( - [Name =>] Identifier, + [Name =>] CHECK_KIND, [Check =>] Boolean_EXPRESSION [, [Message =>] string_EXPRESSION] ); + +CHECK_KIND ::= IDENTIFIER | + Pre'Class | + Post'Class | + Type_Invariant'Class | + Invariant'Class @end smallexample @noindent @@ -1424,15 +1578,17 @@ This pragma is similar to the predefined pragma @code{Assert} except that an extra identifier argument is present. In conjunction with pragma @code{Check_Policy}, this can be used to define groups of assertions that can be independently controlled. The identifier @code{Assertion} is special, it -refers to the normal set of pragma @code{Assert} statements. The identifiers -@code{Precondition} and @code{Postcondition} correspond to the pragmas of these -names, so these three names would normally not be used directly in a pragma -@code{Check}. +refers to the normal set of pragma @code{Assert} statements. Checks introduced by this pragma are normally deactivated by default. They can be activated either by the command line option @option{-gnata}, which turns on all checks, or individually controlled using pragma @code{Check_Policy}. +The identifiers @code{Assertions} and @code{Statement_Assertions} are not +permitted as check kinds, since this would cause confusion with the use +of these identifiers in @code{Assertion_Policy} and @code{Check_Policy} +pragmas, where they are used to refer to sets of assertions. + @node Pragma Check_Float_Overflow @unnumberedsec Pragma Check_Float_Overflow @cindex Floating-point overflow @@ -1516,6 +1672,9 @@ the current unit, or if it appears at the start of any unit that is part of the dependency set of the current unit (e.g., units that are mentioned in @code{with} clauses). +Check names introduced by this pragma are subject to control by compiler +switches (in particular -gnatp) in the usual manner. + @node Pragma Check_Policy @unnumberedsec Pragma Check_Policy @cindex Controlling assertions @@ -1527,22 +1686,50 @@ are mentioned in @code{with} clauses). Syntax: @smallexample @c ada pragma Check_Policy - ([Name =>] Identifier, + ([Name =>] CHECK_KIND, [Policy =>] POLICY_IDENTIFIER); +pragma Check_Policy ( + CHECK_KIND => POLICY_IDENTIFIER + @{, CHECK_KIND => POLICY_IDENTIFIER@}); + +ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND + +CHECK_KIND ::= IDENTIFIER | + Pre'Class | + Post'Class | + Type_Invariant'Class | + Invariant'Class + +The identifiers Name and Policy are not allowed as CHECK_KIND values. This +avoids confusion between the two possible syntax forms for this pragma. + POLICY_IDENTIFIER ::= ON | OFF | CHECK | DISABLE | IGNORE @end smallexample @noindent -This pragma is similar to the predefined pragma @code{Assertion_Policy}, -except that it controls sets of named assertions introduced using the -@code{Check} pragmas. It can be used as a configuration pragma or (unlike -@code{Assertion_Policy}) can be used within a declarative part, in which case -it controls the status to the end of the corresponding construct (in a manner -identical to pragma @code{Suppress)}. +This pragma is used to set the checking policy for assertions (specified +by aspects or pragmas), the @code{Debug} pragma, or additional checks +to be checked using the @code{Check} pragma. It may appear either as +a configuration pragma, or within a declarative part of package. In the +latter case, it applies from the point where it appears to the end of +the declarative region (like pragma @code{Suppress}). + +The @code{Check_Policy} pragma is similar to the +predefined @code{Assertion_Policy} pragma, +and if the check kind corresponds to one of the assertion kinds that +are allowed by @code{Assertion_Policy}, then the effect is identical. + +If the first argument is Debug, then the policy applies to Debug pragmas, +disabling their effect if the policy is @code{OFF}, @code{DISABLE}, or +@code{IGNORE}, and allowing them to execute with normal semantics if +the policy is @code{ON} or @code{CHECK}. In addition if the policy is +@code{DISABLE}, then the procedure call in @code{Debug} pragmas will +be totally ignored and not analyzed semantically. -The identifier given as the first argument corresponds to a name used in -associated @code{Check} pragmas. For example, if the pragma: +Finally the first argument may be some other identifier than the above +possibilities, in which case it controls a set of named assertions +that can be checked using pragma @code{Check}. For example, if the pragma: @smallexample @c ada pragma Check_Policy (Critical_Error, OFF); @@ -1550,37 +1737,18 @@ pragma Check_Policy (Critical_Error, OFF); @noindent is given, then subsequent @code{Check} pragmas whose first argument is also -@code{Critical_Error} will be disabled. The special identifier @code{Assertion} -controls the behavior of normal assertions (thus a pragma -@code{Check_Policy} with this identifier is similar to the normal -@code{Assertion_Policy} pragma except that it can appear within a -declarative part). - -The special identifiers @code{Precondition} and @code{Postcondition} control -the status of preconditions and postconditions given as pragmas. -If a @code{Precondition} pragma -is encountered, it is ignored if turned off by a @code{Check_Policy} specifying -that @code{Precondition} checks are @code{Off} or @code{Ignored}. Similarly use -of the name @code{Postcondition} controls whether @code{Postcondition} pragmas -are recognized. Note that preconditions and postconditions given as aspects -are controlled differently, either by the @code{Assertion_Policy} pragma or -by the @code{Check_Policy} pragma with identifier @code{Assertion}. +@code{Critical_Error} will be disabled. The check policy is @code{OFF} to turn off corresponding checks, and @code{ON} to turn on corresponding checks. The default for a set of checks for which no @code{Check_Policy} is given is @code{OFF} unless the compiler switch @option{-gnata} is given, which turns on all checks by default. -The check policy settings @code{CHECK} and @code{IGNORE} are also recognized +The check policy settings @code{CHECK} and @code{IGNORE} are recognized as synonyms for @code{ON} and @code{OFF}. These synonyms are provided for -compatibility with the standard @code{Assertion_Policy} pragma. - -The implementation defined policy @code{DISABLE} is like -@code{OFF} except that it completely disables semantic -checking of the argument to the corresponding class of -pragmas. This may be useful when the pragma arguments reference -subprograms in a with'ed package which is replaced by a dummy package -for the final build. +compatibility with the standard @code{Assertion_Policy} pragma. The check +policy setting @code{DISABLE} causes the second argument of a corresponding +@code{Check} pragma to be completely ignored and not analyzed. @node Pragma Comment @unnumberedsec Pragma Comment @@ -1820,107 +1988,88 @@ If the alignment for a record or array type is not specified (using pragma @code{Pack}, pragma @code{Component_Alignment}, or a record rep clause), the GNAT uses the default alignment as described previously. -@node Pragma Contract_Case -@unnumberedsec Pragma Contract_Case +@node Pragma Contract_Cases +@unnumberedsec Pragma Contract_Cases @cindex Contract cases -@findex Contract_Case +@findex Contract_Cases @noindent Syntax: @smallexample @c ada -pragma Contract_Case ( - [Name =>] static_string_Expression - ,[Mode =>] (Nominal | Robustness) - [, Requires => Boolean_Expression] - [, Ensures => Boolean_Expression]); +pragma Contract_Cases ( + Condition => Consequence + @{,Condition => Consequence@}); @end smallexample @noindent -The @code{Contract_Case} pragma allows defining fine-grain specifications +The @code{Contract_Cases} pragma allows defining fine-grain specifications that can complement or replace the contract given by a precondition and a -postcondition. Additionally, the @code{Contract_Case} pragma can be used +postcondition. Additionally, the @code{Contract_Cases} pragma can be used by testing and formal verification tools. The compiler checks its validity and, depending on the assertion policy at the point of declaration of the pragma, it may insert a check in the executable. For code generation, the contract -case +cases @smallexample @c ada -pragma Contract_Case ( - Name => ... - Mode => ... - Requires => R, - Ensures => E); +pragma Contract_Cases ( + Cond1 => Pred1, + Cond2 => Pred2); @end smallexample @noindent -is equivalent to +are equivalent to @smallexample @c ada -pragma Postcondition (not R'Old or else E); +C1 : constant Boolean := Cond1; -- evaluated at subprogram entry +C2 : constant Boolean := Cond2; -- evaluated at subprogram entry +pragma Precondition ((C1 and not C2) or (C2 and not C1)); +pragma Postcondition (if C1 then Pred1); +pragma Postcondition (if C2 then Pred2); @end smallexample @noindent -which is also equivalent to (in Ada 2012) - -@smallexample @c ada -pragma Postcondition (if R'Old then E); -@end smallexample - -@noindent -expressing that, whenever condition @code{R} is satisfied on entry to the -subprogram, condition @code{E} should be fulfilled on exit to the subprogram. +The precondition ensures that one and only one of the conditions is +satisfied on entry to the subprogram. +The postcondition ensures that for the condition that was True on entry, +the corrresponding consequence is True on exit. Other consequence expressions +are not evaluated. A precondition @code{P} and postcondition @code{Q} can also be expressed as contract cases: @smallexample @c ada -pragma Contract_Case ( - Name => "Replace precondition", - Mode => Nominal, - Requires => not P, - Ensures => False); -pragma Contract_Case ( - Name => "Replace postcondition", - Mode => Nominal, - Requires => P, - Ensures => Q); +pragma Contract_Cases (P => Q); @end smallexample -@code{Contract_Case} pragmas may only appear immediately following the -(separate) declaration of a subprogram in a package declaration, inside -a package spec unit. Only other pragmas may intervene (that is appear -between the subprogram declaration and a contract case). +The placement and visibility rules for @code{Contract_Cases} pragmas are +identical to those described for preconditions and postconditions. -The compiler checks that boolean expressions given in @code{Requires} and -@code{Ensures} are valid, where the rules for @code{Requires} are the -same as the rule for an expression in @code{Precondition} and the rules -for @code{Ensures} are the same as the rule for an expression in +The compiler checks that boolean expressions given in conditions and +consequences are valid, where the rules for conditions are the same as +the rule for an expression in @code{Precondition} and the rules for +consequences are the same as the rule for an expression in @code{Postcondition}. In particular, attributes @code{'Old} and -@code{'Result} can only be used within the @code{Ensures} -expression. The following is an example of use within a package spec: +@code{'Result} can only be used within consequence expressions. +The condition for the last contract case may be @code{others}, to denote +any case not captured by the previous cases. The +following is an example of use within a package spec: @smallexample @c ada package Math_Functions is ... function Sqrt (Arg : Float) return Float; - pragma Contract_Case (Name => "Small argument", - Mode => Nominal, - Requires => Arg < 100, - Ensures => Sqrt'Result < 10); + pragma Contract_Cases ((Arg in 0 .. 99) => Sqrt'Result < 10, + Arg >= 100 => Sqrt'Result >= 10, + others => Sqrt'Result = 0); ... end Math_Functions; @end smallexample @noindent -The meaning of a contract case is that, whenever the associated subprogram is -executed in a context where @code{Requires} holds, then @code{Ensures} -should hold when the subprogram returns. Mode @code{Nominal} indicates -that the input context should also satisfy the precondition of the -subprogram, and the output context should also satisfy its -postcondition. More @code{Robustness} indicates that the precondition and -postcondition of the subprogram should be ignored for this contract case, -which is mostly useful when testing such a contract using a testing tool -that understands contract cases. +The meaning of contract cases is that only one case should apply at each +call, as determined by the corresponding condition evaluating to True, +and that the consequence for this case should hold when the subprogram +returns. @node Pragma Convention_Identifier @unnumberedsec Pragma Convention_Identifier @@ -2108,7 +2257,8 @@ corresponding to the argument with a terminating semicolon. Pragmas are permitted in sequences of declarations, so you can use pragma @code{Debug} to intersperse calls to debug procedures in the middle of declarations. Debug pragmas can be enabled either by use of the command line switch @option{-gnata} -or by use of the configuration pragma @code{Debug_Policy}. +or by use of the pragma @code{Check_Policy} with a first argument of +@code{Debug}. @node Pragma Debug_Policy @unnumberedsec Pragma Debug_Policy @@ -2117,21 +2267,13 @@ or by use of the configuration pragma @code{Debug_Policy}. Syntax: @smallexample @c ada -pragma Debug_Policy (CHECK | DISABLE | IGNORE); +pragma Debug_Policy (CHECK | DISABLE | IGNORE | ON | OFF); @end smallexample @noindent -If the argument is @code{CHECK}, then pragma @code{DEBUG} is enabled. -If the argument is @code{IGNORE}, then pragma @code{DEBUG} is ignored. -This pragma overrides the effect of the @option{-gnata} switch on the -command line. - -The implementation defined policy @code{DISABLE} is like -@code{IGNORE} except that it completely disables semantic -checking of the argument to @code{pragma Debug}. This may -be useful when the pragma argument references subprograms -in a with'ed package which is replaced by a dummy package -for the final build. +This pragma is equivalent to a corresponding @code{Check_Policy} pragma +with a first argument of @code{Debug}. It is retained for historical +compatibility reasons. @node Pragma Default_Storage_Pool @unnumberedsec Pragma Default_Storage_Pool @@ -2847,7 +2989,18 @@ the standard runtime libraries be recompiled. The two argument form specifies the representation to be used for the specified floating-point type. On all systems other than OpenVMS, the argument must -be @code{IEEE_Float} and the pragma has no effect. On OpenVMS, the +be @code{IEEE_Float} to specify the use of IEEE format, as follows: + +@itemize @bullet +@item +For a digits value of 6, 32-bit IEEE short format will be used. +@item +For a digits value of 15, 64-bit IEEE long format will be used. +@item +No other value of digits is permitted. +@end itemize + +On OpenVMS, the argument may be @code{VAX_Float} to specify the use of the VAX float format, as follows: @@ -3882,6 +4035,33 @@ For further details on this pragma, see the @cite{DEC Ada Language Reference Manual}, section 3.5.7b. Note that to use this pragma, the standard runtime libraries must be recompiled. +@node Pragma Loop_Invariant +@unnumberedsec Pragma Loop_Invariant +@findex Loop_Invariant +@noindent +Syntax: +@smallexample @c ada +pragma Loop_Invariant ( boolean_EXPRESSION ); + +@end smallexample + +@noindent +The effect of this pragma is similar to that of pragma @code{Assert}, +except that in an @code{Assertion_Policy} pragma, the identifier +@code{Loop_Invariant} is used to control whether it is ignored or checked +(or disabled). + +@code{Loop_Invariant} can only appear as one of the items in the sequence +of statements of a loop body. The intention is that it be used to +represent a "loop invariant" assertion, i.e. something that is true each +time through the loop, and which can be used to show that the loop is +achieving its purpose. + +To aid in writing such invariants, the special attribute @code{Loop_Entry} +may be used to refer to the value of an expression on entry to the loop. This +attribute can only be used within the expression of a @code{Loop_Invariant} +pragma. For full details, see documentation of attribute @code{Loop_Entry}. + @node Pragma Loop_Optimize @unnumberedsec Pragma Loop_Optimize @findex Loop_Optimize @@ -3931,6 +4111,48 @@ compiler in order to enable the relevant optimizations, that is to say @option{-funroll-loops} for unrolling and @option{-ftree-vectorize} for vectorization. +@node Pragma Loop_Variant +@unnumberedsec Pragma Loop_Variant +@findex Loop_Variant +@noindent +Syntax: + +@smallexample @c ada +pragma Loop_Variant ( LOOP_VARIANT_ITEM @{, LOOP_VARIANT_ITEM @} ); +LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION +CHANGE_DIRECTION ::= Increases | Decreases +@end smallexample + +@noindent +This pragma must appear immediately within the sequence of statements of a +loop statement. It allows the specification of quantities which must always +decrease or increase in successive iterations of the loop. In its simplest +form, just one expression is specified, whose value must increase or decrease +on each iteration of the loop. + +In a more complex form, multiple arguments can be given which are intepreted +in a nesting lexicographic manner. For example: + +@smallexample @c ada +pragma Loop_Variant (Increases => X, Decreases => Y); +@end smallexample + +@noindent +specifies that each time through the loop either X increases, or X stays +the same and Y decreases. A @code{Loop_Variant} pragma ensures that the +loop is making progress. It can be useful in helping to show informally +or prove formally that the loop always terminates. + +@code{Loop_Variant} is an assertion whose effect can be controlled using +an @code{Assertion_Policy} with a check name of @code{Loop_Variant}. The +policy can be @code{Check} to enable the loop variant check, @code{Ignore} +to ignore the check (in which case the pragma has no effect on the program), +or @code{Disable} in which case the pragma is not even checked for correct +syntax. + +The @code{Loop_Entry} attribute may be used within the expressions of the +@code{Loop_Variant} pragma to refer to values on entry to the loop. + @node Pragma Machine_Attribute @unnumberedsec Pragma Machine_Attribute @findex Machine_Attribute @@ -4029,7 +4251,7 @@ earlier versions of the package body. Syntax: @smallexample @c ada -pragma No_Inline (NAME [, NAME]); +pragma No_Inline (NAME @{, NAME@}); @end smallexample @noindent @@ -4477,6 +4699,25 @@ overflow checking, but does not affect the overflow mode. The pragma @code{Unsuppress (Overflow_Check)} unsuppresses (enables) overflow checking, but does not affect the overflow mode. +@node Pragma Overriding_Renamings +@unnumberedsec Pragma Overriding_Renamings +@findex Overriding_Renamings +@cindex Rational profile +@noindent +Syntax: + +@smallexample @c ada +pragma Overriding_Renamings; +@end smallexample + +@noindent + +This is a GNAT pragma to simplify porting legacy code accepted by the Rational +Ada compiler. In the presence of this pragma, a renaming declaration that +renames an inherited operation declared in the same scope is legal, even though +RM 8.3 (15) stipulates that an overridden operation is not visible within the +declaration of the overriding operation. + @node Pragma Partition_Elaboration_Policy @unnumberedsec Pragma Partition_Elaboration_Policy @findex Partition_Elaboration_Policy @@ -4857,10 +5098,10 @@ priority-ordered scheduling policy. @item Locking_Policy (Ceiling_Locking) [RM D.3] While tasks and interrupts execute a protected action, they inherit the ceiling priority of the corresponding protected object. -@c -@c @item Detect_Blocking -@c This pragma forces the detection of potentially blocking operations within a -@c protected operation, and to raise Program_Error if that happens. + +@item Detect_Blocking +This pragma forces the detection of potentially blocking operations within a +protected operation, and to raise Program_Error if that happens. @end table @noindent @@ -4984,10 +5225,11 @@ The Rational profile is intended to facilitate porting legacy code that compiles with the Rational APEX compiler, even when the code includes non- conforming Ada constructs. The profile enables the following three pragmas: + @itemize @bullet -pragma Implicit_Packing; -pragma Overriding_Renamings; -pragma Use_VADS_Size; +@item pragma Implicit_Packing +@item pragma Overriding_Renamings +@item pragma Use_VADS_Size @end itemize @noindent @@ -5588,12 +5830,38 @@ pragma Suppress (Identifier [, [On =>] Name]); @noindent This is a standard pragma, and supports all the check names required in -the RM. It is included here because GNAT recognizes one additional check -name: @code{Alignment_Check} which can be used to suppress alignment checks +the RM. It is included here because GNAT recognizes some additional check +names that are implementation defined (as permitted by the RM): + +@itemize @bullet + +@item +@code{Alignment_Check} can be used to suppress alignment checks on addresses used in address clauses. Such checks can also be suppressed by suppressing range checks, but the specific use of @code{Alignment_Check} allows suppression of alignment checks without suppressing other range checks. +@item +@code{Predicate_Check} can be used to control whether predicate checks are +active. It is applicable only to predicates for which the policy is +@code{Check}. Unlike @code{Assertion_Policy}, which determines if a given +predicate is ignored or checked for the whole program, the use of +@code{Suppress} and @code{Unsuppress} with this check name allows a given +predicate to be turned on and off at specific points in the program. + +@item +@code{Validity_Check} can be used specifically to control validity checks. +If @code{Suppress} is used to suppress validity checks, then no validity +checks are performed, including those specified by the appropriate compiler +switch or the @code{Validity_Checks} pragma. + +@item +Additional check names previously introduced by use of the @code{Check_Name} +pragma are also allowed. + +@end itemize + +@noindent Note that pragma Suppress gives the compiler permission to omit checks, but does not require the compiler to omit checks. The compiler will generate checks if they are essentially free, even when they are @@ -5789,12 +6057,10 @@ pragma Test_Case ( @noindent The @code{Test_Case} pragma allows defining fine-grain specifications -for use by testing tools. Its syntax is similar to the syntax of the -@code{Contract_Case} pragma, which is used for both testing and -formal verification. +for use by testing tools. The compiler checks the validity of the @code{Test_Case} pragma, but its presence does not lead to any modification of the code generated by the -compiler, contrary to the treatment of the @code{Contract_Case} pragma. +compiler. @code{Test_Case} pragmas may only appear immediately following the (separate) declaration of a subprogram in a package declaration, inside @@ -5835,6 +6101,7 @@ postcondition of the subprogram should be ignored for this test case. @findex Thread_Local_Storage @cindex Task specific storage @cindex TLS (Thread Local Storage) +@cindex Task_Attributes Syntax: @smallexample @c ada @@ -6144,6 +6411,10 @@ checks. This pragma is standard in Ada 2005. It is available in all earlier versions of Ada as an implementation-defined pragma. +Note that in addition to the checks defined in the Ada RM, GNAT recogizes +a number of implementation-defined check names. See description of pragma +@code{Suppress} for full details. + @node Pragma Use_VADS_Size @unnumberedsec Pragma Use_VADS_Size @cindex @code{Size}, VADS compatibility @@ -6249,10 +6520,12 @@ implementation in DEC Ada 83. Syntax: @smallexample @c ada -pragma Warnings (On | Off); -pragma Warnings (On | Off, LOCAL_NAME); -pragma Warnings (static_string_EXPRESSION); -pragma Warnings (On | Off, static_string_EXPRESSION); +pragma Warnings (On | Off [,REASON]); +pragma Warnings (On | Off, LOCAL_NAME [,REASON]); +pragma Warnings (static_string_EXPRESSION [,REASON]); +pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]); + +REASON ::= Reason => static_string_EXPRESSION @end smallexample @noindent @@ -6260,17 +6533,28 @@ Normally warnings are enabled, with the output being controlled by the command line switch. Warnings (@code{Off}) turns off generation of warnings until a Warnings (@code{On}) is encountered or the end of the current unit. If generation of warnings is turned off using this -pragma, then no warning messages are output, regardless of the -setting of the command line switches. +pragma, then some or all of the warning messages are suppressed, +regardless of the setting of the command line switches. + +The @code{Reason} parameter may optionally appear as the last argument +in any of the forms of this pragma. It is intended purely for the +purposes of documenting the reason for the @code{Warnings} pragma. +The compiler will check that the argument is a static string but +otherwise ignore this argument. Other tools may provide specialized +processing for this string. -The form with a single argument may be used as a configuration pragma. +The form with a single argument (or two arguments if Reason present), +where the first argument is @code{ON} or @code{OFF} +may be used as a configuration pragma. If the @var{LOCAL_NAME} parameter is present, warnings are suppressed for the specified entity. This suppression is effective from the point where it occurs till the end of the extended scope of the variable (similar to -the scope of @code{Suppress}). +the scope of @code{Suppress}). This form cannot be used as a configuration +pragma. -The form with a single static_string_EXPRESSION argument provides more precise +The form with a single static_string_EXPRESSION argument (and possible +reason) provides more precise control over which warnings are active. The string is a list of letters specifying which warnings are to be activated and which deactivated. The code for these letters is the same as the string used in the command @@ -6278,7 +6562,7 @@ line switch controlling warnings. For a brief summary, use the gnatmake command with no arguments, which will generate usage information containing the list of warnings switches supported. For full details see @ref{Warning Message Control,,, gnat_ugn, @value{EDITION} -User's Guide}. +User's Guide}. This form can also be used as a configuration pragma. @noindent The warnings controlled by the `-gnatw' switch are generated by the front end @@ -6427,6 +6711,398 @@ Note that when the pragma is used within a file, it affects only the encoding within that file, and does not affect withed units, specs, or subunits. +@node Implementation Defined Aspects +@chapter Implementation Defined Aspects +Ada defines (throughout the Ada 2012 reference manual, summarized +in annex K) a set of aspects that can be specified for certain entities. +These language defined aspects are implemented in GNAT in Ada 2012 mode +and work as described in the Ada 2012 Reference Manual. + +In addition, Ada 2012 allows implementations to define additional aspects +whose meaning is defined by the implementation. GNAT provides +a number of these implementation-dependent aspects which can be used +to extend and enhance the functionality of the compiler. This section of +the GNAT reference manual describes these additional attributes. + +Note that any program using these aspects may not be portable to +other compilers (although GNAT implements this set of aspects on all +platforms). Therefore if portability to other compilers is an important +consideration, you should minimize the use of these aspects. + +Note that for many of these aspects, the effect is essentially similar +to the use of a pragma or attribute specification with the same name +applied to the entity. For example, if we write: + +@smallexample @c ada +type R is range 1 .. 100 + with Value_Size => 10; +@end smallexample + +@noindent +then the effect is the same as: + +@smallexample @c ada +type R is range 1 .. 100; +for R'Value_Size use 10; +@end smallexample + +@noindent +and if we write: + +@smallexample @c ada +type R is new Integer + with Shared => True; +@end smallexample + +@noindent +then the effect is the same as: + +@smallexample @c ada +type R is new Integer; +pragma Shared (R); +@end smallexample + +@noindent +In the documentation sections that follow, such cases are simply marked +as being equivalent to the corresponding pragma or attribute definition +clause. + +@menu +* Aspect Abstract_State:: +* Aspect Ada_2005:: +* Aspect Ada_2012:: +* Aspect Compiler_Unit:: +* Aspect Contract_Cases:: +* Aspect Depends:: +* Aspect Dimension:: +* Aspect Dimension_System:: +* Aspect Favor_Top_Level:: +* Aspect Global:: +* Aspect Inline_Always:: +* Aspect Invariant:: +* Aspect Lock_Free:: +* Aspect Object_Size:: +* Aspect Persistent_BSS:: +* Aspect Predicate:: +* Aspect Preelaborate_05:: +* Aspect Pure_05:: +* Aspect Pure_12:: +* Aspect Pure_Function:: +* Aspect Remote_Access_Type:: +* Aspect Scalar_Storage_Order:: +* Aspect Shared:: +* Aspect Simple_Storage_Pool:: +* Aspect Simple_Storage_Pool_Type:: +* Aspect Suppress_Debug_Info:: +* Aspect Test_Case:: +* Aspect Universal_Aliasing:: +* Aspect Universal_Data:: +* Aspect Unmodified:: +* Aspect Unreferenced:: +* Aspect Unreferenced_Objects:: +* Aspect Value_Size:: +* Aspect Warnings:: +@end menu + +@node Aspect Abstract_State +@unnumberedsec Aspect Abstract_State +@findex Abstract_State +@noindent +This aspect is equivalent to pragma @code{Abstract_State}. + +@node Aspect Ada_2005 +@unnumberedsec Aspect Ada_2005 +@findex Ada_2005 +@noindent +This aspect is equivalent to the one argument form of pragma @code{Ada_2005}. + +@node Aspect Ada_2012 +@unnumberedsec Aspect Ada_2012 +@findex Ada_2012 +@noindent +This aspect is equivalent to the one argument form of pragma @code{Ada_2012}. + +@node Aspect Compiler_Unit +@unnumberedsec Aspect Compiler_Unit +@findex Compiler_Unit +@noindent +This aspect is equivalent to pragma @code{Compiler_Unit}. + +@node Aspect Contract_Cases +@unnumberedsec Aspect Contract_Cases +@findex Contract_Cases +@noindent +This aspect is equivalent to pragma @code{Contract_Cases}, the sequence +of clauses being enclosed in parentheses so that syntactically it is an +aggregate. + +@node Aspect Depends +@unnumberedsec Aspect Depends +@findex Depends +@noindent +This aspect is equivalent to pragma @code{Depends}. + +* Dimension:: + +@node Aspect Dimension +@unnumberedsec Aspect Dimension +@findex Dimension +@noindent +The @code{Dimension} aspect is used to specify the dimensions of a given +subtype of a dimensioned numeric type. The aspect also specifies a symbol +used when doing formatted output of dimensioned quantities. The syntax is: + +@smallexample @c ada +with Dimension => + ([Symbol =>] SYMBOL, DIMENSION_VALUE @{, DIMENSION_Value@}) + +SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL + +DIMENSION_VALUE ::= + RATIONAL +| others => RATIONAL +| DISCRETE_CHOICE_LIST => RATIONAL + +RATIONAL ::= [-] NUMERIC_LITERAL [/ NUMERIC_LITERAL] +@end smallexample + +@noindent +This aspect can only be applied to a subtype whose parent type has +a @code{Dimension_Systen} aspect. The aspect must specify values for +all dimensions of the system. The rational values are the powers of the +corresponding dimensions that are used by the compiler to verify that +physical (numeric) computations are dimensionally consistent. For example, +the computation of a force must result in dimensions (L => 1, M => 1, T => -2). +For further examples of the usage +of this aspect, see package @code{System.Dim.Mks}. +Note that when the dimensioned type is an integer type, then any +dimension value must be an integer literal. + +@node Aspect Dimension_System +@unnumberedsec Aspect Dimension_System +@findex Dimension_System +@noindent +The @code{Dimension_System} aspect is used to define a system of +dimensions that will be used in subsequent subtype declarations with +@code{Dimension} aspects that reference this system. The syntax is: + +@smallexample @c ada +with Dimension_System => (DIMENSION @{, DIMENSION@}); + +DIMENSION ::= ([Unit_Name =>] IDENTIFIER, + [Unit_Symbol =>] SYMBOL, + [Dim_Symbol =>] SYMBOL) + +SYMBOL ::= CHARACTER_LITERAL | STRING_LITERAL +@end smallexample + +@noindent +This aspect is applied to a type, which must be a numeric derived type +(typically a floating-point type), that +will represent values within the dimension system. Each @code{DIMENSION} +corresponds to one particular dimension. A maximum of 7 dimensions may +be specified. @code{Unit_Name} is the name of the dimension (for example +@code{Meter}). @code{Unit_Symbol} is the shorthand used for quantities +of this dimension (for example 'm' for Meter). @code{Dim_Symbol} gives +the identification within the dimension system (typically this is a +single letter, e.g. 'L' standing for length for unit name Meter). The +Unit_Smbol is used in formatted output of dimensioned quantities. The +Dim_Symbol is used in error messages when numeric operations have +inconsistent dimensions. + +GNAT provides the standard definition of the International MKS system in +the run-time package @code{System.Dim.Mks}. You can easily define +similar packages for cgs units or British units, and define conversion factors +between values in different systems. The MKS system is characterized by the +following aspect: + +@smallexample @c ada + type Mks_Type is new Long_Long_Float + with + Dimension_System => ( + (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), + (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), + (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), + (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), + (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Theta"), + (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), + (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); +@end smallexample + +@noindent +See section "Performing Dimensionality Analysis in GNAT" in the GNAT Users +Guide for detailed examples of use of the dimension system. + +@node Aspect Favor_Top_Level +@unnumberedsec Aspect Favor_Top_Level +@findex Favor_Top_Level +@noindent +This aspect is equivalent to pragma @code{Favor_Top_Level}. + +@node Aspect Global +@unnumberedsec Aspect Global +@findex Global +@noindent +This aspect is equivalent pragma @code{Global}. + +@node Aspect Inline_Always +@unnumberedsec Aspect Inline_Always +@findex Inline_Always +@noindent +This aspect is equivalent to pragma @code{Inline_Always}. + +@node Aspect Invariant +@unnumberedsec Aspect Invariant +@findex Invariant +@noindent +This aspect is equivalent to pragma @code{Invariant}. It is a +synonym for the language defined aspect @code{Type_Invariant} except +that it is separately controllable using pragma @code{Assertion_Policy}. + +@node Aspect Lock_Free +@unnumberedsec Aspect Lock_Free +@findex Lock_Free +@noindent +This aspect is equivalent to pragma @code{Lock_Free}. + +@node Aspect Object_Size +@unnumberedsec Aspect Object_Size +@findex Object_Size +@noindent +This aspect is equivalent to an @code{Object_Size} attribute definition +clause. + +@node Aspect Persistent_BSS +@unnumberedsec Aspect Persistent_BSS +@findex Persistent_BSS +@noindent +This aspect is equivalent to pragma @code{Persistent_BSS}. + +@node Aspect Predicate +@unnumberedsec Aspect Predicate +@findex Predicate +@noindent +This aspect is equivalent to pragma @code{Predicate}. It is thus +similar to the language defined aspects @code{Dynamic_Predicate} +and @code{Static_Predicate} except that whether the resulting +predicate is static or dynamic is controlled by the form of the +expression. It is also separately controllable using pragma +@code{Assertion_Policy}. + +@node Aspect Preelaborate_05 +@unnumberedsec Aspect Preelaborate_05 +@findex Preelaborate_05 +@noindent +This aspect is equivalent to pragma @code{Preelaborate_05}. + +@node Aspect Pure_05 +@unnumberedsec Aspect Pure_05 +@findex Pure_05 +@noindent +This aspect is equivalent to pragma @code{Pure_05}. + +@node Aspect Pure_12 +@unnumberedsec Aspect Pure_12 +@findex Pure_12 +@noindent +This aspect is equivalent to pragma @code{Pure_12}. + +@node Aspect Pure_Function +@unnumberedsec Aspect Pure_Function +@findex Pure_Function +@noindent +This aspect is equivalent to pragma @code{Pure_Function}. + +@node Aspect Remote_Access_Type +@unnumberedsec Aspect Remote_Access_Type +@findex Remote_Access_Type +@noindent +This aspect is equivalent to pragma @code{Remote_Access_Type}. + +@node Aspect Scalar_Storage_Order +@unnumberedsec Aspect Scalar_Storage_Order +@findex Scalar_Storage_Order +@noindent +This aspect is equivalent to a @code{Scalar_Storage_Order} +attribute definition clause. + +@node Aspect Shared +@unnumberedsec Aspect Shared +@findex Shared +@noindent +This aspect is equivalent to pragma @code{Shared}, and is thus a synonym +for aspect @code{Atomic}. + +@node Aspect Simple_Storage_Pool +@unnumberedsec Aspect Simple_Storage_Pool +@findex Simple_Storage_Pool +@noindent +This aspect is equivalent to a @code{Simple_Storage_Pool} +attribute definition clause. + +@node Aspect Simple_Storage_Pool_Type +@unnumberedsec Aspect Simple_Storage_Pool_Type +@findex Simple_Storage_Pool_Type +@noindent +This aspect is equivalent to pragma @code{Simple_Storage_Pool_Type}. + +@node Aspect Suppress_Debug_Info +@unnumberedsec Aspect Suppress_Debug_Info +@findex Suppress_Debug_Info +@noindent +This aspect is equivalent to pragma @code{Suppress_Debug_Info}. + +@node Aspect Test_Case +@unnumberedsec Aspect Test_Case +@findex Test_Case +@noindent +This aspect is equivalent to pragma @code{Test_Case}. + +@node Aspect Universal_Aliasing +@unnumberedsec Aspect Universal_Aliasing +@findex Universal_Aliasing +@noindent +This aspect is equivalent to pragma @code{Universal_Aliasing}. + +@node Aspect Universal_Data +@unnumberedsec Aspect Universal_Data +@findex Universal_Data +@noindent +This aspect is equivalent to pragma @code{Universal_Data}. + +@node Aspect Unmodified +@unnumberedsec Aspect Unmodified +@findex Unmodified +@noindent +This aspect is equivalent to pragma @code{Unmodified}. + +@node Aspect Unreferenced +@unnumberedsec Aspect Unreferenced +@findex Unreferenced +@noindent +This aspect is equivalent to pragma @code{Unreferenced}. + +@node Aspect Unreferenced_Objects +@unnumberedsec Aspect Unreferenced_Objects +@findex Unreferenced_Objects +@noindent +This aspect is equivalent to pragma @code{Unreferenced_Objects}. + +@node Aspect Value_Size +@unnumberedsec Aspect Value_Size +@findex Value_Size +@noindent +This aspect is equivalent to a @code{Value_Size} +attribute definition clause. + +@node Aspect Warnings +@unnumberedsec Aspect Warnings +@findex Warnings +@noindent +This aspect is equivalent to the two argument form of pragma @code{Warnings}, +where the first argument is @code{ON} or @code{OFF} and the second argument +is the entity. + @node Implementation Defined Attributes @chapter Implementation Defined Attributes Ada defines (throughout the Ada reference manual, @@ -6447,71 +7123,73 @@ platforms). Therefore if portability to other compilers is an important consideration, you should minimize the use of these attributes. @menu -* Abort_Signal:: -* Address_Size:: -* Asm_Input:: -* Asm_Output:: -* AST_Entry:: -* Bit:: -* Bit_Position:: -* Compiler_Version:: -* Code_Address:: -* Default_Bit_Order:: -* Descriptor_Size:: -* Elaborated:: -* Elab_Body:: -* Elab_Spec:: -* Elab_Subp_Body:: -* Emax:: -* Enabled:: -* Enum_Rep:: -* Enum_Val:: -* Epsilon:: -* Fixed_Value:: -* Has_Access_Values:: -* Has_Discriminants:: -* Img:: -* Integer_Value:: -* Invalid_Value:: -* Large:: -* Machine_Size:: -* Mantissa:: -* Max_Interrupt_Priority:: -* Max_Priority:: -* Maximum_Alignment:: -* Mechanism_Code:: -* Null_Parameter:: -* Object_Size:: -* Passed_By_Reference:: -* Pool_Address:: -* Range_Length:: -* Ref:: -* Result:: -* Safe_Emax:: -* Safe_Large:: -* Scalar_Storage_Order:: -* Simple_Storage_Pool:: -* Small:: -* Storage_Unit:: -* Stub_Type:: -* System_Allocator_Alignment:: -* Target_Name:: -* Tick:: -* To_Address:: -* Type_Class:: -* UET_Address:: -* Unconstrained_Array:: -* Universal_Literal_String:: -* Unrestricted_Access:: -* Valid_Scalars:: -* VADS_Size:: -* Value_Size:: -* Wchar_T_Size:: -* Word_Size:: +* Attribute Abort_Signal:: +* Attribute Address_Size:: +* Attribute Asm_Input:: +* Attribute Asm_Output:: +* Attribute AST_Entry:: +* Attribute Bit:: +* Attribute Bit_Position:: +* Attribute Compiler_Version:: +* Attribute Code_Address:: +* Attribute Default_Bit_Order:: +* Attribute Descriptor_Size:: +* Attribute Elaborated:: +* Attribute Elab_Body:: +* Attribute Elab_Spec:: +* Attribute Elab_Subp_Body:: +* Attribute Emax:: +* Attribute Enabled:: +* Attribute Enum_Rep:: +* Attribute Enum_Val:: +* Attribute Epsilon:: +* Attribute Fixed_Value:: +* Attribute Has_Access_Values:: +* Attribute Has_Discriminants:: +* Attribute Img:: +* Attribute Integer_Value:: +* Attribute Invalid_Value:: +* Attribute Large:: +* Attribute Loop_Entry:: +* Attribute Machine_Size:: +* Attribute Mantissa:: +* Attribute Max_Interrupt_Priority:: +* Attribute Max_Priority:: +* Attribute Maximum_Alignment:: +* Attribute Mechanism_Code:: +* Attribute Null_Parameter:: +* Attribute Object_Size:: +* Attribute Passed_By_Reference:: +* Attribute Pool_Address:: +* Attribute Range_Length:: +* Attribute Ref:: +* Attribute Result:: +* Attribute Safe_Emax:: +* Attribute Safe_Large:: +* Attribute Scalar_Storage_Order:: +* Attribute Simple_Storage_Pool:: +* Attribute Small:: +* Attribute Storage_Unit:: +* Attribute Stub_Type:: +* Attribute System_Allocator_Alignment:: +* Attribute Target_Name:: +* Attribute Tick:: +* Attribute To_Address:: +* Attribute Type_Class:: +* Attribute UET_Address:: +* Attribute Unconstrained_Array:: +* Attribute Universal_Literal_String:: +* Attribute Unrestricted_Access:: +* Attribute Update:: +* Attribute Valid_Scalars:: +* Attribute VADS_Size:: +* Attribute Value_Size:: +* Attribute Wchar_T_Size:: +* Attribute Word_Size:: @end menu -@node Abort_Signal -@unnumberedsec Abort_Signal +@node Attribute Abort_Signal +@unnumberedsec Attribute Abort_Signal @findex Abort_Signal @noindent @code{Standard'Abort_Signal} (@code{Standard} is the only allowed @@ -6521,8 +7199,8 @@ should only be used in the tasking runtime (it is highly peculiar, and completely outside the normal semantics of Ada, for a user program to intercept the abort exception). -@node Address_Size -@unnumberedsec Address_Size +@node Attribute Address_Size +@unnumberedsec Attribute Address_Size @cindex Size of @code{Address} @findex Address_Size @noindent @@ -6533,8 +7211,8 @@ but has the advantage of being static, while a direct reference to System.Address'Size is non-static because Address is a private type. -@node Asm_Input -@unnumberedsec Asm_Input +@node Attribute Asm_Input +@unnumberedsec Attribute Asm_Input @findex Asm_Input @noindent The @code{Asm_Input} attribute denotes a function that takes two @@ -6547,8 +7225,8 @@ constant are the same as those used in the RTL, and are dependent on the configuration file used to built the GCC back end. @ref{Machine Code Insertions} -@node Asm_Output -@unnumberedsec Asm_Output +@node Attribute Asm_Output +@unnumberedsec Attribute Asm_Output @findex Asm_Output @noindent The @code{Asm_Output} attribute denotes a function that takes two @@ -6563,8 +7241,8 @@ GCC back end. If there are no output operands, then this argument may either be omitted, or explicitly given as @code{No_Output_Operands}. @ref{Machine Code Insertions} -@node AST_Entry -@unnumberedsec AST_Entry +@node Attribute AST_Entry +@unnumberedsec Attribute AST_Entry @cindex OpenVMS @findex AST_Entry @noindent @@ -6575,8 +7253,8 @@ pragma @code{Extend_System (Aux_DEC)}). This value enables the given entry to be called when an AST occurs. For further details, refer to the @cite{DEC Ada Language Reference Manual}, section 9.12a. -@node Bit -@unnumberedsec Bit +@node Attribute Bit +@unnumberedsec Attribute Bit @findex Bit @code{@var{obj}'Bit}, where @var{obj} is any object, yields the bit offset within the storage unit (byte) that contains the first bit of @@ -6602,8 +7280,8 @@ are subject to index checks. This attribute is designed to be compatible with the DEC Ada 83 definition and implementation of the @code{Bit} attribute. -@node Bit_Position -@unnumberedsec Bit_Position +@node Attribute Bit_Position +@unnumberedsec Attribute Bit_Position @findex Bit_Position @noindent @code{@var{R.C}'Bit_Position}, where @var{R} is a record object and C is one @@ -6614,8 +7292,8 @@ type @code{Universal_Integer}. The value depends only on the field @var{C} and is independent of the alignment of the containing record @var{R}. -@node Compiler_Version -@unnumberedsec Compiler_Version +@node Attribute Compiler_Version +@unnumberedsec Attribute Compiler_Version @findex Compiler_Version @noindent @code{Standard'Compiler_Version} (@code{Standard} is the only allowed @@ -6623,8 +7301,8 @@ prefix) yields a static string identifying the version of the compiler being used to compile the unit containing the attribute reference. A typical result would be something like "@value{EDITION} @i{version} (20090221)". -@node Code_Address -@unnumberedsec Code_Address +@node Attribute Code_Address +@unnumberedsec Attribute Code_Address @findex Code_Address @cindex Subprogram address @cindex Address of subprogram code @@ -6662,8 +7340,8 @@ generated code of the specified subprogram, which may or may not be the same value as is returned by the corresponding @code{'Address} attribute. -@node Default_Bit_Order -@unnumberedsec Default_Bit_Order +@node Attribute Default_Bit_Order +@unnumberedsec Attribute Default_Bit_Order @cindex Big endian @cindex Little endian @findex Default_Bit_Order @@ -6674,8 +7352,8 @@ as a @code{Pos} value (0 for @code{High_Order_First}, 1 for @code{Low_Order_First}). This is used to construct the definition of @code{Default_Bit_Order} in package @code{System}. -@node Descriptor_Size -@unnumberedsec Descriptor_Size +@node Attribute Descriptor_Size +@unnumberedsec Attribute Descriptor_Size @cindex Descriptor @cindex Dope vector @findex Descriptor_Size @@ -6698,8 +7376,8 @@ In the example above, the descriptor contains two values of type a size of 31 bits and an alignment of 4, the descriptor size is @code{2 * Positive'Size + 2} or 64 bits. -@node Elaborated -@unnumberedsec Elaborated +@node Attribute Elaborated +@unnumberedsec Attribute Elaborated @findex Elaborated @noindent The prefix of the @code{'Elaborated} attribute must be a unit name. The @@ -6710,8 +7388,8 @@ in user programs. The value will always be True once elaboration of all units has been completed. An exception is for units which need no elaboration, the value is always False for such units. -@node Elab_Body -@unnumberedsec Elab_Body +@node Attribute Elab_Body +@unnumberedsec Attribute Elab_Body @findex Elab_Body @noindent This attribute can only be applied to a program unit name. It returns @@ -6723,8 +7401,8 @@ is useful to be able to call this elaboration procedure from Ada code, e.g.@: if it is necessary to do selective re-elaboration to fix some error. -@node Elab_Spec -@unnumberedsec Elab_Spec +@node Attribute Elab_Spec +@unnumberedsec Attribute Elab_Spec @findex Elab_Spec @noindent This attribute can only be applied to a program unit name. It returns @@ -6736,8 +7414,8 @@ which it is useful to be able to call this elaboration procedure from Ada code, e.g.@: if it is necessary to do selective re-elaboration to fix some error. -@node Elab_Subp_Body -@unnumberedsec Elab_Subp_Body +@node Attribute Elab_Subp_Body +@unnumberedsec Attribute Elab_Subp_Body @findex Elab_Subp_Body @noindent This attribute can only be applied to a library level subprogram @@ -6747,8 +7425,8 @@ of the referenced subprogram unit. This is used in the main generated elaboration procedure by the binder in CodePeer mode only and is unrecognized otherwise. -@node Emax -@unnumberedsec Emax +@node Attribute Emax +@unnumberedsec Attribute Emax @cindex Ada 83 attributes @findex Emax @noindent @@ -6756,8 +7434,8 @@ The @code{Emax} 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 Enabled -@unnumberedsec Enabled +@node Attribute Enabled +@unnumberedsec Attribute Enabled @findex Enabled @noindent The @code{Enabled} attribute allows an application program to check at compile @@ -6777,8 +7455,8 @@ to see if the check is enabled. A user of this package can then issue a @code{pragma Suppress} or @code{pragma Unsuppress} before instantiating the package or subprogram, controlling whether the check will be present. -@node Enum_Rep -@unnumberedsec Enum_Rep +@node Attribute Enum_Rep +@unnumberedsec Attribute Enum_Rep @cindex Representation of enums @findex Enum_Rep @noindent @@ -6812,8 +7490,8 @@ integer type, and the argument is a variable, so that the universal integer calculation is done at run time, then the call to @code{Enum_Rep} may raise @code{Constraint_Error}. -@node Enum_Val -@unnumberedsec Enum_Val +@node Attribute Enum_Val +@unnumberedsec Attribute Enum_Val @cindex Representation of enums @findex Enum_Val @noindent @@ -6833,8 +7511,8 @@ This will be equal to value of the @code{Val} attribute in the absence of an enumeration representation clause. This is a static attribute (i.e.@: the result is static if the argument is static). -@node Epsilon -@unnumberedsec Epsilon +@node Attribute Epsilon +@unnumberedsec Attribute Epsilon @cindex Ada 83 attributes @findex Epsilon @noindent @@ -6842,8 +7520,8 @@ The @code{Epsilon} 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 Fixed_Value -@unnumberedsec Fixed_Value +@node Attribute Fixed_Value +@unnumberedsec Attribute Fixed_Value @findex Fixed_Value @noindent For every fixed-point type @var{S}, @code{@var{S}'Fixed_Value} denotes a @@ -6869,8 +7547,8 @@ that there are full range checks, to ensure that the result is in range. This attribute is primarily intended for use in implementation of the input-output functions for fixed-point values. -@node Has_Access_Values -@unnumberedsec Has_Access_Values +@node Attribute Has_Access_Values +@unnumberedsec Attribute Has_Access_Values @cindex Access values, testing for @findex Has_Access_Values @noindent @@ -6882,8 +7560,8 @@ The intended use of this attribute is in conjunction with generic definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has access values. -@node Has_Discriminants -@unnumberedsec Has_Discriminants +@node Attribute Has_Discriminants +@unnumberedsec Attribute Has_Discriminants @cindex Discriminants, testing for @findex Has_Discriminants @noindent @@ -6893,8 +7571,8 @@ otherwise. The intended use of this attribute is in conjunction with generic definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has discriminants. -@node Img -@unnumberedsec Img +@node Attribute Img +@unnumberedsec Attribute Img @findex Img @noindent The @code{Img} attribute differs from @code{Image} in that it may be @@ -6916,8 +7594,8 @@ Put_Line ("X = " & @var{T}'Image (X)); @noindent where @var{T} is the (sub)type of the object @code{X}. -@node Integer_Value -@unnumberedsec Integer_Value +@node Attribute Integer_Value +@unnumberedsec Attribute Integer_Value @findex Integer_Value @noindent For every integer type @var{S}, @code{@var{S}'Integer_Value} denotes a @@ -6944,8 +7622,8 @@ that there are full range checks, to ensure that the result is in range. This attribute is primarily intended for use in implementation of the standard input-output functions for fixed-point values. -@node Invalid_Value -@unnumberedsec Invalid_Value +@node Attribute Invalid_Value +@unnumberedsec Attribute Invalid_Value @findex Invalid_Value @noindent For every scalar type S, S'Invalid_Value returns an undefined value of the @@ -6955,8 +7633,8 @@ uninitialized value of the type if pragma Initialize_Scalars is used, including the ability to modify the value with the binder -Sxx flag and relevant environment variables at run time. -@node Large -@unnumberedsec Large +@node Attribute Large +@unnumberedsec Attribute Large @cindex Ada 83 attributes @findex Large @noindent @@ -6964,15 +7642,45 @@ 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 Machine_Size -@unnumberedsec Machine_Size +@node Attribute Loop_Entry +@unnumberedsec Attribute Loop_Entry +@findex Loop_Entry +@noindent +Syntax: + +@smallexample @c ada +X'Loop_Entry [(loop_name)] +@end smallexample + +@noindent +The @code{Loop_Entry} attribute is used to refer to the value that an +expression had upon entry to a given loop in much the same way that the +@code{Old} attribute in a subprogram postcondition can be used to refer +to the value an expression had upon entry to the subprogram. The +relevant loop is either identified by the given loop name, or it is the +innermost enclosing loop when no loop name is given. + +@noindent +A @code{Loop_Entry} attribute can only occur within a +@code{Loop_Variant} or @code{Loop_Invariant} pragma. A common use of +@code{Loop_Entry} is to compare the current value of objects with their +initial value at loop entry, in a @code{Loop_Invariant} pragma. + +@noindent +The effect of using @code{X'Loop_Entry} is the same as declaring +a constant initialized with the initial value of @code{X} at loop +entry. This copy is not performed if the loop is not entered, or if the +corresponding pragmas are ignored or disabled. + +@node Attribute Machine_Size +@unnumberedsec Attribute Machine_Size @findex Machine_Size @noindent This attribute is identical to the @code{Object_Size} attribute. It is provided for compatibility with the DEC Ada 83 attribute of this name. -@node Mantissa -@unnumberedsec Mantissa +@node Attribute Mantissa +@unnumberedsec Attribute Mantissa @cindex Ada 83 attributes @findex Mantissa @noindent @@ -6980,8 +7688,8 @@ The @code{Mantissa} 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 Max_Interrupt_Priority -@unnumberedsec Max_Interrupt_Priority +@node Attribute Max_Interrupt_Priority +@unnumberedsec Attribute Max_Interrupt_Priority @cindex Interrupt priority, maximum @findex Max_Interrupt_Priority @noindent @@ -6989,16 +7697,16 @@ this attribute. permissible prefix), provides the same value as @code{System.Max_Interrupt_Priority}. -@node Max_Priority -@unnumberedsec Max_Priority +@node Attribute Max_Priority +@unnumberedsec Attribute Max_Priority @cindex Priority, maximum @findex Max_Priority @noindent @code{Standard'Max_Priority} (@code{Standard} is the only permissible prefix) provides the same value as @code{System.Max_Priority}. -@node Maximum_Alignment -@unnumberedsec Maximum_Alignment +@node Attribute Maximum_Alignment +@unnumberedsec Attribute Maximum_Alignment @cindex Alignment, maximum @findex Maximum_Alignment @noindent @@ -7008,8 +7716,8 @@ target. This is a static value that can be used to specify the alignment for an object, guaranteeing that it is properly aligned in all cases. -@node Mechanism_Code -@unnumberedsec Mechanism_Code +@node Attribute Mechanism_Code +@unnumberedsec Attribute Mechanism_Code @cindex Return values, passing mechanism @cindex Parameters, passing mechanism @findex Mechanism_Code @@ -7047,8 +7755,8 @@ by descriptor (NCA: non-contiguous array) Values from 3 through 10 are only relevant to Digital OpenVMS implementations. @cindex OpenVMS -@node Null_Parameter -@unnumberedsec Null_Parameter +@node Attribute Null_Parameter +@unnumberedsec Attribute Null_Parameter @cindex Zero address, passing @findex Null_Parameter @noindent @@ -7067,8 +7775,8 @@ passed for a record or other composite object passed by reference. There is no way of indicating this without the @code{Null_Parameter} attribute. -@node Object_Size -@unnumberedsec Object_Size +@node Attribute Object_Size +@unnumberedsec Attribute Object_Size @cindex Size, used for objects @findex Object_Size @noindent @@ -7092,8 +7800,8 @@ alignment will be 4, because of the integer field, and so the default size of record objects for this type will be 64 (8 bytes). -@node Passed_By_Reference -@unnumberedsec Passed_By_Reference +@node Attribute Passed_By_Reference +@unnumberedsec Attribute Passed_By_Reference @cindex Parameters, when passed by reference @findex Passed_By_Reference @noindent @@ -7103,8 +7811,8 @@ normally passed by reference and @code{False} if the type is normally passed by copy in calls. For scalar types, the result is always @code{False} and is static. For non-scalar types, the result is non-static. -@node Pool_Address -@unnumberedsec Pool_Address +@node Attribute Pool_Address +@unnumberedsec Attribute Pool_Address @cindex Parameters, when passed by reference @findex Pool_Address @noindent @@ -7122,28 +7830,28 @@ the global heap, on the stack, or in a static memory area. For an object created by @code{new}, @code{@var{Ptr.all}'Pool_Address} is what is passed to @code{Allocate} and returned from @code{Deallocate}. -@node Range_Length -@unnumberedsec Range_Length +@node Attribute Range_Length +@unnumberedsec Attribute Range_Length @findex Range_Length @noindent @code{@var{type}'Range_Length} for any discrete type @var{type} yields the number of values represented by the subtype (zero for a null range). The result is static for static subtypes. @code{Range_Length} applied to the index subtype of a one dimensional array always gives the -same result as @code{Range} applied to the array itself. +same result as @code{Length} applied to the array itself. -@node Ref -@unnumberedsec Ref +@node Attribute Ref +@unnumberedsec Attribute Ref @findex Ref @noindent The @code{System.Address'Ref} (@code{System.Address} is the only permissible prefix) denotes a function identical to @code{System.Storage_Elements.To_Address} except that -it is a static attribute. See @ref{To_Address} for more details. +it is a static attribute. See @ref{Attribute To_Address} for more details. -@node Result -@unnumberedsec Result +@node Attribute Result +@unnumberedsec Attribute Result @findex Result @noindent @code{@var{function}'Result} can only be used with in a Postcondition pragma @@ -7152,8 +7860,8 @@ is used to refer to the result of the function in the postcondition expression. For a further discussion of the use of this attribute and examples of its use, see the description of pragma Postcondition. -@node Safe_Emax -@unnumberedsec Safe_Emax +@node Attribute Safe_Emax +@unnumberedsec Attribute Safe_Emax @cindex Ada 83 attributes @findex Safe_Emax @noindent @@ -7161,8 +7869,8 @@ The @code{Safe_Emax} 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 Safe_Large -@unnumberedsec Safe_Large +@node Attribute Safe_Large +@unnumberedsec Attribute Safe_Large @cindex Ada 83 attributes @findex Safe_Large @noindent @@ -7170,8 +7878,8 @@ The @code{Safe_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 Scalar_Storage_Order -@unnumberedsec Scalar_Storage_Order +@node Attribute Scalar_Storage_Order +@unnumberedsec Attribute Scalar_Storage_Order @cindex Endianness @cindex Scalar storage order @findex Scalar_Storage_Order @@ -7263,8 +7971,8 @@ are relaxed. Instead, the following rules apply: @end itemize -@node Simple_Storage_Pool -@unnumberedsec Simple_Storage_Pool +@node Attribute Simple_Storage_Pool +@unnumberedsec Attribute Simple_Storage_Pool @cindex Storage pool, simple @cindex Simple storage pool @findex Simple_Storage_Pool @@ -7323,8 +8031,8 @@ parameter. The detailed semantics of such unchecked deallocations is the same as defined in section 13.11.2 of the Ada Reference Manual, except that the term ``simple storage pool'' is substituted for ``storage pool''. -@node Small -@unnumberedsec Small +@node Attribute Small +@unnumberedsec Attribute Small @cindex Ada 83 attributes @findex Small @noindent @@ -7335,15 +8043,15 @@ for compatibility with Ada 83. See the Ada 83 reference manual for an exact description of the semantics of this attribute when applied to floating-point types. -@node Storage_Unit -@unnumberedsec Storage_Unit +@node Attribute Storage_Unit +@unnumberedsec Attribute Storage_Unit @findex Storage_Unit @noindent @code{Standard'Storage_Unit} (@code{Standard} is the only permissible prefix) provides the same value as @code{System.Storage_Unit}. -@node Stub_Type -@unnumberedsec Stub_Type +@node Attribute Stub_Type +@unnumberedsec Attribute Stub_Type @findex Stub_Type @noindent The GNAT implementation of remote access-to-classwide types is @@ -7363,8 +8071,8 @@ type @code{RACW_Stub_Type} declared in the internal implementation-defined unit @code{System.Partition_Interface}. Use of this attribute will create an implicit dependency on this unit. -@node System_Allocator_Alignment -@unnumberedsec System_Allocator_Alignment +@node Attribute System_Allocator_Alignment +@unnumberedsec Attribute System_Allocator_Alignment @cindex Alignment, allocator @findex System_Allocator_Alignment @noindent @@ -7375,8 +8083,8 @@ in user storage pools based on malloc either to reject allocation with alignment too large or to enable a realignment circuitry if the alignment request is larger than this value. -@node Target_Name -@unnumberedsec Target_Name +@node Attribute Target_Name +@unnumberedsec Attribute Target_Name @findex Target_Name @noindent @code{Standard'Target_Name} (@code{Standard} is the only permissible @@ -7385,15 +8093,15 @@ for the current compilation. For GCC implementations, this is the standard gcc target name without the terminating slash (for example, GNAT 5.0 on windows yields "i586-pc-mingw32msv"). -@node Tick -@unnumberedsec Tick +@node Attribute Tick +@unnumberedsec Attribute Tick @findex Tick @noindent @code{Standard'Tick} (@code{Standard} is the only permissible prefix) provides the same value as @code{System.Tick}, -@node To_Address -@unnumberedsec To_Address +@node Attribute To_Address +@unnumberedsec Attribute To_Address @findex To_Address @noindent The @code{System'To_Address} @@ -7408,8 +8116,8 @@ 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). -@node Type_Class -@unnumberedsec Type_Class +@node Attribute Type_Class +@unnumberedsec Attribute Type_Class @findex Type_Class @noindent @code{@var{type}'Type_Class} for any type or subtype @var{type} yields @@ -7436,8 +8144,8 @@ Protected types yield the value @code{Type_Class_Task}, which thus applies to all concurrent types. This attribute is designed to be compatible with the DEC Ada 83 attribute of the same name. -@node UET_Address -@unnumberedsec UET_Address +@node Attribute UET_Address +@unnumberedsec Attribute UET_Address @findex UET_Address @noindent The @code{UET_Address} attribute can only be used for a prefix which @@ -7447,8 +8155,8 @@ intended only for use within the GNAT implementation. See the unit @code{Ada.Exceptions} in files @file{a-except.ads} and @file{a-except.adb} for details on how this attribute is used in the implementation. -@node Unconstrained_Array -@unnumberedsec Unconstrained_Array +@node Attribute Unconstrained_Array +@unnumberedsec Attribute Unconstrained_Array @findex Unconstrained_Array @noindent The @code{Unconstrained_Array} attribute can be used with a prefix that @@ -7458,8 +8166,8 @@ and @code{False} otherwise. In a generic instance, the result is still static, and yields the result of applying this test to the generic actual. -@node Universal_Literal_String -@unnumberedsec Universal_Literal_String +@node Attribute Universal_Literal_String +@unnumberedsec Attribute Universal_Literal_String @cindex Named numbers, representation of @findex Universal_Literal_String @noindent @@ -7481,8 +8189,8 @@ begin end; @end smallexample -@node Unrestricted_Access -@unnumberedsec Unrestricted_Access +@node Attribute Unrestricted_Access +@unnumberedsec Attribute Unrestricted_Access @cindex @code{Access}, unrestricted @findex Unrestricted_Access @noindent @@ -7506,8 +8214,80 @@ scope. For instance, a function cannot use @code{Unrestricted_Access} to create a unconstrained pointer and then return that value to the caller. -@node Valid_Scalars -@unnumberedsec Valid_Scalars +@node Attribute Update +@unnumberedsec Attribute Update +@findex Update +@noindent +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); +@end smallexample + +@noindent +where @code{PREFIX} is the name of an array or record object, and +@code{AGGREGATE} is a named aggregate that does not contain an @code{others} +choice. The effect is to yield a copy of the array or record value which +is unchanged apart from the components mentioned in the aggregate, which +are changed to the indicated value. The original value of the array or +record value is not affected. For example: + +@smallexample @c ada +type Arr is Array (1 .. 5) of Integer; +... +Avar1 : Arr := (1,2,3,4,5); +Avar2 : Arr := Avar1'Update ((2 => 10, 3 .. 4 => 20)); +@end smallexample + +@noindent +yields a value for @code{Avar2} of 1,10,20,20,5 with @code{Avar1} +begin unmodified. Similarly: + +@smallexample @c ada +type Rec is A, B, C : Integer; +... +Rvar1 : Rec := (A => 1, B => 2, C => 3); +Rvar2 : Rec := Rvar1'Update ((B => 20)); +@end smallexample + +@noindent +yields a value for @code{Rvar2} of (A => 1, B => 20, C => 3), +with @code{Rvar1} being unmodifed. +Note that the value of the attribute reference is computed +completely before it is used. This means that if you write: + +@smallexample @c ada +Avar1 := Avar1'Update ((1 => 10, 2 => Function_Call)); +@end smallexample + +@noindent +then the value of @code{Avar1} is not modified if @code{Function_Call} +raises an exception, unlike the effect of a series of direct assignments +to elements of @code{Avar1}. In general this requires that +two extra complete copies of the object are required, which should be +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. + +In the record case, no component can be mentioned more than once. In +the array case, two overlapping ranges can appear in the aggregate, +in which case the modifications are processed left to right. + +Multi-dimensional arrays can be modified, as shown by this example: + +@smallexample @c ada +A : array (1 .. 10, 1 .. 10) of Integer; +.. +A := A'Update (1 => (2 => 20), 3 => (4 => 30)); +@end smallexample + +@noindent +which changes element (1,2) to 20 and (3,4) to 30. + +@node Attribute Valid_Scalars +@unnumberedsec Attribute Valid_Scalars @findex Valid_Scalars @noindent The @code{'Valid_Scalars} attribute is intended to make it easier to @@ -7528,8 +8308,8 @@ be determined at compile time that the prefix of the attribute has no scalar parts (e.g., if the prefix is of an access type, an interface type, an undiscriminated task type, or an undiscriminated protected type). -@node VADS_Size -@unnumberedsec VADS_Size +@node Attribute VADS_Size +@unnumberedsec Attribute VADS_Size @cindex @code{Size}, VADS compatibility @findex VADS_Size @noindent @@ -7543,24 +8323,24 @@ typical machines). In addition @code{'VADS_Size} applied to an object gives the result that would be obtained by applying the attribute to the corresponding type. -@node Value_Size -@unnumberedsec Value_Size +@node Attribute Value_Size +@unnumberedsec Attribute Value_Size @cindex @code{Size}, setting for not-first subtype @findex Value_Size @code{@var{type}'Value_Size} is the number of bits required to represent a value of the given subtype. It is the same as @code{@var{type}'Size}, but, unlike @code{Size}, may be set for non-first subtypes. -@node Wchar_T_Size -@unnumberedsec Wchar_T_Size +@node Attribute Wchar_T_Size +@unnumberedsec Attribute Wchar_T_Size @findex Wchar_T_Size @code{Standard'Wchar_T_Size} (@code{Standard} is the only permissible prefix) provides the size in bits of the C @code{wchar_t} type primarily for constructing the definition of this type in package @code{Interfaces.C}. -@node Word_Size -@unnumberedsec Word_Size +@node Attribute Word_Size +@unnumberedsec Attribute Word_Size @findex Word_Size @code{Standard'Word_Size} (@code{Standard} is the only permissible prefix) provides the value @code{System.Word_Size}. @@ -10392,6 +11172,12 @@ The implementation defined check name Alignment_Check controls checking of address clause values for proper alignment (that is, the address supplied must be consistent with the alignment of the type). +The implementation defined check name Predicate_Check controls whether +predicate checks are generated. + +The implementation defined check name Validity_Check controls whether +validity checks are generated. + In addition, a user program can add implementation-defined check names by means of the pragma Check_Name. @@ -11842,7 +12628,7 @@ For primitive types, the alignment is the minimum of the actual size of objects of the type divided by @code{Storage_Unit}, and the maximum alignment supported by the target. (This maximum alignment is given by the GNAT-specific attribute -@code{Standard'Maximum_Alignment}; see @ref{Maximum_Alignment}.) +@code{Standard'Maximum_Alignment}; see @ref{Attribute Maximum_Alignment}.) @cindex @code{Maximum_Alignment} attribute For example, for type @code{Long_Float}, the object size is 8 bytes, and the default alignment will be 8 on any target that supports alignments @@ -14256,6 +15042,25 @@ The use of these parameters is described later in this section. If an unrecognized keyword appears in a form string, it is silently ignored and not considered invalid. +@noindent +For OpenVMS additional FORM string keywords are available for use with +RMS services. The syntax is: + +@smallexample +VMS_RMS_Keys=(keyword=value,@dots{},keyword=value) +@end smallexample + +@noindent +The following RMS keywords and values are currently defined: + +@smallexample +Context=Force_Stream_Mode|Force_Record_Mode +@end smallexample + +@noindent +VMS RMS keys are silently ignored on non-VMS systems. On OpenVMS +unimplented RMS keywords, values, or invalid syntax will raise Use_Error. + @node Direct_IO @section Direct_IO @@ -15505,6 +16310,8 @@ of GNAT, and will generate a warning message. * System.Address_Image (s-addima.ads):: * System.Assertions (s-assert.ads):: * System.Memory (s-memory.ads):: +* System.Multiprocessors (s-multip.ads):: +* System.Multiprocessors.Dispatching_Domains (s-mudido.ads):: * System.Partition_Interface (s-parint.ads):: * System.Pool_Global (s-pooglo.ads):: * System.Pool_Local (s-pooloc.ads):: @@ -16967,6 +17774,22 @@ allocation mechanisms for the default pool, and in addition, direct calls to this unit may be made for low level allocation uses (for example see the body of @code{GNAT.Tables}). +@node System.Multiprocessors (s-multip.ads) +@section @code{System.Multiprocessors} (@file{s-multip.ads}) +@cindex @code{System.Multiprocessors} (@file{s-multip.ads}) +@cindex Multiprocessor interface +This is an Ada 2012 unit defined in the Ada 2012 Reference Manual, but +in GNAT we also make it available in Ada 95 and Ada 2005 (where it is +technically an implementation-defined addition). + +@node System.Multiprocessors.Dispatching_Domains (s-mudido.ads) +@section @code{System.Multiprocessors.Dispatching_Domains} (@file{s-mudido.ads}) +@cindex @code{System.Multiprocessors.Dispatching_Domains} (@file{s-mudido.ads}) +@cindex Multiprocessor interface +This is an Ada 2012 unit defined in the Ada 2012 Reference Manual, but +in GNAT we also make it available in Ada 95 and Ada 2005 (where it is +technically an implementation-defined addition). + @node System.Partition_Interface (s-parint.ads) @section @code{System.Partition_Interface} (@file{s-parint.ads}) @cindex @code{System.Partition_Interface} (@file{s-parint.ads}) @@ -18072,7 +18895,7 @@ A complete description of the AIs may be found in @item @code{Atomic_Components} @tab @item @code{Bit_Order} @tab @item @code{Component_Size} @tab -@item @code{Contract_Case} @tab -- GNAT +@item @code{Contract_Cases} @tab -- GNAT @item @code{Discard_Names} @tab @item @code{External_Tag} @tab @item @code{Favor_Top_Level} @tab -- GNAT @@ -18115,7 +18938,7 @@ A complete description of the AIs may be found in Note that for aspects with an expression, e.g. @code{Size}, the expression is treated like a default expression (visibility is analyzed at the point of occurrence of the aspect, but evaluation of the expression occurs at the - freeze point of the entity involved. + freeze point of the entity involved). @noindent RM References: 3.02.01 (3) 3.02.02 (2) 3.03.01 (2/2) 3.08 (6) diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 1af8a943ef7..af5209c5f8b 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -89,8 +89,6 @@ Texts. A copy of the license is included in the section entitled @set FSFEDITION @set EDITION GNAT -@set DEFAULTLANGUAGEVERSION Ada 2005 -@set NONDEFAULTLANGUAGEVERSION Ada 95 @ifset unw @set PLATFORM @@ -169,39 +167,39 @@ AdaCore@* * About This Guide:: * Getting Started with GNAT:: * The GNAT Compilation Model:: -* Compiling Using gcc:: -* Binding Using gnatbind:: -* Linking Using gnatlink:: +* Compiling with gcc:: +* Binding with gnatbind:: +* Linking with gnatlink:: * The GNAT Make Program gnatmake:: * Improving Performance:: -* Renaming Files Using gnatchop:: +* Renaming Files with gnatchop:: * Configuration Pragmas:: -* Handling Arbitrary File Naming Conventions Using gnatname:: +* Handling Arbitrary File Naming Conventions with gnatname:: * GNAT Project Manager:: * Tools Supporting Project Files:: * The Cross-Referencing Tools gnatxref and gnatfind:: * The GNAT Pretty-Printer gnatpp:: -* The GNAT Metric Tool gnatmetric:: -* File Name Krunching Using gnatkr:: -* Preprocessing Using gnatprep:: +* The GNAT Metrics Tool gnatmetric:: +* File Name Krunching with gnatkr:: +* Preprocessing with gnatprep:: * The GNAT Library Browser gnatls:: -* Cleaning Up Using gnatclean:: +* Cleaning Up with gnatclean:: @ifclear vms * GNAT and Libraries:: * Using the GNU make Utility:: @end ifclear * Memory Management Issues:: * Stack Related Facilities:: -* Verifying Properties Using gnatcheck:: -* Creating Sample Bodies Using gnatstub:: -* Creating Unit Tests Using gnattest:: +* Verifying Properties with gnatcheck:: +* Creating Sample Bodies with gnatstub:: +* Creating Unit Tests with gnattest:: * Performing Dimensionality Analysis in GNAT:: * Generating Ada Bindings for C and C++ headers:: * Other Utility Programs:: -* Running and Debugging Ada Programs:: @ifclear vms * Code Coverage and Profiling:: @end ifclear +* Running and Debugging Ada Programs:: @ifset vms * Compatibility with HP Ada:: @end ifset @@ -212,468 +210,10 @@ AdaCore@* * Conditional Compilation:: * Inline Assembler:: * Compatibility and Porting Guide:: -@ifset unw * Microsoft Windows Topics:: * Mac OS Topics:: -@end ifset * GNU Free Documentation License:: * Index:: - - --- The Detailed Node Listing --- - -About This Guide - -* What This Guide Contains:: -* What You Should Know before Reading This Guide:: -* Related Information:: -* Conventions:: - -Getting Started with GNAT - -* Running GNAT:: -* Running a Simple Ada Program:: -* Running a Program with Multiple Units:: -* Using the gnatmake Utility:: -@ifset vms -* Editing with Emacs:: -@end ifset -@ifclear vms -* Introduction to GPS:: -@end ifclear - -The GNAT Compilation Model - -* Source Representation:: -* Foreign Language Representation:: -* File Naming Rules:: -* Using Other File Names:: -* Alternative File Naming Schemes:: -* Generating Object Files:: -* Source Dependencies:: -* The Ada Library Information Files:: -* Binding an Ada Program:: -* Mixed Language Programming:: -@ifclear vms -* Building Mixed Ada & C++ Programs:: -* Comparison between GNAT and C/C++ Compilation Models:: -@end ifclear -* Comparison between GNAT and Conventional Ada Library Models:: -@ifset vms -* Placement of temporary files:: -@end ifset - -Foreign Language Representation - -* Latin-1:: -* Other 8-Bit Codes:: -* Wide Character Encodings:: - -Compiling Ada Programs With gcc - -* Compiling Programs:: -* Switches for gcc:: -* Search Paths and the Run-Time Library (RTL):: -* Order of Compilation Issues:: -* Examples:: - -Switches for gcc - -* Output and Error Message Control:: -* Warning Message Control:: -* Debugging and Assertion Control:: -* Validity Checking:: -* Style Checking:: -* Run-Time Checks:: -* Using gcc for Syntax Checking:: -* Using gcc for Semantic Checking:: -* Compiling Different Versions of Ada:: -* Character Set Control:: -* File Naming Control:: -* Subprogram Inlining Control:: -* Auxiliary Output Control:: -* Debugging Control:: -* Exception Handling Control:: -* Units to Sources Mapping Files:: -* Integrated Preprocessing:: -@ifset vms -* Return Codes:: -@end ifset - -Binding Ada Programs With gnatbind - -* Running gnatbind:: -* Switches for gnatbind:: -* Command-Line Access:: -* Search Paths for gnatbind:: -* Examples of gnatbind Usage:: - -Switches for gnatbind - -* Consistency-Checking Modes:: -* Binder Error Message Control:: -* Elaboration Control:: -* Output Control:: -* Binding with Non-Ada Main Programs:: -* Binding Programs with No Main Subprogram:: - -Linking Using gnatlink - -* Running gnatlink:: -* Switches for gnatlink:: - -The GNAT Make Program gnatmake - -* Running gnatmake:: -* Switches for gnatmake:: -* Mode Switches for gnatmake:: -* Notes on the Command Line:: -* How gnatmake Works:: -* Examples of gnatmake Usage:: - -Improving Performance -* Performance Considerations:: -* Text_IO Suggestions:: -* Reducing Size of Ada Executables with gnatelim:: -* Reducing Size of Executables with unused subprogram/data elimination:: - -Performance Considerations -* Controlling Run-Time Checks:: -* Use of Restrictions:: -* Optimization Levels:: -* Debugging Optimized Code:: -* Inlining of Subprograms:: -* Vectorization of loops:: -* Other Optimization Switches:: -* Optimization and Strict Aliasing:: -@ifset vms -* Coverage Analysis:: -@end ifset - -Reducing Size of Ada Executables with gnatelim -* About gnatelim:: -* Running gnatelim:: -* Processing Precompiled Libraries:: -* Correcting the List of Eliminate Pragmas:: -* Making Your Executables Smaller:: -* Summary of the gnatelim Usage Cycle:: - -Reducing Size of Executables with unused subprogram/data elimination -* About unused subprogram/data elimination:: -* Compilation options:: - -Renaming Files Using gnatchop - -* Handling Files with Multiple Units:: -* Operating gnatchop in Compilation Mode:: -* Command Line for gnatchop:: -* Switches for gnatchop:: -* Examples of gnatchop Usage:: - -Configuration Pragmas - -* Handling of Configuration Pragmas:: -* The Configuration Pragmas Files:: - -Handling Arbitrary File Naming Conventions Using gnatname - -* Arbitrary File Naming Conventions:: -* Running gnatname:: -* Switches for gnatname:: -* Examples of gnatname Usage:: - -The Cross-Referencing Tools gnatxref and gnatfind - -* Switches for gnatxref:: -* Switches for gnatfind:: -* Project Files for gnatxref and gnatfind:: -* Regular Expressions in gnatfind and gnatxref:: -* Examples of gnatxref Usage:: -* Examples of gnatfind Usage:: - -The GNAT Pretty-Printer gnatpp - -* Switches for gnatpp:: -* Formatting Rules:: - -The GNAT Metrics Tool gnatmetric - -* Switches for gnatmetric:: - -File Name Krunching Using gnatkr - -* About gnatkr:: -* Using gnatkr:: -* Krunching Method:: -* Examples of gnatkr Usage:: - -Preprocessing Using gnatprep -* Preprocessing Symbols:: -* Using gnatprep:: -* Switches for gnatprep:: -* Form of Definitions File:: -* Form of Input Text for gnatprep:: - -The GNAT Library Browser gnatls - -* Running gnatls:: -* Switches for gnatls:: -* Examples of gnatls Usage:: - -Cleaning Up Using gnatclean - -* Running gnatclean:: -* Switches for gnatclean:: -@c * Examples of gnatclean Usage:: - -@ifclear vms - -GNAT and Libraries - -* Introduction to Libraries in GNAT:: -* General Ada Libraries:: -* Stand-alone Ada Libraries:: -* Rebuilding the GNAT Run-Time Library:: - -Using the GNU make Utility - -* Using gnatmake in a Makefile:: -* Automatically Creating a List of Directories:: -* Generating the Command Line Switches:: -* Overcoming Command Line Length Limits:: -@end ifclear - -Memory Management Issues - -* Some Useful Memory Pools:: -* The GNAT Debug Pool Facility:: -@ifclear vms -* The gnatmem Tool:: -@end ifclear - -Stack Related Facilities - -* Stack Overflow Checking:: -* Static Stack Usage Analysis:: -* Dynamic Stack Usage Analysis:: - -Some Useful Memory Pools - -The GNAT Debug Pool Facility - -@ifclear vms -The gnatmem Tool - -* Running gnatmem:: -* Switches for gnatmem:: -* Example of gnatmem Usage:: -@end ifclear - -Verifying Properties Using gnatcheck - -Sample Bodies Using gnatstub - -* Running gnatstub:: -* Switches for gnatstub:: - -Creating Unit Tests Using gnattest - -* Running gnattest:: -* Switches for gnattest:: -* Project Attributes for gnattest:: -* Simple Example:: -* Setting Up and Tearing Down the Testing Environment:: -* Regenerating Tests:: -* Default Test Behavior:: -* Testing Primitive Operations of Tagged Types:: -* Testing Inheritance:: -* Tagged Types Substitutability Testing:: -* Testing with Contracts:: -* Additional Tests:: -@ifclear vms -* Support for other platforms/run-times:: -@end ifclear -* Current Limitations:: - -Other Utility Programs - -* Using Other Utility Programs with GNAT:: -* The External Symbol Naming Scheme of GNAT:: -* Converting Ada Files to html with gnathtml:: - -@ifclear vms -Code Coverage and Profiling - -* Code Coverage of Ada Programs using gcov:: -* Profiling an Ada Program using gprof:: -@end ifclear - -Running and Debugging Ada Programs - -* The GNAT Debugger GDB:: -* Running GDB:: -* Introduction to GDB Commands:: -* Using Ada Expressions:: -* Calling User-Defined Subprograms:: -* Using the Next Command in a Function:: -* Ada Exceptions:: -* Ada Tasks:: -* Debugging Generic Units:: -* Remote Debugging using gdbserver:: -* GNAT Abnormal Termination or Failure to Terminate:: -* Naming Conventions for GNAT Source Files:: -* Getting Internal Debugging Information:: -* Stack Traceback:: - -@ifset vms -* LSE:: -@end ifset - -@ifset vms -Compatibility with HP Ada - -* Ada Language Compatibility:: -* Differences in the Definition of Package System:: -* Language-Related Features:: -* The Package STANDARD:: -* The Package SYSTEM:: -* Tasking and Task-Related Features:: -* Pragmas and Pragma-Related Features:: -* Library of Predefined Units:: -* Bindings:: -* Main Program Definition:: -* Implementation-Defined Attributes:: -* Compiler and Run-Time Interfacing:: -* Program Compilation and Library Management:: -* Input-Output:: -* Implementation Limits:: -* Tools and Utilities:: - -Language-Related Features - -* Integer Types and Representations:: -* Floating-Point Types and Representations:: -* Pragmas Float_Representation and Long_Float:: -* Fixed-Point Types and Representations:: -* Record and Array Component Alignment:: -* Address Clauses:: -* Other Representation Clauses:: - -Tasking and Task-Related Features - -* Implementation of Tasks in HP Ada for OpenVMS Alpha Systems:: -* Assigning Task IDs:: -* Task IDs and Delays:: -* Task-Related Pragmas:: -* Scheduling and Task Priority:: -* The Task Stack:: -* External Interrupts:: - -Pragmas and Pragma-Related Features - -* Restrictions on the Pragma INLINE:: -* Restrictions on the Pragma INTERFACE:: -* Restrictions on the Pragma SYSTEM_NAME:: - -Library of Predefined Units - -* Changes to DECLIB:: - -Bindings - -* Shared Libraries and Options Files:: -* Interfaces to C:: -@end ifset - -Platform-Specific Information for the Run-Time Libraries - -* Summary of Run-Time Configurations:: -* Specifying a Run-Time Library:: -* Choosing the Scheduling Policy:: -* Solaris-Specific Considerations:: -* Linux-Specific Considerations:: -* AIX-Specific Considerations:: -* RTX-Specific Considerations:: -* HP-UX-Specific Considerations:: - -Example of Binder Output File - -Elaboration Order Handling in GNAT - -* Elaboration Code:: -* Checking the Elaboration Order:: -* Controlling the Elaboration Order:: -* Controlling Elaboration in GNAT - Internal Calls:: -* Controlling Elaboration in GNAT - External Calls:: -* Default Behavior in GNAT - Ensuring Safety:: -* Treatment of Pragma Elaborate:: -* Elaboration Issues for Library Tasks:: -* Mixing Elaboration Models:: -* What to Do If the Default Elaboration Behavior Fails:: -* Elaboration for Dispatching Calls:: -* Summary of Procedures for Elaboration Control:: -* Other Elaboration Order Considerations:: - -Overflow Check Handling in GNAT -* Background:: -* Overflow Checking Modes in GNAT:: -* Specifying the Desired Mode:: -* Default Settings:: -* Implementation Notes:: - -Conditional Compilation -* Use of Boolean Constants:: -* Debugging - A Special Case:: -* Conditionalizing Declarations:: -* Use of Alternative Implementations:: -* Preprocessing:: - -Inline Assembler - -* Basic Assembler Syntax:: -* A Simple Example of Inline Assembler:: -* Output Variables in Inline Assembler:: -* Input Variables in Inline Assembler:: -* Inlining Inline Assembler Code:: -* Other Asm Functionality:: - -Compatibility and Porting Guide - -* Compatibility with Ada 83:: -* Compatibility between Ada 95 and Ada 2005:: -* Implementation-dependent characteristics:: -@ifclear vms -@c This brief section is only in the non-VMS version -@c The complete chapter on HP Ada issues is in the VMS version -* Compatibility with HP Ada 83:: -@end ifclear -* Compatibility with Other Ada Systems:: -* Representation Clauses:: -@ifset vms -* Transitioning to 64-Bit GNAT for OpenVMS:: -@end ifset - -@ifset unw -Microsoft Windows Topics - -* Using GNAT on Windows:: -* CONSOLE and WINDOWS subsystems:: -* Temporary Files:: -* Mixed-Language Programming on Windows:: -* Windows Calling Conventions:: -* Introduction to Dynamic Link Libraries (DLLs):: -* Using DLLs with GNAT:: -* Building DLLs with GNAT:: -* GNAT and Windows Resources:: -* Debugging a DLL:: -* Setting Stack Size from gnatlink:: -* Setting Heap Size from gnatlink:: - -Mac OS Topics - -* Codesigning the Debugger:: -@end ifset - -* Index:: @end menu @end ifnottex @@ -695,15 +235,13 @@ toolset for the full Ada programming language. It documents the features of the compiler and tools, and explains how to use them to build Ada applications. -@value{EDITION} implements Ada 95 and Ada 2005, and it may also be invoked in -Ada 83 compatibility mode. -By default, @value{EDITION} assumes @value{DEFAULTLANGUAGEVERSION}, -but you can override with a compiler switch -(@pxref{Compiling Different Versions of Ada}) +@value{EDITION} implements Ada 95, Ada 2005 and Ada 2012, and it may also be +invoked in Ada 83 compatibility mode. +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 the Ada 95 and Ada 2005 versions of the language. - +apply to both all Ada 95/2005/2012 versions of the language. @ifclear FSFEDITION For ease of exposition, ``@value{EDITION}'' will be referred to simply as @@ -711,8 +249,6 @@ For ease of exposition, ``@value{EDITION}'' will be referred to simply as @end ifclear - - @menu * What This Guide Contains:: * What You Should Know before Reading This Guide:: @@ -735,16 +271,16 @@ and running Ada programs with the GNAT Ada programming environment. by GNAT. @item -@ref{Compiling Using gcc}, describes how to compile +@ref{Compiling with gcc}, describes how to compile Ada programs with @command{gcc}, the Ada compiler. @item -@ref{Binding Using gnatbind}, describes how to +@ref{Binding with gnatbind}, describes how to perform binding of Ada programs with @code{gnatbind}, the GNAT binding utility. @item -@ref{Linking Using gnatlink}, +@ref{Linking with gnatlink}, describes @command{gnatlink}, a program that provides for linking using the GNAT run-time library to construct a program. @command{gnatlink} can also incorporate foreign language @@ -764,7 +300,7 @@ also describes the @command{gnatelim} tool and unused subprogram/data elimination. @item -@ref{Renaming Files Using gnatchop}, describes +@ref{Renaming Files with gnatchop}, describes @code{gnatchop}, a utility that allows you to preprocess a file that contains Ada source code, and split it into one or more new files, one for each compilation unit. @@ -774,7 +310,7 @@ for each compilation unit. handled by GNAT. @item -@ref{Handling Arbitrary File Naming Conventions Using gnatname}, +@ref{Handling Arbitrary File Naming Conventions with gnatname}, shows how to override the default GNAT file naming conventions, either for an individual unit or globally. @@ -793,17 +329,17 @@ version of an Ada source file with control over casing, indentation, comment placement, and other elements of program presentation style. @item -@ref{The GNAT Metric Tool gnatmetric}, shows how to compute various +@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, and assorted complexity measures. @item -@ref{File Name Krunching Using gnatkr}, describes the @code{gnatkr} +@ref{File Name Krunching with gnatkr}, describes the @code{gnatkr} file name krunching utility, used to handle shortened file names on operating systems with a limit on the length of names. @item -@ref{Preprocessing Using gnatprep}, describes @code{gnatprep}, a +@ref{Preprocessing with gnatprep}, describes @code{gnatprep}, a preprocessor utility that allows a single source file to be used to generate multiple or parameterized source files by means of macro substitution. @@ -814,7 +350,7 @@ utility that displays information about compiled units, including dependences on the corresponding sources files, and consistency of compilations. @item -@ref{Cleaning Up Using gnatclean}, describes @code{gnatclean}, a utility +@ref{Cleaning Up with gnatclean}, describes @code{gnatclean}, a utility to delete files that are produced by the compiler, binder and linker. @ifclear vms @@ -842,15 +378,15 @@ allocation and deallocation and helps detect ``memory leaks''. stack checking and analysis. @item -@ref{Verifying Properties Using gnatcheck}, discusses @code{gnatcheck}, +@ref{Verifying Properties with gnatcheck}, discusses @code{gnatcheck}, a utility that checks Ada code against a set of rules. @item -@ref{Creating Sample Bodies Using gnatstub}, discusses @code{gnatstub}, +@ref{Creating Sample Bodies with gnatstub}, discusses @code{gnatstub}, a utility that generates empty but compilable bodies for library units. @item -@ref{Creating Unit Tests Using gnattest}, discusses @code{gnattest}, +@ref{Creating Unit Tests with gnattest}, discusses @code{gnattest}, a utility that generates unit testing templates for library units. @item @@ -1141,7 +677,7 @@ Alternatively, if you want to rename your files according to this default convention, which is probably more convenient if you will be using GNAT for all your compilations, then the @code{gnatchop} utility can be used to generate correctly-named source files -(@pxref{Renaming Files Using gnatchop}). +(@pxref{Renaming Files with gnatchop}). You can compile the program using the following command (@code{$} is used as the command prompt in the examples in this document): @@ -2078,7 +1614,7 @@ can specify the exact file names that you want used, as described in the next section. Finally, if your Ada programs are migrating from a compiler with a different naming convention, you can use the gnatchop utility to produce source files that follow the GNAT naming conventions. -(For details @pxref{Renaming Files Using gnatchop}.) +(For details @pxref{Renaming Files with gnatchop}.) Note: in the case of @code{Windows NT/XP} or @code{OpenVMS} operating systems, case is not significant. So for example on @code{Windows XP} @@ -3810,8 +3346,8 @@ GNAT uses the current directory for temporary files. @end ifset @c ************************* -@node Compiling Using gcc -@chapter Compiling Using @command{gcc} +@node Compiling with gcc +@chapter Compiling with @command{gcc} @noindent This chapter discusses how to compile Ada programs using the @command{gcc} @@ -3926,23 +3462,19 @@ files. It is possible to supply several file names on the same @command{gcc} command. This causes @command{gcc} to call the appropriate compiler for -each file. For example, the following command lists three separate +each file. For example, the following command lists two separate files to be compiled: @smallexample -$ gcc -c x.adb y.adb z.c +$ gcc -c x.adb y.adb @end smallexample @noindent calls @code{gnat1} (the Ada compiler) twice to compile @file{x.adb} and -@file{y.adb}, and @code{cc1} (the C compiler) once to compile @file{z.c}. -The compiler generates three object files @file{x.o}, @file{y.o} and -@file{z.o} and the two ALI files @file{x.ali} and @file{y.ali} from the -Ada compilations. Any switches apply to all the files ^listed,^listed.^ -@ifclear vms -except for -@option{-gnat@var{x}} switches, which apply only to Ada compilations. -@end ifclear +@file{y.adb}. +The compiler generates two object files @file{x.o} and @file{y.o} +and the two ALI files @file{x.ali} and @file{y.ali}. +Any switches apply to all the files ^listed,^listed.^ @node Switches for gcc @section Switches for @command{gcc} @@ -4157,7 +3689,15 @@ Assume no invalid (bad) values except for 'Valid attribute use @item -gnatc @cindex @option{-gnatc} (@command{gcc}) -Check syntax and semantics only (no code generation attempted). +Check syntax and semantics only (no code generation attempted). When the +compiler is invoked by @command{gnatmake}, if the switch @option{-gnatc} is +only given to the compiler (after @option{-cargs} or in package Compiler of +the project file, @command{gnatmake} will fail because it will not find the +object file after compilation. If @command{gnatmake} is called with +@option{-gnatc} as a builder switch (before @option{-cargs} or in package +Builder of the project file) then @command{gnatmake} will not fail because +it will not look for the object files after compilation, and it will not try +to build and link. @item -gnatC @cindex @option{-gnatC} (@command{gcc}) @@ -4419,7 +3959,7 @@ cases; if two digits are given, then the first applies outside assertions, and the second within assertions. If no digits follow the @option{-gnato}, then it is equivalent to -@option{-gnato11}, +@option{^-gnato11^/OVERFLOW_CHECKS=11^}, causing all intermediate overflows to be handled in strict mode. This switch also causes arithmetic overflow checking to be performed @@ -4983,7 +4523,7 @@ Additional details on incorrect parameters @item -gnatjnn @cindex @option{-gnatjnn} (@command{gcc}) -In normal operation mode (or if @option{-gnatj0} is used, then error messages +In normal operation mode (or if @option{-gnatj0} is used), then error messages with continuation lines are treated as though the continuation lines were separate messages (and so a warning with two continuation lines counts as three warnings, and is listed as three separate messages). @@ -5867,7 +5407,7 @@ This switch suppresses warnings for tracking of deleted conditional code. @cindex @option{-gnatw.t} (@command{gcc}) This switch activates warnings on suspicious postconditions (whether a pragma @code{Postcondition} or a @code{Post} aspect in Ada 2012) -and suspicious contract cases (pragma @code{Contract_Case}). A +and suspicious contract cases (pragma @code{Contract_Cases}). A function postcondition or contract case is suspicious when no postcondition or contract case for this function mentions the result of the function. A procedure postcondition or contract case is suspicious when it only @@ -7002,6 +6542,12 @@ year). The compiler will generate code based on the assumption that the condition being checked is true, which can result in disaster if that assumption is wrong. +The checks subject to suppression include all the checks defined by +the Ada standard, the additional implementation defined checks +@code{Alignment_Check}, @code{Atomic_Synchronization}, and +@code{Validity_Check}, as well as any checks introduced using +@code{pragma Check_Name}. + The @option{-gnatp} switch has no effect if a subsequent @option{-gnat-p} switch appears. @@ -7059,8 +6605,7 @@ with the use of @option{-gnato} in previous versions of GNAT. @findex Machine_Overflows Note that the @option{-gnato??} switch does not affect the code generated -for any floating-point operations; it applies only to integer -semantics. +for any floating-point operations; it applies only to integer semantics. For floating-point, @value{EDITION} has the @code{Machine_Overflows} attribute set to @code{False} and the normal mode of operation is to generate IEEE NaN and infinite values on overflow or invalid operations @@ -7074,13 +6619,13 @@ subscript), or a wild jump (from an out of range case value). Overflow checking is also quite expensive in time and space, since in general it requires the use of double length arithmetic. -Note again that the default is @option{-gnato00}, so overflow checking is -not performed in default mode. This means that out of the box, with the -default settings, @value{EDITION} does not do all the checks expected from the -language description in the Ada Reference Manual. If you want all constraint -checks to be performed, as described in this Manual, then you must -explicitly use the @option{-gnato??} switch either on the @command{gnatmake} or -@command{gcc} command. +Note again that the default is @option{^-gnato00^/OVERFLOW_CHECKS=00^}, +so overflow checking is not performed in default mode. This means that out of +the box, with the default settings, @value{EDITION} does not do all the checks +expected from the language description in the Ada Reference Manual. +If you want all constraint checks to be performed, as described in this Manual, +then you must explicitly use the @option{-gnato??} +switch either on the @command{gnatmake} or @command{gcc} command. @item -gnatE @cindex @option{-gnatE} (@command{gcc}) @@ -7091,7 +6636,7 @@ on subprogram calls and generic instantiations. Note that @option{-gnatE} is not necessary for safety, because in the default mode, GNAT ensures statically that the checks would not fail. For full details of the effect and use of this switch, -@xref{Compiling Using gcc}. +@xref{Compiling with gcc}. @item -fstack-check @cindex @option{-fstack-check} (@command{gcc}) @@ -7160,7 +6705,7 @@ Normally, GNAT allows only a single unit in a source file. However, this restriction does not apply in syntax-check-only mode, and it is possible to check a file containing multiple compilation units concatenated together. This is primarily used by the @code{gnatchop} utility -(@pxref{Renaming Files Using gnatchop}). +(@pxref{Renaming Files with gnatchop}). @end table @node Using gcc for Semantic Checking @@ -7211,8 +6756,8 @@ and specifications where a separate body is present). @noindent The switches described in this section allow you to explicitly specify the version of the Ada language that your programs are written in. -By default @value{EDITION} assumes @value{DEFAULTLANGUAGEVERSION}, -but you can also specify @value{NONDEFAULTLANGUAGEVERSION} or +The default mode is Ada 2012, +but you can also specify Ada 95, Ada 2005 mode, or indicate Ada 83 compatibility mode. @table @option @@ -7280,13 +6825,6 @@ may generally be compiled using this switch (see the description of the @option{-gnat83} and @option{-gnat95} switches for further information). -@ifset PROEDITION -Note that even though Ada 2005 is the current official version of the -language, GNAT still compiles in Ada 95 mode by default, so if you are -using Ada 2005 features in your program, you must use this switch (or -the equivalent Ada_05 or Ada_2005 configuration pragmas). -@end ifset - @item -gnat12 or -gnat2012 (Ada 2012 mode) @cindex @option{-gnat12} (@command{gcc}) @cindex @option{-gnat2012} (@command{gcc}) @@ -7294,7 +6832,7 @@ the equivalent Ada_05 or Ada_2005 configuration pragmas). @noindent This switch directs the compiler to implement the Ada 2012 version of the -language. +language (also the default). Since Ada 2012 is almost completely upwards compatible with Ada 2005 (and thus also with Ada 83, and Ada 95), Ada 83 and Ada 95 programs @@ -7302,11 +6840,6 @@ may generally be compiled using this switch (see the description of the @option{-gnat83}, @option{-gnat95}, and @option{-gnat05/2005} switches for further information). -For information about the approved ``Ada Issues'' that have been incorporated -into Ada 2012, see @url{http://www.ada-auth.org/ais.html}. -Included with GNAT releases is a file @file{features-ada12} that describes -the set of implemented Ada 2012 features. - @item -gnatX (Enable GNAT Extensions) @cindex @option{-gnatX} (@command{gcc}) @cindex Ada language extensions @@ -7935,7 +7468,7 @@ preprocessing. @noindent The actual preprocessing function is described in details in section -@ref{Preprocessing Using gnatprep}. This section only describes how integrated +@ref{Preprocessing with gnatprep}. This section only describes how integrated preprocessing is triggered and parameterized. @table @code @@ -7945,7 +7478,7 @@ preprocessing is triggered and parameterized. This switch indicates to the compiler the file name (without directory information) of the preprocessor data file to use. The preprocessor data file should be found in the source directories. Note that when the compiler is -called by a builder (@command{gnatmake} or @command{gprbuild}) with a project +called by a builder such as (@command{gnatmake} with a project file, if the object directory is not also a source directory, the builder needs to be called with @option{-x}. @@ -8283,8 +7816,8 @@ Compile the subunit in file @file{abc-def.adb} in semantic-checking-only mode. @end table -@node Binding Using gnatbind -@chapter Binding Using @code{gnatbind} +@node Binding with gnatbind +@chapter Binding with @code{gnatbind} @findex gnatbind @menu @@ -9279,8 +8812,8 @@ since gnatlink will not be able to find the generated file. @end table @c ------------------------------------ -@node Linking Using gnatlink -@chapter Linking Using @command{gnatlink} +@node Linking with gnatlink +@chapter Linking with @command{gnatlink} @c ------------------------------------ @findex gnatlink @@ -9897,12 +9430,13 @@ object and ALI files in the directory where it found the dummy file. @item ^-j^/PROCESSES=^@var{n} @cindex @option{^-j^/PROCESSES^} (@command{gnatmake}) @cindex Parallel make -Use @var{n} processes to carry out the (re)compilations. On a -multiprocessor machine compilations will occur in parallel. In the -event of compilation errors, messages from various compilations might -get interspersed (but @command{gnatmake} will give you the full ordered -list of failing compiles at the end). If this is problematic, rerun -the make process with n set to 1 to get a clean list of messages. +Use @var{n} processes to carry out the (re)compilations. On a multiprocessor +machine compilations will occur in parallel. If @var{n} is 0, then the +maximum number of parallel compilations is the number of core processors +on the platform. In the event of compilation errors, messages from various +compilations might get interspersed (but @command{gnatmake} will give you the +full ordered list of failing compiles at the end). If this is problematic, +rerun the make process with n set to 1 to get a clean list of messages. @item ^-k^/CONTINUE_ON_ERROR^ @cindex @option{^-k^/CONTINUE_ON_ERROR^} (@command{gnatmake}) @@ -11358,6 +10892,14 @@ Ada 2005 mode etc. @table @option @c !sort! +@item --version +@cindex @option{--version} @command{gnatelim} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatelim} +Display usage, then exit disregarding all other options. + @item ^-files^/FILES^=@var{filename} @cindex @option{^-files^/FILES^} (@code{gnatelim}) Take the argument source files from the specified file. This file should be an @@ -11636,8 +11178,8 @@ It can be observed that the procedure @code{Unused} and the object appropriate options. @c ******************************** -@node Renaming Files Using gnatchop -@chapter Renaming Files Using @code{gnatchop} +@node Renaming Files with gnatchop +@chapter Renaming Files with @code{gnatchop} @findex gnatchop @noindent @@ -11994,6 +11536,11 @@ unit will be skipped. @cindex Configuration pragmas @cindex Pragmas, configuration +@menu +* Handling of Configuration Pragmas:: +* The Configuration Pragmas Files:: +@end menu + @noindent Configuration pragmas include those pragmas described as such in the Ada Reference Manual, as well as @@ -12070,14 +11617,8 @@ recognized by GNAT: Validity_Checks Warnings Wide_Character_Encoding - @end smallexample -@menu -* Handling of Configuration Pragmas:: -* The Configuration Pragmas Files:: -@end menu - @node Handling of Configuration Pragmas @section Handling of Configuration Pragmas @@ -12166,8 +11707,8 @@ predefined package SYSTEM all the additional types and subprograms that are defined in HP Ada. See @ref{Compatibility with HP Ada} for details. @end ifset -@node Handling Arbitrary File Naming Conventions Using gnatname -@chapter Handling Arbitrary File Naming Conventions Using @code{gnatname} +@node Handling Arbitrary File Naming Conventions with gnatname +@chapter Handling Arbitrary File Naming Conventions with @code{gnatname} @cindex Arbitrary File Naming Conventions @menu @@ -12283,6 +11824,13 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. +@item --subdirs=<dir> +Real object, library or exec directories are subdirectories <dir> of the +specified ones. + +@item --no-backup +Do not create a backup copy of an existing project file. + @item --and Start another section of directories/patterns. @@ -12303,6 +11851,9 @@ specified, no switch @option{^-P^/PROJECT_FILE^} may be specified (see below). @cindex @option{^-d^/SOURCE_DIRS^} (@code{gnatname}) Look for source files in directory @file{dir}. There may be zero, one or more spaces between @option{^-d^/SOURCE_DIRS=^} and @file{dir}. +@file{dir} may end with @code{/**}, that is it may be of the form +@code{root_dir/**}. In this case, the directory @code{root_dir} and all of its +subdirectories, recursively, have to be searched for sources. When a switch @option{^-d^/SOURCE_DIRS^} is specified, the current working directory will not be searched for source files, unless it is explicitly specified with a @option{^-d^/SOURCE_DIRS^} @@ -12329,6 +11880,9 @@ Specifying switch @option{^-D^/DIRS_FILE^} is equivalent to specifying as many switches @option{^-d^/SOURCE_DIRS^} as there are nonempty lines in @file{file}. +@item -eL +Follow symbolic links when processing project files. + @item ^-f^/FOREIGN_PATTERN=^@file{pattern} @cindex @option{^-f^/FOREIGN_PATTERN^} (@code{gnatname}) Foreign patterns. Using this switch, it is possible to add sources of languages @@ -12355,6 +11909,10 @@ information. @file{proj} must be writable. There may be only one switch @option{^-P^/PROJECT_FILE^}. When a switch @option{^-P^/PROJECT_FILE^} is specified, no switch @option{^-c^/CONFIG_FILE^} may be specified. +On all platforms, except on VMS, when @code{gnatname} is invoked for an +existing project file <proj>.gpr, a backup copy of the project file is created +in the project directory with file name <proj>.gpr.saved_x. 'x' is the first +non negative number that makes this backup copy a new file. @item ^-v^/VERBOSE^ @cindex @option{^-v^/VERBOSE^} (@code{gnatname}) @@ -12478,6 +12036,806 @@ are used in this example. @include projects.texi +@c --------------------------------------------- +@c Tools Supporting Project Files +@c --------------------------------------------- + +@node Tools Supporting Project Files +@chapter Tools Supporting Project Files + +@noindent + +@menu +* gnatmake and Project Files:: +* The GNAT Driver and Project Files:: +@end menu + +@c --------------------------------------------- +@node gnatmake and Project Files +@section gnatmake and Project Files +@c --------------------------------------------- + +@noindent +This section covers several topics related to @command{gnatmake} and +project files: defining ^switches^switches^ for @command{gnatmake} +and for the tools that it invokes; specifying configuration pragmas; +the use of the @code{Main} attribute; building and rebuilding library project +files. + +@menu +* Switches Related to Project Files:: +* Switches and Project Files:: +* Specifying Configuration Pragmas:: +* Project Files and Main Subprograms:: +* Library Project Files:: +@end menu + +@c --------------------------------------------- +@node Switches Related to Project Files +@subsection Switches Related to Project Files +@c --------------------------------------------- + +@noindent +The following switches are used by GNAT tools that support project files: + +@table @option + +@item ^-P^/PROJECT_FILE=^@var{project} +@cindex @option{^-P^/PROJECT_FILE^} (any project-aware tool) +Indicates the name of a project file. This project file will be parsed with +the verbosity indicated by @option{^-vP^MESSAGE_PROJECT_FILES=^@emph{x}}, +if any, and using the external references indicated +by @option{^-X^/EXTERNAL_REFERENCE^} switches, if any. +@ifclear vms +There may zero, one or more spaces between @option{-P} and @var{project}. +@end ifclear + +There must be only one @option{^-P^/PROJECT_FILE^} switch on the command line. + +Since the Project Manager parses the project file only after all the switches +on the command line are checked, the order of the switches +@option{^-P^/PROJECT_FILE^}, +@option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} +or @option{^-X^/EXTERNAL_REFERENCE^} is not significant. + +@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} +@cindex @option{^-X^/EXTERNAL_REFERENCE^} (any project-aware tool) +Indicates that external variable @var{name} has the value @var{value}. +The Project Manager will use this value for occurrences of +@code{external(name)} when parsing the project file. + +@ifclear vms +If @var{name} or @var{value} includes a space, then @var{name=value} should be +put between quotes. +@smallexample + -XOS=NT + -X"user=John Doe" +@end smallexample +@end ifclear + +Several @option{^-X^/EXTERNAL_REFERENCE^} switches can be used simultaneously. +If several @option{^-X^/EXTERNAL_REFERENCE^} switches specify the same +@var{name}, only the last one is used. + +An external variable specified with a @option{^-X^/EXTERNAL_REFERENCE^} switch +takes precedence over the value of the same name in the environment. + +@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} +@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (any project-aware tool) +Indicates the verbosity of the parsing of GNAT project files. + +@ifclear vms +@option{-vP0} means Default; +@option{-vP1} means Medium; +@option{-vP2} means High. +@end ifclear + +@ifset vms +There are three possible options for this qualifier: DEFAULT, MEDIUM and +HIGH. +@end ifset + +The default is ^Default^DEFAULT^: no output for syntactically correct +project files. +If several @option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} switches are present, +only the last one is used. + +@item ^-aP^/ADD_PROJECT_SEARCH_DIR=^<dir> +@cindex @option{^-aP^/ADD_PROJECT_SEARCH_DIR=^} (any project-aware tool) +Add directory <dir> at the beginning of the project search path, in order, +after the current working directory. + +@ifclear vms +@item -eL +@cindex @option{-eL} (any project-aware tool) +Follow all symbolic links when processing project files. +@end ifclear + +@item ^--subdirs^/SUBDIRS^=<subdir> +@cindex @option{^--subdirs^/SUBDIRS^=} (gnatmake and gnatclean) +This switch is recognized by @command{gnatmake} and @command{gnatclean}. It +indicate that the real directories (except the source directories) are the +subdirectories <subdir> of the directories specified in the project files. +This applies in particular to object directories, library directories and +exec directories. If the subdirectories do not exist, they are created +automatically. + +@end table + +@c --------------------------------------------- +@node Switches and Project Files +@subsection Switches and Project Files +@c --------------------------------------------- + +@noindent +@ifset vms +It is not currently possible to specify VMS style qualifiers in the project +files; only Unix style ^switches^switches^ may be specified. +@end ifset + +For each of the packages @code{Builder}, @code{Compiler}, @code{Binder}, and +@code{Linker}, you can specify a @code{^Default_Switches^Default_Switches^} +attribute, a @code{Switches} attribute, or both; +as their names imply, these ^switch^switch^-related +attributes affect the ^switches^switches^ that are used for each of these GNAT +components when +@command{gnatmake} is invoked. As will be explained below, these +component-specific ^switches^switches^ precede +the ^switches^switches^ provided on the @command{gnatmake} command line. + +The @code{^Default_Switches^Default_Switches^} attribute is an attribute +indexed by language name (case insensitive) whose value is a string list. +For example: + +@smallexample @c projectfile +@group +package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnaty^-gnaty^", + "^-v^-v^"); +end Compiler; +@end group +@end smallexample + +@noindent +The @code{Switches} attribute is indexed on a file name (which may or may +not be case sensitive, depending +on the operating system) whose value is a string list. For example: + +@smallexample @c projectfile +@group +package Builder is + for Switches ("main1.adb") + use ("^-O2^-O2^"); + for Switches ("main2.adb") + use ("^-g^-g^"); +end Builder; +@end group +@end smallexample + +@noindent +For the @code{Builder} package, the file names must designate source files +for main subprograms. For the @code{Binder} and @code{Linker} packages, the +file names must designate @file{ALI} or source files for main subprograms. +In each case just the file name without an explicit extension is acceptable. + +For each tool used in a program build (@command{gnatmake}, the compiler, the +binder, and the linker), the corresponding package @dfn{contributes} a set of +^switches^switches^ for each file on which the tool is invoked, based on the +^switch^switch^-related attributes defined in the package. +In particular, the ^switches^switches^ +that each of these packages contributes for a given file @var{f} comprise: + +@itemize @bullet +@item the value of attribute @code{Switches (@var{f})}, + if it is specified in the package for the given file, +@item otherwise, the value of @code{^Default_Switches^Default_Switches^ ("Ada")}, + if it is specified in the package. + +@end itemize + +@noindent +If neither of these attributes is defined in the package, then the package does +not contribute any ^switches^switches^ for the given file. + +When @command{gnatmake} is invoked on a file, the ^switches^switches^ comprise +two sets, in the following order: those contributed for the file +by the @code{Builder} package; +and the switches passed on the command line. + +When @command{gnatmake} invokes a tool (compiler, binder, linker) on a file, +the ^switches^switches^ passed to the tool comprise three sets, +in the following order: + +@enumerate +@item +the applicable ^switches^switches^ contributed for the file +by the @code{Builder} package in the project file supplied on the command line; + +@item +those contributed for the file by the package (in the relevant project file -- +see below) corresponding to the tool; and + +@item +the applicable switches passed on the command line. +@end enumerate + +The term @emph{applicable ^switches^switches^} reflects the fact that +@command{gnatmake} ^switches^switches^ may or may not be passed to individual +tools, depending on the individual ^switch^switch^. + +@command{gnatmake} may invoke the compiler on source files from different +projects. The Project Manager will use the appropriate project file to +determine the @code{Compiler} package for each source file being compiled. +Likewise for the @code{Binder} and @code{Linker} packages. + +As an example, consider the following package in a project file: + +@smallexample @c projectfile +@group +project Proj1 is + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-g^-g^"); + for Switches ("a.adb") + use ("^-O1^-O1^"); + for Switches ("b.adb") + use ("^-O2^-O2^", + "^-gnaty^-gnaty^"); + end Compiler; +end Proj1; +@end group +@end smallexample + +@noindent +If @command{gnatmake} is invoked with this project file, and it needs to +compile, say, the files @file{a.adb}, @file{b.adb}, and @file{c.adb}, then +@file{a.adb} will be compiled with the ^switch^switch^ +@option{^-O1^-O1^}, +@file{b.adb} with ^switches^switches^ +@option{^-O2^-O2^} +and @option{^-gnaty^-gnaty^}, +and @file{c.adb} with @option{^-g^-g^}. + +The following example illustrates the ordering of the ^switches^switches^ +contributed by different packages: + +@smallexample @c projectfile +@group +project Proj2 is + package Builder is + for Switches ("main.adb") + use ("^-g^-g^", + "^-O1^-)1^", + "^-f^-f^"); + end Builder; +@end group + +@group + package Compiler is + for Switches ("main.adb") + use ("^-O2^-O2^"); + end Compiler; +end Proj2; +@end group +@end smallexample + +@noindent +If you issue the command: + +@smallexample + gnatmake ^-Pproj2^/PROJECT_FILE=PROJ2^ -O0 main +@end smallexample + +@noindent +then the compiler will be invoked on @file{main.adb} with the following +sequence of ^switches^switches^ + +@smallexample + ^-g -O1 -O2 -O0^-g -O1 -O2 -O0^ +@end smallexample + +@noindent +with the last @option{^-O^-O^} +^switch^switch^ having precedence over the earlier ones; +several other ^switches^switches^ +(such as @option{^-c^-c^}) are added implicitly. + +The ^switches^switches^ +@option{^-g^-g^} +and @option{^-O1^-O1^} are contributed by package +@code{Builder}, @option{^-O2^-O2^} is contributed +by the package @code{Compiler} +and @option{^-O0^-O0^} comes from the command line. + +The @option{^-g^-g^} +^switch^switch^ will also be passed in the invocation of +@command{Gnatlink.} + +A final example illustrates switch contributions from packages in different +project files: + +@smallexample @c projectfile +@group +project Proj3 is + for Source_Files use ("pack.ads", "pack.adb"); + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnata^-gnata^"); + end Compiler; +end Proj3; +@end group + +@group +with "Proj3"; +project Proj4 is + for Source_Files use ("foo_main.adb", "bar_main.adb"); + package Builder is + for Switches ("foo_main.adb") + use ("^-s^-s^", + "^-g^-g^"); + end Builder; +end Proj4; +@end group + +@group +-- Ada source file: +with Pack; +procedure Foo_Main is + @dots{} +end Foo_Main; +@end group +@end smallexample + +@noindent +If the command is +@smallexample +gnatmake ^-PProj4^/PROJECT_FILE=PROJ4^ foo_main.adb -cargs -gnato +@end smallexample + +@noindent +then the ^switches^switches^ passed to the compiler for @file{foo_main.adb} are +@option{^-g^-g^} (contributed by the package @code{Proj4.Builder}) and +@option{^-gnato^-gnato^} (passed on the command line). +When the imported package @code{Pack} is compiled, the ^switches^switches^ used +are @option{^-g^-g^} from @code{Proj4.Builder}, +@option{^-gnata^-gnata^} (contributed from package @code{Proj3.Compiler}, +and @option{^-gnato^-gnato^} from the command line. + +When using @command{gnatmake} with project files, some ^switches^switches^ or +arguments may be expressed as relative paths. As the working directory where +compilation occurs may change, these relative paths are converted to absolute +paths. For the ^switches^switches^ found in a project file, the relative paths +are relative to the project file directory, for the switches on the command +line, they are relative to the directory where @command{gnatmake} is invoked. +The ^switches^switches^ for which this occurs are: +^-I^-I^, +^-A^-A^, +^-L^-L^, +^-aO^-aO^, +^-aL^-aL^, +^-aI^-aI^, as well as all arguments that are not switches (arguments to +^switch^switch^ +^-o^-o^, object files specified in package @code{Linker} or after +-largs on the command line). The exception to this rule is the ^switch^switch^ +^--RTS=^--RTS=^ for which a relative path argument is never converted. + +@c --------------------------------------------- +@node Specifying Configuration Pragmas +@subsection Specifying Configuration Pragmas +@c --------------------------------------------- + +@noindent +When using @command{gnatmake} with project files, if there exists a file +@file{gnat.adc} that contains configuration pragmas, this file will be +ignored. + +Configuration pragmas can be defined by means of the following attributes in +project files: @code{Global_Configuration_Pragmas} in package @code{Builder} +and @code{Local_Configuration_Pragmas} in package @code{Compiler}. + +Both these attributes are single string attributes. Their values is the path +name of a file containing configuration pragmas. If a path name is relative, +then it is relative to the project directory of the project file where the +attribute is defined. + +When compiling a source, the configuration pragmas used are, in order, +those listed in the file designated by attribute +@code{Global_Configuration_Pragmas} in package @code{Builder} of the main +project file, if it is specified, and those listed in the file designated by +attribute @code{Local_Configuration_Pragmas} in package @code{Compiler} of +the project file of the source, if it exists. + +@c --------------------------------------------- +@node Project Files and Main Subprograms +@subsection Project Files and Main Subprograms +@c --------------------------------------------- + +@noindent +When using a project file, you can invoke @command{gnatmake} +with one or several main subprograms, by specifying their source files on the +command line. + +@smallexample + gnatmake ^-P^/PROJECT_FILE=^prj main1.adb main2.adb main3.adb +@end smallexample + +@noindent +Each of these needs to be a source file of the same project, except +when the switch ^-u^/UNIQUE^ is used. + +When ^-u^/UNIQUE^ is not used, all the mains need to be sources of the +same project, one of the project in the tree rooted at the project specified +on the command line. The package @code{Builder} of this common project, the +"main project" is the one that is considered by @command{gnatmake}. + +When ^-u^/UNIQUE^ is used, the specified source files may be in projects +imported directly or indirectly by the project specified on the command line. +Note that if such a source file is not part of the project specified on the +command line, the ^switches^switches^ found in package @code{Builder} of the +project specified on the command line, if any, that are transmitted +to the compiler will still be used, not those found in the project file of +the source file. + +When using a project file, you can also invoke @command{gnatmake} without +explicitly specifying any main, and the effect depends on whether you have +defined the @code{Main} attribute. This attribute has a string list value, +where each element in the list is the name of a source file (the file +extension is optional) that contains a unit that can be a main subprogram. + +If the @code{Main} attribute is defined in a project file as a non-empty +string list and the switch @option{^-u^/UNIQUE^} is not used on the command +line, then invoking @command{gnatmake} with this project file but without any +main on the command line is equivalent to invoking @command{gnatmake} with all +the file names in the @code{Main} attribute on the command line. + +Example: +@smallexample @c projectfile +@group + project Prj is + for Main use ("main1.adb", "main2.adb", "main3.adb"); + end Prj; +@end group +@end smallexample + +@noindent +With this project file, @code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^"} +is equivalent to +@code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^ main1.adb main2.adb main3.adb"}. + +When the project attribute @code{Main} is not specified, or is specified +as an empty string list, or when the switch @option{-u} is used on the command +line, then invoking @command{gnatmake} with no main on the command line will +result in all immediate sources of the project file being checked, and +potentially recompiled. Depending on the presence of the switch @option{-u}, +sources from other project files on which the immediate sources of the main +project file depend are also checked and potentially recompiled. In other +words, the @option{-u} switch is applied to all of the immediate sources of the +main project file. + +When no main is specified on the command line and attribute @code{Main} exists +and includes several mains, or when several mains are specified on the +command line, the default ^switches^switches^ in package @code{Builder} will +be used for all mains, even if there are specific ^switches^switches^ +specified for one or several mains. + +But the ^switches^switches^ from package @code{Binder} or @code{Linker} will be +the specific ^switches^switches^ for each main, if they are specified. + +@c --------------------------------------------- +@node Library Project Files +@subsection Library Project Files +@c --------------------------------------------- + +@noindent +When @command{gnatmake} is invoked with a main project file that is a library +project file, it is not allowed to specify one or more mains on the command +line. + +When a library project file is specified, switches ^-b^/ACTION=BIND^ and +^-l^/ACTION=LINK^ have special meanings. + +@itemize @bullet +@item ^-b^/ACTION=BIND^ is only allowed for stand-alone libraries. It indicates + to @command{gnatmake} that @command{gnatbind} should be invoked for the + library. + +@item ^-l^/ACTION=LINK^ may be used for all library projects. It indicates + to @command{gnatmake} that the binder generated file should be compiled + (in the case of a stand-alone library) and that the library should be built. +@end itemize + +@c --------------------------------------------- +@node The GNAT Driver and Project Files +@section The GNAT Driver and Project Files +@c --------------------------------------------- + +@noindent +A number of GNAT tools, other than @command{^gnatmake^gnatmake^} +can benefit from project files: +(@command{^gnatbind^gnatbind^}, +@command{^gnatcheck^gnatcheck^}, +@command{^gnatclean^gnatclean^}, +@command{^gnatelim^gnatelim^}, +@command{^gnatfind^gnatfind^}, +@command{^gnatlink^gnatlink^}, +@command{^gnatls^gnatls^}, +@command{^gnatmetric^gnatmetric^}, +@command{^gnatpp^gnatpp^}, +@command{^gnatstub^gnatstub^}, +and @command{^gnatxref^gnatxref^}). However, none of these tools can be invoked +directly with a project file switch (@option{^-P^/PROJECT_FILE=^}). +They must be invoked through the @command{gnat} driver. + +The @command{gnat} driver is a wrapper that accepts a number of commands and +calls the corresponding tool. It was designed initially for VMS platforms (to +convert VMS qualifiers to Unix-style switches), but it is now available on all +GNAT platforms. + +On non-VMS platforms, the @command{gnat} driver accepts the following commands +(case insensitive): + +@itemize @bullet +@item BIND to invoke @command{^gnatbind^gnatbind^} +@item CHOP to invoke @command{^gnatchop^gnatchop^} +@item CLEAN to invoke @command{^gnatclean^gnatclean^} +@item COMP or COMPILE to invoke the compiler +@item ELIM to invoke @command{^gnatelim^gnatelim^} +@item FIND to invoke @command{^gnatfind^gnatfind^} +@item KR or KRUNCH to invoke @command{^gnatkr^gnatkr^} +@item LINK to invoke @command{^gnatlink^gnatlink^} +@item LS or LIST to invoke @command{^gnatls^gnatls^} +@item MAKE to invoke @command{^gnatmake^gnatmake^} +@item NAME to invoke @command{^gnatname^gnatname^} +@item PREP or PREPROCESS to invoke @command{^gnatprep^gnatprep^} +@item PP or PRETTY to invoke @command{^gnatpp^gnatpp^} +@item METRIC to invoke @command{^gnatmetric^gnatmetric^} +@item STUB to invoke @command{^gnatstub^gnatstub^} +@item XREF to invoke @command{^gnatxref^gnatxref^} + +@end itemize + +@noindent +(note that the compiler is invoked using the command +@command{^gnatmake -f -u -c^gnatmake -f -u -c^}). + +On non-VMS platforms, between @command{gnat} and the command, two +special switches may be used: + +@itemize @bullet +@item @command{-v} to display the invocation of the tool. +@item @command{-dn} to prevent the @command{gnat} driver from removing + the temporary files it has created. These temporary files are + configuration files and temporary file list files. + +@end itemize + +@noindent +The command may be followed by switches and arguments for the invoked +tool. + +@smallexample + gnat bind -C main.ali + gnat ls -a main + gnat chop foo.txt +@end smallexample + +@noindent +Switches may also be put in text files, one switch per line, and the text +files may be specified with their path name preceded by '@@'. + +@smallexample + gnat bind @@args.txt main.ali +@end smallexample + +@noindent +In addition, for commands BIND, COMP or COMPILE, FIND, ELIM, LS or LIST, LINK, +METRIC, PP or PRETTY, STUB and XREF, the project file related switches +(@option{^-P^/PROJECT_FILE^}, +@option{^-X^/EXTERNAL_REFERENCE^} and +@option{^-vP^/MESSAGES_PROJECT_FILE=^x}) may be used in addition to +the switches of the invoking tool. + +When GNAT PP or GNAT PRETTY is used with a project file, but with no source +specified on the command line, it invokes @command{^gnatpp^gnatpp^} with all +the immediate sources of the specified project file. + +When GNAT METRIC is used with a project file, but with no source +specified on the command line, it invokes @command{^gnatmetric^gnatmetric^} +with all the immediate sources of the specified project file and with +@option{^-d^/DIRECTORY^} with the parameter pointing to the object directory +of the project. + +In addition, when GNAT PP, GNAT PRETTY or GNAT METRIC is used with +a project file, no source is specified on the command line and +switch ^-U^/ALL_PROJECTS^ is specified on the command line, then +the underlying tool (^gnatpp^gnatpp^ or +^gnatmetric^gnatmetric^) is invoked for all sources of all projects, +not only for the immediate sources of the main project. +@ifclear vms +(-U stands for Universal or Union of the project files of the project tree) +@end ifclear + +For each of the following commands, there is optionally a corresponding +package in the main project. + +@itemize @bullet +@item package @code{Binder} for command BIND (invoking @code{^gnatbind^gnatbind^}) + +@item package @code{Check} for command CHECK (invoking + @code{^gnatcheck^gnatcheck^}) + +@item package @code{Compiler} for command COMP or COMPILE (invoking the compiler) + +@item package @code{Cross_Reference} for command XREF (invoking + @code{^gnatxref^gnatxref^}) + +@item package @code{Eliminate} for command ELIM (invoking + @code{^gnatelim^gnatelim^}) + +@item package @code{Finder} for command FIND (invoking @code{^gnatfind^gnatfind^}) + +@item package @code{Gnatls} for command LS or LIST (invoking @code{^gnatls^gnatls^}) + +@item package @code{Gnatstub} for command STUB + (invoking @code{^gnatstub^gnatstub^}) + +@item package @code{Linker} for command LINK (invoking @code{^gnatlink^gnatlink^}) + +@item package @code{Check} for command CHECK + (invoking @code{^gnatcheck^gnatcheck^}) + +@item package @code{Metrics} for command METRIC + (invoking @code{^gnatmetric^gnatmetric^}) + +@item package @code{Pretty_Printer} for command PP or PRETTY + (invoking @code{^gnatpp^gnatpp^}) + +@end itemize + +@noindent +Package @code{Gnatls} has a unique attribute @code{Switches}, +a simple variable with a string list value. It contains ^switches^switches^ +for the invocation of @code{^gnatls^gnatls^}. + +@smallexample @c projectfile +@group +project Proj1 is + package gnatls is + for Switches + use ("^-a^-a^", + "^-v^-v^"); + end gnatls; +end Proj1; +@end group +@end smallexample + +@noindent +All other packages have two attribute @code{Switches} and +@code{^Default_Switches^Default_Switches^}. + +@code{Switches} is an indexed attribute, indexed by the +source file name, that has a string list value: the ^switches^switches^ to be +used when the tool corresponding to the package is invoked for the specific +source file. + +@code{^Default_Switches^Default_Switches^} is an attribute, +indexed by the programming language that has a string list value. +@code{^Default_Switches^Default_Switches^ ("Ada")} contains the +^switches^switches^ for the invocation of the tool corresponding +to the package, except if a specific @code{Switches} attribute +is specified for the source file. + +@smallexample @c projectfile +@group +project Proj is + + for Source_Dirs use ("**"); + + package gnatls is + for Switches use + ("^-a^-a^", + "^-v^-v^"); + end gnatls; +@end group +@group + + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnatv^-gnatv^", + "^-gnatwa^-gnatwa^"); + end Binder; +@end group +@group + + package Binder is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-C^-C^", + "^-e^-e^"); + end Binder; +@end group +@group + + package Linker is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-C^-C^"); + for Switches ("main.adb") + use ("^-C^-C^", + "^-v^-v^", + "^-v^-v^"); + end Linker; +@end group +@group + + package Finder is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-a^-a^", + "^-f^-f^"); + end Finder; +@end group +@group + + package Cross_Reference is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-a^-a^", + "^-f^-f^", + "^-d^-d^", + "^-u^-u^"); + end Cross_Reference; +end Proj; +@end group +@end smallexample + +@noindent +With the above project file, commands such as + +@smallexample + ^gnat comp -Pproj main^GNAT COMP /PROJECT_FILE=PROJ MAIN^ + ^gnat ls -Pproj main^GNAT LIST /PROJECT_FILE=PROJ MAIN^ + ^gnat xref -Pproj main^GNAT XREF /PROJECT_FILE=PROJ MAIN^ + ^gnat bind -Pproj main.ali^GNAT BIND /PROJECT_FILE=PROJ MAIN.ALI^ + ^gnat link -Pproj main.ali^GNAT LINK /PROJECT_FILE=PROJ MAIN.ALI^ +@end smallexample + +@noindent +will set up the environment properly and invoke the tool with the switches +found in the package corresponding to the tool: +@code{^Default_Switches^Default_Switches^ ("Ada")} for all tools, +except @code{Switches ("main.adb")} +for @code{^gnatlink^gnatlink^}. +It is also possible to invoke some of the tools, +(@code{^gnatcheck^gnatcheck^}, +@code{^gnatmetric^gnatmetric^}, +and @code{^gnatpp^gnatpp^}) +on a set of project units thanks to the combination of the switches +@option{-P}, @option{-U} and possibly the main unit when one is interested +in its closure. For instance, +@smallexample +gnat metric -Pproj +@end smallexample + +@noindent +will compute the metrics for all the immediate units of project +@code{proj}. +@smallexample +gnat metric -Pproj -U +@end smallexample + +@noindent +will compute the metrics for all the units of the closure of projects +rooted at @code{proj}. +@smallexample +gnat metric -Pproj -U main_unit +@end smallexample + +@noindent +will compute the metrics for the closure of units rooted at +@code{main_unit}. This last possibility relies implicitly +on @command{gnatbind}'s option @option{-R}. But if the argument files for the +tool invoked by the @command{gnat} driver are explicitly specified +either directly or through the tool @option{-files} option, then the tool +is called only for these explicitly specified files. + @c ***************************************** @c * Cross-referencing tools @c ***************************************** @@ -13226,6 +13584,11 @@ point to any character in the middle of the identifier. @findex gnatpp @cindex Pretty-Printer +@menu +* Switches for gnatpp:: +* Formatting Rules:: +@end menu + @noindent ^The @command{gnatpp} tool^GNAT PRETTY^ is an ASIS-based utility for source reformatting / pretty-printing. @@ -13286,11 +13649,6 @@ use the @option{-gnat05} switch if sources should be compiled in Ada 2005 mode etc. @end itemize -@menu -* Switches for gnatpp:: -* Formatting Rules:: -@end menu - @node Switches for gnatpp @section Switches for @command{gnatpp} @@ -13839,6 +14197,14 @@ with @option{^-pipe^/STANDARD_OUTPUT^} option. The additional @command{gnatpp} switches are defined in this subsection. @table @option +@item --version +@cindex @option{--version} @command{gnatpp} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatpp} +Display usage, then exit disregarding all other options. + @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 @@ -14396,8 +14762,8 @@ end Test; @end smallexample @c ********************************* -@node The GNAT Metric Tool gnatmetric -@chapter The GNAT Metric Tool @command{gnatmetric} +@node The GNAT Metrics Tool gnatmetric +@chapter The GNAT Metrics Tool @command{gnatmetric} @findex gnatmetric @cindex Metric tool @@ -14408,6 +14774,10 @@ It takes an Ada source file as input and generates a file containing the metrics data as output. Various switches control which metrics are computed and output. +@menu +* Switches for gnatmetric:: +@end menu + @command{gnatmetric} generates and uses the ASIS tree for the input source and thus requires the input to be syntactically and semantically legal. @@ -14460,10 +14830,6 @@ use the @option{-gnat05} switch if sources should be compiled in Ada 2005 mode etc. @end itemize -@menu -* Switches for gnatmetric:: -@end menu - @node Switches for gnatmetric @section Switches for @command{gnatmetric} @@ -15289,6 +15655,14 @@ Report control fan-in coupling Additional @command{gnatmetric} switches are as follows: @table @option +@item --version +@cindex @option{--version} @command{gnatmetric} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatmetric} +Display usage, then exit disregarding all other options. + @item ^-files @var{filename}^/FILES=@var{filename}^ @cindex @option{^-files^/FILES^} (@code{gnatmetric}) Take the argument source files from the specified file. This file should be an @@ -15335,8 +15709,8 @@ the @option{-U} option followed by the name of the main unit: @c *********************************** -@node File Name Krunching Using gnatkr -@chapter File Name Krunching Using @code{gnatkr} +@node File Name Krunching with gnatkr +@chapter File Name Krunching with @code{gnatkr} @findex gnatkr @noindent @@ -15551,8 +15925,8 @@ $ gnatkr very_long_unit_name.ads/count=6 --> vlunna.ads $ gnatkr very_long_unit_name.ads/count=0 --> very_long_unit_name.ads @end smallexample -@node Preprocessing Using gnatprep -@chapter Preprocessing Using @code{gnatprep} +@node Preprocessing with gnatprep +@chapter Preprocessing with @code{gnatprep} @findex gnatprep @noindent @@ -16001,6 +16375,10 @@ Several such switches may be specified simultaneously. Source path manipulation. Same meaning as the equivalent @command{gnatmake} flags (@pxref{Switches for gnatmake}). +@item ^-aP^/ADD_PROJECT_SEARCH_DIR=^@var{dir} +@cindex @option{^-aP^/ADD_PROJECT_SEARCH_DIR=^} (@code{gnatls}) +Add @var{dir} at the beginning of the project search dir. + @item --RTS=@var{rts-path} @cindex @option{--RTS} (@code{gnatls}) Specifies the default location of the runtime library. Same meaning as the @@ -16148,8 +16526,8 @@ GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]unchconv.ads @end smallexample @end ifset -@node Cleaning Up Using gnatclean -@chapter Cleaning Up Using @code{gnatclean} +@node Cleaning Up with gnatclean +@chapter Cleaning Up with @code{gnatclean} @findex gnatclean @cindex Cleaning tool @@ -16716,6 +17094,7 @@ build an encapsulated library the attribute @group for Library_Dir use "lib_dir"; for Library_Name use "dummy"; + for Library_Kind use "dynamic"; for Library_Interface use ("int1", "int1.child"); for Library_Standalone use "encapsulated"; @end group @@ -18002,8 +18381,8 @@ stack usage reports at run-time. See its body for the details. @c ********************************* @c * GNATCHECK * @c ********************************* -@node Verifying Properties Using gnatcheck -@chapter Verifying Properties Using @command{gnatcheck} +@node Verifying Properties with gnatcheck +@chapter Verifying Properties with @command{gnatcheck} @findex gnatcheck @cindex @command{gnatcheck} @@ -18024,8 +18403,8 @@ For full details, refer to @cite{GNATcheck Reference Manual} document. @c ********************************* -@node Creating Sample Bodies Using gnatstub -@chapter Creating Sample Bodies Using @command{gnatstub} +@node Creating Sample Bodies with gnatstub +@chapter Creating Sample Bodies with @command{gnatstub} @findex gnatstub @noindent @@ -18107,6 +18486,14 @@ is an optional sequence of switches as described in the next section @table @option @c !sort! +@item --version +@cindex @option{--version} @command{gnatstub} +Display Copyright and version, then exit disregarding all other options. + +@item --help +@cindex @option{--help} @command{gnatstub} +Display usage, then exit disregarding all other options. + @item ^-f^/FULL^ @cindex @option{^-f^/FULL^} (@command{gnatstub}) If the destination directory already contains a file with the name of the @@ -18165,7 +18552,7 @@ the generated body sample to @var{n}. The default indentation is 3. @item ^-gnatyo^/ORDERED_SUBPROGRAMS^ -@cindex @option{^-gnato^/ORDERED_SUBPROGRAMS^} (@command{gnatstub}) +@cindex @option{^-gnatyo^/ORDERED_SUBPROGRAMS^} (@command{gnatstub}) Order local bodies alphabetically. (By default local bodies are ordered in the same way as the corresponding local specs in the argument spec file.) @@ -18233,8 +18620,8 @@ Verbose mode: generate version information. @end table @c ********************************* -@node Creating Unit Tests Using gnattest -@chapter Creating Unit Tests Using @command{gnattest} +@node Creating Unit Tests with gnattest +@chapter Creating Unit Tests with @command{gnattest} @findex gnattest @noindent @@ -18505,8 +18892,8 @@ $ gnattest --harness-dir=driver -Psimple.gpr a test driver is created in directory "driver". It can be compiled and run: @smallexample -$ cd driver -$ gprbuild -Ptest_driver +$ cd obj/driver +$ gnatmake -Ptest_driver $ test_runner @end smallexample @@ -18571,8 +18958,8 @@ and body of function Dec in simple.ads and simple.adb, running @smallexample gnattest --harness-dir=driver -Psimple.gpr -cd driver -gprbuild -Ptest_driver +cd obj/driver +gnatmake -Ptest_driver test_runner @end smallexample @@ -18667,8 +19054,8 @@ seen by running the test driver generated for the second example. As previously mentioned, actual tests are already written for this example. @smallexample -cd driver -gprbuild -Ptest_driver +cd obj/driver +gnatmake -Ptest_driver test_runner @end smallexample @@ -18709,8 +19096,8 @@ of the type which have overriding primitives: @smallexample gnattest --harness-dir=driver --validate-type-extensions -Ptagged_rec.gpr -cd driver -gprbuild -Ptest_driver +cd obj/driver +gnatmake -Ptest_driver test_runner @end smallexample @@ -18758,8 +19145,8 @@ Assert (Sqrt (-5.0) = -1.0, "wrong error indication"); are acceptable: @smallexample -cd driver -gprbuild -Ptest_driver +cd obj/driver +gnatmake -Ptest_driver test_runner @end smallexample @@ -18855,7 +19242,7 @@ familiar to engineering practice. The dimensions of algebraic expressions This feature depends on Ada 2012 aspect specifications, and is available from version 7.0.1 of GNAT onwards. The GNAT-specific aspect Dimension_System allows -the user to define a system of units; the aspect Dimension then allows the user +you to define a system of units; the aspect Dimension then allows the user to declare dimensioned quantities within a given system. The major advantage of this model is that it does not require the declaration of @@ -18888,9 +19275,7 @@ conventional units. For example: @smallexample @c ada subtype Length is Mks_Type with - Dimension => (Symbol => 'm', - Meter => 1, - others => 0); + Dimension => (Symbol => 'm', Meter => 1, others => 0); @end smallexample @noindent and similarly for Mass, Time, Electric_Current, Thermodynamic_Temperature, @@ -18919,13 +19304,17 @@ as well as useful multiples of these units: @end smallexample @noindent -The user can then define a derived unit by providing the aspect that +Using this package, you can then define a derived unit by +providing the aspect that specifies its dimensions within the MKS system, as well as the string to be used for output of a value of that unit: @smallexample @c ada subtype Acceleration is Mks_Type - with Dimension => ("m/sec^^^2", Meter => 1, Second => -2, others => 0); + with Dimension => ("m/sec^^^2", + Meter => 1, + Second => -2, + others => 0); @end smallexample @noindent @@ -19528,12 +19917,12 @@ This chapter describes how to use @code{gcov} - coverage testing tool - and @code{gprof} - profiler tool - on your Ada programs. @menu -* Code Coverage of Ada Programs using gcov:: -* Profiling an Ada Program using gprof:: +* Code Coverage of Ada Programs with gcov:: +* Profiling an Ada Program with gprof:: @end menu -@node Code Coverage of Ada Programs using gcov -@section Code Coverage of Ada Programs using gcov +@node Code Coverage of Ada Programs with gcov +@section Code Coverage of Ada Programs with gcov @cindex gcov @cindex -fprofile-arcs @cindex -ftest-coverage @@ -19620,8 +20009,8 @@ text file, and provide this file to gcov as a parameter, preceded by a @@ Note that on AIX compiling a static library with @code{-fprofile-arcs} is not supported as there can be unresolved symbols during the final link. -@node Profiling an Ada Program using gprof -@section Profiling an Ada Program using gprof +@node Profiling an Ada Program with gprof +@section Profiling an Ada Program with gprof @cindex gprof @cindex -pg @cindex Profiling @@ -19846,7 +20235,7 @@ the incorrect user program. * Ada Exceptions:: * Ada Tasks:: * Debugging Generic Units:: -* Remote Debugging using gdbserver:: +* Remote Debugging with gdbserver:: * GNAT Abnormal Termination or Failure to Terminate:: * Naming Conventions for GNAT Source Files:: * Getting Internal Debugging Information:: @@ -20304,9 +20693,9 @@ When the breakpoint occurs, you can step through the code of the instance in the normal manner and examine the values of local variables, as for other units. -@node Remote Debugging using gdbserver -@section Remote Debugging using gdbserver -@cindex Remote Debugging using gdbserver +@node Remote Debugging with gdbserver +@section Remote Debugging with gdbserver +@cindex Remote Debugging with gdbserver @noindent On platforms where gdbserver is supported, it is possible to use this tool @@ -25962,10 +26351,11 @@ eliminate intermediate overflows (@code{ELIMINATED}) As with the pragma, if only one digit appears then it applies to all cases; if two digits are given, then the first applies outside assertions, and the second within assertions. Thus the equivalent -of the example pragma above would be @option{-gnato23}. +of the example pragma above would be +@option{^-gnato23^/OVERFLOW_CHECKS=23^}. If no digits follow the @option{-gnato}, then it is equivalent to -@option{-gnato11}, +@option{^-gnato11^/OVERFLOW_CHECKS=11^}, causing all intermediate operations to be computed using the base type (@code{STRICT} mode). @@ -26496,7 +26886,7 @@ The preprocessor may be used in two separate modes. It can be used quite separately from the compiler, to generate a separate output source file that is then fed to the compiler as a separate step. This is the @code{gnatprep} utility, whose use is fully described in -@ref{Preprocessing Using gnatprep}. +@ref{Preprocessing with gnatprep}. @cindex @code{gnatprep} The preprocessing language allows such constructs as @@ -28252,7 +28642,6 @@ without sacrificing the capabilities of the 64-bit architecture. @end ifset @c ************************************************ -@ifset unw @node Microsoft Windows Topics @appendix Microsoft Windows Topics @cindex Windows NT @@ -28264,6 +28653,9 @@ This chapter describes topics that are specific to the Microsoft Windows platforms (NT, 2000, and XP Professional). @menu +@ifclear FSFEDITION +* Installing from the Command Line:: +@end ifclear * Using GNAT on Windows:: * Using a network installation of GNAT:: * CONSOLE and WINDOWS subsystems:: @@ -28281,6 +28673,54 @@ platforms (NT, 2000, and XP Professional). * Setting Heap Size from gnatlink:: @end menu +@ifclear FSFEDITION +@node Installing from the Command Line +@section Installing from the Command Line +@cindex Batch installation +@cindex Silent installation +@cindex Unassisted installation + +@noindent +By default the @value{EDITION} installers display a GUI that prompts the user +to enter installation path and similar information, and guide him through the +installation process. It is also possible to perform silent installations +using the command-line interface. + +In order to install one of the @value{EDITION} installers from the command +line you should pass parameter @code{/S} (and, optionally, +@code{/D=<directory>}) as command-line arguments. + +@ifset PROEDITION +For example, for an unattended installation of +@value{EDITION} 7.0.2 into the default directory +@code{C:\GNATPRO\7.0.2} you would run: + +@smallexample +gnatpro-7.0.2-i686-pc-mingw32-bin.exe /S +@end smallexample + +To install into a custom directory, say, @code{C:\TOOLS\GNATPRO\7.0.2}: + +@smallexample +gnatpro-7.0.2-i686-pc-mingw32-bin /S /D=C:\TOOLS\GNATPRO\7.0.2 +@end smallexample +@end ifset + +@ifset GPLEDITION +For example, for an unattended installation of +@value{EDITION} 2012 into @code{C:\GNAT\2012}: + +@smallexample +gnat-gpl-2012-i686-pc-mingw32-bin /S /D=C:\GNAT\2012 +@end smallexample +@end ifset + +You can use the same syntax for all installers. + +Note that unattended installations don't modify system path, nor create file +associations, so such activities need to be done by hand. +@end ifclear + @node Using GNAT on Windows @section Using GNAT on Windows @@ -28864,12 +29304,6 @@ end API; @end group @end smallexample -@noindent -Note that a variable is -@strong{always imported with a DLL convention}. A function -can have @code{C} or @code{Stdcall} convention. -(@pxref{Windows Calling Conventions}). - @node Creating an Import Library @subsection Creating an Import Library @cindex Import library @@ -30321,15 +30755,13 @@ codesign -f -s "gdb-cert" <gnat_install_prefix>/bin/gdb name chosen above, and <gnat_install_prefix> should be replaced by the location where you installed GNAT. -@end ifset - @c ********************************** @c * GNU Free Documentation License * @c ********************************** @include fdl.texi @c GNU Free Documentation License -@node Index,,GNU Free Documentation License, Top +@node Index @unnumbered Index @printindex cp diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index c53d67ecf5c..52591c46b07 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.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- -- @@ -73,7 +73,6 @@ procedure Gnatbind is -- Standard library Text : Text_Buffer_Ptr; - Next_Arg : Positive; Output_File_Name_Seen : Boolean := False; Output_File_Name : String_Ptr := new String'(""); @@ -104,6 +103,15 @@ procedure Gnatbind is -- All the one character arguments are still handled by Switch. This -- routine handles -aO -aI and -I-. The lower bound of Argv must be 1. + generic + with procedure Action (Argv : String); + procedure Generic_Scan_Bind_Args; + -- Iterate through the args calling Action on each one, taking care of + -- response files. + + procedure Write_Arg (S : String); + -- Passed to Generic_Scan_Bind_Args to print args + function Is_Cross_Compiler return Boolean; -- Returns True iff this is a cross-compiler @@ -143,7 +151,7 @@ procedure Gnatbind is -- should not be listed. No_Restriction_List : constant array (All_Restrictions) of Boolean := - (No_Allocators_After_Elaboration => True, + (No_Standard_Allocators_After_Elaboration => True, -- This involves run-time conditions not checkable at compile time No_Anonymous_Allocators => True, @@ -176,6 +184,18 @@ procedure Gnatbind is Max_Storage_At_Blocking => True, -- Not checkable at compile time + -- The following three should not be partition-wide, so the + -- following tests are junk to be removed eventually ??? + + No_Specification_Of_Aspect => True, + -- Requires a parameter value, not a count + + No_Use_Of_Attribute => True, + -- Requires a parameter value, not a count + + No_Use_Of_Pragma => True, + -- Requires a parameter value, not a count + others => False); Additional_Restrictions_Listed : Boolean := False; @@ -468,6 +488,62 @@ procedure Gnatbind is end if; end Scan_Bind_Arg; + ---------------------------- + -- Generic_Scan_Bind_Args -- + ---------------------------- + + procedure Generic_Scan_Bind_Args is + Next_Arg : Positive := 1; + + begin + -- Use low level argument routines to avoid dragging in secondary stack + + while Next_Arg < Arg_Count loop + declare + Next_Argv : String (1 .. Len_Arg (Next_Arg)); + + begin + Fill_Arg (Next_Argv'Address, Next_Arg); + + if Next_Argv'Length > 0 then + if Next_Argv (1) = '@' then + if Next_Argv'Length > 1 then + declare + Arguments : constant Argument_List := + Response_File.Arguments_From + (Response_File_Name => + Next_Argv (2 .. Next_Argv'Last), + Recursive => True, + Ignore_Non_Existing_Files => True); + begin + for J in Arguments'Range loop + Action (Arguments (J).all); + end loop; + end; + end if; + + else + Action (Next_Argv); + end if; + end if; + end; + + Next_Arg := Next_Arg + 1; + end loop; + end Generic_Scan_Bind_Args; + + --------------- + -- Write_Arg -- + --------------- + + procedure Write_Arg (S : String) is + begin + Write_Str (" " & S); + end Write_Arg; + + procedure Scan_Bind_Args is new Generic_Scan_Bind_Args (Scan_Bind_Arg); + procedure Put_Bind_Args is new Generic_Scan_Bind_Args (Write_Arg); + procedure Check_Version_And_Help is new Check_Version_And_Help_G (Bindusg.Display); @@ -498,40 +574,16 @@ begin Check_Version_And_Help ("GNATBIND", "1995"); - -- Use low level argument routines to avoid dragging in the secondary stack - - Next_Arg := 1; - Scan_Args : while Next_Arg < Arg_Count loop - declare - Next_Argv : String (1 .. Len_Arg (Next_Arg)); - begin - Fill_Arg (Next_Argv'Address, Next_Arg); - - if Next_Argv'Length > 0 then - if Next_Argv (1) = '@' then - if Next_Argv'Length > 1 then - declare - Arguments : constant Argument_List := - Response_File.Arguments_From - (Response_File_Name => - Next_Argv (2 .. Next_Argv'Last), - Recursive => True, - Ignore_Non_Existing_Files => True); - begin - for J in Arguments'Range loop - Scan_Bind_Arg (Arguments (J).all); - end loop; - end; - end if; + -- We need to Scan_Bind_Args first, to set Verbose_Mode, so we know whether + -- to Put_Bind_Args. - else - Scan_Bind_Arg (Next_Argv); - end if; - end if; - end; + Scan_Bind_Args; - Next_Arg := Next_Arg + 1; - end loop Scan_Args; + if Verbose_Mode then + Write_Str (Command_Name); + Put_Bind_Args; + Write_Eol; + end if; if Use_Pragma_Linker_Constructor then if Bind_Main_Program then diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 4581b2cf18f..be1567089af 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -59,7 +59,6 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; procedure GNATCmd is Project_Node_Tree : Project_Node_Tree_Ref; - Root_Environment : Prj.Tree.Environment; Project_File : String_Access; Project : Prj.Project_Id; Current_Verbosity : Prj.Verbosity := Prj.Default; @@ -1395,9 +1394,6 @@ begin Snames.Initialize; Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags); - Prj.Env.Initialize_Default_Project_Path - (Root_Environment.Project_Path, - Target_Name => Sdefault.Target_Name.all); Project_Node_Tree := new Project_Node_Tree_Data; Prj.Tree.Initialize (Project_Node_Tree); @@ -1769,7 +1765,13 @@ begin (Root_Environment.Project_Path, Argv (Argv'First + 3 .. Argv'Last)); - Remove_Switch (Arg_Num); + -- Pass -aPdir to gnatls, but not to other tools + + if The_Command = List then + Arg_Num := Arg_Num + 1; + else + Remove_Switch (Arg_Num); + end if; -- -eL Follow links for files @@ -1911,6 +1913,13 @@ begin end Inspect_Switches; end if; + -- Add the default project search directories now, after the directories + -- that have been specified by switches -aP<dir>. + + Prj.Env.Initialize_Default_Project_Path + (Root_Environment.Project_Path, + Target_Name => Sdefault.Target_Name.all); + -- If there is a project file specified, parse it, get the switches -- for the tool and setup PATH environment variables. diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 87ad072f7a5..503c2f7b152 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -153,6 +153,8 @@ procedure Gnatlink is Binder_Ali_File : String_Access; Binder_Obj_File : String_Access; + Base_Command_Name : String_Access; + Tname : Temp_File_Name; Tname_FD : File_Descriptor := Invalid_FD; -- Temporary file used by linker to pass list of object files on @@ -226,6 +228,12 @@ procedure Gnatlink is procedure Process_Binder_File (Name : String); -- Reads the binder file and extracts linker arguments + function To_Lower (A : Character) return Character; + -- Fold a character to lower case; + + procedure To_Lower (A : in out String); + -- Fold a string to lower case; + procedure Usage; -- Display usage @@ -314,7 +322,7 @@ procedure Gnatlink is procedure Error_Msg (Message : String) is begin - Write_Str (Base_Name (Command_Name)); + Write_Str (Base_Command_Name.all); Write_Str (": "); Write_Str (Message); Write_Eol; @@ -1406,6 +1414,31 @@ procedure Gnatlink is Status := fclose (Fd); end Process_Binder_File; + -------------- + -- To_Lower -- + -------------- + + function To_Lower (A : Character) return Character is + A_Val : constant Natural := Character'Pos (A); + + begin + if A in 'A' .. 'Z' + or else A_Val in 16#C0# .. 16#D6# + or else A_Val in 16#D8# .. 16#DE# + then + return Character'Val (A_Val + 16#20#); + else + return A; + end if; + end To_Lower; + + procedure To_Lower (A : in out String) is + begin + for J in A'Range loop + A (J) := To_Lower (A (J)); + end loop; + end To_Lower; + ----------- -- Usage -- ----------- @@ -1413,7 +1446,7 @@ procedure Gnatlink is procedure Usage is begin Write_Str ("Usage: "); - Write_Str (Base_Name (Command_Name)); + Write_Str (Base_Command_Name.all); Write_Str (" switches mainprog.ali [non-Ada-objects] [linker-options]"); Write_Eol; Write_Eol; @@ -1501,6 +1534,15 @@ begin end; end if; + Base_Command_Name := new String'(Base_Name (Command_Name)); + + -- Fold to lower case "GNATLINK" on VMS to be consistent with output + -- from other GNAT utilities. + + if Hostparm.OpenVMS then + To_Lower (Base_Command_Name.all); + end if; + Process_Args; if Argument_Count = 0 @@ -1737,7 +1779,7 @@ begin -- Assume this is a cross tool if the executable name is not gnatlink - if Base_Name (Command_Name) = "gnatlink" + if Base_Command_Name.all = "gnatlink" and then Output_File_Name.all = "test" then Error_Msg ("warning: executable name """ & Output_File_Name.all diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index a98aba56c6a..ae623897d6c 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.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- -- @@ -1252,6 +1252,7 @@ procedure Gnatls is procedure Scan_Ls_Arg (Argv : String) is FD : File_Descriptor; Len : Integer; + OK : Boolean; begin pragma Assert (Argv'First = 1); @@ -1260,6 +1261,7 @@ procedure Gnatls is return; end if; + OK := True; if Argv (1) = '-' then if Argv'Length = 1 then Fail ("switch character cannot be followed by a blank"); @@ -1297,6 +1299,11 @@ procedure Gnatls is elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then Add_Lib_Dir (Argv (4 .. Argv'Last)); + -- Processing for -aP<dir> + + elsif Argv'Length > 3 and then Argv (1 .. 3) = "-aP" then + Add_Directories (Prj_Path, Argv (4 .. Argv'Last)); + -- Processing for -nostdinc elsif Argv (2 .. Argv'Last) = "nostdinc" then @@ -1316,7 +1323,7 @@ procedure Gnatls is when 'l' => License := True; when 'V' => Very_Verbose_Mode := True; - when others => null; + when others => OK := False; end case; -- Processing for -files=file @@ -1396,6 +1403,9 @@ procedure Gnatls is Opt.No_Stdinc := True; Opt.RTS_Switch := True; end if; + + else + OK := False; end if; -- If not a switch, it must be a file name @@ -1403,6 +1413,13 @@ procedure Gnatls is else Add_File (Argv); end if; + + if not OK then + Write_Str ("warning: unknown switch """); + Write_Str (Argv); + Write_Line (""""); + end if; + end Scan_Ls_Arg; ----------- @@ -1484,6 +1501,11 @@ procedure Gnatls is Write_Str (" -aOdir specify object files search path"); Write_Eol; + -- Line for -aP switch + + Write_Str (" -aPdir specify project search path"); + Write_Eol; + -- Line for -I switch Write_Str (" -Idir like -aIdir -aOdir"); diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index 68375ef21db..56157ead462 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.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- -- @@ -88,7 +88,7 @@ procedure Gnatname is Table_Initial => 10, Table_Increment => 100, Table_Name => "Gnatname.Arguments"); - -- Table to accumulate the foreign patterns + -- Table to accumulate directories and patterns package Preprocessor_Switches is new Table.Table (Table_Component_Type => String_Access, @@ -346,6 +346,11 @@ procedure Gnatname is Subdirs := new String'(Arg (Subdirs_Switch'Length + 1 .. Arg'Last)); + -- --no-backup + + elsif Arg = "--no-backup" then + Opt.No_Backup := True; + -- -c elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-c" then @@ -515,6 +520,7 @@ procedure Gnatname is Display_Usage_Version_And_Help; Write_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs"); + Write_Line (" --no-backup do not create backup of project file"); Write_Eol; Write_Line (" --and use different patterns"); diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index 418be05b750..c680ec2dea0 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -82,7 +82,7 @@ package Gnatvsn is -- Prefix generated by binder. If it is changed, be sure to change -- GNAT.Compiler_Version.Ver_Prefix as well. - Library_Version : constant String := "4.8"; + Library_Version : constant String := "4.9"; -- Library version. This value must be updated when the compiler -- version number Gnat_Static_Version_String is updated. -- diff --git a/gcc/ada/hostparm.ads b/gcc/ada/hostparm.ads index ebecd5ceeff..d868f2fa724 100644 --- a/gcc/ada/hostparm.ads +++ b/gcc/ada/hostparm.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- -- @@ -54,13 +54,14 @@ package Hostparm is Normalized_CWD : constant String := "." & Direct_Separator; -- Normalized string to access current directory - Max_Line_Length : constant := Types.Column_Number'Pred - (Types.Column_Number'Last); + Max_Line_Length : constant := + Types.Column_Number'Pred (Types.Column_Number'Last); -- Maximum source line length. By default we set it to the maximum -- value that can be supported, which is given by the range of the -- Column_Number type. We subtract 1 because need to be able to -- have a valid Column_Number equal to Max_Line_Length to represent -- the location of a "line too long" error. + -- -- 200 is the minimum value required (RM 2.2(15)). The value set here -- can be reduced by the explicit use of the -gnatyM style switch. diff --git a/gcc/ada/i-cstrea.ads b/gcc/ada/i-cstrea.ads index 1a7e76a713b..95dae64361e 100644 --- a/gcc/ada/i-cstrea.ads +++ b/gcc/ada/i-cstrea.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2012, 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- -- @@ -107,8 +107,8 @@ package Interfaces.C_Streams is function fopen (filename : chars; mode : chars; - encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8) - return FILEs + encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8; + vms_form : chars := System.Null_Address) return FILEs renames System.CRTL.fopen; -- Note: to maintain target independence, use text_translation_required, -- a boolean variable defined in sysdep.c to deal with the target @@ -144,8 +144,8 @@ package Interfaces.C_Streams is (filename : chars; mode : chars; stream : FILEs; - encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8) - return FILEs + encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8; + vms_form : chars := System.Null_Address) return FILEs renames System.CRTL.freopen; function fseek diff --git a/gcc/ada/i-fortra.ads b/gcc/ada/i-fortra.ads index 992eb28634c..0946e49a7e3 100644 --- a/gcc/ada/i-fortra.ads +++ b/gcc/ada/i-fortra.ads @@ -26,11 +26,11 @@ package Interfaces.Fortran is type Logical is new Boolean; for Logical'Size use Integer'Size; pragma Convention (Fortran, Logical); - -- As required by Fortran standard, stand alone logical allocates same - -- space as integer (but what about the array case???). The convention - -- is important, since in Fortran, Booleans have zero/non-zero semantics - -- for False/True, and the pragma Convention (Fortran) activates the - -- special handling required in this case. + -- As required by Fortran standard, logical allocates same space as + -- an integer. The convention is important, since in Fortran, Booleans + -- are implemented with zero/non-zero semantics for False/True, and the + -- pragma Convention (Fortran) activates the special handling required + -- in this case. package Single_Precision_Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); @@ -50,6 +50,60 @@ package Interfaces.Fortran is type Fortran_Character is array (Positive range <>) of Character_Set; + -- Additional declarations as permitted by Ada 2012, p.608, paragraph 21. + -- Interoperability with Fortran 77's vendor extension using star + -- notation and Fortran 90's intrinsic types with kind=n parameter. + -- The following assumes that `n' matches the byte size, which + -- most Fortran compiler, including GCC's follow. + + type Integer_Star_1 is new Integer_8; + type Integer_Kind_1 is new Integer_8; + type Integer_Star_2 is new Integer_16; + type Integer_Kind_2 is new Integer_16; + type Integer_Star_4 is new Integer_32; + type Integer_Kind_4 is new Integer_32; + type Integer_Star_8 is new Integer_64; + type Integer_Kind_8 is new Integer_64; + + type Logical_Star_1 is new Boolean; + type Logical_Star_2 is new Boolean; + type Logical_Star_4 is new Boolean; + type Logical_Star_8 is new Boolean; + type Logical_Kind_1 is new Boolean; + type Logical_Kind_2 is new Boolean; + type Logical_Kind_4 is new Boolean; + type Logical_Kind_8 is new Boolean; + for Logical_Star_1'Size use Integer_8'Size; + for Logical_Star_2'Size use Integer_16'Size; + for Logical_Star_4'Size use Integer_32'Size; + for Logical_Star_8'Size use Integer_64'Size; + for Logical_Kind_1'Size use Integer_8'Size; + for Logical_Kind_2'Size use Integer_16'Size; + for Logical_Kind_4'Size use Integer_32'Size; + for Logical_Kind_8'Size use Integer_64'Size; + pragma Convention (Fortran, Logical_Star_1); + pragma Convention (Fortran, Logical_Star_2); + pragma Convention (Fortran, Logical_Star_4); + pragma Convention (Fortran, Logical_Star_8); + pragma Convention (Fortran, Logical_Kind_1); + pragma Convention (Fortran, Logical_Kind_2); + pragma Convention (Fortran, Logical_Kind_4); + pragma Convention (Fortran, Logical_Kind_8); + + type Real_Star_4 is new Float; + type Real_Kind_4 is new Float; + type Real_Star_8 is new Long_Float; + type Real_Kind_8 is new Long_Float; + + -- In the kind syntax, n is the same as the associated real kind. + -- In the star syntax, n is twice as large (real+imaginary size) + type Complex_Star_8 is new Complex; + type Complex_Kind_4 is new Complex; + type Complex_Star_16 is new Double_Complex; + type Complex_Kind_8 is new Double_Complex; + + type Character_Kind_n is new Fortran_Character; + function To_Fortran (Item : Character) return Character_Set; function To_Ada (Item : Character_Set) return Character; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index efeb8960a4e..bb62264c66b 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -380,7 +380,14 @@ package body Impunit is ("s-ststop", F), -- System.Strings.Stream_Ops ("s-tasinf", F), -- System.Task_Info ("s-wchcnv", F), -- System.Wch_Cnv - ("s-wchcon", F)); -- System.Wch_Con + ("s-wchcon", F), -- System.Wch_Con + + -- The following are strictly speaking Ada 2012 units, but we are allowed + -- to add children to system, so we consider them to be implementation + -- defined additions to System in earlier versions of Ada. + + ("s-multip", T), -- System.Multiprocessors + ("s-mudido", T)); -- System.Multiprocessors.Dispatching_Domains -------------------- -- Ada 2005 Units -- @@ -544,8 +551,6 @@ package body Impunit is -- The following units should be used only in Ada 2012 mode Non_Imp_File_Names_12 : constant File_List := ( - ("s-multip", T), -- System.Multiprocessors - ("s-mudido", T), -- System.Multiprocessors.Dispatching_Domains ("s-stposu", T), -- System.Storage_Pools.Subpools ("a-cobove", T), -- Ada.Containers.Bounded_Vectors ("a-cbdlli", T), -- Ada.Containers.Bounded_Doubly_Linked_Lists diff --git a/gcc/ada/init.c b/gcc/ada/init.c index f5c3a814411..1b2e188ab51 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.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- * @@ -603,14 +603,6 @@ __gnat_install_handler (void) handled properly, avoiding a SEGV generation from stack usage by the handler itself. */ -#if defined (i386) || defined (__x86_64__) || defined (__powerpc__) - stack_t stack; - stack.ss_sp = __gnat_alternate_stack; - stack.ss_size = sizeof (__gnat_alternate_stack); - stack.ss_flags = 0; - sigaltstack (&stack, NULL); -#endif - act.sa_sigaction = __gnat_error_handler; act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; sigemptyset (&act.sa_mask); @@ -624,11 +616,23 @@ __gnat_install_handler (void) sigaction (SIGILL, &act, NULL); if (__gnat_get_interrupt_state (SIGBUS) != 's') sigaction (SIGBUS, &act, NULL); + if (__gnat_get_interrupt_state (SIGSEGV) != 's') + { #if defined (i386) || defined (__x86_64__) || defined (__powerpc__) - act.sa_flags |= SA_ONSTACK; + /* Setup an alternate stack region for the handler execution so that + stack overflows can be handled properly, avoiding a SEGV generation + from stack usage by the handler itself. */ + stack_t stack; + + stack.ss_sp = __gnat_alternate_stack; + stack.ss_size = sizeof (__gnat_alternate_stack); + stack.ss_flags = 0; + sigaltstack (&stack, NULL); + + act.sa_flags |= SA_ONSTACK; #endif - if (__gnat_get_interrupt_state (SIGSEGV) != 's') - sigaction (SIGSEGV, &act, NULL); + sigaction (SIGSEGV, &act, NULL); + } __gnat_handler_installed = 1; } @@ -707,15 +711,6 @@ __gnat_install_handler(void) #include <sys/ucontext.h> #include <sys/regset.h> -/* The code below is common to SPARC and x86. Beware of the delay slot - differences for signal context adjustments. */ - -#if defined (__sparc) -#define RETURN_ADDR_OFFSET 8 -#else -#define RETURN_ADDR_OFFSET 0 -#endif - static void __gnat_error_handler (int sig, siginfo_t *si, void *ucontext ATTRIBUTE_UNUSED) { @@ -809,6 +804,7 @@ __gnat_install_handler (void) /* Routine called from binder to override default feature values. */ void __gnat_set_features (void); int __gnat_features_set = 0; +void (*__gnat_ctrl_c_handler) (void) = 0; #ifdef __IA64 #define lib_get_curr_invo_context LIB$I64_GET_CURR_INVO_CONTEXT @@ -820,13 +816,19 @@ int __gnat_features_set = 0; #define lib_get_invo_handle LIB$GET_INVO_HANDLE #endif +/* Masks for facility identification. */ +#define FAC_MASK 0x0fff0000 +#define DECADA_M_FACILITY 0x00310000 + /* Define macro symbols for the VMS conditions that become Ada exceptions. It would be better to just include <ssdef.h> */ +#define SS$_CONTINUE 1 #define SS$_ACCVIO 12 #define SS$_HPARITH 1284 #define SS$_INTDIV 1156 #define SS$_STKOVF 1364 +#define SS$_CONTROLC 1617 #define SS$_RESIGNAL 2328 #define MTH$_FLOOVEMAT 1475268 /* Some ACVC_21 CXA tests */ @@ -835,6 +837,7 @@ int __gnat_features_set = 0; /* These codes are in standard message libraries. */ extern int C$_SIGKILL; +extern int C$_SIGINT; extern int SS$_DEBUG; extern int LIB$_KEYNOTFOU; extern int LIB$_ACTIMAGE; @@ -846,24 +849,28 @@ extern int LIB$_ACTIMAGE; #define FDL$_UNPRIKW 11829410 #define CMA$_EXIT_THREAD 4227492 -struct cond_sigargs { +struct cond_sigargs +{ unsigned int sigarg; unsigned int sigargval; }; -struct cond_subtests { +struct cond_subtests +{ unsigned int num; const struct cond_sigargs sigargs[]; }; -struct cond_except { +struct cond_except +{ unsigned int cond; const struct Exception_Data *except; unsigned int needs_adjust; /* 1 = adjust PC, 0 = no adjust */ const struct cond_subtests *subtests; }; -struct descriptor_s { +struct descriptor_s +{ unsigned short len, mbz; __char_ptr32 adr; }; @@ -939,7 +946,8 @@ extern Exception_Code Base_Code_In (Exception_Code); #define ADA$_USE_ERROR 0x0031a8a4 /* DEC Ada specific conditions. */ -static const struct cond_except dec_ada_cond_except_table [] = { +static const struct cond_except dec_ada_cond_except_table [] = +{ {ADA$_PROGRAM_ERROR, &program_error, 0, 0}, {ADA$_USE_ERROR, &Use_Error, 0, 0}, {ADA$_KEYSIZERR, &program_error, 0, 0}, @@ -987,18 +995,19 @@ static const struct cond_except dec_ada_cond_except_table [] = { in hindsight should have just made ACCVIO == Storage_Error. */ #define ACCVIO_VIRTUAL_ADDR 3 static const struct cond_subtests accvio_c_e = - {1, /* number of subtests below */ - { - {ACCVIO_VIRTUAL_ADDR, 0} - } - }; +{1, /* number of subtests below */ + { + { ACCVIO_VIRTUAL_ADDR, 0 } + } +}; /* Macro flag to adjust PC which gets off by one for some conditions, not sure if this is reliably true, PC could be off by more for HPARITH for example, unless a trapb is inserted. */ #define NEEDS_ADJUST 1 -static const struct cond_except system_cond_except_table [] = { +static const struct cond_except system_cond_except_table [] = +{ {MTH$_FLOOVEMAT, &constraint_error, 0, 0}, {SS$_INTDIV, &constraint_error, 0, 0}, {SS$_HPARITH, &constraint_error, NEEDS_ADJUST, 0}, @@ -1040,7 +1049,8 @@ static const struct cond_except system_cond_except_table [] = { typedef int resignal_predicate (int code); -static const int * const cond_resignal_table [] = { +static const int * const cond_resignal_table [] = +{ &C$_SIGKILL, (int *)CMA$_EXIT_THREAD, &SS$_DEBUG, @@ -1051,7 +1061,8 @@ static const int * const cond_resignal_table [] = { 0 }; -static const int facility_resignal_table [] = { +static const int facility_resignal_table [] = +{ 0x1380000, /* RDB */ 0x2220000, /* SQL */ 0 @@ -1065,7 +1076,7 @@ __gnat_default_resignal_p (int code) int i, iexcept; for (i = 0; facility_resignal_table [i]; i++) - if ((code & 0xfff0000) == facility_resignal_table [i]) + if ((code & FAC_MASK) == facility_resignal_table [i]) return 1; for (i = 0, iexcept = 0; @@ -1099,7 +1110,6 @@ __gnat_set_resignal_predicate (resignal_predicate *predicate) /* Action routine for SYS$PUTMSG. There may be multiple conditions, each with text to be appended to MESSAGE and separated by line termination. */ - static int copy_msg (struct descriptor_s *msgdesc, char *message) { @@ -1125,7 +1135,6 @@ 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 []) { @@ -1174,6 +1183,8 @@ static const struct cond_except * return &(*table) [i]; } +/* __gnat_handle_vms_condtition is both a frame based handler + for the runtime, and an exception vector for the compiler. */ long __gnat_handle_vms_condition (int *sigargs, void *mechargs) { @@ -1211,6 +1222,23 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs) const struct cond_except *cond_tables [] = {dec_ada_cond_except_table, system_cond_except_table, 0}; + unsigned int ctrlc = SS$_CONTROLC; + unsigned int *sigint = &C$_SIGINT; + int ctrlc_match = LIB$MATCH_COND (&sigargs [1], &ctrlc); + int sigint_match = LIB$MATCH_COND (&sigargs [1], &sigint); + + extern int SYS$DCLAST (void (*astadr)(), unsigned long long astprm, + unsigned int acmode); + + /* If SS$_CONTROLC has been imported as an exception, it will take + priority over a a Ctrl/C handler. See above. SIGINT has a + different condition value due to it's DECCCRTL roots and it's + the condition that gets raised for a "kill -INT". */ + if ((ctrlc_match || sigint_match) && __gnat_ctrl_c_handler) + { + SYS$DCLAST (__gnat_ctrl_c_handler, 0, 0); + return SS$_CONTINUE; + } i = 0; while ((cond_table = cond_tables[i++]) && !exception) @@ -1236,7 +1264,18 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs) message[0] = 0; /* Subtract PC & PSL fields as per ABI for SYS$PUTMSG. */ sigargs[0] -= 2; - SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message); + + extern int SYS$PUTMSG (void *, int (*)(), void *, unsigned long long); + + /* If it was a DEC Ada specific condtiion, make it GNAT otherwise + keep the old facility. */ + if (sigargs [1] & FAC_MASK == DECADA_M_FACILITY) + SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, + (unsigned long long ) message); + else + SYS$PUTMSG (sigargs, copy_msg, 0, + (unsigned long long ) message); + /* Add back PC & PSL fields as per ABI for SYS$PUTMSG. */ sigargs[0] += 2; msg = message; @@ -1247,12 +1286,33 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs) Raise_From_Signal_Handler (exception, msg); } +#if defined (IN_RTS) && defined (__IA64) +/* Called only from adasigio.b32. This is a band aid to avoid going + through the VMS signal handling code which results in a 0x8000 per + handled exception memory leak in P2 space (see VMS source listing + sys/lis/exception.lis) due to the allocation of working space that + is expected to be deallocated upon return from the condition handler, + which doesn't return in GNAT compiled code. */ +void +GNAT$STOP (int *sigargs) +{ + /* Note that there are no mechargs. We rely on the fact that condtions + raised from DEClib I/O do not require an "adjust". Also the count + will be off by 2, since LIB$STOP didn't get a chance to add the + PC and PSL fields, so we bump it so PUTMSG comes out right. */ + sigargs [0] += 2; + __gnat_handle_vms_condition (sigargs, 0); +} +#endif + void __gnat_install_handler (void) { long prvhnd ATTRIBUTE_UNUSED; #if !defined (IN_RTS) + extern int SYS$SETEXV (unsigned int vector, int (*addres)(), + unsigned int accmode, void *(*(prvhnd))); SYS$SETEXV (1, __gnat_handle_vms_condition, 3, &prvhnd); #endif @@ -1378,15 +1438,14 @@ struct regsum }; extern int SYS$GET_REGION_INFO (unsigned int, unsigned long long *, - void *, void *, unsigned int, - void *, unsigned int *); + void *, void *, unsigned int, + void *, unsigned int *); extern int SYS$EXPREG_64 (unsigned long long *, unsigned long long, - unsigned int, unsigned int, void **, - unsigned long long *); + unsigned int, unsigned int, void **, + unsigned long long *); extern int SYS$SETPRT_64 (void *, unsigned long long, unsigned int, - unsigned int, void **, unsigned long long *, - unsigned int *); -extern int SYS$PUTMSG (void *, int (*)(), void *, unsigned long long); + unsigned int, void **, unsigned long long *, + unsigned int *); /* Add a guard page in the memory region containing ADDR at ADDR +/- SIZE. (The sign depends on the kind of the memory region). */ @@ -1412,7 +1471,7 @@ __gnat_set_stack_guard_page (void *addr, unsigned long size) /* Extend the region. */ status = SYS$EXPREG_64 (&buffer.q_region_id, - size, 0, 0, &start_va, &length); + size, 0, 0, &start_va, &length); if ((status & 1) != 1) return -1; @@ -1422,7 +1481,7 @@ __gnat_set_stack_guard_page (void *addr, unsigned long size) start_va = (void *)((unsigned long long)start_va + length - VMS_PAGESIZE); status = SYS$SETPRT_64 (start_va, VMS_PAGESIZE, PSL__C_USER, PRT__C_NA, - &ret_va, &ret_len, &ret_prot); + &ret_va, &ret_len, &ret_prot); if ((status & 1) != 1) return -1; @@ -1473,7 +1532,8 @@ struct feature { int __gl_heap_size = 64; /* Array feature logical names and global variable addresses. */ -static const struct feature features[] = { +static const struct feature features[] = +{ {"GNAT$NO_MALLOC_64", &__gl_heap_size}, {0, 0} }; @@ -1490,13 +1550,13 @@ __gnat_set_features (void) __gnat_vms_get_logical (features[i].name, buff, sizeof (buff)); if (strcmp (buff, "ENABLE") == 0 - || strcmp (buff, "TRUE") == 0 - || strcmp (buff, "1") == 0) - *features[i].gl_addr = 32; + || strcmp (buff, "TRUE") == 0 + || strcmp (buff, "1") == 0) + *features[i].gl_addr = 32; else if (strcmp (buff, "DISABLE") == 0 - || strcmp (buff, "FALSE") == 0 - || strcmp (buff, "0") == 0) - *features[i].gl_addr = 64; + || strcmp (buff, "FALSE") == 0 + || strcmp (buff, "0") == 0) + *features[i].gl_addr = 64; } /* Features to artificially limit the stack size. */ diff --git a/gcc/ada/interfac.ads b/gcc/ada/interfac.ads index 810366d5763..57033a94eca 100644 --- a/gcc/ada/interfac.ads +++ b/gcc/ada/interfac.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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 -- @@ -159,9 +159,11 @@ package Interfaces is type IEEE_Float_32 is digits 6; pragma Float_Representation (IEEE_Float, IEEE_Float_32); + for IEEE_Float_32'Size use 32; type IEEE_Float_64 is digits 15; pragma Float_Representation (IEEE_Float, IEEE_Float_64); + for IEEE_Float_64'Size use 64; -- If there is an IEEE extended float available on the machine, we assume -- that it is available as Long_Long_Float. diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 7f743e23aa9..e786f473add 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.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- -- @@ -33,7 +33,6 @@ with Fname; use Fname; with Fname.UF; use Fname.UF; with Lib.Util; use Lib.Util; with Lib.Xref; use Lib.Xref; - use Lib.Xref.Alfa; with Nlists; use Nlists; with Gnatvsn; use Gnatvsn; with Opt; use Opt; @@ -49,7 +48,6 @@ with Sinput; use Sinput; with Snames; use Snames; with Stringt; use Stringt; with Tbuild; use Tbuild; -with Ttypes; use Ttypes; with Uname; use Uname; with System.Case_Util; use System.Case_Util; @@ -817,11 +815,11 @@ package body Lib.Writ is Nkind (Unit (Cunit)) in N_Generic_Renaming_Declaration) and then Generic_May_Lack_ALI (Fname)) - -- In Alfa mode, always generate the dependencies on ALI + -- In SPARK mode, always generate the dependencies on ALI -- files, which are required to compute frame conditions -- of subprograms. - or else Alfa_Mode + or else SPARK_Mode then Write_Info_Tab (25); @@ -1434,98 +1432,12 @@ package body Lib.Writ is SCO_Output; end if; - -- Output Alfa information if needed + -- Output SPARK cross-reference information if needed - if Opt.Xref_Active and then Alfa_Mode then - Collect_Alfa (Sdep_Table => Sdep_Table, Num_Sdep => Num_Sdep); - Output_Alfa; - end if; - - -- Output target dependent information if needed - - if Generate_Target_Dependent_Info then - Gen_TDI : declare - subtype Str4 is String (1 .. 4); - - procedure Gen_TDI_Bool (Code : Str4; Val : Boolean); - -- Generate T line for Bool value - - procedure Gen_TDI_Nat (Code : Str4; Val : Int); - -- Generate T line for Pos or Nat value - - ------------------ - -- Gen_TDI_Bool -- - ------------------ - - procedure Gen_TDI_Bool (Code : Str4; Val : Boolean) is - begin - Write_Info_Initiate ('T'); - Write_Info_Char (' '); - Write_Info_Str (Code); - - if Val then - Write_Info_Str (" TRUE"); - else - Write_Info_Str (" FALSE"); - end if; - - Write_Info_EOL; - end Gen_TDI_Bool; - - ----------------- - -- Gen_TDI_Nat -- - ----------------- - - procedure Gen_TDI_Nat (Code : Str4; Val : Int) is - begin - Write_Info_Initiate ('T'); - Write_Info_Char (' '); - Write_Info_Str (Code); - Write_Info_Char (' '); - Write_Info_Nat (Val); - - Write_Info_EOL; - end Gen_TDI_Nat; - - -- Start of processing for Gen_TDI - - begin - Gen_TDI_Nat ("SINS", Standard_Short_Short_Integer_Size); - Gen_TDI_Nat ("SINW", Standard_Short_Short_Integer_Width); - Gen_TDI_Nat ("SHIS", Standard_Short_Integer_Size); - Gen_TDI_Nat ("SHIW", Standard_Short_Integer_Width); - Gen_TDI_Nat ("INTS", Standard_Integer_Size); - Gen_TDI_Nat ("INTW", Standard_Integer_Width); - Gen_TDI_Nat ("LINS", Standard_Long_Integer_Size); - Gen_TDI_Nat ("LINW", Standard_Long_Integer_Width); - Gen_TDI_Nat ("LLIS", Standard_Long_Long_Integer_Size); - Gen_TDI_Nat ("LLIW", Standard_Long_Long_Integer_Width); - Gen_TDI_Nat ("SFLS", Standard_Short_Float_Size); - Gen_TDI_Nat ("SFLD", Standard_Short_Float_Digits); - Gen_TDI_Nat ("FLTS", Standard_Float_Size); - Gen_TDI_Nat ("FLTD", Standard_Float_Digits); - Gen_TDI_Nat ("LFLS", Standard_Long_Float_Size); - Gen_TDI_Nat ("LFLD", Standard_Long_Float_Digits); - Gen_TDI_Nat ("LLFS", Standard_Long_Long_Float_Size); - Gen_TDI_Nat ("LLFD", Standard_Long_Long_Float_Digits); - Gen_TDI_Nat ("CHAS", Standard_Character_Size); - Gen_TDI_Nat ("WCHS", Standard_Wide_Character_Size); - Gen_TDI_Nat ("WWCS", Standard_Wide_Wide_Character_Size); - Gen_TDI_Nat ("ADRS", System_Address_Size); - Gen_TDI_Nat ("MBMP", System_Max_Binary_Modulus_Power); - Gen_TDI_Nat ("MNMP", System_Max_Nonbinary_Modulus_Power); - Gen_TDI_Nat ("SUNI", System_Storage_Unit); - Gen_TDI_Nat ("WRDS", System_Word_Size); - Gen_TDI_Nat ("TICK", System_Tick_Nanoseconds); - Gen_TDI_Nat ("WCTS", Interfaces_Wchar_T_Size); - Gen_TDI_Nat ("MAXA", Maximum_Alignment); - Gen_TDI_Nat ("ALLA", System_Allocator_Alignment); - Gen_TDI_Nat ("MUNF", Max_Unaligned_Field); - Gen_TDI_Bool ("BEND", Bytes_Big_Endian); - Gen_TDI_Bool ("STRA", Target_Strict_Alignment); - Gen_TDI_Nat ("DFLA", Target_Double_Float_Alignment); - Gen_TDI_Nat ("DSCA", Target_Double_Scalar_Alignment); - end Gen_TDI; + if Opt.Xref_Active and then SPARK_Mode then + SPARK_Specific.Collect_SPARK_Xrefs (Sdep_Table => Sdep_Table, + Num_Sdep => Num_Sdep); + SPARK_Specific.Output_SPARK_Xrefs; end if; -- Output final blank line and we are done. This final blank line is diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 3867c5f2643..b631b2aa43a 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.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- -- @@ -811,30 +811,13 @@ package Lib.Writ is -- reference data. See the spec of Par_SCO in file par_sco.ads for full -- details of the format. - ---------------------- - -- Alfa Information -- - ---------------------- - - -- The Alfa information follows the SCO information. See the spec of Alfa - -- in file alfa.ads for full details of the format. - - ------------------------------------- - -- T Target Dependent Information -- - ------------------------------------- - - -- This section is present if the option to generate target dependent - -- information is present (this flag is set by the -gnatT switch). The - -- format of T lines is: - - -- T key val - - -- There is one line for each constant declared in the Ttypes package - - -- key is the four letter code (which can be found as a comment on each - -- of the constant declarations in Ttypes). + --------------------------------------- + -- SPARK Cross-Reference Information -- + --------------------------------------- - -- val is the value of the constant, which is either a non-negative - -- decimal constant, or TRUE or FALSE for a Boolean value. + -- The SPARK cross-reference information follows the SCO information. See + -- the spec of SPARK_Xrefs in file spark_xrefs.ads for full details of the + -- format. ---------------------- -- Global Variables -- diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-spark_specific.adb index c9ab1e03b10..78413137b0f 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- L I B . X R E F . A L F A -- +-- L I B . X R E F . S P A R K _ S P E C I F I C -- -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2012, 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- -- @@ -23,23 +23,23 @@ -- -- ------------------------------------------------------------------------------ -with Alfa; use Alfa; -with Einfo; use Einfo; -with Nmake; use Nmake; -with Put_Alfa; +with SPARK_Xrefs; use SPARK_Xrefs; +with Einfo; use Einfo; +with Nmake; use Nmake; +with Put_SPARK_Xrefs; with GNAT.HTable; separate (Lib.Xref) -package body Alfa is +package body SPARK_Specific is --------------------- -- Local Constants -- --------------------- - -- Table of Alfa_Entities, True for each entity kind used in Alfa + -- Table of SPARK_Entities, True for each entity kind used in SPARK - Alfa_Entities : constant array (Entity_Kind) of Boolean := + SPARK_Entities : constant array (Entity_Kind) of Boolean := (E_Constant => True, E_Function => True, E_In_Out_Parameter => True, @@ -51,9 +51,9 @@ package body Alfa is E_Variable => True, others => False); - -- True for each reference type used in Alfa + -- True for each reference type used in SPARK - Alfa_References : constant array (Character) of Boolean := + SPARK_References : constant array (Character) of Boolean := ('m' => True, 'r' => True, 's' => True, @@ -79,28 +79,28 @@ package body Alfa is -- Table of cross-references for reads and writes through explicit -- dereferences, that are output as reads/writes to the special variable -- "Heap". These references are added to the regular references when - -- computing Alfa cross-references. + -- computing SPARK cross-references. ----------------------- -- Local Subprograms -- ----------------------- - procedure Add_Alfa_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat); - -- Add file and corresponding scopes for unit to the tables Alfa_File_Table - -- and Alfa_Scope_Table. When two units are present for the same - -- compilation unit, as it happens for library-level instantiations of - -- generics, then Ubody /= Uspec, and all scopes are added to the same - -- Alfa file. Otherwise Ubody = Uspec. + procedure Add_SPARK_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat); + -- Add file and corresponding scopes for unit to the tables + -- SPARK_File_Table and SPARK_Scope_Table. When two units are present for + -- the same compilation unit, as it happens for library-level + -- instantiations of generics, then Ubody /= Uspec, and all scopes are + -- added to the same SPARK file. Otherwise Ubody = Uspec. - procedure Add_Alfa_Scope (N : Node_Id); - -- Add scope N to the table Alfa_Scope_Table + procedure Add_SPARK_Scope (N : Node_Id); + -- Add scope N to the table SPARK_Scope_Table - procedure Add_Alfa_Xrefs; - -- Filter table Xrefs to add all references used in Alfa to the table - -- Alfa_Xref_Table. + procedure Add_SPARK_Xrefs; + -- Filter table Xrefs to add all references used in SPARK to the table + -- SPARK_Xref_Table. - procedure Detect_And_Add_Alfa_Scope (N : Node_Id); - -- Call Add_Alfa_Scope on scopes + procedure Detect_And_Add_SPARK_Scope (N : Node_Id); + -- Call Add_SPARK_Scope on scopes function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range; -- Hash function for hash table @@ -127,11 +127,11 @@ package body Alfa is Inside_Stubs : Boolean); -- Traverse corresponding construct, calling Process on all declarations - ------------------- - -- Add_Alfa_File -- - ------------------- + -------------------- + -- Add_SPARK_File -- + -------------------- - procedure Add_Alfa_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat) is + procedure Add_SPARK_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat) is File : constant Source_File_Index := Source_Index (Uspec); From : Scope_Index; @@ -146,7 +146,7 @@ package body Alfa is return; end if; - From := Alfa_Scope_Table.Last + 1; + From := SPARK_Scope_Table.Last + 1; -- Unit might not have an associated compilation unit, as seen in code -- filling Sdep_Table in Write_ALI. @@ -154,19 +154,19 @@ package body Alfa is if Present (Cunit (Ubody)) then Traverse_Compilation_Unit (CU => Cunit (Ubody), - Process => Detect_And_Add_Alfa_Scope'Access, + Process => Detect_And_Add_SPARK_Scope'Access, Inside_Stubs => False); end if; -- When two units are present for the same compilation unit, as it -- happens for library-level instantiations of generics, then add all - -- scopes to the same Alfa file. + -- scopes to the same SPARK file. if Ubody /= Uspec then if Present (Cunit (Uspec)) then Traverse_Compilation_Unit (CU => Cunit (Uspec), - Process => Detect_And_Add_Alfa_Scope'Access, + Process => Detect_And_Add_SPARK_Scope'Access, Inside_Stubs => False); end if; end if; @@ -177,9 +177,9 @@ package body Alfa is Scope_Id : Int; begin Scope_Id := 1; - for Index in From .. Alfa_Scope_Table.Last loop + for Index in From .. SPARK_Scope_Table.Last loop declare - S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); + S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (Index); begin S.Scope_Num := Scope_Id; S.File_Num := Dspec; @@ -195,18 +195,18 @@ package body Alfa is begin Scope_Id := From; - for Index in From .. Alfa_Scope_Table.Last loop + for Index in From .. SPARK_Scope_Table.Last loop declare - S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); + S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (Index); begin if S.Scope_Num /= 0 then - Alfa_Scope_Table.Table (Scope_Id) := S; + SPARK_Scope_Table.Table (Scope_Id) := S; Scope_Id := Scope_Id + 1; end if; end; end loop; - Alfa_Scope_Table.Set_Last (Scope_Id - 1); + SPARK_Scope_Table.Set_Last (Scope_Id - 1); end; -- Make entry for new file in file table @@ -225,19 +225,19 @@ package body Alfa is Unit_File_Name := new String'(Name_Buffer (1 .. Name_Len)); end if; - Alfa_File_Table.Append ( + SPARK_File_Table.Append ( (File_Name => File_Name, Unit_File_Name => Unit_File_Name, File_Num => Dspec, From_Scope => From, - To_Scope => Alfa_Scope_Table.Last)); - end Add_Alfa_File; + To_Scope => SPARK_Scope_Table.Last)); + end Add_SPARK_File; - -------------------- - -- Add_Alfa_Scope -- - -------------------- + --------------------- + -- Add_SPARK_Scope -- + --------------------- - procedure Add_Alfa_Scope (N : Node_Id) is + procedure Add_SPARK_Scope (N : Node_Id) is E : constant Entity_Id := Defining_Entity (N); Loc : constant Source_Ptr := Sloc (E); Typ : Character; @@ -294,7 +294,7 @@ package body Alfa is -- File_Num and Scope_Num are filled later. From_Xref and To_Xref are -- filled even later, but are initialized to represent an empty range. - Alfa_Scope_Table.Append ( + SPARK_Scope_Table.Append ( (Scope_Name => new String'(Unique_Name (E)), File_Num => 0, Scope_Num => 0, @@ -306,37 +306,37 @@ package body Alfa is From_Xref => 1, To_Xref => 0, Scope_Entity => E)); - end Add_Alfa_Scope; + end Add_SPARK_Scope; - -------------------- - -- Add_Alfa_Xrefs -- - -------------------- + --------------------- + -- Add_SPARK_Xrefs -- + --------------------- - procedure Add_Alfa_Xrefs is + procedure Add_SPARK_Xrefs is function Entity_Of_Scope (S : Scope_Index) return Entity_Id; -- Return the entity which maps to the input scope index function Get_Entity_Type (E : Entity_Id) return Character; -- Return a character representing the type of entity - function Is_Alfa_Reference + function Is_SPARK_Reference (E : Entity_Id; Typ : Character) return Boolean; - -- Return whether entity reference E meets Alfa requirements. Typ is the - -- reference type. + -- Return whether entity reference E meets SPARK requirements. Typ is + -- the reference type. - function Is_Alfa_Scope (E : Entity_Id) return Boolean; + function Is_SPARK_Scope (E : Entity_Id) return Boolean; -- Return whether the entity or reference scope meets requirements for - -- being an Alfa scope. + -- being an SPARK scope. function Is_Future_Scope_Entity (E : Entity_Id; S : Scope_Index) return Boolean; - -- Check whether entity E is in Alfa_Scope_Table at index S or higher + -- Check whether entity E is in SPARK_Scope_Table at index S or higher function Is_Global_Constant (E : Entity_Id) return Boolean; -- Return True if E is a global constant for which we should ignore - -- reads in Alfa. + -- reads in SPARK. function Lt (Op1 : Natural; Op2 : Natural) return Boolean; -- Comparison function for Sort call @@ -375,7 +375,7 @@ package body Alfa is Hash => Entity_Hash, Equal => "="); -- Package used to build a correspondance between entities and scope - -- numbers used in Alfa cross references. + -- numbers used in SPARK cross references. Nrefs : Nat := Xrefs.Last; -- Number of references in table. This value may get reset (reduced) @@ -398,7 +398,7 @@ package body Alfa is function Entity_Of_Scope (S : Scope_Index) return Entity_Id is begin - return Alfa_Scope_Table.Table (S).Scope_Entity; + return SPARK_Scope_Table.Table (S).Scope_Entity; end Entity_Of_Scope; --------------------- @@ -424,11 +424,11 @@ package body Alfa is return Scopes.Get (N).Num; end Get_Scope_Num; - ----------------------- - -- Is_Alfa_Reference -- - ----------------------- + ------------------------ + -- Is_SPARK_Reference -- + ------------------------ - function Is_Alfa_Reference + function Is_SPARK_Reference (E : Entity_Id; Typ : Character) return Boolean is @@ -440,15 +440,15 @@ package body Alfa is if Ekind (E) in Overloadable_Kind then return Typ = 's'; - -- References to constant objects are not considered in Alfa section, - -- as these will be translated as constants in the intermediate - -- language for formal verification, and should therefore never - -- appear in frame conditions. + -- References to constant objects are not considered in SPARK + -- section, as these will be translated as constants in the + -- intermediate language for formal verification, and should + -- therefore never appear in frame conditions. elsif Is_Constant_Object (E) then return False; - -- Objects of Task type or protected type are not Alfa references + -- Objects of Task type or protected type are not SPARK references elsif Present (Etype (E)) and then Ekind (Etype (E)) in Concurrent_Kind @@ -461,19 +461,19 @@ package body Alfa is else return Typ = 'r' or else Typ = 'm'; end if; - end Is_Alfa_Reference; + end Is_SPARK_Reference; - ------------------- - -- Is_Alfa_Scope -- - ------------------- + -------------------- + -- Is_SPARK_Scope -- + -------------------- - function Is_Alfa_Scope (E : Entity_Id) return Boolean is + function Is_SPARK_Scope (E : Entity_Id) return Boolean is begin return Present (E) and then not Is_Generic_Unit (E) and then Renamed_Entity (E) = Empty and then Get_Scope_Num (E) /= No_Scope; - end Is_Alfa_Scope; + end Is_SPARK_Scope; ---------------------------- -- Is_Future_Scope_Entity -- @@ -484,7 +484,7 @@ package body Alfa is S : Scope_Index) return Boolean is function Is_Past_Scope_Entity return Boolean; - -- Check whether entity E is in Alfa_Scope_Table at index strictly + -- Check whether entity E is in SPARK_Scope_Table at index strictly -- lower than S. -------------------------- @@ -493,11 +493,11 @@ package body Alfa is function Is_Past_Scope_Entity return Boolean is begin - for Index in Alfa_Scope_Table.First .. S - 1 loop - if Alfa_Scope_Table.Table (Index).Scope_Entity = E then + for Index in SPARK_Scope_Table.First .. S - 1 loop + if SPARK_Scope_Table.Table (Index).Scope_Entity = E then declare - Dummy : constant Alfa_Scope_Record := - Alfa_Scope_Table.Table (Index); + Dummy : constant SPARK_Scope_Record := + SPARK_Scope_Table.Table (Index); pragma Unreferenced (Dummy); begin return True; @@ -511,8 +511,8 @@ package body Alfa is -- Start of processing for Is_Future_Scope_Entity begin - for Index in S .. Alfa_Scope_Table.Last loop - if Alfa_Scope_Table.Table (Index).Scope_Entity = E then + for Index in S .. SPARK_Scope_Table.Last loop + if SPARK_Scope_Table.Table (Index).Scope_Entity = E then return True; end if; end loop; @@ -663,8 +663,8 @@ package body Alfa is To : Xref_Index) is begin - Alfa_Scope_Table.Table (S).From_Xref := From; - Alfa_Scope_Table.Table (S).To_Xref := To; + SPARK_Scope_Table.Table (S).From_Xref := From; + SPARK_Scope_Table.Table (S).To_Xref := To; end Update_Scope_Range; -- Local variables @@ -679,12 +679,12 @@ package body Alfa is Ref_Name : String_Ptr; Scope_Id : Scope_Index; - -- Start of processing for Add_Alfa_Xrefs + -- Start of processing for Add_SPARK_Xrefs begin - for Index in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop + for Index in SPARK_Scope_Table.First .. SPARK_Scope_Table.Last loop declare - S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); + S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (Index); begin Set_Scope_Num (S.Scope_Entity, S.Scope_Num); end; @@ -710,7 +710,7 @@ package body Alfa is Xrefs.Table (Index).Def := Sloc (Xrefs.Table (Index).Key.Ent); end loop; - -- Eliminate entries not appropriate for Alfa. Done prior to sorting + -- Eliminate entries not appropriate for SPARK. Done prior to sorting -- cross-references, as it discards useless references which do not have -- a proper format for the comparison function (like no location). @@ -722,12 +722,12 @@ package body Alfa is Ref : Xref_Key renames Xrefs.Table (Rnums (Index)).Key; begin - if Alfa_Entities (Ekind (Ref.Ent)) - and then Alfa_References (Ref.Typ) - and then Is_Alfa_Scope (Ref.Ent_Scope) - and then Is_Alfa_Scope (Ref.Ref_Scope) + if SPARK_Entities (Ekind (Ref.Ent)) + and then SPARK_References (Ref.Typ) + and then Is_SPARK_Scope (Ref.Ent_Scope) + and then Is_SPARK_Scope (Ref.Ref_Scope) and then not Is_Global_Constant (Ref.Ent) - and then Is_Alfa_Reference (Ref.Ent, Ref.Typ) + and then Is_SPARK_Reference (Ref.Ent, Ref.Typ) -- Discard references from unknown scopes, e.g. generic scopes @@ -791,7 +791,7 @@ package body Alfa is -- The two steps have eliminated all references, nothing to do - if Alfa_Scope_Table.Last = 0 then + if SPARK_Scope_Table.Last = 0 then return; end if; @@ -808,7 +808,7 @@ package body Alfa is begin -- If this assertion fails, the scope which we are looking for is - -- not in Alfa scope table, which reveals either a problem in the + -- not in SPARK scope table, which reveals either a problem in the -- construction of the scope table, or an erroneous scope for the -- current cross-reference. @@ -822,14 +822,14 @@ package body Alfa is Update_Scope_Range (S => Scope_Id, From => From_Index, - To => Alfa_Xref_Table.Last); + To => SPARK_Xref_Table.Last); - From_Index := Alfa_Xref_Table.Last + 1; + From_Index := SPARK_Xref_Table.Last + 1; end if; while Ref.Ent_Scope /= Entity_Of_Scope (Scope_Id) loop Scope_Id := Scope_Id + 1; - pragma Assert (Scope_Id <= Alfa_Scope_Table.Last); + pragma Assert (Scope_Id <= SPARK_Scope_Table.Last); end loop; if Ref.Ent /= Ref_Id then @@ -844,7 +844,7 @@ package body Alfa is Col := Int (Get_Column_Number (Ref_Entry.Def)); end if; - Alfa_Xref_Table.Append ( + SPARK_Xref_Table.Append ( (Entity_Name => Ref_Name, Entity_Line => Line, Etype => Get_Entity_Type (Ref.Ent), @@ -862,14 +862,17 @@ package body Alfa is Update_Scope_Range (S => Scope_Id, From => From_Index, - To => Alfa_Xref_Table.Last); - end Add_Alfa_Xrefs; + To => SPARK_Xref_Table.Last); + end Add_SPARK_Xrefs; - ------------------ - -- Collect_Alfa -- - ------------------ + ------------------------- + -- Collect_SPARK_Xrefs -- + ------------------------- - procedure Collect_Alfa (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat) is + procedure Collect_SPARK_Xrefs + (Sdep_Table : Unit_Ref_Table; + Num_Sdep : Nat) + is D1 : Nat; D2 : Nat; @@ -878,9 +881,9 @@ package body Alfa is pragma Assert (Xrefs.Last /= 0); - Initialize_Alfa_Tables; + Initialize_SPARK_Tables; - -- Generate file and scope Alfa information + -- Generate file and scope SPARK cross-reference information D1 := 1; while D1 <= Num_Sdep loop @@ -888,7 +891,7 @@ package body Alfa is -- In rare cases, when treating the library-level instantiation of a -- generic, two consecutive units refer to the same compilation unit -- node and entity. In that case, treat them as a single unit for the - -- sake of Alfa cross references by passing to Add_Alfa_File. + -- sake of SPARK cross references by passing to Add_SPARK_File. if D1 < Num_Sdep and then Cunit_Entity (Sdep_Table (D1)) = @@ -899,7 +902,7 @@ package body Alfa is D2 := D1; end if; - Add_Alfa_File + Add_SPARK_File (Ubody => Sdep_Table (D1), Uspec => Sdep_Table (D2), Dspec => D2); @@ -921,9 +924,9 @@ package body Alfa is begin -- Fill in the hash-table - for S in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop + for S in SPARK_Scope_Table.First .. SPARK_Scope_Table.Last loop declare - Srec : Alfa_Scope_Record renames Alfa_Scope_Table.Table (S); + Srec : SPARK_Scope_Record renames SPARK_Scope_Table.Table (S); begin Entity_Hash_Table.Set (Srec.Scope_Entity, S); end; @@ -931,9 +934,9 @@ package body Alfa is -- Use the hash-table to locate spec entities - for S in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop + for S in SPARK_Scope_Table.First .. SPARK_Scope_Table.Last loop declare - Srec : Alfa_Scope_Record renames Alfa_Scope_Table.Table (S); + Srec : SPARK_Scope_Record renames SPARK_Scope_Table.Table (S); Spec_Entity : constant Entity_Id := Unique_Entity (Srec.Scope_Entity); @@ -947,24 +950,24 @@ package body Alfa is and then Spec_Scope /= 0 then Srec.Spec_File_Num := - Alfa_Scope_Table.Table (Spec_Scope).File_Num; + SPARK_Scope_Table.Table (Spec_Scope).File_Num; Srec.Spec_Scope_Num := - Alfa_Scope_Table.Table (Spec_Scope).Scope_Num; + SPARK_Scope_Table.Table (Spec_Scope).Scope_Num; end if; end; end loop; end; - -- Generate cross reference Alfa information + -- Generate SPARK cross-reference information - Add_Alfa_Xrefs; - end Collect_Alfa; + Add_SPARK_Xrefs; + end Collect_SPARK_Xrefs; - ------------------------------- - -- Detect_And_Add_Alfa_Scope -- - ------------------------------- + -------------------------------- + -- Detect_And_Add_SPARK_Scope -- + -------------------------------- - procedure Detect_And_Add_Alfa_Scope (N : Node_Id) is + procedure Detect_And_Add_SPARK_Scope (N : Node_Id) is begin if Nkind_In (N, N_Subprogram_Declaration, N_Subprogram_Body, @@ -972,9 +975,9 @@ package body Alfa is N_Package_Declaration, N_Package_Body) then - Add_Alfa_Scope (N); + Add_SPARK_Scope (N); end if; - end Detect_And_Add_Alfa_Scope; + end Detect_And_Add_SPARK_Scope; ------------------------------------- -- Enclosing_Subprogram_Or_Package -- @@ -1432,4 +1435,4 @@ package body Alfa is (Handled_Statement_Sequence (N), Process, Inside_Stubs); end Traverse_Subprogram_Body; -end Alfa; +end SPARK_Specific; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 2f01dd4480f..8825f066f4e 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -79,7 +79,7 @@ package body Lib.Xref is -- Unit number corresponding to Loc. Value is undefined and not -- referenced if Loc is set to No_Location. - -- The following components are only used for Alfa cross-references + -- The following components are only used for SPARK cross-references Ref_Scope : Entity_Id; -- Entity of the closest subprogram or package enclosing the reference @@ -151,11 +151,11 @@ package body Lib.Xref is Hash => Hash, Equal => Equal); - ---------------------- - -- Alfa Information -- - ---------------------- + ----------------------------- + -- SPARK Xrefs Information -- + ----------------------------- - package body Alfa is separate; + package body SPARK_Specific is separate; ------------------------ -- Local Subprograms -- @@ -516,11 +516,9 @@ package body Lib.Xref is P := Parent (P); if Nkind (P) = N_Pragma then - if Pragma_Name (P) = Name_Warnings - or else - Pragma_Name (P) = Name_Unmodified - or else - Pragma_Name (P) = Name_Unreferenced + if Nam_In (Pragma_Name (P), Name_Warnings, + Name_Unmodified, + Name_Unreferenced) then return False; end if; @@ -634,10 +632,10 @@ package body Lib.Xref is or else (Typ = 'b' and then Is_Generic_Instance (E)) -- Allow the generation of references to reads, writes and calls - -- in Alfa mode when the related context comes from an instance. + -- in SPARK mode when the related context comes from an instance. or else - (Alfa_Mode + (SPARK_Mode and then In_Extended_Main_Code_Unit (N) and then (Typ = 'm' or else Typ = 'r' or else Typ = 's')) then @@ -887,12 +885,12 @@ package body Lib.Xref is -- Ignore references from within an instance. The only exceptions to -- this are default subprograms, for which we generate an implicit - -- reference and compilations in Alfa_Mode. + -- reference and compilations in SPARK mode. and then (Instantiation_Location (Sloc (N)) = No_Location or else Typ = 'i' - or else Alfa_Mode) + or else SPARK_Mode) -- Ignore dummy references @@ -975,11 +973,11 @@ package body Lib.Xref is return; end if; - -- In Alfa mode, consider the underlying entity renamed instead of + -- In SPARK mode, consider the underlying entity renamed instead of -- the renaming, which is needed to compute a valid set of effects -- (reads, writes) for the enclosing subprogram. - if Alfa_Mode then + if SPARK_Mode then Ent := Get_Through_Renamings (Ent); -- If no enclosing object, then it could be a reference to any @@ -989,10 +987,10 @@ package body Lib.Xref is if No (Ent) then if Actual_Typ = 'w' then - Alfa.Generate_Dereference (Nod, 'r'); - Alfa.Generate_Dereference (Nod, 'w'); + SPARK_Specific.Generate_Dereference (Nod, 'r'); + SPARK_Specific.Generate_Dereference (Nod, 'w'); else - Alfa.Generate_Dereference (Nod, 'r'); + SPARK_Specific.Generate_Dereference (Nod, 'r'); end if; return; @@ -1008,14 +1006,14 @@ package body Lib.Xref is Actual_Typ := 'P'; end if; - if Alfa_Mode then + if SPARK_Mode then Ref := Sloc (Nod); Def := Sloc (Ent); - Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (Nod); - Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent); + Ref_Scope := SPARK_Specific.Enclosing_Subprogram_Or_Package (Nod); + Ent_Scope := SPARK_Specific.Enclosing_Subprogram_Or_Package (Ent); - -- Since we are reaching through renamings in Alfa mode, we may + -- Since we are reaching through renamings in SPARK mode, we may -- end up with standard constants. Ignore those. if Sloc (Ent_Scope) <= Standard_Location @@ -1364,6 +1362,23 @@ package body Lib.Xref is then Tref := Etype (Tref); + -- Another special case: an object of a classwide type + -- initialized with a tag-indeterminate call gets a subtype + -- of the classwide type during expansion. See if the original + -- type in the declaration is named, and return it instead + -- of going to the root type. + + if Ekind (Tref) = E_Class_Wide_Subtype + and then Nkind (Parent (Ent)) = N_Object_Declaration + and then + Nkind (Original_Node (Object_Definition (Parent (Ent)))) + = N_Identifier + then + Tref := + Entity + (Original_Node ((Object_Definition (Parent (Ent))))); + end if; + -- For anything else, exit else @@ -2047,8 +2062,8 @@ package body Lib.Xref is Ctyp := '*'; end if; - -- Special handling for access parameters and objects of - -- an anonymous access type. + -- Special handling for access parameters and objects and + -- components of an anonymous access type. if Ekind_In (Etype (XE.Key.Ent), E_Anonymous_Access_Type, @@ -2056,7 +2071,9 @@ package body Lib.Xref is E_Anonymous_Access_Protected_Subprogram_Type) then if Is_Formal (XE.Key.Ent) - or else Ekind_In (XE.Key.Ent, E_Variable, E_Constant) + or else + Ekind_In + (XE.Key.Ent, E_Variable, E_Constant, E_Component) then Ctyp := 'p'; end if; diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index 00d72c12a05..cfb43d8b1dc 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -26,9 +26,9 @@ -- This package contains for collecting and outputting cross-reference -- information. -with Einfo; use Einfo; -with Lib.Util; use Lib.Util; -with Put_Alfa; +with Einfo; use Einfo; +with Lib.Util; use Lib.Util; +with Put_SPARK_Xrefs; package Lib.Xref is @@ -599,14 +599,14 @@ package Lib.Xref is -- Export at line 4, that its body is exported to C, and that the link name -- as given in the pragma is "here". - ---------------------- - -- Alfa Information -- - ---------------------- + ----------------------------- + -- SPARK Xrefs Information -- + ----------------------------- - -- This package defines procedures for collecting Alfa information and - -- printing in ALI files. + -- This package defines procedures for collecting SPARK cross-reference + -- information and printing in ALI files. - package Alfa is + package SPARK_Specific is function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id; -- Return the closest enclosing subprogram of package @@ -631,17 +631,19 @@ package Lib.Xref is -- Call Process on all declarations through all compilation units. -- Generic declarations are ignored. - procedure Collect_Alfa (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat); - -- Collect Alfa information from library units (for files and scopes) - -- and from cross-references. Fill in the tables in library package - -- called Alfa. + procedure Collect_SPARK_Xrefs + (Sdep_Table : Unit_Ref_Table; + Num_Sdep : Nat); + -- Collect SPARK cross-reference information from library units (for + -- files and scopes) and from shared cross-references. Fill in the + -- tables in library package called SPARK_Xrefs. - procedure Output_Alfa is new Put_Alfa; - -- Output Alfa information to the ALI files, based on the information - -- collected in the tables in library package called Alfa, and using - -- routines in Lib.Util. + procedure Output_SPARK_Xrefs is new Put_SPARK_Xrefs; + -- Output SPARK cross-reference information to the ALI files, based on + -- the information collected in the tables in library package called + -- SPARK_Xrefs, and using routines in Lib.Util. - end Alfa; + end SPARK_Specific; ----------------- -- Subprograms -- diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 27d0f697e98..d9973b52a0b 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -1321,8 +1321,8 @@ package body Make is then Errutil.Error_Msg ('"' & Argv & - """ is not a gnatmake switch. Consider moving " & - "it to Global_Compilation_Switches.", + """ is not a gnatmake switch. Consider moving " + & "it to Global_Compilation_Switches.", Element.Location); Make_Failed ("*** illegal switch """ & Argv & """"); end if; @@ -2982,8 +2982,8 @@ package body Make is Make_Failed ("not allowed to compile """ & Get_Name_String (Fname) & - """; use -a switch, or compile file with " & - """-gnatg"" switch"); + """; use -a switch, or use the compiler directly with " + & "the ""-gnatg"" switch"); end if; end if; end; @@ -3449,8 +3449,8 @@ package body Make is Fail ("not allowed to compile """ & Get_Name_String (Source.File) & - """; use -a switch, or compile file with " & - """-gnatg"" switch"); + """; use -a switch, or use the compiler directly with " + & "the ""-gnatg"" switch"); end if; Verbose_Msg @@ -3841,7 +3841,7 @@ package body Make is Last := 1; Result (1) := new String' - ("-gnatec=" & Get_Name_String (For_Project.Config_File_Name)); + ("-gnatec=" & Get_Name_String (For_Project.Config_File_Name)); else Temporary_Config_File := False; @@ -4233,8 +4233,7 @@ package body Make is (Index).Library_Dir.Display_Name) & "lib" & Get_Name_String - (Library_Projs.Table - (Index).Library_Name) & + (Library_Projs.Table (Index).Library_Name) & "." & MLib.Tgt.Archive_Ext); @@ -4244,9 +4243,8 @@ package body Make is Linker_Switches.Increment_Last; Linker_Switches.Table (Linker_Switches.Last) := new String'("-L" & - Get_Name_String - (Library_Projs.Table (Index). - Library_Dir.Display_Name)); + Get_Name_String (Library_Projs.Table (Index). + Library_Dir.Display_Name)); -- Add the -l switch @@ -4254,8 +4252,7 @@ package body Make is Linker_Switches.Table (Linker_Switches.Last) := new String'("-l" & Get_Name_String - (Library_Projs.Table (Index). - Library_Name)); + (Library_Projs.Table (Index).Library_Name)); end if; end if; end loop; @@ -5478,7 +5475,6 @@ package body Make is -- is invoked with the -F switch to force checking of elaboration flags. Project_Node_Tree : Project_Node_Tree_Ref; - Root_Environment : Prj.Tree.Environment; Stop_Compile : Boolean; @@ -5592,8 +5588,8 @@ package body Make is -- No main program may be specified on the command line elsif Osint.Number_Of_Files /= 0 then - Make_Failed ("-B cannot be used with a main specified on " & - "the command line"); + Make_Failed + ("-B cannot be used with a main specified on the command line"); -- And the project file cannot be a library project file @@ -5641,8 +5637,9 @@ package body Make is and then not Unique_Compile and then ((not Make_Steps) or else Bind_Only or else Link_Only) then - Make_Failed ("cannot specify a main program " & - "on the command line for a library project file"); + Make_Failed + ("cannot specify a main program " + & "on the command line for a library project file"); end if; -- If no mains have been specified on the command line, and we are @@ -5652,8 +5649,8 @@ package body Make is else if Main_Index /= 0 then - Make_Failed ("cannot specify a multi-unit index but no main " & - "on the command line"); + Make_Failed ("cannot specify a multi-unit index but no main " + & "on the command line"); end if; declare @@ -5879,9 +5876,10 @@ package body Make is Add_Switch ("-I" & Normalize_Directory_Name - (Get_Primary_Src_Search_Directory.all).all, - Compiler, Append_Switch => False, - And_Save => False); + (Get_Primary_Src_Search_Directory.all).all, + Compiler, + Append_Switch => False, + And_Save => False); end if; @@ -6393,8 +6391,6 @@ package body Make is -- the command line switches Prj.Tree.Initialize (Env, Gnatmake_Flags); - Prj.Env.Initialize_Default_Project_Path - (Env.Project_Path, Target_Name => Sdefault.Target_Name.all); Project_Node_Tree := new Project_Node_Tree_Data; Prj.Tree.Initialize (Project_Node_Tree); @@ -6440,9 +6436,8 @@ package body Make is if Prefix'Length > 0 then declare PATH : constant String := - Prefix & Directory_Separator & "bin" & - Path_Separator & - Getenv ("PATH").all; + Prefix & Directory_Separator & "bin" & Path_Separator & + Getenv ("PATH").all; begin Setenv ("PATH", PATH); end; @@ -6494,6 +6489,12 @@ package body Make is Usage; end if; + -- Add the default project search directories now, after the directories + -- that have been specified by switches -aP<dir>. + + Prj.Env.Initialize_Default_Project_Path + (Env.Project_Path, Target_Name => Sdefault.Target_Name.all); + -- Test for trailing -P switch if Project_File_Name_Present and then Project_File_Name = null then @@ -7423,8 +7424,8 @@ package body Make is elsif Program_Args = Linker and then Argv = "-o" then - Make_Failed ("switch -o not allowed within a -largs. " & - "Use -o directly."); + Make_Failed + ("switch -o not allowed within a -largs. Use -o directly."); -- Check to see if we are reading switches after a -cargs, -bargs or -- -largs switch. If so, save it. @@ -7573,16 +7574,16 @@ package body Make is elsif Src_Path_Name = null and then Lib_Path_Name = null then - Make_Failed ("RTS path not valid: missing " & - "adainclude and adalib directories"); + Make_Failed ("RTS path not valid: missing " + & "adainclude and adalib directories"); elsif Src_Path_Name = null then - Make_Failed ("RTS path not valid: missing adainclude " & - "directory"); + Make_Failed ("RTS path not valid: missing adainclude " + & "directory"); elsif Lib_Path_Name = null then - Make_Failed ("RTS path not valid: missing adalib " & - "directory"); + Make_Failed ("RTS path not valid: missing adalib " + & "directory"); end if; end; end if; @@ -7820,8 +7821,8 @@ package body Make is -- or a -P switch inside a project file. Fail - ("either the tool is not ""project-aware"" or " & - "a project file is specified inside a project file"); + ("either the tool is not ""project-aware"" or " + & "a project file is specified inside a project file"); elsif Argv'Last = 2 then diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 6d33aaacca7..aef82cba856 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -369,12 +369,12 @@ package body Makeutl is Status : Boolean; -- For call to Close - Iter : Source_Iterator := - For_Each_Source - (In_Tree => Project_Tree, - Language => Name_Ada, - Encapsulated_Libs => False, - Locally_Removed => False); + Iter : Source_Iterator := For_Each_Source + (In_Tree => Project_Tree, + Language => Name_Ada, + Encapsulated_Libs => False, + Locally_Removed => False); + Source : Prj.Source_Id; begin @@ -390,7 +390,10 @@ package body Makeutl is Unit := Source.Unit; - if Unit = No_Unit_Index or else Unit.Name = No_Name then + if Source.Replaced_By /= No_Source + or else Unit = No_Unit_Index + or else Unit.Name = No_Name + then ALI_Name := No_File; -- If this is a body, put it in the mapping @@ -431,13 +434,14 @@ package body Makeutl is -- found. if ALI_Name /= No_File then + -- Look in the project and the projects that are extending it -- to find the real ALI file. declare - ALI : constant String := Get_Name_String (ALI_Name); + ALI : constant String := Get_Name_String (ALI_Name); + ALI_Path : Name_Id := No_Name; - ALI_Path : Name_Id := No_Name; begin loop -- For library projects, use the library ALI directory, @@ -462,6 +466,7 @@ package body Makeutl is end loop; if ALI_Path /= No_Name then + -- First line is the unit name Get_Name_String (ALI_Unit); @@ -475,7 +480,7 @@ package body Makeutl is exit when not OK; - -- Second line it the ALI file name + -- Second line is the ALI file name Get_Name_String (ALI_Name); Add_Char_To_Name_Buffer (ASCII.LF); @@ -488,7 +493,7 @@ package body Makeutl is exit when not OK; - -- Third line it the ALI path name + -- Third line is the ALI path name Get_Name_String (ALI_Path); Add_Char_To_Name_Buffer (ASCII.LF); @@ -576,8 +581,9 @@ package body Makeutl is if Sw'Length >= 3 and then (Sw (2) = 'I' or else (not For_Gnatbind - and then (Sw (2) = 'L' - or else Sw (2) = 'A'))) + and then (Sw (2) = 'L' + or else + Sw (2) = 'A'))) then Start := 3; @@ -592,7 +598,7 @@ package body Makeutl is or else Sw (2 .. 3) = "aI" or else - (For_Gnatbind and then Sw (2 .. 3) = "A=")) + (For_Gnatbind and then Sw (2 .. 3) = "A=")) then Start := 4; @@ -1250,56 +1256,56 @@ package body Makeutl is Obj_Proj := Source.Project; while Obj_Proj /= No_Project loop - declare - Dir : constant String := - Get_Name_String - (Obj_Proj.Object_Directory.Display_Name); + if Obj_Proj.Object_Directory /= No_Path_Information then + declare + Dir : constant String := + Get_Name_String (Obj_Proj.Object_Directory.Display_Name); - Object_Path : constant String := - Normalize_Pathname - (Name => - Get_Name_String (Source.Object), - Resolve_Links => Opt.Follow_Links_For_Files, - Directory => Dir); + Object_Path : constant String := + Normalize_Pathname + (Name => Get_Name_String (Source.Object), + Resolve_Links => Opt.Follow_Links_For_Files, + Directory => Dir); - Obj_Path : constant Path_Name_Type := Create_Name (Object_Path); - Stamp : Time_Stamp_Type := Empty_Time_Stamp; + Obj_Path : constant Path_Name_Type := + Create_Name (Object_Path); - begin - -- For specs, we do not check object files if there is a body. - -- This saves a system call. On the other hand, we do need to - -- know the object_path, in case the user has passed the .ads - -- on the command line to compile the spec only. - - if Source.Kind /= Spec - or else Source.Unit = No_Unit_Index - or else Source.Unit.File_Names (Impl) = No_Source - then - Stamp := File_Stamp (Obj_Path); - end if; + Stamp : Time_Stamp_Type := Empty_Time_Stamp; - if Stamp /= Empty_Time_Stamp - or else (Obj_Proj.Extended_By = No_Project - and then Source.Object_Project = No_Project) - then - Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp); - end if; + begin + -- For specs, we do not check object files if there is a + -- body. This saves a system call. On the other hand, we do + -- need to know the object_path, in case the user has passed + -- the .ads on the command line to compile the spec only. + + if Source.Kind /= Spec + or else Source.Unit = No_Unit_Index + or else Source.Unit.File_Names (Impl) = No_Source + then + Stamp := File_Stamp (Obj_Path); + end if; - Obj_Proj := Obj_Proj.Extended_By; - end; + if Stamp /= Empty_Time_Stamp + or else (Obj_Proj.Extended_By = No_Project + and then Source.Object_Project = No_Project) + then + Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp); + end if; + end; + end if; + + Obj_Proj := Obj_Proj.Extended_By; end loop; elsif Source.Language.Config.Dependency_Kind = Makefile then declare Object_Dir : constant String := - Get_Name_String - (Source.Project.Object_Directory.Display_Name); + Get_Name_String (Source.Project.Object_Directory.Display_Name); Dep_Path : constant String := - Normalize_Pathname - (Name => Get_Name_String (Source.Dep_Name), - Resolve_Links => - Opt.Follow_Links_For_Files, - Directory => Object_Dir); + Normalize_Pathname + (Name => Get_Name_String (Source.Dep_Name), + Resolve_Links => Opt.Follow_Links_For_Files, + Directory => Object_Dir); begin Source.Dep_Path := Create_Name (Dep_Path); Source.Dep_TS := Osint.Unknown_Attributes; @@ -1317,8 +1323,8 @@ package body Makeutl is (Env : Prj.Tree.Environment; Argv : String) return Boolean is - Start : Positive := 3; - Finish : Natural := Argv'Last; + Start : Positive := 3; + Finish : Natural := Argv'Last; pragma Assert (Argv'First = 1); pragma Assert (Argv (1 .. 2) = "-X"); diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 2842dfd4e81..1cebb464b8e 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.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- -- @@ -1039,6 +1039,100 @@ package body Namet is end if; end Name_Find; + ------------- + -- Nam_In -- + ------------- + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id) return Boolean + is + begin + return T = V1 or else + T = V2; + end Nam_In; + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3; + end Nam_In; + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id; + V4 : Name_Id) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4; + end Nam_In; + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id; + V4 : Name_Id; + V5 : Name_Id) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5; + end Nam_In; + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id; + V4 : Name_Id; + V5 : Name_Id; + V6 : Name_Id) 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; + end Nam_In; + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id; + V4 : Name_Id; + V5 : Name_Id; + V6 : Name_Id; + V7 : Name_Id) 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 Nam_In; + ------------------ -- Reinitialize -- ------------------ diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index e8978f8b52f..dcce9ea91c9 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.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- -- @@ -165,6 +165,65 @@ package Namet is First_Name_Id : constant Name_Id := Names_Low_Bound + 2; -- Subscript of first entry in names table + ------------------------------ + -- Name_Id Membership Tests -- + ------------------------------ + + -- The following functions allow a convenient notation for testing whether + -- a Name_Id value matches any one of a list of possible values. In each + -- case True is returned if the given T argument is equal to any of the V + -- arguments. These essentially duplicate the Ada 2012 membership tests, + -- but we cannot use the latter (yet) in the compiler front end, because + -- of bootstrap considerations + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id) return Boolean; + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id) return Boolean; + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id; + V4 : Name_Id) return Boolean; + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id; + V4 : Name_Id; + V5 : Name_Id) return Boolean; + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id; + V4 : Name_Id; + V5 : Name_Id; + V6 : Name_Id) return Boolean; + + function Nam_In + (T : Name_Id; + V1 : Name_Id; + V2 : Name_Id; + V3 : Name_Id; + V4 : Name_Id; + V5 : Name_Id; + V6 : Name_Id; + V7 : Name_Id) return Boolean; + + pragma Inline (Nam_In); + -- Inline all above functions + ----------------- -- Subprograms -- ----------------- diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index 453e665eccc..41b5ac2e08c 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.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- -- @@ -987,21 +987,6 @@ package body Nlists is return Int (Lists.Last) - Int (Lists.First) + 1; end Num_Lists; - ------- - -- p -- - ------- - - function p (U : Union_Id) return Node_Or_Entity_Id is - begin - if U in Node_Range then - return Parent (Node_Or_Entity_Id (U)); - elsif U in List_Range then - return Parent (List_Id (U)); - else - return 99_999_999; - end if; - end p; - ------------ -- Parent -- ------------ diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index 10c04ed9021..5fd66ded7ff 100644 --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.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- -- @@ -363,12 +363,4 @@ package Nlists is -- These functions return the addresses of the Next_Node and Prev_Node -- tables (used in Back_End for Gigi). - function p (U : Union_Id) return Node_Or_Entity_Id; - -- This function is intended for use from the debugger, it determines - -- whether U is a Node_Id or List_Id, and calls the appropriate Parent - -- function and returns the parent Node in either case. This is shorter - -- to type, and avoids the overloading problem of using Parent. It - -- should NEVER be used except from the debugger. If p is called with - -- other than a node or list id value, it returns 99_999_999. - end Nlists; diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index 98eab409877..1fc43cc203e 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.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- -- @@ -44,7 +44,7 @@ package body Opt is function Full_Expander_Active return Boolean is begin - return Expander_Active and not Alfa_Mode; + return Expander_Active and not SPARK_Mode; end Full_Expander_Active; ---------------------------------- @@ -59,8 +59,6 @@ package body Opt is Assume_No_Invalid_Values_Config := Assume_No_Invalid_Values; Check_Float_Overflow_Config := Check_Float_Overflow; Check_Policy_List_Config := Check_Policy_List; - Debug_Pragmas_Disabled_Config := Debug_Pragmas_Disabled; - Debug_Pragmas_Enabled_Config := Debug_Pragmas_Enabled; Default_Pool_Config := Default_Pool; Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks; Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed; @@ -94,8 +92,6 @@ package body Opt is Assume_No_Invalid_Values := Save.Assume_No_Invalid_Values; Check_Float_Overflow := Save.Check_Float_Overflow; Check_Policy_List := Save.Check_Policy_List; - Debug_Pragmas_Disabled := Save.Debug_Pragmas_Disabled; - Debug_Pragmas_Enabled := Save.Debug_Pragmas_Enabled; Default_Pool := Save.Default_Pool; Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks; Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed; @@ -131,8 +127,6 @@ package body Opt is Save.Assume_No_Invalid_Values := Assume_No_Invalid_Values; Save.Check_Float_Overflow := Check_Float_Overflow; Save.Check_Policy_List := Check_Policy_List; - Save.Debug_Pragmas_Disabled := Debug_Pragmas_Disabled; - Save.Debug_Pragmas_Enabled := Debug_Pragmas_Enabled; Save.Default_Pool := Default_Pool; Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks; Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed; @@ -183,14 +177,10 @@ package body Opt is if Main_Unit then Assertions_Enabled := Assertions_Enabled_Config; Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config; - Debug_Pragmas_Disabled := Debug_Pragmas_Disabled_Config; - Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; Check_Policy_List := Check_Policy_List_Config; else Assertions_Enabled := False; Assume_No_Invalid_Values := False; - Debug_Pragmas_Disabled := False; - Debug_Pragmas_Enabled := False; Check_Policy_List := Empty; end if; @@ -203,8 +193,6 @@ package body Opt is Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config; Check_Float_Overflow := Check_Float_Overflow_Config; Check_Policy_List := Check_Policy_List_Config; - Debug_Pragmas_Disabled := Debug_Pragmas_Disabled_Config; - Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config; Extensions_Allowed := Extensions_Allowed_Config; External_Name_Exp_Casing := External_Name_Exp_Casing_Config; @@ -261,8 +249,6 @@ package body Opt is Tree_Read_Bool (Assertions_Enabled); Tree_Read_Bool (Check_Float_Overflow); Tree_Read_Int (Int (Check_Policy_List)); - Tree_Read_Bool (Debug_Pragmas_Disabled); - Tree_Read_Bool (Debug_Pragmas_Enabled); Tree_Read_Int (Int (Default_Pool)); Tree_Read_Bool (Full_List); @@ -328,8 +314,6 @@ package body Opt is Tree_Write_Bool (Assertions_Enabled); Tree_Write_Bool (Check_Float_Overflow); Tree_Write_Int (Int (Check_Policy_List)); - Tree_Write_Bool (Debug_Pragmas_Disabled); - Tree_Write_Bool (Debug_Pragmas_Enabled); Tree_Write_Int (Int (Default_Pool)); Tree_Write_Bool (Full_List); Tree_Write_Int (Int (Version_String'Length)); diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 9beeb583523..01cbad1fc9a 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -119,14 +119,11 @@ package Opt is -- Think twice before using "="; Ada_Version >= Ada_2012 is more likely -- what you want, because it will apply to future versions of the language. - Ada_Version_Default : constant Ada_Version_Type := Ada_2005; + Ada_Version_Default : constant Ada_Version_Type := Ada_2012; pragma Warnings (Off, Ada_Version_Default); -- GNAT -- Default Ada version if no switch given. The Warnings off is to kill -- constant condition warnings. - -- - -- WARNING: some scripts rely on the format of this line of code. Any - -- change must be coordinated with the scripts requirements. Ada_Version : Ada_Version_Type := Ada_Version_Default; -- GNAT @@ -209,7 +206,10 @@ package Opt is Assertions_Enabled : Boolean := False; -- GNAT - -- Enable assertions made using pragma Assert + -- Indicates default policy (True = Check, False = Ignore) to be applied + -- to all assertion aspects and pragmas, and to pragma Debug, if there is + -- no overriding Assertion_Policy, Check_Policy, or Debug_Policy pragma. + -- Set True by use of -gnata. Assume_No_Invalid_Values : Boolean := False; -- GNAT Normally, in accordance with (RM 13.9.1 (9-11)) the front end @@ -285,13 +285,13 @@ package Opt is Check_Object_Consistency : Boolean := False; -- GNATBIND, GNATMAKE - -- Set to True to check whether every object file is consistent with - -- its corresponding ada library information (ALI) file. An object - -- file is inconsistent with the corresponding ALI file if the object - -- file does not exist or if it has an older time stamp than the ALI file. - -- Default above is for GNATBIND. GNATMAKE overrides this default to - -- True (see Make.Initialize) since we normally do need to check source - -- consistencies in gnatmake. + -- Set to True to check whether every object file is consistent with its + -- corresponding ada library information (ALI) file. An object file is + -- inconsistent with the corresponding ALI file if the object file does + -- not exist or if it has an older time stamp than the ALI file. Default + -- above is for GNATBIND. GNATMAKE overrides this default to True (see + -- Make.Initialize) since we normally do need to check source consistencies + -- in gnatmake. Check_Only : Boolean := False; -- GNATBIND @@ -304,7 +304,7 @@ package Opt is -- terminated by Empty. The order is most recently processed first. Note -- that Push_Scope and Pop_Scope in Sem_Ch8 save and restore the value -- of this variable, implementing the required scope control for pragmas - -- appearing a declarative part. + -- appearing in a declarative part. Check_Readonly_Files : Boolean := False; -- GNATMAKE @@ -344,7 +344,7 @@ package Opt is -- Modified by use of -gnatwu/U. CodePeer_Mode : Boolean := False; - -- GNAT, GNATBIND + -- GNAT, GNATBIND, GPRBUILD -- Enable full CodePeer mode (SCIL generation, disable switches that -- interact badly with it, etc...). @@ -391,14 +391,6 @@ package Opt is -- Set to True (-C switch) to indicate that the compiler will be invoked -- with a mapping file (-gnatem compiler switch). - Debug_Pragmas_Enabled : Boolean := False; - -- GNAT - -- Enable debug statements from pragma Debug - - Debug_Pragmas_Disabled : Boolean := False; - -- GNAT - -- Debug pragmas completely disabled (no semantic checking) - subtype Debug_Level_Value is Nat range 0 .. 3; Debugger_Level : Debug_Level_Value := 0; -- GNATBIND @@ -447,6 +439,10 @@ package Opt is -- Set True to force the run time to raise Program_Error if calls to -- potentially blocking operations are detected from protected actions. + Directories_Must_Exist_In_Projects : Boolean := True; + -- PROJECT MANAGER + -- Set to False with switch -f of gnatclean and gprclean + Display_Compilation_Progress : Boolean := False; -- GNATMAKE, GPRMAKE, GPRBUILD -- Set True (-d switch) to display information on progress while compiling @@ -600,26 +596,25 @@ package Opt is Fast_Math : Boolean := False; -- GNAT -- Indicates the current setting of Fast_Math mode, as set by the use - -- of a Fast_Math pragma (set on by Fast_Math (On)). + -- of a Fast_Math pragma (set True by Fast_Math (On)). Float_Format : Character := ' '; -- GNAT -- A non-blank value indicates that a Float_Format pragma has been - -- processed, in which case this variable is set to 'I' for IEEE or - -- to 'V' for VAX. The setting of 'V' is only possible on OpenVMS - -- versions of GNAT. + -- processed, in which case this variable is set to 'I' for IEEE or to + -- 'V' for VAX. The setting of 'V' is only possible on OpenVMS versions + -- of GNAT. Float_Format_Long : Character := ' '; -- GNAT - -- A non-blank value indicates that a Long_Float pragma has been - -- processed (this pragma is recognized only in OpenVMS versions - -- of GNAT), in which case this variable is set to D or G for - -- D_Float or G_Float. + -- A non-blank value indicates that a Long_Float pragma has been processed + -- (this pragma is recognized only in OpenVMS versions of GNAT), in which + -- case this variable is set to D or G for D_Float or G_Float. Force_ALI_Tree_File : Boolean := False; -- GNAT - -- Force generation of ALI file even if errors are encountered. - -- Also forces generation of tree file if -gnatt is also set. + -- Force generation of ALI file even if errors are encountered. Also forces + -- generation of tree file if -gnatt is also set. Set on by use of -gnatQ. Disable_ALI_File : Boolean := False; -- GNAT @@ -667,11 +662,6 @@ package Opt is -- True when switch -fdebug-instances is used. When True, a table of -- instances is included in SCOs. - Generate_Target_Dependent_Info : Boolean := False; - -- GNAT - -- When true (-gnatet switch used). True if target dependent info is to be - -- generated in the ali file. - Generating_Code : Boolean := False; -- GNAT -- True if the frontend finished its work and has called the backend to @@ -978,7 +968,7 @@ package Opt is -- GNATMAKE -- Set to True if minimal recompilation mode requested - Multiple_Unit_Index : Int; + Multiple_Unit_Index : Int := 0; -- GNAT -- This is set non-zero if the current unit is being compiled in multiple -- unit per file mode, meaning that the current unit is selected from the @@ -986,6 +976,11 @@ package Opt is -- in this variable (e.g. 2 = select second unit in file). A value of -- zero indicates that we are in normal (one unit per file) mode. + No_Backup : Boolean := False; + -- GNATNAME + -- Set by switch --no-backup. + -- Do not create backup copies of project files. + No_Deletion : Boolean := False; -- GNATPREP -- Set by preprocessor switch -a. Do not eliminate any source text. Implies @@ -1186,6 +1181,16 @@ package Opt is -- Set to True to enable compatibility mode with Rational compiler, and -- to accept renamings of implicit operations in their own scope. + Relaxed_RM_Semantics : Boolean := False; + -- GNAT + -- Set to True to ignore some Ada semantic error to help parse legacy + -- Ada code for use in e.g. static analysis (such as CodePeer). This + -- deals with cases where other compilers allow illegal constructs. Tools + -- such as CodePeer are interested in analyzing code rather than enforcing + -- legality rules, so as long as these illegal constructs end up with code + -- that can be handled by the tool in question, there is no reason to + -- reject the code that is considered correct by the other compiler. + Replace_In_Comments : Boolean := False; -- GNATPREP -- Set to True if -C switch used @@ -1261,7 +1266,15 @@ package Opt is -- GNAT -- Set True to perform style checks. Activates checks carried out in -- package Style (see body of this package for details of checks). This - -- flag is set True by either the -gnatg or -gnaty switches. + -- flag is set True by use of either the -gnatg or -gnaty switches, or + -- by the Style_Check pragma. + + Style_Check_Main : Boolean := False; + -- GNAT + -- Set True if Style_Check was set for the main unit. This is used to + -- renable style checks for units in the mail extended source that get + -- with'ed indirectly. It is set True by use of either the -gnatg or + -- -gnaty switches, but not by use of the Style_Checks pragma. Suppress_All_Inlining : Boolean := False; -- GNAT @@ -1324,6 +1337,20 @@ package Opt is -- types and dispatching calls, assuming the underlying target supports -- it (e.g. in the JVM case). + Target_Dependent_Info_Read_Name : String_Ptr := null; + -- GNAT + -- Set non-null to override the normal processing in Get_Targ and set the + -- necessary information by reading the target dependent information file + -- whose name is given here (see packages Get_Targ and Set_Targ for full + -- details). Set to non-null file name by use of the -gnateT switch. + + Target_Dependent_Info_Write_Name : String_Ptr := null; + -- GNAT + -- Set non-null to enable a call to Set_Targ.Write_Target_Dependent_Info + -- which writes a target independent information file (see packages + -- Get_Targ and Set_Targ for full details) using the name given by + -- this switch. Set to non-null file name by use of the -gnatet switch. + Task_Dispatching_Policy : Character := ' '; -- GNAT, GNATBIND -- Set to ' ' for the default case (no task dispatching policy specified). @@ -1383,12 +1410,12 @@ package Opt is -- Flag set to force attempt at semantic analysis, even if parser errors -- occur. This will probably cause blowups at this stage in the game. On -- the other hand, most such blowups will be caught cleanly and simply - -- say compilation abandoned. This flag is set to True by -gnatq or -gnatQ. + -- say compilation abandoned. This flag is set True by -gnatq or -gnatQ. Unchecked_Shared_Lib_Imports : Boolean := False; -- GPRBUILD -- Set to True when shared library projects are allowed to import projects - -- that are not shared library projects. Set by switch + -- that are not shared library projects. Set on by use of the switch -- --unchecked-shared-lib-imports. Undefined_Symbols_Are_False : Boolean := False; @@ -1433,13 +1460,6 @@ package Opt is -- Set to True if -h (-gnath for the compiler) switch encountered -- requesting usage information - Use_Expression_With_Actions : Boolean; - -- The N_Expression_With_Actions node has been introduced relatively - -- recently, and not all back ends are prepared to handle it yet. So - -- we use this flag to suppress its use during a transitional period. - -- Currently the default is False for all cases (set in gnat1drv). - -- The default can be modified using -gnatd.X/-gnatd.Y. - Use_Pragma_Linker_Constructor : Boolean := False; -- GNATBIND -- True if pragma Linker_Constructor applies to adainit @@ -1757,17 +1777,6 @@ package Opt is -- terminated by Empty. The order is most recently processed first. This -- list includes only those pragmas in configuration pragma files. - Debug_Pragmas_Disabled_Config : Boolean; - -- GNAT - -- This is the value of the configuration switch for debug pragmas disabled - -- mode, as possibly set by use of the configuration pragma Debug_Policy. - - Debug_Pragmas_Enabled_Config : Boolean; - -- GNAT - -- This is the value of the configuration switch for debug pragmas enabled - -- mode, as possibly set by the command line switch -gnata and possibly - -- modified by the use of the configuration pragma Debug_Policy. - Default_Pool_Config : Node_Id := Empty; -- GNAT -- Same as Default_Pool above, except this is only for Default_Storage_Pool @@ -1913,7 +1922,7 @@ package Opt is -- really seems wrong for Errout to depend on Expander. -- -- Note: for many purposes, it is more appropriate to test the flag - -- Full_Expander_Active, which also checks that Alfa mode is not active. + -- Full_Expander_Active, which also checks that SPARK mode is not active. Static_Dispatch_Tables : Boolean := True; -- This flag indicates if the backend supports generation of statically @@ -1967,12 +1976,21 @@ package Opt is -- Modes for Formal Verification -- ----------------------------------- - Alfa_Mode : Boolean := False; + SPARK_Mode : Boolean := False; -- Specific compiling mode targeting formal verification through the -- generation of Why code for those parts of the input code that belong to - -- the Alfa subset of Ada. Set by debug flag -gnatd.F. - - Strict_Alfa_Mode : Boolean := False; + -- the SPARK 2014 subset of Ada. Set True by the gnat2why executable or by + -- use of the -gnatd.F debug switch. Note that this is completely separate + -- from the SPARK restriction defined in GNAT to detect violations of a + -- subset of SPARK 2005 rules. + + Frame_Condition_Mode : Boolean := False; + -- Specific mode to be used in combination with SPARK_Mode. If set to + -- true, ALI files containing the frame conditions (global effects) are + -- generated, and Why files are *not* generated. If not true, Why files + -- are generated. Set by debug flag -gnatd.G. + + SPARK_Strict_Mode : Boolean := False; -- Interpret compiler permissions as strictly as possible. E.g. base ranges -- for integers are limited to the strict minimum with this option. Set by -- debug flag -gnatd.D. @@ -1984,12 +2002,12 @@ package Opt is function Full_Expander_Active return Boolean; pragma Inline (Full_Expander_Active); - -- Returns the value of (Expander_Active and not Alfa_Mode). This "flag" + -- Returns the value of (Expander_Active and not SPARK_Mode). This "flag" -- indicates that expansion is fully active, that is, not in the reduced - -- mode for Alfa (True) or that expansion is either deactivated, or active - -- in the reduced mode for Alfa (False). For more information on full + -- mode for SPARK (True) or that expansion is either deactivated, or active + -- in the reduced mode for SPARK (False). For more information on full -- expansion, see package Expander. For more information on reduced - -- Alfa expansion, see package Exp_Alfa. + -- SPARK expansion, see package Exp_SPARK. private @@ -2007,8 +2025,6 @@ private Assume_No_Invalid_Values : Boolean; Check_Float_Overflow : Boolean; Check_Policy_List : Node_Id; - Debug_Pragmas_Disabled : Boolean; - Debug_Pragmas_Enabled : Boolean; Default_Pool : Node_Id; Dynamic_Elaboration_Checks : Boolean; Exception_Locations_Suppressed : Boolean; diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index 5ac680176b8..da3c25deb5f 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.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- -- @@ -344,7 +344,7 @@ package body Output is procedure Write_Eol is begin - -- Remove any trailing space + -- Remove any trailing spaces while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop Next_Col := Next_Col - 1; diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb index c255325699f..f0537f27cd1 100644 --- a/gcc/ada/par-ch11.adb +++ b/gcc/ada/par-ch11.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- -- @@ -199,11 +199,43 @@ package body Ch11 is return Error; end P_Exception_Choice; + ---------------------------- + -- 11.3 Raise Expression -- + ---------------------------- + + -- RAISE_EXPRESSION ::= raise [exception_NAME [with string_EXPRESSION]] + + -- The caller has verified that the initial token is RAISE + + -- Error recovery: can raise Error_Resync + + function P_Raise_Expression return Node_Id is + Raise_Node : Node_Id; + + begin + if Ada_Version < Ada_2012 then + Error_Msg_SC ("raise expression is an Ada 2012 feature"); + Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch"); + end if; + + Raise_Node := New_Node (N_Raise_Expression, Token_Ptr); + Scan; -- past RAISE + + Set_Name (Raise_Node, P_Name); + + if Token = Tok_With then + Scan; -- past WITH + Set_Expression (Raise_Node, P_Expression); + end if; + + return Raise_Node; + end P_Raise_Expression; + --------------------------- -- 11.3 Raise Statement -- --------------------------- - -- RAISE_STATEMENT ::= raise [exception_NAME]; + -- RAISE_STATEMENT ::= raise [exception_NAME with string_EXPRESSION]; -- The caller has verified that the initial token is RAISE diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 06261bc60b3..3c192f2877b 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.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- -- @@ -204,6 +204,11 @@ package body Ch12 is Gen_Decl := New_Node (N_Generic_Package_Declaration, Gen_Sloc); Set_Specification (Gen_Decl, P_Package (Pf_Spcn)); + -- Aspects have been parsed by the package spec. Move them to the + -- generic declaration where they belong. + + Move_Aspects (Specification (Gen_Decl), Gen_Decl); + else Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc); diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index 2cd54b7001c..224c63b7eb9 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.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- -- @@ -40,6 +40,12 @@ package body Ch2 is -- the scanned association has an identifier (this is used to check the -- rule that no associations without identifiers can follow an association -- which has an identifier). The result is returned in Association. + -- + -- Note: We allow attribute forms Pre'Class, Post'Class, Invariant'Class, + -- Type_Invariant'Class in place of a pragma argument identifier. Rather + -- than handle this case specially, we replace such references with + -- one of the special internal identifiers _Pre, _Post, _Invariant, or + -- _Type_Invariant, and this procedure is where this replacement occurs. --------------------- -- 2.3 Identifier -- @@ -427,9 +433,7 @@ package body Ch2 is P := P_Pragma; if Nkind (P) /= N_Error - and then (Pragma_Name (P) = Name_Assert - or else - Pragma_Name (P) = Name_Debug) + and then Nam_In (Pragma_Name (P), Name_Assert, Name_Debug) then Error_Msg_Name_1 := Pragma_Name (P); Error_Msg_N @@ -448,6 +452,24 @@ package body Ch2 is -- [pragma_argument_IDENTIFIER =>] NAME -- | [pragma_argument_IDENTIFIER =>] EXPRESSION + -- In Ada 2012, there are two more possibilities: + + -- PRAGMA_ARGUMENT_ASSOCIATION ::= + -- [pragma_argument_ASPECT_MARK =>] NAME + -- | [pragma_argument_ASPECT_MARK =>] EXPRESSION + + -- where the interesting allowed cases (which do not fit the syntax of the + -- first alternative above) are + + -- ASPECT_MARK ::= + -- Pre'Class | Post'Class | Invariant'Class | Type_Invariant'Class + + -- We allow this special usage in all Ada modes, but it would be a pain to + -- allow these aspects to pervade the pragma syntax, and the representation + -- of pragma nodes internally. So what we do is to replace these + -- ASPECT_MARK forms with identifiers whose name is one of the special + -- internal names _Pre, _Post, _Invariant, or _Type_Invariant. + -- Error recovery: cannot raise Error_Resync procedure Scan_Pragma_Argument_Association @@ -461,6 +483,7 @@ package body Ch2 is begin Association := New_Node (N_Pragma_Argument_Association, Token_Ptr); Set_Chars (Association, No_Name); + Id_Present := False; -- Argument starts with identifier @@ -470,22 +493,69 @@ package body Ch2 is Scan; -- past Identifier if Token = Tok_Arrow then - Identifier_Seen := True; Scan; -- past arrow - Set_Chars (Association, Chars (Identifier_Node)); Id_Present := True; - -- Case of argument with no identifier + -- Case of one of the special aspect forms - else - Restore_Scan_State (Scan_State); -- to Identifier - Id_Present := False; + elsif Token = Tok_Apostrophe then + Scan; -- past apostrophe + + -- We have apostrophe, so check for identifier'Class + + if Token /= Tok_Identifier or else Token_Name /= Name_Class then + null; + + -- We have identifier'Class, check for arrow + + else + Scan; -- Past Class + + if Token /= Tok_Arrow then + null; + + -- Here we have scanned identifier'Class => + + else + Id_Present := True; + Scan; -- past arrow + + case Chars (Identifier_Node) is + when Name_Pre => + Set_Chars (Identifier_Node, Name_uPre); + + when Name_Post => + Set_Chars (Identifier_Node, Name_uPost); + + when Name_Type_Invariant => + Set_Chars (Identifier_Node, Name_uType_Invariant); + + when Name_Invariant => + Set_Chars (Identifier_Node, Name_uInvariant); + + -- If it is X'Class => for some invalid X, we will give + -- an error, and forget that 'Class was present, which + -- will give better error recovery. We could do a spell + -- check here, but it seems too much work. + + when others => + Error_Msg_SC ("invalid aspect id for pragma"); + end case; + end if; + end if; end if; - -- Argument does not start with identifier + -- Identifier was present - else - Id_Present := False; + if Id_Present then + Set_Chars (Association, Chars (Identifier_Node)); + Identifier_Seen := True; + + -- Identifier not present after all + + else + Restore_Scan_State (Scan_State); -- to Identifier + end if; end if; -- Diagnose error of "positional" argument for pragma appearing after @@ -493,9 +563,10 @@ package body Ch2 is -- Ada RM terminology). -- Since older GNAT versions did not generate this error, disable this - -- message in codepeer mode to help legacy code using codepeer. + -- message in Relaxed_RM_Semantics mode to help legacy code using e.g. + -- codepeer. - if Identifier_Seen and not Id_Present and not CodePeer_Mode then + if Identifier_Seen and not Id_Present and not Relaxed_RM_Semantics then Error_Msg_SC ("|pragma argument identifier required here"); Error_Msg_SC ("\since previous argument had identifier (RM 2.8(4))"); end if; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 185a07d97c2..e1e634a9e96 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.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- -- @@ -509,16 +509,25 @@ package body Ch4 is and then not Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name)) then - Set_Expressions (Name_Node, New_List); + -- Attribute Loop_Entry has no effect on the name extension + -- parsing logic, as if the attribute never existed in the + -- source. Continue parsing the subsequent expressions or + -- ranges. + + if Attr_Name = Name_Loop_Entry then + Scan; -- past left paren + goto Scan_Name_Extension_Left_Paren; -- Attribute Update contains an array or record association -- list which provides new values for various components or -- elements. The list is parsed as an aggregate. - if Attr_Name = Name_Update then + elsif Attr_Name = Name_Update then + Set_Expressions (Name_Node, New_List); Append (P_Aggregate, Expressions (Name_Node)); else + Set_Expressions (Name_Node, New_List); Scan; -- past left paren loop @@ -689,16 +698,17 @@ package body Ch4 is if Token = Tok_Arrow then Error_Msg - ("expect identifier in parameter association", - Sloc (Expr_Node)); + ("expect identifier in parameter association", Sloc (Expr_Node)); Scan; -- past arrow elsif not Comma_Present then T_Right_Paren; + Prefix_Node := Name_Node; Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node)); Set_Prefix (Name_Node, Prefix_Node); Set_Expressions (Name_Node, Arg_List); + goto Scan_Name_Extension; end if; @@ -1818,6 +1828,7 @@ package body Ch4 is -- RELATION ::= -- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST + -- | RAISE_EXPRESSION -- MEMBERSHIP_CHOICE_LIST ::= -- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE} @@ -1825,6 +1836,8 @@ package body Ch4 is -- MEMBERSHIP_CHOICE ::= -- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK + -- RAISE_EXPRESSION ::= raise exception_NAME [with string_EXPRESSION] + -- On return, Expr_Form indicates the categorization of the expression -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to @@ -1839,6 +1852,15 @@ package body Ch4 is Optok : Source_Ptr; begin + -- First check for raise expression + + if Token = Tok_Raise then + Expr_Form := EF_Non_Simple; + return P_Raise_Expression; + end if; + + -- All other cases + Node1 := P_Simple_Expression; if Token not in Token_Class_Relop then diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 2243acea2eb..7531f405fe1 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.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- -- @@ -150,7 +150,7 @@ package body Ch6 is -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK -- SUBPROGRAM_BODY ::= - -- SUBPROGRAM_SPECIFICATION is + -- SUBPROGRAM_SPECIFICATION [ASPECT_SPECIFICATIONS] is -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS @@ -684,6 +684,15 @@ package body Ch6 is Stub_Node := New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node)); Set_Specification (Stub_Node, Specification_Node); + + -- The specification has been parsed as part of a subprogram + -- declaration, and aspects have already been collected. + + if Is_Non_Empty_List (Aspects) then + Set_Parent (Aspects, Stub_Node); + Set_Aspect_Specifications (Stub_Node, Aspects); + end if; + Scan; -- past SEPARATE Pop_Scope_Stack; TF_Semicolon; @@ -829,6 +838,22 @@ package body Ch6 is ("\unit must be compiled with -gnat2012 switch!"); end if; + -- Catch an illegal placement of the aspect specification + -- list: + + -- function_specification + -- [aspect_specification] is (expression); + + -- This case is correctly processed by the parser because + -- the expression function first appears as a subprogram + -- declaration to the parser. + + if Is_Non_Empty_List (Aspects) then + Error_Msg + ("aspect specifications must come after parenthesized " + & "expression", Sloc (First (Aspects))); + end if; + -- Parse out expression and build expression function Body_Node := diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb index 15f98bfcfb3..d52a13d6c5b 100644 --- a/gcc/ada/par-ch7.adb +++ b/gcc/ada/par-ch7.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- -- @@ -138,6 +138,7 @@ package body Ch7 is end if; T_Body; + Scope.Table (Scope.Last).Sloc := Token_Ptr; Name_Node := P_Defining_Program_Unit_Name; Scope.Table (Scope.Last).Labl := Name_Node; TF_Is; @@ -182,6 +183,7 @@ package body Ch7 is -- Cases other than Package_Body else + Scope.Table (Scope.Last).Sloc := Token_Ptr; Name_Node := P_Defining_Program_Unit_Name; Scope.Table (Scope.Last).Labl := Name_Node; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 07f31be423c..3587dff4d12 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -155,9 +155,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is begin if Nkind (Expression (Arg)) /= N_Identifier - or else (Chars (Argx) /= Name_On - and then - Chars (Argx) /= Name_Off) + or else not Nam_In (Chars (Argx), Name_On, Name_Off) then Error_Msg_Name_2 := Name_On; Error_Msg_Name_3 := Name_Off; @@ -1029,8 +1027,15 @@ begin -- set well before any semantic analysis is performed. Note that we -- ignore this pragma if debug flag -gnatd.i is set. + -- Also note that the "one argument" case may have two arguments if the + -- second one is a reason argument. + when Pragma_Warnings => - if Arg_Count = 1 and then not Debug_Flag_Dot_I then + if not Debug_Flag_Dot_I + and then (Arg_Count = 1 + or else (Arg_Count = 2 + and then Chars (Arg2) = Name_Reason)) + then Check_No_Identifier (Arg1); declare @@ -1123,7 +1128,6 @@ begin Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning | Pragma_Compiler_Unit | - Pragma_Contract_Case | Pragma_Contract_Cases | Pragma_Convention_Identifier | Pragma_CPP_Class | @@ -1140,6 +1144,7 @@ begin Pragma_Controlled | Pragma_Convention | Pragma_Debug_Policy | + Pragma_Depends | Pragma_Detect_Blocking | Pragma_Default_Storage_Pool | Pragma_Disable_Atomic_Synchronization | diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 3b59287b703..f2ac335e08c 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.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- -- @@ -181,8 +181,7 @@ package body Util is if Ada_Version = Ada_95 and then Warn_On_Ada_2005_Compatibility then - if Token_Name = Name_Overriding - or else Token_Name = Name_Synchronized + if Nam_In (Token_Name, Name_Overriding, Name_Synchronized) or else (Token_Name = Name_Interface and then Prev_Token /= Tok_Pragma) then diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 571713f3d51..ac21375ef46 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.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- -- @@ -838,6 +838,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is package Ch11 is function P_Handled_Sequence_Of_Statements return Node_Id; + function P_Raise_Expression return Node_Id; function P_Raise_Statement return Node_Id; function Parse_Exception_Handlers return List_Id; diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 54fe0ddb8d7..29c2daa89e1 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -917,7 +917,7 @@ package body Par_SCO is From : Nat; procedure Traverse_Aux_Decls (N : Node_Id); - -- Traverse the Aux_Decl_Nodes of compilation unit N + -- Traverse the Aux_Decls_Node of compilation unit N ------------------------ -- Traverse_Aux_Decls -- @@ -927,8 +927,14 @@ package body Par_SCO is ADN : constant Node_Id := Aux_Decls_Node (N); begin Traverse_Declarations_Or_Statements (Config_Pragmas (ADN)); - Traverse_Declarations_Or_Statements (Declarations (ADN)); Traverse_Declarations_Or_Statements (Pragmas_After (ADN)); + + -- Declarations and Actions do not correspond to source constructs, + -- they contain only nodes from expansion, so at this point they + -- should still be empty: + + pragma Assert (No (Declarations (ADN))); + pragma Assert (No (Actions (ADN))); end Traverse_Aux_Decls; -- Start of processing for SCO_Record @@ -1448,18 +1454,18 @@ package body Par_SCO is C1 := ASCII.NUL; - case Get_Aspect_Id (Chars (Identifier (AN))) is + case Get_Aspect_Id (AN) is -- Aspects rewritten into pragmas controlled by a Check_Policy: -- Current_Pragma_Sloc must be set to the sloc of the aspect -- specification. The corresponding pragma will have the same -- sloc. - when Aspect_Pre | - Aspect_Precondition | - Aspect_Post | - Aspect_Postcondition | - Aspect_Invariant => + when Aspect_Pre | + Aspect_Precondition | + Aspect_Post | + Aspect_Postcondition | + Aspect_Invariant => C1 := 'a'; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index b575edaa105..a69281130dd 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.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- -- @@ -365,7 +365,6 @@ package body Prj.Attr is -- package Remote "Premote#" & - "LVbuild_slaves#" & "SVroot_dir#" & -- package Stack diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 9ba624cdc0d..48241efbdd0 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -1558,7 +1558,8 @@ package body Prj.Conf is Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; - On_Load_Config : Config_File_Hook := null) + On_Load_Config : Config_File_Hook := null; + Implicit_Project : Boolean := False) is begin pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path)); @@ -1578,7 +1579,8 @@ package body Prj.Conf is Packages_To_Check => Packages_To_Check, Current_Directory => Current_Directory, Is_Config_File => False, - Env => Env); + Env => Env, + Implicit_Project => Implicit_Project); if User_Project_Node = Empty_Node then User_Project_Node := Empty_Node; diff --git a/gcc/ada/prj-conf.ads b/gcc/ada/prj-conf.ads index 7154e55d23a..1c72fa769ba 100644 --- a/gcc/ada/prj-conf.ads +++ b/gcc/ada/prj-conf.ads @@ -55,7 +55,8 @@ package Prj.Conf is Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; - On_Load_Config : Config_File_Hook := null); + On_Load_Config : Config_File_Hook := null; + Implicit_Project : Boolean := False); -- Find the main configuration project and parse the project tree rooted at -- this configuration project. -- @@ -85,6 +86,13 @@ package Prj.Conf is -- Any error in generating or parsing the config file is reported via the -- Invalid_Config exception, with an appropriate message. Any error while -- parsing the project file results in No_Project. + -- + -- If Implicit_Project is True, the main project file being parsed is + -- deemed to be in the current working directory, even if it is not the + -- case. Implicit_Project is set to True when a tool such as gprbuild is + -- invoked without a project file and is using an implicit project file + -- that is virtually in the current working directory, but is physically + -- in another directory. procedure Process_Project_And_Apply_Config (Main_Project : out Prj.Project_Id; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 4788fbedf95..67b077f372f 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -33,6 +33,8 @@ with Prj.Com; use Prj.Com; with Sdefault; with Tempdir; +with Ada.Text_IO; use Ada.Text_IO; + with GNAT.Directory_Operations; use GNAT.Directory_Operations; package body Prj.Env is @@ -1895,14 +1897,17 @@ package body Prj.Env is New_Len : Positive; New_Last : Positive; - Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; - Gpr_Project_Path : constant String := "GPR_PROJECT_PATH"; - -- Name of alternate env. variable that contain path name(s) of - -- directories where project files may reside. GPR_PROJECT_PATH has - -- precedence over ADA_PROJECT_PATH. - - Gpr_Prj_Path : String_Access; - Ada_Prj_Path : String_Access; + Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; + Gpr_Project_Path : constant String := "GPR_PROJECT_PATH"; + Gpr_Project_Path_File : constant String := "GPR_PROJECT_PATH_FILE"; + -- Names of alternate env. variable that contain path name(s) of + -- directories where project files may reside. They are taken into + -- account in this order: GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH, + -- ADA_PROJECT_PATH. + + Gpr_Prj_Path_File : String_Access; + Gpr_Prj_Path : String_Access; + Ada_Prj_Path : String_Access; -- The path name(s) of directories where project files may reside. -- May be empty. @@ -1926,8 +1931,50 @@ package body Prj.Env is -- If environment variables are defined and not empty, add their content - Gpr_Prj_Path := Getenv (Gpr_Project_Path); - Ada_Prj_Path := Getenv (Ada_Project_Path); + Gpr_Prj_Path_File := Getenv (Gpr_Project_Path_File); + Gpr_Prj_Path := Getenv (Gpr_Project_Path); + Ada_Prj_Path := Getenv (Ada_Project_Path); + + if Gpr_Prj_Path_File.all /= "" then + declare + File : Ada.Text_IO.File_Type; + Line : String (1 .. 10_000); + Last : Natural; + + Tmp : String_Access; + + begin + Open (File, In_File, Gpr_Prj_Path_File.all); + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + + if Last /= 0 + and then (Last = 1 or else Line (1 .. 2) /= "--") + then + Tmp := Self.Path; + Self.Path := + new String' + (Tmp.all & Path_Separator & Line (1 .. Last)); + Free (Tmp); + end if; + + if Current_Verbosity = High then + Debug_Output ("Adding directory to Project_Path: """ + & Line (1 .. Last) & '"'); + end if; + end loop; + + Close (File); + + exception + when others => + Write_Str ("warning: could not read project path file """); + Write_Str (Gpr_Prj_Path_File.all); + Write_Line (""""); + end; + + end if; if Gpr_Prj_Path.all /= "" then Add_Directories (Self, Gpr_Prj_Path.all); diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index e2b1ad1d9fd..7de436943f5 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.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- -- @@ -24,6 +24,8 @@ ------------------------------------------------------------------------------ with Csets; +with Hostparm; +with Makeutl; use Makeutl; with Opt; with Output; with Osint; use Osint; @@ -37,6 +39,7 @@ with Prj.Util; use Prj.Util; with Sdefault; with Snames; use Snames; with Table; use Table; +with Tempdir; with Ada.Characters.Handling; use Ada.Characters.Handling; with GNAT.Directory_Operations; use GNAT.Directory_Operations; @@ -62,8 +65,6 @@ package body Prj.Makr is Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data; -- The project tree where the project file is parsed - Root_Environment : Prj.Tree.Environment; - Args : Argument_List_Access; -- The list of arguments for calls to the compiler to get the unit names -- and kinds (spec or body) in the Ada sources. @@ -952,10 +953,10 @@ package body Prj.Makr is then Name := Prj.Tree.Name_Of (Current_Node, Tree); - if Name = Name_Source_Files or else - Name = Name_Source_List_File or else - Name = Name_Source_Dirs or else - Name = Name_Naming + if Nam_In (Name, Name_Source_Files, + Name_Source_List_File, + Name_Source_Dirs, + Name_Naming) then Comments := Tree.Project_Nodes.Table (Current_Node).Comments; @@ -1047,6 +1048,42 @@ package body Prj.Makr is Project_File_Extension; Output_Name_Last := Output_Name_Last + Project_File_Extension'Length; + -- Back up project file if it already exists (not needed in VMS since + -- versioning of files takes care of this requirement on VMS). + + if not Hostparm.OpenVMS + and then not Opt.No_Backup + and then Is_Regular_File (Path_Name (1 .. Path_Last)) + then + declare + Discard : Boolean; + Saved_Path : constant String := + Path_Name (1 .. Path_Last) & ".saved_"; + Nmb : Natural; + + begin + Nmb := 0; + loop + declare + Img : constant String := Nmb'Img; + + begin + if not Is_Regular_File + (Saved_Path & Img (2 .. Img'Last)) + then + Copy_File + (Name => Path_Name (1 .. Path_Last), + Pathname => Saved_Path & Img (2 .. Img'Last), + Mode => Overwrite, + Success => Discard); + exit; + end if; + + Nmb := Nmb + 1; + end; + end loop; + end; + end if; end if; -- Change the current directory to the directory of the project file, @@ -1198,6 +1235,7 @@ package body Prj.Makr is Success : Boolean; Saved_Output : File_Descriptor; Saved_Error : File_Descriptor; + Tmp_File : Path_Name_Type; begin -- If we don't have the path of the compiler yet, @@ -1219,19 +1257,26 @@ package body Prj.Makr is end if; end if; - -- If we don't have yet the file name of the - -- temporary file, get it now. + -- Create the temporary file - if Temp_File_Name = null then - Create_Temp_File (FD, Temp_File_Name); + Tempdir.Create_Temp_File (FD, Tmp_File); - if FD = Invalid_FD then - Prj.Com.Fail - ("could not create temporary file"); - end if; + if FD = Invalid_FD then + Prj.Com.Fail + ("could not create temporary file"); + + else + Temp_File_Name := + new String'(Get_Name_String (Tmp_File)); + end if; + -- On VMS, a file created with Create_Temp_File cannot + -- be used to redirect output. + + if Hostparm.OpenVMS then Close (FD); Delete_File (Temp_File_Name.all, Success); + FD := Create_Output_Text_File (Temp_File_Name.all); end if; Args (Args'Last) := new String' @@ -1239,16 +1284,6 @@ package body Prj.Makr is Directory_Separator & Str (1 .. Last)); - -- Create the temporary file - - FD := Create_Output_Text_File - (Name => Temp_File_Name.all); - - if FD = Invalid_FD then - Prj.Com.Fail - ("could not create temporary file"); - end if; - -- Save the standard output and error Saved_Output := Dup (Standout); @@ -1294,7 +1329,8 @@ package body Prj.Makr is if not Is_Valid (File) then Prj.Com.Fail - ("could not read temporary file"); + ("could not read temporary file " & + Temp_File_Name.all); end if; Save_Last_Source_Index := Sources.Last; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index b956292a6e6..f1538de9922 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -3155,16 +3155,21 @@ package body Prj.Nmsc is end if; if not Dir_Exists then + if Directories_Must_Exist_In_Projects then - -- Get the absolute name of the library directory that - -- does not exist, to report an error. + -- Get the absolute name of the library directory that does + -- not exist, to report an error. - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Project.Library_Dir.Display_Name); - Error_Msg - (Data.Flags, - "library directory { does not exist", - Lib_Dir.Location, Project); + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Project.Library_Dir.Display_Name); + Error_Msg + (Data.Flags, + "library directory { does not exist", + Lib_Dir.Location, Project); + + else + Project.Library_Dir := No_Path_Information; + end if; -- Checks for object/source directories @@ -3208,8 +3213,8 @@ package body Prj.Nmsc is File_Name_Type (Dir_Elem.Value); Error_Msg (Data.Flags, - "library directory cannot be the same " & - "as source directory {", + "library directory cannot be the same " + & "as source directory {", Lib_Dir.Location, Project); OK := False; exit; @@ -3243,8 +3248,8 @@ package body Prj.Nmsc is Error_Msg (Data.Flags, - "library directory cannot be the same" & - " as source directory { of project %%", + "library directory cannot be the same " + & "as source directory { of project %%", Lib_Dir.Location, Project); OK := False; exit Project_Loop; @@ -3654,6 +3659,21 @@ package body Prj.Nmsc is end loop; end if; + if not Lib_Standalone.Default + and then Project.Library_Kind = Static + then + -- An standalone library must be a shared library + + Error_Msg_Name_1 := Project.Name; + + Error_Msg + (Data.Flags, + Continuation.all & + "standalone library project %% must be a shared library", + Project.Location, Project); + Continuation := Continuation_String'Access; + end if; + if Project.Library and not Data.In_Aggregate_Lib then -- Record the library name @@ -5022,9 +5042,8 @@ package body Prj.Nmsc is function Is_Reserved (Name : Name_Id) return Boolean is begin if Get_Name_Table_Byte (Name) /= 0 - and then Name /= Name_Project - and then Name /= Name_Extends - and then Name /= Name_External + and then + not Nam_In (Name, Name_Project, Name_Extends, Name_External) and then Name not in Ada_2005_Reserved_Words then Unit := No_Name; @@ -5408,15 +5427,20 @@ package body Prj.Nmsc is Externally_Built => Project.Externally_Built); if not Dir_Exists and then not Project.Externally_Built then + if Opt.Directories_Must_Exist_In_Projects then + -- The object directory does not exist, report an error if + -- the project is not externally built. - -- The object directory does not exist, report an error if the - -- project is not externally built. + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Object_Dir.Value); + Error_Or_Warning + (Data.Flags, Data.Flags.Require_Obj_Dirs, + "object directory { not found", + Project.Location, Project); - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Object_Dir.Value); - Error_Or_Warning - (Data.Flags, Data.Flags.Require_Obj_Dirs, - "object directory { not found", Project.Location, Project); + else + Project.Object_Directory := No_Path_Information; + end if; end if; end if; @@ -5489,10 +5513,15 @@ package body Prj.Nmsc is Externally_Built => Project.Externally_Built); if not Dir_Exists then - Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); - Error_Or_Warning - (Data.Flags, Data.Flags.Missing_Source_Files, - "exec directory { not found", Project.Location, Project); + if Opt.Directories_Must_Exist_In_Projects then + Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "exec directory { not found", Project.Location, Project); + + else + Project.Exec_Directory := No_Path_Information; + end if; end if; end if; end if; @@ -7729,7 +7758,7 @@ package body Prj.Nmsc is if Language.First_Source = No_Source and then (Data.Flags.Require_Sources_Other_Lang - or else Language.Name = Name_Ada) + or else Language.Name = Name_Ada) then Iter := For_Each_Source (In_Tree => Data.Tree, Project => Project.Project); diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 5d09dbe6010..7f617a0e6dc 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.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- -- @@ -191,7 +191,8 @@ package body Prj.Part is Depth : Natural; Current_Dir : String; Is_Config_File : Boolean; - Env : in out Environment); + Env : in out Environment; + Implicit_Project : Boolean := False); -- Parse a project file. This is a recursive procedure: it calls itself for -- imported and extended projects. When From_Extended is not None, if the -- project has already been parsed and is an extended project A, return the @@ -201,6 +202,10 @@ package body Prj.Part is -- -- Is_Config_File should be set to True if the project represents a config -- file (.cgpr) since some specific checks apply. + -- + -- If Implicit_Project is True, change the Directory of the project node + -- to be the Current_Dir. Recursive calls to Parse_Single_Project are + -- always done with the default False value for Implicit_Project. procedure Pre_Parse_Context_Clause (In_Tree : Project_Node_Tree_Ref; @@ -530,7 +535,8 @@ package body Prj.Part is Current_Directory : String := ""; Is_Config_File : Boolean; Env : in out Prj.Tree.Environment; - Target_Name : String := "") + Target_Name : String := ""; + Implicit_Project : Boolean := False) is Dummy : Boolean; pragma Warnings (Off, Dummy); @@ -598,7 +604,8 @@ package body Prj.Part is Depth => 0, Current_Dir => Current_Directory, Is_Config_File => Is_Config_File, - Env => Env); + Env => Env, + Implicit_Project => Implicit_Project); exception when Types.Unrecoverable_Error => @@ -1230,7 +1237,8 @@ package body Prj.Part is Depth : Natural; Current_Dir : String; Is_Config_File : Boolean; - Env : in out Environment) + Env : in out Environment; + Implicit_Project : Boolean := False) is Path_Name : constant String := Get_Name_String (Path_Name_Id); @@ -1394,7 +1402,10 @@ package body Prj.Part is Tree.Reset_State; Scan (In_Tree); - if not Is_Config_File and then Name_From_Path = No_Name then + if not Is_Config_File + and then Name_From_Path = No_Name + and then not Implicit_Project + then -- The project file name is not correct (no or bad extension, or not -- following Ada identifier's syntax). @@ -1977,6 +1988,13 @@ package body Prj.Part is Tree.Restore_And_Free (Project_Comment_State); Debug_Decrease_Indent; + + if Project /= Empty_Node and then Implicit_Project then + Name_Len := 0; + Add_Str_To_Name_Buffer (Current_Dir); + Add_Char_To_Name_Buffer (Dir_Sep); + In_Tree.Project_Nodes.Table (Project).Directory := Name_Find; + end if; end Parse_Single_Project; ----------------------- diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads index 708142ddb27..1bf1366fb5c 100644 --- a/gcc/ada/prj-part.ads +++ b/gcc/ada/prj-part.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2011, 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- -- @@ -47,7 +47,8 @@ package Prj.Part is Current_Directory : String := ""; Is_Config_File : Boolean; Env : in out Prj.Tree.Environment; - Target_Name : String := ""); + Target_Name : String := ""; + Implicit_Project : Boolean := False); -- Parse project file and all its imported project files and create a tree. -- Return the node for the project (or Empty_Node if parsing failed). If -- Always_Errout_Finalize is True, Errout.Finalize is called in all cases, @@ -66,5 +67,12 @@ package Prj.Part is -- Target_Name will be used to initialize the default project path, unless -- In_Tree.Project_Path has already been initialized (which is the -- recommended use). + -- + -- If Implicit_Project is True, the main project file being parsed is + -- deemed to be in the current working directory, even if it is not the + -- case. Implicit_Project is set to True when a tool such as gprbuild is + -- invoked without a project file and is using an implicit project file + -- that is virtually in the current working directory, but is physically + -- in another directory. end Prj.Part; diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index 8072c9daae4..c1215216dbb 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- P R J . T R E E -- +-- P R J . T R E E -- -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2011, 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- -- @@ -279,7 +279,8 @@ package body Prj.Tree is function Case_Insensitive (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) return Boolean is + In_Tree : Project_Node_Tree_Ref) return Boolean + is begin pragma Assert (Present (Node) @@ -524,7 +525,8 @@ package body Prj.Tree is function Directory_Of (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) return Path_Name_Type is + In_Tree : Project_Node_Tree_Ref) return Path_Name_Type + is begin pragma Assert (Present (Node) @@ -539,7 +541,8 @@ package body Prj.Tree is function End_Of_Line_Comment (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) return Name_Id is + In_Tree : Project_Node_Tree_Ref) return Name_Id + is Zone : Project_Node_Id := Empty_Node; begin @@ -960,7 +963,8 @@ package body Prj.Tree is function Follows_Empty_Line (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) return Boolean is + In_Tree : Project_Node_Tree_Ref) return Boolean + is begin pragma Assert (Present (Node) @@ -1005,14 +1009,14 @@ package body Prj.Tree is ---------------- procedure Initialize - (Self : out Environment; - Flags : Processing_Flags) is + (Self : out Environment; + Flags : Processing_Flags) + is begin -- Do not reset the external references, in case we are reloading a -- project, since we want to preserve the current environment. But we -- still need to ensure that the external references are properly -- initialized. - -- Prj.Ext.Reset (Tree.External); Prj.Ext.Initialize (Self.External); @@ -1025,7 +1029,8 @@ package body Prj.Tree is procedure Initialize_And_Copy (Self : out Environment; - Copy_From : Environment) is + Copy_From : Environment) + is begin Self.Flags := Copy_From.Flags; Prj.Ext.Initialize (Self.External, Copy_From => Copy_From.External); @@ -1079,7 +1084,8 @@ package body Prj.Tree is function Is_Extending_All (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) return Boolean is + In_Tree : Project_Node_Tree_Ref) return Boolean + is begin pragma Assert (Present (Node) @@ -1096,7 +1102,8 @@ package body Prj.Tree is function Is_Not_Last_In_List (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) return Boolean is + In_Tree : Project_Node_Tree_Ref) return Boolean + is begin pragma Assert (Present (Node) @@ -1155,7 +1162,8 @@ package body Prj.Tree is function Kind_Of (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind is + In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind + is begin pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Kind; @@ -1167,7 +1175,8 @@ package body Prj.Tree is function Location_Of (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) return Source_Ptr is + In_Tree : Project_Node_Tree_Ref) return Source_Ptr + is begin pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Location; @@ -1179,7 +1188,8 @@ package body Prj.Tree is function Name_Of (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) return Name_Id is + In_Tree : Project_Node_Tree_Ref) return Name_Id + is begin pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Name; @@ -1207,7 +1217,8 @@ package body Prj.Tree is function Next_Comment (Node : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is + In_Tree : Project_Node_Tree_Ref) return Project_Node_Id + is begin pragma Assert (Present (Node) @@ -1648,8 +1659,8 @@ package body Prj.Tree is Follows_Empty_Line => Empty_Line, Is_Followed_By_Empty_Line => False); - -- Otherwise, it is an end of line comment. If there is - -- an end of line node specified, associate the comment with + -- Otherwise, it is an end of line comment. If there is an + -- end of line node specified, associate the comment with -- this node. elsif Present (End_Of_Line_Node) then @@ -2038,7 +2049,6 @@ package body Prj.Tree is (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) - is Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree); begin diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index a16409965d0..0d585a3afe4 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- P R J . T R E E -- +-- P R J . T R E E -- -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2011, 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- -- @@ -61,8 +61,8 @@ package Prj.Tree is end record; procedure Initialize - (Self : out Environment; - Flags : Processing_Flags); + (Self : out Environment; + Flags : Processing_Flags); -- Initialize a new environment procedure Initialize_And_Copy diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index de2254cb222..9e0e0aa38d1 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.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- -- @@ -112,6 +112,15 @@ package body Prj is new Restricted_Lang'(Name => Name_Find, Next => Restricted_Languages); end Add_Restricted_Language; + ------------------------------------- + -- Remove_All_Restricted_Languages -- + ------------------------------------- + + procedure Remove_All_Restricted_Languages is + begin + Restricted_Languages := null; + end Remove_All_Restricted_Languages; + ------------------- -- Add_To_Buffer -- ------------------- diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 449b038e475..66f878688d0 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -45,6 +45,10 @@ package Prj is -- Call by gprbuild for each language specify by switch -- --restricted-to-languages=. + procedure Remove_All_Restricted_Languages; + -- Call by gprbuild in CodePeer mode to ignore switches + -- --restricted-to-languages=. + function Is_Allowed_Language (Name : Name_Id) return Boolean; -- Returns True if --restricted-to-languages= is not used or if Name -- is one of the restricted languages. @@ -1829,6 +1833,7 @@ package Prj is Gprbuild_Flags : constant Processing_Flags; Gprclean_Flags : constant Processing_Flags; + Gprexec_Flags : constant Processing_Flags; Gnatmake_Flags : constant Processing_Flags; -- Flags used by the various tools. They all display the error messages -- through Prj.Err. @@ -2003,6 +2008,18 @@ private Missing_Source_Files => Error, Ignore_Missing_With => False); + Gprexec_Flags : constant Processing_Flags := + (Report_Error => null, + When_No_Sources => Silent, + Require_Sources_Other_Lang => False, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => False, + Error_On_Unknown_Language => True, + Require_Obj_Dirs => Silent, + Allow_Invalid_External => Error, + Missing_Source_Files => Silent, + Ignore_Missing_With => False); + Gnatmake_Flags : constant Processing_Flags := (Report_Error => null, When_No_Sources => Error, diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index 32ae8f66c5f..2c334686b54 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -1,7 +1,7 @@ @set gprconfig GPRconfig @c ------ projects.texi -@c Copyright (C) 2002-2012, Free Software Foundation, Inc. +@c Copyright (C) 2002-2013, Free Software Foundation, Inc. @c This file is shared between the GNAT user's guide and gprbuild. It is not @c compilable on its own, you should instead compile the other two manuals. @c For that reason, there is no toplevel @menu @@ -82,7 +82,6 @@ the information on the command line itself). They share common switches to control the loading of the project (in particular @option{^-P^/PROJECT_FILE=^@emph{projectfile}} and @option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}}). -@xref{Switches Related to Project Files}. The Project Manager supports a wide range of development strategies, for systems of all sizes. Here are some typical practices that are @@ -218,6 +217,7 @@ should contain the following code: @menu * Source Files and Directories:: +* Duplicate Sources in Projects:: * Object and Exec Directory:: * Main Subprograms:: * Tools Options in Project Files:: @@ -402,21 +402,31 @@ setting @code{Source_Dirs}. The project manager automatically finds @file{pack.ads}, @file{pack.adb} and @file{proc.adb} as source files of the project. -Note that it is considered an error for a project file to have no sources -attached to it unless explicitly declared as mentioned above. +Note that by default a warning is issued when a project has no sources attached +to it and this is not explicitly indicated in the project file. +@c --------------------------------------------- +@node Duplicate Sources in Projects +@subsection Duplicate Sources in Projects +@c --------------------------------------------- + +@noindent If the order of the source directories is known statically, that is if -@code{"**"} is not used in the string list @code{Source_Dirs}, then there may +@code{"/**"} is not used in the string list @code{Source_Dirs}, then there may be several files with the same source file name sitting in different directories of the project. In this case, only the file in the first directory is considered as a source of the project and the others are hidden. If -@code{"**"} is used in the string list @code{Source_Dirs}, it is an error +@code{"/**"} is used in the string list @code{Source_Dirs}, it is an error to have several files with the same source file name in the same directory -@code{"**"} subtree, since there would be an ambiguity as to which one should +@code{"/**"} subtree, since there would be an ambiguity as to which one should be used. However, two files with the same source file name may exist in two single directories or directory subtrees. In this case, the one in the first directory or directory subtree is a source of the project. +If there are two sources in different directories of the same @code{"/**"} +subtree, one way to resolve the problem is to exclude the directory of the +file that should not be used as a source of the project. + @c --------------------------------------------- @node Object and Exec Directory @subsection Object and Exec Directory @@ -875,8 +885,7 @@ the associated language, and thus the compiler to use. Note that the use by the Ada compiler of pragmas Source_File_Name is not supported when using project files. You must use the features described in this -paragraph. You can however specify other configuration pragmas -(@pxref{Specifying Configuration Pragmas}). +paragraph. You can however specify other configuration pragmas. The following attributes can be defined in package @code{Naming}: @@ -1092,31 +1101,6 @@ The following attributes can be defined in package @code{Remote}: @table @asis -@item @b{Build_Slaves} -@cindex @code{Build_Slaves} - -A list of string referencing the remote build slaves to use for the -compilation phase. The format is: -@code{[protocol://]name.domain[:port]}. - -Where @code{protocol} is one of: - -@table @asis - -@item rsync -@cindex @code{rsync} - -The sources are copied using the external @code{rsync} tool. - -@item file - -The sources are accessed via a shared directory or mount point. - -@end table - -The default port used to communicate with @command{gprslave} is -@code{8484}. - @item @b{Root_Dir}: @cindex @code{Root_Dir} @@ -1225,12 +1209,18 @@ the search stops: current project file. @item -@cindex @code{ADA_PROJECT_PATH} +@cindex @code{GPR_PROJECT_PATH_FILE} @cindex @code{GPR_PROJECT_PATH} +@cindex @code{ADA_PROJECT_PATH} Then it is searched relative to all the directories specified in the - ^environment variables^logical names^ @b{GPR_PROJECT_PATH} and - @b{ADA_PROJECT_PATH} (in that order) if they exist. The former is - recommended, the latter is kept for backward compatibility. + ^environment variables^logical names^ @b{GPR_PROJECT_PATH_FILE}, + @b{GPR_PROJECT_PATH} and @b{ADA_PROJECT_PATH} (in that order) if they exist. + The value of @b{GPR_PROJECT_PATH_FILE}, when defined, is the path name of + a text file that contains project directory path names, one per line. + @b{GPR_PROJECT_PATH} and @b{ADA_PROJECT_PATH}, when defined, contain + project directory path names separated by directory separators. + @b{ADA_PROJECT_PATH} is used for compatibility, it is recommended to + use @b{GPR_PROJECT_PATH_FILE} or @b{GPR_PROJECT_PATH}. @item Finally, it is searched relative to the default project directories. Such directories depends on the tool used. The different locations searched @@ -1532,13 +1522,13 @@ The second parameter to @code{external} is optional, and is the default value to use if "mode" is not set from the command line or the environment. In order to set the switches according to the different scenarios, other -constructs have to be introduced such as typed variables and case statements. +constructs have to be introduced such as typed variables and case constructions. @cindex typed variable -@cindex case statement +@cindex case construction A @b{typed variable} is a variable that can take only a limited number of values, similar to an enumeration in Ada. -Such a variable can then be used in a @b{case statement} and create conditional +Such a variable can then be used in a @b{case construction} and create conditional sections in the project. The following example shows how this can be done: @smallexample @c projectfile @@ -1565,7 +1555,7 @@ project is considered as invalid. The @code{Mode} variable is initialized with an external value defaulting to @code{"debug"}. This default could be omitted and that would -force the user to define the value. Finally, we can use a case statement to set the +force the user to define the value. Finally, we can use a case construction to set the switches depending on the scenario the user has chosen. Most aspects of the projects can depend on scenarios. The notable exception @@ -1900,12 +1890,15 @@ language and takes a list of sources as parameter. library can furthermore only depends on static libraries (including the GNAT runtime). This attribute can be set to @code{no} to make it clear that the library should not be standalone in which case the - @code{Library_Interface} should not defined. + @code{Library_Interface} should not defined. Note that this attribute + only applies to shared libraries, so @code{Library_Kind} must be set + to @code{dynamic}. @smallexample @c projectfile @group for Library_Dir use "lib"; for Library_Name use "loggin"; + for Library_Kind use "dynamic"; for Library_Interface use ("lib1", "lib2"); -- unit names for Library_Standalone use "encapsulated"; @end group @@ -2914,8 +2907,8 @@ attributes. * External Values:: * Typed String Declaration:: * Variables:: +* Case Constructions:: * Attributes:: -* Case Statements:: @end menu @c --------------------------------------------- @@ -3122,6 +3115,9 @@ The following packages are currently supported in project files @code{Builder}. The first string should always be @code{-rules} to specify that all the other options belong to the @code{-rules} section of the parameters to @command{gnatcheck}. +@item Clean + This package specifies the options used when cleaning a project or a project + tree using the tools @command{gnatclean} or @command{gprclean}. @item Compiler This package specifies the compilation options used by the compiler for each languages. @xref{Tools Options in Project Files}. @@ -3151,17 +3147,12 @@ The following packages are currently supported in project files @item IDE This package specifies the options used when starting an integrated development environment, for instance @command{GPS} or @command{Gnatbench}. - @xref{The Development Environments}. @item Install This package specifies the options used when installing a project with @command{gprinstall}. @xref{Installation}. @item Linker This package specifies the options used by the linker. @xref{Main Subprograms}. -@item Makefile -@cindex Makefile package in projects - This package is used by the GPS plugin Makefile.py. See the documentation - in that plugin (from GPS: /Tools/Plug-ins). @item Metrics This package specifies the options used when calling the tool @command{gnatmetric} via the @command{gnat} driver. Its attributes @@ -3178,6 +3169,9 @@ The following packages are currently supported in project files @command{gnatpp} via the @command{gnat} driver. Its attributes @b{Default_Switches} and @b{Switches} have the same semantics as for the package @code{Builder}. +@item Remote + This package is used by @command{gprbuild} to describe how distributed + compilation should be done. @item Stack This package specifies the options used when calling the tool @command{gnatstack} via the @command{gnat} driver. Its attributes @@ -3430,7 +3424,7 @@ Here is an example of a string type declaration: Variables of a string type are called @b{typed variables}; all other variables are called @b{untyped variables}. Typed variables are particularly useful in @code{case} constructions, to support conditional -attribute declarations. (@pxref{Case Statements}). +attribute declarations. (@pxref{Case Constructions}). A string type may be referenced by its name if it has been declared in the same project file, or by an expanded name whose prefix is the name of the project @@ -3452,7 +3446,7 @@ string (""). A @b{typed} variable can be used as part of a @b{case} expression to compute the value, but it can only be declared once in the project file, -so that all case statements see the same value for the variable. This +so that all case constructions see the same value for the variable. This provides more consistency and makes the project easier to understand. The syntax for its declaration is identical to the Ada syntax for an object declaration. In effect, a typed variable acts as a constant. @@ -3514,10 +3508,102 @@ A @b{context} may be one of the following: @end itemize @c --------------------------------------------- +@node Case Constructions +@subsection Case Constructions +@c --------------------------------------------- + +@noindent +A @b{case} statement is used in a project file to effect conditional +behavior. Through this statement, you can set the value of attributes +and variables depending on the value previously assigned to a typed +variable. + +All choices in a choice list must be distinct. Unlike Ada, the choice +lists of all alternatives do not need to include all values of the type. +An @code{others} choice must appear last in the list of alternatives. + +The syntax of a @code{case} construction is based on the Ada case statement +(although the @code{null} statement for empty alternatives is optional). + +The case expression must be a typed string variable, whose value is often +given by an external reference (@pxref{External Values}). + +Each alternative starts with the reserved word @code{when}, either a list of +literal strings separated by the @code{"|"} character or the reserved word +@code{others}, and the @code{"=>"} token. +Each literal string must belong to the string type that is the type of the +case variable. +After each @code{=>}, there are zero or more statements. The only +statements allowed in a case construction are other case constructions, +attribute declarations and variable declarations. String type declarations and +package declarations are not allowed. Variable declarations are restricted to +variables that have already been declared before the case construction. + +@smallexample +case_statement ::= + @i{case} @i{<typed_variable_>}name @i{is} @{case_item@} @i{end case} ; + +case_item ::= + @i{when} discrete_choice_list => + @{case_statement + | attribute_declaration + | variable_declaration + | empty_declaration@} + +discrete_choice_list ::= string_literal @{| string_literal@} | @i{others} +@end smallexample + +@noindent +Here is a typical example: + +@smallexample @c projectfile +@group +project MyProj is + type OS_Type is ("GNU/Linux", "Unix", "NT", "VMS"); + OS : OS_Type := external ("OS", "GNU/Linux"); + + package Compiler is + case OS is + when "GNU/Linux" | "Unix" => + for Switches ("Ada") use ("-gnath"); + when "NT" => + for Switches ("Ada") use ("-gnatP"); + when others => + null; + end case; + end Compiler; +end MyProj; +@end group +@end smallexample + +@c --------------------------------------------- @node Attributes @subsection Attributes @c --------------------------------------------- +@menu +* Project Level Attributes:: +* Package Binder Attributes:: +* Package Builder Attributes:: +* Package Check Attributes:: +* Package Clean Attributes:: +* Package Compiler Attributes:: +* Package Cross_Reference Attributes:: +* Package Eliminate Attributes:: +* Package Finder Attributes:: +* Package gnatls Attributes:: +* Package gnatstub Attributes:: +* Package IDE Attributes:: +* Package Install Attributes:: +* Package Linker Attributes:: +* Package Metrics Attribute:: +* Package Naming Attributes:: +* Package Pretty_Printer Attributes:: +* Package Remote Attributes:: +* Package Stack Attributes:: +* Package Synchronize Attributes:: +@end menu + @noindent A project (and its packages) may have @b{attributes} that define the project's properties. Some attributes have values that are strings; @@ -3570,7 +3656,7 @@ Here are some examples of attribute declarations: @end smallexample @noindent -Attributes references may be appear anywhere in expressions, and are used +Attributes references may appear anywhere in expressions, and are used to retrieve the value previously assigned to the attribute. If an attribute has not been set in a given package or project, its value defaults to the empty string or the empty list. @@ -3608,1099 +3694,1253 @@ The prefix of an attribute may be: @end itemize @noindent -Legal attribute names are listed below, including the package in -which they must be declared. These names are case-insensitive. The -semantics for the attributes is explained in great details in other sections. - -The column @emph{index} indicates whether the attribute is an indexed attribute, -and when it is whether its index is case sensitive (sensitive) or not (insensitive), or if case sensitivity depends is the same as file names sensitivity on the -system (file). The text is between brackets ([]) if the index is optional. - -@multitable @columnfractions .3 .1 .2 .4 -@headitem Attribute Name @tab Value @tab Package @tab Index -@headitem General attributes @tab @tab @tab @pxref{Building With Projects} -@item Name @tab string @tab - @tab (Read-only, name of project) -@item Project_Dir @tab string @tab - @tab (Read-only, directory of project) -@item Source_Files @tab list @tab - @tab - -@item Source_Dirs @tab list @tab - @tab - -@item Source_List_File @tab string @tab - @tab - -@item Locally_Removed_Files @tab list @tab - @tab - -@item Excluded_Source_Files @tab list @tab - @tab - -@item Object_Dir @tab string @tab - @tab - -@item Exec_Dir @tab string @tab - @tab - -@item Excluded_Source_Dirs @tab list @tab - @tab - -@item Excluded_Source_Files @tab list @tab - @tab - -@item Excluded_Source_List_File @tab list @tab - @tab - -@item Inherit_Source_Path @tab list @tab - @tab insensitive -@item Languages @tab list @tab - @tab - -@item Main @tab list @tab - @tab - -@item Main_Language @tab string @tab - @tab - -@item Externally_Built @tab string @tab - @tab - -@item Roots @tab list @tab - @tab file -@headitem - Library-related attributes @tab @tab @tab @pxref{Library Projects} -@item Library_Dir @tab string @tab - @tab - -@item Library_Name @tab string @tab - @tab - -@item Library_Kind @tab string @tab - @tab - -@item Library_Version @tab string @tab - @tab - -@item Library_Interface @tab string @tab - @tab - -@item Library_Auto_Init @tab string @tab - @tab - -@item Library_Options @tab list @tab - @tab - -@item Leading_Library_Options @tab list @tab - @tab - -@item Library_Src_Dir @tab string @tab - @tab - -@item Library_ALI_Dir @tab string @tab - @tab - -@item Library_GCC @tab string @tab - @tab - -@item Library_Symbol_File @tab string @tab - @tab - -@item Library_Symbol_Policy @tab string @tab - @tab - -@item Library_Reference_Symbol_File @tab string @tab - @tab - -@item Interfaces @tab list @tab - @tab - -@headitem - Naming @tab @tab @tab @pxref{Naming Schemes} -@item Spec_Suffix @tab string @tab Naming @tab insensitive (language) -@item Body_Suffix @tab string @tab Naming @tab insensitive (language) -@item Separate_Suffix @tab string @tab Naming @tab - -@item Casing @tab string @tab Naming @tab - -@item Dot_Replacement @tab string @tab Naming @tab - -@item Spec @tab string @tab Naming @tab insensitive (Ada unit) -@item Body @tab string @tab Naming @tab insensitive (Ada unit) -@item Specification_Exceptions @tab list @tab Naming @tab insensitive (language) -@item Implementation_Exceptions @tab list @tab Naming @tab insensitive (language) -@headitem - Building @tab @tab @tab @pxref{Switches and Project Files} -@item Default_Switches @tab list @tab Builder, Compiler, Binder, Linker, Cross_Reference, Finder, Pretty_Printer, gnatstub, Check, Synchronize, Eliminate, Metrics, IDE @tab insensitive (language name) -@item Switches @tab list @tab Builder, Compiler, Binder, Linker, Cross_Reference, Finder, gnatls, Pretty_Printer, gnatstub, Check, Synchronize, Eliminate, Metrics, Stack @tab [file] (file name) -@item Local_Configuration_Pragmas @tab string @tab Compiler @tab - -@item Local_Config_File @tab string @tab insensitive @tab - -@item Global_Configuration_Pragmas @tab list @tab Builder @tab - -@item Global_Compilation_Switches @tab list @tab Builder @tab language -@item Executable @tab string @tab Builder @tab [file] -@item Executable_Suffix @tab string @tab Builder @tab - -@item Global_Config_File @tab string @tab Builder @tab insensitive (language) -@headitem - IDE (used and created by GPS) @tab @tab @tab -@item Remote_Host @tab string @tab IDE @tab - -@item Program_Host @tab string @tab IDE @tab - -@item Communication_Protocol @tab string @tab IDE @tab - -@item Compiler_Command @tab string @tab IDE @tab insensitive (language) -@item Debugger_Command @tab string @tab IDE @tab - -@item Gnatlist @tab string @tab IDE @tab - -@item Gnat @tab string @tab IDE @tab - -@item VCS_Kind @tab string @tab IDE @tab - -@item VCS_File_Check @tab string @tab IDE @tab - -@item VCS_Log_Check @tab string @tab IDE @tab - -@item Documentation_Dir @tab string @tab IDE @tab - -@headitem - Configuration files @tab @tab @tab See gprbuild manual -@item Default_Language @tab string @tab - @tab - -@item Run_Path_Option @tab list @tab - @tab - -@item Run_Path_Origin @tab string @tab - @tab - -@item Separate_Run_Path_Options @tab string @tab - @tab - -@item Toolchain_Version @tab string @tab - @tab insensitive -@item Toolchain_Description @tab string @tab - @tab insensitive -@item Object_Generated @tab string @tab - @tab insensitive -@item Objects_Linked @tab string @tab - @tab insensitive -@item Target @tab string @tab - @tab - -@item Library_Builder @tab string @tab - @tab - -@item Library_Support @tab string @tab - @tab - -@item Archive_Builder @tab list @tab - @tab - -@item Archive_Builder_Append_Option @tab list @tab - @tab - -@item Archive_Indexer @tab list @tab - @tab - -@item Archive_Suffix @tab string @tab - @tab - -@item Library_Partial_Linker @tab list @tab - @tab - -@item Shared_Library_Prefix @tab string @tab - @tab - -@item Shared_Library_Suffix @tab string @tab - @tab - -@item Symbolic_Link_Supported @tab string @tab - @tab - -@item Library_Major_Minor_Id_Supported @tab string @tab - @tab - -@item Library_Auto_Init_Supported @tab string @tab - @tab - -@item Shared_Library_Minimum_Switches @tab list @tab - @tab - -@item Library_Version_Switches @tab list @tab - @tab - -@item Library_Install_Name_Option @tab string @tab - @tab - -@item Runtime_Library_Dir @tab string @tab - @tab insensitive -@item Runtime_Source_Dir @tab string @tab - @tab insensitive -@item Driver @tab string @tab Compiler,Binder,Linker @tab insensitive (language) -@item Required_Switches @tab list @tab Compiler,Binder,Linker @tab insensitive (language) -@item Leading_Required_Switches @tab list @tab Compiler @tab insensitive (language) -@item Trailing_Required_Switches @tab list @tab Compiler @tab insensitive (language) -@item Pic_Options @tab list @tab Compiler @tab insensitive (language) -@item Path_Syntax @tab string @tab Compiler @tab insensitive (language) -@item Object_File_Suffix @tab string @tab Compiler @tab insensitive (language) -@item Object_File_Switches @tab list @tab Compiler @tab insensitive (language) -@item Multi_Unit_Switches @tab list @tab Compiler @tab insensitive (language) -@item Multi_Unit_Object_Separator @tab string @tab Compiler @tab insensitive (language) -@item Mapping_File_Switches @tab list @tab Compiler @tab insensitive (language) -@item Mapping_Spec_Suffix @tab string @tab Compiler @tab insensitive (language) -@item Mapping_body_Suffix @tab string @tab Compiler @tab insensitive (language) -@item Config_File_Switches @tab list @tab Compiler @tab insensitive (language) -@item Config_Body_File_Name @tab string @tab Compiler @tab insensitive (language) -@item Config_Body_File_Name_Index @tab string @tab Compiler @tab insensitive (language) -@item Config_Body_File_Name_Pattern @tab string @tab Compiler @tab insensitive (language) -@item Config_Spec_File_Name @tab string @tab Compiler @tab insensitive (language) -@item Config_Spec_File_Name_Index @tab string @tab Compiler @tab insensitive (language) -@item Config_Spec_File_Name_Pattern @tab string @tab Compiler @tab insensitive (language) -@item Config_File_Unique @tab string @tab Compiler @tab insensitive (language) -@item Dependency_Switches @tab list @tab Compiler @tab insensitive (language) -@item Dependency_Driver @tab list @tab Compiler @tab insensitive (language) -@item Include_Switches @tab list @tab Compiler @tab insensitive (language) -@item Include_Path @tab string @tab Compiler @tab insensitive (language) -@item Include_Path_File @tab string @tab Compiler @tab insensitive (language) -@item Prefix @tab string @tab Binder @tab insensitive (language) -@item Objects_Path @tab string @tab Binder @tab insensitive (language) -@item Objects_Path_File @tab string @tab Binder @tab insensitive (language) -@item Linker_Options @tab list @tab Linker @tab - -@item Leading_Switches @tab list @tab Linker @tab - -@item Map_File_Options @tab string @tab Linker @tab - -@item Executable_Switches @tab list @tab Linker @tab - -@item Lib_Dir_Switch @tab string @tab Linker @tab - -@item Lib_Name_Switch @tab string @tab Linker @tab - -@item Max_Command_Line_Length @tab string @tab Linker @tab - -@item Response_File_Format @tab string @tab Linker @tab - -@item Response_File_Switches @tab list @tab Linker @tab - -@end multitable -@c --------------------------------------------- -@node Case Statements -@subsection Case Statements -@c --------------------------------------------- +In the following sections, all predefined attributes are succinctly described, +first the project level attributes, that is those attributes that are not in a +package, then the attributes in the different packages. -@noindent -A @b{case} statement is used in a project file to effect conditional -behavior. Through this statement, you can set the value of attributes -and variables depending on the value previously assigned to a typed -variable. +It is possible for different tools to create dynamically new packages with +attributes, or new attribute in predefined packages. These attributes are +not documented here. -All choices in a choice list must be distinct. Unlike Ada, the choice -lists of all alternatives do not need to include all values of the type. -An @code{others} choice must appear last in the list of alternatives. +The attributes under Configuration headings are usually found only in +configuration project files. -The syntax of a @code{case} construction is based on the Ada case statement -(although the @code{null} statement for empty alternatives is optional). +The characteristics of each attribute are indicated as follows: -The case expression must be a typed string variable, whose value is often -given by an external reference (@pxref{External Values}). +@itemize @bullet -Each alternative starts with the reserved word @code{when}, either a list of -literal strings separated by the @code{"|"} character or the reserved word -@code{others}, and the @code{"=>"} token. -Each literal string must belong to the string type that is the type of the -case variable. -After each @code{=>}, there are zero or more statements. The only -statements allowed in a case construction are other case statements, -attribute declarations and variable declarations. String type declarations and -package declarations are not allowed. Variable declarations are restricted to -variables that have already been declared before the case construction. +@item @b{Type of value} -@smallexample -case_statement ::= - @i{case} @i{<typed_variable_>}name @i{is} @{case_item@} @i{end case} ; +The value of an attribute may be a single string, indicated by the word +"single", or a string list, indicated by the word "list". -case_item ::= - @i{when} discrete_choice_list => - @{case_statement - | attribute_declaration - | variable_declaration - | empty_declaration@} +@item @b{Read-only} -discrete_choice_list ::= string_literal @{| string_literal@} | @i{others} -@end smallexample +When the attribute is read-only, that is when it is not allowed to declare +the attribute, this is indicated by the words "read-only". -@noindent -Here is a typical example: +@item @b{Optional index} -@smallexample @c projectfile -@group -project MyProj is - type OS_Type is ("GNU/Linux", "Unix", "NT", "VMS"); - OS : OS_Type := external ("OS", "GNU/Linux"); +If it is allowed in the value of the attribute (both single and list) to have +an optional index, this is indicated by the words "optional index". - package Compiler is - case OS is - when "GNU/Linux" | "Unix" => - for Switches ("Ada") use ("-gnath"); - when "NT" => - for Switches ("Ada") use ("-gnatP"); - when others => - null; - end case; - end Compiler; -end MyProj; -@end group -@end smallexample +@item @b{Indexed attribute} -@c --------------------------------------------- -@node Tools Supporting Project Files -@chapter Tools Supporting Project Files -@c --------------------------------------------- +When an it is an indexed attribute, this is indicated by the word "indexed". -@noindent +@item @b{Case-sensitivity of the index} -@menu -* gnatmake and Project Files:: -* The GNAT Driver and Project Files:: -* The Development Environments:: -@end menu +For an indexed attribute, if the index is case-insensitive, this is indicated +by the words "case-insensitive index". -@c --------------------------------------------- -@node gnatmake and Project Files -@section gnatmake and Project Files -@c --------------------------------------------- +@item @b{File name index} + +For an indexed attribute, when the index is a file name, this is indicated by +the words "file name index". The index may or may not be case-sensitive, +depending on the platform. + +@item @b{others allowed in index} + +For an indexed attribute, if it is allowed to use @b{others} as the index, +this is indicated by the words "others allowed". + +@end itemize +@node Project Level Attributes +@subsubsection Project Level Attributes @noindent -This section covers several topics related to @command{gnatmake} and -project files: defining ^switches^switches^ for @command{gnatmake} -and for the tools that it invokes; specifying configuration pragmas; -the use of the @code{Main} attribute; building and rebuilding library project -files. -@menu -* Switches Related to Project Files:: -* Switches and Project Files:: -* Specifying Configuration Pragmas:: -* Project Files and Main Subprograms:: -* Library Project Files:: -@end menu +@itemize @bullet -@c --------------------------------------------- -@node Switches Related to Project Files -@subsection Switches Related to Project Files -@c --------------------------------------------- +@item @b{General} +@itemize @bullet + +@item @b{Name}: single, read-only + +The name of the project. + +@item @b{Project_Dir}: single, read-only + +The path name of the project directory. + +@item @b{Main}: list, optional index + +The list of main sources for the executables. + +@item @b{Languages}: list + +The list of languages of the sources of the project. + +@item @b{Roots}: list, indexed, file name index + +The index is the file name of an executable source. Indicates the list of units +from the main project that need to be bound and linked with their closures +with the executable. The index is either a file name, a language name or "*". +The roots for an executable source are those in @b{Roots} with an index that +is the executable source file name, if declared. Otherwise, they are those in +@b{Roots} with an index that is the language name of the executable source, +if present. Otherwise, they are those in @b{Roots ("*")}, if declared. If none +of these three possibilities are declared, then there are no roots for the +executable source. + +@item @b{Externally_Built}: single + +Indicates if the project is externally built. +Only case-insensitive values allowed are "true" and "false", the default. + +@end itemize @noindent -The following switches are used by GNAT tools that support project files: -@table @option +@item @b{Directories} -@item ^-P^/PROJECT_FILE=^@var{project} -@cindex @option{^-P^/PROJECT_FILE^} (any project-aware tool) -Indicates the name of a project file. This project file will be parsed with -the verbosity indicated by @option{^-vP^MESSAGE_PROJECT_FILES=^@emph{x}}, -if any, and using the external references indicated -by @option{^-X^/EXTERNAL_REFERENCE^} switches, if any. -@ifclear vms -There may zero, one or more spaces between @option{-P} and @var{project}. -@end ifclear +@itemize @bullet -There must be only one @option{^-P^/PROJECT_FILE^} switch on the command line. +@item @b{Object_Dir}: single -Since the Project Manager parses the project file only after all the switches -on the command line are checked, the order of the switches -@option{^-P^/PROJECT_FILE^}, -@option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} -or @option{^-X^/EXTERNAL_REFERENCE^} is not significant. +Indicates the object directory for the project. -@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} -@cindex @option{^-X^/EXTERNAL_REFERENCE^} (any project-aware tool) -Indicates that external variable @var{name} has the value @var{value}. -The Project Manager will use this value for occurrences of -@code{external(name)} when parsing the project file. +@item @b{Exec_Dir}: single -@ifclear vms -If @var{name} or @var{value} includes a space, then @var{name=value} should be -put between quotes. -@smallexample - -XOS=NT - -X"user=John Doe" -@end smallexample -@end ifclear +Indicates the exec directory for the project, that is the directory where the +executables are. -Several @option{^-X^/EXTERNAL_REFERENCE^} switches can be used simultaneously. -If several @option{^-X^/EXTERNAL_REFERENCE^} switches specify the same -@var{name}, only the last one is used. +@item @b{Source_Dirs}: list -An external variable specified with a @option{^-X^/EXTERNAL_REFERENCE^} switch -takes precedence over the value of the same name in the environment. +The list of source directories of the project. -@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} -@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (any project-aware tool) -Indicates the verbosity of the parsing of GNAT project files. +@item @b{Inherit_Source_Path}: list, indexed, case-insensitive index -@ifclear vms -@option{-vP0} means Default; -@option{-vP1} means Medium; -@option{-vP2} means High. -@end ifclear +Index is a language name. Value is a list of language names. Indicates that +in the source search path of the index language the source directories of +the languages in the list should be included. -@ifset vms -There are three possible options for this qualifier: DEFAULT, MEDIUM and -HIGH. -@end ifset +Example: -The default is ^Default^DEFAULT^: no output for syntactically correct -project files. -If several @option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} switches are present, -only the last one is used. +for Inherit_Source_Path ("C++") use ("C"); -@item ^-aP^/ADD_PROJECT_SEARCH_DIR=^<dir> -@cindex @option{^-aP^/ADD_PROJECT_SEARCH_DIR=^} (any project-aware tool) -Add directory <dir> at the beginning of the project search path, in order, -after the current working directory. +@item @b{Exclude_Source_Dirs}: list -@ifclear vms -@item -eL -@cindex @option{-eL} (any project-aware tool) -Follow all symbolic links when processing project files. -@end ifclear +The list of directories that are included in Source_Dirs but are not source +directories of the project. -@item ^--subdirs^/SUBDIRS^=<subdir> -@cindex @option{^--subdirs^/SUBDIRS^=} (gnatmake and gnatclean) -This switch is recognized by @command{gnatmake} and @command{gnatclean}. It -indicate that the real directories (except the source directories) are the -subdirectories <subdir> of the directories specified in the project files. -This applies in particular to object directories, library directories and -exec directories. If the subdirectories do not exist, they are created -automatically. +@item @b{Ignore_Source_Sub_Dirs}: list -@end table +Value is a list of simple names for subdirectories that are removed from the +list of source directories, including theur subdirectories. -@c --------------------------------------------- -@node Switches and Project Files -@subsection Switches and Project Files -@c --------------------------------------------- +@end itemize -@noindent -@ifset vms -It is not currently possible to specify VMS style qualifiers in the project -files; only Unix style ^switches^switches^ may be specified. -@end ifset +@item @b{Source Files} -For each of the packages @code{Builder}, @code{Compiler}, @code{Binder}, and -@code{Linker}, you can specify a @code{^Default_Switches^Default_Switches^} -attribute, a @code{Switches} attribute, or both; -as their names imply, these ^switch^switch^-related -attributes affect the ^switches^switches^ that are used for each of these GNAT -components when -@command{gnatmake} is invoked. As will be explained below, these -component-specific ^switches^switches^ precede -the ^switches^switches^ provided on the @command{gnatmake} command line. +@itemize @bullet -The @code{^Default_Switches^Default_Switches^} attribute is an attribute -indexed by language name (case insensitive) whose value is a string list. -For example: +@item @b{Source_Files}: list -@smallexample @c projectfile -@group -package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnaty^-gnaty^", - "^-v^-v^"); -end Compiler; -@end group -@end smallexample +Value is a list of source file simple names. -@noindent -The @code{Switches} attribute is indexed on a file name (which may or may -not be case sensitive, depending -on the operating system) whose value is a string list. For example: +@item @b{Locally_Removed_Files}: list -@smallexample @c projectfile -@group -package Builder is - for Switches ("main1.adb") - use ("^-O2^-O2^"); - for Switches ("main2.adb") - use ("^-g^-g^"); -end Builder; -@end group -@end smallexample +Obsolescent. Equivalent to Excluded_Source_Files. -@noindent -For the @code{Builder} package, the file names must designate source files -for main subprograms. For the @code{Binder} and @code{Linker} packages, the -file names must designate @file{ALI} or source files for main subprograms. -In each case just the file name without an explicit extension is acceptable. - -For each tool used in a program build (@command{gnatmake}, the compiler, the -binder, and the linker), the corresponding package @dfn{contributes} a set of -^switches^switches^ for each file on which the tool is invoked, based on the -^switch^switch^-related attributes defined in the package. -In particular, the ^switches^switches^ -that each of these packages contributes for a given file @var{f} comprise: +@item @b{Excluded_Source_Files}: list + +Value is a list of simple file names that are not sources of the project. +Allows to remove sources that are inherited or found in the source directories +and that match the naming scheme. + +@item @b{Source_List_File}: single + +Value is a text file name that contains a list of source file simple names, +one on each line. + +@item @b{Excluded_Source_List_File}: single + +Value is a text file name that contains a list of file simple names that +are not sources of the project. + +@item @b{Interfaces}: list + +Value is a list of file names that constitutes the interfaces of the project. + +@end itemize + +@item @b{Aggregate Projects} @itemize @bullet -@item the value of attribute @code{Switches (@var{f})}, - if it is specified in the package for the given file, -@item otherwise, the value of @code{^Default_Switches^Default_Switches^ ("Ada")}, - if it is specified in the package. + +@item @b{Project_Files}: list + +Value is the list of aggregated projects. + +@item @b{Project_Path}: list + +Value is a list of directories that are added to the project search path when +looking for the aggregated projects. + +@item @b{External}: single, indexed + +Index is the name of an external reference. Value is the value of the +external reference to be used when parsing the aggregated projects. @end itemize -@noindent -If neither of these attributes is defined in the package, then the package does -not contribute any ^switches^switches^ for the given file. +@item @b{Libraries} -When @command{gnatmake} is invoked on a file, the ^switches^switches^ comprise -two sets, in the following order: those contributed for the file -by the @code{Builder} package; -and the switches passed on the command line. +@itemize @bullet -When @command{gnatmake} invokes a tool (compiler, binder, linker) on a file, -the ^switches^switches^ passed to the tool comprise three sets, -in the following order: +@item @b{Library_Dir}: single -@enumerate -@item -the applicable ^switches^switches^ contributed for the file -by the @code{Builder} package in the project file supplied on the command line; +Value is the name of the library directory. This attribute needs to be +declared for each library project. -@item -those contributed for the file by the package (in the relevant project file -- -see below) corresponding to the tool; and +@item @b{Library_Name}: single -@item -the applicable switches passed on the command line. -@end enumerate +Value is the name of the library. This attribute needs to be declared or +inherited for each library project. -The term @emph{applicable ^switches^switches^} reflects the fact that -@command{gnatmake} ^switches^switches^ may or may not be passed to individual -tools, depending on the individual ^switch^switch^. +@item @b{Library_Kind}: single -@command{gnatmake} may invoke the compiler on source files from different -projects. The Project Manager will use the appropriate project file to -determine the @code{Compiler} package for each source file being compiled. -Likewise for the @code{Binder} and @code{Linker} packages. +Specifies the kind of library: static library (archive) or shared library. +Case-insensitive values must be one of "static" for archives (the default) or +"dynamic" or "relocatable" for shared libraries. -As an example, consider the following package in a project file: +@item @b{Library_Version}: single -@smallexample @c projectfile -@group -project Proj1 is - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-g^-g^"); - for Switches ("a.adb") - use ("^-O1^-O1^"); - for Switches ("b.adb") - use ("^-O2^-O2^", - "^-gnaty^-gnaty^"); - end Compiler; -end Proj1; -@end group -@end smallexample +Value is the name of the library file. -@noindent -If @command{gnatmake} is invoked with this project file, and it needs to -compile, say, the files @file{a.adb}, @file{b.adb}, and @file{c.adb}, then -@file{a.adb} will be compiled with the ^switch^switch^ -@option{^-O1^-O1^}, -@file{b.adb} with ^switches^switches^ -@option{^-O2^-O2^} -and @option{^-gnaty^-gnaty^}, -and @file{c.adb} with @option{^-g^-g^}. - -The following example illustrates the ordering of the ^switches^switches^ -contributed by different packages: +@item @b{Library_Interface}: list -@smallexample @c projectfile -@group -project Proj2 is - package Builder is - for Switches ("main.adb") - use ("^-g^-g^", - "^-O1^-)1^", - "^-f^-f^"); - end Builder; -@end group +Value is the list of unit names that constitutes the interfaces +of a Stand-Alone Library project. -@group - package Compiler is - for Switches ("main.adb") - use ("^-O2^-O2^"); - end Compiler; -end Proj2; -@end group -@end smallexample +@item @b{Library_Standalone}: single -@noindent -If you issue the command: +Specifies if a Stand-Alone Library (SAL) is encapsulated or not. +Only authorized case-insensitive values are "standard" for non encapsulated +SALs, "encapsulated" for encapsulated SALs or "no" for non SAL library project. -@smallexample - gnatmake ^-Pproj2^/PROJECT_FILE=PROJ2^ -O0 main -@end smallexample +@item @b{Library_Encapsulated_Options}: list -@noindent -then the compiler will be invoked on @file{main.adb} with the following -sequence of ^switches^switches^ +Value is a list of options that need to be used when linking an encapsulated +Stand-Alone Library. -@smallexample - ^-g -O1 -O2 -O0^-g -O1 -O2 -O0^ -@end smallexample +@item @b{Library_Encapsulated_Supported}: single -@noindent -with the last @option{^-O^-O^} -^switch^switch^ having precedence over the earlier ones; -several other ^switches^switches^ -(such as @option{^-c^-c^}) are added implicitly. +Indicates if encapsulated Stand-Alone Libraries are supported. Only +authorized case-insensitive values are "true" and "false" (the default). -The ^switches^switches^ -@option{^-g^-g^} -and @option{^-O1^-O1^} are contributed by package -@code{Builder}, @option{^-O2^-O2^} is contributed -by the package @code{Compiler} -and @option{^-O0^-O0^} comes from the command line. +@item @b{Library_Auto_Init}: single -The @option{^-g^-g^} -^switch^switch^ will also be passed in the invocation of -@command{Gnatlink.} +Indicates if a Stand-Alone Library is auto-initialized. Only authorized +case-insentive values are "true" and "false". -A final example illustrates switch contributions from packages in different -project files: +@item @b{Leading_Library_Options}: list -@smallexample @c projectfile -@group -project Proj3 is - for Source_Files use ("pack.ads", "pack.adb"); - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnata^-gnata^"); - end Compiler; -end Proj3; -@end group +Value is a list of options that are to be used at the beginning of +the command line when linking a shared library. -@group -with "Proj3"; -project Proj4 is - for Source_Files use ("foo_main.adb", "bar_main.adb"); - package Builder is - for Switches ("foo_main.adb") - use ("^-s^-s^", - "^-g^-g^"); - end Builder; -end Proj4; -@end group +@item @b{Library_Options}: list -@group --- Ada source file: -with Pack; -procedure Foo_Main is - @dots{} -end Foo_Main; -@end group -@end smallexample +Value is a list of options that are to be used when linking a shared library. -@noindent -If the command is -@smallexample -gnatmake ^-PProj4^/PROJECT_FILE=PROJ4^ foo_main.adb -cargs -gnato -@end smallexample +@item @b{Library_Src_Dir}: single -@noindent -then the ^switches^switches^ passed to the compiler for @file{foo_main.adb} are -@option{^-g^-g^} (contributed by the package @code{Proj4.Builder}) and -@option{^-gnato^-gnato^} (passed on the command line). -When the imported package @code{Pack} is compiled, the ^switches^switches^ used -are @option{^-g^-g^} from @code{Proj4.Builder}, -@option{^-gnata^-gnata^} (contributed from package @code{Proj3.Compiler}, -and @option{^-gnato^-gnato^} from the command line. - -When using @command{gnatmake} with project files, some ^switches^switches^ or -arguments may be expressed as relative paths. As the working directory where -compilation occurs may change, these relative paths are converted to absolute -paths. For the ^switches^switches^ found in a project file, the relative paths -are relative to the project file directory, for the switches on the command -line, they are relative to the directory where @command{gnatmake} is invoked. -The ^switches^switches^ for which this occurs are: -^-I^-I^, -^-A^-A^, -^-L^-L^, -^-aO^-aO^, -^-aL^-aL^, -^-aI^-aI^, as well as all arguments that are not switches (arguments to -^switch^switch^ -^-o^-o^, object files specified in package @code{Linker} or after --largs on the command line). The exception to this rule is the ^switch^switch^ -^--RTS=^--RTS=^ for which a relative path argument is never converted. +Value is the name of the directory where copies of the sources of the +interfaces of a Stand-Alone Library are to be copied. -@c --------------------------------------------- -@node Specifying Configuration Pragmas -@subsection Specifying Configuration Pragmas -@c --------------------------------------------- +@item @b{Library_ALI_Dir}: single -@noindent -When using @command{gnatmake} with project files, if there exists a file -@file{gnat.adc} that contains configuration pragmas, this file will be -ignored. - -Configuration pragmas can be defined by means of the following attributes in -project files: @code{Global_Configuration_Pragmas} in package @code{Builder} -and @code{Local_Configuration_Pragmas} in package @code{Compiler}. - -Both these attributes are single string attributes. Their values is the path -name of a file containing configuration pragmas. If a path name is relative, -then it is relative to the project directory of the project file where the -attribute is defined. - -When compiling a source, the configuration pragmas used are, in order, -those listed in the file designated by attribute -@code{Global_Configuration_Pragmas} in package @code{Builder} of the main -project file, if it is specified, and those listed in the file designated by -attribute @code{Local_Configuration_Pragmas} in package @code{Compiler} of -the project file of the source, if it exists. +Value is the name of the directory where the ALI files of the interfaces +of a Stand-Alone Library are to be copied. When this attribute is not declared, +the directory is the library directory. -@c --------------------------------------------- -@node Project Files and Main Subprograms -@subsection Project Files and Main Subprograms -@c --------------------------------------------- +@item @b{Library_gcc}: single -@noindent -When using a project file, you can invoke @command{gnatmake} -with one or several main subprograms, by specifying their source files on the -command line. +Obsolescent attribute. Specify the linker driver used to link a shared library. +Use instead attribute Linker'Driver. -@smallexample - gnatmake ^-P^/PROJECT_FILE=^prj main1.adb main2.adb main3.adb -@end smallexample +@item @b{Library_Symbol_File}: single -@noindent -Each of these needs to be a source file of the same project, except -when the switch ^-u^/UNIQUE^ is used. - -When ^-u^/UNIQUE^ is not used, all the mains need to be sources of the -same project, one of the project in the tree rooted at the project specified -on the command line. The package @code{Builder} of this common project, the -"main project" is the one that is considered by @command{gnatmake}. - -When ^-u^/UNIQUE^ is used, the specified source files may be in projects -imported directly or indirectly by the project specified on the command line. -Note that if such a source file is not part of the project specified on the -command line, the ^switches^switches^ found in package @code{Builder} of the -project specified on the command line, if any, that are transmitted -to the compiler will still be used, not those found in the project file of -the source file. - -When using a project file, you can also invoke @command{gnatmake} without -explicitly specifying any main, and the effect depends on whether you have -defined the @code{Main} attribute. This attribute has a string list value, -where each element in the list is the name of a source file (the file -extension is optional) that contains a unit that can be a main subprogram. - -If the @code{Main} attribute is defined in a project file as a non-empty -string list and the switch @option{^-u^/UNIQUE^} is not used on the command -line, then invoking @command{gnatmake} with this project file but without any -main on the command line is equivalent to invoking @command{gnatmake} with all -the file names in the @code{Main} attribute on the command line. +Value is the name of the library symbol file. -Example: -@smallexample @c projectfile -@group - project Prj is - for Main use ("main1.adb", "main2.adb", "main3.adb"); - end Prj; -@end group -@end smallexample +@item @b{Library_Symbol_Policy}: single -@noindent -With this project file, @code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^"} -is equivalent to -@code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^ main1.adb main2.adb main3.adb"}. - -When the project attribute @code{Main} is not specified, or is specified -as an empty string list, or when the switch @option{-u} is used on the command -line, then invoking @command{gnatmake} with no main on the command line will -result in all immediate sources of the project file being checked, and -potentially recompiled. Depending on the presence of the switch @option{-u}, -sources from other project files on which the immediate sources of the main -project file depend are also checked and potentially recompiled. In other -words, the @option{-u} switch is applied to all of the immediate sources of the -main project file. - -When no main is specified on the command line and attribute @code{Main} exists -and includes several mains, or when several mains are specified on the -command line, the default ^switches^switches^ in package @code{Builder} will -be used for all mains, even if there are specific ^switches^switches^ -specified for one or several mains. - -But the ^switches^switches^ from package @code{Binder} or @code{Linker} will be -the specific ^switches^switches^ for each main, if they are specified. +Indicates the symbol policy kind. Only authorized case-insensitive values are +"autonomous", "default", "compliant", "controlled" or "direct". -@c --------------------------------------------- -@node Library Project Files -@subsection Library Project Files -@c --------------------------------------------- +@item @b{Library_Reference_Symbol_File}: single -@noindent -When @command{gnatmake} is invoked with a main project file that is a library -project file, it is not allowed to specify one or more mains on the command -line. +Value is the name of the reference symbol file. -When a library project file is specified, switches ^-b^/ACTION=BIND^ and -^-l^/ACTION=LINK^ have special meanings. +@end itemize + +@item @b{Configuration - General} @itemize @bullet -@item ^-b^/ACTION=BIND^ is only allowed for stand-alone libraries. It indicates - to @command{gnatmake} that @command{gnatbind} should be invoked for the - library. -@item ^-l^/ACTION=LINK^ may be used for all library projects. It indicates - to @command{gnatmake} that the binder generated file should be compiled - (in the case of a stand-alone library) and that the library should be built. +@item @b{Default_Language}: single + +Value is the case-insensitive name of the language of a project when attribute +Languages is not specified. + +@item @b{Run_Path_Option}: list + +Value is the list of switches to be used when specifying the run path option +in an executable. + +@item @b{Run_Path_Origin}: single + +Value is the the string that may replace the path name of the executable +directory in the run path options. + +@item @b{Separate_Run_Path_Options}: single + +Indicates if there may be or not several run path options specified when +linking an executable. Only authorized case-insensitive b=values are "true" or +"false" (the default). + +@item @b{Toolchain_Version}: single, indexed, case-insensitive index + +Index is a language name. Specify the version of a toolchain for a language. + +@item @b{Toolchain_Description}: single, indexed, case-insensitive index + +Obsolescent. No longer used. + +@item @b{Object_Generated}: single, indexed, case-insensitive index + +Index is a language name. Indicates if invoking the compiler for a language +produces an object file. Only authorized case-insensitive values are "false" +and "true" (the default). + +@item @b{Objects_Linked}: single, indexed, case-insensitive index + +Index is a language name. Indicates if the object files created by the compiler +for a language need to be linked in the executable. Only authorized +case-insensitive values are "false" and "true" (the default). + +@item @b{Target}: single + +Value is the name of the target platform. + @end itemize -@c --------------------------------------------- -@node The GNAT Driver and Project Files -@section The GNAT Driver and Project Files -@c --------------------------------------------- +@item @b{Configuration - Libraries} -@noindent -A number of GNAT tools, other than @command{^gnatmake^gnatmake^} -can benefit from project files: -(@command{^gnatbind^gnatbind^}, -@command{^gnatcheck^gnatcheck^}, -@command{^gnatclean^gnatclean^}, -@command{^gnatelim^gnatelim^}, -@command{^gnatfind^gnatfind^}, -@command{^gnatlink^gnatlink^}, -@command{^gnatls^gnatls^}, -@command{^gnatmetric^gnatmetric^}, -@command{^gnatpp^gnatpp^}, -@command{^gnatstub^gnatstub^}, -and @command{^gnatxref^gnatxref^}). However, none of these tools can be invoked -directly with a project file switch (@option{^-P^/PROJECT_FILE=^}). -They must be invoked through the @command{gnat} driver. - -The @command{gnat} driver is a wrapper that accepts a number of commands and -calls the corresponding tool. It was designed initially for VMS platforms (to -convert VMS qualifiers to Unix-style switches), but it is now available on all -GNAT platforms. - -On non-VMS platforms, the @command{gnat} driver accepts the following commands -(case insensitive): +@itemize @bullet + +@item @b{Library_Builder}: single + +Value is the path name of the application that is to be used to build +libraries. Usually the path name of "gprlib". + +@item @b{Library_Support}: single + +Indicates the level of support of libraries. Only authorized case-insensitive +values are "static_only", "full" or "none" (the default). + +@end itemize + +@item @b{Configuration - Archives} @itemize @bullet -@item BIND to invoke @command{^gnatbind^gnatbind^} -@item CHOP to invoke @command{^gnatchop^gnatchop^} -@item CLEAN to invoke @command{^gnatclean^gnatclean^} -@item COMP or COMPILE to invoke the compiler -@item ELIM to invoke @command{^gnatelim^gnatelim^} -@item FIND to invoke @command{^gnatfind^gnatfind^} -@item KR or KRUNCH to invoke @command{^gnatkr^gnatkr^} -@item LINK to invoke @command{^gnatlink^gnatlink^} -@item LS or LIST to invoke @command{^gnatls^gnatls^} -@item MAKE to invoke @command{^gnatmake^gnatmake^} -@item NAME to invoke @command{^gnatname^gnatname^} -@item PREP or PREPROCESS to invoke @command{^gnatprep^gnatprep^} -@item PP or PRETTY to invoke @command{^gnatpp^gnatpp^} -@item METRIC to invoke @command{^gnatmetric^gnatmetric^} -@item STUB to invoke @command{^gnatstub^gnatstub^} -@item XREF to invoke @command{^gnatxref^gnatxref^} + +@item @b{Archive_Builder}: list + +Value is the name of the application to be used to create a static library +(archive), followed by the options to be used. + +@item @b{Archive_Builder_Append_Option}: list + +Value is the list of options to be used when invoking the archive builder +to add project files into an archive. + +@item @b{Archive_Indexer}: list + +Value is the name of the archive indexer, followed by the required options. + +@item @b{Archive_Suffix}: single + +Value is the extension of archives. When not declared, the extension is ".a". + +@item @b{Library_Partial_Linker}: list + +Value is the name of the partial linker executable, followed by the required +options. @end itemize -@noindent -(note that the compiler is invoked using the command -@command{^gnatmake -f -u -c^gnatmake -f -u -c^}). +@item @b{Configuration - Shared Libraries} + +@itemize @bullet + +@item @b{Shared_Library_Prefix}: single + +Value is the prefix in the name of shared library files. When not declared, +the prefix is "lib". + +@item @b{Shared_Library_Suffix}: single + +Value is the the extension of the name of shared library files. When not +declared, the extension is ".so". + +@item @b{Symbolic_Link_Supported}: single + +Indicates if symbolic links are supported on the platform. Only authorized +case-insensitive values are "true" and "false" (the default). + +@item @b{Library_Major_Minor_Id_Supported}: single + +Indicates if major and minor ids for shared library names are supported on +the platform. Only authorized case-insensitive values are "true" and "false" +(the default). + +@item @b{Library_Auto_Init_Supported}: single + +Indicates if auto-initialization of Stand-Alone Libraries is supported. Only +authorized case-insensitive values are "true" and "false" (the default). + +@item @b{Shared_Library_Minimum_Switches}: list + +Value is the list of required switches when linking a shared library. + +@item @b{Library_Version_Switches}: list -On non-VMS platforms, between @command{gnat} and the command, two -special switches may be used: +Value is the list of switches to specify a internal name for a shared library. + +@item @b{Library_Install_Name_Option}: single + +Value is the name of the option that needs to be used, concatenated with the +path name of the library file, when linking a shared library. + +@item @b{Runtime_Library_Dir}: single, indexed, case-insensitive index + +Index is a language name. Value is the path name of the directory where the +runtime libraries are located. + +@item @b{Runtime_Source_Dir}: single, indexed, case-insensitive index + +Index is a language name. Value is the path name of the directory where the +sources of runtime libraries are located. + +@end itemize + +@end itemize + +@node Package Binder Attributes +@subsubsection Package Binder Attributes @itemize @bullet -@item @command{-v} to display the invocation of the tool. -@item @command{-dn} to prevent the @command{gnat} driver from removing - the temporary files it has created. These temporary files are - configuration files and temporary file list files. + +@item @b{General} + +@itemize @bullet + +@item @b{Default_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of switches to be used when binding +code of the language, if there is no applicable attribute Switches. + +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed + +Index is either a language name or a source file name. Value is the list of +switches to be used when binding code. Index is either the source file name +of the executable to be bound or the language name of the code to be bound. @end itemize -@noindent -The command may be followed by switches and arguments for the invoked -tool. +@item @b{Configuration - Binding} -@smallexample - gnat bind -C main.ali - gnat ls -a main - gnat chop foo.txt -@end smallexample +@itemize @bullet -@noindent -Switches may also be put in text files, one switch per line, and the text -files may be specified with their path name preceded by '@@'. +@item @b{Driver}: single, indexed, case-insensitive index -@smallexample - gnat bind @@args.txt main.ali -@end smallexample +Index is a language name. Value is the name of the application to be used when +binding code of the language. -@noindent -In addition, for commands BIND, COMP or COMPILE, FIND, ELIM, LS or LIST, LINK, -METRIC, PP or PRETTY, STUB and XREF, the project file related switches -(@option{^-P^/PROJECT_FILE^}, -@option{^-X^/EXTERNAL_REFERENCE^} and -@option{^-vP^/MESSAGES_PROJECT_FILE=^x}) may be used in addition to -the switches of the invoking tool. - -When GNAT PP or GNAT PRETTY is used with a project file, but with no source -specified on the command line, it invokes @command{^gnatpp^gnatpp^} with all -the immediate sources of the specified project file. - -When GNAT METRIC is used with a project file, but with no source -specified on the command line, it invokes @command{^gnatmetric^gnatmetric^} -with all the immediate sources of the specified project file and with -@option{^-d^/DIRECTORY^} with the parameter pointing to the object directory -of the project. - -In addition, when GNAT PP, GNAT PRETTY or GNAT METRIC is used with -a project file, no source is specified on the command line and -switch ^-U^/ALL_PROJECTS^ is specified on the command line, then -the underlying tool (^gnatpp^gnatpp^ or -^gnatmetric^gnatmetric^) is invoked for all sources of all projects, -not only for the immediate sources of the main project. -@ifclear vms -(-U stands for Universal or Union of the project files of the project tree) -@end ifclear +@item @b{Required_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of the required switches to be +used when binding code of the language. + +@item @b{Prefix}: single, indexed, case-insensitive index + +Index is a language name. Value is a prefix to be used for the binder exchange +file name for the language. Used to have different binder exchange file names +when binding different languages. + +@item @b{Objects_Path}: single,indexed, case-insensitive index + +Index is a language name. Value is the name of the environment variable that +contains the path for the object directories. + +@item @b{Object_Path_File}: single,indexed, case-insensitive index -For each of the following commands, there is optionally a corresponding -package in the main project. +Index is a language name. Value is the name of the environment variable. The +value of the environment variable is the path name of a text file that +contains the list of object directories. + +@end itemize + +@end itemize + +@node Package Builder Attributes +@subsubsection Package Builder Attributes @itemize @bullet -@item package @code{Binder} for command BIND (invoking @code{^gnatbind^gnatbind^}) -@item package @code{Check} for command CHECK (invoking - @code{^gnatcheck^gnatcheck^}) +@item @b{Default_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of builder switches to be used when +building an executable of the language, if there is no applicable attribute +Switches. -@item package @code{Compiler} for command COMP or COMPILE (invoking the compiler) +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed -@item package @code{Cross_Reference} for command XREF (invoking - @code{^gnatxref^gnatxref^}) +Index is either a language name or a source file name. Value is the list of +builder switches to be used when building an executable. Index is either the +source file name of the executable to be built or its language name. -@item package @code{Eliminate} for command ELIM (invoking - @code{^gnatelim^gnatelim^}) +@item @b{Global_Compilation_Switches}: list, optional index, indexed, + case-insensitive index -@item package @code{Finder} for command FIND (invoking @code{^gnatfind^gnatfind^}) +Index is either a language name or a source file name. Value is the list of +compilation switches to be used when building an executable. Index is either +the source file name of the executable to be built or its language name. -@item package @code{Gnatls} for command LS or LIST (invoking @code{^gnatls^gnatls^}) +@item @b{Executable}: single, indexed, case-insensitive index -@item package @code{Gnatstub} for command STUB - (invoking @code{^gnatstub^gnatstub^}) +Index is an executable source file name. Value is the simple file name of the +executable to be built. -@item package @code{Linker} for command LINK (invoking @code{^gnatlink^gnatlink^}) +@item @b{Executable_Suffix}: single -@item package @code{Check} for command CHECK - (invoking @code{^gnatcheck^gnatcheck^}) +Value is the extension of the file names of executable. When not specified, +the extension is the default extension of executables on the platform. -@item package @code{Metrics} for command METRIC - (invoking @code{^gnatmetric^gnatmetric^}) +@item @b{Global_Configuration_Pragmas}: single -@item package @code{Pretty_Printer} for command PP or PRETTY - (invoking @code{^gnatpp^gnatpp^}) +Value is the file name of a configuration pragmas file that is specified to +the Ada compiler when compiling any Ada source in the project tree. + +@item @b{Global_Config_File}: single, indexed, case-insensitive index + +Index is a language name. Value is the file name of a configuration file that +is specified to the compiler when compiling any source of the language in the +project tree. @end itemize -@noindent -Package @code{Gnatls} has a unique attribute @code{Switches}, -a simple variable with a string list value. It contains ^switches^switches^ -for the invocation of @code{^gnatls^gnatls^}. +@node Package Check Attributes +@subsubsection Package Check Attributes -@smallexample @c projectfile -@group -project Proj1 is - package gnatls is - for Switches - use ("^-a^-a^", - "^-v^-v^"); - end gnatls; -end Proj1; -@end group -@end smallexample +@itemize @bullet -@noindent -All other packages have two attribute @code{Switches} and -@code{^Default_Switches^Default_Switches^}. +@item @b{Default_Switches}: list, indexed, case-insensitive index -@code{Switches} is an indexed attribute, indexed by the -source file name, that has a string list value: the ^switches^switches^ to be -used when the tool corresponding to the package is invoked for the specific -source file. +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. -@code{^Default_Switches^Default_Switches^} is an attribute, -indexed by the programming language that has a string list value. -@code{^Default_Switches^Default_Switches^ ("Ada")} contains the -^switches^switches^ for the invocation of the tool corresponding -to the package, except if a specific @code{Switches} attribute -is specified for the source file. +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed -@smallexample @c projectfile -@group -project Proj is +Index is a source file name. Value is the list of switches to be used when +invoking @code{gnatcheck} for the source. - for Source_Dirs use ("**"); +@end itemize - package gnatls is - for Switches use - ("^-a^-a^", - "^-v^-v^"); - end gnatls; -@end group -@group +@node Package Clean Attributes +@subsubsection Package Clean Attributes - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnatv^-gnatv^", - "^-gnatwa^-gnatwa^"); - end Binder; -@end group -@group +@itemize @bullet - package Binder is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-C^-C^", - "^-e^-e^"); - end Binder; -@end group -@group +@item @b{Switches}: list - package Linker is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-C^-C^"); - for Switches ("main.adb") - use ("^-C^-C^", - "^-v^-v^", - "^-v^-v^"); - end Linker; -@end group -@group +Value is a list of switches to be used by the cleaning application. - package Finder is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-a^-a^", - "^-f^-f^"); - end Finder; -@end group -@group +@item @b{Source_Artifact_Extensions}: list, indexed, case-insensitive index - package Cross_Reference is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-a^-a^", - "^-f^-f^", - "^-d^-d^", - "^-u^-u^"); - end Cross_Reference; -end Proj; -@end group -@end smallexample +Index is a language names. Value is the list of extensions for file names +derived from object file names that need to be cleaned in the object +directory of the project. -@noindent -With the above project file, commands such as +@item @b{Object_Artifact_Extensions}: list, indexed, case-insensitive index -@smallexample - ^gnat comp -Pproj main^GNAT COMP /PROJECT_FILE=PROJ MAIN^ - ^gnat ls -Pproj main^GNAT LIST /PROJECT_FILE=PROJ MAIN^ - ^gnat xref -Pproj main^GNAT XREF /PROJECT_FILE=PROJ MAIN^ - ^gnat bind -Pproj main.ali^GNAT BIND /PROJECT_FILE=PROJ MAIN.ALI^ - ^gnat link -Pproj main.ali^GNAT LINK /PROJECT_FILE=PROJ MAIN.ALI^ -@end smallexample +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. -@noindent -will set up the environment properly and invoke the tool with the switches -found in the package corresponding to the tool: -@code{^Default_Switches^Default_Switches^ ("Ada")} for all tools, -except @code{Switches ("main.adb")} -for @code{^gnatlink^gnatlink^}. -It is also possible to invoke some of the tools, -(@code{^gnatcheck^gnatcheck^}, -@code{^gnatmetric^gnatmetric^}, -and @code{^gnatpp^gnatpp^}) -on a set of project units thanks to the combination of the switches -@option{-P}, @option{-U} and possibly the main unit when one is interested -in its closure. For instance, -@smallexample -gnat metric -Pproj -@end smallexample +@end itemize -@noindent -will compute the metrics for all the immediate units of project -@code{proj}. -@smallexample -gnat metric -Pproj -U -@end smallexample +@node Package Compiler Attributes +@subsubsection Package Compiler Attributes -@noindent -will compute the metrics for all the units of the closure of projects -rooted at @code{proj}. -@smallexample -gnat metric -Pproj -U main_unit -@end smallexample +@itemize @bullet -@noindent -will compute the metrics for the closure of units rooted at -@code{main_unit}. This last possibility relies implicitly -on @command{gnatbind}'s option @option{-R}. But if the argument files for the -tool invoked by the @command{gnat} driver are explicitly specified -either directly or through the tool @option{-files} option, then the tool -is called only for these explicitly specified files. +@item @b{General} -@c --------------------------------------------- -@node The Development Environments -@section The Development Environments -@c --------------------------------------------- +@itemize @bullet -@noindent -See the appropriate manuals for more details. These environments will -store a number of settings in the project itself, when they are meant -to be shared by the whole team working on the project. Here are the -attributes defined in the package @b{IDE} in projects. +@item @b{Default_Switches}: list, indexed, case-insensitive index -@table @code -@item Remote_Host -This is a simple attribute. Its value is a string that designates the remote -host in a cross-compilation environment, to be used for remote compilation and -debugging. This field should not be specified when running on the local -machine. - -@item Program_Host -This is a simple attribute. Its value is a string that specifies the -name of IP address of the embedded target in a cross-compilation environment, -on which the program should execute. - -@item Communication_Protocol -This is a simple string attribute. Its value is the name of the protocol -to use to communicate with the target in a cross-compilation environment, -e.g.@: @code{"wtx"} or @code{"vxworks"}. - -@item Compiler_Command -This is an associative array attribute, whose domain is a language name. Its -value is string that denotes the command to be used to invoke the compiler. -The value of @code{Compiler_Command ("Ada")} is expected to be compatible with -@command{gnatmake}, in particular in the handling of switches. - -@item Debugger_Command -This is simple attribute, Its 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 Default_Switches -This is an associative array attribute. Its indexes are the name of the -external tools that the GNAT Programming System (GPS) is supporting. Its -value is a list of switches to use when invoking that tool. - -@item Gnatlist -This is a simple attribute. Its value is a string that specifies the name -of the @command{gnatls} utility to be used to retrieve information about the -predefined path; e.g., @code{"gnatls"}, @code{"powerpc-wrs-vxworks-gnatls"}. - -@item VCS_Kind -This is a simple attribute. Its value is a string used to specify the -Version Control System (VCS) to be used for this project, e.g.@: CVS, RCS -ClearCase or Perforce. - -@item Gnat -This is a simple attribute. Its value is a string that specifies the name -of the @command{gnat} utility to be used when executing various tools from -GPS, in particular @code{"gnat pp"}, @code{"gnat stub"},@dots{} - -@item VCS_File_Check -This is a simple attribute. Its value is a string that specifies the -command used by the VCS to check the validity of a file, either -when the user explicitly asks for a check, or as a sanity check before -doing the check-in. - -@item VCS_Log_Check -This is a simple attribute. Its value is a string that specifies -the command used by the VCS to check the validity of a log file. - -@item VCS_Repository_Root -The VCS repository root path. This is used to create tags or branches -of the repository. For subversion the value should be the @code{URL} -as specified to check-out the working copy of the repository. - -@item VCS_Patch_Root -The local root directory to use for building patch file. All patch chunks -will be relative to this path. The root project directory is used if -this value is not defined. +Index is a language name. Value is a list of switches to be used when invoking +the compiler for the language for a source of the project, if there is no +applicable attribute Switches. + +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed + +Index is a source file name or a language name. Value is the list of switches +to be used when invoking the compiler for the source or for its language. + +@item @b{Local_Configuration_Pragmas}: single + +Value is the file name of a configuration pragmas file that is specified to +the Ada compiler when compiling any Ada source in the project. + +@item @b{Local_Config_File}: single, indexed, case-insensitive index + +Index is a language name. Value is the file name of a configuration file that +is specified to the compiler when compiling any source of the language in the +project. + +@end itemize + +@item @b{Configuration - Compiling} + +@itemize @bullet + +@item @b{Driver}: single, indexed, case-insensitive index + +Index is a language name. Value is the name of the executable for the compiler +of the language. + +@item @b{Language_Kind}: single, indexed, case-insensitive index + +Index is a language name. Indicates the kind of the language, either file based +or unit based. Only authorized case-insensitive values are "unit_based" and +"file_based" (the default). + +@item @b{Dependency_Kind}: : single, indexed, case-insensitive index + +Index is a language name. Indicates how the dependencies are handled for the +language. Only authorized case-insensitive values are "makefile", "ali_file", +"ali_closure" or "none" (the default. + +@item @b{Required_Switches}: list, indexed, case-insensitive index + +Equivalent to attribute Leading_Required_Switches. + +@item @b{Leading_Required_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of the minimum switches to be used +at the beginning of the command line when invoking the compiler for the +language. + +@item @b{Trailing_Required_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of the minimum switches to be used +at the end of the command line when invoking the compiler for the language. + +@item @b{PIC_Option}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of switches to be used when +compiling a source of the language when the project is a shared library +project. + +@item @b{Path_Syntax}: single, indexed, case-insensitive index + +Index is a language name. Value is the kind of path syntax to be used when +invoking the compiler for the language. Only authorized case-insensitive +values are "canonical" and "host" (the default). + +@item @b{Source_File_Switches}: single, indexed, case-insensitive index + +Index is a language name. Value is a list of switches to be used just before +the path name of the source to compile when invoking the compiler for a source +of the language. + +@item @b{Object_File_Suffix}: single, indexed, case-insensitive index + +Index is a language name. Value is the extension of the object files created +by the compiler of the language. When not specified, the extension is the +default one for the platform. + +@item @b{Object_File_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of switches to be used by the +compiler of the language to specify the path name of the object file. When not +specified, the switch used is "-o". + +@item @b{Multi_Unit_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of switches to be used to compile +a unit in a multi unit source of the language. The index of the unit in the +source is concatenated with the last switches in the list. + +@item @b{Multi_Unit_Object_Separator}: single, indexed, case-insensitive index + +Index is a language name. Value is the string to be used in the object file +name before the index of the unit, when compiling a unit in a multi unit source +of the language. + +@end itemize + +@item @b{Configuration - Mapping Files} + +@itemize @bullet + +@item @b{Mapping_File_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of switches to be used to specify +a mapping file when invoking the compiler for a source of the language. + +@item @b{Mapping_Spec_Suffix}: single, indexed, case-insensitive index + +Index is a language name. Value is the suffix to be used in a mapping file +to indicate that the source is a spec. + +@item @b{Mapping_Body_Suffix}: single, indexed, case-insensitive index + +Index is a language name. Value is the suffix to be used in a mapping file +to indicate that the source is a body. + +@end itemize + +@item @b{Configuration - Config Files} + +@itemize @bullet + +@item @b{Config_File_Switches}: list: single, indexed, case-insensitive index + +Index is a language name. Value is the list of switches to specify to the +compiler of the language a configuration file. + +@item @b{Config_Body_File_Name}: single, indexed, case-insensitive index + +Index is a language name. Value is the template to be used to indicate a +configuration specific to a body of the language in a configuration +file. + +@item @b{Config_Body_File_Name_Index}: single, indexed, case-insensitive index + +Index is a language name. Value is the template to be used to indicate a +configuration specific to the body a unit in a multi unit source of the +language in a configuration file. + +@item @b{Config_Body_File_Name_Pattern}: single, indexed, + case-insensitive index + +Index is a language name. Value is the template to be used to indicate a +configuration for all bodies of the languages in a configuration file. + +@item @b{Config_Spec_File_Name}: single, indexed, case-insensitive index + +Index is a language name. Value is the template to be used to indicate a +configuration specific to a spec of the language in a configuration +file. + +@item @b{Config_Spec_File_Name_Index}: single, indexed, case-insensitive index + +Index is a language name. Value is the template to be used to indicate a +configuration specific to the spec a unit in a multi unit source of the +language in a configuration file. + +@item @b{Config_Spec_File_Name_Pattern}: single, indexed, + case-insensitive index + +Index is a language name. Value is the template to be used to indicate a +configuration for all specs of the languages in a configuration file. + +@item @b{Config_File_Unique}: single, indexed, case-insensitive index + +Index is a language name. Indicates if there should be only one configuration +file specified to the compiler of the language. Only authorized +case-insensitive values are "true" and "false" (the default). + +@end itemize + +@item @b{Configuration - Dependencies} + +@itemize @bullet + +@item @b{Dependency_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of switches to be used to specify +to the compiler the dependency file when the dependency kind of the language is +file based, and when Dependency_Driver is not specified for the language. + +@item @b{Dependency_Driver}: list, indexed, case-insensitive index + +Index is a language name. Value is the name of the executable to be used to +create the dependency file for a source of the language, followed by the +required switches. + +@end itemize + +@item @b{Configuration - Search Paths} + +@itemize @bullet + +@item @b{Include_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of switches to specify to the +compiler of the language to indicate a directory to look for sources. + +@item @b{Include_Path}: single, indexed, case-insensitive index + +Index is a language name. Value is the name of an environment variable that +contains the path of all the directories that the compiler of the language +may search for sources. + +@item @b{Include_Path_File}: single, indexed, case-insensitive index + +Index is a language name. Value is the name of an environment variable the +value of which is the path name of a text file that contains the directories +that the compiler of the language may search for sources. + +@item @b{Object_Path_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is the list of switches to specify to the +compiler of the language the name of a text file that contains the list of +object directories. When this attribute is not declared, the text file is +not created. + +@end itemize + +@end itemize + +@node Package Cross_Reference Attributes +@subsubsection Package Cross_Reference Attributes + +@itemize @bullet + +@item @b{Default_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is a list of switches to be used when invoking +@code{gnatxref} for a source of the language, if there is no applicable +attribute Switches. + +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed + +Index is a source file name. Value is the list of switches to be used when +invoking @code{gnatxref} for the source. + +@end itemize + +@node Package Eliminate Attributes +@subsubsection Package Eliminate Attributes + +@itemize @bullet + +@item @b{Default_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is a list of switches to be used when invoking +@code{gnatelim} for a source of the language, if there is no applicable +attribute Switches. + +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed + +Index is a source file name. Value is the list of switches to be used when +invoking @code{gnatelim} for the source. + +@end itemize + +@node Package Finder Attributes +@subsubsection Package Finder Attributes + +@itemize @bullet + +@item @b{Default_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is a list of switches to be used when invoking +@code{gnatfind} for a source of the language, if there is no applicable +attribute Switches. + +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed + +Index is a source file name. Value is the list of switches to be used when +invoking @code{gnatfind} for the source. + +@end itemize + +@node Package gnatls Attributes +@subsubsection Package gnatls Attributes + +@itemize @bullet + +@item @b{Switches}: list + +Value is a list of switches to be used when invoking @code{gnatls}. + +@end itemize + +@node Package gnatstub Attributes +@subsubsection Package gnatstub Attributes + +@itemize @bullet + +@item @b{Default_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is a list of switches to be used when invoking +@code{gnatstub} for a source of the language, if there is no applicable +attribute Switches. + +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed + +Index is a source file name. Value is the list of switches to be used when +invoking @code{gnatstub} for the source. + +@end itemize + +@node Package IDE Attributes +@subsubsection Package IDE Attributes + +@itemize @bullet + +@item @b{Default_Switches}: list, indexed + +Index is the name of an external tool that the GNAT Programming System (GPS) +is supporting. Value is a list of switches to use when invoking that tool. + +@item @b{Remote_Host}: single + +Value is a string that designates the remote host in a cross-compilation +environment, to be used for remote compilation and debugging. This attribute +should not be specified when running on the local machine. + +@item @b{Program_Host}: single + +Value is a string that specifies the name of IP address of the embedded target +in a cross-compilation environment, on which the program should execute. + +@item @b{Communication_Protocol}: single + +Value is the name of the protocol to use to communicate with the target +in a cross-compilation environment, for example @code{"wtx"} or +@code{"vxworks"}. + +@item @b{Compiler_Command}: single, indexed, case-insensitive index + +Index is a language Name. Value is a string that denotes the command to be +used to invoke the compiler. The value of @code{Compiler_Command ("Ada")} is +expected to be compatible with @command{gnatmake}, in particular in +the handling of switches. + +@item @b{Debugger_Command}: single + +Value is a string that specifies the name of the debugger to be used, such as +gdb, powerpc-wrs-vxworks-gdb or gdb-4. + +@item @b{gnatlist}: single + +Value is a string that specifies the name of the @command{gnatls} utility +to be used to retrieve information about the predefined path; for example, +@code{"gnatls"}, @code{"powerpc-wrs-vxworks-gnatls"}. + +@item @b{VCS_Kind}: single + +Value is a string used to specify the Version Control System (VCS) to be used +for this project, for example CVS, RCS, ClearCase or Perforce. + +@item @b{VCS_File_Check}: single + +Value is a string that specifies the command used by the VCS to check +the validity of a file, either when the user explicitly asks for a check, +or as a sanity check before doing the check-in. + +@item @b{VCS_Log_Check}: single + +Value is a string that specifies the command used by the VCS to check +the validity of a log file. + +@item @b{Documentation_Dir}: single + +Value is the directory used to generate the documentation of source code. + +@end itemize + +@node Package Install Attributes +@subsubsection Package Install Attributes + +@itemize @bullet + +@item @b{Prefix}: single + +Value is the install destination directory. + +@item @b{Sources_Subdir}: single + +Value is the sources directory or subdirectory of Prefix. + +@item @b{Exec_Subdir}: single + +Value is the executables directory or subdirectory of Prefix. + +@item @b{Lib_Subdir}: single + +Value is library directory or subdirectory of Prefix. + +@item @b{Project_Subdir}: single + +Value is the project directory or subdirectory of Prefix. + +@item @b{Active}: single + +Indicates that the project is to be installed or not. Case-insensitive value +"false" means that the project is not to be installed, all other values mean +that the project is to be installed. + +@end itemize + +@node Package Linker Attributes +@subsubsection Package Linker Attributes + +@itemize @bullet + +@item @b{General} + +@itemize @bullet + +@item @b{Required_Switches}: list + +Value is a list of switches that are required when invoking the linker to link +an executable. + +@item @b{Default_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is a list of switches for the linker when +linking an executable for a main source of the language, when there is no +applicable Switches. + +@item @b{Leading_Switches}: list, optional index, indexed, + case-insensitive index, others allowed + +Index is a source file name or a language name. Value is the list of switches +to be used at the beginning of the command line when invoking the linker to +build an executable for the source or for its language. + +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed + +Index is a source file name or a language name. Value is the list of switches +to be used when invoking the linker to build an executable for the source or +for its language. + +@item @b{Trailing_Switches}: list, optional index, indexed, + case-insensitive index, others allowed + +Index is a source file name or a language name. Value is the list of switches +to be used at the end of the command line when invoking the linker to +build an executable for the source or for its language. These switches may +override the Required_Switches. + +@item @b{Linker_Options}: list + +Value is a list of switches/options that are to be added when linking an +executable from a project importing the current project directly or indirectly. +Linker_Options are not used when linking an executable from the current +project. + +@item @b{Map_File_Option}: single + +Value is the switch to specify the map file name that the linker needs to +create. + +@end itemize + +@item @b{Configuration - Linking} + +@itemize @bullet + +@item @b{Driver}: single + +Value is the name of the linker executable. + +@end itemize + +@item @b{Configuration - Response Files} + +@itemize @bullet + +@item @b{Max_Command_Line_Length}: single + +Value is the maximum number of character in the command line when invoking +the linker to link an executable. + +@item @b{Response_File_Format}: single + +Indicates the kind of response file to create when the length of the linking +command line is too large. Only authorized case-insensitive values are "none", +"gnu", "object_list", "gcc_gnu", "gcc_option_list" and "gcc_object_list". + +@item @b{Response_File_Switches}: list + +Value is the list of switches to specify a response file to the linker. + +@end itemize + +@end itemize + +@node Package Metrics Attribute +@subsubsection Package Metrics Attribute + +@itemize @bullet + +@item @b{Default_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is a list of switches to be used when invoking +@code{gnatmetric} for a source of the language, if there is no applicable +attribute Switches. + +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed + +Index is a source file name. Value is the list of switches to be used when +invoking @code{gnatmetric} for the source. + +@end itemize + +@node Package Naming Attributes +@subsubsection Package Naming Attributes + +@itemize @bullet + +@item @b{Specification_Suffix}: single, indexed, case-insensitive index + +Equivalent to attribute Spec_Suffix. + +@item @b{Spec_Suffix}: single, indexed, case-insensitive index + +Index is a language name. Value is the extension of file names for specs of +the language. + +@item @b{Implementation_Suffix}: single, indexed, case-insensitive index + +Equivalent to attribute Body_Suffix. + +@item @b{Body_Suffix}: single, indexed, case-insensitive index + +Index is a language name. Value is the extension of file names for bodies of +the language. + +@item @b{Separate_Suffix}: single + +Value is the extension of file names for subunits of Ada. + +@item @b{Casing}: single + +Indicates the casing of sources of the Ada language. Only authorized +case-insensitive values are "lowercase", "uppercase" and "mixedcase". + +@item @b{Dot_Replacement}: single + +Value is the string that replace the dot of unit names in the source file names +of the Ada language. + +@item @b{Specification}: single, optional index, indexed, + case-insensitive index + +Equivalent to attribute Spec. + +@item @b{Spec}: single, optional index, indexed, case-insensitive index + +Index is a unit name. Value is the file name of the spec of the unit. + +@item @b{Implementation}: single, optional index, indexed, + case-insensitive index + +Equivalent to attribute Body. + +@item @b{Body}: single, optional index, indexed, case-insensitive index + +Index is a unit name. Value is the file name of the body of the unit. + +@item @b{Specification_Exceptions}: list, indexed, case-insensitive index + +Index is a language name. Value is a list of specs for the language that do not +necessarily follow the naming scheme for the language and that may or may not +be found in the source directories of the project. + +@item @b{Implementation_Exceptions}: list, indexed, case-insensitive index + +Index is a language name. Value is a list of bodies for the language that do not +necessarily follow the naming scheme for the language and that may or may not +be found in the source directories of the project. + +@end itemize + +@node Package Pretty_Printer Attributes +@subsubsection Package Pretty_Printer Attributes + +@itemize @bullet + +@item @b{Default_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is a list of switches to be used when invoking +@code{gnatpp} for a source of the language, if there is no applicable +attribute Switches. + +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed + +Index is a source file name. Value is the list of switches to be used when +invoking @code{gnatpp} for the source. + +@end itemize + +@node Package Remote Attributes +@subsubsection Package Remote Attributes + +@itemize @bullet + +@item @b{Build_Slaves}: list + +Value is the list of machine names that are to be used in distributed +compilation. + +@item @b{Root_Dir}: single + +Value is the root directory used by the slave machines. + +@end itemize + +@node Package Stack Attributes +@subsubsection Package Stack Attributes + +@itemize @bullet + +@item @b{Switches}: list + +Value is the list of switches to be used when invoking @code{gnatstack}. + +@end itemize + +@node Package Synchronize Attributes +@subsubsection Package Synchronize Attributes + +@itemize @bullet + +@item @b{Default_Switches}: list, indexed, case-insensitive index + +Index is a language name. Value is a list of switches to be used when invoking +@code{gnatsync} for a source of the language, if there is no applicable +attribute Switches. + +@item @b{Switches}: list, optional index, indexed, case-insensitive index, + others allowed + +Index is a source file name. Value is the list of switches to be used when +invoking @code{gnatsync} for the source. + +@end itemize -@end table diff --git a/gcc/ada/put_alfa.adb b/gcc/ada/put_spark_xrefs.adb index f4715bfdd84..f200e213270 100644 --- a/gcc/ada/put_alfa.adb +++ b/gcc/ada/put_spark_xrefs.adb @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- P U T _ A L F A -- +-- P U T _ S P A R K _ X R E F S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2012, 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- -- @@ -23,15 +23,15 @@ -- -- ------------------------------------------------------------------------------ -with Alfa; use Alfa; +with SPARK_Xrefs; use SPARK_Xrefs; -procedure Put_Alfa is +procedure Put_SPARK_Xrefs is begin - -- Loop through entries in Alfa_File_Table + -- Loop through entries in SPARK_File_Table - for J in 1 .. Alfa_File_Table.Last loop + for J in 1 .. SPARK_File_Table.Last loop declare - F : Alfa_File_Record renames Alfa_File_Table.Table (J); + F : SPARK_File_Record renames SPARK_File_Table.Table (J); Start : Scope_Index; Stop : Scope_Index; @@ -71,7 +71,7 @@ begin pragma Assert (Start <= Stop); declare - S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Start); + S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (Start); begin Write_Info_Initiate ('F'); @@ -109,11 +109,11 @@ begin end; end loop; - -- Loop through entries in Alfa_File_Table + -- Loop through entries in SPARK_File_Table - for J in 1 .. Alfa_File_Table.Last loop + for J in 1 .. SPARK_File_Table.Last loop declare - F : Alfa_File_Record renames Alfa_File_Table.Table (J); + F : SPARK_File_Record renames SPARK_File_Table.Table (J); Start : Scope_Index; Stop : Scope_Index; File : Nat; @@ -132,7 +132,7 @@ begin pragma Assert (Start <= Stop); Output_One_Scope : declare - S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Start); + S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (Start); XStart : Xref_Index; XStop : Xref_Index; @@ -177,8 +177,8 @@ begin pragma Assert (XStart <= XStop); Output_One_Xref : declare - R : Alfa_Xref_Record renames - Alfa_Xref_Table.Table (XStart); + R : SPARK_Xref_Record renames + SPARK_Xref_Table.Table (XStart); begin if R.Entity_Line /= Entity_Line @@ -240,4 +240,4 @@ begin end loop; end; end loop; -end Put_Alfa; +end Put_SPARK_Xrefs; diff --git a/gcc/ada/put_alfa.ads b/gcc/ada/put_spark_xrefs.ads index aee4ec384dd..fa0b81c068b 100644 --- a/gcc/ada/put_alfa.ads +++ b/gcc/ada/put_spark_xrefs.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- P U T _ A L F A -- +-- P U T _ S P A R K _ X R E F S -- -- -- -- S p e c -- -- -- --- 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- -- @@ -23,10 +23,11 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the function used to read Alfa information from the --- internal tables defined in package Alfa, and output text information for --- the ALI file. The interface allows control over the destination of the --- output, so that this routine can also be used for debugging purposes. +-- This package contains the function used to read SPARK cross-reference +-- information from the internal tables defined in package SPARK_Xrefs, and +-- output text information for the ALI file. The interface allows control over +-- the destination of the output, so that this routine can also be used for +-- debugging purposes. with Types; use Types; @@ -52,7 +53,7 @@ generic with procedure Write_Info_Terminate is <>; -- Terminate current info line and output lines built in Info_Buffer -procedure Put_Alfa; --- Read information from Alfa tables (Alfa.Alfa_Xref_Table, --- Alfa.Alfa_Scope_Table and Alfa.Alfa_File_Table) and output corresponding --- information in ALI format using the Write_Info procedures. +procedure Put_SPARK_Xrefs; +-- Read information from SPARK tables (SPARK_Xrefs.SPARK_Xref_Table, +-- SPARK_Xrefs.SPARK_Scope_Table and SPARK_Xrefs.SPARK_File_Table) and output +-- corresponding information in ALI format using the Write_Info procedures. diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index 42c5a5c4b45..a428642db1a 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -1019,7 +1019,7 @@ extern void __gnat_notify_unhandled_exception (struct Exception_Occurrence *); #ifdef __USING_SJLJ_EXCEPTIONS__ #define PERSONALITY_FUNCTION __gnat_personality_sj0 -#elif defined(__SEH__) +#elif defined (__SEH__) #define PERSONALITY_FUNCTION __gnat_personality_imp #else #define PERSONALITY_FUNCTION __gnat_personality_v0 @@ -1056,7 +1056,7 @@ typedef int version_arg_t; typedef _Unwind_Action phases_arg_t; #endif -#ifdef __SEH__ +#if defined (__SEH__) && !defined (__USING_SJLJ_EXCEPTIONS__) static #endif _Unwind_Reason_Code @@ -1222,7 +1222,7 @@ __gnat_Unwind_ForcedUnwind (_Unwind_Exception *e, #endif } -#ifdef __SEH__ +#if defined (__SEH__) && !defined (__USING_SJLJ_EXCEPTIONS__) #define STATUS_USER_DEFINED (1U << 29) diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index c3e6772ed50..a907c7b9d18 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -29,22 +29,23 @@ -- -- ------------------------------------------------------------------------------ -with Alloc; use Alloc; -with Atree; use Atree; -with Casing; use Casing; -with Debug; use Debug; -with Einfo; use Einfo; -with Lib; use Lib; -with Namet; use Namet; -with Opt; use Opt; -with Output; use Output; -with Sinfo; use Sinfo; -with Sinput; use Sinput; -with Snames; use Snames; -with Stand; use Stand; -with Table; use Table; -with Uname; use Uname; -with Urealp; use Urealp; +with Alloc; use Alloc; +with Atree; use Atree; +with Casing; use Casing; +with Debug; use Debug; +with Einfo; use Einfo; +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sem_Aux; use Sem_Aux; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with Table; use Table; +with Uname; use Uname; +with Urealp; use Urealp; with Ada.Unchecked_Conversion; @@ -113,7 +114,8 @@ package body Repinfo is Table_Name => "FE_Rep_Table"); Unit_Casing : Casing_Type; - -- Identifier casing for current unit + -- Identifier casing for current unit. This is set by List_Rep_Info for + -- each unit, before calling subprograms which may read it. Need_Blank_Line : Boolean; -- Set True if a blank line is needed before outputting any information for @@ -133,7 +135,7 @@ package body Repinfo is -- Called before outputting anything for an entity. Ensures that -- a blank line precedes the output for a particular entity. - procedure List_Entities (Ent : Entity_Id); + procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean); -- This procedure lists the entities associated with the entity E, starting -- with the First_Entity and using the Next_Entity link. If a nested -- package is found, entities within the package are recursively processed. @@ -142,7 +144,7 @@ package body Repinfo is -- List name of entity Ent in appropriate case. The name is listed with -- full qualification up to but not including the compilation unit name. - procedure List_Array_Info (Ent : Entity_Id); + procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean); -- List representation info for array type Ent procedure List_Mechanisms (Ent : Entity_Id); @@ -152,9 +154,14 @@ package body Repinfo is procedure List_Object_Info (Ent : Entity_Id); -- List representation info for object Ent - procedure List_Record_Info (Ent : Entity_Id); + procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean); -- List representation info for record type Ent + procedure List_Scalar_Storage_Order + (Ent : Entity_Id; + Bytes_Big_Endian : Boolean); + -- List scalar storage order information for record or array type Ent + procedure List_Type_Info (Ent : Entity_Id); -- List type info for type Ent @@ -286,7 +293,7 @@ package body Repinfo is -- List_Array_Info -- ---------------------- - procedure List_Array_Info (Ent : Entity_Id) is + procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is begin List_Type_Info (Ent); Write_Str ("for "); @@ -294,13 +301,15 @@ package body Repinfo is Write_Str ("'Component_Size use "); Write_Val (Component_Size (Ent)); Write_Line (";"); + + List_Scalar_Storage_Order (Ent, Bytes_Big_Endian); end List_Array_Info; ------------------- -- List_Entities -- ------------------- - procedure List_Entities (Ent : Entity_Id) is + procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is Body_E : Entity_Id; E : Entity_Id; @@ -379,12 +388,12 @@ package body Repinfo is elsif Is_Record_Type (E) then if List_Representation_Info >= 1 then - List_Record_Info (E); + List_Record_Info (E, Bytes_Big_Endian); end if; elsif Is_Array_Type (E) then if List_Representation_Info >= 1 then - List_Array_Info (E); + List_Array_Info (E, Bytes_Big_Endian); end if; elsif Is_Type (E) then @@ -411,7 +420,7 @@ package body Repinfo is if Ekind (E) = E_Package then if No (Renamed_Object (E)) then - List_Entities (E); + List_Entities (E, Bytes_Big_Endian); end if; -- Recurse into bodies @@ -428,12 +437,12 @@ package body Repinfo is or else Ekind (E) = E_Protected_Body then - List_Entities (E); + List_Entities (E, Bytes_Big_Endian); -- Recurse into blocks elsif Ekind (E) = E_Block then - List_Entities (E); + List_Entities (E, Bytes_Big_Endian); end if; end if; @@ -449,7 +458,6 @@ package body Repinfo is and then Present (Corresponding_Spec (Find_Declaration (Ent))) then E := First_Entity (Corresponding_Spec (Find_Declaration (Ent))); - while Present (E) loop if Is_Subprogram (E) and then @@ -461,7 +469,7 @@ package body Repinfo is and then Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit then - List_Entities (Body_E); + List_Entities (Body_E, Bytes_Big_Endian); end if; end if; @@ -675,6 +683,8 @@ package body Repinfo is Write_Line ("Intrinsic"); when Convention_Entry => Write_Line ("Entry"); + when Convention_Ghost => + Write_Line ("Ghost"); when Convention_Protected => Write_Line ("Protected"); when Convention_Assembler => @@ -716,7 +726,6 @@ package body Repinfo is Form := First_Formal (Ent); while Present (Form) loop Get_Unqualified_Decoded_Name_String (Chars (Form)); - while Name_Len <= Plen loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ' '; @@ -779,7 +788,7 @@ package body Repinfo is -- List_Record_Info -- ---------------------- - procedure List_Record_Info (Ent : Entity_Id) is + procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is Comp : Entity_Id; Cfbit : Uint; Sunit : Uint; @@ -963,13 +972,15 @@ package body Repinfo is end loop; Write_Line ("end record;"); + + List_Scalar_Storage_Order (Ent, Bytes_Big_Endian); end List_Record_Info; ------------------- -- List_Rep_Info -- ------------------- - procedure List_Rep_Info is + procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is Col : Nat; begin @@ -978,11 +989,11 @@ package body Repinfo is then for U in Main_Unit .. Last_Unit loop if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then + Unit_Casing := Identifier_Casing (Source_Index (U)); -- Normal case, list to standard output if not List_Representation_Info_To_File then - Unit_Casing := Identifier_Casing (Source_Index (U)); Write_Eol; Write_Str ("Representation information for unit "); Write_Unit_Name (Unit_Name (U)); @@ -994,7 +1005,7 @@ package body Repinfo is end loop; Write_Eol; - List_Entities (Cunit_Entity (U)); + List_Entities (Cunit_Entity (U), Bytes_Big_Endian); -- List representation information to file @@ -1002,7 +1013,7 @@ package body Repinfo is Create_Repinfo_File_Access.all (Get_Name_String (File_Name (Source_Index (U)))); Set_Special_Output (Write_Info_Line'Access); - List_Entities (Cunit_Entity (U)); + List_Entities (Cunit_Entity (U), Bytes_Big_Endian); Set_Special_Output (null); Close_Repinfo_File_Access.all; end if; @@ -1011,6 +1022,52 @@ package body Repinfo is end if; end List_Rep_Info; + ------------------------------- + -- List_Scalar_Storage_Order -- + ------------------------------- + + procedure List_Scalar_Storage_Order + (Ent : Entity_Id; + Bytes_Big_Endian : Boolean) + is + procedure List_Attr (Attr_Name : String); + -- Show attribute definition clause for Attr_Name + + --------------- + -- List_Attr -- + --------------- + + procedure List_Attr (Attr_Name : String) is + begin + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'" & Attr_Name & " use System."); + + if Bytes_Big_Endian xor Reverse_Storage_Order (Ent) then + Write_Str ("High"); + else + Write_Str ("Low"); + end if; + + Write_Line ("_Order_First;"); + end List_Attr; + + -- Start of processing for List_Scalar_Storage_Order + + begin + if Has_Rep_Item (Ent, Name_Scalar_Storage_Order) then + + -- For a record type with explicitly specified scalar storage order, + -- also display explicit Bit_Order. + + if Is_Record_Type (Ent) then + List_Attr ("Bit_Order"); + end if; + + List_Attr ("Scalar_Storage_Order"); + end if; + end List_Scalar_Storage_Order; + -------------------- -- List_Type_Info -- -------------------- @@ -1287,7 +1344,6 @@ package body Repinfo is when Discrim_Val => declare Sub : constant Int := UI_To_Int (Node.Op1); - begin pragma Assert (Sub in D'Range); return D (Sub); diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads index 652769924e7..99fccc34d4a 100644 --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2009, 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- -- @@ -283,8 +283,9 @@ package Repinfo is -- Compiler Interface -- ------------------------ - procedure List_Rep_Info; - -- Procedure to list representation information + procedure List_Rep_Info (Bytes_Big_Endian : Boolean); + -- Procedure to list representation information. Bytes_Big_Endian is the + -- value from Ttypes (Repinfo cannot have a dependency on Ttypes). procedure Tree_Write; -- Writes out internal tables to current tree file using the relevant diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index d4acf1dd912..2e5d2beb753 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.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,6 +68,24 @@ package body Restrict is -- Set True if any entry of No_Specifcation_Of_Aspects has been set True. -- Once set True, this is never turned off again. + No_Use_Of_Attribute : array (Attribute_Id) of Source_Ptr := + (others => No_Location); + + No_Use_Of_Attribute_Warning : array (Attribute_Id) of Boolean := + (others => False); + + No_Use_Of_Attribute_Set : Boolean := False; + -- Indicates that No_Use_Of_Attribute was set at least once + + No_Use_Of_Pragma : array (Pragma_Id) of Source_Ptr := + (others => No_Location); + + No_Use_Of_Pragma_Warning : array (Pragma_Id) of Boolean := + (others => False); + + No_Use_Of_Pragma_Set : Boolean := False; + -- Indicates that No_Use_Of_Pragma was set at least once + ----------------------- -- Local Subprograms -- ----------------------- @@ -287,6 +305,72 @@ package body Restrict is Check_Restriction (No_Implicit_Heap_Allocations, N); end Check_No_Implicit_Heap_Alloc; + ------------------------------------------- + -- Check_Restriction_No_Use_Of_Attribute -- + -------------------------------------------- + + procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id) is + Id : constant Name_Id := Chars (N); + A_Id : constant Attribute_Id := Get_Attribute_Id (Id); + + begin + -- Ignore call if node N is not in the main source unit, since we only + -- give messages for the main unit. This avoids giving messages for + -- aspects that are specified in withed units. + + if not In_Extended_Main_Source_Unit (N) then + return; + end if; + + -- If nothing set, nothing to check + + if not No_Use_Of_Attribute_Set then + return; + end if; + + Error_Msg_Sloc := No_Use_Of_Attribute (A_Id); + + if Error_Msg_Sloc /= No_Location then + Error_Msg_Node_1 := N; + Error_Msg_Warn := No_Use_Of_Attribute_Warning (A_Id); + Error_Msg_N + ("<violation of restriction `No_Use_Of_Attribute '='> &`#", N); + end if; + end Check_Restriction_No_Use_Of_Attribute; + + ---------------------------------------- + -- Check_Restriction_No_Use_Of_Pragma -- + ---------------------------------------- + + procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id) is + Id : constant Node_Id := Pragma_Identifier (N); + P_Id : constant Pragma_Id := Get_Pragma_Id (Chars (Id)); + + begin + -- Ignore call if node N is not in the main source unit, since we only + -- give messages for the main unit. This avoids giving messages for + -- aspects that are specified in withed units. + + if not In_Extended_Main_Source_Unit (N) then + return; + end if; + + -- If nothing set, nothing to check + + if not No_Use_Of_Pragma_Set then + return; + end if; + + Error_Msg_Sloc := No_Use_Of_Pragma (P_Id); + + if Error_Msg_Sloc /= No_Location then + Error_Msg_Node_1 := Id; + Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id); + Error_Msg_N + ("<violation of restriction `No_Use_Of_Pragma '='> &`#", Id); + end if; + end Check_Restriction_No_Use_Of_Pragma; + ----------------------------------- -- Check_Obsolescent_2005_Entity -- ----------------------------------- @@ -295,6 +379,10 @@ package body Restrict is function Chars_Is (E : Entity_Id; S : String) return Boolean; -- Return True iff Chars (E) matches S (given in lower case) + -------------- + -- Chars_Is -- + -------------- + function Chars_Is (E : Entity_Id; S : String) return Boolean is Nam : constant Name_Id := Chars (E); begin @@ -476,12 +564,12 @@ package body Restrict is begin Msg_Issued := False; - -- In CodePeer and Alfa mode, we do not want to check for any + -- In CodePeer and SPARK mode, we do not want to check for any -- restriction, or set additional restrictions other than those already -- set in gnat1drv.adb so that we have consistency between each -- compilation. - if CodePeer_Mode or Alfa_Mode then + if CodePeer_Mode or SPARK_Mode then return; end if; @@ -1271,6 +1359,44 @@ package body Restrict is No_Specification_Of_Aspect_Set := True; end Set_Restriction_No_Specification_Of_Aspect; + ----------------------------------------- + -- Set_Restriction_No_Use_Of_Attribute -- + ----------------------------------------- + + procedure Set_Restriction_No_Use_Of_Attribute + (N : Node_Id; + Warning : Boolean) + is + A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); + + begin + No_Use_Of_Attribute_Set := True; + No_Use_Of_Attribute (A_Id) := Sloc (N); + + if Warning = False then + No_Use_Of_Attribute_Warning (A_Id) := False; + end if; + end Set_Restriction_No_Use_Of_Attribute; + + -------------------------------------- + -- Set_Restriction_No_Use_Of_Pragma -- + -------------------------------------- + + procedure Set_Restriction_No_Use_Of_Pragma + (N : Node_Id; + Warning : Boolean) + is + A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N)); + + begin + No_Use_Of_Pragma_Set := True; + No_Use_Of_Pragma (A_Id) := Sloc (N); + + if Warning = False then + No_Use_Of_Pragma_Warning (A_Id) := False; + end if; + end Set_Restriction_No_Use_Of_Pragma; + ---------------------------------- -- Suppress_Restriction_Message -- ---------------------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 54702abd10c..f54fb4b811a 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.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- -- @@ -62,7 +62,7 @@ package Restrict is -- since we want the binder to be able to accurately diagnose inter-unit -- restriction violations. - Restriction_Warnings : Rident.Restriction_Flags; + Restriction_Warnings : Rident.Restriction_Flags := (others => False); -- If one of these flags is set, then it means that violation of the -- corresponding restriction results only in a warning message, not -- in an error message, and the restriction is not otherwise enforced. @@ -252,6 +252,16 @@ package Restrict is -- Wrapper on Check_Restriction with Msg_Issued, with the out-parameter -- being ignored here. + procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id); + -- N is the node of an attribute definition clause. An error message + -- (warning) will be issued if a restriction (warning) was previously set + -- for this attribute using Set_No_Use_Of_Attribute. + + procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id); + -- N is the node of a pragma. An error message (warning) will be issued + -- if a restriction (warning) was previously set for this pragma using + -- Set_No_Use_Of_Pragma. + procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id); -- Called when a dependence on a unit is created (either implicitly, or by -- an explicit WITH clause). U is a node for the unit involved, and Err is @@ -416,6 +426,19 @@ package Restrict is -- case of a Restriction_Warnings pragma specifying this restriction and -- False for a Restrictions pragma specifying this restriction. + procedure Set_Restriction_No_Use_Of_Attribute + (N : Node_Id; + Warning : Boolean); + -- N is the node id for the identifier in a pragma Restrictions for + -- No_Use_Of_Attribute. Caller has verified that this is a valid attribute + -- designator. + + procedure Set_Restriction_No_Use_Of_Pragma + (N : Node_Id; + Warning : Boolean); + -- N is the node id for the identifier in a pragma Restrictions for + -- No_Use_Of_Pragma. Caller has verified that this is a valid pragma id. + function Tasking_Allowed return Boolean; pragma Inline (Tasking_Allowed); -- Tests if tasking operations are allowed by the current restrictions diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 5327da54aac..382d2d1b015 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -537,15 +537,11 @@ package body Rtsfind is return Nkind (Prf) = N_Identifier and then - (Chars (Prf) = Name_Text_IO - or else - Chars (Prf) = Name_Wide_Text_IO - or else - Chars (Prf) = Name_Wide_Wide_Text_IO) - and then - Nkind (Sel) = N_Identifier - and then - Chars (Sel) in Text_IO_Package_Name; + Nam_In (Chars (Prf), Name_Text_IO, + Name_Wide_Text_IO, + Name_Wide_Wide_Text_IO) + and then Nkind (Sel) = N_Identifier + and then Chars (Sel) in Text_IO_Package_Name; end Is_Text_IO_Kludge_Unit; --------------- diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 2bfbaa82a36..f218cdc7a2b 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.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- -- @@ -1307,6 +1307,9 @@ package Rtsfind is RE_Release_Buffer, -- System.Partition_Interface RE_BS_To_Any, -- System.Partition_Interface RE_Any_To_BS, -- System.Partition_Interface + RE_Build_Complex_TC, -- System.Partition_Interface + RE_Get_TC, -- System.Partition_Interface + RE_Set_TC, -- System.Partition_Interface RE_FA_A, -- System.Partition_Interface RE_FA_B, -- System.Partition_Interface @@ -1350,10 +1353,6 @@ package Rtsfind is RE_TA_Std_String, -- System.Partition_Interface RE_TA_TC, -- System.Partition_Interface - RE_TC_Alias, -- System.Partition_Interface - RE_TC_Build, -- System.Partition_Interface - RE_Get_TC, -- System.Partition_Interface - RE_Set_TC, -- System.Partition_Interface RE_TC_A, -- System.Partition_Interface RE_TC_B, -- System.Partition_Interface RE_TC_C, -- System.Partition_Interface @@ -1373,12 +1372,14 @@ package Rtsfind is RE_TC_Opaque, -- System.Partition_Interface RE_TC_WC, -- System.Partition_Interface RE_TC_WWC, -- System.Partition_Interface - RE_TC_Array, -- System.Partition_Interface - RE_TC_Sequence, -- System.Partition_Interface RE_TC_String, -- System.Partition_Interface - RE_TC_Struct, -- System.Partition_Interface - RE_TC_Union, -- System.Partition_Interface - RE_TC_Object, -- System.Partition_Interface + + RE_Tk_Alias, -- System.Partition_Interface + RE_Tk_Array, -- System.Partition_Interface + RE_Tk_Sequence, -- System.Partition_Interface + RE_Tk_Struct, -- System.Partition_Interface + RE_Tk_Objref, -- System.Partition_Interface + RE_Tk_Union, -- System.Partition_Interface RE_IS_Is1, -- System.Scalar_Values RE_IS_Is2, -- System.Scalar_Values @@ -2550,6 +2551,9 @@ package Rtsfind is RE_Release_Buffer => System_Partition_Interface, RE_BS_To_Any => System_Partition_Interface, RE_Any_To_BS => System_Partition_Interface, + RE_Build_Complex_TC => System_Partition_Interface, + RE_Get_TC => System_Partition_Interface, + RE_Set_TC => System_Partition_Interface, RE_FA_A => System_Partition_Interface, RE_FA_B => System_Partition_Interface, @@ -2593,10 +2597,6 @@ package Rtsfind is RE_TA_Std_String => System_Partition_Interface, RE_TA_TC => System_Partition_Interface, - RE_TC_Alias => System_Partition_Interface, - RE_TC_Build => System_Partition_Interface, - RE_Get_TC => System_Partition_Interface, - RE_Set_TC => System_Partition_Interface, RE_TC_A => System_Partition_Interface, RE_TC_B => System_Partition_Interface, RE_TC_C => System_Partition_Interface, @@ -2616,12 +2616,14 @@ package Rtsfind is RE_TC_Opaque => System_Partition_Interface, RE_TC_WC => System_Partition_Interface, RE_TC_WWC => System_Partition_Interface, - RE_TC_Array => System_Partition_Interface, - RE_TC_Sequence => System_Partition_Interface, RE_TC_String => System_Partition_Interface, - RE_TC_Struct => System_Partition_Interface, - RE_TC_Union => System_Partition_Interface, - RE_TC_Object => System_Partition_Interface, + + RE_Tk_Alias => System_Partition_Interface, + RE_Tk_Array => System_Partition_Interface, + RE_Tk_Sequence => System_Partition_Interface, + RE_Tk_Struct => System_Partition_Interface, + RE_Tk_Objref => System_Partition_Interface, + RE_Tk_Union => System_Partition_Interface, RE_Global_Pool_Object => System_Pool_Global, diff --git a/gcc/ada/s-crtl.ads b/gcc/ada/s-crtl.ads index 18c43c42a64..390f47e02df 100644 --- a/gcc/ada/s-crtl.ads +++ b/gcc/ada/s-crtl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2003-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-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- -- @@ -97,7 +97,8 @@ package System.CRTL is function fopen (filename : chars; mode : chars; - encoding : Filename_Encoding := Unspecified) return FILEs; + encoding : Filename_Encoding := Unspecified; + vms_form : chars := System.Null_Address) return FILEs; pragma Import (C, fopen, "__gnat_fopen"); function fputc (C : int; stream : FILEs) return int; @@ -113,7 +114,8 @@ package System.CRTL is (filename : chars; mode : chars; stream : FILEs; - encoding : Filename_Encoding := Unspecified) return FILEs; + encoding : Filename_Encoding := Unspecified; + vms_form : chars := System.Null_Address) return FILEs; pragma Import (C, freopen, "__gnat_freopen"); function fseek diff --git a/gcc/ada/s-dimmks.ads b/gcc/ada/s-dimmks.ads index fa0c6e0356d..879f5d740a9 100644 --- a/gcc/ada/s-dimmks.ads +++ b/gcc/ada/s-dimmks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2012, 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- -- @@ -57,7 +57,7 @@ package System.Dim.Mks is (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); - -- SI Base dimensioned subtype + -- SI Base dimensioned subtypes subtype Length is Mks_Type with @@ -69,7 +69,7 @@ package System.Dim.Mks is with Dimension => (Symbol => "kg", Kilogram => 1, - others => 0); + others => 0); subtype Time is Mks_Type with @@ -92,19 +92,22 @@ package System.Dim.Mks is subtype Amount_Of_Substance is Mks_Type with Dimension => (Symbol => "mol", - Mole => 1, + Mole => 1, others => 0); subtype Luminous_Intensity is Mks_Type with Dimension => (Symbol => "cd", Candela => 1, - others => 0); + others => 0); + + -- Initialize SI Base unit values - -- SI Base units + -- Turn off the all the dimension warnings for these basic assignments + -- since otherwise we would get complaints about assigning dimensionless + -- values to dimensioned subtypes (we can't assign 1.0*m to m!). - pragma Warnings (Off); - -- Turn off the all the dimension warnings + pragma Warnings (Off, "*assumed to be*"); m : constant Length := 1.0; kg : constant Mass := 1.0; @@ -114,16 +117,16 @@ package System.Dim.Mks is mol : constant Amount_Of_Substance := 1.0; cd : constant Luminous_Intensity := 1.0; - pragma Warnings (On); + pragma Warnings (On, "*assumed to be*"); -- SI Derived dimensioned subtypes subtype Absorbed_Dose is Mks_Type with Dimension => (Symbol => "Gy", - Meter => 2, + Meter => 2, Second => -2, - others => 0); + others => 0); subtype Angle is Mks_Type with @@ -133,14 +136,14 @@ package System.Dim.Mks is subtype Area is Mks_Type with Dimension => ( - Meter => 2, + Meter => 2, others => 0); subtype Catalytic_Activity is Mks_Type with Dimension => (Symbol => "kat", Second => -1, - Mole => 1, + Mole => 1, others => 0); subtype Celsius_Temperature is Mks_Type @@ -152,11 +155,11 @@ package System.Dim.Mks is subtype Electric_Capacitance is Mks_Type with Dimension => (Symbol => 'F', - Meter => -2, + Meter => -2, Kilogram => -1, - Second => 4, - Ampere => 2, - others => 0); + Second => 4, + Ampere => 2, + others => 0); subtype Electric_Charge is Mks_Type with @@ -168,119 +171,119 @@ package System.Dim.Mks is subtype Electric_Conductance is Mks_Type with Dimension => (Symbol => 'S', - Meter => -2, + Meter => -2, Kilogram => -1, - Second => 3, - Ampere => 2, - others => 0); + Second => 3, + Ampere => 2, + others => 0); subtype Electric_Potential_Difference is Mks_Type with Dimension => (Symbol => 'V', - Meter => 2, - Kilogram => 1, - Second => -3, - Ampere => -1, - others => 0); + Meter => 2, + Kilogram => 1, + Second => -3, + Ampere => -1, + others => 0); subtype Electric_Resistance is Mks_Type with Dimension => (Symbol => "Ω", - Meter => 2, - Kilogram => 1, - Second => -3, - Ampere => -2, - others => 0); + Meter => 2, + Kilogram => 1, + Second => -3, + Ampere => -2, + others => 0); subtype Energy is Mks_Type with Dimension => (Symbol => 'J', - Meter => 2, - Kilogram => 1, - Second => -2, - others => 0); + Meter => 2, + Kilogram => 1, + Second => -2, + others => 0); subtype Equivalent_Dose is Mks_Type with Dimension => (Symbol => "Sv", - Meter => 2, + Meter => 2, Second => -2, - others => 0); + others => 0); subtype Force is Mks_Type with Dimension => (Symbol => 'N', - Meter => 1, + Meter => 1, Kilogram => 1, - Second => -2, - others => 0); + Second => -2, + others => 0); subtype Frequency is Mks_Type with Dimension => (Symbol => "Hz", Second => -1, - others => 0); + others => 0); subtype Illuminance is Mks_Type with Dimension => (Symbol => "lx", - Meter => -2, - Candela => 1, - others => 0); + Meter => -2, + Candela => 1, + others => 0); subtype Inductance is Mks_Type with Dimension => (Symbol => 'H', - Meter => 2, - Kilogram => 1, - Second => -2, - Ampere => -2, - others => 0); + Meter => 2, + Kilogram => 1, + Second => -2, + Ampere => -2, + others => 0); subtype Luminous_Flux is Mks_Type with Dimension => (Symbol => "lm", Candela => 1, - others => 0); + others => 0); subtype Magnetic_Flux is Mks_Type with Dimension => (Symbol => "Wb", - Meter => 2, - Kilogram => 1, - Second => -2, - Ampere => -1, - others => 0); + Meter => 2, + Kilogram => 1, + Second => -2, + Ampere => -1, + others => 0); subtype Magnetic_Flux_Density is Mks_Type with Dimension => (Symbol => 'T', - Kilogram => 1, - Second => -2, - Ampere => -1, - others => 0); + Kilogram => 1, + Second => -2, + Ampere => -1, + others => 0); subtype Power is Mks_Type with Dimension => (Symbol => 'W', - Meter => 2, - Kilogram => 1, - Second => -3, - others => 0); + Meter => 2, + Kilogram => 1, + Second => -3, + others => 0); subtype Pressure is Mks_Type with Dimension => (Symbol => "Pa", - Meter => -1, - Kilogram => 1, - Second => -2, - others => 0); + Meter => -1, + Kilogram => 1, + Second => -2, + others => 0); subtype Radioactivity is Mks_Type with Dimension => (Symbol => "Bq", Second => -1, - others => 0); + others => 0); subtype Solid_Angle is Mks_Type with @@ -290,18 +293,23 @@ package System.Dim.Mks is subtype Speed is Mks_Type with Dimension => ( - Meter => 1, + Meter => 1, Second => -1, - others => 0); + others => 0); subtype Volume is Mks_Type with Dimension => ( - Meter => 3, + Meter => 3, others => 0); - pragma Warnings (Off); - -- Turn off the all the dimension warnings + -- Initialize derived dimension values + + -- Turn off the all the dimension warnings for these basic assignments + -- since otherwise we would get complaints about assigning dimensionless + -- values to dimensioned subtypes. + + pragma Warnings (Off, "*assumed to be*"); rad : constant Angle := 1.0; sr : constant Solid_Angle := 1.0; @@ -376,5 +384,5 @@ package System.Dim.Mks is kA : constant Electric_Current := 1.0E+03; -- kilo MeA : constant Electric_Current := 1.0E+06; -- mega - pragma Warnings (On); + pragma Warnings (On, "*assumed to be*"); end System.Dim.Mks; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index 88bad49f76e..64b89926753 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.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- -- @@ -29,15 +29,15 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Finalization; use Ada.Finalization; -with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.Finalization; use Ada.Finalization; +with Ada.IO_Exceptions; use Ada.IO_Exceptions; with Interfaces.C; -with Interfaces.C.Strings; use Interfaces.C.Strings; -with Interfaces.C_Streams; use Interfaces.C_Streams; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with Interfaces.C_Streams; use Interfaces.C_Streams; with System.CRTL.Runtime; -with System.Case_Util; use System.Case_Util; +with System.Case_Util; use System.Case_Util; with System.OS_Lib; with System.Soft_Links; @@ -52,6 +52,12 @@ package body System.File_IO is use type Interfaces.C.int; use type CRTL.size_t; + subtype String_Access is System.OS_Lib.String_Access; + procedure Free (X : in out String_Access) renames System.OS_Lib.Free; + + function "=" (X, Y : String_Access) return Boolean + renames System.OS_Lib."="; + ---------------------- -- Global Variables -- ---------------------- @@ -98,6 +104,9 @@ package body System.File_IO is (C, text_translation_required, "__gnat_text_translation_required"); -- If true, add appropriate suffix to control string for Open + VMS_Formstr : String_Access := null; + -- For special VMS RMS keywords and values + ----------------------- -- Local Subprograms -- ----------------------- @@ -132,11 +141,20 @@ package body System.File_IO is -- with Name includes that file name in the message. procedure Raise_Device_Error - (File : AFCB_Ptr; Errno : Integer := OS_Lib.Errno); + (File : AFCB_Ptr; + Errno : Integer := OS_Lib.Errno); pragma No_Return (Raise_Device_Error); -- Clear error indication on File and raise Device_Error with an exception -- message providing errno information. + procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access); + -- Parse the RMS Keys + + function Form_RMS_Context_Key + (Form : String; + VMS_Form : String_Access) return Natural; + -- Parse the RMS Context Key + ---------------- -- Append_Set -- ---------------- @@ -514,7 +532,6 @@ package body System.File_IO is Fopstr (1) := (if Creat then 'w' else 'r'); Fopstr (2) := '+'; Fptr := 3; - end case; -- If text_translation_required is true then we need to append either a @@ -558,13 +575,10 @@ package body System.File_IO is if V1 = 0 then return Default; - elsif Form (V1) = 'y' then return True; - elsif Form (V1) = 'n' then return False; - else raise Use_Error with "invalid Form"; end if; @@ -640,6 +654,197 @@ package body System.File_IO is Stop := 0; end Form_Parameter; + -------------------------- + -- Form_RMS_Context_Key -- + -------------------------- + + function Form_RMS_Context_Key + (Form : String; + VMS_Form : String_Access) return Natural + is + type Context_Parms is + (Binary_Data, Convert_Fortran_Carriage_Control, Force_Record_Mode, + Force_Stream_Mode, Explicit_Write); + -- Ada-fied list of all possible Context keyword values + + Pos : Natural := 0; + Klen : Natural := 0; + Index : Natural; + + begin + -- Find the end of the occupation + + for J in VMS_Form'First .. VMS_Form'Last loop + if VMS_Form (J) = ASCII.NUL then + Pos := J; + exit; + end if; + end loop; + + Index := Form'First; + while Index < Form'Last loop + if Form (Index) = '=' then + Index := Index + 1; + + -- Loop through the context values and look for a match + + for Parm in Context_Parms loop + declare + KImage : String := Context_Parms'Image (Parm); + + begin + Klen := KImage'Length; + To_Lower (KImage); + + if Index + Klen - 1 <= Form'Last + and then Form (Index .. Index + Klen - 1) = KImage + then + case Parm is + when Force_Record_Mode => + VMS_Form (Pos) := '"'; + Pos := Pos + 1; + VMS_Form (Pos .. Pos + 6) := "ctx=rec"; + Pos := Pos + 7; + VMS_Form (Pos) := '"'; + Pos := Pos + 1; + VMS_Form (Pos) := ','; + return Index + Klen; + + when Force_Stream_Mode => + VMS_Form (Pos) := '"'; + Pos := Pos + 1; + VMS_Form (Pos .. Pos + 6) := "ctx=stm"; + Pos := Pos + 7; + VMS_Form (Pos) := '"'; + Pos := Pos + 1; + VMS_Form (Pos) := ','; + return Index + Klen; + + when others => + raise Use_Error + with "unimplemented RMS Context Value"; + end case; + end if; + end; + end loop; + + raise Use_Error with "unrecognized RMS Context Value"; + end if; + end loop; + + raise Use_Error with "malformed RMS Context Value"; + end Form_RMS_Context_Key; + + ----------------------- + -- Form_VMS_RMS_Keys -- + ----------------------- + + procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access) + is + VMS_RMS_Keys_Token : constant String := "vms_rms_keys"; + Klen : Natural := VMS_RMS_Keys_Token'Length; + Index : Natural; + + -- Ada-fied list of all RMS keywords, translated from the HP C Run-Time + -- Library Reference Manual, Table REF-3: RMS Valid Keywords and Values. + + type RMS_Keys is + (Access_Callback, Allocation_Quantity, Block_Size, Context, + Default_Extension_Quantity, Default_File_Name_String, Error_Callback, + File_Processing_Options, Fixed_Header_Size, Global_Buffer_Count, + Multiblock_Count, Multibuffer_Count, Maximum_Record_Size, + Terminal_Input_Prompt, Record_Attributes, Record_Format, + Record_Processing_Options, Retrieval_Pointer_Count, Sharing_Options, + Timeout_IO_Value); + + begin + Index := Form'First + Klen - 1; + while Index < Form'Last loop + Index := Index + 1; + + -- Scan for the token signalling VMS RMS Keys ahead. Should + -- whitespace be eaten??? + + if Form (Index - Klen .. Index - 1) = VMS_RMS_Keys_Token then + + -- Allocate the VMS form string that will contain the cryptic + -- CRTL RMS strings and initialize it to all nulls. Since the + -- CRTL strings are always shorter than the Ada-fied strings, + -- it follows that an allocation of the original size will be + -- more than adequate. + VMS_Form := new String'(Form (Form'First .. Form'Last)); + VMS_Form.all := (others => ASCII.NUL); + + if Form (Index) = '=' then + Index := Index + 1; + if Form (Index) = '(' then + while Index < Form'Last loop + Index := Index + 1; + + -- Loop through the RMS Keys and dispatch. + + for Key in RMS_Keys loop + declare + KImage : String := RMS_Keys'Image (Key); + + begin + Klen := KImage'Length; + To_Lower (KImage); + + if Form (Index .. Index + Klen - 1) = KImage then + case Key is + when Context => + Index := Form_RMS_Context_Key + (Form (Index + Klen .. Form'Last), + VMS_Form); + exit; + + when others => + raise Use_Error + with "unimplemented VMS RMS Form Key"; + end case; + end if; + end; + end loop; + + if Form (Index) = ')' then + + -- Done, erase the unneeded trailing comma and return + + for J in reverse VMS_Form'First .. VMS_Form'Last loop + if VMS_Form (J) = ',' then + VMS_Form (J) := ASCII.NUL; + return; + end if; + end loop; + + -- Shouldn't be possible to get here + + raise Use_Error; + + elsif Form (Index) = ',' then + + -- Another key ahead, exit inner loop + + null; + + else + + -- Keyword value not terminated correctly + + raise Use_Error with "malformed VMS RMS Form"; + end if; + end loop; + end if; + end if; + + -- Found the keyword, but not followed by correct syntax + + raise Use_Error with "malformed VMS RMS Form"; + end if; + end loop; + end Form_VMS_RMS_Keys; + ------------- -- Is_Open -- ------------- @@ -822,13 +1027,10 @@ package body System.File_IO is if V1 = 0 then Shared := None; - elsif Formstr (V1 .. V2) = "yes" then Shared := Yes; - elsif Formstr (V1 .. V2) = "no" then Shared := No; - else raise Use_Error with "invalid Form"; end if; @@ -844,13 +1046,10 @@ package body System.File_IO is if V1 = 0 then Encoding := CRTL.Unspecified; - elsif Formstr (V1 .. V2) = "utf8" then Encoding := CRTL.UTF8; - elsif Formstr (V1 .. V2) = "8bits" then Encoding := CRTL.ASCII_8bits; - else raise Use_Error with "invalid Form"; end if; @@ -868,6 +1067,17 @@ package body System.File_IO is Form_Boolean (Formstr, "text_translation", Default => True); end if; + -- Acquire settings of target specific form parameters on VMS. Only + -- Context is currently implemented, for forcing a byte stream mode + -- read. On non-VMS systems, the settings are ultimately ignored in + -- the implementation of __gnat_fopen. + + -- Should a warning be issued on non-VMS systems? That's not possible + -- without testing System.OpenVMS boolean which isn't present in most + -- non-VMS versions of package System. + + Form_VMS_RMS_Keys (Formstr, VMS_Formstr); + -- If we were given a stream (call from xxx.C_Streams.Open), then set -- the full name to the given one, and skip to end of processing. @@ -1030,7 +1240,19 @@ package body System.File_IO is -- since by the time of the delete, the current working directory -- may have changed and we do not want to delete a different file! - Stream := fopen (Namestr'Address, Fopstr'Address, Encoding); + if VMS_Formstr = null then + Stream := fopen (Namestr'Address, Fopstr'Address, Encoding, + Null_Address); + else + Stream := fopen (Namestr'Address, Fopstr'Address, Encoding, + VMS_Formstr.all'Address); + end if; + + -- No need to keep this around + + if VMS_Formstr /= null then + Free (VMS_Formstr); + end if; if Stream = NULL_Stream then @@ -1042,15 +1264,15 @@ package body System.File_IO is declare function Is_File_Not_Found_Error (Errno_Value : Integer) return Integer; - -- Non-zero when the given errno value indicates a non- - -- existing file. - pragma Import (C, Is_File_Not_Found_Error, "__gnat_is_file_not_found_error"); + -- Non-zero when the given errno value indicates a non- + -- existing file. - Errno : constant Integer := OS_Lib.Errno; + Errno : constant Integer := OS_Lib.Errno; Message : constant String := Errno_Message (Name, Errno); + begin if Is_File_Not_Found_Error (Errno) /= 0 then raise Name_Error with Message; @@ -1089,7 +1311,8 @@ package body System.File_IO is ------------------------ procedure Raise_Device_Error - (File : AFCB_Ptr; Errno : Integer := OS_Lib.Errno) + (File : AFCB_Ptr; + Errno : Integer := OS_Lib.Errno) is begin -- Clear error status so that the same error is not reported twice @@ -1123,7 +1346,6 @@ package body System.File_IO is else -- 0 < Nread < Siz raise Data_Error with "not enough data read"; end if; - end Read_Buf; procedure Read_Buf @@ -1196,13 +1418,25 @@ package body System.File_IO is Fopen_Mode (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr); - File.Stream := freopen - (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding); + Form_VMS_RMS_Keys (File.Form.all, VMS_Formstr); + + if VMS_Formstr = null then + File.Stream := freopen + (File.Name.all'Address, Fopstr'Address, File.Stream, + File.Encoding, Null_Address); + else + File.Stream := freopen + (File.Name.all'Address, Fopstr'Address, File.Stream, + File.Encoding, VMS_Formstr.all'Address); + end if; + + if VMS_Formstr /= null then + Free (VMS_Formstr); + end if; if File.Stream = NULL_Stream then Close (File_Ptr); raise Use_Error; - else File.Mode := Mode; Append_Set (File); diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index 9848cb82c82..4e11fb1c211 100644 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2012, 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- -- @@ -924,7 +924,6 @@ package System.OS_Lib is procedure OS_Exit (Status : Integer); pragma No_Return (OS_Exit); - -- Exit to OS with given status code (program is terminated). Note that -- this is abrupt termination. All tasks are immediately terminated. There -- are no finalization or other Ada-specific cleanup actions performed. On diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb index 874b1cb186a..a2c466406c4 100644 --- a/gcc/ada/s-osprim-mingw.adb +++ b/gcc/ada/s-osprim-mingw.adb @@ -68,17 +68,17 @@ package body System.OS_Primitives is type Clock_Data_Access is access all Clock_Data; - -- Two base clock buffers. This is used to be able to update a buffer - -- while the other buffer is read. The point is that we do not want to - -- use a lock inside the Clock routine for performance reasons. We still - -- use a lock in the Get_Base_Time which is called very rarely. Current - -- is a pointer, the pragma Atomic is there to ensure that the value can - -- be set or read atomically. That's it, when Get_Base_Time has updated - -- a buffer the switch to the new value is done by changing Current - -- pointer. + -- Two base clock buffers. This is used to be able to update a buffer while + -- the other buffer is read. The point is that we do not want to use a lock + -- inside the Clock routine for performance reasons. We still use a lock + -- in the Get_Base_Time which is called very rarely. Current is a pointer, + -- the pragma Atomic is there to ensure that the value can be set or read + -- atomically. That's it, when Get_Base_Time has updated a buffer the + -- switch to the new value is done by changing Current pointer. First, Second : aliased Clock_Data; - Current : Clock_Data_Access := First'Access; + + Current : Clock_Data_Access := First'Access; pragma Atomic (Current); -- The following signature is to detect change on the base clock data @@ -177,9 +177,11 @@ package body System.OS_Primitives is epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch system_time_ns : constant := 100; -- 100 ns per tick Sec_Unit : constant := 10#1#E9; - Max_Elapsed : constant LARGE_INTEGER := + + Max_Elapsed : constant LARGE_INTEGER := LARGE_INTEGER (Tick_Frequency / 100_000); -- Look for a precision of 0.01 ms + Sig : constant Signature_Type := Signature; Loc_Ticks, Ctrl_Ticks : aliased LARGE_INTEGER; @@ -269,13 +271,14 @@ package body System.OS_Primitives is end if; end loop; - New_Data.Base_Clock := Duration - (Long_Long_Float ((New_Data.Base_Time - epoch_1970) * system_time_ns) / - Long_Long_Float (Sec_Unit)); + New_Data.Base_Clock := + Duration + (Long_Long_Float + ((New_Data.Base_Time - epoch_1970) * system_time_ns) / + Long_Long_Float (Sec_Unit)); -- At this point all the base values have been set into the new data - -- record. We just change the pointer (atomic operation) to this new - -- values. + -- record. Change the pointer (atomic operation) to these new values. Current := New_Data; Data := New_Data.all; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index fcdf2ad87f7..480c5a573a4 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -65,7 +65,7 @@ -- The latest implementation avoids both this problem by using a named -- scheme for recording restrictions, rather than a positional scheme which -- fails completely if restrictions are added or subtracted. Now the worst --- that happens at bind time in incosistent builds is that unrecognized +-- that happens at bind time in inconsistent builds is that unrecognized -- restrictions are ignored, and the consistency checking for restrictions -- might be incomplete, which is no big deal. @@ -88,69 +88,71 @@ package System.Rident is -- binder will check that every unit either has the restriction set, or -- does not violate the restriction. - (Simple_Barriers, -- GNAT (Ravenscar) - No_Abort_Statements, -- (RM D.7(5), H.4(3)) - No_Access_Subprograms, -- (RM H.4(17)) - No_Allocators, -- (RM H.4(7)) - No_Allocators_After_Elaboration, -- Ada 2012 (RM D.7(19.1/2)) - No_Anonymous_Allocators, -- Ada 2012 (RM H.4(8/1)) - No_Asynchronous_Control, -- (RM J.13(3/2) - No_Calendar, -- GNAT - No_Default_Stream_Attributes, -- Ada 2012 (RM 13.12.1(4/2)) - No_Delay, -- (RM H.4(21)) - No_Direct_Boolean_Operators, -- GNAT - No_Dispatch, -- (RM H.4(19)) - No_Dispatching_Calls, -- GNAT - No_Dynamic_Attachment, -- GNAT - No_Dynamic_Priorities, -- (RM D.9(9)) - No_Enumeration_Maps, -- GNAT - No_Entry_Calls_In_Elaboration_Code, -- GNAT - No_Entry_Queue, -- GNAT (Ravenscar) - No_Exception_Handlers, -- GNAT - No_Exception_Propagation, -- GNAT - No_Exception_Registration, -- GNAT - No_Exceptions, -- (RM H.4(12)) - No_Finalization, -- GNAT - No_Fixed_Point, -- (RM H.4(15)) - No_Floating_Point, -- (RM H.4(14)) - No_IO, -- (RM H.4(20)) - No_Implicit_Conditionals, -- GNAT - No_Implicit_Dynamic_Code, -- GNAT - No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3)) - No_Implicit_Loops, -- GNAT - No_Initialize_Scalars, -- GNAT - No_Local_Allocators, -- (RM H.4(8)) - No_Local_Timing_Events, -- (RM D.7(10.2/2)) - No_Local_Protected_Objects, -- GNAT - No_Nested_Finalization, -- (RM D.7(4)) - No_Protected_Type_Allocators, -- GNAT - No_Protected_Types, -- (RM H.4(5)) - No_Recursion, -- (RM H.4(22)) - No_Reentrancy, -- (RM H.4(23)) - No_Relative_Delay, -- GNAT (Ravenscar) - No_Requeue_Statements, -- GNAT - No_Secondary_Stack, -- GNAT - No_Select_Statements, -- GNAT (Ravenscar) - No_Specific_Termination_Handlers, -- (RM D.7(10.7/2)) - No_Standard_Storage_Pools, -- GNAT - No_Stream_Optimizations, -- GNAT - No_Streams, -- GNAT - No_Task_Allocators, -- (RM D.7(7)) - No_Task_Attributes_Package, -- GNAT - No_Task_Hierarchy, -- (RM D.7(3), H.4(3)) - No_Task_Termination, -- GNAT (Ravenscar) - No_Tasking, -- GNAT - No_Terminate_Alternatives, -- (RM D.7(6)) - No_Unchecked_Access, -- (RM H.4(18)) - No_Unchecked_Conversion, -- (RM J.13(4/2)) - No_Unchecked_Deallocation, -- (RM J.13(5/2)) - Static_Priorities, -- GNAT - Static_Storage_Size, -- GNAT + (Simple_Barriers, -- Ada 2012 (D.7 (10.9/3)) + No_Abort_Statements, -- (RM D.7(5), H.4(3)) + No_Access_Parameter_Allocators, -- Ada 2012 (RM H.4 (8.3/3)) + No_Access_Subprograms, -- (RM H.4(17)) + No_Allocators, -- (RM H.4(7)) + No_Anonymous_Allocators, -- Ada 2012 (RM H.4(8/1)) + No_Asynchronous_Control, -- (RM J.13(3/2) + No_Calendar, -- GNAT + No_Coextensions, -- Ada 2012 (RM H.4(8.2/3)) + No_Default_Stream_Attributes, -- Ada 2012 (RM 13.12.1(4/2)) + No_Delay, -- (RM H.4(21)) + No_Direct_Boolean_Operators, -- GNAT + No_Dispatch, -- (RM H.4(19)) + No_Dispatching_Calls, -- GNAT + No_Dynamic_Attachment, -- Ada 2012 (RM E.7(10/3)) + No_Dynamic_Priorities, -- (RM D.9(9)) + No_Enumeration_Maps, -- GNAT + No_Entry_Calls_In_Elaboration_Code, -- GNAT + No_Entry_Queue, -- GNAT (Ravenscar) + No_Exception_Handlers, -- GNAT + No_Exception_Propagation, -- GNAT + No_Exception_Registration, -- GNAT + No_Exceptions, -- (RM H.4(12)) + No_Finalization, -- GNAT + No_Fixed_Point, -- (RM H.4(15)) + No_Floating_Point, -- (RM H.4(14)) + No_IO, -- (RM H.4(20)) + No_Implicit_Conditionals, -- GNAT + No_Implicit_Dynamic_Code, -- GNAT + No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3)) + No_Implicit_Loops, -- GNAT + No_Initialize_Scalars, -- GNAT + No_Local_Allocators, -- (RM H.4(8)) + No_Local_Timing_Events, -- (RM D.7(10.2/2)) + No_Local_Protected_Objects, -- Ada 2012 (D.7(10/1.3)) + No_Nested_Finalization, -- (RM D.7(4)) + No_Protected_Type_Allocators, -- Ada 2012 (D.7 (10.3/2)) + No_Protected_Types, -- (RM H.4(5)) + No_Recursion, -- (RM H.4(22)) + No_Reentrancy, -- (RM H.4(23)) + No_Relative_Delay, -- Ada 2012 (D.7 (10.5/3)) + No_Requeue_Statements, -- Ada 2012 (D.7 (10.6/3)) + No_Secondary_Stack, -- GNAT + No_Select_Statements, -- Ada 2012 (D.7 (10.7/4)) + No_Specific_Termination_Handlers, -- (RM D.7(10.7/2)) + No_Standard_Allocators_After_Elaboration, -- Ada 2012 (RM D.7(19.1/2)) + No_Standard_Storage_Pools, -- GNAT + No_Stream_Optimizations, -- GNAT + No_Streams, -- GNAT + No_Task_Allocators, -- (RM D.7(7)) + No_Task_Attributes_Package, -- GNAT + No_Task_Hierarchy, -- (RM D.7(3), H.4(3)) + No_Task_Termination, -- GNAT (Ravenscar) + No_Tasking, -- GNAT + No_Terminate_Alternatives, -- (RM D.7(6)) + No_Unchecked_Access, -- (RM H.4(18)) + No_Unchecked_Conversion, -- (RM J.13(4/2)) + No_Unchecked_Deallocation, -- (RM J.13(5/2)) + Static_Priorities, -- GNAT + Static_Storage_Size, -- GNAT -- The following require consistency checking with special rules. See -- individual routines in unit Bcheck for details of what is required. - No_Default_Initialization, -- GNAT + No_Default_Initialization, -- GNAT -- The following cases do not require consistency checking and if used -- as a configuration pragma within a specific unit, apply only to that @@ -162,30 +164,34 @@ package System.Rident is -- it is sticky, in that if it is found anywhere within any of these -- units, it applies to all units in this extended main source. - Immediate_Reclamation, -- (RM H.4(10)) - No_Implementation_Aspect_Specifications, -- Ada 2012 AI-241 - No_Implementation_Attributes, -- Ada 2005 AI-257 - No_Implementation_Identifiers, -- Ada 2012 AI-246 - No_Implementation_Pragmas, -- Ada 2005 AI-257 - No_Implementation_Restrictions, -- GNAT - No_Implementation_Units, -- Ada 2012 AI-242 - No_Implicit_Aliasing, -- GNAT - No_Elaboration_Code, -- GNAT - No_Obsolescent_Features, -- Ada 2005 AI-368 - No_Wide_Characters, -- GNAT - SPARK, -- GNAT + Immediate_Reclamation, -- (RM H.4(10)) + No_Implementation_Aspect_Specifications, -- Ada 2012 AI-241 + No_Implementation_Attributes, -- Ada 2005 AI-257 + No_Implementation_Identifiers, -- Ada 2012 AI-246 + No_Implementation_Pragmas, -- Ada 2005 AI-257 + No_Implementation_Restrictions, -- GNAT + No_Implementation_Units, -- Ada 2012 AI-242 + No_Implicit_Aliasing, -- GNAT + No_Elaboration_Code, -- GNAT + No_Obsolescent_Features, -- Ada 2005 AI-368 + No_Wide_Characters, -- GNAT + SPARK, -- GNAT -- The following cases require a parameter value + No_Specification_Of_Aspect, -- 2012 (RM 13.12.1 (6.1/3)) + No_Use_Of_Attribute, -- 2012 (RM 13.12.1 (6.2/3)) + No_Use_Of_Pragma, -- 2012 (RM 13.12.1 (6.3/3)) + -- The following entries are fully checked at compile/bind time, which -- means that the compiler can in general tell the minimum value which -- could be used with a restrictions pragma. The binder can deduce the -- appropriate minimum value for the partition by taking the maximum -- value required by any unit. - Max_Protected_Entries, -- (RM D.7(14)) - Max_Select_Alternatives, -- (RM D.7(12)) - Max_Task_Entries, -- (RM D.7(13), H.4(3)) + Max_Protected_Entries, -- (RM D.7(14)) + Max_Select_Alternatives, -- (RM D.7(12)) + Max_Task_Entries, -- (RM D.7(13), H.4(3)) -- The following entries are also fully checked at compile/bind time, -- and the compiler can also at least in some cases tell the minimum @@ -193,19 +199,19 @@ package System.Rident is -- is that the contributions are additive, so the binder deduces this -- value by adding the unit contributions. - Max_Tasks, -- (RM D.7(19), H.4(3)) + Max_Tasks, -- (RM D.7(19), H.4(3)) -- The following entries are checked at compile time only for zero/ -- nonzero entries. This means that the compiler can tell at compile -- time if a restriction value of zero is (would be) violated, but that -- the compiler cannot distinguish between different non-zero values. - Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3)) - Max_Entry_Queue_Length, -- GNAT + Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3)) + Max_Entry_Queue_Length, -- Ada 2012 (RM D.7 (19.1/2)) -- The remaining entries are not checked at compile/bind time - Max_Storage_At_Blocking, -- (RM D.7(17)) + Max_Storage_At_Blocking, -- (RM D.7(17)) Not_A_Restriction_Id); @@ -242,7 +248,7 @@ package System.Rident is subtype All_Parameter_Restrictions is Restriction_Id range - Max_Protected_Entries .. Max_Storage_At_Blocking; + No_Specification_Of_Aspect .. Max_Storage_At_Blocking; -- All restrictions that take a parameter subtype Checked_Parameter_Restrictions is diff --git a/gcc/ada/s-solita.adb b/gcc/ada/s-solita.adb index a222c87f470..19a422a81df 100644 --- a/gcc/ada/s-solita.adb +++ b/gcc/ada/s-solita.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -181,12 +181,13 @@ package body System.Soft_Links.Tasking is -- There is no need for explicit protection against race conditions for -- this part because it can only be executed by the environment task - -- after all the other tasks have been finalized. + -- after all the other tasks have been finalized. Note that there is no + -- fall-back handler which could apply to this environment task because + -- it has no parents, and, as specified in ARM C.7.3 par. 9/2, "the + -- fall-back handler applies only to the dependent tasks of the task". if Self_Id.Common.Specific_Handler /= null then Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); - elsif Self_Id.Common.Fall_Back_Handler /= null then - Self_Id.Common.Fall_Back_Handler.all (Cause, Self_Id, EO); end if; end Task_Termination_Handler_T; diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index c765cc0789d..71b116cd06a 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-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- -- @@ -268,49 +268,45 @@ package body System.Tasking.Restricted.Stages is Save_Occurrence (EO, E); end; - -- Look for a fall-back handler. It can be either in the task itself - -- or in the environment task. Note that this code is always executed - -- by a task whose master is the environment task. The task termination - -- code for the environment task is executed by - -- SSL.Task_Termination_Handler. + -- Look for a fall-back handler -- This package is part of the restricted run time which supports -- neither task hierarchies (No_Task_Hierarchy) nor specific task -- termination handlers (No_Specific_Termination_Handlers). - -- There is no need for explicit protection against race conditions - -- for Self_ID.Common.Fall_Back_Handler because this procedure can - -- only be executed by Self, and the Fall_Back_Handler can only be - -- modified by Self. + -- As specified in ARM C.7.3 par. 9/2, "the fall-back handler applies + -- only to the dependent tasks of the task". Hence, if the terminating + -- tasks (Self_ID) had a fall-back handler, it would not apply to + -- itself. This code is always executed by a task whose master is the + -- environment task (the task termination code for the environment task + -- is executed by SSL.Task_Termination_Handler), so the fall-back + -- handler to execute for this task can only be defined by its parent + -- (there is no grandparent). - if Self_ID.Common.Fall_Back_Handler /= null then - Self_ID.Common.Fall_Back_Handler (Cause, Self_ID, EO); - else - declare - TH : Termination_Handler := null; + declare + TH : Termination_Handler := null; - begin - if Single_Lock then - Lock_RTS; - end if; + begin + if Single_Lock then + Lock_RTS; + end if; - Write_Lock (Self_ID.Common.Parent); + Write_Lock (Self_ID.Common.Parent); - TH := Self_ID.Common.Parent.Common.Fall_Back_Handler; + TH := Self_ID.Common.Parent.Common.Fall_Back_Handler; - Unlock (Self_ID.Common.Parent); + Unlock (Self_ID.Common.Parent); - if Single_Lock then - Unlock_RTS; - end if; + if Single_Lock then + Unlock_RTS; + end if; - -- Execute the task termination handler if we found it + -- Execute the task termination handler if we found it - if TH /= null then - TH.all (Cause, Self_ID, EO); - end if; - end; - end if; + if TH /= null then + TH.all (Cause, Self_ID, EO); + end if; + end; Terminate_Task (Self_ID); end Task_Wrapper; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 75f4e2c4e44..487bf8d5340 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.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. -- -- -- -- 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- -- @@ -1075,7 +1075,7 @@ package body System.Tasking.Stages is procedure Search_Fall_Back_Handler (ID : Task_Id); -- Procedure that searches recursively a fall-back handler through the -- master relationship. If the handler is found, its pointer is stored - -- in TH. + -- in TH. It stops when the handler is found or when the ID is null. ------------------------------ -- Search_Fall_Back_Handler -- @@ -1083,21 +1083,22 @@ package body System.Tasking.Stages is procedure Search_Fall_Back_Handler (ID : Task_Id) is begin + -- A null Task_Id indicates that we have reached the root of the + -- task hierarchy and no handler has been found. + + if ID = null then + return; + -- If there is a fall back handler, store its pointer for later -- execution. - if ID.Common.Fall_Back_Handler /= null then + elsif ID.Common.Fall_Back_Handler /= null then TH := ID.Common.Fall_Back_Handler; -- Otherwise look for a fall back handler in the parent - elsif ID.Common.Parent /= null then - Search_Fall_Back_Handler (ID.Common.Parent); - - -- Otherwise, do nothing - else - return; + Search_Fall_Back_Handler (ID.Common.Parent); end if; end Search_Fall_Back_Handler; @@ -1331,9 +1332,12 @@ package body System.Tasking.Stages is TH := Self_ID.Common.Specific_Handler; else -- Look for a fall-back handler following the master relationship - -- for the task. + -- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back + -- handler applies only to the dependent tasks of the task". Hence, + -- if the terminating tasks (Self_ID) had a fall-back handler, it + -- would not apply to itself, so we start the search with the parent. - Search_Fall_Back_Handler (Self_ID); + Search_Fall_Back_Handler (Self_ID.Common.Parent); end if; Unlock (Self_ID); diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 95b69428704..d3ec497188d 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.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- -- @@ -470,6 +470,9 @@ package body Sem is when N_Quantified_Expression => Analyze_Quantified_Expression (N); + when N_Raise_Expression => + Analyze_Raise_Expression (N); + when N_Raise_Statement => Analyze_Raise_Statement (N); @@ -1308,6 +1311,7 @@ package body Sem is S_In_Spec_Expr : constant Boolean := In_Spec_Expression; S_Inside_A_Generic : constant Boolean := Inside_A_Generic; S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope; + S_Style_Check : constant Boolean := Style_Check; Generic_Main : constant Boolean := Nkind (Unit (Cunit (Main_Unit))) @@ -1315,6 +1319,10 @@ package body Sem is -- If the main unit is generic, every compiled unit, including its -- context, is compiled with expansion disabled. + Ext_Main_Source_Unit : constant Boolean := + In_Extended_Main_Source_Unit (Comp_Unit); + -- Determine if unit is in extended main source unit + Save_Config_Switches : Config_Switches_Type; -- Variable used to save values of config switches while we analyze the -- new unit, to be restored on exit for proper recursive behavior. @@ -1383,9 +1391,6 @@ package body Sem is -- Sequential_IO) as this would prevent pragma Extend_System from being -- taken into account, for example when Text_IO is renaming DEC.Text_IO. - -- Cleaner might be to do the kludge at the point of excluding the - -- pragma (do not exclude for renamings ???) - if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False) then @@ -1420,12 +1425,28 @@ package body Sem is -- For unit in main extended unit, we reset the configuration values -- for the non-partition-wide restrictions. For other units reset them. - if In_Extended_Main_Source_Unit (Comp_Unit) then + if Ext_Main_Source_Unit then Restore_Config_Cunit_Boolean_Restrictions; else Reset_Cunit_Boolean_Restrictions; end if; + -- Turn off style checks for unit that is not in the extended main + -- source unit. This improves processing efficiency for such units + -- (for which we don't want style checks anyway, and where they will + -- get suppressed), and is definitely needed to stop some style checks + -- from invading the run-time units (e.g. overriding checks). + + if not Ext_Main_Source_Unit then + Style_Check := False; + + -- If this is part of the extended main source unit, set style check + -- mode to match the style check mode of the main source unit itself. + + else + Style_Check := Style_Check_Main; + end if; + -- Only do analysis of unit that has not already been analyzed if not Analyzed (Comp_Unit) then @@ -1479,6 +1500,7 @@ package body Sem is In_Spec_Expression := S_In_Spec_Expr; Inside_A_Generic := S_Inside_A_Generic; Outer_Generic_Scope := S_Outer_Gen_Scope; + Style_Check := S_Style_Check; Restore_Opt_Config_Switches (Save_Config_Switches); diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 31fc37b95af..545aadc6a53 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.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- -- @@ -177,7 +177,7 @@ -- repeatedly (for instance in the above aggregate "new Thing (Function_Call)" -- needs to be called 100 times.) --- The reason why this mechanism does not work is that, the expanded code for +-- The reason why this mechanism does not work is that the expanded code for -- the children is typically inserted above the parent and thus when the -- father gets expanded no re-evaluation takes place. For instance in the case -- of aggregates if "new Thing (Function_Call)" is expanded before of the @@ -429,11 +429,11 @@ package Sem is -- compilation unit. These sections are separated by distinct occurrences -- of package Standard. The currently active section of the scope stack -- goes from the current scope to the first (innermost) occurrence of - -- Standard, which is additionally marked with the flag - -- Is_Active_Stack_Base. The basic visibility routine (Find_Direct_Name, in - -- Sem_Ch8) uses this contiguous section of the scope stack to determine - -- whether a given entity is or is not visible at a point. In_Open_Scopes - -- only examines the currently active section of the scope stack. + -- Standard, which is additionally marked with flag Is_Active_Stack_Base. + -- The basic visibility routine (Find_Direct_Name, in Sem_Ch8) uses this + -- contiguous section of the scope stack to determine whether a given + -- entity is or is not visible at a point. In_Open_Scopes only examines + -- the currently active section of the scope stack. -- Similar complications arise when processing child instances. These -- must be compiled in the context of parent instances, and therefore the @@ -464,7 +464,12 @@ package Sem is -- Save contents of Local_Suppress_Stack on entry to restore on exit Save_Check_Policy_List : Node_Id; - -- Save contents of Check_Policy_List on entry to restore on exit + -- Save contents of Check_Policy_List on entry to restore on exit. The + -- Check_Policy pragmas are chained with Check_Policy_List pointing to + -- the most recent entry. This list is searched starting here, so that + -- the search finds the most recent appicable entry. When we restore + -- Check_Policy_List on exit from the scope, the effect is to remove + -- all entries set in the scope being exited. Save_Default_Storage_Pool : Node_Id; -- Save contents of Default_Storage_Pool on entry to restore on exit diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 58f98f5ab9a..9d7d7b7e4b1 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1678,9 +1678,10 @@ package body Sem_Aggr is -- unless the expression covers a single component, or the -- expander is inactive. - -- In Alfa mode, expressions that can perform side-effects will be - -- recognized by the gnat2why back-end, and the whole subprogram - -- will be ignored. So semantic analysis can be performed safely. + -- In SPARK mode, expressions that can perform side-effects will + -- be recognized by the gnat2why back-end, and the whole + -- subprogram will be ignored. So semantic analysis can be + -- performed safely. if Single_Elmt or else not Full_Expander_Active diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index c2a298bbdf8..f52abe98702 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -175,7 +175,7 @@ package body Sem_Attr is -- Note that the only required action of this procedure is to catch the -- static expression cases as described in the RM. Folding of other cases -- is done where convenient, but some additional non-static folding is in - -- N_Expand_Attribute_Reference in cases where this is more convenient. + -- Expand_N_Attribute_Reference in cases where this is more convenient. function Is_Anonymous_Tagged_Base (Anon : Entity_Id; @@ -376,10 +376,6 @@ package body Sem_Attr is pragma No_Return (Error_Attr); -- Like Error_Attr, but error is posted at the start of the prefix - procedure S14_Attribute; - -- Called for all attributes defined for formal verification to check - -- that the S14_Extensions flag is set. - procedure Standard_Attribute (Val : Int); -- Used to process attributes whose prefix is package Standard which -- yield values of type Universal_Integer. The attribute reference @@ -602,10 +598,13 @@ package body Sem_Attr is if Has_Pragma_Inline_Always (Entity (P)) then Error_Attr_P ("prefix of % attribute cannot be Inline_Always subprogram"); - end if; - if Aname = Name_Unchecked_Access then + elsif Aname = Name_Unchecked_Access then Error_Attr ("attribute% cannot be applied to a subprogram", P); + + elsif Is_Ghost_Subprogram (Entity (P)) then + Error_Attr_P + ("prefix of % attribute cannot be a ghost subprogram"); end if; -- Issue an error if the prefix denotes an eliminated subprogram @@ -651,10 +650,11 @@ package body Sem_Attr is Kill_Current_Values; end if; - -- Treat as call for elaboration purposes and we are all done. - -- Suppress this treatment under debug flag. + -- In the static elaboration model, treat the attribute reference + -- as a call for elaboration purposes. Suppress this treatment + -- under debug flag. In any case, we are all done. - if not Debug_Flag_Dot_UU then + if not Dynamic_Elaboration_Checks and not Debug_Flag_Dot_UU then Check_Elab_Call (N); end if; @@ -1221,11 +1221,9 @@ package body Sem_Attr is -- the prefix of another attribute. Error is posted on parent. if Nkind (Parent (N)) = N_Attribute_Reference - and then (Attribute_Name (Parent (N)) = Name_Address - or else - Attribute_Name (Parent (N)) = Name_Code_Address - or else - Attribute_Name (Parent (N)) = Name_Access) + and then Nam_In (Attribute_Name (Parent (N)), Name_Address, + Name_Code_Address, + Name_Access) then Error_Msg_Name_1 := Attribute_Name (Parent (N)); Error_Msg_N ("illegal prefix for % attribute", Parent (N)); @@ -1742,9 +1740,13 @@ package body Sem_Attr is -- AI05-0057: if restriction No_Default_Stream_Attributes is active, -- it is illegal to use a predefined elementary type stream attribute -- either by itself, or more importantly as part of the attribute - -- subprogram for a composite type. + -- subprogram for a composite type. However, if the broader + -- restriction No_Streams is active, stream operations are not + -- generated, and there is no error. - if Restriction_Active (No_Default_Stream_Attributes) then + if Restriction_Active (No_Default_Stream_Attributes) + and then not Restriction_Active (No_Streams) + then declare T : Entity_Id; @@ -1965,18 +1967,6 @@ package body Sem_Attr is Set_Etype (N, Standard_Boolean); end Legal_Formal_Attribute; - ------------------- - -- S14_Attribute -- - ------------------- - - procedure S14_Attribute is - begin - if not Formal_Extensions then - Error_Attr - ("attribute % requires the use of debug switch -gnatd.V", N); - end if; - end S14_Attribute; - ------------------------ -- Standard_Attribute -- ------------------------ @@ -2130,20 +2120,6 @@ package body Sem_Attr is E1 := Empty; E2 := Empty; - -- Do not analyze the expressions of attribute Loop_Entry. Depending on - -- the number of arguments and/or the nature of the first argument, the - -- whole attribute reference may be rewritten into an indexed component. - -- In the case of two or more arguments, the expressions are analyzed - -- when the indexed component is analyzed, otherwise the sole argument - -- is preanalyzed to determine whether it is a loop name. - - elsif Aname = Name_Loop_Entry then - E1 := First (Exprs); - - if Present (E1) then - E2 := Next (E1); - end if; - else E1 := First (Exprs); Analyze (E1); @@ -2196,9 +2172,7 @@ package body Sem_Attr is -- a context check if Ada_Version >= Ada_2005 - and then (Aname = Name_Count - or else Aname = Name_Caller - or else Aname = Name_AST_Entry) + and then Nam_In (Aname, Name_Count, Name_Caller, Name_AST_Entry) then declare Count : Natural := 0; @@ -2405,6 +2379,11 @@ package body Sem_Attr is 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; @@ -2832,9 +2811,7 @@ package body Sem_Attr is Check_E0; if Nkind (P) = N_Attribute_Reference - and then (Attribute_Name (P) = Name_Elab_Body - or else - Attribute_Name (P) = Name_Elab_Spec) + and then Nam_In (Attribute_Name (P), Name_Elab_Body, Name_Elab_Spec) then null; @@ -3634,11 +3611,6 @@ package body Sem_Attr is -- Inspect the prefix for any uses of entities declared within the -- related loop. Loop_Id denotes the loop identifier. - procedure Convert_To_Indexed_Component; - -- Transform the attribute reference into an indexed component where - -- the prefix is Prefix'Loop_Entry and the expressions are associated - -- with the indexed component. - -------------------------------- -- Check_References_In_Prefix -- -------------------------------- @@ -3689,13 +3661,7 @@ package body Sem_Attr is -- Prevent the search from going too far - elsif Nkind_In (Stmt, N_Entry_Body, - N_Package_Body, - N_Package_Declaration, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) - then + elsif Is_Body_Or_Package_Declaration (Stmt) then exit; end if; @@ -3711,27 +3677,10 @@ package body Sem_Attr is Check_References (P); end Check_References_In_Prefix; - ---------------------------------- - -- Convert_To_Indexed_Component -- - ---------------------------------- - - procedure Convert_To_Indexed_Component is - New_Loop_Entry : constant Node_Id := Relocate_Node (N); - - begin - -- The new Loop_Entry loses its arguments. They will be converted - -- into the expressions of the indexed component. - - Set_Expressions (New_Loop_Entry, No_List); - - Rewrite (N, - Make_Indexed_Component (Loc, - Prefix => New_Loop_Entry, - Expressions => Exprs)); - end Convert_To_Indexed_Component; - -- Local variables + Context : constant Node_Id := Parent (N); + Attr : Node_Id; Enclosing_Loop : Node_Id; In_Loop_Assertion : Boolean := False; Loop_Id : Entity_Id := Empty; @@ -3741,47 +3690,84 @@ package body Sem_Attr is -- Start of processing for Loop_Entry begin - S14_Attribute; + Attr := N; - -- The attribute reference appears as - -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN) + -- Set the type of the attribute now to ensure the successfull + -- continuation of analysis even if the attribute is misplaced. - -- In this case, the loop name is omitted and the arguments are part - -- of an indexed component. Transform the whole attribute reference - -- to reflect this scenario. + Set_Etype (Attr, P_Type); - if Present (E2) then - Convert_To_Indexed_Component; - Analyze (N); - return; + -- Attribute 'Loop_Entry may appear in several flavors: - -- The attribute reference appears as - -- Prefix'Loop_Entry (Loop_Name) - -- or - -- Prefix'Loop_Entry (Expr1) + -- * Prefix'Loop_Entry - in this form, the attribute applies to the + -- nearest enclosing loop. - -- Depending on what Expr1 resolves to, either rewrite the reference - -- into an indexed component or continue with the analysis. + -- * Prefix'Loop_Entry (Expr) - depending on what Expr denotes, the + -- attribute may be related to a loop denoted by label Expr or + -- the prefix may denote an array object and Expr may act as an + -- indexed component. - elsif Present (E1) then + -- * Prefix'Loop_Entry (Expr1, ..., ExprN) - the attribute applies + -- to the nearest enclosing loop, all expressions are part of + -- an indexed component. - -- Do not expand the argument as it may have side effects. Simply - -- preanalyze to determine whether it is a loop or something else. + -- * Prefix'Loop_Entry (Expr) (...) (...) - depending on what Expr + -- denotes, the attribute may be related to a loop denoted by + -- label Expr or the prefix may denote a multidimensional array + -- array object and Expr along with the rest of the expressions + -- may act as indexed components. - Preanalyze_And_Resolve (E1); + -- Regardless of variations, the attribute reference does not have an + -- expression list. Instead, all available expressions are stored as + -- indexed components. - if Is_Entity_Name (E1) - and then Present (Entity (E1)) - and then Ekind (Entity (E1)) = E_Loop - then - Loop_Id := Entity (E1); + -- When the attribute is part of an indexed component, find the first + -- expression as it will determine the semantics of 'Loop_Entry. + + if Nkind (Context) = N_Indexed_Component then + E1 := First (Expressions (Context)); + E2 := Next (E1); + + -- The attribute reference appears in the following form: + + -- Prefix'Loop_Entry (Exp1, Expr2, ..., ExprN) [(...)] + + -- In this case, the loop name is omitted and no rewriting is + -- required. - -- The argument is not a loop name + if Present (E2) then + null; + + -- The form of the attribute is: + + -- Prefix'Loop_Entry (Expr) [(...)] + + -- If Expr denotes a loop entry, the whole attribute and indexed + -- component will have to be rewritten to reflect this relation. else - Convert_To_Indexed_Component; - Analyze (N); - return; + pragma Assert (Present (E1)); + + -- Do not expand the expression as it may have side effects. + -- Simply preanalyze to determine whether it is a loop name or + -- something else. + + Preanalyze_And_Resolve (E1); + + if Is_Entity_Name (E1) + and then Present (Entity (E1)) + and then Ekind (Entity (E1)) = E_Loop + then + Loop_Id := Entity (E1); + + -- Transform the attribute and enclosing indexed component + + Set_Expressions (N, Expressions (Context)); + Rewrite (Context, N); + Set_Etype (Context, P_Type); + + Attr := Context; + end if; end if; end if; @@ -3802,20 +3788,16 @@ package body Sem_Attr is -- Climb the parent chain to verify the location of the attribute and -- find the enclosing loop. - Stmt := N; + Stmt := Attr; while Present (Stmt) loop - -- Locate the enclosing Loop_Invariant / Loop_Variant pragma (if - -- any). Note that when these two are expanded, we must look for - -- an Assertion pragma. + -- Locate the enclosing Loop_Invariant / Loop_Variant pragma if Nkind (Original_Node (Stmt)) = N_Pragma and then - (Pragma_Name (Original_Node (Stmt)) = Name_Assert - or else - Pragma_Name (Original_Node (Stmt)) = Name_Loop_Invariant - or else - Pragma_Name (Original_Node (Stmt)) = Name_Loop_Variant) + Nam_In (Pragma_Name (Original_Node (Stmt)), + Name_Loop_Invariant, + Name_Loop_Variant) then In_Loop_Assertion := True; @@ -3840,13 +3822,7 @@ package body Sem_Attr is -- Prevent the search from going too far - elsif Nkind_In (Stmt, N_Entry_Body, - N_Package_Body, - N_Package_Declaration, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) - then + elsif Is_Body_Or_Package_Declaration (Stmt) then exit; end if; @@ -3865,8 +3841,8 @@ package body Sem_Attr is -- appear within a body of accept statement, if this construct is -- itself enclosed by the given loop statement. - for J in reverse 0 .. Scope_Stack.Last loop - Scop := Scope_Stack.Table (J).Entity; + for Index in reverse 0 .. Scope_Stack.Last loop + Scop := Scope_Stack.Table (Index).Entity; if Ekind (Scop) = E_Loop and then Scop = Loop_Id then exit; @@ -3896,20 +3872,6 @@ package body Sem_Attr is then Error_Attr_P ("prefix of attribute % must denote an entity"); end if; - - Set_Etype (N, Etype (P)); - - -- Associate the attribute with its related loop - - if No (Loop_Entry_Attributes (Loop_Id)) then - Set_Loop_Entry_Attributes (Loop_Id, New_Elmt_List); - end if; - - -- A Loop_Entry may be [pre]analyzed several times, depending on the - -- context. Ensure that it appears only once in the attributes list - -- of the related loop. - - Append_Unique_Elmt (N, Loop_Entry_Attributes (Loop_Id)); end Loop_Entry; ------------- @@ -4257,24 +4219,30 @@ package body Sem_Attr is if In_Spec_Expression then - -- Check in postcondition or Ensures clause + -- Check in postcondition, Test_Case or Contract_Cases Prag := N; - while not Nkind_In (Prag, N_Pragma, - N_Function_Specification, - N_Procedure_Specification, - N_Subprogram_Body) + while Present (Prag) + and then not Nkind_In (Prag, N_Pragma, + N_Function_Specification, + N_Procedure_Specification, + N_Aspect_Specification, + N_Subprogram_Body) loop Prag := Parent (Prag); end loop; - if Nkind (Prag) /= N_Pragma then + -- In ASIS mode, the aspect itself is analyzed, in addition to the + -- corresponding pragma. Do not issue errors when analyzing the + -- aspect. + + if Nkind (Prag) = N_Aspect_Specification then + null; + + elsif Nkind (Prag) /= N_Pragma then Error_Attr ("% attribute can only appear in postcondition", P); - elsif Get_Pragma_Id (Prag) = Pragma_Contract_Case - or else - Get_Pragma_Id (Prag) = Pragma_Test_Case - then + elsif Get_Pragma_Id (Prag) = Pragma_Test_Case then declare Arg_Ens : constant Node_Id := Get_Ensures_From_CTC_Pragma (Prag); @@ -4282,18 +4250,36 @@ package body Sem_Attr is begin Arg := N; - while Arg /= Prag and Arg /= Arg_Ens loop + while Arg /= Prag and then Arg /= Arg_Ens loop Arg := Parent (Arg); end loop; if Arg /= Arg_Ens then - if Get_Pragma_Id (Prag) = Pragma_Contract_Case then - Error_Attr - ("% attribute misplaced inside contract case", P); - else - Error_Attr - ("% attribute misplaced inside test case", P); - end if; + Error_Attr ("% attribute misplaced inside test case", P); + end if; + end; + + elsif Get_Pragma_Id (Prag) = Pragma_Contract_Cases then + declare + Aggr : constant Node_Id := + Expression (First (Pragma_Argument_Associations (Prag))); + Arg : Node_Id; + + begin + Arg := N; + while Arg /= Prag and then Parent (Parent (Arg)) /= Aggr loop + Arg := Parent (Arg); + end loop; + + -- At this point, Parent (Arg) should be a component + -- association. Attribute Result is only allowed in + -- the expression part of this association. + + if Nkind (Parent (Arg)) /= N_Component_Association + or else Arg /= Expression (Parent (Arg)) + then + Error_Attr + ("% attribute misplaced inside contract cases", P); end if; end; @@ -4320,11 +4306,10 @@ package body Sem_Attr is end if; end if; - -- Either the attribute reference is generated for a Requires - -- clause, in which case no expressions follow, or it is a - -- primary. In that case, if expressions follow, the attribute - -- reference is an indexable object, so rewrite the node - -- accordingly. + -- 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. if Present (E1) then Rewrite (N, @@ -4371,13 +4356,13 @@ package body Sem_Attr is -- enclosing subprogram. This is properly an expansion activity -- but it has to be performed now to prevent out-of-order issues. - -- This expansion is both harmful and not needed in Alfa mode, since + -- This expansion is both harmful and not needed in SPARK mode, since -- the formal verification backend relies on the types of nodes -- (hence is not robust w.r.t. a change to base type here), and does -- not suffer from the out-of-order issue described above. Thus, this - -- expansion is skipped in Alfa mode. + -- expansion is skipped in SPARK mode. - if not Is_Entity_Name (P) and then not Alfa_Mode then + if not Is_Entity_Name (P) and then not SPARK_Mode then P_Type := Base_Type (P_Type); Set_Etype (N, P_Type); Set_Etype (P, P_Type); @@ -4649,25 +4634,31 @@ package body Sem_Attr is Error_Attr; end if; - -- Check in postcondition or Ensures clause of function + -- Check in postcondition, Test_Case or Contract_Cases of function Prag := N; - while not Nkind_In (Prag, N_Pragma, - N_Function_Specification, - N_Subprogram_Body) + while Present (Prag) + and then not Nkind_In (Prag, N_Pragma, + N_Function_Specification, + N_Aspect_Specification, + N_Subprogram_Body) loop Prag := Parent (Prag); end loop; - if Nkind (Prag) /= N_Pragma then + -- In ASIS mode, the aspect itself is analyzed, in addition to the + -- corresponding pragma. Do not issue errors when analyzing the + -- aspect. + + if Nkind (Prag) = N_Aspect_Specification then + null; + + elsif Nkind (Prag) /= N_Pragma then Error_Attr ("% attribute can only appear in postcondition of function", P); - elsif Get_Pragma_Id (Prag) = Pragma_Contract_Case - or else - Get_Pragma_Id (Prag) = Pragma_Test_Case - then + elsif Get_Pragma_Id (Prag) = Pragma_Test_Case then declare Arg_Ens : constant Node_Id := Get_Ensures_From_CTC_Pragma (Prag); @@ -4675,18 +4666,36 @@ package body Sem_Attr is begin Arg := N; - while Arg /= Prag and Arg /= Arg_Ens loop + while Arg /= Prag and then Arg /= Arg_Ens loop Arg := Parent (Arg); end loop; if Arg /= Arg_Ens then - if Get_Pragma_Id (Prag) = Pragma_Contract_Case then - Error_Attr - ("% attribute misplaced inside contract case", P); - else - Error_Attr - ("% attribute misplaced inside test case", P); - end if; + Error_Attr ("% attribute misplaced inside test case", P); + end if; + end; + + elsif Get_Pragma_Id (Prag) = Pragma_Contract_Cases then + declare + Aggr : constant Node_Id := + Expression (First (Pragma_Argument_Associations (Prag))); + Arg : Node_Id; + + begin + Arg := N; + while Arg /= Prag and then Parent (Parent (Arg)) /= Aggr loop + Arg := Parent (Arg); + end loop; + + -- At this point, Parent (Arg) should be a component + -- association. Attribute Result is only allowed in + -- the expression part of this association. + + if Nkind (Parent (Arg)) /= N_Component_Association + or else Arg /= Expression (Parent (Arg)) + then + Error_Attr + ("% attribute misplaced inside contract cases", P); end if; end; @@ -5011,6 +5020,13 @@ package body Sem_Attr is then null; + -- Some other compilers allow dubious use of X'???'Size + + elsif Relaxed_RM_Semantics + and then Nkind (P) = N_Attribute_Reference + then + null; + else Error_Attr_P ("invalid prefix for % attribute"); end if; @@ -5651,7 +5667,6 @@ package body Sem_Attr is -- Start of processing for Update begin - S14_Attribute; Check_E1; if not Is_Object_Reference (P) then @@ -9133,7 +9148,6 @@ package body Sem_Attr is and then (Ekind (Btyp) = E_Access_Subprogram_Type or else Is_Local_Anonymous_Access (Btyp)) - and then Subprogram_Access_Level (Entity (P)) > Type_Access_Level (Btyp) then @@ -9180,15 +9194,12 @@ package body Sem_Attr is -- when within an instance, because any violations will have -- been caught by the compilation of the generic unit. - -- Note that we relax this check in CodePeer mode for - -- compatibility with legacy code, since CodePeer is an - -- Ada source code analyzer, not a strict compiler. - -- ??? Note that a better approach would be to have a - -- separate switch to relax this rule, and enable this - -- switch in CodePeer mode. + -- We relax this check in Relaxed_RM_Semantics mode for + -- compatibility with legacy code for use by Ada source + -- code analyzers (e.g. CodePeer). elsif Attr_Id = Attribute_Access - and then not CodePeer_Mode + and then not Relaxed_RM_Semantics and then not In_Instance and then Present (Enclosing_Generic_Unit (Entity (P))) and then Present (Enclosing_Generic_Body (N)) @@ -9288,6 +9299,17 @@ package body Sem_Attr is Resolve (Prefix (P)); Generate_Reference (Entity (Selector_Name (P)), P); + -- Implement check implied by 3.10.2 (18.1/2) : F.all'access is + -- statically illegal if F is an anonymous access to subprogram. + + elsif Nkind (P) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (P)) + and then Ekind (Etype (Entity (Prefix (P)))) = + E_Anonymous_Access_Subprogram_Type + then + Error_Msg_N ("anonymous access to subprogram " + & "has deeper accessibility than any master", P); + elsif Is_Overloaded (P) then -- Use the designated type of the context to disambiguate @@ -9493,7 +9515,7 @@ package body Sem_Attr is and then (Ada_Version < Ada_2005 or else - not Effectively_Has_Constrained_Partial_View + not Object_Type_Has_Constrained_Partial_View (Typ => Designated_Type (Base_Type (Typ)), Scop => Current_Scope)) then @@ -9527,9 +9549,9 @@ package body Sem_Attr is -- in such a context. if Attr_Id /= Attribute_Unchecked_Access + and then Ekind (Btyp) = E_General_Access_Type and then Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) - and then Ekind (Btyp) = E_General_Access_Type then Accessibility_Message; return; @@ -10031,9 +10053,7 @@ package body Sem_Attr is -- then this is only legal within a task or protected record. when others => - if not Is_Entity_Name (P) - or else not Is_Type (Entity (P)) - then + if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then Resolve (P); end if; @@ -10041,9 +10061,7 @@ package body Sem_Attr is -- 'Class) then this is only legal within a task or protected -- record. What is this all about ??? - if Is_Entity_Name (N) - and then Is_Type (Entity (N)) - then + if Is_Entity_Name (N) and then Is_Type (Entity (N)) then if Is_Concurrent_Type (Entity (N)) and then In_Open_Scopes (Entity (P)) then diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 490048e9a7c..3c5d2af59ba 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.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- -- @@ -86,8 +86,12 @@ package body Sem_Aux is return Get_Full_View (Non_Limited_View (Typ)); + -- If it is class_wide, check whether the specific type comes from + -- A limited_with. + elsif Is_Class_Wide_Type (Typ) and then Is_Incomplete_Type (Etype (Typ)) + and then From_With_Type (Etype (Typ)) and then Present (Non_Limited_View (Etype (Typ))) then return Class_Wide_Type (Non_Limited_View (Etype (Typ))); @@ -151,25 +155,6 @@ package body Sem_Aux is end if; end Constant_Value; - ---------------------------------------------- - -- Effectively_Has_Constrained_Partial_View -- - ---------------------------------------------- - - function Effectively_Has_Constrained_Partial_View - (Typ : Entity_Id; - Scop : Entity_Id) return Boolean - is - begin - return Has_Constrained_Partial_View (Typ) - or else (In_Generic_Body (Scop) - and then Is_Generic_Type (Base_Type (Typ)) - and then Is_Private_Type (Base_Type (Typ)) - and then not Is_Tagged_Type (Typ) - and then not (Is_Array_Type (Typ) - and then not Is_Constrained (Typ)) - and then Has_Discriminants (Typ)); - end Effectively_Has_Constrained_Partial_View; - ----------------------------- -- Enclosing_Dynamic_Scope -- ----------------------------- @@ -467,8 +452,8 @@ package body Sem_Aux is elsif Nkind (N) = N_Attribute_Definition_Clause and then (Chars (N) = Nam - or else (Nam = Name_Priority - and then Chars (N) = Name_Interrupt_Priority)) + or else (Nam = Name_Priority + and then Chars (N) = Name_Interrupt_Priority)) then if Check_Parents or else Entity (N) = E then return N; @@ -477,9 +462,9 @@ package body Sem_Aux is elsif Nkind (N) = N_Aspect_Specification and then (Chars (Identifier (N)) = Nam - or else (Nam = Name_Priority - and then Chars (Identifier (N)) = - Name_Interrupt_Priority)) + or else + (Nam = Name_Priority + and then Chars (Identifier (N)) = Name_Interrupt_Priority)) then if Check_Parents then return N; @@ -630,25 +615,6 @@ package body Sem_Aux is return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents)); end Has_Rep_Pragma; - ------------------------------- - -- Initialization_Suppressed -- - ------------------------------- - - function Initialization_Suppressed (Typ : Entity_Id) return Boolean is - begin - return Suppress_Initialization (Typ) - or else Suppress_Initialization (Base_Type (Typ)); - end Initialization_Suppressed; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Obsolescent_Warnings.Init; - end Initialize; - --------------------- -- In_Generic_Body -- --------------------- @@ -686,6 +652,25 @@ package body Sem_Aux is return False; end In_Generic_Body; + ------------------------------- + -- Initialization_Suppressed -- + ------------------------------- + + function Initialization_Suppressed (Typ : Entity_Id) return Boolean is + begin + return Suppress_Initialization (Typ) + or else Suppress_Initialization (Base_Type (Typ)); + end Initialization_Suppressed; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Obsolescent_Warnings.Init; + end Initialize; + --------------------- -- Is_By_Copy_Type -- --------------------- @@ -828,38 +813,6 @@ package body Sem_Aux is end if; end Is_Generic_Formal; - --------------------------- - -- Is_Indefinite_Subtype -- - --------------------------- - - function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is - K : constant Entity_Kind := Ekind (Ent); - - begin - if Is_Constrained (Ent) then - return False; - - elsif K in Array_Kind - or else K in Class_Wide_Kind - or else Has_Unknown_Discriminants (Ent) - then - return True; - - -- Known discriminants: indefinite if there are no default values - - elsif K in Record_Kind - or else Is_Incomplete_Or_Private_Type (Ent) - or else Is_Concurrent_Type (Ent) - then - return (Has_Discriminants (Ent) - and then - No (Discriminant_Default_Value (First_Discriminant (Ent)))); - - else - return False; - end if; - end Is_Indefinite_Subtype; - ------------------------------- -- Is_Immutably_Limited_Type -- ------------------------------- @@ -959,6 +912,38 @@ package body Sem_Aux is end if; end Is_Immutably_Limited_Type; + --------------------------- + -- Is_Indefinite_Subtype -- + --------------------------- + + function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is + K : constant Entity_Kind := Ekind (Ent); + + begin + if Is_Constrained (Ent) then + return False; + + elsif K in Array_Kind + or else K in Class_Wide_Kind + or else Has_Unknown_Discriminants (Ent) + then + return True; + + -- Known discriminants: indefinite if there are no default values + + elsif K in Record_Kind + or else Is_Incomplete_Or_Private_Type (Ent) + or else Is_Concurrent_Type (Ent) + then + return (Has_Discriminants (Ent) + and then + No (Discriminant_Default_Value (First_Discriminant (Ent)))); + + else + return False; + end if; + end Is_Indefinite_Subtype; + --------------------- -- Is_Limited_Type -- --------------------- @@ -1147,6 +1132,25 @@ package body Sem_Aux is return N; end Number_Discriminants; + ---------------------------------------------- + -- Object_Type_Has_Constrained_Partial_View -- + ---------------------------------------------- + + function Object_Type_Has_Constrained_Partial_View + (Typ : Entity_Id; + Scop : Entity_Id) return Boolean + is + begin + return Has_Constrained_Partial_View (Typ) + or else (In_Generic_Body (Scop) + and then Is_Generic_Type (Base_Type (Typ)) + and then Is_Private_Type (Base_Type (Typ)) + and then not Is_Tagged_Type (Typ) + and then not (Is_Array_Type (Typ) + and then not Is_Constrained (Typ)) + and then Has_Discriminants (Typ)); + end Object_Type_Has_Constrained_Partial_View; + --------------- -- Tree_Read -- --------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index fafd70f7f45..e7086cc0ecc 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.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- -- @@ -105,14 +105,6 @@ package Sem_Aux is -- constants from the point of view of constant folding. Empty is also -- returned for variables with no initialization expression. - function Effectively_Has_Constrained_Partial_View - (Typ : Entity_Id; - Scop : Entity_Id) return Boolean; - -- Return True if Typ has attribute Has_Constrained_Partial_View set to - -- True; in addition, within a generic body, return True if a subtype is - -- a descendant of an untagged generic formal private or derived type, and - -- the subtype is not an unconstrained array subtype (RM 3.3(23.10/3)). - function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id; -- For any entity, Ent, returns the closest dynamic scope in which the -- entity is declared or Standard_Standard for library-level entities. @@ -259,6 +251,12 @@ package Sem_Aux is function In_Generic_Body (Id : Entity_Id) return Boolean; -- Determine whether entity Id appears inside a generic body + function Initialization_Suppressed (Typ : Entity_Id) return Boolean; + pragma Inline (Initialization_Suppressed); + -- Returns True if initialization should be suppressed for the given type + -- or subtype. This is true if Suppress_Initialization is set either for + -- the subtype itself, or for the corresponding base type. + function Is_By_Copy_Type (Ent : Entity_Id) return Boolean; -- Ent is any entity. Returns True if Ent is a type entity where the type -- is required to be passed by copy, as defined in (RM 6.2(3)). @@ -329,11 +327,14 @@ package Sem_Aux is function Number_Discriminants (Typ : Entity_Id) return Pos; -- Typ is a type with discriminants, yields number of discriminants in type - function Initialization_Suppressed (Typ : Entity_Id) return Boolean; - pragma Inline (Initialization_Suppressed); - -- Returns True if initialization should be suppressed for the given type - -- or subtype. This is true if Suppress_Initialization is set either for - -- the subtype itself, or for the corresponding base type. + function Object_Type_Has_Constrained_Partial_View + (Typ : Entity_Id; + Scop : Entity_Id) return Boolean; + -- Return True if type of object has attribute Has_Constrained_Partial_View + -- set to True; in addition, within a generic body, return True if subtype + -- of the object is a descendant of an untagged generic formal private or + -- derived type, and the subtype is not an unconstrained array subtype + -- (RM 3.3(23.10/3)). function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; pragma Inline (Ultimate_Alias); diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 432de5dc367..515d2a6009e 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.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. -- -- -- -- 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- -- @@ -114,6 +114,18 @@ package body Sem_Case is Others_Present : Boolean; Case_Node : Node_Id) is + procedure Check_Against_Predicate + (Pred : in out Node_Id; + Choice : Choice_Bounds; + Prev_Lo : in out Uint; + Prev_Hi : in out Uint; + Error : in out Boolean); + -- Determine whether a choice covers legal values as defined by a static + -- predicate set. Pred is a static predicate range. Choice is the choice + -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous + -- choice that covered a predicate set. Error denotes whether the check + -- found an illegal intersection. + 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 @@ -123,102 +135,292 @@ package body Sem_Case is -- Comparison routine for comparing Choice_Table entries. Use the lower -- bound of each Choice as the key. + procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id); + procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint); + procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id); + procedure Missing_Choice (Value1 : Uint; Value2 : Uint); + -- Issue an error message indicating that there are missing choices, + -- followed by the image of the missing choices themselves which lie + -- between Value1 and Value2 inclusive. + + 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. + procedure Move_Choice (From : Natural; To : Natural); -- Move routine for sorting the Choice_Table package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice); - procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id); - procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint); - procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id); - procedure Issue_Msg (Value1 : Uint; Value2 : Uint); - -- Issue an error message indicating that there are missing choices, - -- followed by the image of the missing choices themselves which lie - -- between Value1 and Value2 inclusive. + ----------------------------- + -- Check_Against_Predicate -- + ----------------------------- - --------------- - -- Issue_Msg -- - --------------- + procedure Check_Against_Predicate + (Pred : in out Node_Id; + Choice : Choice_Bounds; + Prev_Lo : in out Uint; + Prev_Hi : in out Uint; + Error : in out Boolean) + is + procedure Illegal_Range + (Loc : Source_Ptr; + Lo : Uint; + Hi : Uint); + -- Emit an error message regarding a choice that clashes with the + -- legal static predicate sets. Loc is the location of the choice + -- that introduced the illegal range. Lo .. Hi is the range. + + function Inside_Range + (Lo : Uint; + Hi : Uint; + Val : Uint) return Boolean; + -- Determine whether position Val within a discrete type is within + -- the range Lo .. Hi inclusive. + + ------------------- + -- Illegal_Range -- + ------------------- + + procedure Illegal_Range + (Loc : Source_Ptr; + Lo : Uint; + Hi : Uint) + is + begin + Error_Msg_Name_1 := Chars (Bounds_Type); - procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is - begin - Issue_Msg (Expr_Value (Value1), Expr_Value (Value2)); - end Issue_Msg; + -- Single value - procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is - begin - Issue_Msg (Expr_Value (Value1), Value2); - end Issue_Msg; + if Lo = Hi then + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Lo; + Error_Msg ("static predicate on % excludes value ^!", Loc); + else + Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type); + Error_Msg ("static predicate on % excludes value %!", Loc); + end if; - procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is - begin - Issue_Msg (Value1, Expr_Value (Value2)); - end Issue_Msg; + -- Range - procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is - Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); + else + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Lo; + Error_Msg_Uint_2 := Hi; + Error_Msg + ("static predicate on % excludes range ^ .. ^!", Loc); + else + Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type); + Error_Msg_Name_3 := Choice_Image (Hi, Bounds_Type); + Error_Msg + ("static predicate on % excludes range % .. %!", Loc); + end if; + end if; + end Illegal_Range; + + ------------------ + -- Inside_Range -- + ------------------ + + function Inside_Range + (Lo : Uint; + Hi : Uint; + Val : Uint) return Boolean + is + begin + return + Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi); + end Inside_Range; + + -- Local variables + + Choice_Hi : constant Uint := Expr_Value (Choice.Hi); + Choice_Lo : constant Uint := Expr_Value (Choice.Lo); + Loc : Source_Ptr; + Next_Hi : Uint; + Next_Lo : Uint; + Pred_Hi : Uint; + Pred_Lo : Uint; + + -- Start of processing for Check_Against_Predicate begin - -- AI05-0188 : within an instance the non-others choices do not - -- have to belong to the actual subtype. + -- Find the proper error message location - if Ada_Version >= Ada_2012 and then In_Instance then - return; + if Present (Choice.Node) then + Loc := Sloc (Choice.Node); + else + Loc := Sloc (Case_Node); end if; - -- In some situations, we call this with a null range, and - -- obviously we don't want to complain in this case! + if Present (Pred) then + Pred_Lo := Expr_Value (Low_Bound (Pred)); + Pred_Hi := Expr_Value (High_Bound (Pred)); + + -- Previous choices managed to satisfy all static predicate sets + + else + Illegal_Range (Loc, Choice_Lo, Choice_Hi); + Error := True; - if Value1 > Value2 then return; end if; - -- Case of only one value that is missing + -- Step 1: Detect duplicate choices - if Value1 = Value2 then - if Is_Integer_Type (Bounds_Type) then - Error_Msg_Uint_1 := Value1; - Error_Msg ("missing case value: ^!", Msg_Sloc); + 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); + Error := True; + + -- Step 2: Detect full coverage + + -- Choice_Lo Choice_Hi + -- +============+ + -- Pred_Lo Pred_Hi + + elsif Choice_Lo = Pred_Lo and then Choice_Hi = Pred_Hi then + Prev_Lo := Choice_Lo; + Prev_Hi := Choice_Hi; + Next (Pred); + + -- Step 3: Detect all cases where a choice mentions values that are + -- not part of the static predicate sets. + + -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi + -- +-----------+ . . . . . +=========+ + -- ^ illegal ^ + + elsif Choice_Lo < Pred_Lo and then Choice_Hi < Pred_Lo then + Illegal_Range (Loc, Choice_Lo, Choice_Hi); + Error := True; + + -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi + -- +-----------+=========+===========+ + -- ^ illegal ^ + + elsif Choice_Lo < Pred_Lo + and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Hi) + then + Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1); + Error := True; + + -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi + -- +=========+ . . . . +-----------+ + -- ^ illegal ^ + + elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then + Missing_Choice (Pred_Lo, Pred_Hi); + Error := True; + + -- There may be several static predicate sets between the current + -- one and the choice. Inspect the next static predicate set. + + Next (Pred); + Check_Against_Predicate + (Pred => Pred, + Choice => Choice, + Prev_Lo => Prev_Lo, + Prev_Hi => Prev_Hi, + Error => Error); + + -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi + -- +=========+===========+-----------+ + -- ^ illegal ^ + + elsif Pred_Hi < Choice_Hi + and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Lo) + then + Next (Pred); + + -- The choice may fall in a static predicate set. If this is the + -- case, avoid mentioning legal values in the error message. + + if Present (Pred) then + Next_Lo := Expr_Value (Low_Bound (Pred)); + Next_Hi := Expr_Value (High_Bound (Pred)); + + -- The next static predicate set is to the right of the choice + + if Choice_Hi < Next_Lo and then Choice_Hi < Next_Hi then + Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi); + else + Illegal_Range (Loc, Pred_Hi + 1, Next_Lo - 1); + end if; else - Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); - Error_Msg ("missing case value: %!", Msg_Sloc); + Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi); end if; - -- More than one choice value, so print range of values + Error := True; + + -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi + -- +-----------+=========+-----------+ + -- ^ illegal ^ ^ illegal ^ + + -- Emit an error on the low gap, disregard the upper gap + + elsif Choice_Lo < Pred_Lo and then Pred_Hi < Choice_Hi then + Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1); + Error := True; + + -- Step 4: Detect all cases of partial or missing coverage + + -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi + -- +=========+==========+===========+ + -- ^ gap ^ ^ gap ^ else - if Is_Integer_Type (Bounds_Type) then - Error_Msg_Uint_1 := Value1; - Error_Msg_Uint_2 := Value2; - Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc); - else - Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); - Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type); - Error_Msg ("missing case values: % .. %!", Msg_Sloc); - end if; - end if; - end Issue_Msg; + -- An "others" choice covers all gaps - --------------- - -- Lt_Choice -- - --------------- + if Others_Present then + Prev_Lo := Choice_Lo; + Prev_Hi := Choice_Hi; + Next (Pred); - function Lt_Choice (C1, C2 : Natural) return Boolean is - begin - return - Expr_Value (Choice_Table (Nat (C1)).Lo) - < - Expr_Value (Choice_Table (Nat (C2)).Lo); - end Lt_Choice; + -- Choice_Lo Choice_Hi Pred_Hi + -- +===========+===========+ + -- Pred_Lo ^ gap ^ - ----------------- - -- Move_Choice -- - ----------------- + -- The upper gap may be covered by a subsequent choice - procedure Move_Choice (From : Natural; To : Natural) is - begin - Choice_Table (Nat (To)) := Choice_Table (Nat (From)); - end Move_Choice; + elsif Pred_Lo = Choice_Lo then + Prev_Lo := Choice_Lo; + Prev_Hi := Choice_Hi; + + -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi + -- +===========+=========+===========+===========+ + -- ^ covered ^ ^ gap ^ + + else pragma Assert (Pred_Lo < Choice_Lo); + + -- A previous choice covered the gap up to the current choice + + if Prev_Hi = Choice_Lo - 1 then + Prev_Lo := Choice_Lo; + Prev_Hi := Choice_Hi; + + if Choice_Hi = Pred_Hi then + Next (Pred); + end if; + + -- The previous choice did not intersect with the current + -- static predicate set. + + elsif Prev_Hi < Pred_Lo then + Missing_Choice (Pred_Lo, Choice_Lo - 1); + Error := True; + + -- The previous choice covered part of the static predicate set + + else + Missing_Choice (Prev_Hi, Choice_Lo - 1); + Error := True; + end if; + end if; + end if; + end Check_Against_Predicate; ------------------------------ -- Explain_Non_Static_Bound -- @@ -236,16 +438,16 @@ package body Sem_Case is if Bounds_Type /= Subtyp then - -- If the case is a variant part, the expression is given by - -- the discriminant itself, and the bounds are the culprits. + -- If the case is a variant part, the expression is given by the + -- discriminant itself, and the bounds are the culprits. if Nkind (Case_Node) = N_Variant_Part then Error_Msg_NE ("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. + -- 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 @@ -269,30 +471,150 @@ package body Sem_Case is end if; end Explain_Non_Static_Bound; - -- Variables local to Check_Choices + --------------- + -- Lt_Choice -- + --------------- + + function Lt_Choice (C1, C2 : Natural) return Boolean is + begin + return + Expr_Value (Choice_Table (Nat (C1)).Lo) + < + Expr_Value (Choice_Table (Nat (C2)).Lo); + end Lt_Choice; + + -------------------- + -- Missing_Choice -- + -------------------- - Choice : Node_Id; - Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); - Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); + procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id) is + begin + Missing_Choice (Expr_Value (Value1), Expr_Value (Value2)); + end Missing_Choice; - Prev_Choice : Node_Id; + procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint) is + begin + Missing_Choice (Expr_Value (Value1), Value2); + end Missing_Choice; + + procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id) is + begin + Missing_Choice (Value1, Expr_Value (Value2)); + end Missing_Choice; + + procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is + Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); + + begin + -- AI05-0188 : within an instance the non-others choices do not have + -- to belong to the actual subtype. + + if Ada_Version >= Ada_2012 and then In_Instance then + return; + + -- In some situations, we call this with a null range, and obviously + -- we don't want to complain in this case. + + elsif Value1 > Value2 then + return; + end if; + + -- Case of only one value that is missing + + if Value1 = Value2 then + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Value1; + Error_Msg ("missing case value: ^!", Msg_Sloc); + else + Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); + Error_Msg ("missing case value: %!", Msg_Sloc); + end if; + + -- More than one choice value, so print range of values + + else + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Value1; + Error_Msg_Uint_2 := Value2; + Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc); + else + Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); + Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type); + Error_Msg ("missing case values: % .. %!", Msg_Sloc); + end if; + end if; + end Missing_Choice; + + --------------------- + -- Missing_Choices -- + --------------------- - Hi : Uint; - Lo : Uint; - Prev_Hi : Uint; + procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint) is + Hi : Uint; + Lo : Uint; + Set : Node_Id; + + begin + Set := Pred; + while Present (Set) loop + Lo := Expr_Value (Low_Bound (Set)); + Hi := Expr_Value (High_Bound (Set)); + + -- A choice covered part of a static predicate set + + if Lo <= Prev_Hi and then Prev_Hi < Hi then + Missing_Choice (Prev_Hi + 1, Hi); + + else + Missing_Choice (Lo, Hi); + end if; + + Next (Set); + end loop; + end Missing_Choices; + + ----------------- + -- Move_Choice -- + ----------------- + + procedure Move_Choice (From : Natural; To : Natural) is + begin + Choice_Table (Nat (To)) := Choice_Table (Nat (From)); + end Move_Choice; + + -- Local variables + + Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); + Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); + Has_Predicate : constant Boolean := + Is_Static_Subtype (Bounds_Type) + and then Present (Static_Predicate (Bounds_Type)); + Num_Choices : constant Nat := Choice_Table'Last; + + Choice : Node_Id; + Choice_Hi : Uint; + Choice_Lo : Uint; + Error : Boolean; + Pred : Node_Id; + Prev_Choice : Node_Id; + Prev_Lo : Uint; + Prev_Hi : Uint; -- Start of processing for Check_Choices begin - -- Choice_Table must start at 0 which is an unused location used - -- by the sorting algorithm. However the first valid position for - -- a discrete choice is 1. + -- Choice_Table must start at 0 which is an unused location used by the + -- sorting algorithm. However the first valid position for a discrete + -- choice is 1. pragma Assert (Choice_Table'First = 0); - if Choice_Table'Last = 0 then + -- The choices do not cover the base range. Emit an error if "others" is + -- not available and return as there is no need for further processing. + + if Num_Choices = 0 then if not Others_Present then - Issue_Msg (Bounds_Lo, Bounds_Hi); + Missing_Choice (Bounds_Lo, Bounds_Hi); end if; return; @@ -300,59 +622,98 @@ package body Sem_Case is Sorting.Sort (Positive (Choice_Table'Last)); - Lo := Expr_Value (Choice_Table (1).Lo); - Hi := Expr_Value (Choice_Table (1).Hi); - Prev_Hi := Hi; + -- The type covered by the list of choices is actually a static subtype + -- subject to a static predicate. The predicate defines subsets of legal + -- values and requires finer grained analysis. + + if Has_Predicate then + Pred := First (Static_Predicate (Bounds_Type)); + Prev_Lo := Uint_Minus_1; + Prev_Hi := Uint_Minus_1; + Error := False; + + for Index in 1 .. Num_Choices loop + Check_Against_Predicate + (Pred => Pred, + Choice => Choice_Table (Index), + Prev_Lo => Prev_Lo, + Prev_Hi => Prev_Hi, + Error => Error); + + -- The analysis detected an illegal intersection between a choice + -- and a static predicate set. - if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then - Issue_Msg (Bounds_Lo, Lo - 1); + if Error then + return; + end if; + end loop; - -- If values are missing outside of the subtype, add explanation. - -- No additional message if only one value is missing. + -- The choices may legally cover some of the static predicate sets, + -- but not all. Emit an error for each non-covered set. - if Expr_Value (Bounds_Lo) < Lo - 1 then - Explain_Non_Static_Bound; + if not Others_Present then + Missing_Choices (Pred, Prev_Hi); end if; - end if; - for J in 2 .. Choice_Table'Last loop - Lo := Expr_Value (Choice_Table (J).Lo); - Hi := Expr_Value (Choice_Table (J).Hi); + -- Default analysis - if Lo <= Prev_Hi then - Choice := Choice_Table (J).Node; + else + Choice_Lo := Expr_Value (Choice_Table (1).Lo); + Choice_Hi := Expr_Value (Choice_Table (1).Hi); + Prev_Hi := Choice_Hi; - -- Find first previous choice that overlaps + if not Others_Present and then Expr_Value (Bounds_Lo) < Choice_Lo then + Missing_Choice (Bounds_Lo, Choice_Lo - 1); - for K in 1 .. J - 1 loop - if Lo <= Expr_Value (Choice_Table (K).Hi) then - Prev_Choice := Choice_Table (K).Node; - exit; - end if; - end loop; + -- If values are missing outside of the subtype, add explanation. + -- No additional message if only one value is missing. - if Sloc (Prev_Choice) <= Sloc (Choice) then - Error_Msg_Sloc := Sloc (Prev_Choice); - Error_Msg_N ("duplication of choice value#", Choice); - else - Error_Msg_Sloc := Sloc (Choice); - Error_Msg_N ("duplication of choice value#", Prev_Choice); + if Expr_Value (Bounds_Lo) < Choice_Lo - 1 then + Explain_Non_Static_Bound; end if; - - elsif not Others_Present and then Lo /= Prev_Hi + 1 then - Issue_Msg (Prev_Hi + 1, Lo - 1); end if; - if Hi > Prev_Hi then - Prev_Hi := Hi; - end if; - end loop; + for Outer_Index in 2 .. Num_Choices loop + Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo); + Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi); + + if Choice_Lo <= Prev_Hi then + Choice := Choice_Table (Outer_Index).Node; - if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then - Issue_Msg (Hi + 1, Bounds_Hi); + -- Find first previous choice that overlaps - if Expr_Value (Bounds_Hi) > Hi + 1 then - Explain_Non_Static_Bound; + for Inner_Index in 1 .. Outer_Index - 1 loop + if Choice_Lo <= + Expr_Value (Choice_Table (Inner_Index).Hi) + then + Prev_Choice := Choice_Table (Inner_Index).Node; + exit; + end if; + end loop; + + if Sloc (Prev_Choice) <= Sloc (Choice) then + Error_Msg_Sloc := Sloc (Prev_Choice); + Error_Msg_N ("duplication of choice value#", Choice); + else + Error_Msg_Sloc := Sloc (Choice); + Error_Msg_N ("duplication of choice value#", Prev_Choice); + end if; + + elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then + Missing_Choice (Prev_Hi + 1, Choice_Lo - 1); + end if; + + if Choice_Hi > Prev_Hi then + Prev_Hi := Choice_Hi; + 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 Expr_Value (Bounds_Hi) > Choice_Hi + 1 then + Explain_Non_Static_Bound; + end if; end if; end if; end Check_Choices; @@ -899,7 +1260,8 @@ package body Sem_Case is then Bad_Predicated_Subtype_Use ("cannot use subtype& with non-static " - & "predicate as case alternative", Choice, E); + & "predicate as case alternative", Choice, E, + Suggest_Static => True); -- Static predicate case diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index a4241afabd7..98b0d5795ae 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -79,8 +79,8 @@ package body Sem_Ch10 is -- Build and decorate the list of shadow entities for a package mentioned -- in a limited_with clause. If the package was not previously analyzed -- then it also performs a basic decoration of the real entities. This is - -- required to do not pass non-decorated entities to the back-end. - -- Implements Ada 2005 (AI-50217). + -- required in order to avoid passing non-decorated entities to the + -- back-end. Implements Ada 2005 (AI-50217). procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id); -- Check whether the source for the body of a compilation unit must be @@ -401,9 +401,8 @@ package body Sem_Ch10 is elsif Nkind (Cont_Item) = N_Pragma and then - (Pragma_Name (Cont_Item) = Name_Elaborate - or else - Pragma_Name (Cont_Item) = Name_Elaborate_All) + Nam_In (Pragma_Name (Cont_Item), Name_Elaborate, + Name_Elaborate_All) and then not Used_Type_Or_Elab then Prag_Unit := @@ -2457,14 +2456,6 @@ package body Sem_Ch10 is return; end if; - -- We reset ordinary style checking during the analysis of a with'ed - -- unit, but we do NOT reset GNAT special analysis mode (the latter - -- definitely *does* apply to with'ed units). - - if not GNAT_Mode then - Style_Check := False; - end if; - -- If the library unit is a predefined unit, and we are in high -- integrity mode, then temporarily reset Configurable_Run_Time_Mode -- for the analysis of the with'ed unit. This mode does not prevent @@ -2501,9 +2492,9 @@ package body Sem_Ch10 is if Nkind (Nam) = N_Selected_Component and then Nkind (Prefix (Nam)) = N_Identifier and then Chars (Prefix (Nam)) = Name_Gnat - and then (Chars (Selector_Name (Nam)) = Name_Most_Recent_Exception - or else - Chars (Selector_Name (Nam)) = Name_Exception_Traces) + and then Nam_In (Chars (Selector_Name (Nam)), + Name_Most_Recent_Exception, + Name_Exception_Traces) then Check_Restriction (No_Exception_Propagation, N); Special_Exception_Package_Used := True; diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index e3635c66e17..180ecc6ca0b 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.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- -- @@ -424,6 +424,60 @@ package body Sem_Ch11 is end if; end Analyze_Handled_Statements; + ------------------------------ + -- Analyze_Raise_Expression -- + ------------------------------ + + procedure Analyze_Raise_Expression (N : Node_Id) is + Exception_Id : constant Node_Id := Name (N); + Exception_Name : Entity_Id := Empty; + + begin + Check_SPARK_Restriction ("raise expression is not allowed", N); + + -- Check exception restrictions on the original source + + if Comes_From_Source (N) then + Check_Restriction (No_Exceptions, N); + end if; + + Analyze (Exception_Id); + + if Is_Entity_Name (Exception_Id) then + Exception_Name := Entity (Exception_Id); + end if; + + if No (Exception_Name) + or else Ekind (Exception_Name) /= E_Exception + then + Error_Msg_N + ("exception name expected in raise statement", Exception_Id); + else + Set_Is_Raised (Exception_Name); + end if; + + -- Deal with RAISE WITH case + + if Present (Expression (N)) then + Check_Compiler_Unit (Expression (N)); + Analyze_And_Resolve (Expression (N), Standard_String); + end if; + + -- Check obsolescent use of Numeric_Error + + if Exception_Name = Standard_Numeric_Error then + Check_Restriction (No_Obsolescent_Features, Exception_Id); + end if; + + -- Kill last assignment indication + + Kill_Current_Values (Last_Assignment_Only => True); + + -- Set type as Any_Type since we have no information at all on the type + + Set_Etype (N, Any_Type); + end Analyze_Raise_Expression; + ----------------------------- -- Analyze_Raise_Statement -- ----------------------------- diff --git a/gcc/ada/sem_ch11.ads b/gcc/ada/sem_ch11.ads index 63544bd0e31..656f12d8cc3 100644 --- a/gcc/ada/sem_ch11.ads +++ b/gcc/ada/sem_ch11.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, 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- -- @@ -27,6 +27,7 @@ with Types; use Types; package Sem_Ch11 is procedure Analyze_Exception_Declaration (N : Node_Id); procedure Analyze_Handled_Statements (N : Node_Id); + procedure Analyze_Raise_Expression (N : Node_Id); procedure Analyze_Raise_Statement (N : Node_Id); procedure Analyze_Raise_xxx_Error (N : Node_Id); procedure Analyze_Subprogram_Info (N : Node_Id); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 3f8abe7f58c..98d45f83378 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3021,6 +3021,13 @@ package body Sem_Ch12 is Id := Defining_Entity (N); Generate_Definition (Id); + -- Analyze aspects now, so that generated pragmas appear in the + -- declarations before building and analyzing the generic copy. + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Id); + end if; + -- Expansion is not applied to generic units Start_Generic; @@ -3079,9 +3086,6 @@ package body Sem_Ch12 is end if; end if; - if Has_Aspects (N) then - Analyze_Aspect_Specifications (N, Id); - end if; end Analyze_Generic_Package_Declaration; -------------------------------------------- @@ -3244,11 +3248,10 @@ package body Sem_Ch12 is begin Aspect := First (Aspect_Specifications (N)); while Present (Aspect) loop - if Get_Aspect_Id (Chars (Identifier (Aspect))) - /= Aspect_Warnings - then + if Get_Aspect_Id (Aspect) /= Aspect_Warnings then Analyze (Expression (Aspect)); end if; + Next (Aspect); end loop; @@ -4966,8 +4969,7 @@ package body Sem_Ch12 is Make_Compilation_Unit (Sloc (N), Context_Items => Empty_List, Unit => Act_Decl, - Aux_Decls_Node => - Make_Compilation_Unit_Aux (Sloc (N))); + Aux_Decls_Node => Make_Compilation_Unit_Aux (Sloc (N))); Set_Parent_Spec (Act_Decl, Parent_Spec (N)); @@ -4984,8 +4986,8 @@ package body Sem_Ch12 is -- The two compilation unit nodes are linked by the Library_Unit field - Set_Library_Unit (Decl_Cunit, Body_Cunit); - Set_Library_Unit (Body_Cunit, Decl_Cunit); + Set_Library_Unit (Decl_Cunit, Body_Cunit); + Set_Library_Unit (Body_Cunit, Decl_Cunit); -- Preserve the private nature of the package if needed @@ -5043,8 +5045,7 @@ package body Sem_Ch12 is procedure Check_Access_Definition (N : Node_Id) is begin pragma Assert - (Ada_Version >= Ada_2005 - and then Present (Access_Definition (N))); + (Ada_Version >= Ada_2005 and then Present (Access_Definition (N))); null; end Check_Access_Definition; @@ -5466,11 +5467,13 @@ package body Sem_Ch12 is -- For a formal that is an array type, the component type is often a -- previous formal in the same unit. The privacy status of the component -- type will have been examined earlier in the traversal of the - -- corresponding actuals, and this status should not be modified for the - -- array type itself. + -- corresponding actuals, and this status should not be modified for + -- the array (sub)type itself. However, if the base type of the array + -- (sub)type is private, its full view must be restored in the body to + -- be consistent with subsequent index subtypes, etc. -- - -- To detect this case we have to rescan the list of formals, which - -- is usually short enough to ignore the resulting inefficiency. + -- To detect this case we have to rescan the list of formals, which is + -- usually short enough to ignore the resulting inefficiency. ----------------------------- -- Denotes_Previous_Actual -- @@ -5511,6 +5514,7 @@ package body Sem_Ch12 is and then Is_Entity_Name (Subtype_Indication (Parent (E))) then if Is_Array_Type (E) + and then not Is_Private_Type (Etype (E)) and then Denotes_Previous_Actual (Component_Type (E)) then null; @@ -5548,8 +5552,8 @@ package body Sem_Ch12 is if Is_Discrete_Or_Fixed_Point_Type (E) then Set_RM_Size (E, RM_Size (Astype)); - -- In nested instances, the base type of an access actual - -- may itself be private, and need to be exchanged. + -- In nested instances, the base type of an access actual may + -- itself be private, and need to be exchanged. elsif Is_Access_Type (E) and then Is_Private_Type (Etype (E)) @@ -5651,9 +5655,9 @@ package body Sem_Ch12 is then Switch_View (Typ); - -- If the type of the entity is a subtype, it may also - -- have to be made visible, together with the base type - -- of its full view, after exchange. + -- If the type of the entity is a subtype, it may also have + -- to be made visible, together with the base type of its + -- full view, after exchange. if Is_Private_Type (Etype (E)) then Switch_View (Etype (E)); @@ -5687,8 +5691,8 @@ package body Sem_Ch12 is -- Search generic parent for possible child unit with the given name function In_Enclosing_Instance return Boolean; - -- Within an instance of the parent, the child unit may be denoted - -- by a simple name, or an abbreviated expanded name. Examine enclosing + -- Within an instance of the parent, the child unit may be denoted by + -- a simple name, or an abbreviated expanded name. Examine enclosing -- scopes to locate a possible parent instantiation. ------------------------ @@ -5905,10 +5909,10 @@ package body Sem_Ch12 is elsif In_Open_Scopes (Inst_Par) then -- If the parent is already installed, install the actuals - -- for its formal packages. This is necessary when the - -- child instance is a child of the parent instance: - -- in this case, the parent is placed on the scope stack - -- but the formal packages are not made visible. + -- for its formal packages. This is necessary when the child + -- instance is a child of the parent instance: in this case, + -- the parent is placed on the scope stack but the formal + -- packages are not made visible. Install_Formal_Packages (Inst_Par); end if; @@ -6140,9 +6144,9 @@ package body Sem_Ch12 is -- The normal exchange mechanism relies on the setting of a -- flag on the reference in the generic. However, an additional - -- mechanism is needed for types that are not explicitly mentioned - -- in the generic, but may be needed in expanded code in the - -- instance. This includes component types of arrays and + -- mechanism is needed for types that are not explicitly + -- mentioned in the generic, but may be needed in expanded code + -- in the instance. This includes component types of arrays and -- designated types of access types. This processing must also -- include the index types of arrays which we take care of here. @@ -6324,10 +6328,10 @@ package body Sem_Ch12 is New_N : Node_Id; function Copy_Generic_Descendant (D : Union_Id) return Union_Id; - -- Check the given value of one of the Fields referenced by the - -- current node to determine whether to copy it recursively. The - -- field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain - -- value (Sloc, Uint, Char) in which case it need not be copied. + -- Check the given value of one of the Fields referenced by the current + -- node to determine whether to copy it recursively. The field may hold + -- a Node_Id, a List_Id, or an Elist_Id, or a plain value (Sloc, Uint, + -- Char) in which case it need not be copied. procedure Copy_Descendants; -- Common utility for various nodes @@ -6341,10 +6345,10 @@ package body Sem_Ch12 is -- Apply Copy_Node recursively to the members of a node list function In_Defining_Unit_Name (Nam : Node_Id) return Boolean; - -- True if an identifier is part of the defining program unit name - -- of a child unit. The entity of such an identifier must be kept - -- (for ASIS use) even though as the name of an enclosing generic - -- it would otherwise not be preserved in the generic tree. + -- True if an identifier is part of the defining program unit name of + -- a child unit. The entity of such an identifier must be kept (for + -- ASIS use) even though as the name of an enclosing generic it would + -- otherwise not be preserved in the generic tree. ---------------------- -- Copy_Descendants -- @@ -6504,19 +6508,20 @@ package body Sem_Ch12 is Set_Associated_Node (N, New_N); -- If we are within an instantiation, this is a nested generic - -- that has already been analyzed at the point of definition. We - -- must preserve references that were global to the enclosing + -- that has already been analyzed at the point of definition. + -- We must preserve references that were global to the enclosing -- parent at that point. Other occurrences, whether global or -- local to the current generic, must be resolved anew, so we -- reset the entity in the generic copy. A global reference has a -- smaller depth than the parent, or else the same depth in case -- both are distinct compilation units. + -- A child unit is implicitly declared within the enclosing parent -- but is in fact global to it, and must be preserved. -- It is also possible for Current_Instantiated_Parent to be - -- defined, and for this not to be a nested generic, namely if the - -- unit is loaded through Rtsfind. In that case, the entity of + -- defined, and for this not to be a nested generic, namely if + -- the unit is loaded through Rtsfind. In that case, the entity of -- New_N is only a link to the associated node, and not a defining -- occurrence. @@ -6557,11 +6562,11 @@ package body Sem_Ch12 is -- Case of instantiating identifier or some other name or operator else - -- If the associated node is still defined, the entity in it is - -- global, and must be copied to the instance. If this copy is - -- being made for a body to inline, it is applied to an - -- instantiated tree, and the entity is already present and must - -- be also preserved. + -- If the associated node is still defined, the entity in it + -- is global, and must be copied to the instance. If this copy + -- is being made for a body to inline, it is applied to an + -- instantiated tree, and the entity is already present and + -- must be also preserved. declare Assoc : constant Node_Id := Get_Associated_Node (N); @@ -6636,7 +6641,7 @@ package body Sem_Ch12 is -- If we are not instantiating, then this is where we load and -- analyze subunits, i.e. at the point where the stub occurs. A -- more permissive system might defer this analysis to the point - -- of instantiation, but this seems to complicated for now. + -- of instantiation, but this seems too complicated for now. if not Instantiating then declare @@ -6661,8 +6666,8 @@ package body Sem_Ch12 is Lib.Analysing_Subunit_Of_Main := False; -- If the proper body is not found, a warning message will be - -- emitted when analyzing the stub, or later at the point - -- of instantiation. Here we just leave the stub as is. + -- emitted when analyzing the stub, or later at the point of + -- instantiation. Here we just leave the stub as is. if Unum = No_Unit then Subunits_Missing := True; @@ -6900,7 +6905,6 @@ package body Sem_Ch12 is begin if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then New_N := Make_Null_Statement (Sloc (N)); - else Copy_Descendants; end if; @@ -7459,7 +7463,7 @@ package body Sem_Ch12 is Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G)))); end if; - -- Freeze package that encloses instance, and place node after + -- Freeze package that encloses instance, and place node after the -- package that encloses generic. If enclosing package is already -- frozen we have to assume it is at the proper place. This may be a -- potential ABE that requires dynamic checking. Do not add a freeze @@ -7878,9 +7882,9 @@ package body Sem_Ch12 is Par_N : Node_Id; function Enclosing_Body (N : Node_Id) return Node_Id; - -- Find enclosing package or subprogram body, if any. Freeze node - -- may be placed at end of current declarative list if previous - -- instance and current one have different enclosing bodies. + -- Find enclosing package or subprogram body, if any. Freeze node may + -- be placed at end of current declarative list if previous instance + -- and current one have different enclosing bodies. function Previous_Instance (Gen : Entity_Id) return Entity_Id; -- Find the local instance, if any, that declares the generic that is @@ -8389,8 +8393,8 @@ package body Sem_Ch12 is -- Install the scopes of noninstance parent units ending with Par procedure Install_Spec (Par : Entity_Id); - -- The child unit is within the declarative part of the parent, so - -- the declarations within the parent are immediately visible. + -- The child unit is within the declarative part of the parent, so the + -- declarations within the parent are immediately visible. ------------------------------- -- Install_Noninstance_Specs -- @@ -8417,10 +8421,10 @@ package body Sem_Ch12 is begin -- If this parent of the child instance is a top-level unit, - -- then record the unit and its visibility for later resetting - -- in Remove_Parent. We exclude units that are generic instances, - -- as we only want to record this information for the ultimate - -- top-level noninstance parent (is that always correct???). + -- then record the unit and its visibility for later resetting in + -- Remove_Parent. We exclude units that are generic instances, as we + -- only want to record this information for the ultimate top-level + -- noninstance parent (is that always correct???). if Scope (Par) = Standard_Standard and then not Is_Generic_Instance (Par) @@ -8694,15 +8698,15 @@ package body Sem_Ch12 is procedure Find_Matching_Actual (F : Node_Id; Act : in out Entity_Id); - -- We need to associate each formal entity in the formal package - -- with the corresponding entity in the actual package. The actual - -- package has been analyzed and possibly expanded, and as a result - -- there is no one-to-one correspondence between the two lists (for - -- example, the actual may include subtypes, itypes, and inherited - -- primitive operations, interspersed among the renaming declarations - -- for the actuals) . We retrieve the corresponding actual by name - -- because each actual has the same name as the formal, and they do - -- appear in the same order. + -- We need to associate each formal entity in the formal package with + -- the corresponding entity in the actual package. The actual package + -- has been analyzed and possibly expanded, and as a result there is + -- no one-to-one correspondence between the two lists (for example, + -- the actual may include subtypes, itypes, and inherited primitive + -- operations, interspersed among the renaming declarations for the + -- actuals) . We retrieve the corresponding actual by name because each + -- actual has the same name as the formal, and they do appear in the + -- same order. function Get_Formal_Entity (N : Node_Id) return Entity_Id; -- Retrieve entity of defining entity of generic formal parameter. @@ -8714,13 +8718,12 @@ package body Sem_Ch12 is (Formal_Node : Node_Id; Formal_Ent : Entity_Id; Actual_Ent : Entity_Id); - -- Associates the formal entity with the actual. In the case - -- where Formal_Ent is a formal package, this procedure iterates - -- through all of its formals and enters associations between the - -- actuals occurring in the formal package's corresponding actual - -- package (given by Actual_Ent) and the formal package's formal - -- parameters. This procedure recurses if any of the parameters is - -- itself a package. + -- Associates the formal entity with the actual. In the case where + -- Formal_Ent is a formal package, this procedure iterates through all + -- of its formals and enters associations between the actuals occurring + -- in the formal package's corresponding actual package (given by + -- Actual_Ent) and the formal package's formal parameters. This + -- procedure recurses if any of the parameters is itself a package. function Is_Instance_Of (Act_Spec : Entity_Id; @@ -9175,12 +9178,12 @@ package body Sem_Ch12 is function From_Parent_Scope (Subp : Entity_Id) return Boolean; -- If the generic is a child unit, the parent has been installed on the - -- scope stack, but a default subprogram cannot resolve to something on - -- the parent because that parent is not really part of the visible + -- scope stack, but a default subprogram cannot resolve to something + -- on the parent because that parent is not really part of the visible -- context (it is there to resolve explicit local entities). If the - -- default has resolved in this way, we remove the entity from - -- immediate visibility and analyze the node again to emit an error - -- message or find another visible candidate. + -- default has resolved in this way, we remove the entity from immediate + -- visibility and analyze the node again to emit an error message or + -- find another visible candidate. procedure Valid_Actual_Subprogram (Act : Node_Id); -- Perform legality check and raise exception on failure @@ -9558,14 +9561,14 @@ package body Sem_Ch12 is end if; -- The actual has to be resolved in order to check that it is a - -- variable (due to cases such as F (1), where F returns access to an - -- array, and for overloaded prefixes). + -- variable (due to cases such as F (1), where F returns access to + -- an array, and for overloaded prefixes). Ftyp := Get_Instance_Of (Etype (A_Gen_Obj)); - -- If the type of the formal is not itself a formal, and the - -- current unit is a child unit, the formal type must be declared - -- in a parent, and must be retrieved by visibility. + -- If the type of the formal is not itself a formal, and the current + -- unit is a child unit, the formal type must be declared in a + -- parent, and must be retrieved by visibility. if Ftyp = Orig_Ftyp and then Is_Generic_Unit (Scope (Ftyp)) @@ -12404,7 +12407,16 @@ package body Sem_Ch12 is Analyze (Act); end if; - if Errs /= Serious_Errors_Detected then + -- Ensure that a ghost subprogram does not act as generic actual + + if Is_Entity_Name (Act) + and then Is_Ghost_Subprogram (Entity (Act)) + then + Error_Msg_N + ("ghost subprogram & cannot act as generic actual", Act); + Abandon_Instantiation (Act); + + elsif Errs /= Serious_Errors_Detected then -- Do a minimal analysis of the generic, to prevent spurious -- warnings complaining about the generic being unreferenced, diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 92df5569df6..1496912cdb4 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -26,6 +26,7 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -50,6 +51,7 @@ with Sem_Ch9; use Sem_Ch9; with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; @@ -82,7 +84,7 @@ package body Sem_Ch13 is -- type whose inherited alignment is no longer appropriate for the new -- size value. In this case, we reset the Alignment to unknown. - procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id); + procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id); -- If Typ has predicates (indicated by Has_Predicates being set for Typ, -- then either there are pragma Predicate entries on the rep chain for the -- type (note that Predicate aspects are converted to pragma Predicate), or @@ -90,7 +92,9 @@ package body Sem_Ch13 is -- This procedure builds the spec and body for the Predicate function that -- tests these predicates. N is the freeze node for the type. The spec of -- the function is inserted before the freeze node, and the body of the - -- function is inserted after the freeze node. + -- function is inserted after the freeze node. If the predicate expression + -- has at least one Raise_Expression, then this procedure also builds the + -- M version of the predicate function for use in membership tests. procedure Build_Static_Predicate (Typ : Entity_Id; @@ -874,7 +878,7 @@ package body Sem_Ch13 is and then Entity (ASN) = E and then Is_Delayed_Aspect (ASN) then - A_Id := Get_Aspect_Id (Chars (Identifier (ASN))); + A_Id := Get_Aspect_Id (ASN); case A_Id is @@ -921,6 +925,81 @@ package body Sem_Ch13 is ----------------------------------- procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is + procedure Decorate_Delayed_Aspect_And_Pragma + (Asp : Node_Id; + Prag : Node_Id); + -- Establish the linkages between a delayed aspect and its corresponding + -- pragma. Set all delay-related flags on both constructs. + + procedure Insert_Delayed_Pragma (Prag : Node_Id); + -- Insert a postcondition-like pragma into the tree depending on the + -- context. Prag must denote one of the following: Pre, Post, Depends, + -- Global or Contract_Cases. + + ---------------------------------------- + -- Decorate_Delayed_Aspect_And_Pragma -- + ---------------------------------------- + + procedure Decorate_Delayed_Aspect_And_Pragma + (Asp : Node_Id; + Prag : Node_Id) + is + begin + Set_Aspect_Rep_Item (Asp, Prag); + Set_Corresponding_Aspect (Prag, Asp); + Set_From_Aspect_Specification (Prag); + Set_Is_Delayed_Aspect (Prag); + Set_Is_Delayed_Aspect (Asp); + Set_Parent (Prag, Asp); + end Decorate_Delayed_Aspect_And_Pragma; + + --------------------------- + -- Insert_Delayed_Pragma -- + --------------------------- + + procedure Insert_Delayed_Pragma (Prag : Node_Id) is + Aux : Node_Id; + + begin + -- When the context is a library unit, the pragma is added to the + -- Pragmas_After list. + + if Nkind (Parent (N)) = N_Compilation_Unit then + Aux := Aux_Decls_Node (Parent (N)); + + if No (Pragmas_After (Aux)) then + Set_Pragmas_After (Aux, New_List); + end if; + + Prepend (Prag, Pragmas_After (Aux)); + + -- Pragmas associated with subprogram bodies are inserted in the + -- declarative part. + + elsif Nkind (N) = N_Subprogram_Body then + if No (Declarations (N)) then + Set_Declarations (N, New_List); + end if; + + Append (Prag, Declarations (N)); + + -- Default + + else + Insert_After (N, Prag); + + -- Analyze the pragma before analyzing the proper body of a stub. + -- This ensures that the pragma will appear on the proper contract + -- list (see N_Contract). + + if Nkind (N) = N_Subprogram_Body_Stub then + Analyze (Prag); + end if; + end if; + end Insert_Delayed_Pragma; + + -- Local variables + Aspect : Node_Id; Aitem : Node_Id; Ent : Node_Id; @@ -931,6 +1010,8 @@ package body Sem_Ch13 is -- Insert pragmas/attribute definition clause after this node when no -- delayed analysis is required. + -- Start of processing for Analyze_Aspect_Specifications + -- The general processing involves building an attribute definition -- clause or a pragma node that corresponds to the aspect. Then in order -- to delay the evaluation of this aspect to the freeze point, we attach @@ -944,11 +1025,11 @@ package body Sem_Ch13 is -- Some special cases don't require delay analysis, thus the aspect is -- analyzed right now. - -- Note that there is a special handling for - -- Pre/Post/Test_Case/Contract_Case aspects. In this case, we do not - -- have to worry about delay issues, since the pragmas themselves deal - -- with delay of visibility for the expression analysis. Thus, we just - -- insert the pragma after the node N. + -- Note that there is a special handling for Pre, Post, Test_Case, + -- Contract_Cases aspects. In these cases, we do not have to worry + -- about delay issues, since the pragmas themselves deal with delay + -- of visibility for the expression analysis. Thus, we just insert + -- the pragma after the node N. begin pragma Assert (Present (L)); @@ -957,7 +1038,7 @@ package body Sem_Ch13 is Aspect := First (L); Aspect_Loop : while Present (Aspect) loop - declare + Analyze_One_Aspect : declare Expr : constant Node_Id := Expression (Aspect); Id : constant Node_Id := Identifier (Aspect); Loc : constant Source_Ptr := Sloc (Aspect); @@ -973,12 +1054,22 @@ package body Sem_Ch13 is -- is set below when Expr is present. procedure Analyze_Aspect_External_Or_Link_Name; - -- This routine performs the analysis of the External_Name or - -- Link_Name aspects. + -- Perform analysis of the External_Name or Link_Name aspects procedure Analyze_Aspect_Implicit_Dereference; - -- This routine performs the analysis of the Implicit_Dereference - -- aspects. + -- Perform analysis of the Implicit_Dereference aspects + + procedure Make_Aitem_Pragma + (Pragma_Argument_Associations : List_Id; + Pragma_Name : Name_Id); + -- This is a wrapper for Make_Pragma used for converting aspects + -- to pragmas. It takes care of Sloc (set from Loc) and building + -- the pragma identifier from the given name. In addition the + -- flags Class_Present and Split_PPC are set from the aspect + -- node, as well as Is_Ignored. This routine also sets the + -- From_Aspect_Specification in the resulting pragma node to + -- True, and sets Corresponding_Aspect to point to the aspect. + -- The resulting pragma is assigned to Aitem. ------------------------------------------ -- Analyze_Aspect_External_Or_Link_Name -- @@ -997,14 +1088,14 @@ package body Sem_Ch13 is begin A := First (L); while Present (A) loop - exit when Chars (Identifier (A)) = Name_Export - or else Chars (Identifier (A)) = Name_Import; + exit when Nam_In (Chars (Identifier (A)), Name_Export, + Name_Import); Next (A); end loop; if No (A) then Error_Msg_N - ("Missing Import/Export for Link/External name", + ("missing Import/Export for Link/External name", Aspect); end if; end; @@ -1018,7 +1109,7 @@ package body Sem_Ch13 is begin if not Is_Type (E) or else not Has_Discriminants (E) then Error_Msg_N - ("Aspect must apply to a type with discriminants", N); + ("aspect must apply to a type with discriminants", N); else declare @@ -1047,6 +1138,42 @@ package body Sem_Ch13 is end if; end Analyze_Aspect_Implicit_Dereference; + ----------------------- + -- Make_Aitem_Pragma -- + ----------------------- + + procedure Make_Aitem_Pragma + (Pragma_Argument_Associations : List_Id; + Pragma_Name : Name_Id) + is + begin + -- We should never get here if aspect was disabled + + pragma Assert (not Is_Disabled (Aspect)); + + -- Build the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => + Pragma_Argument_Associations, + Pragma_Identifier => + Make_Identifier (Sloc (Id), Pragma_Name), + Class_Present => Class_Present (Aspect), + Split_PPC => Split_PPC (Aspect)); + + -- Set additional semantic fields + + if Is_Ignored (Aspect) then + Set_Is_Ignored (Aitem); + end if; + + Set_Corresponding_Aspect (Aitem, Aspect); + Set_From_Aspect_Specification (Aitem, True); + end Make_Aitem_Pragma; + + -- Start of processing for Analyze_One_Aspect + begin -- Skip aspect if already analyzed (not clear if this is needed) @@ -1054,6 +1181,16 @@ 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 flag appropriately. + + Check_Applicable_Policy (Aspect); + + if Is_Disabled (Aspect) then + goto Continue; + end if; + -- Set the source location of expression, used in the case of -- a failed precondition/postcondition or invariant. Note that -- the source location of the expression is not usually the best @@ -1068,7 +1205,7 @@ package body Sem_Ch13 is -- Check restriction No_Implementation_Aspect_Specifications - if Impl_Defined_Aspects (A_Id) then + if Implementation_Defined_Aspect (A_Id) then Check_Restriction (No_Implementation_Aspect_Specifications, Aspect); end if; @@ -1077,7 +1214,7 @@ package body Sem_Ch13 is Check_Restriction_No_Specification_Of_Aspect (Aspect); - -- Analyze this aspect + -- Analyze this aspect (actual analysis is delayed till later) Set_Analyzed (Aspect); Set_Entity (Aspect, E); @@ -1090,9 +1227,8 @@ package body Sem_Ch13 is if No_Duplicates_Allowed (A_Id) then Anod := First (L); while Anod /= Aspect loop - if Same_Aspect - (A_Id, Get_Aspect_Id (Chars (Identifier (Anod)))) - and then Comes_From_Source (Aspect) + if Comes_From_Source (Aspect) + and then Same_Aspect (A_Id, Get_Aspect_Id (Anod)) then Error_Msg_Name_1 := Nam; Error_Msg_Sloc := Sloc (Anod); @@ -1118,7 +1254,7 @@ package body Sem_Ch13 is -- Check some general restrictions on language defined aspects - if not Impl_Defined_Aspects (A_Id) then + if not Implementation_Defined_Aspect (A_Id) then Error_Msg_Name_1 := Nam; -- Not allowed for renaming declarations @@ -1199,46 +1335,49 @@ package body Sem_Ch13 is Chars => Chars (Id), Expression => Relocate_Node (Expr)); - -- Case 2: Aspects cooresponding to pragmas + -- If the address is specified, then we treat the entity as + -- referenced, to avoid spurious warnings. This is analogous + -- to what is done with an attribute definition clause, but + -- here we don't want to generate a reference because this + -- is the point of definition of the entity. + + if A_Id = Aspect_Address then + Set_Referenced (E); + end if; + + -- Case 2: Aspects corresponding to pragmas -- Case 2a: Aspects corresponding to pragmas with two -- arguments, where the first argument is a local name -- referring to the entity, and the second argument is the -- aspect definition expression. + -- Suppress/Unsuppress + when Aspect_Suppress | Aspect_Unsuppress => - -- Construct the pragma - - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => New_Occurrence_Of (E, Loc)), + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => New_Occurrence_Of (E, Loc)), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Chars (Id)); - Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr))), + -- Synchronization - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); + -- Corresponds to pragma Implemented, construct the pragma when Aspect_Synchronization => - -- The aspect corresponds to pragma Implemented. - -- Construct the pragma. - - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => New_Occurrence_Of (E, Loc)), - - Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr))), - - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Implemented)); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => New_Occurrence_Of (E, Loc)), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Implemented); -- No delay is required since the only values are: By_Entry -- | By_Protected_Procedure | By_Any | Optional which don't @@ -1246,45 +1385,60 @@ package body Sem_Ch13 is Delay_Required := False; + -- Attach Handler + when Aspect_Attach_Handler => - Aitem := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Attach_Handler), - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Sloc (Ent), - Expression => Ent), - Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr)))); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Attach_Handler); + + -- Dynamic_Predicate, Predicate, Static_Predicate when Aspect_Dynamic_Predicate | Aspect_Predicate | Aspect_Static_Predicate => -- Construct the pragma (always a pragma Predicate, with - -- flags recording whether it is static/dynamic). + -- flags recording whether it is static/dynamic). We also + -- set flags recording this in the type itself. - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Sloc (Ent), - Expression => Ent), - Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr))), - Class_Present => Class_Present (Aspect), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Predicate)); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Predicate); + + -- Mark type has predicates, and remember what kind of + -- aspect lead to this predicate (we need this to access + -- the right set of check policies later on). + + Set_Has_Predicates (E); + + if A_Id = Aspect_Dynamic_Predicate then + Set_Has_Dynamic_Predicate_Aspect (E); + elsif A_Id = Aspect_Static_Predicate then + Set_Has_Static_Predicate_Aspect (E); + end if; -- If the type is private, indicate that its completion -- has a freeze node, because that is the one that will be -- visible at freeze time. - Set_Has_Predicates (E); - - if Is_Private_Type (E) - and then Present (Full_View (E)) - then + if Is_Private_Type (E) and then Present (Full_View (E)) then Set_Has_Predicates (Full_View (E)); + + if A_Id = Aspect_Dynamic_Predicate then + Set_Has_Dynamic_Predicate_Aspect (Full_View (E)); + elsif A_Id = Aspect_Static_Predicate then + Set_Has_Static_Predicate_Aspect (Full_View (E)); + end if; + Set_Has_Delayed_Aspects (Full_View (E)); Ensure_Freeze_Node (Full_View (E)); end if; @@ -1294,6 +1448,8 @@ package body Sem_Ch13 is -- referring to the entity, and the first argument is the -- aspect definition expression. + -- Convention + when Aspect_Convention => -- The aspect may be part of the specification of an import @@ -1321,9 +1477,7 @@ package body Sem_Ch13 is while Present (A) loop A_Name := Chars (Identifier (A)); - if A_Name = Name_Import or else - A_Name = Name_Export - then + if Nam_In (A_Name, Name_Import, Name_Export) then if Found then Error_Msg_N ("conflicting", A); else @@ -1362,29 +1516,33 @@ package body Sem_Ch13 is Append_To (Arg_List, E_Assoc); end if; - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => Arg_List, - Pragma_Identifier => - Make_Identifier (Loc, P_Name)); + Make_Aitem_Pragma + (Pragma_Argument_Associations => Arg_List, + Pragma_Name => P_Name); + + -- Convention is a static name, and must be associated + -- with the entity at once. + + Delay_Required := False; end; - -- The following 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. + -- 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. when Aspect_CPU | Aspect_Interrupt_Priority | Aspect_Priority => + if Nkind (N) = N_Subprogram_Body then - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr))), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Chars (Id)); + else Aitem := Make_Attribute_Definition_Clause (Loc, @@ -1393,20 +1551,17 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr)); end if; - when Aspect_Warnings => + -- Warnings - -- Construct the pragma + when Aspect_Warnings => - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr)), - Make_Pragma_Argument_Association (Loc, - Expression => New_Occurrence_Of (E, Loc))), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id)), - Class_Present => Class_Present (Aspect)); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr)), + Make_Pragma_Argument_Association (Loc, + Expression => New_Occurrence_Of (E, Loc))), + Pragma_Name => Chars (Id)); -- We don't have to play the delay game here, since the only -- values are ON/OFF which don't get analyzed anyway. @@ -1420,6 +1575,8 @@ package body Sem_Ch13 is -- entity, a second argument that is the expression and a third -- argument that is an appropriate message. + -- Invariant, Type_Invariant + when Aspect_Invariant | Aspect_Type_Invariant => @@ -1427,18 +1584,13 @@ package body Sem_Ch13 is -- an invariant must apply to a private type, or appear in -- the private part of a spec and apply to a completion. - -- Construct the pragma - - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Sloc (Ent), - Expression => Ent), - Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr))), - Class_Present => Class_Present (Aspect), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Invariant)); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Invariant); -- Add message unless exception messages are suppressed @@ -1461,38 +1613,60 @@ package body Sem_Ch13 is -- Case 2d : Aspects that correspond to a pragma with one -- argument. - when Aspect_Abstract_State => - Aitem := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Abstract_State), - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Relocate_Node (Expr)))); + -- 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); Delay_Required := False; + -- Depends + + -- Aspect Depends must be delayed because it mentions names + -- of inputs and output that are classified by aspect Global. + -- The aspect and pragma are treated the same way as a post + -- condition. + + when Aspect_Depends => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Depends); + + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + Insert_Delayed_Pragma (Aitem); + goto Continue; + + -- Global + -- Aspect Global must be delayed because it can mention names -- and benefit from the forward visibility rules applicable to - -- aspects of subprograms. + -- aspects of subprograms. The aspect and pragma are treated + -- the same way as a post condition. when Aspect_Global => - Aitem := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Global), - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Relocate_Node (Expr)))); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Global); + + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + Insert_Delayed_Pragma (Aitem); + goto Continue; + + -- Relative_Deadline when Aspect_Relative_Deadline => - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Relocate_Node (Expr))), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Relative_Deadline)); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Relative_Deadline); -- If the aspect applies to a task, the corresponding pragma -- must appear within its declarations, not after. @@ -1529,6 +1703,8 @@ package body Sem_Ch13 is -- Case 3a: The aspects listed below don't correspond to -- pragmas/attributes but do require delayed analysis. + -- Default_Value, Default_Component_Value + when Aspect_Default_Value | Aspect_Default_Component_Value => Aitem := Empty; @@ -1536,6 +1712,8 @@ package body Sem_Ch13 is -- Case 3b: The aspects listed below don't correspond to -- pragmas/attributes and don't need delayed analysis. + -- Implicit_Dereference + -- For Implicit_Dereference, External_Name and Link_Name, only -- the legality checks are done during the analysis, thus no -- delay is required. @@ -1544,22 +1722,31 @@ package body Sem_Ch13 is Analyze_Aspect_Implicit_Dereference; goto Continue; + -- External_Name, Link_Name + when Aspect_External_Name | Aspect_Link_Name => Analyze_Aspect_External_Or_Link_Name; goto Continue; + -- Dimension + when Aspect_Dimension => Analyze_Aspect_Dimension (N, Id, Expr); goto Continue; + -- Dimension_System + when Aspect_Dimension_System => Analyze_Aspect_Dimension_System (N, Id, Expr); goto Continue; -- Case 4: Special handling for aspects - -- Pre/Post/Test_Case/Contract_Case whose corresponding pragmas - -- take care of the delay. + + -- Pre/Post/Test_Case/Contract_Cases whose corresponding + -- pragmas take care of the delay. + + -- Pre/Post -- Aspects Pre/Post generate Precondition/Postcondition pragmas -- with a first argument that is the expression, and a second @@ -1568,7 +1755,7 @@ package body Sem_Ch13 is -- required pragma placement. The processing for the pragmas -- takes care of the required delay. - when Pre_Post_Aspects => declare + when Pre_Post_Aspects => Pre_Post : declare Pname : Name_Id; begin @@ -1614,16 +1801,12 @@ package body Sem_Ch13 is -- Build the precondition/postcondition pragma - Aitem := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Sloc (Id), Pname), - Class_Present => Class_Present (Aspect), - Split_PPC => Split_PPC (Aspect), - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Eloc, - Chars => Name_Check, - Expression => Relocate_Node (Expr)))); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Eloc, + Chars => Name_Check, + Expression => Relocate_Node (Expr))), + Pragma_Name => Pname); -- Add message unless exception messages are suppressed @@ -1639,8 +1822,6 @@ package body Sem_Ch13 is & Build_Location_String (Eloc)))); end if; - Set_From_Aspect_Specification (Aitem, True); - Set_Corresponding_Aspect (Aitem, Aspect); Set_Is_Delayed_Aspect (Aspect); -- For Pre/Post cases, insert immediately after the entity @@ -1649,120 +1830,21 @@ package body Sem_Ch13 is -- about delay issues, since the pragmas themselves deal -- with delay of visibility for the expression analysis. - -- If the entity is a library-level subprogram, the pre/ - -- postconditions must be treated as late pragmas. Note - -- that they must be prepended, not appended, to the list, - -- so that split AND THEN sections are processed in the - -- correct order. - - if Nkind (Parent (N)) = N_Compilation_Unit then - declare - Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); - - begin - if No (Pragmas_After (Aux)) then - Set_Pragmas_After (Aux, New_List); - end if; - - Prepend (Aitem, Pragmas_After (Aux)); - end; - - -- If it is a subprogram body, add pragmas to list of - -- declarations in body. - - elsif Nkind (N) = N_Subprogram_Body then - if No (Declarations (N)) then - Set_Declarations (N, New_List); - end if; - - Append (Aitem, Declarations (N)); - - else - Insert_After (N, Aitem); - end if; - + Insert_Delayed_Pragma (Aitem); goto Continue; - end; - - when Aspect_Contract_Case | - Aspect_Test_Case => + end Pre_Post; - declare - Args : List_Id; - Comp_Expr : Node_Id; - Comp_Assn : Node_Id; - New_Expr : Node_Id; + -- Test_Case - begin - Args := New_List; - - if Nkind (Parent (N)) = N_Compilation_Unit then - Error_Msg_Name_1 := Nam; - Error_Msg_N ("incorrect placement of aspect `%`", E); - goto Continue; - end if; - - if Nkind (Expr) /= N_Aggregate then - Error_Msg_Name_1 := Nam; - Error_Msg_NE - ("wrong syntax for aspect `%` for &", Id, E); - goto Continue; - end if; - - -- Make pragma expressions refer to the original aspect - -- expressions through the Original_Node link. This is - -- used in semantic analysis for ASIS mode, so that the - -- original expression also gets analyzed. - - Comp_Expr := First (Expressions (Expr)); - while Present (Comp_Expr) loop - New_Expr := Relocate_Node (Comp_Expr); - Set_Original_Node (New_Expr, Comp_Expr); - Append_To (Args, - Make_Pragma_Argument_Association (Sloc (Comp_Expr), - Expression => New_Expr)); - Next (Comp_Expr); - end loop; - - Comp_Assn := First (Component_Associations (Expr)); - while Present (Comp_Assn) loop - if List_Length (Choices (Comp_Assn)) /= 1 - or else - Nkind (First (Choices (Comp_Assn))) /= N_Identifier - then - Error_Msg_Name_1 := Nam; - Error_Msg_NE - ("wrong syntax for aspect `%` for &", Id, E); - goto Continue; - end if; - - New_Expr := Relocate_Node (Expression (Comp_Assn)); - Set_Original_Node (New_Expr, Expression (Comp_Assn)); - Append_To (Args, - Make_Pragma_Argument_Association (Sloc (Comp_Assn), - Chars => Chars (First (Choices (Comp_Assn))), - Expression => New_Expr)); - Next (Comp_Assn); - end loop; - - -- Build the contract-case or test-case pragma - - Aitem := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Sloc (Id), Nam), - Pragma_Argument_Associations => Args); - - Delay_Required := False; - end; - - when Aspect_Contract_Cases => Contract_Cases : declare - Case_Guard : Node_Id; - Extra : Node_Id; - Others_Seen : Boolean := False; - Post_Case : Node_Id; + when Aspect_Test_Case => Test_Case : declare + Args : List_Id; + Comp_Expr : Node_Id; + Comp_Assn : Node_Id; + New_Expr : Node_Id; begin + Args := New_List; + if Nkind (Parent (N)) = N_Compilation_Unit then Error_Msg_Name_1 := Nam; Error_Msg_N ("incorrect placement of aspect `%`", E); @@ -1776,68 +1858,70 @@ package body Sem_Ch13 is goto Continue; end if; - -- Verify the legality of individual post cases - - Post_Case := First (Component_Associations (Expr)); - while Present (Post_Case) loop - if Nkind (Post_Case) /= N_Component_Association then - Error_Msg_N ("wrong syntax in post case", Post_Case); - goto Continue; - end if; - - -- Each post case must have exactly one case guard - - Case_Guard := First (Choices (Post_Case)); - Extra := Next (Case_Guard); - - if Present (Extra) then - Error_Msg_N - ("post case may have only one case guard", Extra); - goto Continue; - end if; - - -- Check the placement of "others" (if available) - - if Nkind (Case_Guard) = N_Others_Choice then - if Others_Seen then - Error_Msg_Name_1 := Nam; - Error_Msg_N - ("only one others choice allowed in aspect %", - Case_Guard); - goto Continue; - else - Others_Seen := True; - end if; + -- Make pragma expressions refer to the original aspect + -- expressions through the Original_Node link. This is + -- used in semantic analysis for ASIS mode, so that the + -- original expression also gets analyzed. + + Comp_Expr := First (Expressions (Expr)); + while Present (Comp_Expr) loop + New_Expr := Relocate_Node (Comp_Expr); + Set_Original_Node (New_Expr, Comp_Expr); + Append_To (Args, + Make_Pragma_Argument_Association (Sloc (Comp_Expr), + Expression => New_Expr)); + Next (Comp_Expr); + end loop; - elsif Others_Seen then + Comp_Assn := First (Component_Associations (Expr)); + while Present (Comp_Assn) loop + if List_Length (Choices (Comp_Assn)) /= 1 + or else + Nkind (First (Choices (Comp_Assn))) /= N_Identifier + then Error_Msg_Name_1 := Nam; - Error_Msg_N - ("others must be the last choice in aspect %", N); + Error_Msg_NE + ("wrong syntax for aspect `%` for &", Id, E); goto Continue; end if; - Next (Post_Case); + New_Expr := Relocate_Node (Expression (Comp_Assn)); + Set_Original_Node (New_Expr, Expression (Comp_Assn)); + Append_To (Args, + Make_Pragma_Argument_Association (Sloc (Comp_Assn), + Chars => Chars (First (Choices (Comp_Assn))), + Expression => New_Expr)); + Next (Comp_Assn); end loop; - -- Transform the aspect into a pragma + -- Build the test-case pragma - Aitem := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Loc, Nam), - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Relocate_Node (Expr)))); + Make_Aitem_Pragma + (Pragma_Argument_Associations => Args, + Pragma_Name => Nam); Delay_Required := False; - end Contract_Cases; + end Test_Case; + + -- Contract_Cases + + when Aspect_Contract_Cases => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Nam); + + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + Insert_Delayed_Pragma (Aitem); + goto Continue; -- Case 5: Special handling for aspects with an optional -- boolean argument. -- In the general case, the corresponding pragma cannot be - -- generated yet because the evaluation of the boolean needs to - -- be delayed til the freeze point. + -- generated yet because the evaluation of the boolean needs + -- to be delayed till the freeze point. when Boolean_Aspects | Library_Unit_Aspects => @@ -1902,7 +1986,9 @@ package body Sem_Ch13 is -- issue of visibility delay for these aspects. if A_Id in Library_Unit_Aspects - and then Nkind (N) = N_Package_Declaration + and then + Nkind_In (N, N_Package_Declaration, + N_Generic_Package_Declaration) and then Nkind (Parent (N)) /= N_Compilation_Unit then Error_Msg_N @@ -1915,13 +2001,11 @@ package body Sem_Ch13 is -- simply insert the pragma, no delay is required. if No (Expr) then - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Sloc (Ent), - Expression => Ent)), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent)), + Pragma_Name => Chars (Id)); Delay_Required := False; @@ -1939,18 +2023,31 @@ package body Sem_Ch13 is if Present (Aitem) then Set_From_Aspect_Specification (Aitem, True); + end if; - if Nkind (Aitem) = N_Pragma then - Set_Corresponding_Aspect (Aitem, Aspect); + -- 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; - 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 subprogram body (see below). + -- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux + -- node (no delay is required here) except for aspects on a + -- subprogram body (see below) and a generic package, for which + -- we need to introduce the pragma before building the generic + -- copy (see sem_ch12). - if Nkind (Parent (N)) = N_Compilation_Unit + elsif Nkind (Parent (N)) = N_Compilation_Unit and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect)) then declare @@ -1964,13 +2061,11 @@ package body Sem_Ch13 is if Is_Boolean_Aspect (Aspect) and then No (Aitem) then if Is_True (Static_Boolean (Expr)) then - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Sloc (Ent), - Expression => Ent)), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent)), + Pragma_Name => Chars (Id)); Set_From_Aspect_Specification (Aitem, True); Set_Corresponding_Aspect (Aitem, Aspect); @@ -1991,19 +2086,13 @@ package body Sem_Ch13 is Prepend (Aitem, Declarations (N)); - -- Aspect Abstract_State produces 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. - - elsif Nam = Name_Abstract_State - and then Nkind (N) = N_Package_Declaration - then + elsif Nkind (N) = N_Generic_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))); + Prepend (Aitem, + Visible_Declarations (Specification (N))); else if No (Pragmas_After (Aux)) then @@ -2031,12 +2120,17 @@ package body Sem_Ch13 is Set_Is_Delayed_Aspect (Aspect); - -- In the case of Default_Value, link aspect to base type - -- as well, even though it appears on a first subtype. This - -- is mandated by the semantics of the aspect. Verify that - -- this a scalar type, to prevent cascaded errors. + -- In the case of Default_Value, link the aspect to base type + -- as well, even though it appears on a first subtype. This is + -- mandated by the semantics of the aspect. Do not establish + -- the link when processing the base type itself as this leads + -- to a rep item circularity. Verify that we are dealing with + -- a scalar type to prevent cascaded errors. - if A_Id = Aspect_Default_Value and then Is_Scalar_Type (E) then + if A_Id = Aspect_Default_Value + and then Is_Scalar_Type (E) + and then Base_Type (E) /= E + then Set_Has_Delayed_Aspects (Base_Type (E)); Record_Rep_Item (Base_Type (E), Aspect); end if; @@ -2052,7 +2146,7 @@ package body Sem_Ch13 is Insert_After (Ins_Node, Aitem); Ins_Node := Aitem; end if; - end; + end Analyze_One_Aspect; <<Continue>> Next (Aspect); @@ -2309,7 +2403,7 @@ package body Sem_Ch13 is procedure Check_One_Function (Subp : Entity_Id) is Default_Element : constant Node_Id := - Find_Aspect + Find_Value_Of_Aspect (Etype (First_Formal (Subp)), Aspect_Iterator_Element); @@ -2741,6 +2835,7 @@ package body Sem_Ch13 is end if; Set_Entity (N, U_Ent); + Check_Restriction_No_Use_Of_Attribute (N); -- Switch on particular attribute @@ -4251,6 +4346,14 @@ package body Sem_Ch13 is return; end if; + -- Ignore enumeration rep clauses by default in CodePeer mode, + -- unless -gnatd.I is specified, as a work around for potential false + -- positive messages. + + if CodePeer_Mode and not Debug_Flag_Dot_II then + return; + end if; + -- First some basic error checks Find_Type (Ident); @@ -4689,12 +4792,12 @@ package body Sem_Ch13 is -- If we have a type with predicates, build predicate function if Is_Type (E) and then Has_Predicates (E) then - Build_Predicate_Function (E, N); + 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_Function or + -- 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. @@ -5225,9 +5328,9 @@ package body Sem_Ch13 is SId := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Typ), "Invariant")); - Set_Has_Invariants (SId); Set_Has_Invariants (Typ); Set_Ekind (SId, E_Procedure); + Set_Is_Invariant_Procedure (SId); Set_Invariant_Procedure (Typ, SId); Spec := @@ -5597,11 +5700,11 @@ package body Sem_Ch13 is end if; end Build_Invariant_Procedure; - ------------------------------ - -- Build_Predicate_Function -- - ------------------------------ + ------------------------------- + -- Build_Predicate_Functions -- + ------------------------------- - -- The procedure that is constructed here has the form: + -- The procedures that are constructed here have the form: -- function typPredicate (Ixxx : typ) return Boolean is -- begin @@ -5618,17 +5721,41 @@ package body Sem_Ch13 is -- inherited. Note that we do NOT generate Check pragmas, that's because we -- use this function even if checks are off, e.g. for membership tests. - procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is - Loc : constant Source_Ptr := Sloc (Typ); - Spec : Node_Id; - SId : Entity_Id; - FDecl : Node_Id; - FBody : Node_Id; + -- If the expression has at least one Raise_Expression, then we also build + -- the typPredicateM version of the function, in which any occurrence of a + -- Raise_Expression is converted to "return False". + + procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Expr : Node_Id; - -- This is the expression for the return statement in the function. It + -- This is the expression for the result of the function. It is -- is build by connecting the component predicates with AND THEN. + Expr_M : Node_Id; + -- This is the corresponding return expression for the Predicate_M + -- function. It differs in that raise expressions are marked for + -- special expansion (see Process_REs). + + Object_Name : constant Name_Id := New_Internal_Name ('I'); + -- Name for argument of Predicate procedure. Note that we use the same + -- name for both predicate procedure. That way the reference within the + -- predicate expression is the same in both functions. + + Object_Entity : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => Object_Name); + -- Entity for argument of Predicate procedure + + Object_Entity_M : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => Object_Name); + -- Entity for argument of Predicate_M procedure + + Raise_Expression_Present : Boolean := False; + -- Set True if Expr has at least one Raise_Expression + + Static_Predic : Node_Id := Empty; + -- Set to N_Pragma node for a static predicate if one is encountered + procedure Add_Call (T : Entity_Id); -- Includes a call to the predicate function for type T in Expr if T -- has predicates and Predicate_Function (T) is non-empty. @@ -5639,19 +5766,19 @@ package body Sem_Ch13 is -- Inheritance of predicates for the parent type is done by calling the -- Predicate_Function of the parent type, using Add_Call above. - Object_Name : constant Name_Id := New_Internal_Name ('I'); - -- Name for argument of Predicate procedure + function Test_RE (N : Node_Id) return Traverse_Result; + -- Used in Test_REs, tests one node for being a raise expression, and if + -- so sets Raise_Expression_Present True. - Object_Entity : constant Entity_Id := - Make_Defining_Identifier (Loc, Object_Name); - -- The entity for the spec entity for the argument + procedure Test_REs is new Traverse_Proc (Test_RE); + -- Tests to see if Expr contains any raise expressions - Dynamic_Predicate_Present : Boolean := False; - -- Set True if a dynamic predicate is present, results in the entire - -- predicate being considered dynamic even if it looks static + function Process_RE (N : Node_Id) return Traverse_Result; + -- Used in Process REs, tests if node N is a raise expression, and if + -- so, marks it to be converted to return False. - Static_Predicate_Present : Node_Id := Empty; - -- Set to N_Pragma node for a static predicate if one is encountered. + procedure Process_REs is new Traverse_Proc (Process_RE); + -- Marks any raise expressions in Expr_M to return False -------------- -- Add_Call -- @@ -5730,8 +5857,8 @@ package body Sem_Ch13 is Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); -- Use the Sloc of the usage name, not the defining name - Set_Entity (N, Object_Entity); Set_Etype (N, Typ); + Set_Entity (N, Object_Entity); -- We want to treat the node as if it comes from source, so that -- ASIS will not ignore it @@ -5747,15 +5874,14 @@ package body Sem_Ch13 is if Nkind (Ritem) = N_Pragma and then Pragma_Name (Ritem) = Name_Predicate then - if Present (Corresponding_Aspect (Ritem)) then - case Chars (Identifier (Corresponding_Aspect (Ritem))) is - when Name_Dynamic_Predicate => - Dynamic_Predicate_Present := True; - when Name_Static_Predicate => - Static_Predicate_Present := Ritem; - when others => - null; - end case; + -- Save the static predicate of the type for diagnostics and + -- error reporting purposes. + + if Present (Corresponding_Aspect (Ritem)) + and then Chars (Identifier (Corresponding_Aspect (Ritem))) = + Name_Static_Predicate + then + Static_Predic := Ritem; end if; -- Acquire arguments @@ -5830,13 +5956,37 @@ package body Sem_Ch13 is end loop; end Add_Predicates; - -- Start of processing for Build_Predicate_Function + ---------------- + -- Process_RE -- + ---------------- - begin - -- Initialize for construction of statement list + function Process_RE (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Raise_Expression then + Set_Convert_To_Return_False (N); + return Skip; + else + return OK; + end if; + end Process_RE; - Expr := Empty; + ------------- + -- Test_RE -- + ------------- + + function Test_RE (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Raise_Expression then + Raise_Expression_Present := True; + return Abandon; + else + return OK; + end if; + end Test_RE; + -- Start of processing for Build_Predicate_Functions + + begin -- Return if already built or if type does not have predicates if not Has_Predicates (Typ) @@ -5845,6 +5995,10 @@ package body Sem_Ch13 is return; end if; + -- Prepare to construct predicate expression + + Expr := Empty; + -- Add Predicates for the current type Add_Predicates; @@ -5859,92 +6013,248 @@ package body Sem_Ch13 is end if; end; - -- If we have predicates, build the function + -- Case where predicates are present if Present (Expr) then - -- Build function declaration + -- Test for raise expression present - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); - Set_Has_Predicates (SId); - Set_Ekind (SId, E_Function); - Set_Predicate_Function (Typ, SId); + Test_REs (Expr); - -- The predicate function is shared between views of a type. + -- If raise expression is present, capture a copy of Expr for use + -- in building the predicateM function version later on. For this + -- copy we replace references to Object_Entity by Object_Entity_M. - if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - Set_Predicate_Function (Full_View (Typ), SId); + if Raise_Expression_Present then + declare + Map : constant Elist_Id := New_Elmt_List; + begin + Append_Elmt (Object_Entity, Map); + Append_Elmt (Object_Entity_M, Map); + Expr_M := New_Copy_Tree (Expr, Map => Map); + end; end if; - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Object_Entity, - Parameter_Type => New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); - - FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec); - - -- Build function body - - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); - - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Object_Name), - Parameter_Type => - New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); - - FBody := - Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => Expr)))); + -- Build the main predicate function - -- Insert declaration before freeze node and body after + declare + SId : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + -- The entity for the the function spec - Insert_Before_And_Analyze (N, FDecl); - Insert_After_And_Analyze (N, FBody); + SIdB : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + -- The entity for the function body - -- Deal with static predicate case + Spec : Node_Id; + FDecl : Node_Id; + FBody : Node_Id; - if Ekind_In (Typ, E_Enumeration_Subtype, - E_Modular_Integer_Subtype, - E_Signed_Integer_Subtype) - and then Is_Static_Subtype (Typ) - and then not Dynamic_Predicate_Present - then - Build_Static_Predicate (Typ, Expr, Object_Name); + begin + -- Build function declaration + + Set_Ekind (SId, E_Function); + Set_Is_Predicate_Function (SId); + Set_Predicate_Function (Typ, SId); + + -- The predicate function is shared between views of a type + + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Set_Predicate_Function (Full_View (Typ), SId); + end if; + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FDecl := + Make_Subprogram_Declaration (Loc, + Specification => Spec); + + -- Build function body + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SIdB, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Expr)))); + + -- Insert declaration before freeze node and body after + + Insert_Before_And_Analyze (N, FDecl); + Insert_After_And_Analyze (N, FBody); + end; + + -- Test for raise expressions present and if so build M version + + if Raise_Expression_Present then + declare + SId : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "PredicateM")); + -- The entity for the the function spec + + SIdB : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "PredicateM")); + -- The entity for the function body + + Spec : Node_Id; + FDecl : Node_Id; + FBody : Node_Id; + BTemp : Entity_Id; + + begin + -- Mark any raise expressions for special expansion + + Process_REs (Expr_M); + + -- Build function declaration + + Set_Ekind (SId, E_Function); + Set_Is_Predicate_Function_M (SId); + Set_Predicate_Function_M (Typ, SId); + + -- The predicate function is shared between views of a type + + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Set_Predicate_Function_M (Full_View (Typ), SId); + end if; + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity_M, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FDecl := + Make_Subprogram_Declaration (Loc, + Specification => Spec); + + -- Build function body + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SIdB, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + -- Build the body, we declare the boolean expression before + -- doing the return, because we are not really confident of + -- what happens if a return appears within a return! + + BTemp := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('B')); + + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => BTemp, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => Expr_M)), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (BTemp, Loc))))); + + -- Insert declaration before freeze node and body after + + Insert_Before_And_Analyze (N, FDecl); + Insert_After_And_Analyze (N, FBody); + end; + end if; + + if Is_Scalar_Type (Typ) then + + -- Attempt to build a static predicate for a discrete or a real + -- subtype. This action may fail because the actual expression may + -- not be static. Note that the presence of an inherited or + -- explicitly declared dynamic predicate is orthogonal to this + -- check because we are only interested in the static predicate. - if Present (Static_Predicate_Present) - and No (Static_Predicate (Typ)) + if Ekind_In (Typ, E_Decimal_Fixed_Point_Subtype, + E_Enumeration_Subtype, + E_Floating_Point_Subtype, + E_Modular_Integer_Subtype, + E_Ordinary_Fixed_Point_Subtype, + E_Signed_Integer_Subtype) then - Error_Msg_F - ("expression does not have required form for " - & "static predicate", - Next (First (Pragma_Argument_Associations - (Static_Predicate_Present)))); + Build_Static_Predicate (Typ, Expr, Object_Name); + + -- Emit an error when the predicate is categorized as static + -- but its expression is dynamic. + + if Present (Static_Predic) + and then No (Static_Predicate (Typ)) + then + Error_Msg_F + ("expression does not have required form for " + & "static predicate", + Next (First (Pragma_Argument_Associations + (Static_Predic)))); + end if; + end if; + + -- If a static predicate applies on other types, that's an error: + -- either the type is scalar but non-static, or it's not even a + -- scalar type. We do not issue an error on generated types, as + -- these may be duplicates of the same error on a source type. + + elsif Present (Static_Predic) and then Comes_From_Source (Typ) then + if Is_Scalar_Type (Typ) then + Error_Msg_FE + ("static predicate not allowed for non-static type&", + Typ, Typ); + else + Error_Msg_FE + ("static predicate not allowed for non-scalar type&", + Typ, Typ); end if; end if; end if; - end Build_Predicate_Function; + end Build_Predicate_Functions; ---------------------------- -- Build_Static_Predicate -- @@ -5973,15 +6283,15 @@ package body Sem_Ch13 is type REnt is record Lo, Hi : Uint; end record; - -- One entry in a Rlist value, a single REnt (range entry) value - -- denotes one range from Lo to Hi. To represent a single value - -- range Lo = Hi = value. + -- One entry in a Rlist value, a single REnt (range entry) value denotes + -- one range from Lo to Hi. To represent a single value range Lo = Hi = + -- value. type RList is array (Nat range <>) of REnt; - -- A list of ranges. The ranges are sorted in increasing order, - -- and are disjoint (there is a gap of at least one value between - -- each range in the table). A value is in the set of ranges in - -- Rlist if it lies within one of these ranges + -- A list of ranges. The ranges are sorted in increasing order, and are + -- disjoint (there is a gap of at least one value between each range in + -- the table). A value is in the set of ranges in Rlist if it lies + -- within one of these ranges. False_Range : constant RList := RList'(1 .. 0 => REnt'(No_Uint, No_Uint)); @@ -5995,41 +6305,41 @@ package body Sem_Ch13 is True_Range : constant RList := RList'(1 => REnt'(BLo, BHi)); -- Range representing True, value must be in the base range - function "and" (Left, Right : RList) return RList; - -- And's together two range lists, returning a range list. This is - -- a set intersection operation. + function "and" (Left : RList; Right : RList) return RList; + -- And's together two range lists, returning a range list. This is a set + -- intersection operation. - function "or" (Left, Right : RList) return RList; - -- Or's together two range lists, returning a range list. This is a - -- set union operation. + function "or" (Left : RList; Right : RList) return RList; + -- Or's together two range lists, returning a range list. This is a set + -- union operation. function "not" (Right : RList) return RList; -- Returns complement of a given range list, i.e. a range list - -- representing all the values in TLo .. THi that are not in the - -- input operand Right. + -- representing all the values in TLo .. THi that are not in the input + -- operand Right. function Build_Val (V : Uint) return Node_Id; -- Return an analyzed N_Identifier node referencing this value, suitable -- for use as an entry in the Static_Predicate list. This node is typed -- with the base type. - function Build_Range (Lo, Hi : Uint) return Node_Id; - -- Return an analyzed N_Range node referencing this range, suitable - -- for use as an entry in the Static_Predicate list. This node is typed - -- with the base type. + function Build_Range (Lo : Uint; Hi : Uint) return Node_Id; + -- Return an analyzed N_Range node referencing this range, suitable for + -- use as an entry in the Static_Predicate list. This node is typed with + -- the base type. function Get_RList (Exp : Node_Id) return RList; - -- This is a recursive routine that converts the given expression into - -- a list of ranges, suitable for use in building the static predicate. + -- This is a recursive routine that converts the given expression into a + -- list of ranges, suitable for use in building the static predicate. function Is_False (R : RList) return Boolean; pragma Inline (Is_False); - -- Returns True if the given range list is empty, and thus represents - -- a False list of ranges that can never be satisfied. + -- Returns True if the given range list is empty, and thus represents a + -- False list of ranges that can never be satisfied. function Is_True (R : RList) return Boolean; - -- Returns True if R trivially represents the True predicate by having - -- a single range from BLo to BHi. + -- Returns True if R trivially represents the True predicate by having a + -- single range from BLo to BHi. function Is_Type_Ref (N : Node_Id) return Boolean; pragma Inline (Is_Type_Ref); @@ -6062,7 +6372,7 @@ package body Sem_Ch13 is -- "and" -- ----------- - function "and" (Left, Right : RList) return RList is + function "and" (Left : RList; Right : RList) return RList is FEnt : REnt; -- First range of result @@ -6087,8 +6397,8 @@ package body Sem_Ch13 is return False_Range; end if; - -- Loop to remove entries at start that are disjoint, and thus - -- just get discarded from the result entirely. + -- Loop to remove entries at start that are disjoint, and thus just + -- get discarded from the result entirely. loop -- If no operands left in either operand, result is false @@ -6113,15 +6423,15 @@ package body Sem_Ch13 is end if; end loop; - -- Now we have two non-null operands, and first entries overlap. - -- The first entry in the result will be the overlapping part of - -- these two entries. + -- Now we have two non-null operands, and first entries overlap. The + -- first entry in the result will be the overlapping part of these + -- two entries. FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); - -- Now we can remove the entry that ended at a lower value, since - -- its contribution is entirely contained in Fent. + -- Now we can remove the entry that ended at a lower value, since its + -- contribution is entirely contained in Fent. if Left (SLeft).Hi <= Right (SRight).Hi then SLeft := SLeft + 1; @@ -6129,10 +6439,10 @@ package body Sem_Ch13 is SRight := SRight + 1; end if; - -- Compute result by concatenating this first entry with the "and" - -- of the remaining parts of the left and right operands. Note that - -- if either of these is empty, "and" will yield empty, so that we - -- will end up with just Fent, which is what we want in that case. + -- Compute result by concatenating this first entry with the "and" of + -- the remaining parts of the left and right operands. Note that if + -- either of these is empty, "and" will yield empty, so that we will + -- end up with just Fent, which is what we want in that case. return FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); @@ -6196,7 +6506,7 @@ package body Sem_Ch13 is -- "or" -- ---------- - function "or" (Left, Right : RList) return RList is + function "or" (Left : RList; Right : RList) return RList is FEnt : REnt; -- First range of result @@ -6221,8 +6531,8 @@ package body Sem_Ch13 is return Left; end if; - -- Initialize result first entry from left or right operand - -- depending on which starts with the lower range. + -- Initialize result first entry from left or right operand depending + -- on which starts with the lower range. if Left (SLeft).Lo < Right (SRight).Lo then FEnt := Left (SLeft); @@ -6232,12 +6542,12 @@ package body Sem_Ch13 is SRight := SRight + 1; end if; - -- This loop eats ranges from left and right operands that - -- are contiguous with the first range we are gathering. + -- This loop eats ranges from left and right operands that are + -- contiguous with the first range we are gathering. loop - -- Eat first entry in left operand if contiguous or - -- overlapped by gathered first operand of result. + -- Eat first entry in left operand if contiguous or overlapped by + -- gathered first operand of result. if SLeft <= Left'Last and then Left (SLeft).Lo <= FEnt.Hi + 1 @@ -6245,8 +6555,8 @@ package body Sem_Ch13 is FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); SLeft := SLeft + 1; - -- Eat first entry in right operand if contiguous or - -- overlapped by gathered right operand of result. + -- Eat first entry in right operand if contiguous or overlapped by + -- gathered right operand of result. elsif SRight <= Right'Last and then Right (SRight).Lo <= FEnt.Hi + 1 @@ -6254,7 +6564,7 @@ package body Sem_Ch13 is FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); SRight := SRight + 1; - -- All done if no more entries to eat! + -- All done if no more entries to eat else exit; @@ -6273,20 +6583,18 @@ package body Sem_Ch13 is -- Build_Range -- ----------------- - function Build_Range (Lo, Hi : Uint) return Node_Id is + function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is Result : Node_Id; + begin - if Lo = Hi then - return Build_Val (Hi); - else - Result := - Make_Range (Loc, - Low_Bound => Build_Val (Lo), - High_Bound => Build_Val (Hi)); - Set_Etype (Result, Btyp); - Set_Analyzed (Result); - return Result; - end if; + Result := + Make_Range (Loc, + Low_Bound => Build_Val (Lo), + High_Bound => Build_Val (Hi)); + Set_Etype (Result, Btyp); + Set_Analyzed (Result); + + return Result; end Build_Range; --------------- @@ -6449,7 +6757,10 @@ package body Sem_Ch13 is declare Ent : constant Entity_Id := Entity (Name (Exp)); begin - if Has_Predicates (Ent) then + if Is_Predicate_Function (Ent) + or else + Is_Predicate_Function_M (Ent) + then return Stat_Pred (Etype (First_Formal (Ent))); end if; end; @@ -6693,11 +7004,7 @@ package body Sem_Ch13 is -- Convert range into required form - if Lo = Hi then - Append_To (Plist, Build_Val (Lo)); - else - Append_To (Plist, Build_Range (Lo, Hi)); - end if; + Append_To (Plist, Build_Range (Lo, Hi)); end if; end; end loop; @@ -6977,6 +7284,14 @@ package body Sem_Ch13 is when Aspect_Default_Value => T := Entity (ASN); + -- Depends is a delayed aspect because it mentiones names first + -- introduced by aspect Global which is already delayed. There is + -- no action to be taken with respect to the aspect itself as the + -- analysis is done by the corresponding pragma. + + when Aspect_Depends => + return; + when Aspect_Dispatching_Domain => T := RTE (RE_Dispatching_Domain); @@ -6988,8 +7303,8 @@ package body Sem_Ch13 is -- Global is a delayed aspect because it may reference names that -- have not been declared yet. There is no action to be taken with - -- respect to the aspect itself as the reference checking is done on - -- the corresponding pragma. + -- respect to the aspect itself as the reference checking is done + -- on the corresponding pragma. when Aspect_Global => return; @@ -7064,7 +7379,6 @@ package body Sem_Ch13 is -- Here is the list of aspects that don't require delay analysis when Aspect_Abstract_State | - Aspect_Contract_Case | Aspect_Contract_Cases | Aspect_Dimension | Aspect_Dimension_System | @@ -7318,13 +7632,10 @@ package body Sem_Ch13 is Check_Expr_Constants (Prefix (Nod)); when N_Attribute_Reference => - if Attribute_Name (Nod) = Name_Address - or else - Attribute_Name (Nod) = Name_Access - or else - Attribute_Name (Nod) = Name_Unchecked_Access - or else - Attribute_Name (Nod) = Name_Unrestricted_Access + if Nam_In (Attribute_Name (Nod), Name_Address, + Name_Access, + Name_Unchecked_Access, + Name_Unrestricted_Access) then Check_At_Constant_Address (Prefix (Nod)); @@ -7489,10 +7800,7 @@ package body Sem_Ch13 is -- record, both at location zero. This seems a bit strange, but -- it seems to happen in some circumstances, perhaps on an error. - if Chars (C1_Ent) = Name_uTag - and then - Chars (C2_Ent) = Name_uTag - then + if Nam_In (Chars (C1_Ent), Name_uTag, Name_uTag) then return; end if; @@ -9002,7 +9310,13 @@ package body Sem_Ch13 is procedure Too_Late is begin - Error_Msg_N ("|representation item appears too late!", N); + -- Other compilers seem more relaxed about rep items appearing too + -- late. Since analysis tools typically don't care about rep items + -- anyway, no reason to be too strict about this. + + if not Relaxed_RM_Semantics then + Error_Msg_N ("|representation item appears too late!", N); + end if; end Too_Late; -- Start of processing for Rep_Item_Too_Late @@ -9017,7 +9331,7 @@ package body Sem_Ch13 is and then not From_With_Type (T) - -- Exclude generated entitiesa (not coming from source). The common + -- Exclude generated entities (not coming from source). The common -- case is when we generate a renaming which prematurely freezes the -- renamed internal entity, but we still want to be able to set copies -- of attribute values such as Size/Alignment. @@ -9066,11 +9380,8 @@ package body Sem_Ch13 is declare Pname : constant Name_Id := Pragma_Name (N); begin - if Pname = Name_Convention or else - Pname = Name_Import or else - Pname = Name_Export or else - Pname = Name_External or else - Pname = Name_Interface + if Nam_In (Pname, Name_Convention, Name_Import, Name_Export, + Name_External, Name_Interface) then return False; end if; @@ -9223,12 +9534,16 @@ package body Sem_Ch13 is return False; end if; - -- Representations are different if component alignments differ + -- Representations are different if component alignments or scalar + -- storage orders differ. if (Is_Record_Type (T1) or else Is_Array_Type (T1)) - and then + and then (Is_Record_Type (T2) or else Is_Array_Type (T2)) - and then Component_Alignment (T1) /= Component_Alignment (T2) + and then + (Component_Alignment (T1) /= Component_Alignment (T2) + or else + Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) then return False; end if; @@ -9305,7 +9620,7 @@ package body Sem_Ch13 is function Same_Rep return Boolean; -- CD1 and CD2 are either components or discriminants. This - -- function tests whether the two have the same representation + -- function tests whether they have the same representation. -------------- -- Same_Rep -- @@ -9315,8 +9630,11 @@ package body Sem_Ch13 is begin if No (Component_Clause (CD1)) then return No (Component_Clause (CD2)); - else + -- Note: at this point, component clauses have been + -- normalized to the default bit order, so that the + -- comparison of Component_Bit_Offsets is meaningful. + return Present (Component_Clause (CD2)) and then @@ -9665,8 +9983,7 @@ package body Sem_Ch13 is procedure No_Independence is begin if Pragma_Name (N) = Name_Independent then - Error_Msg_NE - ("independence cannot be guaranteed for&", N, E); + Error_Msg_NE ("independence cannot be guaranteed for&", N, E); else Error_Msg_NE ("independent components cannot be guaranteed for&", N, E); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2346b10a1d0..a3b2c4e3a3e 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -35,6 +35,7 @@ with Exp_Ch3; use Exp_Ch3; with Exp_Ch9; use Exp_Ch9; with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; +with Exp_Pakd; use Exp_Pakd; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; @@ -63,7 +64,6 @@ 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; @@ -1230,11 +1230,11 @@ package body Sem_Ch3 is Check_For_Premature_Usage (T_Def); - -- The return type and/or any parameter type may be incomplete. Mark - -- the subprogram_type as depending on the incomplete type, so that - -- it can 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. + -- The return type and/or any parameter type may be incomplete. Mark the + -- subprogram_type as depending on the incomplete type, so that it can + -- 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. if Present (Formals) then Formal := First_Formal (Desig_Type); @@ -1256,9 +1256,9 @@ package body Sem_Ch3 is end loop; end if; - -- If the return type is incomplete, this is legal as long as the - -- type is declared in the current scope and will be completed in - -- it (rather than being part of limited view). + -- If the return type is incomplete, this is legal as long as the type + -- is declared in the current scope and will be completed in it (rather + -- than being part of limited view). if Ekind (Etype (Desig_Type)) = E_Incomplete_Type and then not Has_Delayed_Freeze (Desig_Type) @@ -1331,9 +1331,9 @@ package body Sem_Ch3 is if Base_Type (Full_Desig) = T then Error_Msg_N ("access type cannot designate itself", S); - -- In Ada 2005, the type may have a limited view through some unit - -- in its own context, allowing the following circularity that cannot - -- be detected earlier + -- In Ada 2005, the type may have a limited view through some unit in + -- its own context, allowing the following circularity that cannot be + -- detected earlier elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T @@ -1348,8 +1348,8 @@ package body Sem_Ch3 is Set_Etype (T, T); - -- If the type has appeared already in a with_type clause, it is - -- frozen and the pointer size is already set. Else, initialize. + -- 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 Init_Size_Align (T); @@ -1661,6 +1661,15 @@ package body Sem_Ch3 is (New_Subp, Is_Abstract_Subprogram (Prim)); Set_Interface_Alias (New_Subp, Iface_Prim); + -- If the returned type is an interface then propagate it to + -- the returned type. Needed by the thunk to generate the code + -- which displaces "this" to reference the corresponding + -- secondary dispatch table in the returned object. + + if Is_Interface (Etype (Iface_Prim)) then + Set_Etype (New_Subp, Etype (Iface_Prim)); + end if; + -- Internal entities associated with interface types are -- only registered in the list of primitives of the tagged -- type. They are only used to fill the contents of the @@ -2171,45 +2180,22 @@ package body Sem_Ch3 is D := Next_Node; 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. + -- 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. declare - Decl : Node_Id; - Spec : Node_Id; - Sent : Entity_Id; - Prag : Node_Id; + Decl : Node_Id; + Subp_Id : Entity_Id; begin Decl := First (L); while Present (Decl) loop - if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then - Spec := Specification (Original_Node (Decl)); - Sent := Defining_Unit_Name (Spec); - - -- Analyze preconditions and postconditions - - Prag := Spec_PPC_List (Contract (Sent)); - while Present (Prag) loop - Analyze_PPC_In_Decl_Part (Prag, Sent); - Prag := Next_Pragma (Prag); - end loop; - - -- Analyze contract-cases and test-cases - - Prag := Spec_CTC_List (Contract (Sent)); - while Present (Prag) loop - Analyze_CTC_In_Decl_Part (Prag, Sent); - Prag := Next_Pragma (Prag); - end loop; - - -- At this point, entities have been attached to identifiers. - -- This is required to be able to detect suspicious contracts. - - Check_Subprogram_Contract (Sent); + if Nkind (Decl) = N_Subprogram_Declaration then + Subp_Id := Defining_Unit_Name (Specification (Decl)); + Analyze_Subprogram_Contract (Subp_Id); end if; Next (Decl); @@ -3274,11 +3260,11 @@ package body Sem_Ch3 is end if; end if; - -- Deal with predicate check before we start to do major rewriting. - -- it is OK to initialize and then check the initialized value, since - -- the object goes out of scope if we get a predicate failure. Note - -- that we do this in the analyzer and not the expander because the - -- analyzer does some substantial rewriting in some cases. + -- Deal with predicate check before we start to do major rewriting. It + -- is OK to initialize and then check the initialized value, since the + -- object goes out of scope if we get a predicate failure. Note that we + -- do this in the analyzer and not the expander because the analyzer + -- does some substantial rewriting in some cases. -- We need a predicate check if the type has predicates, and if either -- there is an initializing expression, or for default initialization @@ -3291,6 +3277,13 @@ package body Sem_Ch3 is or else Is_Partially_Initialized_Type (T, Include_Implicit => False)) then + -- If the type has a static predicate and the expression is known at + -- compile time, see if the expression satisfies the predicate. + + if Present (E) then + Check_Expression_Against_Static_Predicate (E, T); + end if; + Insert_After (N, Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc))); end if; @@ -3304,8 +3297,7 @@ package body Sem_Ch3 is if Is_String_Type (T) and then not Constant_Present (N) then Check_SPARK_Restriction - ("declaration of object of unconstrained type not allowed", - N); + ("declaration of object of unconstrained type not allowed", N); end if; -- Nothing to do in deferred constant case @@ -3734,6 +3726,13 @@ package body Sem_Ch3 is end if; Analyze_Dimension (N); + + -- Verify whether the object declaration introduces an illegal hidden + -- state within a package subject to a null abstract state. + + if Formal_Extensions and then Ekind (Id) = E_Variable then + Check_No_Hidden_State (Id); + end if; end Analyze_Object_Declaration; --------------------------- @@ -8347,7 +8346,6 @@ package body Sem_Ch3 is and then Present (Full_View (T)) then Analyze_And_Resolve (Expr, BDT, Suppress => Overflow_Check); - else Analyze_And_Resolve (Expr, BDT); end if; @@ -8674,6 +8672,10 @@ package body Sem_Ch3 is Set_Known_To_Have_Preelab_Init (Def_Id, Known_To_Have_Preelab_Init (T)); + -- Private subtypes may have private dependents + + Set_Private_Dependents (Def_Id, New_Elmt_List); + elsif Is_Class_Wide_Type (T) then Set_Ekind (Def_Id, E_Class_Wide_Subtype); @@ -9643,7 +9645,7 @@ package body Sem_Ch3 is elsif Is_Subprogram (E) and then (not Comes_From_Source (E) - or else Chars (E) = Name_uCall) + or else Chars (E) = Name_uCall) then null; @@ -9845,10 +9847,10 @@ package body Sem_Ch3 is -- The side effect removal machinery may generate illegal Ada -- code to avoid the usage of access types and 'reference in - -- Alfa mode. Since this is legal code with respect to theorem + -- SPARK mode. Since this is legal code with respect to theorem -- proving, do not emit the error. - if Alfa_Mode + if SPARK_Mode and then Nkind (Exp) = N_Function_Call and then Nkind (Parent (Exp)) = N_Object_Declaration and then not Comes_From_Source @@ -10772,13 +10774,9 @@ package body Sem_Ch3 is -- A deferred constant is a visible entity. If type has invariants, -- verify that the initial value satisfies them. - if Expander_Active and then Has_Invariants (T) then - declare - Call : constant Node_Id := - Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N))); - begin - Insert_After (N, Call); - end; + if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then + Insert_After (N, + Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N)))); end if; end if; end Constant_Redeclaration; @@ -11105,6 +11103,7 @@ package body Sem_Ch3 is is Loc : constant Source_Ptr := Sloc (Constrained_Typ); Compon_Type : constant Entity_Id := Etype (Comp); + Array_Comp : Node_Id; function Build_Constrained_Array_Type (Old_Type : Entity_Id) return Entity_Id; @@ -11502,7 +11501,22 @@ package body Sem_Ch3 is return Compon_Type; elsif Is_Array_Type (Compon_Type) then - return Build_Constrained_Array_Type (Compon_Type); + Array_Comp := Build_Constrained_Array_Type (Compon_Type); + + -- If the component of the parent is packed, and the record type is + -- already frozen, as is the case for an itype, the component type + -- itself will not be frozen, and the packed array type for it must + -- be constructed explicitly. Since the creation of packed types is + -- an expansion activity, we only do this if expansion is active. + + if Expander_Active + and then Is_Packed (Compon_Type) + and then Is_Frozen (Current_Scope) + then + Create_Packed_Array_Type (Array_Comp); + end if; + + return Array_Comp; elsif Has_Discriminants (Compon_Type) then return Build_Constrained_Discriminated_Type (Compon_Type); @@ -11970,7 +11984,7 @@ package body Sem_Ch3 is -- which must not be reevaluated. -- The forced evaluation removes side effects from expressions, - -- which should occur also in Alfa mode. Otherwise, we end up with + -- which should occur also in SPARK mode. Otherwise, we end up with -- unexpected insertions of actions at places where this is not -- supposed to occur, e.g. on default parameters of a call. @@ -12060,9 +12074,9 @@ package body Sem_Ch3 is Set_Ekind (Def_Id, E_Signed_Integer_Subtype); end if; - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); Set_Discrete_RM_Size (Def_Id); end Constrain_Integer; @@ -12078,10 +12092,10 @@ package body Sem_Ch3 is begin Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Small_Value (Def_Id, Small_Value (T)); + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Small_Value (Def_Id, Small_Value (T)); -- Process the constraint @@ -12429,9 +12443,7 @@ package body Sem_Ch3 is then Old_C := First_Component (Typ); while Present (Old_C) loop - if Chars ((Old_C)) = Name_uTag - or else Chars ((Old_C)) = Name_uParent - then + if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then Append_Elmt (Old_C, Comp_List); end if; @@ -13268,9 +13280,9 @@ package body Sem_Ch3 is or else Is_Internal (Parent_Subp) or else Is_Private_Overriding or else Is_Internal_Name (Chars (Parent_Subp)) - or else Chars (Parent_Subp) = Name_Initialize - or else Chars (Parent_Subp) = Name_Adjust - or else Chars (Parent_Subp) = Name_Finalize + or else Nam_In (Chars (Parent_Subp), Name_Initialize, + Name_Adjust, + Name_Finalize) then Set_Derived_Name; @@ -13443,10 +13455,9 @@ package body Sem_Ch3 is -- set on both views of the type. if Is_Controlled (Parent_Type) - and then - (Chars (Parent_Subp) = Name_Initialize or else - Chars (Parent_Subp) = Name_Adjust or else - Chars (Parent_Subp) = Name_Finalize) + and then Nam_In (Chars (Parent_Subp), Name_Initialize, + Name_Adjust, + Name_Finalize) and then Is_Hidden (Parent_Subp) and then not Is_Visibly_Controlled (Parent_Type) then @@ -16324,31 +16335,6 @@ package body Sem_Ch3 is end Inherit_Components; ----------------------- - -- Is_Constant_Bound -- - ----------------------- - - function Is_Constant_Bound (Exp : Node_Id) return Boolean is - begin - if Compile_Time_Known_Value (Exp) then - return True; - - elsif Is_Entity_Name (Exp) - and then Present (Entity (Exp)) - then - return Is_Constant_Object (Entity (Exp)) - or else Ekind (Entity (Exp)) = E_Enumeration_Literal; - - elsif Nkind (Exp) in N_Binary_Op then - return Is_Constant_Bound (Left_Opnd (Exp)) - and then Is_Constant_Bound (Right_Opnd (Exp)) - and then Scope (Entity (Exp)) = Standard_Standard; - - else - return False; - end if; - end Is_Constant_Bound; - - ----------------------- -- Is_Null_Extension -- ----------------------- @@ -16495,10 +16481,16 @@ package body Sem_Ch3 is Type_Scope := Scope (Base_Type (Scope (C))); end if; - -- This test only concerns tagged types + -- For an untagged type derived from a private type, the only visible + -- components are new discriminants. In an instance all components are + -- visible (see Analyze_Selected_Component). if not Is_Tagged_Type (Original_Scope) then - return True; + return not Has_Private_Ancestor (Original_Scope) + or else In_Open_Scopes (Scope (Original_Scope)) + or else In_Instance + or else (Ekind (Original_Comp) = E_Discriminant + and then Original_Scope = Type_Scope); -- If it is _Parent or _Tag, there is no visibility issue @@ -16567,9 +16559,9 @@ package body Sem_Ch3 is and then Is_Local_Type (Type_Scope); end if; - -- There is another weird way in which a component may be invisible - -- when the private and the full view are not derived from the same - -- ancestor. Here is an example : + -- There is another weird way in which a component may be invisible when + -- the private and the full view are not derived from the same ancestor. + -- Here is an example : -- type A1 is tagged record F1 : integer; end record; -- type A2 is new A1 with record F2 : integer; end record; @@ -17410,8 +17402,6 @@ package body Sem_Ch3 is -- now. We have to create a new entity with the same name, Thus we -- can't use Create_Itype. - -- This is messy, should be fixed ??? - Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); Set_Is_Itype (Full); Set_Associated_Node_For_Itype (Full, Related_Nod); @@ -18634,9 +18624,9 @@ package body Sem_Ch3 is -- duplication of the expression without forcing evaluation. -- The forced evaluation removes side effects from expressions, - -- which should occur also in Alfa mode. Otherwise, we end up with - -- unexpected insertions of actions at places where this is not - -- supposed to occur, e.g. on default parameters of a call. + -- which should occur also in SPARK mode. Otherwise, we end up + -- with unexpected insertions of actions at places where this is + -- not supposed to occur, e.g. on default parameters of a call. if Expander_Active then Force_Evaluation (Lo); @@ -18749,7 +18739,7 @@ package body Sem_Ch3 is -- Case of other than an explicit N_Range node -- The forced evaluation removes side effects from expressions, which - -- should occur also in Alfa mode. Otherwise, we end up with unexpected + -- should occur also in SPARK mode. Otherwise, we end up with unexpected -- insertions of actions at places where this is not supposed to occur, -- e.g. on default parameters of a call. @@ -19343,7 +19333,7 @@ package body Sem_Ch3 is or else (Is_Class_Wide_Type (Entity (Subt)) and then - Chars (Etype (Base_Type (Entity (Subt)))) = + Chars (Etype (Base_Type (Entity (Subt)))) = Type_Id)); end if; @@ -20179,7 +20169,7 @@ package body Sem_Ch3 is -- Complete both implicit base and declared first subtype entities - Set_Etype (Implicit_Base, Base_Typ); + Set_Etype (Implicit_Base, Base_Typ); Set_Size_Info (Implicit_Base, (Base_Typ)); Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); @@ -20193,7 +20183,7 @@ package body Sem_Ch3 is -- subtype range. Keep Size, RM_Size and First_Rep_Item info, which -- should not be relied upon in formal verification. - if Strict_Alfa_Mode then + if SPARK_Strict_Mode then declare Sym_Hi_Val : Uint; Sym_Lo_Val : Uint; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 98a8dbc8ce3..a0b37ea0a5b 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.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- -- @@ -174,12 +174,6 @@ package Sem_Ch3 is -- Given a discriminant somewhere in the Typ_For_Constraint tree and a -- Constraint, return the value of that discriminant. - function Is_Constant_Bound (Exp : Node_Id) return Boolean; - -- Exp is the expression for an array bound. Determines whether the - -- bound is a compile-time known value, or a constant entity, or an - -- enumeration literal, or an expression composed of constant-bound - -- subexpressions which are evaluated by means of standard operators. - function Is_Null_Extension (T : Entity_Id) return Boolean; -- Returns True if the tagged type T has an N_Full_Type_Declaration that -- is a null extension, meaning that it has an extension part without any diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 421cd81b5c3..04db9b0d391 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -413,8 +413,8 @@ package body Sem_Ch4 is if Comes_From_Source (N) then Check_Restriction (No_Allocators, N); - -- Processing for No_Allocators_After_Elaboration, loop to look at - -- enclosing context, checking task case and main subprogram case. + -- Processing for No_Standard_Allocators_After_Elaboration, loop to + -- look at enclosing context, checking task/main subprogram case. C := N; P := Parent (C); @@ -431,7 +431,8 @@ package body Sem_Ch4 is -- violation of No_Allocators_After_Elaboration we can detect. if Nkind (Original_Node (Parent (P))) = N_Task_Body then - Check_Restriction (No_Allocators_After_Elaboration, N); + Check_Restriction + (No_Standard_Allocators_After_Elaboration, N); exit; end if; @@ -573,19 +574,6 @@ package body Sem_Ch4 is Rewrite (E, New_Copy_Tree (Subtype_Mark (E))); Analyze_Allocator (N); return; - - -- Ada 2005, AI-363: if the designated type has a constrained - -- partial view, it cannot receive a discriminant constraint, - -- and the allocated object is unconstrained. - - elsif Ada_Version >= Ada_2005 - and then Effectively_Has_Constrained_Partial_View - (Typ => Base_Typ, - Scop => Current_Scope) - then - Error_Msg_N - ("constraint not allowed when type " & - "has a constrained partial view", Constraint (E)); end if; if Expander_Active then @@ -866,6 +854,11 @@ package body Sem_Ch4 is -- Flag indicates whether an interpretation of the prefix is a -- parameterless call that returns an access_to_subprogram. + procedure Check_Ghost_Subprogram_Call; + -- Verify the legality of a call to a ghost subprogram. Such calls can + -- appear only in assertion expressions except subtype predicates or + -- from within another ghost subprogram. + procedure Check_Mixed_Parameter_And_Named_Associations; -- Check that parameter and named associations are not mixed. This is -- a restriction in SPARK mode. @@ -880,6 +873,38 @@ package body Sem_Ch4 is procedure No_Interpretation; -- Output error message when no valid interpretation exists + --------------------------------- + -- Check_Ghost_Subprogram_Call -- + --------------------------------- + + procedure Check_Ghost_Subprogram_Call is + S : Entity_Id; + + begin + -- The ghost subprogram appears inside an assertion expression + + if In_Assertion_Expression (N) then + return; + + else + S := Current_Scope; + while Present (S) and then S /= Standard_Standard loop + + -- The call appears inside another ghost subprogram + + if Is_Ghost_Subprogram (S) then + return; + end if; + + S := Scope (S); + end loop; + end if; + + Error_Msg_N + ("call to ghost subprogram must appear in assertion expression or " + & "another ghost subprogram", N); + end Check_Ghost_Subprogram_Call; + -------------------------------------------------- -- Check_Mixed_Parameter_And_Named_Associations -- -------------------------------------------------- @@ -970,6 +995,12 @@ package body Sem_Ch4 is Check_Mixed_Parameter_And_Named_Associations; end if; + -- Mark a function that appears inside an assertion expression + + if Nkind (N) = N_Function_Call and then In_Assertion_Expr > 0 then + Set_In_Assertion_Expression (N); + end if; + -- Initialize the type of the result of the call to the error type, -- which will be reset if the type is successfully resolved. @@ -1076,6 +1107,8 @@ package body Sem_Ch4 is Set_Etype (Nam_Ent, Etype (N)); end if; + -- Overloaded call + else -- An overloaded selected component must denote overloaded operations -- of a concurrent type. The interpretations are attached to the @@ -1160,9 +1193,9 @@ package body Sem_Ch4 is Get_Next_Interp (X, It); end loop; - -- If the name is the result of a function call, it can only - -- be a call to a function returning an access to subprogram. - -- Insert explicit dereference. + -- If the name is the result of a function call, it can only be a + -- call to a function returning an access to subprogram. Insert + -- explicit dereference. if Nkind (Nam) = N_Function_Call then Insert_Explicit_Dereference (Nam); @@ -1241,6 +1274,13 @@ package body Sem_Ch4 is End_Interp_List; end if; + + -- A call to a ghost subprogram is allowed only in assertion expressions + -- excluding subtype predicates or from within another ghost subprogram. + + if Is_Ghost_Subprogram (Get_Subprogram_Entity (N)) then + Check_Ghost_Subprogram_Call; + end if; end Analyze_Call; ----------------------------- @@ -1248,14 +1288,8 @@ package body Sem_Ch4 is ----------------------------- procedure Analyze_Case_Expression (N : Node_Id) is - Expr : constant Node_Id := Expression (N); - FirstX : constant Node_Id := Expression (First (Alternatives (N))); - Alt : Node_Id; - Exp_Type : Entity_Id; - Exp_Btype : Entity_Id; - - Dont_Care : Boolean; - Others_Present : Boolean; + function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean; + -- Determine whether subtype Subtyp has aspect Static_Predicate procedure Non_Static_Choice_Error (Choice : Node_Id); -- Error routine invoked by the generic instantiation below when @@ -1270,6 +1304,28 @@ package body Sem_Ch4 is Process_Associated_Node => No_OP); use Case_Choices_Processing; + -------------------------- + -- Has_Static_Predicate -- + -------------------------- + + function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean is + Item : Node_Id; + + begin + Item := First_Rep_Item (Subtyp); + while Present (Item) loop + if Nkind (Item) = N_Aspect_Specification + and then Chars (Identifier (Item)) = Name_Static_Predicate + then + return True; + end if; + + Next_Rep_Item (Item); + end loop; + + return False; + end Has_Static_Predicate; + ----------------------------- -- Non_Static_Choice_Error -- ----------------------------- @@ -1280,6 +1336,17 @@ package body Sem_Ch4 is ("choice given in case expression is not static!", Choice); end Non_Static_Choice_Error; + -- Local variables + + Expr : constant Node_Id := Expression (N); + FirstX : constant Node_Id := Expression (First (Alternatives (N))); + Alt : Node_Id; + Exp_Type : Entity_Id; + Exp_Btype : Entity_Id; + + Dont_Care : Boolean; + Others_Present : Boolean; + -- Start of processing for Analyze_Case_Expression begin @@ -1364,9 +1431,22 @@ package body Sem_Ch4 is Exp_Type := Exp_Btype; end if; + -- The case expression alternatives cover the range of a static subtype + -- subject to aspect Static_Predicate. Do not check the choices when the + -- case expression has not been fully analyzed yet because this may lead + -- to bogus errors. + + if Is_Static_Subtype (Exp_Type) + and then Has_Static_Predicate (Exp_Type) + and then In_Spec_Expression + then + null; + -- Call instantiated Analyze_Choices which does the rest of the work - Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); + else + Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); + end if; if Exp_Type = Universal_Integer and then not Others_Present then Error_Msg_N @@ -1721,8 +1801,8 @@ package body Sem_Ch4 is -- In formal verification mode, keep track of all reads and writes -- through explicit dereferences. - if Alfa_Mode then - Alfa.Generate_Dereference (N); + if SPARK_Mode then + SPARK_Specific.Generate_Dereference (N); end if; Analyze (P); @@ -1896,13 +1976,15 @@ package body Sem_Ch4 is begin A := First (Actions (N)); - loop + while Present (A) loop Analyze (A); Next (A); - exit when No (A); end loop; - -- This test needs a comment ??? + -- We currently hijack Expression_With_Actions with a VOID type and + -- a NULL statement in the Expression. This will ultimately be replaced + -- by a proper separate N_Compound_Statement node, at which point the + -- test below can go away??? if Nkind (Expression (N)) = N_Null_Statement then Set_Etype (N, Standard_Void_Type); @@ -2306,12 +2388,20 @@ package body Sem_Ch4 is Analyze (P); + -- If P is an explicit dereference whose prefix is of a remote access- + -- to-subprogram type, then N has already been rewritten as a subprogram + -- call and analyzed. + if Nkind (N) in N_Subprogram_Call then + return; - -- If P is an explicit dereference whose prefix is of a - -- remote access-to-subprogram type, then N has already - -- been rewritten as a subprogram call and analyzed. + -- When the prefix is attribute 'Loop_Entry and the sole expression of + -- the indexed component denotes a loop name, the indexed form is turned + -- into an attribute reference. + elsif Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Loop_Entry + then return; end if; @@ -3411,13 +3501,15 @@ package body Sem_Ch4 is ----------------------------------- procedure Analyze_Quantified_Expression (N : Node_Id) is - QE_Scop : Entity_Id; - function Is_Empty_Range (Typ : Entity_Id) return Boolean; -- If the iterator is part of a quantified expression, and the range is -- known to be statically empty, emit a warning and replace expression -- with its static value. Returns True if the replacement occurs. + function No_Else_Or_Trivial_True (If_Expr : Node_Id) return Boolean; + -- Determine whether if expression If_Expr lacks an else part or if it + -- has one, it evaluates to True. + -------------------- -- Is_Empty_Range -- -------------------- @@ -3455,6 +3547,26 @@ package body Sem_Ch4 is end if; end Is_Empty_Range; + ----------------------------- + -- No_Else_Or_Trivial_True -- + ----------------------------- + + function No_Else_Or_Trivial_True (If_Expr : Node_Id) return Boolean is + Else_Expr : constant Node_Id := + Next (Next (First (Expressions (If_Expr)))); + begin + return + No (Else_Expr) + or else (Compile_Time_Known_Value (Else_Expr) + and then Is_True (Expr_Value (Else_Expr))); + end No_Else_Or_Trivial_True; + + -- Local variables + + Cond : constant Node_Id := Condition (N); + Loop_Id : Entity_Id; + QE_Scop : Entity_Id; + -- Start of processing for Analyze_Quantified_Expression begin @@ -3479,21 +3591,56 @@ package body Sem_Ch4 is if Present (Iterator_Specification (N)) then Preanalyze (Iterator_Specification (N)); + -- Do not proceed with the analysis when the range of iteration is + -- empty. The appropriate error is issued by Is_Empty_Range. + if Is_Entity_Name (Name (Iterator_Specification (N))) and then Is_Empty_Range (Etype (Name (Iterator_Specification (N)))) then return; end if; - else + else pragma Assert (Present (Loop_Parameter_Specification (N))); Preanalyze (Loop_Parameter_Specification (N)); end if; - Preanalyze_And_Resolve (Condition (N), Standard_Boolean); + Preanalyze_And_Resolve (Cond, Standard_Boolean); End_Scope; - Set_Etype (N, Standard_Boolean); + + -- Verify that the loop variable is used within the condition of the + -- quantified expression. + + if Present (Iterator_Specification (N)) then + Loop_Id := Defining_Identifier (Iterator_Specification (N)); + else + Loop_Id := Defining_Identifier (Loop_Parameter_Specification (N)); + end if; + + if Warn_On_Suspicious_Contract + and then not Referenced (Loop_Id, Cond) + then + Error_Msg_N ("?T?unused variable &", Loop_Id); + end if; + + -- Diagnose a possible misuse of the "some" existential quantifier. When + -- we have a quantified expression of the form: + + -- for some X => (if P then Q [else True]) + + -- the if expression will not hold and render the quantified expression + -- trivially True. + + if Formal_Extensions + and then not All_Present (N) + and then Nkind (Cond) = N_If_Expression + and then No_Else_Or_Trivial_True (Cond) + then + Error_Msg_N ("?suspicious expression", N); + Error_Msg_N ("\\did you mean (for all X ='> (if P then Q))", N); + Error_Msg_N ("\\or (for some X ='> P and then Q) instead'?", N); + end if; end Analyze_Quantified_Expression; ------------------- @@ -4016,13 +4163,11 @@ package body Sem_Ch4 is and then Nkind (Name) /= N_Selected_Component) or else (Nkind (Parent_N) = N_Attribute_Reference - and then (Attribute_Name (Parent_N) = Name_First - or else - Attribute_Name (Parent_N) = Name_Last - or else - Attribute_Name (Parent_N) = Name_Length - or else - Attribute_Name (Parent_N) = Name_Range))) + and then + Nam_In (Attribute_Name (Parent_N), Name_First, + Name_Last, + Name_Length, + Name_Range))) then Set_Etype (N, Etype (Comp)); @@ -4404,10 +4549,10 @@ package body Sem_Ch4 is -- Emit appropriate message. Gigi will replace the -- node subsequently with the appropriate Raise. - -- In Alfa mode, this is made into an error to simplify + -- In SPARK mode, this is made into an error to simplify -- the processing of the formal verification backend. - if Alfa_Mode then + if SPARK_Mode then Apply_Compile_Time_Constraint_Error (N, "component not present in }", CE_Discriminant_Check_Failed, @@ -4685,9 +4830,9 @@ package body Sem_Ch4 is elsif Nkind (Expr) = N_Attribute_Reference and then - (Attribute_Name (Expr) = Name_Access or else - Attribute_Name (Expr) = Name_Unchecked_Access or else - Attribute_Name (Expr) = Name_Unrestricted_Access) + Nam_In (Attribute_Name (Expr), Name_Access, + Name_Unchecked_Access, + Name_Unrestricted_Access) then Error_Msg_N ("argument of conversion cannot be access", N); Error_Msg_N ("\use qualified expression instead", N); @@ -4942,8 +5087,7 @@ package body Sem_Ch4 is -- Start of processing for Check_Arithmetic_Pair begin - if Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then - + if Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then if Is_Numeric_Type (T1) and then Is_Numeric_Type (T2) and then (Covers (T1 => T1, T2 => T2) @@ -4953,11 +5097,9 @@ package body Sem_Ch4 is Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; - elsif Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide then - + elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) then if Is_Fixed_Point_Type (T1) - and then (Is_Fixed_Point_Type (T2) - or else T2 = Universal_Real) + and then (Is_Fixed_Point_Type (T2) or else T2 = Universal_Real) then -- If Treat_Fixed_As_Integer is set then the Etype is already set -- and no further processing is required (this is the case of an @@ -4995,7 +5137,7 @@ package body Sem_Ch4 is elsif Is_Fixed_Point_Type (T1) and then (Base_Type (T2) = Base_Type (Standard_Integer) - or else T2 = Universal_Integer) + or else T2 = Universal_Integer) then Add_One_Interp (N, Op_Id, T1); @@ -5012,7 +5154,7 @@ package body Sem_Ch4 is elsif Is_Fixed_Point_Type (T2) and then (Base_Type (T1) = Base_Type (Standard_Integer) - or else T1 = Universal_Integer) + or else T1 = Universal_Integer) and then Op_Name = Name_Op_Multiply then Add_One_Interp (N, Op_Id, T2); @@ -6622,11 +6764,13 @@ package body Sem_Ch4 is Func_Name := Empty; if Is_Variable (Prefix) then - Func_Name := Find_Aspect (Etype (Prefix), Aspect_Variable_Indexing); + Func_Name := + Find_Value_Of_Aspect (Etype (Prefix), Aspect_Variable_Indexing); end if; if No (Func_Name) then - Func_Name := Find_Aspect (Etype (Prefix), Aspect_Constant_Indexing); + Func_Name := + Find_Value_Of_Aspect (Etype (Prefix), Aspect_Constant_Indexing); end if; -- If aspect does not exist the expression is illegal. Error is diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 2e8f3a7b2f0..5b34ecc347b 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -141,13 +141,13 @@ package body Sem_Ch5 is -- directly. elsif (Is_Prival (Ent) - and then - (Ekind (Current_Scope) = E_Function - or else Ekind (Enclosing_Dynamic_Scope - (Current_Scope)) = E_Function)) + and then + (Ekind (Current_Scope) = E_Function + or else Ekind (Enclosing_Dynamic_Scope + (Current_Scope)) = E_Function)) or else (Ekind (Ent) = E_Component - and then Is_Protected_Type (Scope (Ent))) + and then Is_Protected_Type (Scope (Ent))) then Error_Msg_N ("protected function cannot modify protected object", N); @@ -222,16 +222,15 @@ package body Sem_Ch5 is if Is_Entity_Name (Opnd) and then (Ekind (Entity (Opnd)) = E_Out_Parameter - or else Ekind (Entity (Opnd)) = - E_In_Out_Parameter - or else Ekind (Entity (Opnd)) = - E_Generic_In_Out_Parameter + or else Ekind_In (Entity (Opnd), + E_In_Out_Parameter, + E_Generic_In_Out_Parameter) or else (Ekind (Entity (Opnd)) = E_Variable and then Nkind (Parent (Entity (Opnd))) = - N_Object_Renaming_Declaration + N_Object_Renaming_Declaration and then Nkind (Parent (Parent (Entity (Opnd)))) = - N_Accept_Statement)) + N_Accept_Statement)) then Opnd_Type := Get_Actual_Subtype (Opnd); @@ -394,7 +393,7 @@ package body Sem_Ch5 is end loop; if (Nkind (Ent) = N_Attribute_Reference - and then Attribute_Name (Ent) = Name_Priority) + and then Attribute_Name (Ent) = Name_Priority) -- Renamings of the attribute Priority applied to protected -- objects have been previously expanded into calls to the @@ -402,15 +401,15 @@ package body Sem_Ch5 is or else (Nkind (Ent) = N_Function_Call - and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling) - or else - Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling))) + and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling) + or else + Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling))) then -- The enclosing subprogram cannot be a protected function S := Current_Scope; while not (Is_Subprogram (S) - and then Convention (S) = Convention_Protected) + and then Convention (S) = Convention_Protected) and then S /= Standard_Standard loop S := Scope (S); @@ -583,8 +582,8 @@ package body Sem_Ch5 is Propagate_Tag (Lhs, Rhs); elsif Nkind (Rhs) = N_Function_Call - and then Is_Entity_Name (Name (Rhs)) - and then Is_Abstract_Subprogram (Entity (Name (Rhs))) + and then Is_Entity_Name (Name (Rhs)) + and then Is_Abstract_Subprogram (Entity (Name (Rhs))) then Error_Msg_N ("call to abstract function must be dispatching", Name (Rhs)); @@ -607,9 +606,7 @@ package body Sem_Ch5 is -- as well to anonymous access-to-subprogram types that are component -- subtypes or formal parameters. - if Ada_Version >= Ada_2005 - and then Is_Access_Type (T1) - then + if Ada_Version >= Ada_2005 and then Is_Access_Type (T1) then if Is_Local_Anonymous_Access (T1) or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type @@ -665,12 +662,10 @@ package body Sem_Ch5 is -- assignment within the block. elsif Is_Array_Type (T1) - and then - (Nkind (Rhs) /= N_Type_Conversion - or else Is_Constrained (Etype (Rhs))) - and then - (Nkind (Rhs) /= N_Function_Call - or else Nkind (N) /= N_Block_Statement) + and then (Nkind (Rhs) /= N_Type_Conversion + or else Is_Constrained (Etype (Rhs))) + and then (Nkind (Rhs) /= N_Function_Call + or else Nkind (N) /= N_Block_Statement) then -- Assignment verifies that the length of the Lsh and Rhs are equal, -- but of course the indexes do not have to match. If the right-hand @@ -1172,7 +1167,7 @@ package body Sem_Ch5 is elsif Ada_Version = Ada_83 and then (Is_Generic_Type (Exp_Btype) - or else Is_Generic_Type (Root_Type (Exp_Btype))) + or else Is_Generic_Type (Root_Type (Exp_Btype))) then Error_Msg_N ("(Ada 83) case expression cannot be of a generic type", Exp); @@ -1198,9 +1193,7 @@ package body Sem_Ch5 is -- A case statement with a single OTHERS alternative is not allowed -- in SPARK. - if Others_Present - and then List_Length (Alternatives (N)) = 1 - then + if Others_Present and then List_Length (Alternatives (N)) = 1 then Check_SPARK_Restriction ("OTHERS as unique case alternative is not allowed", N); end if; @@ -1297,9 +1290,7 @@ package body Sem_Ch5 is Scope_Id := Scope_Stack.Table (J).Entity; Kind := Ekind (Scope_Id); - if Kind = E_Loop - and then (No (Target) or else Scope_Id = U_Name) - then + if Kind = E_Loop and then (No (Target) or else Scope_Id = U_Name) then Set_Has_Exit (Scope_Id); exit; @@ -1423,9 +1414,7 @@ package body Sem_Ch5 is Scope_Id := Scope_Stack.Table (J).Entity; if Label_Scope = Scope_Id - or else (Ekind (Scope_Id) /= E_Block - and then Ekind (Scope_Id) /= E_Loop - and then Ekind (Scope_Id) /= E_Return_Statement) + or else not Ekind_In (Scope_Id, E_Block, E_Loop, E_Return_Statement) then if Scope_Id /= Label_Scope then Error_Msg_N @@ -1447,9 +1436,9 @@ package body Sem_Ch5 is -- The expander has circuitry to completely delete code that it can tell -- will not be executed (as a result of compile time known conditions). In - -- the analyzer, we ensure that code that will be deleted in this manner is - -- analyzed but not expanded. This is obviously more efficient, but more - -- significantly, difficulties arise if code is expanded and then + -- the analyzer, we ensure that code that will be deleted in this manner + -- is analyzed but not expanded. This is obviously more efficient, but + -- more significantly, difficulties arise if code is expanded and then -- eliminated (e.g. exception table entries disappear). Similarly, itypes -- generated in deleted code must be frozen from start, because the nodes -- on which they depend will not be available at the freeze point. @@ -1675,10 +1664,10 @@ package body Sem_Ch5 is and then (Nkind (Parent (N)) /= N_Quantified_Expression or else Operating_Mode = Check_Semantics) - -- Do not perform this expansion in Alfa mode, since the formal + -- Do not perform this expansion in SPARK mode, since the formal -- verification directly deals with the source form of the iterator. - and then not Alfa_Mode + and then not SPARK_Mode then declare Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); @@ -1800,7 +1789,7 @@ package body Sem_Ch5 is declare Element : constant Entity_Id := - Find_Aspect (Typ, Aspect_Iterator_Element); + Find_Value_Of_Aspect (Typ, Aspect_Iterator_Element); begin if No (Element) then Error_Msg_NE ("cannot iterate over&", N, Typ); @@ -1811,7 +1800,7 @@ package body Sem_Ch5 is -- If the container has a variable indexing aspect, the -- element is a variable and is modifiable in the loop. - if Present (Find_Aspect (Typ, Aspect_Variable_Indexing)) then + if Has_Aspect (Typ, Aspect_Variable_Indexing) then Set_Ekind (Def_Id, E_Variable); end if; end if; @@ -1825,7 +1814,7 @@ package body Sem_Ch5 is if Is_Entity_Name (Original_Node (Name (N))) and then not Is_Iterator (Typ) then - if No (Find_Aspect (Typ, Aspect_Iterator_Element)) then + if not Has_Aspect (Typ, Aspect_Iterator_Element) then Error_Msg_NE ("cannot iterate over&", Name (N), Typ); else @@ -2161,15 +2150,11 @@ package body Sem_Ch5 is -- Propagate staticness to loop range itself, in case the -- corresponding subtype is static. - if New_Lo /= Lo - and then Is_Static_Expression (New_Lo) - then + if New_Lo /= Lo and then Is_Static_Expression (New_Lo) then Rewrite (Low_Bound (R), New_Copy (New_Lo)); end if; - if New_Hi /= Hi - and then Is_Static_Expression (New_Hi) - then + if New_Hi /= Hi and then Is_Static_Expression (New_Hi) then Rewrite (High_Bound (R), New_Copy (New_Hi)); end if; end Process_Bounds; @@ -2238,9 +2223,8 @@ package body Sem_Ch5 is -- new iterator form. if Nkind (DS_Copy) = N_Function_Call - or else - (Is_Entity_Name (DS_Copy) - and then not Is_Type (Entity (DS_Copy))) + or else (Is_Entity_Name (DS_Copy) + and then not Is_Type (Entity (DS_Copy))) then -- This is an iterator specification. Rewrite it as such and -- analyze it to capture function calls that may require @@ -2314,15 +2298,19 @@ package body Sem_Ch5 is Set_Etype (DS, Entity (DS)); end if; - -- Attempt to iterate through non-static predicate + -- Attempt to iterate through non-static predicate. Note that a type + -- with inherited predicates may have both static and dynamic forms. + -- In this case it is not sufficent to check the static predicate + -- function only, look for a dynamic predicate aspect as well. if Is_Discrete_Type (Entity (DS)) and then Present (Predicate_Function (Entity (DS))) - and then No (Static_Predicate (Entity (DS))) + and then (No (Static_Predicate (Entity (DS))) + or else Has_Dynamic_Predicate_Aspect (Entity (DS))) then Bad_Predicated_Subtype_Use ("cannot use subtype& with non-static predicate for loop " & - "iteration", DS, Entity (DS)); + "iteration", DS, Entity (DS), Suggest_Static => True); end if; end if; @@ -2351,7 +2339,7 @@ package body Sem_Ch5 is and then Is_Itype (Etype (Id)) and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions and then Nkind (Original_Node (Parent (Loop_Nod))) = - N_Quantified_Expression) + N_Quantified_Expression) then Set_Etype (Id, Etype (DS)); end if; @@ -2395,9 +2383,8 @@ package body Sem_Ch5 is -- instance, since in practice they tend to be dubious in these -- cases since they can result from intended parametrization. - if not Inside_A_Generic - and then not In_Instance - then + if not Inside_A_Generic and then not In_Instance then + -- Specialize msg if invalid values could make the loop -- non-null after all. @@ -2436,7 +2423,7 @@ package body Sem_Ch5 is -- The other case for a warning is a reverse loop where the -- upper bound is the integer literal zero or one, and the - -- lower bound can be positive. + -- lower bound may exceed this value. -- For example, we have @@ -2449,10 +2436,23 @@ package body Sem_Ch5 is and then Nkind (Original_Node (H)) = N_Integer_Literal and then (Intval (Original_Node (H)) = Uint_0 - or else Intval (Original_Node (H)) = Uint_1) + or else + Intval (Original_Node (H)) = Uint_1) then - Error_Msg_N ("??loop range may be null", DS); - Error_Msg_N ("\??bounds may be wrong way round", DS); + -- Lower bound may in fact be known and known not to exceed + -- upper bound (e.g. reverse 0 .. 1) and that's OK. + + if Compile_Time_Known_Value (L) + and then Expr_Value (L) <= Expr_Value (H) + then + null; + + -- Otherwise warning is warranted + + else + Error_Msg_N ("??loop range may be null", DS); + Error_Msg_N ("\??bounds may be wrong way round", DS); + end if; end if; end; end if; @@ -2549,6 +2549,7 @@ package body Sem_Ch5 is Iter : constant Node_Id := Iteration_Scheme (N); Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; + Stmt : Node_Id; -- Start of processing for Analyze_Loop_Statement @@ -2686,7 +2687,7 @@ package body Sem_Ch5 is -- types the actual subtype of the components will only be determined -- when the cursor declaration is analyzed. - -- If the expander is not active, or in Alfa mode, then we want to + -- If the expander is not active, or in SPARK mode, then we want to -- analyze the loop body now even in the Ada 2012 iterator case, since -- the rewriting will not be done. Insert the loop variable in the -- current scope, if not done when analysing the iteration scheme. @@ -2711,13 +2712,22 @@ package body Sem_Ch5 is Analyze_Statements (Statements (N)); end if; + -- When the iteration scheme of a loop contains attribute 'Loop_Entry, + -- the loop is transformed into a conditional block. Retrieve the loop. + + Stmt := N; + + if Subject_To_Loop_Entry_Attributes (Stmt) then + Stmt := Find_Loop_In_Conditional_Block (Stmt); + end if; + -- Finish up processing for the loop. We kill all current values, since -- in general we don't know if the statements in the loop have been -- executed. We could do a bit better than this with a loop that we -- know will execute at least once, but it's not worth the trouble and -- the front end is not in the business of flow tracing. - Process_End_Label (N, 'e', Ent); + Process_End_Label (Stmt, 'e', Ent); End_Scope; Kill_Current_Values; @@ -2728,15 +2738,15 @@ package body Sem_Ch5 is -- before making this call, since Check_Infinite_Loop_Warning relies on -- being able to use semantic visibility information to find references. - if Comes_From_Source (N) then - Check_Infinite_Loop_Warning (N); + if Comes_From_Source (Stmt) then + Check_Infinite_Loop_Warning (Stmt); end if; -- Code after loop is unreachable if the loop has no WHILE or FOR and -- contains no EXIT statements within the body of the loop. if No (Iter) and then not Has_Exit (Ent) then - Check_Unreachable_Code (N); + Check_Unreachable_Code (Stmt); end if; end Analyze_Loop_Statement; @@ -2839,9 +2849,7 @@ package body Sem_Ch5 is P : Node_Id; begin - if Is_List_Member (N) - and then Comes_From_Source (N) - then + if Is_List_Member (N) and then Comes_From_Source (N) then declare Nxt : Node_Id; @@ -2954,7 +2962,16 @@ package body Sem_Ch5 is elsif Nkind (P) = N_Handled_Sequence_Of_Statements and then Nkind (Parent (P)) = N_Block_Statement then - null; + -- The original loop is now placed inside a block statement + -- due to the expansion of attribute 'Loop_Entry. Return as + -- this is not a "real" block for the purposes of exit + -- counting. + + if Nkind (N) = N_Loop_Statement + and then Subject_To_Loop_Entry_Attributes (N) + then + return; + end if; -- Statements in exception handler in a block @@ -2993,9 +3010,8 @@ package body Sem_Ch5 is Analyze (R_Copy); - if Nkind (R_Copy) in N_Subexpr - and then Is_Overloaded (R_Copy) - then + if Nkind (R_Copy) in N_Subexpr and then Is_Overloaded (R_Copy) then + -- Apply preference rules for range of predefined integer types, or -- diagnose true ambiguity. @@ -3037,9 +3053,7 @@ package body Sem_Ch5 is -- Subtype mark in iteration scheme - if Is_Entity_Name (R_Copy) - and then Is_Type (Entity (R_Copy)) - then + if Is_Entity_Name (R_Copy) and then Is_Type (Entity (R_Copy)) then null; -- Expression in range, or Ada 2012 iterator @@ -3053,9 +3067,9 @@ package body Sem_Ch5 is -- Check that the resulting object is an iterable container - elsif Present (Find_Aspect (Typ, Aspect_Iterator_Element)) - or else Present (Find_Aspect (Typ, Aspect_Constant_Indexing)) - or else Present (Find_Aspect (Typ, Aspect_Variable_Indexing)) + elsif Has_Aspect (Typ, Aspect_Iterator_Element) + or else Has_Aspect (Typ, Aspect_Constant_Indexing) + or else Has_Aspect (Typ, Aspect_Variable_Indexing) then null; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 728e4a7a8d7..68edadfafd7 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -101,6 +101,11 @@ package body Sem_Ch6 is -- Local Subprograms -- ----------------------- + procedure Analyze_Null_Procedure + (N : Node_Id; + Is_Completion : out Boolean); + -- A null procedure can be a declaration or (Ada 2012) a completion. + procedure Analyze_Return_Statement (N : Node_Id); -- Common processing for simple and extended return statements @@ -327,14 +332,14 @@ package body Sem_Ch6 is end; end if; - Prev := Current_Entity_In_Scope (Defining_Entity (Spec)); + Prev := Current_Entity_In_Scope (Defining_Entity (Spec)); -- If there are previous overloadable entities with the same name, -- check whether any of them is completed by the expression function. if Present (Prev) and then Is_Overloadable (Prev) then - Def_Id := Analyze_Subprogram_Specification (Spec); - Prev := Find_Corresponding_Spec (N); + Def_Id := Analyze_Subprogram_Specification (Spec); + Prev := Find_Corresponding_Spec (N); end if; Ret := Make_Simple_Return_Statement (LocX, Expression (N)); @@ -362,9 +367,7 @@ package body Sem_Ch6 is Analyze (New_Body); Set_Is_Inlined (Prev); - elsif Present (Prev) - and then Comes_From_Source (Prev) - then + elsif Present (Prev) and then Comes_From_Source (Prev) then Set_Has_Completion (Prev, False); -- For navigation purposes, indicate that the function is a body @@ -436,9 +439,9 @@ package body Sem_Ch6 is begin if Nkind (Par) = N_Package_Specification - and then Decls = Visible_Declarations (Par) - and then Present (Private_Declarations (Par)) - and then not Is_Empty_List (Private_Declarations (Par)) + and then Decls = Visible_Declarations (Par) + and then Present (Private_Declarations (Par)) + and then not Is_Empty_List (Private_Declarations (Par)) then Decls := Private_Declarations (Par); end if; @@ -446,7 +449,18 @@ package body Sem_Ch6 is Insert_After (Last (Decls), New_Body); Push_Scope (Id); Install_Formals (Id); - Preanalyze_Spec_Expression (Expression (Ret), Etype (Id)); + + -- Do a preanalysis of the expression on a separate copy, to + -- prevent visibility issues later with operators in instances. + -- Attach copy to tree so that parent links are available. + + declare + Expr : constant Node_Id := New_Copy_Tree (Expression (Ret)); + begin + Set_Parent (Expr, Ret); + Preanalyze_Spec_Expression (Expr, Etype (Id)); + end; + End_Scope; end; end if; @@ -472,19 +486,19 @@ package body Sem_Ch6 is ---------------------------- procedure Analyze_Function_Call (N : Node_Id) is - P : constant Node_Id := Name (N); - Actuals : constant List_Id := Parameter_Associations (N); - Actual : Node_Id; + Actuals : constant List_Id := Parameter_Associations (N); + Func_Nam : constant Node_Id := Name (N); + Actual : Node_Id; begin - Analyze (P); + Analyze (Func_Nam); -- A call of the form A.B (X) may be an Ada 2005 call, which is -- rewritten as B (A, X). If the rewriting is successful, the call -- has been analyzed and we just return. - if Nkind (P) = N_Selected_Component - and then Name (N) /= P + if Nkind (Func_Nam) = N_Selected_Component + and then Name (N) /= Func_Nam and then Is_Rewrite_Substitution (N) and then Present (Etype (N)) then @@ -493,7 +507,7 @@ package body Sem_Ch6 is -- If error analyzing name, then set Any_Type as result type and return - if Etype (P) = Any_Type then + if Etype (Func_Nam) = Any_Type then Set_Etype (N, Any_Type); return; end if; @@ -510,12 +524,6 @@ package body Sem_Ch6 is end if; Analyze_Call (N); - - -- Mark function call if within assertion - - if In_Assertion_Expr /= 0 then - Set_In_Assertion (N); - end if; end Analyze_Function_Call; ----------------------------- @@ -523,9 +531,9 @@ package body Sem_Ch6 is ----------------------------- procedure Analyze_Function_Return (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Stm_Entity : constant Entity_Id := Return_Statement_Entity (N); - Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity); + Loc : constant Source_Ptr := Sloc (N); + Stm_Entity : constant Entity_Id := Return_Statement_Entity (N); + Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity); R_Type : constant Entity_Id := Etype (Scope_Id); -- Function result subtype @@ -882,7 +890,7 @@ package body Sem_Ch6 is if Present (Expr) - -- Defend against previous errors + -- Defend against previous errors and then Nkind (Expr) /= N_Empty and then Present (Etype (Expr)) @@ -1099,6 +1107,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_Ekind (Body_Id, E_Subprogram_Body); Set_Convention (Body_Id, Convention (Gen_Id)); Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id)); @@ -1139,7 +1148,7 @@ package body Sem_Ch6 is -- than inserted in the code, in order to facilitate a distinct -- treatment for them. - if not Alfa_Mode then + if not SPARK_Mode then Process_PPCs (N, Gen_Id, Body_Id); end if; @@ -1204,6 +1213,137 @@ package body Sem_Ch6 is End_Generic; end Analyze_Generic_Subprogram_Body; + ---------------------------- + -- Analyze_Null_Procedure -- + ---------------------------- + + procedure Analyze_Null_Procedure + (N : Node_Id; + Is_Completion : out Boolean) + is + Loc : constant Source_Ptr := Sloc (N); + Spec : constant Node_Id := Specification (N); + Designator : Entity_Id; + Form : Node_Id; + Null_Body : Node_Id := Empty; + Prev : Entity_Id; + + begin + -- Capture the profile of the null procedure before analysis, for + -- expansion at the freeze point and at each point of call. The body is + -- used if the procedure has preconditions, or if it is a completion. In + -- the first case the body is analyzed at the freeze point, in the other + -- it replaces the null procedure declaration. + + Null_Body := + Make_Subprogram_Body (Loc, + Specification => New_Copy_Tree (Spec), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Make_Null_Statement (Loc)))); + + -- Create new entities for body and formals + + Set_Defining_Unit_Name (Specification (Null_Body), + Make_Defining_Identifier (Loc, Chars (Defining_Entity (N)))); + + Form := First (Parameter_Specifications (Specification (Null_Body))); + while Present (Form) loop + Set_Defining_Identifier (Form, + Make_Defining_Identifier (Loc, Chars (Defining_Identifier (Form)))); + Next (Form); + end loop; + + -- Determine whether the null procedure may be a completion of a generic + -- suprogram, in which case we use the new null body as the completion + -- and set minimal semantic information on the original declaration, + -- which is rewritten as a null statement. + + Prev := Current_Entity_In_Scope (Defining_Entity (Spec)); + + if Present (Prev) and then Is_Generic_Subprogram (Prev) then + Insert_Before (N, Null_Body); + Set_Ekind (Defining_Entity (N), Ekind (Prev)); + Set_Contract (Defining_Entity (N), Make_Contract (Loc)); + + Rewrite (N, Make_Null_Statement (Loc)); + Analyze_Generic_Subprogram_Body (Null_Body, Prev); + Is_Completion := True; + return; + + else + + -- Resolve the types of the formals now, because the freeze point + -- may appear in a different context, e.g. an instantiation. + + Form := First (Parameter_Specifications (Specification (Null_Body))); + while Present (Form) loop + if Nkind (Parameter_Type (Form)) /= N_Access_Definition then + Find_Type (Parameter_Type (Form)); + + elsif + No (Access_To_Subprogram_Definition (Parameter_Type (Form))) + then + Find_Type (Subtype_Mark (Parameter_Type (Form))); + + else + -- The case of a null procedure with a formal that is an + -- access_to_subprogram type, and that is used as an actual + -- in an instantiation is left to the enthusiastic reader. + + null; + end if; + + Next (Form); + end loop; + end if; + + -- If there are previous overloadable entities with the same name, + -- check whether any of them is completed by the null procedure. + + if Present (Prev) and then Is_Overloadable (Prev) then + Designator := Analyze_Subprogram_Specification (Spec); + Prev := Find_Corresponding_Spec (N); + end if; + + if No (Prev) or else not Comes_From_Source (Prev) then + Designator := Analyze_Subprogram_Specification (Spec); + Set_Has_Completion (Designator); + + -- Signal to caller that this is a procedure declaration + + Is_Completion := False; + + -- Null procedures are always inlined, but generic formal subprograms + -- which appear as such in the internal instance of formal packages, + -- need no completion and are not marked Inline. + + if Expander_Active + and then Nkind (N) /= N_Formal_Concrete_Subprogram_Declaration + then + Set_Corresponding_Body (N, Defining_Entity (Null_Body)); + Set_Body_To_Inline (N, Null_Body); + Set_Is_Inlined (Designator); + end if; + + else + -- The null procedure is a completion + + Is_Completion := True; + + if Expander_Active then + Rewrite (N, Null_Body); + Analyze (N); + + else + Designator := Analyze_Subprogram_Specification (Spec); + Set_Has_Completion (Designator); + Set_Has_Completion (Prev); + end if; + end if; + end Analyze_Null_Procedure; + ----------------------------- -- Analyze_Operator_Symbol -- ----------------------------- @@ -1220,7 +1360,7 @@ package body Sem_Ch6 is begin if (Nkind (Par) = N_Function_Call - and then N = Name (Par)) + and then N = Name (Par)) or else Nkind (Par) = N_Function_Instantiation or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par)) @@ -1322,9 +1462,9 @@ package body Sem_Ch6 is -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls if Nkind (P) = N_Attribute_Reference - and then (Attribute_Name (P) = Name_Elab_Spec or else - Attribute_Name (P) = Name_Elab_Body or else - Attribute_Name (P) = Name_Elab_Subp_Body) + and then Nam_In (Attribute_Name (P), Name_Elab_Spec, + Name_Elab_Body, + Name_Elab_Subp_Body) then if Present (Actuals) then Error_Msg_N @@ -1410,11 +1550,9 @@ package body Sem_Ch6 is -- function, the context will select the operation whose type is Void. elsif Nkind (P) = N_Selected_Component - and then (Ekind (Entity (Selector_Name (P))) = E_Entry - or else - Ekind (Entity (Selector_Name (P))) = E_Procedure - or else - Ekind (Entity (Selector_Name (P))) = E_Function) + and then Ekind_In (Entity (Selector_Name (P)), E_Entry, + E_Procedure, + E_Function) then Analyze_Call_And_Resolve; @@ -1490,8 +1628,8 @@ package body Sem_Ch6 is Returns_Object : constant Boolean := Nkind (N) = N_Extended_Return_Statement or else - (Nkind (N) = N_Simple_Return_Statement - and then Present (Expression (N))); + (Nkind (N) = N_Simple_Return_Statement + and then Present (Expression (N))); -- True if we're returning something; that is, "return <expression>;" -- or "return Result : T [:= ...]". False for "return;". Used for error -- checking: If Returns_Object is True, N should apply to a function @@ -1685,9 +1823,7 @@ package body Sem_Ch6 is -- Unconstrained array as result is not allowed in SPARK - if Is_Array_Type (Typ) - and then not Is_Constrained (Typ) - then + if Is_Array_Type (Typ) and then not Is_Constrained (Typ) then Check_SPARK_Restriction ("returning an unconstrained array is not allowed", Result_Definition (N)); @@ -1703,9 +1839,7 @@ package body Sem_Ch6 is -- right before this, because they don't get applied to types that -- do not come from source. - if Is_Access_Type (Typ) - and then Null_Exclusion_Present (N) - then + if Is_Access_Type (Typ) and then Null_Exclusion_Present (N) then Set_Etype (Designator, Create_Null_Excluding_Itype (T => Typ, @@ -1752,8 +1886,7 @@ package body Sem_Ch6 is elsif Ekind (Typ) = E_Incomplete_Type or else (Is_Class_Wide_Type (Typ) - and then - Ekind (Root_Type (Typ)) = E_Incomplete_Type) + and then Ekind (Root_Type (Typ)) = E_Incomplete_Type) then -- AI05-0151: Tagged incomplete types are allowed in all formal -- parts. Untagged incomplete types are not allowed in bodies. @@ -1952,7 +2085,7 @@ package body Sem_Ch6 is Is_Limited_Record (Designated_Type (Etype (Scop))))) and then Expander_Active - -- Avoid cases with no tasking support + -- Avoid cases with no tasking support and then RTE_Available (RE_Current_Master) and then not Restriction_Active (No_Task_Hierarchy) @@ -2019,14 +2152,14 @@ package body Sem_Ch6 is return Nkind (N) = N_Pragma and then - (Pragma_Name (N) = Name_Inline_Always - or else + (Pragma_Name (N) = Name_Inline_Always + or else (Front_End_Inlining and then Pragma_Name (N) = Name_Inline)) and then - Chars - (Expression (First (Pragma_Argument_Associations (N)))) - = Chars (Body_Id); + Chars + (Expression (First (Pragma_Argument_Associations (N)))) = + Chars (Body_Id); end Is_Inline_Pragma; -- Start of processing for Check_Inline_Pragma @@ -2490,9 +2623,7 @@ package body Sem_Ch6 is -- part of the context of one of its subunits. No need to redo the -- analysis. - elsif Prev_Id = Body_Id - and then Has_Completion (Body_Id) - then + elsif Prev_Id = Body_Id and then Has_Completion (Body_Id) then return; else @@ -2545,10 +2676,11 @@ package body Sem_Ch6 is end if; -- Ada 2012 aspects may appear in a subprogram body, but only if there - -- is no previous spec. + -- is no previous spec. Ditto for a subprogram stub that does not have + -- a corresponding spec, but for which there may also be a spec_id. if Has_Aspects (N) then - if Present (Corresponding_Spec (N)) then + if Present (Spec_Id) then Error_Msg_N ("aspect specifications must appear in subprogram declaration", N); @@ -2658,8 +2790,8 @@ package body Sem_Ch6 is (Nkind (Original_Node (Spec_Decl)) = N_Subprogram_Renaming_Declaration or else (Present (Corresponding_Body (Spec_Decl)) - and then - Nkind (Unit_Declaration_Node + and then + Nkind (Unit_Declaration_Node (Corresponding_Body (Spec_Decl))) = N_Subprogram_Renaming_Declaration)) then @@ -2771,6 +2903,7 @@ package body Sem_Ch6 is end if; Set_Corresponding_Body (Unit_Declaration_Node (Spec_Id), Body_Id); + Set_Contract (Body_Id, Empty); Set_Ekind (Body_Id, E_Subprogram_Body); Set_Scope (Body_Id, Scope (Spec_Id)); Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id)); @@ -2821,9 +2954,7 @@ package body Sem_Ch6 is -- is the limited view of a class-wide type and the non-limited view is -- available, update the return type accordingly. - if Ada_Version >= Ada_2005 - and then Comes_From_Source (N) - then + if Ada_Version >= Ada_2005 and then Comes_From_Source (N) then declare Etyp : Entity_Id; Rtyp : Entity_Id; @@ -2834,9 +2965,7 @@ 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_With_Type (Etyp) then Set_Directly_Designated_Type (Etype (Current_Scope), Available_View (Etyp)); end if; @@ -2898,7 +3027,7 @@ package body Sem_Ch6 is and then Expander_Active and then (Has_Pragma_Inline_Always (Spec_Id) - or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining)) + or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining)) then Build_Body_To_Inline (N, Spec_Id); end if; @@ -2963,7 +3092,7 @@ package body Sem_Ch6 is -- than inserted in the code, in order to facilitate a distinct -- treatment for them. - if not Alfa_Mode then + if not SPARK_Mode then Process_PPCs (N, Spec_Id, Body_Id); end if; @@ -3193,84 +3322,311 @@ package body Sem_Ch6 is end; end Analyze_Subprogram_Body_Helper; - ------------------------------------ - -- Analyze_Subprogram_Declaration -- - ------------------------------------ + --------------------------------- + -- Analyze_Subprogram_Contract -- + --------------------------------- - procedure Analyze_Subprogram_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Scop : constant Entity_Id := Current_Scope; - Designator : Entity_Id; - Form : Node_Id; - Null_Body : Node_Id := Empty; + procedure Analyze_Subprogram_Contract (Subp : Entity_Id) is + Result_Seen : Boolean := False; + -- A flag which keeps track of whether at least one postcondition or + -- contract-case mentions attribute 'Result (set True if so). - -- Start of processing for Analyze_Subprogram_Declaration + procedure Check_Result_And_Post_State + (Prag : Node_Id; + Error_Nod : in out Node_Id); + -- Determine whether pragma Prag mentions attribute 'Result and whether + -- the pragma contains an expression that evaluates differently in pre- + -- and post-state. Prag is a postcondition or a contract-cases pragma. + -- Error_Nod denotes the proper error node. - begin - -- Null procedures are not allowed in SPARK + --------------------------------- + -- Check_Result_And_Post_State -- + --------------------------------- - if Nkind (Specification (N)) = N_Procedure_Specification - and then Null_Present (Specification (N)) - then - Check_SPARK_Restriction ("null procedure is not allowed", N); - end if; + procedure Check_Result_And_Post_State + (Prag : Node_Id; + Error_Nod : in out Node_Id) + is + procedure Check_Expression (Expr : Node_Id); + -- Perform the 'Result and post-state checks on a given expression - -- For a null procedure, capture the profile before analysis, for - -- expansion at the freeze point and at each point of call. The body - -- will only be used if the procedure has preconditions. In that case - -- the body is analyzed at the freeze point. + function Is_Function_Result (N : Node_Id) return Traverse_Result; + -- Attempt to find attribute 'Result in a subtree denoted by N - if Nkind (Specification (N)) = N_Procedure_Specification - and then Null_Present (Specification (N)) - and then Expander_Active - then - Null_Body := - Make_Subprogram_Body (Loc, - Specification => - New_Copy_Tree (Specification (N)), - Declarations => - New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Make_Null_Statement (Loc)))); + function Is_Trivial_Boolean (N : Node_Id) return Boolean; + -- Determine whether source node N denotes "True" or "False" - -- Create new entities for body and formals + function Mentions_Post_State (N : Node_Id) return Boolean; + -- Determine whether a subtree denoted by N mentions any construct + -- that denotes a post-state. - Set_Defining_Unit_Name (Specification (Null_Body), - Make_Defining_Identifier (Loc, Chars (Defining_Entity (N)))); + procedure Check_Function_Result is + new Traverse_Proc (Is_Function_Result); - Form := First (Parameter_Specifications (Specification (Null_Body))); - while Present (Form) loop - Set_Defining_Identifier (Form, - Make_Defining_Identifier (Loc, - Chars (Defining_Identifier (Form)))); + ---------------------- + -- Check_Expression -- + ---------------------- - -- Resolve the types of the formals now, because the freeze point - -- may appear in a different context, e.g. an instantiation. + procedure Check_Expression (Expr : Node_Id) is + begin + if not Is_Trivial_Boolean (Expr) then + Check_Function_Result (Expr); - if Nkind (Parameter_Type (Form)) /= N_Access_Definition then - Find_Type (Parameter_Type (Form)); + if not Mentions_Post_State (Expr) then + if Pragma_Name (Prag) = Name_Contract_Cases then + Error_Msg_N + ("contract case refers only to pre-state?T?", Expr); + else + Error_Msg_N + ("postcondition refers only to pre-state?T?", Prag); + end if; + end if; + end if; + end Check_Expression; - elsif - No (Access_To_Subprogram_Definition (Parameter_Type (Form))) + ------------------------ + -- Is_Function_Result -- + ------------------------ + + function Is_Function_Result (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Result then - Find_Type (Subtype_Mark (Parameter_Type (Form))); + Result_Seen := True; + return Abandon; + + -- Continue the traversal else + return OK; + end if; + end Is_Function_Result; - -- the case of a null procedure with a formal that is an - -- access_to_subprogram type, and that is used as an actual - -- in an instantiation is left to the enthusiastic reader. + ------------------------ + -- Is_Trivial_Boolean -- + ------------------------ - null; + function Is_Trivial_Boolean (N : Node_Id) return Boolean is + begin + return + Comes_From_Source (N) + and then Is_Entity_Name (N) + and then (Entity (N) = Standard_True + or else Entity (N) = Standard_False); + end Is_Trivial_Boolean; + + ------------------------- + -- Mentions_Post_State -- + ------------------------- + + function Mentions_Post_State (N : Node_Id) return Boolean is + Post_State_Seen : Boolean := False; + + function Is_Post_State (N : Node_Id) return Traverse_Result; + -- Attempt to find a construct that denotes a post-state. If this + -- is the case, set flag Post_State_Seen. + + ------------------- + -- Is_Post_State -- + ------------------- + + function Is_Post_State (N : Node_Id) return Traverse_Result is + Ent : Entity_Id; + + begin + if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then + Post_State_Seen := True; + return Abandon; + + elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then + Ent := Entity (N); + + if No (Ent) or else Ekind (Ent) in Assignable_Kind then + Post_State_Seen := True; + return Abandon; + end if; + + elsif Nkind (N) = N_Attribute_Reference then + if Attribute_Name (N) = Name_Old then + return Skip; + elsif Attribute_Name (N) = Name_Result then + Post_State_Seen := True; + return Abandon; + end if; + end if; + + return OK; + end Is_Post_State; + + procedure Find_Post_State is new Traverse_Proc (Is_Post_State); + + -- Start of processing for Mentions_Post_State + + begin + Find_Post_State (N); + return Post_State_Seen; + end Mentions_Post_State; + + -- Local variables + + Expr : constant Node_Id := + Expression (First (Pragma_Argument_Associations (Prag))); + Nam : constant Name_Id := Pragma_Name (Prag); + CCase : Node_Id; + + -- Start of processing for Check_Result_And_Post_State + + begin + if No (Error_Nod) then + Error_Nod := Prag; + end if; + + -- Examine all consequences + + if Nam = Name_Contract_Cases then + CCase := First (Component_Associations (Expr)); + while Present (CCase) loop + Check_Expression (Expression (CCase)); + + Next (CCase); + end loop; + + -- Examine the expression of a postcondition + + else + pragma Assert (Nam = Name_Postcondition); + Check_Expression (Expr); + end if; + end Check_Result_And_Post_State; + + -- Local variables + + Items : constant Node_Id := Contract (Subp); + Error_CCase : Node_Id; + Error_Post : Node_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); + + -- Verify whether a postcondition mentions attribute 'Result and + -- its expression introduces a post-state. + + if Warn_On_Suspicious_Contract + and then Pragma_Name (Prag) = Name_Postcondition + then + Check_Result_And_Post_State (Prag, Error_Post); end if; - Next (Form); + Prag := Next_Pragma (Prag); + end loop; + + -- Analyze contract-cases and test-cases + + Prag := Contract_Test_Cases (Items); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Contract_Cases then + Analyze_Contract_Cases_In_Decl_Part (Prag); + + -- Verify whether contract-cases mention attribute 'Result and + -- its expression introduces a post-state. Perform the check + -- only when the pragma is legal. + + if Warn_On_Suspicious_Contract + and then not Error_Posted (Prag) + then + Check_Result_And_Post_State (Prag, Error_CCase); + end if; + + else + pragma Assert (Pragma_Name (Prag) = Name_Test_Case); + Analyze_Test_Case_In_Decl_Part (Prag, Subp); + end if; + + Prag := Next_Pragma (Prag); + end loop; + + -- Analyze classification pragmas + + 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); + end if; + + Prag := Next_Pragma (Prag); end loop; + end if; + + -- Emit an error when none of the postconditions or contract-cases + -- mention attribute 'Result in the context of a function. + + if Warn_On_Suspicious_Contract + and then Ekind_In (Subp, E_Function, E_Generic_Function) + and then not Result_Seen + then + if Present (Error_Post) and then Present (Error_CCase) then + Error_Msg_N + ("neither function postcondition nor contract cases mention " + & "result?T?", Error_Post); + + elsif Present (Error_Post) then + Error_Msg_N + ("function postcondition does not mention result?T?", + Error_Post); + + elsif Present (Error_CCase) then + Error_Msg_N + ("contract cases do not mention result?T?", Error_CCase); + end if; + end if; + end Analyze_Subprogram_Contract; + + ------------------------------------ + -- Analyze_Subprogram_Declaration -- + ------------------------------------ + + procedure Analyze_Subprogram_Declaration (N : Node_Id) is + Scop : constant Entity_Id := Current_Scope; + Designator : Entity_Id; + Is_Completion : Boolean; + -- Indicates whether a null procedure declaration is a completion + + begin + -- Null procedures are not allowed in SPARK + + if Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) + then + Check_SPARK_Restriction ("null procedure is not allowed", N); if Is_Protected_Type (Current_Scope) then Error_Msg_N ("protected operation cannot be a null procedure", N); end if; + + Analyze_Null_Procedure (N, Is_Completion); + + if Is_Completion then + + -- The null procedure acts as a body, nothing further is needed. + + return; + end if; end if; Designator := Analyze_Subprogram_Specification (Specification (N)); @@ -3290,30 +3646,12 @@ package body Sem_Ch6 is Indent; end if; - if Nkind (Specification (N)) = N_Procedure_Specification - and then Null_Present (Specification (N)) - then - Set_Has_Completion (Designator); - - -- Null procedures are always inlined, but generic formal subprograms - -- which appear as such in the internal instance of formal packages, - -- need no completion and are not marked Inline. - - if Present (Null_Body) - and then Nkind (N) /= N_Formal_Concrete_Subprogram_Declaration - then - Set_Corresponding_Body (N, Defining_Entity (Null_Body)); - Set_Body_To_Inline (N, Null_Body); - Set_Is_Inlined (Designator); - end if; - end if; - Validate_RCI_Subprogram_Declaration (N); New_Overloaded_Entity (Designator); Check_Delayed_Subprogram (Designator); -- If the type of the first formal of the current subprogram is a - -- nongeneric tagged private type, mark the subprogram as being a + -- non-generic tagged private type, mark the subprogram as being a -- private primitive. Ditto if this is a function with controlling -- result, and the return type is currently private. In both cases, -- the type of the controlling argument or result must be in the @@ -3373,7 +3711,7 @@ package body Sem_Ch6 is if Is_Interface (Etyp) and then not Is_Abstract_Subprogram (Designator) and then not (Ekind (Designator) = E_Procedure - and then Null_Present (Specification (N))) + and then Null_Present (Specification (N))) then Error_Msg_Name_1 := Chars (Defining_Entity (N)); @@ -3401,10 +3739,9 @@ package body Sem_Ch6 is Set_Kill_Elaboration_Checks (Designator); end if; - if Scop /= Standard_Standard - and then not Is_Child_Unit (Designator) - then + if Scop /= Standard_Standard and then not Is_Child_Unit (Designator) then Set_Categorization_From_Scope (Designator, Scop); + else -- For a compilation unit, check for library-unit pragmas @@ -3890,7 +4227,7 @@ package body Sem_Ch6 is elsif No (Expression (N)) and then Nkind (Parent (Parent (N))) = - N_Extended_Return_Statement + N_Extended_Return_Statement then return OK; @@ -3932,7 +4269,7 @@ package body Sem_Ch6 is return Present (Declarations (N)) and then Present (First (Declarations (N))) and then Chars (Expression (Return_Statement)) = - Chars (Defining_Identifier (First (Declarations (N)))); + Chars (Defining_Identifier (First (Declarations (N)))); end if; end Has_Single_Return; @@ -3950,9 +4287,8 @@ package body Sem_Ch6 is Nxt := Next (Decl); if Nkind (Decl) = N_Pragma - and then (Pragma_Name (Decl) = Name_Unreferenced - or else - Pragma_Name (Decl) = Name_Unmodified) + and then Nam_In (Pragma_Name (Decl), Name_Unreferenced, + Name_Unmodified) then Remove (Decl); end if; @@ -4455,8 +4791,8 @@ package body Sem_Ch6 is Conv := Current_Entity (Id); elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name) - and then Chars (Selector_Name (Id)) - = Name_Unchecked_Conversion + and then + Chars (Selector_Name (Id)) = Name_Unchecked_Conversion then Conv := Current_Entity (Selector_Name (Id)); else @@ -4809,8 +5145,8 @@ package body Sem_Ch6 is May_Inline : constant Boolean := Has_Pragma_Inline_Always (Spec_Id) or else (Has_Pragma_Inline (Spec_Id) - and then ((Optimization_Level > 0 - and then Ekind (Spec_Id) + and then ((Optimization_Level > 0 + and then Ekind (Spec_Id) = E_Function) or else Front_End_Inlining)); Body_To_Analyze : Node_Id; @@ -5040,9 +5376,8 @@ package body Sem_Ch6 is Nxt := Next (Decl); if Nkind (Decl) = N_Pragma - and then (Pragma_Name (Decl) = Name_Unreferenced - or else - Pragma_Name (Decl) = Name_Unmodified) + and then Nam_In (Pragma_Name (Decl), Name_Unreferenced, + Name_Unmodified) then Remove (Decl); end if; @@ -5493,10 +5828,9 @@ package body Sem_Ch6 is if Ada_Version >= Ada_2005 and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type and then - (Can_Never_Be_Null (Old_Type) - /= Can_Never_Be_Null (New_Type) - or else Is_Access_Constant (Etype (Old_Type)) - /= Is_Access_Constant (Etype (New_Type))) + (Can_Never_Be_Null (Old_Type) /= Can_Never_Be_Null (New_Type) + or else Is_Access_Constant (Etype (Old_Type)) /= + Is_Access_Constant (Etype (New_Type))) then Conformance_Error ("\return type does not match!", New_Id); return; @@ -5519,7 +5853,6 @@ package body Sem_Ch6 is if Ctype >= Subtype_Conformant then if Convention (Old_Id) /= Convention (New_Id) then - if not Is_Frozen (New_Id) then null; @@ -5646,8 +5979,8 @@ package body Sem_Ch6 is Access_Types_Match := Ada_Version >= Ada_2005 - -- Ensure that this rule is only applied when New_Id is a - -- renaming of Old_Id. + -- Ensure that this rule is only applied when New_Id is a + -- renaming of Old_Id. and then Nkind (Parent (Parent (New_Id))) = N_Subprogram_Renaming_Declaration @@ -5655,26 +5988,26 @@ package body Sem_Ch6 is and then Present (Entity (Name (Parent (Parent (New_Id))))) and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id - -- Now handle the allowed access-type case + -- Now handle the allowed access-type case and then Is_Access_Type (Old_Formal_Base) and then Is_Access_Type (New_Formal_Base) - -- The type kinds must match. The only exception occurs with - -- multiple generics of the form: + -- The type kinds must match. The only exception occurs with + -- multiple generics of the form: - -- generic generic - -- type F is private; type A is private; - -- type F_Ptr is access F; type A_Ptr is access A; - -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr); - -- package F_Pack is ... package A_Pack is - -- package F_Inst is - -- new F_Pack (A, A_Ptr, A_P); + -- generic generic + -- type F is private; type A is private; + -- type F_Ptr is access F; type A_Ptr is access A; + -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr); + -- package F_Pack is ... package A_Pack is + -- package F_Inst is + -- new F_Pack (A, A_Ptr, A_P); - -- When checking for conformance between the parameters of A_P - -- and F_P, the type kinds of F_Ptr and A_Ptr will not match - -- because the compiler has transformed A_Ptr into a subtype of - -- F_Ptr. We catch this case in the code below. + -- When checking for conformance between the parameters of A_P + -- and F_P, the type kinds of F_Ptr and A_Ptr will not match + -- because the compiler has transformed A_Ptr into a subtype of + -- F_Ptr. We catch this case in the code below. and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base) or else @@ -5684,7 +6017,7 @@ package body Sem_Ch6 is and then Etype (Etype (New_Formal_Base)) = Old_Formal_Base)) and then Directly_Designated_Type (Old_Formal_Base) = - Directly_Designated_Type (New_Formal_Base) + Directly_Designated_Type (New_Formal_Base) and then ((Is_Itype (Old_Formal_Base) and then Can_Never_Be_Null (Old_Formal_Base)) or else @@ -5959,26 +6292,51 @@ package body Sem_Ch6 is ---------------------- procedure Check_Convention (Op : Entity_Id) is + function Convention_Of (Id : Entity_Id) return Convention_Id; + -- Given an entity, return its convention. The function treats Ghost + -- as convention Ada because the two have the same dynamic semantics. + + ------------------- + -- Convention_Of -- + ------------------- + + function Convention_Of (Id : Entity_Id) return Convention_Id is + Conv : constant Convention_Id := Convention (Id); + begin + if Conv = Convention_Ghost then + return Convention_Ada; + else + return Conv; + end if; + end Convention_Of; + + -- Local variables + + Op_Conv : constant Convention_Id := Convention_Of (Op); + Iface_Conv : Convention_Id; Iface_Elmt : Elmt_Id; Iface_Prim_Elmt : Elmt_Id; Iface_Prim : Entity_Id; + -- Start of processing for Check_Convention + begin Iface_Elmt := First_Elmt (Ifaces_List); while Present (Iface_Elmt) loop Iface_Prim_Elmt := - First_Elmt (Primitive_Operations (Node (Iface_Elmt))); + First_Elmt (Primitive_Operations (Node (Iface_Elmt))); while Present (Iface_Prim_Elmt) loop Iface_Prim := Node (Iface_Prim_Elmt); + Iface_Conv := Convention_Of (Iface_Prim); if Is_Interface_Conformant (Typ, Iface_Prim, Op) - and then Convention (Iface_Prim) /= Convention (Op) + and then Iface_Conv /= Op_Conv then Error_Msg_N ("inconsistent conventions in primitive operations", Typ); Error_Msg_Name_1 := Chars (Op); - Error_Msg_Name_2 := Get_Convention_Name (Convention (Op)); + Error_Msg_Name_2 := Get_Convention_Name (Op_Conv); Error_Msg_Sloc := Sloc (Op); if Comes_From_Source (Op) or else No (Alias (Op)) then @@ -5998,9 +6356,8 @@ package body Sem_Ch6 is end if; Error_Msg_Name_1 := Chars (Op); - Error_Msg_Name_2 := - Get_Convention_Name (Convention (Iface_Prim)); - Error_Msg_Sloc := Sloc (Iface_Prim); + Error_Msg_Name_2 := Get_Convention_Name (Iface_Conv); + Error_Msg_Sloc := Sloc (Iface_Prim); Error_Msg_N ("\\overridden operation % with " & "convention % defined #", Typ); @@ -6116,17 +6473,13 @@ package body Sem_Ch6 is -- done for delayed_freeze subprograms because the underlying -- returned type may not be known yet (for private types) - if not Has_Delayed_Freeze (Designator) - and then Expander_Active - then + if not Has_Delayed_Freeze (Designator) and then Expander_Active then declare Typ : constant Entity_Id := Etype (Designator); Utyp : constant Entity_Id := Underlying_Type (Typ); - begin if Is_Immutably_Limited_Type (Typ) then Set_Returns_By_Ref (Designator); - elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Designator); end if; @@ -6190,7 +6543,7 @@ package body Sem_Ch6 is -- with partial declaration. if Is_Access_Type (New_Discr_Type) - and then Null_Exclusion_Present (New_Discr) + and then Null_Exclusion_Present (New_Discr) then New_Discr_Type := Create_Null_Excluding_Itype @@ -6445,11 +6798,9 @@ package body Sem_Ch6 is if Present (Overridden_Subp) and then (not Is_Hidden (Overridden_Subp) or else - ((Chars (Overridden_Subp) = Name_Initialize - or else - Chars (Overridden_Subp) = Name_Adjust - or else - Chars (Overridden_Subp) = Name_Finalize) + (Nam_In (Chars (Overridden_Subp), Name_Initialize, + Name_Adjust, + Name_Finalize) and then Present (Alias (Overridden_Subp)) and then not Is_Hidden (Alias (Overridden_Subp)))) then @@ -6678,9 +7029,7 @@ package body Sem_Ch6 is -- sequences (which were the original sequences of statements in -- the exception handlers) and check them. - if Nkind (Last_Stm) = N_Label - and then Exception_Junk (Last_Stm) - then + if Nkind (Last_Stm) = N_Label and then Exception_Junk (Last_Stm) then Stm := Last_Stm; loop Prev (Stm); @@ -6721,7 +7070,7 @@ package body Sem_Ch6 is (Nkind_In (Last_Stm, N_Goto_Statement, N_Label, N_Object_Declaration) - and then Exception_Junk (Last_Stm)) + and then Exception_Junk (Last_Stm)) or else Nkind (Last_Stm) in N_Push_xxx_Label or else Nkind (Last_Stm) in N_Pop_xxx_Label @@ -6982,340 +7331,6 @@ package body Sem_Ch6 is end if; end Check_Returns; - ------------------------------- - -- Check_Subprogram_Contract -- - ------------------------------- - - procedure Check_Subprogram_Contract (Spec_Id : Entity_Id) is - - -- Code is currently commented out as, in some cases, it causes crashes - -- because Direct_Primitive_Operations is not available for a private - -- type. This may cause more warnings to be issued than necessary. See - -- below for the intended use of this variable. ??? - --- Inherited : constant Subprogram_List := --- Inherited_Subprograms (Spec_Id); --- -- List of subprograms inherited by this subprogram - - -- We ignore postconditions "True" or "False" and contract-cases which - -- have similar Ensures components, which we call "trivial", when - -- issuing warnings, since these postconditions and contract-cases - -- purposedly ignore the post-state. - - Last_Postcondition : Node_Id := Empty; - -- Last non-trivial postcondition on the subprogram, or else Empty if - -- either no non-trivial postcondition or only inherited postconditions. - - Last_Contract_Case : Node_Id := Empty; - -- Last non-trivial contract-case on the subprogram, or else Empty - - Attribute_Result_Mentioned : Boolean := False; - -- Whether attribute 'Result is mentioned in a non-trivial postcondition - -- or contract-case. - - No_Warning_On_Some_Postcondition : Boolean := False; - -- Whether there exists a non-trivial postcondition or contract-case - -- without a corresponding warning. - - Post_State_Mentioned : Boolean := False; - -- Whether some expression mentioned in a postcondition or contract-case - -- can have a different value in the post-state than in the pre-state. - - function Check_Attr_Result (N : Node_Id) return Traverse_Result; - -- Check if N is a reference to the attribute 'Result, and if so set - -- Attribute_Result_Mentioned and return Abandon. Otherwise return OK. - - function Check_Post_State (N : Node_Id) return Traverse_Result; - -- Check whether the value of evaluating N can be different in the - -- post-state, compared to the same evaluation in the pre-state, and - -- if so set Post_State_Mentioned and return Abandon. Return Skip on - -- reference to attribute 'Old, in order to ignore its prefix, which - -- is precisely evaluated in the pre-state. Otherwise return OK. - - function Is_Trivial_Post_Or_Ensures (N : Node_Id) return Boolean; - -- Return True if node N is trivially "True" or "False", and it comes - -- from source. In particular, nodes that are statically known "True" or - -- "False" by the compiler but not written as such in source code are - -- not considered as trivial. - - procedure Process_Contract_Cases (Spec : Node_Id); - -- This processes the Spec_CTC_List from Spec, processing any contract - -- case from the list. The caller has checked that Spec_CTC_List is - -- non-Empty. - - procedure Process_Post_Conditions (Spec : Node_Id; Class : Boolean); - -- This processes the Spec_PPC_List from Spec, processing any - -- postcondition from the list. If Class is True, then only - -- postconditions marked with Class_Present are considered. The - -- caller has checked that Spec_PPC_List is non-Empty. - - function Find_Attribute_Result is new Traverse_Func (Check_Attr_Result); - - function Find_Post_State is new Traverse_Func (Check_Post_State); - - ----------------------- - -- Check_Attr_Result -- - ----------------------- - - function Check_Attr_Result (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Attribute_Reference - and then Get_Attribute_Id (Attribute_Name (N)) = Attribute_Result - then - Attribute_Result_Mentioned := True; - return Abandon; - else - return OK; - end if; - end Check_Attr_Result; - - ---------------------- - -- Check_Post_State -- - ---------------------- - - function Check_Post_State (N : Node_Id) return Traverse_Result is - Found : Boolean := False; - - begin - case Nkind (N) is - when N_Function_Call | - N_Explicit_Dereference => - Found := True; - - when N_Identifier | - N_Expanded_Name => - - declare - E : constant Entity_Id := Entity (N); - - begin - -- ???Quantified expressions get analyzed later, so E can - -- be empty at this point. In this case, we suppress the - -- warning, just in case E is assignable. It seems better to - -- have false negatives than false positives. At some point, - -- we should make the warning more accurate, either by - -- analyzing quantified expressions earlier, or moving - -- this processing later. - - if No (E) - or else - (Is_Entity_Name (N) - and then Ekind (E) in Assignable_Kind) - then - Found := True; - end if; - end; - - when N_Attribute_Reference => - case Get_Attribute_Id (Attribute_Name (N)) is - when Attribute_Old => - return Skip; - when Attribute_Result => - Found := True; - when others => - null; - end case; - - when others => - null; - end case; - - if Found then - Post_State_Mentioned := True; - return Abandon; - else - return OK; - end if; - end Check_Post_State; - - -------------------------------- - -- Is_Trivial_Post_Or_Ensures -- - -------------------------------- - - function Is_Trivial_Post_Or_Ensures (N : Node_Id) return Boolean is - begin - return Is_Entity_Name (N) - and then (Entity (N) = Standard_True - or else - Entity (N) = Standard_False) - and then Comes_From_Source (N); - end Is_Trivial_Post_Or_Ensures; - - ---------------------------- - -- Process_Contract_Cases -- - ---------------------------- - - procedure Process_Contract_Cases (Spec : Node_Id) is - Prag : Node_Id; - Arg : Node_Id; - - Ignored : Traverse_Final_Result; - pragma Unreferenced (Ignored); - - begin - Prag := Spec_CTC_List (Contract (Spec)); - loop - -- Retrieve the Ensures component of the contract-case, if any - - Arg := Get_Ensures_From_CTC_Pragma (Prag); - - -- Ignore trivial contract-case when Ensures component is "True" - -- or "False". - - if Pragma_Name (Prag) = Name_Contract_Case - and then not Is_Trivial_Post_Or_Ensures (Expression (Arg)) - then - -- Since contract-cases are listed in reverse order, the first - -- contract-case in the list is the last in the source. - - if No (Last_Contract_Case) then - Last_Contract_Case := Prag; - end if; - - -- For functions, look for presence of 'Result in Ensures - - if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then - Ignored := Find_Attribute_Result (Arg); - end if; - - -- For each individual contract-case, look for presence - -- of an expression that could be evaluated differently - -- in post-state. - - Post_State_Mentioned := False; - Ignored := Find_Post_State (Arg); - - if Post_State_Mentioned then - No_Warning_On_Some_Postcondition := True; - else - Error_Msg_N - ("`Ensures` component refers only to pre-state??", Prag); - end if; - 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 - Prag : Node_Id; - Arg : Node_Id; - Ignored : Traverse_Final_Result; - pragma Unreferenced (Ignored); - - begin - Prag := Spec_PPC_List (Contract (Spec)); - loop - Arg := First (Pragma_Argument_Associations (Prag)); - - -- Ignore trivial postcondition of "True" or "False" - - if Pragma_Name (Prag) = Name_Postcondition - and then not Is_Trivial_Post_Or_Ensures (Expression (Arg)) - then - -- Since pre- and post-conditions are listed in reverse order, - -- the first postcondition in the list is last in the source. - - if not Class and then No (Last_Postcondition) then - Last_Postcondition := Prag; - end if; - - -- For functions, look for presence of 'Result in postcondition - - if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then - Ignored := Find_Attribute_Result (Arg); - end if; - - -- For each individual non-inherited postcondition, look - -- for presence of an expression that could be evaluated - -- differently in post-state. - - if not Class then - Post_State_Mentioned := False; - Ignored := Find_Post_State (Arg); - - if Post_State_Mentioned then - No_Warning_On_Some_Postcondition := True; - else - Error_Msg_N - ("postcondition refers only to pre-state??", Prag); - end if; - end if; - end if; - - Prag := Next_Pragma (Prag); - exit when No (Prag); - end loop; - end Process_Post_Conditions; - - -- Start of processing for Check_Subprogram_Contract - - begin - if not Warn_On_Suspicious_Contract then - return; - end if; - - -- Process spec postconditions - - if Present (Spec_PPC_List (Contract (Spec_Id))) then - Process_Post_Conditions (Spec_Id, Class => False); - end if; - - -- Process inherited postconditions - - -- Code is currently commented out as, in some cases, it causes crashes - -- because Direct_Primitive_Operations is not available for a private - -- type. This may cause more warnings to be issued than necessary. ??? - --- for J in Inherited'Range loop --- if Present (Spec_PPC_List (Contract (Inherited (J)))) then --- Process_Post_Conditions (Inherited (J), Class => True); --- end if; --- end loop; - - -- Process contract cases - - if Present (Spec_CTC_List (Contract (Spec_Id))) then - Process_Contract_Cases (Spec_Id); - end if; - - -- Issue warning for functions whose postcondition does not mention - -- 'Result after all postconditions have been processed, and provided - -- all postconditions do not already get a warning that they only refer - -- to pre-state. - - if Ekind_In (Spec_Id, E_Function, E_Generic_Function) - and then (Present (Last_Postcondition) - or else Present (Last_Contract_Case)) - and then not Attribute_Result_Mentioned - and then No_Warning_On_Some_Postcondition - then - if Present (Last_Postcondition) then - if Present (Last_Contract_Case) then - Error_Msg_N - ("neither function postcondition nor " - & "contract cases mention result?T?", Last_Postcondition); - - else - Error_Msg_N - ("function postcondition does not mention result?T?", - Last_Postcondition); - end if; - else - Error_Msg_N - ("contract cases do not mention result?T?", Last_Contract_Case); - end if; - end if; - end Check_Subprogram_Contract; - ---------------------------- -- Check_Subprogram_Order -- ---------------------------- @@ -7511,11 +7526,14 @@ package body Sem_Ch6 is ---------------------- function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is + BT1 : constant Entity_Id := Base_Type (T1); + BT2 : constant Entity_Id := Base_Type (T2); + begin if T1 = T2 then return True; - elsif Base_Type (T1) = Base_Type (T2) then + elsif BT1 = BT2 then -- The following is too permissive. A more precise test should -- check that the generic actual is an ancestor subtype of the @@ -7528,6 +7546,16 @@ package body Sem_Ch6 is or else not Is_Generic_Actual_Type (T2) or else Scope (T1) /= Scope (T2); + -- If T2 is a generic actual type it is declared as the subtype of + -- the actual. If that actual is itself a subtype we need to use its + -- own base type to check for compatibility. + + elsif Ekind (BT2) = Ekind (T2) and then BT1 = Base_Type (BT2) then + return True; + + elsif Ekind (BT1) = Ekind (T1) and then BT2 = Base_Type (BT1) then + return True; + else return False; end if; @@ -7572,14 +7600,10 @@ 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_With_Type (T1) and then T2 = Available_View (T1) then return True; - elsif From_With_Type (T2) - and then T1 = Available_View (T2) - then + elsif From_With_Type (T2) and then T1 = Available_View (T2) then return True; elsif From_With_Type (T1) @@ -7596,10 +7620,9 @@ package body Sem_Ch6 is -- Start of processing for Conforming_Types begin - -- The context is an instance association for a formal - -- access-to-subprogram type; the formal parameter types require - -- mapping because they may denote other formal parameters of the - -- generic unit. + -- The context is an instance association for a formal access-to- + -- subprogram type; the formal parameter types require mapping because + -- they may denote other formal parameters of the generic unit. if Get_Inst then Type_1 := Get_Instance_Of (T1); @@ -7645,9 +7668,8 @@ package body Sem_Ch6 is Are_Anonymous_Access_To_Subprogram_Types := Ekind (Type_1) = Ekind (Type_2) and then - (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type - or else - Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type); + Ekind_In (Type_1, E_Anonymous_Access_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type); -- Test anonymous access type case. For this case, static subtype -- matching is required for mode conformance (RM 6.3.1(15)). We check @@ -7657,7 +7679,10 @@ package body Sem_Ch6 is if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type and then Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type) - or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254) + + -- Ada 2005 (AI-254) + + or else Are_Anonymous_Access_To_Subprogram_Types then declare Desig_1 : Entity_Id; @@ -7725,8 +7750,8 @@ package body Sem_Ch6 is else return Base_Type (Desig_1) = Base_Type (Desig_2) and then (Ctype = Type_Conformant - or else - Subtypes_Statically_Match (Desig_1, Desig_2)); + or else + Subtypes_Statically_Match (Desig_1, Desig_2)); end if; end; @@ -7736,7 +7761,7 @@ package body Sem_Ch6 is if ((Ekind (Type_1) = E_Anonymous_Access_Type and then Is_Access_Type (Type_2)) or else (Ekind (Type_2) = E_Anonymous_Access_Type - and then Is_Access_Type (Type_1))) + and then Is_Access_Type (Type_1))) and then Conforming_Types (Designated_Type (Type_1), Designated_Type (Type_2), Ctype) @@ -7826,13 +7851,20 @@ package body Sem_Ch6 is -- Start of processing for Create_Extra_Formals begin - -- We never generate extra formals if expansion is not active - -- because we don't need them unless we are generating code. + -- We never generate extra formals if expansion is not active because we + -- don't need them unless we are generating code. if not Expander_Active then return; end if; + -- No need to generate extra formals in interface thunks whose target + -- primitive has no extra formals. + + if Is_Thunk (E) and then No (Extra_Formals (Thunk_Entity (E))) then + return; + end if; + -- If this is a derived subprogram then the subtypes of the parent -- subprogram's formal parameters will be used to determine the need -- for extra formals. @@ -7852,9 +7884,7 @@ package body Sem_Ch6 is -- situation may arise for subprogram types created as part of -- dispatching calls (see Expand_Dispatching_Call) - if Present (Last_Extra) and then - Present (Extra_Formal (Last_Extra)) - then + if Present (Last_Extra) and then Present (Extra_Formal (Last_Extra)) then return; end if; @@ -7908,13 +7938,19 @@ package body Sem_Ch6 is -- on discriminants and others do not (and requiring the extra -- formal would introduce distributed overhead). + -- If the type does not have a completion yet, treat as prior to + -- Ada 2012 for consistency. + if Has_Discriminants (Formal_Type) and then not Is_Constrained (Formal_Type) and then not Is_Indefinite_Subtype (Formal_Type) and then (Ada_Version < Ada_2012 - or else - not (Is_Tagged_Type (Underlying_Type (Formal_Type)) - and then Is_Limited_Type (Formal_Type))) + or else No (Underlying_Type (Formal_Type)) + or else not + (Is_Limited_Type (Formal_Type) + and then + (Is_Tagged_Type + (Underlying_Type (Formal_Type))))) then Set_Extra_Constrained (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O")); @@ -8093,9 +8129,7 @@ package body Sem_Ch6 is -- Chain new entity if front of homonym in current scope, so that -- homonyms are contiguous. - if Present (E) - and then E /= C_E - then + if Present (E) and then E /= C_E then while Homonym (C_E) /= E loop C_E := Homonym (C_E); end loop; @@ -8270,10 +8304,35 @@ package body Sem_Ch6 is function Different_Generic_Profile (E : Entity_Id) return Boolean is F1, F2 : Entity_Id; + function Same_Generic_Actual (T1, T2 : Entity_Id) return Boolean; + -- Check that the types of corresponding formals have the same + -- generic actual if any. We have to account for subtypes of a + -- generic formal, declared between a spec and a body, which may + -- appear distinct in an instance but matched in the generic. + + ------------------------- + -- Same_Generic_Actual -- + ------------------------- + + function Same_Generic_Actual (T1, T2 : Entity_Id) return Boolean is + begin + return Is_Generic_Actual_Type (T1) = Is_Generic_Actual_Type (T2) + or else + (Present (Parent (T1)) + and then Comes_From_Source (Parent (T1)) + and then Nkind (Parent (T1)) = N_Subtype_Declaration + and then Is_Entity_Name (Subtype_Indication (Parent (T1))) + and then Entity (Subtype_Indication (Parent (T1))) = T2); + end Same_Generic_Actual; + + -- Start of processing for Different_Generic_Profile + begin - if Ekind (E) = E_Function - and then Is_Generic_Actual_Type (Etype (E)) /= - Is_Generic_Actual_Type (Etype (Designator)) + if not In_Instance then + return False; + + elsif Ekind (E) = E_Function + and then not Same_Generic_Actual (Etype (E), Etype (Designator)) then return True; end if; @@ -8281,9 +8340,7 @@ package body Sem_Ch6 is F1 := First_Formal (Designator); F2 := First_Formal (E); while Present (F1) loop - if Is_Generic_Actual_Type (Etype (F1)) /= - Is_Generic_Actual_Type (Etype (F2)) - then + if not Same_Generic_Actual (Etype (F1), Etype (F2)) then return True; end if; @@ -8353,6 +8410,15 @@ package body Sem_Ch6 is then null; + -- For null procedures coming from source that are completions, + -- analysis of the generated body will establish the link. + + elsif Comes_From_Source (E) + and then Nkind (Spec) = N_Procedure_Specification + and then Null_Present (Spec) + then + return E; + elsif not Has_Completion (E) then if Nkind (N) /= N_Subprogram_Body_Stub then Set_Corresponding_Spec (N, E); @@ -8371,7 +8437,7 @@ package body Sem_Ch6 is -- If E is an internal function with a controlling result that -- was created for an operation inherited by a null extension, -- it may be overridden by a body without a previous spec (one - -- more reason why these should be shunned). In that case + -- more reason why these should be shunned). In that case we -- remove the generated body if present, because the current -- one is the explicit overriding. @@ -8606,14 +8672,10 @@ package body Sem_Ch6 is return Nkind (Selector_Name (E1)) = N_Character_Literal and then Chars (E2) = Chars (Selector_Name (E1)); - elsif Nkind (E1) in N_Op - and then Nkind (E2) = N_Function_Call - then + elsif Nkind (E1) in N_Op and then Nkind (E2) = N_Function_Call then return FCO (E1, E2); - elsif Nkind (E2) in N_Op - and then Nkind (E1) = N_Function_Call - then + elsif Nkind (E2) in N_Op and then Nkind (E1) = N_Function_Call then return FCO (E2, E1); -- Otherwise we must have the same syntactic entity @@ -8915,9 +8977,9 @@ package body Sem_Ch6 is -- All other node types cannot appear in this context. Strictly -- we should raise a fatal internal error. Instead we just ignore -- the nodes. This means that if anyone makes a mistake in the - -- expander and mucks an expression tree irretrievably, the - -- result will be a failure to detect a (probably very obscure) - -- case of non-conformance, which is better than bombing on some + -- expander and mucks an expression tree irretrievably, the result + -- will be a failure to detect a (probably very obscure) case + -- of non-conformance, which is better than bombing on some -- case where two expressions do in fact conform. when others => @@ -9107,8 +9169,8 @@ package body Sem_Ch6 is return Type_Conformant (Iface_Prim, Prim, Skip_Controlling_Formals => True); - -- Case of a function returning an interface, or an access to one. - -- Check that the return types correspond. + -- Case of a function returning an interface, or an access to one. Check + -- that the return types correspond. elsif Implements_Interface (Typ, Iface) then if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type) @@ -9319,8 +9381,8 @@ package body Sem_Ch6 is and then No (N_Formal) and then (Ekind (New_E) /= E_Function or else - Types_Correspond - (Etype (P_Prim), Etype (New_E))) + Types_Correspond + (Etype (P_Prim), Etype (New_E))) then return False; end if; @@ -9329,8 +9391,8 @@ package body Sem_Ch6 is Next_Elmt (Prim_Elt); end loop; - -- If no match found, then the new subprogram does not - -- override in the generic (nor in the instance). + -- If no match found, then the new subprogram does not override + -- in the generic (nor in the instance). -- If the type in question is not abstract, and the subprogram -- is, this will be an error if the new operation is in the @@ -9371,7 +9433,7 @@ package body Sem_Ch6 is begin for J in Inherited'Range loop - P := Spec_PPC_List (Contract (Inherited (J))); + P := Pre_Post_Conditions (Contract (Inherited (J))); while Present (P) loop Error_Msg_Sloc := Sloc (P); @@ -9455,9 +9517,9 @@ package body Sem_Ch6 is -- Insert inequality right after equality if it is explicit or after -- the derived type when implicit. These entities are created only - -- for visibility purposes, and eventually replaced in the course of - -- expansion, so they do not need to be attached to the tree and seen - -- by the back-end. Keeping them internal also avoids spurious + -- for visibility purposes, and eventually replaced in the course + -- of expansion, so they do not need to be attached to the tree and + -- seen by the back-end. Keeping them internal also avoids spurious -- freezing problems. The declaration is inserted in the tree for -- analysis, and removed afterwards. If the equality operator comes -- from an explicit declaration, attach the inequality immediately @@ -9566,9 +9628,9 @@ package body Sem_Ch6 is New_E : Entity_Id) return Boolean; -- Check whether new subprogram and old subprogram are both inherited -- from subprograms that have distinct dispatch table entries. This can - -- occur with derivations from instances with accidental homonyms. - -- The function is conservative given that the converse is only true - -- within instances that contain accidental overloadings. + -- occur with derivations from instances with accidental homonyms. The + -- function is conservative given that the converse is only true within + -- instances that contain accidental overloadings. ------------------------------------ -- Check_For_Primitive_Subprogram -- @@ -9615,12 +9677,8 @@ package body Sem_Ch6 is ("abstract subprograms must be visible " & "(RM 3.9.3(10))!", S); - elsif Ekind (S) = E_Function - and then not Is_Overriding - then - if Is_Tagged_Type (T) - and then T = Base_Type (Etype (S)) - then + elsif Ekind (S) = E_Function and then not Is_Overriding then + if Is_Tagged_Type (T) and then T = Base_Type (Etype (S)) then Error_Msg_N ("private function with tagged result must" & " override visible-part function", S); @@ -10038,7 +10096,7 @@ package body Sem_Ch6 is -- interface procedures. elsif (Ekind (Def_Id) = E_Procedure - or else Ekind (Def_Id) = E_Entry) + or else Ekind (Def_Id) = E_Entry) and then Ekind (Subp) = E_Procedure and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), @@ -10059,13 +10117,12 @@ package body Sem_Ch6 is -- routine must be of mode "out", "in out" or -- access-to-variable. - if (Ekind (Candidate) = E_Entry - or else Ekind (Candidate) = E_Procedure) + if Ekind_In (Candidate, E_Entry, E_Procedure) and then Is_Protected_Type (Typ) and then Ekind (Formal) /= E_In_Out_Parameter and then Ekind (Formal) /= E_Out_Parameter - and then Nkind (Parameter_Type (Parent (Formal))) - /= N_Access_Definition + and then Nkind (Parameter_Type (Parent (Formal))) /= + N_Access_Definition then null; @@ -10240,8 +10297,8 @@ package body Sem_Ch6 is Check_Dispatching_Operation (S, Empty); Check_For_Primitive_Subprogram (Is_Primitive_Subp); - -- If subprogram has an explicit declaration, check whether it - -- has an overriding indicator. + -- If subprogram has an explicit declaration, check whether it has an + -- overriding indicator. if Comes_From_Source (S) then Check_Synchronized_Overriding (S, Overridden_Subp); @@ -10332,11 +10389,11 @@ package body Sem_Ch6 is if Scope (E) /= Current_Scope then null; - -- Ada 2012 (AI05-0165): For internally generated bodies of - -- null procedures locate the internally generated spec. We - -- enforce mode conformance since a tagged type may inherit - -- from interfaces several null primitives which differ only - -- in the mode of the formals. + -- Ada 2012 (AI05-0165): For internally generated bodies of null + -- procedures locate the internally generated spec. We enforce + -- mode conformance since a tagged type may inherit from + -- interfaces several null primitives which differ only in + -- the mode of the formals. elsif not Comes_From_Source (S) and then Is_Null_Procedure (S) @@ -10453,9 +10510,7 @@ package body Sem_Ch6 is begin Prev := First_Entity (Current_Scope); - while Present (Prev) - and then Next_Entity (Prev) /= E - loop + while Present (Prev) and then Next_Entity (Prev) /= E loop Next_Entity (Prev); end loop; @@ -10798,8 +10853,7 @@ package body Sem_Ch6 is end if; return - Ekind (Desig) = E_Incomplete_Type - and then From_With_Type (Desig); + Ekind (Desig) = E_Incomplete_Type and then From_With_Type (Desig); end Designates_From_With_Type; --------------------------- @@ -10842,7 +10896,7 @@ package body Sem_Ch6 is if Is_Incomplete_Type (Formal_Type) or else (Is_Class_Wide_Type (Formal_Type) - and then Is_Incomplete_Type (Root_Type (Formal_Type))) + and then Is_Incomplete_Type (Root_Type (Formal_Type))) then -- Ada 2005 (AI-326): Tagged incomplete types allowed in -- primitive operations, as long as their completion is @@ -11186,22 +11240,17 @@ package body Sem_Ch6 is 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. - procedure Expand_Contract_Cases (CCs : Node_Id; Subp_Id : Entity_Id); - -- Given pragma Contract_Cases CCs, create the circuitry needed to - -- evaluate case guards and trigger consequence expressions. Subp_Id - -- denotes the related subprogram. - - function Grab_CC return Node_Id; - -- Prag contains an analyzed contract case pragma. This function copies - -- relevant components of the pragma, creates the corresponding Check - -- pragma and returns the Check pragma as the result. - 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 @@ -11210,14 +11259,17 @@ package body Sem_Ch6 is -- 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 Invariants_Or_Predicates_Present return Boolean; - -- Determines if any invariants or predicates are present for any OUT - -- or IN OUT parameters of the subprogram, or (for a function) if the - -- return value has an invariant. - 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 @@ -11227,6 +11279,30 @@ package body Sem_Ch6 is -- 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 -- ----------------------------- @@ -11244,6 +11320,7 @@ package body Sem_Ch6 is 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 := @@ -11253,553 +11330,18 @@ package body Sem_Ch6 is Call := Make_Invariant_Call (Obj); - Append_To (Plist, - 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))); + 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; - --------------------------- - -- Expand_Contract_Cases -- - --------------------------- - - -- Pragma Contract_Cases is expanded in the following manner: - - -- subprogram S is - -- Flag_1 : Boolean := False; - -- . . . - -- Flag_N : Boolean := False; - -- Flag_N+1 : Boolean := False; -- when "others" present - -- Count : Natural := 0; - - -- <preconditions (if any)> - - -- if Case_Guard_1 then - -- Flag_1 := True; - -- Count := Count + 1; - -- end if; - -- . . . - -- if Case_Guard_N then - -- Flag_N := True; - -- Count := Count + 1; - -- end if; - - -- if Count = 0 then - -- raise Assertion_Error with "contract cases incomplete"; - -- <or> - -- Flag_N+1 := True; -- when "others" present - - -- elsif Count > 1 then - -- declare - -- Str0 : constant String := - -- "contract cases overlap for subprogram ABC"; - -- Str1 : constant String := - -- (if Flag_1 then - -- Str0 & "case guard at xxx evaluates to True" - -- else Str0); - -- StrN : constant String := - -- (if Flag_N then - -- StrN-1 & "case guard at xxx evaluates to True" - -- else StrN-1); - -- begin - -- raise Assertion_Error with StrN; - -- end; - -- end if; - - -- procedure _Postconditions is - -- begin - -- <postconditions (if any)> - - -- if Flag_1 and then not Consequence_1 then - -- raise Assertion_Error with "failed contract case at xxx"; - -- end if; - -- . . . - -- if Flag_N[+1] and then not Consequence_N[+1] then - -- raise Assertion_Error with "failed contract case at xxx"; - -- end if; - -- end _Postconditions; - -- begin - -- . . . - -- end S; - - procedure Expand_Contract_Cases (CCs : Node_Id; Subp_Id : Entity_Id) is - Loc : constant Source_Ptr := Sloc (CCs); - - procedure Case_Guard_Error - (Decls : List_Id; - Flag : Entity_Id; - Error_Loc : Source_Ptr; - Msg : in out Entity_Id); - -- Given a declarative list Decls, status flag Flag, the location of - -- the error and a string Msg, construct the following check: - -- Msg : constant String := - -- (if Flag then - -- Msg & "case guard at Error_Loc evaluates to True" - -- else Msg); - -- The resulting code is added to Decls - - procedure Consequence_Error - (Checks : in out Node_Id; - Flag : Entity_Id; - Conseq : Node_Id); - -- Given an if statement Checks, status flag Flag and a consequence - -- Conseq, construct the following check: - -- [els]if Flag and then not Conseq then - -- raise Assertion_Error - -- with "failed contract case at Sloc (Conseq)"; - -- [end if;] - -- The resulting code is added to Checks - - function Declaration_Of (Id : Entity_Id) return Node_Id; - -- Given the entity Id of a boolean flag, generate: - -- Id : Boolean := False; - - function Increment (Id : Entity_Id) return Node_Id; - -- Given the entity Id of a numerical variable, generate: - -- Id := Id + 1; - - function Set (Id : Entity_Id) return Node_Id; - -- Given the entity Id of a boolean variable, generate: - -- Id := True; - - ---------------------- - -- Case_Guard_Error -- - ---------------------- - - procedure Case_Guard_Error - (Decls : List_Id; - Flag : Entity_Id; - Error_Loc : Source_Ptr; - Msg : in out Entity_Id) - is - New_Line : constant Character := Character'Val (10); - New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S'); - - begin - Start_String; - Store_String_Char (New_Line); - Store_String_Chars (" case guard at "); - Store_String_Chars (Build_Location_String (Error_Loc)); - Store_String_Chars (" evaluates to True"); - - -- Generate: - -- New_Msg : constant String := - -- (if Flag then - -- Msg & "case guard at Error_Loc evaluates to True" - -- else Msg); - - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => New_Msg, - Constant_Present => True, - Object_Definition => New_Reference_To (Standard_String, Loc), - Expression => - Make_If_Expression (Loc, - Expressions => New_List ( - New_Reference_To (Flag, Loc), - - Make_Op_Concat (Loc, - Left_Opnd => New_Reference_To (Msg, Loc), - Right_Opnd => Make_String_Literal (Loc, End_String)), - - New_Reference_To (Msg, Loc))))); - - Msg := New_Msg; - end Case_Guard_Error; - - ----------------------- - -- Consequence_Error -- - ----------------------- - - procedure Consequence_Error - (Checks : in out Node_Id; - Flag : Entity_Id; - Conseq : Node_Id) - is - Cond : Node_Id; - Error : Node_Id; - - begin - -- Generate: - -- Flag and then not Conseq - - Cond := - Make_And_Then (Loc, - Left_Opnd => New_Reference_To (Flag, Loc), - Right_Opnd => - Make_Op_Not (Loc, - Right_Opnd => Relocate_Node (Conseq))); - - -- Generate: - -- raise Assertion_Error - -- with "failed contract case at Sloc (Conseq)"; - - Start_String; - Store_String_Chars ("failed contract case at "); - Store_String_Chars (Build_Location_String (Sloc (Conseq))); - - Error := - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, End_String))); - - if No (Checks) then - Checks := - Make_If_Statement (Loc, - Condition => Cond, - Then_Statements => New_List (Error)); - - else - if No (Elsif_Parts (Checks)) then - Set_Elsif_Parts (Checks, New_List); - end if; - - Append_To (Elsif_Parts (Checks), - Make_Elsif_Part (Loc, - Condition => Cond, - Then_Statements => New_List (Error))); - end if; - end Consequence_Error; - - -------------------- - -- Declaration_Of -- - -------------------- - - function Declaration_Of (Id : Entity_Id) return Node_Id is - begin - return - Make_Object_Declaration (Loc, - Defining_Identifier => Id, - Object_Definition => - New_Reference_To (Standard_Boolean, Loc), - Expression => - New_Reference_To (Standard_False, Loc)); - end Declaration_Of; - - --------------- - -- Increment -- - --------------- - - function Increment (Id : Entity_Id) return Node_Id is - begin - return - Make_Assignment_Statement (Loc, - Name => New_Reference_To (Id, Loc), - Expression => - Make_Op_Add (Loc, - Left_Opnd => New_Reference_To (Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1))); - end Increment; - - --------- - -- Set -- - --------- - - function Set (Id : Entity_Id) return Node_Id is - begin - return - Make_Assignment_Statement (Loc, - Name => New_Reference_To (Id, Loc), - Expression => New_Reference_To (Standard_True, Loc)); - end Set; - - -- Local variables - - Aggr : constant Node_Id := - Expression (First - (Pragma_Argument_Associations (CCs))); - Decls : constant List_Id := Declarations (N); - Multiple_PCs : constant Boolean := - List_Length (Component_Associations (Aggr)) > 1; - Case_Guard : Node_Id; - CG_Checks : Node_Id; - CG_Stmts : List_Id; - Conseq : Node_Id; - Conseq_Checks : Node_Id := Empty; - Count : Entity_Id; - Error_Decls : List_Id; - Flag : Entity_Id; - Msg_Str : Entity_Id; - Others_Flag : Entity_Id := Empty; - Post_Case : Node_Id; - - -- Start of processing for Expand_Contract_Cases - - begin - -- Create the counter which tracks the number of case guards that - -- evaluate to True. - - -- Count : Natural := 0; - - Count := Make_Temporary (Loc, 'C'); - - Prepend_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Count, - Object_Definition => New_Reference_To (Standard_Natural, Loc), - Expression => Make_Integer_Literal (Loc, 0))); - - -- Create the base error message for multiple overlapping case - -- guards. - - -- Msg_Str : constant String := - -- "contract cases overlap for subprogram Subp_Id"; - - if Multiple_PCs then - Msg_Str := Make_Temporary (Loc, 'S'); - - Start_String; - Store_String_Chars ("contract cases overlap for subprogram "); - Store_String_Chars (Get_Name_String (Chars (Subp_Id))); - - Error_Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Msg_Str, - Constant_Present => True, - Object_Definition => New_Reference_To (Standard_String, Loc), - Expression => Make_String_Literal (Loc, End_String))); - end if; - - -- Process individual post cases - - Post_Case := First (Component_Associations (Aggr)); - while Present (Post_Case) loop - Case_Guard := First (Choices (Post_Case)); - Conseq := Expression (Post_Case); - - -- The "others" choice requires special processing - - if Nkind (Case_Guard) = N_Others_Choice then - Others_Flag := Make_Temporary (Loc, 'F'); - Prepend_To (Decls, Declaration_Of (Others_Flag)); - - -- Check possible overlap between a case guard and "others" - - if Multiple_PCs then - Case_Guard_Error - (Decls => Error_Decls, - Flag => Others_Flag, - Error_Loc => Sloc (Case_Guard), - Msg => Msg_Str); - end if; - - -- Check the corresponding consequence of "others" - - Consequence_Error - (Checks => Conseq_Checks, - Flag => Others_Flag, - Conseq => Conseq); - - -- Regular post case - - else - -- Create the flag which tracks the state of its associated - -- case guard. - - Flag := Make_Temporary (Loc, 'F'); - Prepend_To (Decls, Declaration_Of (Flag)); - - -- The flag is set when the case guard is evaluated to True - -- if Case_Guard then - -- Flag := True; - -- Count := Count + 1; - -- end if; - - Append_To (Decls, - Make_If_Statement (Loc, - Condition => Relocate_Node (Case_Guard), - Then_Statements => New_List ( - Set (Flag), - Increment (Count)))); - - -- Check whether this case guard overlaps with another case - -- guard. - - if Multiple_PCs then - Case_Guard_Error - (Decls => Error_Decls, - Flag => Flag, - Error_Loc => Sloc (Case_Guard), - Msg => Msg_Str); - end if; - - -- The corresponding consequence of the case guard which - -- evaluated to True must hold on exit from the subprogram. - - Consequence_Error (Conseq_Checks, Flag, Conseq); - end if; - - Next (Post_Case); - end loop; - - -- Raise Assertion_Error when none of the case guards evaluate to - -- True. The only exception is when we have "others", in which case - -- there is no error because "others" acts as a default True. - - -- Generate: - -- Flag := True; - - if Present (Others_Flag) then - CG_Stmts := New_List (Set (Others_Flag)); - - -- Generate: - -- raise Assetion_Error with "contract cases incomplete"; - - else - Start_String; - Store_String_Chars ("contract cases incomplete"); - - CG_Stmts := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, End_String)))); - end if; - - CG_Checks := - Make_If_Statement (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => New_Reference_To (Count, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 0)), - Then_Statements => CG_Stmts); - - -- Detect a possible failure due to several case guards evaluating to - -- True. - - -- Generate: - -- elsif Count > 0 then - -- declare - -- <Error_Decls> - -- begin - -- raise Assertion_Error with <Msg_Str>; - -- end if; - - if Multiple_PCs then - Set_Elsif_Parts (CG_Checks, New_List ( - Make_Elsif_Part (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => New_Reference_To (Count, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1)), - - Then_Statements => New_List ( - Make_Block_Statement (Loc, - Declarations => Error_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To - (RTE (RE_Raise_Assert_Failure), Loc), - Parameter_Associations => New_List ( - New_Reference_To (Msg_Str, Loc)))))))))); - end if; - - Append_To (Decls, CG_Checks); - - -- Raise Assertion_Error when the corresponding consequence of a case - -- guard that evaluated to True fails. - - if No (Plist) then - Plist := New_List; - end if; - - Append_To (Plist, Conseq_Checks); - end Expand_Contract_Cases; - - ------------- - -- Grab_CC -- - ------------- - - function Grab_CC return Node_Id is - Loc : constant Source_Ptr := Sloc (Prag); - CP : Node_Id; - Req : Node_Id; - Ens : Node_Id; - Post : Node_Id; - - -- As with postcondition, the string is "failed xx from yy" where - -- xx is in all lower case. The reason for this different wording - -- compared to other Check cases is that the failure is not at the - -- point of occurrence of the pragma, unlike the other Check cases. - - Msg : constant String := - "failed contract case from " & Build_Location_String (Loc); - - begin - -- Copy the Requires and Ensures expressions - - Req := New_Copy_Tree - (Expression (Get_Requires_From_CTC_Pragma (Prag)), - New_Scope => Current_Scope); - - Ens := New_Copy_Tree - (Expression (Get_Ensures_From_CTC_Pragma (Prag)), - New_Scope => Current_Scope); - - -- Build the postcondition (not Requires'Old or else Ensures) - - Post := - Make_Or_Else (Loc, - Left_Opnd => - Make_Op_Not (Loc, - Make_Attribute_Reference (Loc, - Prefix => Req, - Attribute_Name => Name_Old)), - Right_Opnd => Ens); - - -- For a contract case pragma within a generic, generate a - -- postcondition pragma for later expansion. This is also used - -- when an error was detected, thus setting Expander_Active to False. - - if not Expander_Active then - CP := - Make_Pragma (Loc, - Chars => Name_Postcondition, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Chars => Name_Check, - Expression => Post), - - Make_Pragma_Argument_Association (Loc, - Chars => Name_Message, - Expression => Make_String_Literal (Loc, Msg)))); - - -- Otherwise, create the Check pragma - - else - CP := - Make_Pragma (Loc, - Chars => Name_Check, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Chars => Name_Name, - Expression => Make_Identifier (Loc, Name_Postcondition)), - - Make_Pragma_Argument_Association (Loc, - Chars => Name_Check, - Expression => Post), - - Make_Pragma_Argument_Association (Loc, - Chars => Name_Message, - Expression => Make_String_Literal (Loc, Msg)))); - end if; - - -- Return the Postcondition or Check pragma - - return CP; - end Grab_CC; - -------------- -- Grab_PPC -- -------------- @@ -11809,6 +11351,12 @@ package body Sem_Ch6 is 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 @@ -11860,11 +11408,19 @@ package body Sem_Ch6 is 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, Nam))); + 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 @@ -11894,65 +11450,109 @@ package body Sem_Ch6 is return CP; end Grab_PPC; - ----------------------------------- - -- Insert_After_Last_Declaration -- - ----------------------------------- + --------------------------- + -- Has_Checked_Predicate -- + --------------------------- - procedure Insert_After_Last_Declaration (Nod : Node_Id) is - Decls : constant List_Id := Declarations (N); + function Has_Checked_Predicate (Typ : Entity_Id) return Boolean is + Anc : Entity_Id; + Pred : Node_Id; begin - if No (Decls) then - Set_Declarations (N, New_List (Nod)); - else - Append_To (Decls, Nod); - end if; - end Insert_After_Last_Declaration; + -- 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. - -------------------------------------- - -- Invariants_Or_Predicates_Present -- - -------------------------------------- + -- Note that predicate pragmas include all three cases of predicate + -- aspects (Predicate, Dynamic_Predicate, Static_Predicate), so this + -- routine checks for all three cases. - function Invariants_Or_Predicates_Present return Boolean is - Formal : Entity_Id; + 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 - -- Check function return result. If result is an access type there - -- may be invariants on the designated type. + Spec := Parent (Proc_Id); + Decl := Parent (Spec); - if Ekind (Designator) /= E_Procedure - and then Has_Invariants (Etype (Designator)) - then - return True; + -- Retrieve the entity of the invariant procedure body - elsif Ekind (Designator) /= E_Procedure - and then Is_Access_Type (Etype (Designator)) - and then Has_Invariants (Designated_Type (Etype (Designator))) + if Nkind (Spec) = N_Procedure_Specification + and then Nkind (Decl) = N_Subprogram_Declaration then - return True; + Body_Id := Corresponding_Body (Decl); + + -- The body acts as a spec + + else + Body_Id := Proc_Id; end if; - -- Check parameters + -- The body will be generated later - Formal := First_Formal (Designator); - while Present (Formal) loop - if Ekind (Formal) /= E_In_Parameter - and then (Has_Invariants (Etype (Formal)) - or else Present (Predicate_Function (Etype (Formal)))) - then - return True; + if No (Body_Id) then + return False; + end if; - elsif Is_Access_Type (Etype (Formal)) - and then Has_Invariants (Designated_Type (Etype (Formal))) - then + 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; - - Next_Formal (Formal); - end loop; + end if; return False; - end Invariants_Or_Predicates_Present; + 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 -- @@ -12006,6 +11606,14 @@ package body Sem_Ch6 is 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 @@ -12017,10 +11625,18 @@ package body Sem_Ch6 is 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. - if Get_TSS_Name (Designator) /= TSS_Null then + elsif Get_TSS_Name (Designator) /= TSS_Null then return; end if; @@ -12032,7 +11648,7 @@ package body Sem_Ch6 is -- the body will be analyzed and converted when we scan the body -- declarations below. - Prag := Spec_PPC_List (Contract (Spec_Id)); + Prag := Pre_Post_Conditions (Contract (Spec_Id)); while Present (Prag) loop if Pragma_Name (Prag) = Name_Precondition then @@ -12061,7 +11677,7 @@ package body Sem_Ch6 is -- Now deal with inherited preconditions for J in Inherited'Range loop - Prag := Spec_PPC_List (Contract (Inherited (J))); + Prag := Pre_Post_Conditions (Contract (Inherited (J))); while Present (Prag) loop if Pragma_Name (Prag) = Name_Precondition @@ -12081,16 +11697,12 @@ package body Sem_Ch6 is declare New_Expr : constant Node_Id := - Get_Pragma_Arg - (Next - (First - (Pragma_Argument_Associations - (Inherited_Precond)))); + Get_Pragma_Arg + (Next (First (Pragma_Argument_Associations + (Inherited_Precond)))); Old_Expr : constant Node_Id := - Get_Pragma_Arg - (Next - (First - (Pragma_Argument_Associations + Get_Pragma_Arg + (Next (First (Pragma_Argument_Associations (Precond)))); begin @@ -12174,15 +11786,9 @@ package body Sem_Ch6 is while Present (Prag) loop if Nkind (Prag) = N_Pragma then - -- If pragma, capture if enabled postcondition, else ignore - - if Pragma_Name (Prag) = Name_Postcondition - and then Check_Enabled (Name_Postcondition) - then - if Plist = No_List then - Plist := Empty_List; - end if; + -- Capture postcondition pragmas + if Pragma_Name (Prag) = Name_Postcondition then Analyze (Prag); -- If expansion is disabled, as in a generic unit, save @@ -12191,7 +11797,7 @@ package body Sem_Ch6 is if not Expander_Active then Prepend (Grab_PPC, Declarations (N)); else - Append (Grab_PPC, Plist); + Append_Enabled_Item (Grab_PPC, Plist); end if; end if; @@ -12215,17 +11821,17 @@ package body Sem_Ch6 is if Present (Spec_Id) then Spec_Postconditions : declare procedure Process_Contract_Cases (Spec : Node_Id); - -- This processes the Spec_CTC_List from Spec, processing any - -- contract-case from the list. The caller has checked that - -- Spec_CTC_List is non-Empty. + -- 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 Spec_PPC_List 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 Spec_PPC_List is non-Empty. + -- 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 -- @@ -12233,23 +11839,16 @@ package body Sem_Ch6 is procedure Process_Contract_Cases (Spec : Node_Id) is begin - -- Loop through Contract_Case pragmas from spec + -- Loop through Contract_Cases pragmas from spec - Prag := Spec_CTC_List (Contract (Spec)); + Prag := Contract_Test_Cases (Contract (Spec)); loop - if Pragma_Name (Prag) = Name_Contract_Case then - if Plist = No_List then - Plist := Empty_List; - end if; - - if not Expander_Active then - Prepend (Grab_CC, Declarations (N)); - else - Append (Grab_CC, Plist); - end if; - - elsif Pragma_Name (Prag) = Name_Contract_Cases then - Expand_Contract_Cases (Prag, Spec_Id); + 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); @@ -12276,20 +11875,15 @@ package body Sem_Ch6 is -- Loop through PPC pragmas from spec - Prag := Spec_PPC_List (Contract (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 Plist = No_List then - Plist := Empty_List; - end if; - if not Expander_Active then - Prepend - (Grab_PPC (Pspec), Declarations (N)); + Prepend (Grab_PPC (Pspec), Declarations (N)); else - Append (Grab_PPC (Pspec), Plist); + Append_Enabled_Item (Grab_PPC (Pspec), Plist); end if; end if; @@ -12303,166 +11897,148 @@ package body Sem_Ch6 is begin -- Process postconditions expressed as contract-cases - if Present (Spec_CTC_List (Contract (Spec_Id))) then + if Present (Contract_Test_Cases (Contract (Spec_Id))) then Process_Contract_Cases (Spec_Id); end if; -- Process spec postconditions - if Present (Spec_PPC_List (Contract (Spec_Id))) then + 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 (Spec_PPC_List (Contract (Inherited (J)))) then + 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; - -- If we had any postconditions and expansion is enabled, or if the - -- subprogram has invariants, then build the _Postconditions procedure. + -- Add an invariant call to check the result of a function - if (Present (Plist) or else Invariants_Or_Predicates_Present) - and then Expander_Active - then - if No (Plist) then - Plist := Empty_List; - end if; + if Ekind (Designator) /= E_Procedure and then Expander_Active then + Func_Typ := Etype (Designator); + Result := Make_Defining_Identifier (Loc, Name_uResult); - -- Special processing for function return + Set_Etype (Result, Func_Typ); - if Ekind (Designator) /= E_Procedure then - declare - Rent : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_uResult); - Ftyp : constant Entity_Id := Etype (Designator); + -- Add argument for return - begin - Set_Etype (Rent, Ftyp); + Parms := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Result, + Parameter_Type => New_Occurrence_Of (Func_Typ, Loc))); - -- Add argument for return + -- 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. - Parms := - New_List ( - Make_Parameter_Specification (Loc, - Parameter_Type => New_Occurrence_Of (Ftyp, Loc), - Defining_Identifier => Rent)); + 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; - -- 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. + -- Same if return value is an access to type with invariants - if Has_Invariants (Etype (Rent)) - and then Present (Invariant_Procedure (Etype (Rent))) - and then Is_Public_Subprogram_For (Etype (Rent)) - then - Append_To (Plist, - Make_Invariant_Call (New_Occurrence_Of (Rent, Loc))); - end if; + Check_Access_Invariants (Result); - -- Same if return value is an access to type with invariants + -- Procedure case - Check_Access_Invariants (Rent); - end; + else + Parms := No_List; + end if; - -- Procedure rather than a function + -- 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. - else - Parms := No_List; - end if; + 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); - -- 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 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; - declare - Formal : Entity_Id; - Ftype : Entity_Id; + Check_Access_Invariants (Formal); - begin - Formal := First_Formal (Designator); - while Present (Formal) loop - if Ekind (Formal) /= E_In_Parameter - or else Is_Access_Type (Etype (Formal)) + if Has_Predicates (Formal_Typ) + and then Present (Predicate_Function (Formal_Typ)) + and then Has_Checked_Predicate (Formal_Typ) then - Ftype := Etype (Formal); + Append_Enabled_Item + (Make_Predicate_Check + (Formal_Typ, New_Occurrence_Of (Formal, Loc)), + Plist); + end if; + end if; - if Has_Invariants (Ftype) - and then Present (Invariant_Procedure (Ftype)) - and then Is_Public_Subprogram_For (Ftype) - then - Append_To (Plist, - Make_Invariant_Call - (New_Occurrence_Of (Formal, Loc))); - end if; + Next_Formal (Formal); + end loop; + end if; - Check_Access_Invariants (Formal); + -- Build and insert postcondition procedure - if Present (Predicate_Function (Ftype)) then - Append_To (Plist, - Make_Predicate_Check - (Ftype, New_Occurrence_Of (Formal, Loc))); - end if; - end if; + if Expander_Active and then Present (Plist) then + Post_Proc := + Make_Defining_Identifier (Loc, Chars => Name_uPostconditions); - Next_Formal (Formal); - end loop; - end; + -- 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: - -- Build and insert postcondition procedure + -- procedure Proc (Obj : Array_Typ) is + -- procedure _postconditions is + -- begin + -- ... Obj ... + -- end _postconditions; - declare - Post_Proc : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_uPostconditions); - -- The entity for the _Postconditions procedure + -- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1)); + -- begin - begin - -- 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), + -- 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. - Declarations => Empty_List, + Insert_After_Last_Declaration ( + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Post_Proc, + Parameter_Specifications => Parms), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Plist))); + Declarations => Empty_List, - Set_Ekind (Post_Proc, E_Procedure); + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Plist))); - -- If this is a procedure, set the Postcondition_Proc attribute on - -- the proper defining entity for the subprogram. + Set_Ekind (Post_Proc, E_Procedure); - if Ekind (Designator) = E_Procedure then - Set_Postcondition_Proc (Designator, Post_Proc); - end if; - end; + -- 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; @@ -12515,9 +12091,7 @@ package body Sem_Ch6 is -- If this is an empty initialization procedure, no need to create -- actual subtypes (small optimization). - if Ekind (Subp) = E_Procedure - and then Is_Null_Init_Proc (Subp) - then + if Ekind (Subp) = E_Procedure and then Is_Null_Init_Proc (Subp) then return; end if; @@ -12654,6 +12228,13 @@ package body Sem_Ch6 is -- [IN] OUT parameters allowed for functions in Ada 2012 if Ada_Version >= Ada_2012 then + + -- Even in Ada 2012 operators can only have IN parameters + + if Is_Operator_Symbol_Name (Chars (Scope (Formal_Id))) then + Error_Msg_N ("operators can only have IN parameters", Spec); + end if; + if In_Present (Spec) then Set_Ekind (Formal_Id, E_In_Out_Parameter); else @@ -12817,16 +12398,12 @@ package body Sem_Ch6 is -- Verify that user-defined operators have proper number of arguments -- First case of operators which can only be unary - if Id = Name_Op_Not - or else Id = Name_Op_Abs - then + if Nam_In (Id, Name_Op_Not, Name_Op_Abs) then N_OK := (N = 1); -- Case of operators which can be unary or binary - elsif Id = Name_Op_Add - or Id = Name_Op_Subtract - then + elsif Nam_In (Id, Name_Op_Add, Name_Op_Subtract) then N_OK := (N in 1 .. 2); -- All other operators can only be binary diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index a0df51ef21e..0799adc1849 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.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- -- @@ -46,6 +46,10 @@ package Sem_Ch6 is procedure Analyze_Subprogram_Declaration (N : Node_Id); procedure Analyze_Subprogram_Body (N : Node_Id); + 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. + function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id; -- Analyze subprogram specification in both subprogram declarations -- and body declarations. Returns the defining entity for the @@ -139,10 +143,6 @@ package Sem_Ch6 is -- type-conformant subprogram that becomes hidden by the new subprogram. -- Is_Primitive indicates whether the subprogram is primitive. - procedure Check_Subprogram_Contract (Spec_Id : Entity_Id); - -- Spec_Id is the spec entity for a subprogram. This routine issues - -- warnings on suspicious contracts if Warn_On_Suspicious_Contract is set. - procedure Check_Subtype_Conformant (New_Id : Entity_Id; Old_Id : Entity_Id; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index dd1e1d4120e..505fe9d9916 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.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- -- @@ -557,6 +557,7 @@ package body Sem_Ch7 is and then Ekind (Entity (N)) = E_Constant then V := Constant_Value (Entity (N)); + if Present (V) and then not Compile_Time_Known_Value_Or_Aggr (V) then @@ -1166,7 +1167,7 @@ package body Sem_Ch7 is while Present (Inst_Par) and then Inst_Par /= Standard_Standard and then (not In_Open_Scopes (Inst_Par) - or else not In_Private_Part (Inst_Par)) + or else not In_Private_Part (Inst_Par)) loop Install_Private_Declarations (Inst_Par); Set_Use (Private_Declarations @@ -1394,9 +1395,8 @@ package body Sem_Ch7 is begin ASN := First (Aspect_Specifications (Parent (E))); while Present (ASN) loop - if Chars (Identifier (ASN)) = Name_Invariant - or else - Chars (Identifier (ASN)) = Name_Type_Invariant + if Nam_In (Chars (Identifier (ASN)), Name_Invariant, + Name_Type_Invariant) then Build_Invariant_Procedure (E, N); exit; @@ -1661,8 +1661,8 @@ package body Sem_Ch7 is and then Present (DTC_Entity (New_Op)) and then Present (DTC_Entity (Prim_Op)) then - pragma Assert (DT_Position (New_Op) - = DT_Position (Prim_Op)); + pragma Assert + (DT_Position (New_Op) = DT_Position (Prim_Op)); null; end if; @@ -1813,9 +1813,71 @@ package body Sem_Ch7 is procedure Install_Private_Declarations (P : Entity_Id) is Id : Entity_Id; - Priv_Elmt : Elmt_Id; - Priv : Entity_Id; Full : Entity_Id; + Priv_Deps : Elist_Id; + + procedure Swap_Private_Dependents (Priv_Deps : Elist_Id); + -- When the full view of a private type is made available, we do the + -- same for its private dependents under proper visibility conditions. + -- When compiling a grand-chid unit this needs to be done recursively. + + ----------------------------- + -- Swap_Private_Dependents -- + ----------------------------- + + procedure Swap_Private_Dependents (Priv_Deps : Elist_Id) is + Deps : Elist_Id; + Priv : Entity_Id; + Priv_Elmt : Elmt_Id; + Is_Priv : Boolean; + + begin + Priv_Elmt := First_Elmt (Priv_Deps); + while Present (Priv_Elmt) loop + Priv := Node (Priv_Elmt); + + -- Before the exchange, verify that the presence of the Full_View + -- field. This field will be empty if the entity has already been + -- installed due to a previous call. + + if Present (Full_View (Priv)) + and then Is_Visible_Dependent (Priv) + then + if Is_Private_Type (Priv) then + Deps := Private_Dependents (Priv); + Is_Priv := True; + else + Is_Priv := False; + end if; + + -- For each subtype that is swapped, we also swap the reference + -- to it in Private_Dependents, to allow access to it when we + -- swap them out in End_Package_Scope. + + Replace_Elmt (Priv_Elmt, Full_View (Priv)); + Exchange_Declarations (Priv); + Set_Is_Immediately_Visible + (Priv, In_Open_Scopes (Scope (Priv))); + Set_Is_Potentially_Use_Visible + (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt))); + + -- Within a child unit, recurse, except in generic child unit, + -- which (unfortunately) handle private_dependents separately. + + if Is_Priv + and then Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) + and then not Is_Empty_Elmt_List (Deps) + and then not Inside_A_Generic + then + Swap_Private_Dependents (Deps); + end if; + end if; + + Next_Elmt (Priv_Elmt); + end loop; + end Swap_Private_Dependents; + + -- Start of processing for Install_Private_Declarations begin -- First exchange declarations for private types, so that the full @@ -1823,8 +1885,8 @@ package body Sem_Ch7 is -- Private_Dependents list and also exchange any subtypes of or derived -- types from it. Finally, if this is a Taft amendment type, the -- incomplete declaration is irrelevant, and we want to link the - -- eventual full declaration with the original private one so we also - -- skip the exchange. + -- eventual full declaration with the original private one so we + -- also skip the exchange. Id := First_Entity (P); while Present (Id) and then Id /= First_Private_Entity (P) loop @@ -1834,8 +1896,8 @@ package body Sem_Ch7 is and then Scope (Full_View (Id)) = Scope (Id) and then Ekind (Full_View (Id)) /= E_Incomplete_Type then - -- If there is a use-type clause on the private type, set the - -- full view accordingly. + -- If there is a use-type clause on the private type, set the full + -- view accordingly. Set_In_Use (Full_View (Id), In_Use (Id)); Full := Full_View (Id); @@ -1851,9 +1913,9 @@ package body Sem_Ch7 is -- from another private type which is not private anymore. This -- can only happen in a package nested within a child package, -- when the parent type is defined in the parent unit. At this - -- point the current type is not private either, and we have to - -- install the underlying full view, which is now visible. Save - -- the current full view as well, so that all views can be + -- point the current type is not private either, and we have + -- to install the underlying full view, which is now visible. + -- Save the current full view as well, so that all views can be -- restored on exit. It may seem that after compiling the child -- body there are not environments to restore, but the back-end -- expects those links to be valid, and freeze nodes depend on @@ -1870,36 +1932,10 @@ package body Sem_Ch7 is end if; end if; - Priv_Elmt := First_Elmt (Private_Dependents (Id)); - + Priv_Deps := Private_Dependents (Id); Exchange_Declarations (Id); Set_Is_Immediately_Visible (Id); - - while Present (Priv_Elmt) loop - Priv := Node (Priv_Elmt); - - -- Before the exchange, verify that the presence of the - -- Full_View field. It will be empty if the entity has already - -- been installed due to a previous call. - - if Present (Full_View (Priv)) - and then Is_Visible_Dependent (Priv) - then - - -- For each subtype that is swapped, we also swap the - -- reference to it in Private_Dependents, to allow access - -- to it when we swap them out in End_Package_Scope. - - Replace_Elmt (Priv_Elmt, Full_View (Priv)); - Exchange_Declarations (Priv); - Set_Is_Immediately_Visible - (Priv, In_Open_Scopes (Scope (Priv))); - Set_Is_Potentially_Use_Visible - (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt))); - end if; - - Next_Elmt (Priv_Elmt); - end loop; + Swap_Private_Dependents (Priv_Deps); end if; Next_Entity (Id); @@ -1983,7 +2019,7 @@ package body Sem_Ch7 is return In_Open_Scopes (S) or else (Is_Generic_Instance (Current_Scope) - and then Scope (Dep) = Scope (Current_Scope)); + and then Scope (Dep) = Scope (Current_Scope)); else return True; end if; @@ -2036,8 +2072,8 @@ package body Sem_Ch7 is if Ada_Version < Ada_2012 then Enter_Name (Id); - -- Ada 2012 (AI05-0162): Enter the name in the current scope handling - -- private type that completes an incomplete type. + -- Ada 2012 (AI05-0162): Enter the name in the current scope. Note that + -- there may be an incomplete previous view. else declare @@ -2094,7 +2130,7 @@ package body Sem_Ch7 is -- Create a class-wide type with the same attributes - Make_Class_Wide_Type (Id); + Make_Class_Wide_Type (Id); elsif Abstract_Present (Def) then Error_Msg_N ("only a tagged type can be abstract", N); @@ -2281,8 +2317,7 @@ package body Sem_Ch7 is Check_Conventions (Id); end if; - if (Ekind (Id) = E_Private_Type - or else Ekind (Id) = E_Limited_Private_Type) + if Ekind_In (Id, E_Private_Type, E_Limited_Private_Type) and then No (Full_View (Id)) and then not Is_Generic_Type (Id) and then not Is_Derived_Type (Id) @@ -2427,8 +2462,6 @@ package body Sem_Ch7 is ("full view of type must be definite subtype", Full); end if; - Priv_Elmt := First_Elmt (Private_Dependents (Id)); - -- Swap out the subtypes and derived types of Id that -- were compiled in this scope, or installed previously -- by Install_Private_Declarations. @@ -2437,6 +2470,7 @@ package body Sem_Ch7 is -- field which may be empty due to a swap by a previous call to -- End_Package_Scope (e.g. from the freezing mechanism). + Priv_Elmt := First_Elmt (Private_Dependents (Id)); while Present (Priv_Elmt) loop Priv_Sub := Node (Priv_Elmt); @@ -2516,7 +2550,7 @@ package body Sem_Ch7 is if Etype (Subp) = Id or else (Is_Class_Wide_Type (Etype (Subp)) - and then Etype (Etype (Subp)) = Id) + and then Etype (Etype (Subp)) = Id) then Error_Msg_NE ("type& must be completed in the private part", @@ -2529,8 +2563,7 @@ package body Sem_Ch7 is end; elsif not Is_Child_Unit (Id) - and then (not Is_Private_Type (Id) - or else No (Full_View (Id))) + and then (not Is_Private_Type (Id) or else No (Full_View (Id))) then Set_Is_Hidden (Id); Set_Is_Potentially_Use_Visible (Id, False); @@ -2582,6 +2615,16 @@ package body Sem_Ch7 is return True; end if; 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. + + 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 + return True; end if; -- Otherwise search entity chain for entity requiring completion diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 32d49cc6932..4fdef1cdac2 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -450,6 +450,25 @@ package body Sem_Ch8 is -- when compiling a subunit or instantiating a generic body on the fly, -- when it is necessary to save and restore full environments. + function Enclosing_Instance return Entity_Id; + -- In an instance nested within another one, several semantic checks are + -- unnecessary because the legality of the nested instance has been checked + -- in the enclosing generic unit. This applies in particular to legality + -- checks on actuals for formal subprograms of the inner instance, which + -- are checked as subprogram renamings, and may be complicated by confusion + -- in private/full views. This function returns the instance enclosing the + -- current one if there is such, else it returns Empty. + -- + -- If the renaming determines the entity for the default of a formal + -- subprogram nested within another instance, choose the innermost + -- candidate. This is because if the formal has a box, and we are within + -- an enclosing instance where some candidate interpretations are local + -- to this enclosing instance, we know that the default was properly + -- resolved when analyzing the generic, so we prefer the local + -- candidates to those that are external. This is not always the case + -- but is a reasonable heuristic on the use of nested generics. The + -- proper solution requires a full renaming model. + function Has_Implicit_Character_Literal (N : Node_Id) return Boolean; -- Find a type derived from Character or Wide_Character in the prefix of N. -- Used to resolved qualified names whose selector is a character literal. @@ -773,6 +792,12 @@ package body Sem_Ch8 is Make_Subtype_From_Expr (Nam, Typ))); Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc)); Set_Etype (Nam, Subt); + + -- Freeze subtype at once, to prevent order of elaboration + -- issues in the backend. The renamed object exists, so its + -- type is already frozen in any case. + + Freeze_Before (N, Subt); end if; end if; end Check_Constrained_Object; @@ -1076,9 +1101,7 @@ package body Sem_Ch8 is then null; - elsif Ada_Version >= Ada_2005 - and then Nkind (Nam) in N_Has_Entity - then + elsif Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then declare Nam_Decl : Node_Id; Nam_Ent : Entity_Id; @@ -1103,7 +1126,7 @@ package body Sem_Ch8 is -- have a null exclusion or a null-excluding subtype. if Is_Formal_Object (Nam_Ent) - and then In_Generic_Scope (Id) + and then In_Generic_Scope (Id) then if not Can_Never_Be_Null (Etype (Nam_Ent)) then Error_Msg_N @@ -1132,10 +1155,10 @@ package body Sem_Ch8 is elsif Nkind (Nam_Decl) = N_Object_Declaration and then In_Instance - and then Present - (Corresponding_Generic_Association (Nam_Decl)) - and then Nkind (Expression (Nam_Decl)) - = N_Raise_Constraint_Error + and then + Present (Corresponding_Generic_Association (Nam_Decl)) + and then Nkind (Expression (Nam_Decl)) = + N_Raise_Constraint_Error then Error_Msg_N ("renamed actual does not exclude `NULL` " @@ -1214,7 +1237,7 @@ package body Sem_Ch8 is Nkind (Original_Node (Nam)) /= N_Attribute_Reference) or else (Nkind (Nam) = N_Type_Conversion - and then Is_Tagged_Type (Entity (Subtype_Mark (Nam)))) + and then Is_Tagged_Type (Entity (Subtype_Mark (Nam)))) then null; @@ -1385,9 +1408,7 @@ package body Sem_Ch8 is begin E := First_Entity (Old_P); - while Present (E) - and then E /= New_P - loop + while Present (E) and then E /= New_P loop if Is_Type (E) and then Nkind (Parent (E)) = N_Subtype_Declaration then @@ -1589,8 +1610,7 @@ package body Sem_Ch8 is begin if (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Entry_Family) or else (Nkind (P) = N_Selected_Component - and then - Ekind (Entity (Selector_Name (P))) = E_Entry_Family) + and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family) then if Is_Entity_Name (P) then Old_S := Entity (P); @@ -1982,13 +2002,11 @@ package body Sem_Ch8 is Ren_Formal := First_Formal (Ren); Sub_Formal := First_Formal (Sub); - while Present (Ren_Formal) - and then Present (Sub_Formal) - loop + while Present (Ren_Formal) and then Present (Sub_Formal) loop if Has_Null_Exclusion (Parent (Ren_Formal)) and then not (Has_Null_Exclusion (Parent (Sub_Formal)) - or else Can_Never_Be_Null (Etype (Sub_Formal))) + or else Can_Never_Be_Null (Etype (Sub_Formal))) then Error_Msg_NE ("`NOT NULL` required for parameter &", @@ -2004,9 +2022,8 @@ package body Sem_Ch8 is if Nkind (Parent (Ren)) = N_Function_Specification and then Nkind (Parent (Sub)) = N_Function_Specification and then Has_Null_Exclusion (Parent (Ren)) - and then - not (Has_Null_Exclusion (Parent (Sub)) - or else Can_Never_Be_Null (Etype (Sub))) + and then not (Has_Null_Exclusion (Parent (Sub)) + or else Can_Never_Be_Null (Etype (Sub))) then Error_Msg_N ("return must specify `NOT NULL`", @@ -2081,9 +2098,7 @@ package body Sem_Ch8 is then F_Nam := First_Entity (Entity (Nam)); F_Spec := First_Formal (Formal_Spec); - while Present (F_Nam) - and then Present (F_Spec) - loop + while Present (F_Nam) and then Present (F_Spec) loop if Is_Controlling_Formal (F_Nam) and then Has_Unknown_Discriminants (Etype (F_Spec)) and then not Is_Class_Wide_Type (Etype (F_Spec)) @@ -2114,10 +2129,8 @@ package body Sem_Ch8 is if Present (Alias (Subp)) then return Alias (Subp); - elsif - Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration - and then Present - (Corresponding_Body (Unit_Declaration_Node (Subp))) + elsif Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Unit_Declaration_Node (Subp))) then -- Check if renamed entity is a renaming_as_body @@ -2167,7 +2180,8 @@ package body Sem_Ch8 is -- this must be treated as a normal attribute reference, to be -- expanded in subsequent instantiations. - if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) + if Is_Actual + and then Is_Abstract_Subprogram (Formal_Spec) and then Full_Expander_Active then declare @@ -2382,8 +2396,8 @@ package body Sem_Ch8 is pragma Assert (Is_Primitive (Entity (Nam)) - and then - Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam)))); + and then + Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam)))); declare Old_Decl : constant Node_Id := Unit_Declaration_Node (Rename_Spec); @@ -2421,6 +2435,7 @@ package body Sem_Ch8 is -- constructed later at the freeze point, so indicate that the -- completion has not been seen yet. + Set_Contract (New_S, Empty); Set_Ekind (New_S, E_Subprogram_Body); New_S := Rename_Spec; Set_Has_Completion (Rename_Spec, False); @@ -2490,8 +2505,7 @@ package body Sem_Ch8 is (Is_Tagged_Type (T) or else (Is_Access_Type (T) - and then - Is_Tagged_Type (Designated_Type (T)))) + and then Is_Tagged_Type (Designated_Type (T)))) and then Scope (Entity (Selector_Name (Nam))) /= T then Analyze_Renamed_Primitive_Operation @@ -2506,9 +2520,7 @@ package body Sem_Ch8 is -- This is not allowed for renaming as body if the renamed -- spec is already frozen (see RM 8.5.4(5) for details). - if Present (Rename_Spec) - and then Is_Frozen (Rename_Spec) - then + if Present (Rename_Spec) and then Is_Frozen (Rename_Spec) then Error_Msg_N ("renaming-as-body cannot rename entry as subprogram", N); Error_Msg_NE @@ -2607,9 +2619,7 @@ package body Sem_Ch8 is -- when performing a null exclusion check between a renaming and a -- renamed subprogram that has been found to be illegal. - if Ada_Version >= Ada_2005 - and then Entity (Nam) /= Any_Id - then + if Ada_Version >= Ada_2005 and then Entity (Nam) /= Any_Id then Check_Null_Exclusion (Ren => New_S, Sub => Entity (Nam)); @@ -2710,13 +2720,11 @@ package body Sem_Ch8 is if CW_Actual then null; - else + elsif not Is_Actual or else No (Enclosing_Instance) then Check_Mode_Conformant (New_S, Old_S); end if; - if Is_Actual - and then Error_Posted (New_S) - then + if Is_Actual and then Error_Posted (New_S) then Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S); end if; end if; @@ -2750,13 +2758,12 @@ package body Sem_Ch8 is Set_Is_Intrinsic_Subprogram (New_S, - Is_Intrinsic_Subprogram (Old_S) - and then - (Chars (Old_S) /= Name_Op_Ne - or else Ekind (Old_S) = E_Operator - or else - Is_Intrinsic_Subprogram - (Corresponding_Equality (Old_S)))); + Is_Intrinsic_Subprogram (Old_S) + and then + (Chars (Old_S) /= Name_Op_Ne + or else Ekind (Old_S) = E_Operator + or else Is_Intrinsic_Subprogram + (Corresponding_Equality (Old_S)))); if Ekind (Alias (New_S)) = E_Operator then Set_Has_Delayed_Freeze (New_S, False); @@ -2821,13 +2828,13 @@ package body Sem_Ch8 is and then Entity (Prefix (Nam)) = Current_Scope and then Chars (Selector_Name (Nam)) = Chars (New_S) then - if Overriding_Renamings then - null; + -- This is an error, but we overlook the error and accept the + -- renaming if the special Overriding_Renamings mode is in effect. - else + if not Overriding_Renamings then Error_Msg_NE - ("implicit operation& is not visible (RM 8.3 (15))", - Nam, Old_S); + ("implicit operation& is not visible (RM 8.3 (15))", + Nam, Old_S); end if; end if; @@ -2909,7 +2916,6 @@ package body Sem_Ch8 is F1 := First_Formal (Candidate_Renaming); F2 := First_Formal (New_S); T1 := First_Subtype (Etype (F1)); - while Present (F1) and then Present (F2) loop Next_Formal (F1); Next_Formal (F2); @@ -2980,9 +2986,8 @@ package body Sem_Ch8 is if Comes_From_Source (N) and then Present (Old_S) - and then - (Nkind (Old_S) = N_Defining_Operator_Symbol - or else Ekind (Old_S) = E_Operator) + and then (Nkind (Old_S) = N_Defining_Operator_Symbol + or else Ekind (Old_S) = E_Operator) and then Nkind (New_S) = N_Defining_Operator_Symbol and then Chars (Old_S) /= Chars (New_S) then @@ -3003,9 +3008,8 @@ package body Sem_Ch8 is and then Comes_From_Source (N) and then Scope (Old_S) /= Standard_Standard and then Warn_On_Redundant_Constructs - and then - (Is_Immediately_Visible (Old_S) - or else Is_Potentially_Use_Visible (Old_S)) + and then (Is_Immediately_Visible (Old_S) + or else Is_Potentially_Use_Visible (Old_S)) and then Is_Overloadable (Current_Scope) and then Chars (Current_Scope) /= Chars (Old_S) then @@ -3102,9 +3106,7 @@ package body Sem_Ch8 is if Is_Entity_Name (Pack_Name) then Pack := Entity (Pack_Name); - if Ekind (Pack) /= E_Package - and then Etype (Pack) /= Any_Type - then + if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then if Ekind (Pack) = E_Generic_Package then Error_Msg_N -- CODEFIX ("a generic package is not allowed in a use clause", @@ -3224,14 +3226,12 @@ package body Sem_Ch8 is function Mentioned (Nam : Node_Id) return Boolean is begin return Nkind (Name (Item)) = N_Selected_Component - and then - Chars (Prefix (Name (Item))) = Chars (Nam); + and then Chars (Prefix (Name (Item))) = Chars (Nam); end Mentioned; begin Pref := Prefix (Id); Item := First (Context_Items (Parent (N))); - while Present (Item) and then Item /= N loop if Nkind (Item) = N_With_Clause and then Limited_Present (Item) @@ -3260,9 +3260,7 @@ package body Sem_Ch8 is begin if In_Open_Scopes (Pack) then - if Warn_On_Redundant_Constructs - and then Pack = Current_Scope - then + if Warn_On_Redundant_Constructs and then Pack = Current_Scope then Error_Msg_NE -- CODEFIX ("& is already use-visible within itself?r?", Pack_Name, Pack); end if; @@ -3365,13 +3363,9 @@ package body Sem_Ch8 is Error_Msg_N ("illegal expressions in attribute reference", Nam); elsif - Aname = Name_Compose or else - Aname = Name_Exponent or else - Aname = Name_Leading_Part or else - Aname = Name_Pos or else - Aname = Name_Round or else - Aname = Name_Scaling or else - Aname = Name_Val + Nam_In (Aname, Name_Compose, Name_Exponent, Name_Leading_Part, + Name_Pos, Name_Round, Name_Scaling, + Name_Val) then if Nkind (N) = N_Subprogram_Renaming_Declaration and then Present (Corresponding_Formal_Spec (N)) @@ -3572,9 +3566,7 @@ package body Sem_Ch8 is Old_S : Entity_Id; begin - if Is_Frozen (Subp) - and then not Has_Completion (Subp) - then + if Is_Frozen (Subp) and then not Has_Completion (Subp) then B_Node := Build_Renamed_Body (Parent (Declaration_Node (Subp)), Defining_Entity (N)); @@ -3591,12 +3583,10 @@ package body Sem_Ch8 is Analyze (B_Node); end if; - if Is_Intrinsic_Subprogram (Old_S) - and then not In_Instance - then + if Is_Intrinsic_Subprogram (Old_S) and then not In_Instance then Error_Msg_N ("subprogram used in renaming_as_body cannot be intrinsic", - Name (N)); + Name (N)); end if; else @@ -3629,11 +3619,10 @@ package body Sem_Ch8 is -- for details on their handling. elsif Is_Concurrent_Type (Scope (E)) then - P := Parent (N); while Present (P) and then not Nkind_In (P, N_Parameter_Specification, - N_Component_Declaration) + N_Component_Declaration) loop P := Parent (P); end loop; @@ -3670,13 +3659,10 @@ package body Sem_Ch8 is begin Item := First (Context_Items (Parent (N))); - - while Present (Item) - and then Item /= N - loop + while Present (Item) and then Item /= N loop if Nkind (Item) = N_With_Clause - -- Protect the frontend against previous critical errors + -- Protect the frontend against previous critical errors and then Nkind (Name (Item)) /= N_Selected_Component and then Entity (Name (Item)) = Pack @@ -3745,9 +3731,9 @@ package body Sem_Ch8 is ("renamed unit must be a child unit of generic parent", Name (N)); elsif Nkind (N) in N_Generic_Renaming_Declaration - and then Nkind (Name (N)) = N_Expanded_Name - and then Is_Generic_Instance (Entity (Prefix (Name (N)))) - and then Is_Generic_Unit (Old_E) + and then Nkind (Name (N)) = N_Expanded_Name + and then Is_Generic_Instance (Entity (Prefix (Name (N)))) + and then Is_Generic_Unit (Old_E) then Error_Msg_N ("renamed generic unit must be a library unit", Name (N)); @@ -3766,6 +3752,30 @@ package body Sem_Ch8 is end if; end Check_Library_Unit_Renaming; + ------------------------ + -- Enclosing_Instance -- + ------------------------ + + function Enclosing_Instance return Entity_Id is + S : Entity_Id; + + begin + if not Is_Generic_Instance (Current_Scope) then + return Empty; + end if; + + S := Scope (Current_Scope); + while S /= Standard_Standard loop + if Is_Generic_Instance (S) then + return S; + end if; + + S := Scope (S); + end loop; + + return Empty; + end Enclosing_Instance; + --------------- -- End_Scope -- --------------- @@ -3952,16 +3962,14 @@ package body Sem_Ch8 is if Nkind (Id) = N_Defining_Operator_Symbol and then - (Is_Primitive_Operator_In_Use - (Id, First_Formal (Id)) - or else - (Present (Next_Formal (First_Formal (Id))) - and then - Is_Primitive_Operator_In_Use - (Id, Next_Formal (First_Formal (Id))))) + (Is_Primitive_Operator_In_Use (Id, First_Formal (Id)) + or else + (Present (Next_Formal (First_Formal (Id))) + and then + Is_Primitive_Operator_In_Use + (Id, Next_Formal (First_Formal (Id))))) then null; - else Set_Is_Potentially_Use_Visible (Id, False); end if; @@ -4222,10 +4230,10 @@ package body Sem_Ch8 is Nkind (N) = N_Identifier and then (Nkind (Parent (N)) = N_Procedure_Call_Statement - or else - (Nkind (Parent (N)) = N_Parameter_Association - and then N = Explicit_Actual_Parameter (Parent (N)) - and then Nkind (Parent (Parent (N))) = + or else + (Nkind (Parent (N)) = N_Parameter_Association + and then N = Explicit_Actual_Parameter (Parent (N)) + and then Nkind (Parent (Parent (N))) = N_Procedure_Call_Statement)); end Is_Actual_Parameter; @@ -4558,7 +4566,7 @@ package body Sem_Ch8 is -- is put or put_line, then add a special error message (since -- this is a very common error for beginners to make). - if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then + if Nam_In (Chars (N), Name_Put, Name_Put_Line) then Error_Msg_N -- CODEFIX ("\\possible missing `WITH Ada.Text_'I'O; " & "USE Ada.Text_'I'O`!", N); @@ -4802,9 +4810,7 @@ package body Sem_Ch8 is -- Find current instance Inst := Current_Scope; - while Present (Inst) - and then Inst /= Standard_Standard - loop + while Present (Inst) and then Inst /= Standard_Standard loop if Is_Generic_Instance (Inst) then exit; end if; @@ -5202,9 +5208,7 @@ package body Sem_Ch8 is end; if No (Id) - and then (Ekind (P_Name) = E_Procedure - or else - Ekind (P_Name) = E_Function) + and then Ekind_In (P_Name, E_Procedure, E_Function) and then Is_Generic_Instance (P_Name) then -- Expanded name denotes entity in (instance of) generic subprogram. @@ -5463,9 +5467,7 @@ 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 Ekind (P_Name) = E_Package and then From_With_Type (P_Name) then if From_With_Type (Id) or else Is_Type (Id) or else Ekind (Id) = E_Package @@ -5481,11 +5483,11 @@ package body Sem_Ch8 is if Is_Task_Type (P_Name) and then ((Ekind (Id) = E_Entry - and then Nkind (Parent (N)) /= N_Attribute_Reference) + and then Nkind (Parent (N)) /= N_Attribute_Reference) or else - (Ekind (Id) = E_Entry_Family - and then - Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) + (Ekind (Id) = E_Entry_Family + and then + Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) then -- If both the task type and the entry are in scope, this may still -- be the expanded name of an entry formal. @@ -5538,18 +5540,15 @@ package body Sem_Ch8 is if Ekind (Id) = E_Void then Premature_Usage (N); - elsif Is_Overloadable (Id) - and then Present (Homonym (Id)) - then + elsif Is_Overloadable (Id) and then Present (Homonym (Id)) then declare H : Entity_Id := Homonym (Id); begin while Present (H) loop if Scope (H) = Scope (Id) - and then - (not Is_Hidden (H) - or else Is_Immediately_Visible (H)) + and then (not Is_Hidden (H) + or else Is_Immediately_Visible (H)) then Collect_Interps (N); exit; @@ -5618,17 +5617,6 @@ package body Sem_Ch8 is Old_S : Entity_Id; Inst : Entity_Id; - function Enclosing_Instance return Entity_Id; - -- If the renaming determines the entity for the default of a formal - -- subprogram nested within another instance, choose the innermost - -- candidate. This is because if the formal has a box, and we are within - -- an enclosing instance where some candidate interpretations are local - -- to this enclosing instance, we know that the default was properly - -- resolved when analyzing the generic, so we prefer the local - -- candidates to those that are external. This is not always the case - -- but is a reasonable heuristic on the use of nested generics. The - -- proper solution requires a full renaming model. - function Is_Visible_Operation (Op : Entity_Id) return Boolean; -- If the renamed entity is an implicit operator, check whether it is -- visible because its operand type is properly visible. This check @@ -5644,32 +5632,6 @@ package body Sem_Ch8 is -- Determine whether a candidate subprogram is defined within the -- enclosing instance. If yes, it has precedence over outer candidates. - ------------------------ - -- Enclosing_Instance -- - ------------------------ - - function Enclosing_Instance return Entity_Id is - S : Entity_Id; - - begin - if not Is_Generic_Instance (Current_Scope) - and then not Is_Actual - then - return Empty; - end if; - - S := Scope (Current_Scope); - while S /= Standard_Standard loop - if Is_Generic_Instance (S) then - return S; - end if; - - S := Scope (S); - end loop; - - return Empty; - end Enclosing_Instance; - -------------------------- -- Is_Visible_Operation -- -------------------------- @@ -5683,9 +5645,8 @@ package body Sem_Ch8 is if Ekind (Op) /= E_Operator or else Scope (Op) /= Standard_Standard or else (In_Instance - and then - (not Is_Actual - or else Present (Enclosing_Instance))) + and then (not Is_Actual + or else Present (Enclosing_Instance))) then return True; @@ -5776,7 +5737,10 @@ package body Sem_Ch8 is Candidate_Renaming := Empty; if not Is_Overloaded (Nam) then - if Entity_Matches_Spec (Entity (Nam), New_S) then + if Is_Actual and then Present (Enclosing_Instance) then + Old_S := Entity (Nam); + + elsif Entity_Matches_Spec (Entity (Nam), New_S) then Candidate_Renaming := New_S; if Is_Visible_Operation (Entity (Nam)) then @@ -5786,8 +5750,8 @@ package body Sem_Ch8 is elsif Present (First_Formal (Entity (Nam))) and then Present (First_Formal (New_S)) - and then (Base_Type (Etype (First_Formal (Entity (Nam)))) - = Base_Type (Etype (First_Formal (New_S)))) + and then (Base_Type (Etype (First_Formal (Entity (Nam)))) = + Base_Type (Etype (First_Formal (New_S)))) then Candidate_Renaming := Entity (Nam); end if; @@ -5851,8 +5815,8 @@ package body Sem_Ch8 is elsif Present (First_Formal (It.Nam)) and then Present (First_Formal (New_S)) - and then (Base_Type (Etype (First_Formal (It.Nam))) - = Base_Type (Etype (First_Formal (New_S)))) + and then (Base_Type (Etype (First_Formal (It.Nam))) = + Base_Type (Etype (First_Formal (New_S)))) then Candidate_Renaming := It.Nam; end if; @@ -5964,10 +5928,10 @@ package body Sem_Ch8 is ((RTE_Available (RE_Dispatch_Table_Wrapper) and then Scope (Selector) = RTE (RE_Dispatch_Table_Wrapper)) - or else - (RTE_Available (RE_No_Dispatch_Table_Wrapper) - and then Scope (Selector) = - RTE (RE_No_Dispatch_Table_Wrapper))) + or else + (RTE_Available (RE_No_Dispatch_Table_Wrapper) + and then Scope (Selector) = + RTE (RE_No_Dispatch_Table_Wrapper))) then C_Etype := Empty; @@ -6071,7 +6035,7 @@ package body Sem_Ch8 is elsif Is_Appropriate_For_Entry_Prefix (P_Type) and then not In_Open_Scopes (P_Name) and then (not Is_Concurrent_Type (Etype (P_Name)) - or else not In_Open_Scopes (Etype (P_Name))) + or else not In_Open_Scopes (Etype (P_Name))) then -- Call to protected operation or entry. Type checking is -- needed on the prefix. @@ -6148,9 +6112,9 @@ package body Sem_Ch8 is -- entry, as is P.X; this is an error. if Ekind (P_Name) /= E_Function - and then (not Is_Overloaded (P) - or else - Nkind (Parent (N)) = N_Procedure_Call_Statement) + and then + (not Is_Overloaded (P) + or else Nkind (Parent (N)) = N_Procedure_Call_Statement) then -- Prefix may mention a package that is hidden by a local -- declaration: let the user know. Scan the full homonym @@ -6327,9 +6291,7 @@ package body Sem_Ch8 is -- Warn_On_Obsolescent_ Feature). Once this issue -- is cleared in the sources, it can be enabled. - elsif Warn_On_Obsolescent_Feature - and then False - then + elsif Warn_On_Obsolescent_Feature and then False then Error_Msg_N ("applying 'Class to an untagged incomplete type" & " is an obsolescent feature (RM J.11)?r?", N); @@ -6596,9 +6558,7 @@ package body Sem_Ch8 is Priv_Id : Entity_Id := Empty; begin - if Ekind (P) = E_Package - and then not In_Open_Scopes (P) - then + if Ekind (P) = E_Package and then not In_Open_Scopes (P) then Priv_Id := First_Private_Entity (P); end if; @@ -6611,9 +6571,7 @@ package body Sem_Ch8 is end if; Id := First_Entity (P); - while Present (Id) - and then Id /= Priv_Id - loop + while Present (Id) and then Id /= Priv_Id loop if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then -- We replace the node with the literal itself, resolve as a @@ -6695,7 +6653,6 @@ package body Sem_Ch8 is begin Predef_Op := Current_Entity (Selector_Name (N)); - while Present (Predef_Op) and then Scope (Predef_Op) /= Standard_Standard loop @@ -6760,9 +6717,7 @@ package body Sem_Ch8 is -- Start of processing for Has_Implicit_Operator begin - if Ekind (P) = E_Package - and then not In_Open_Scopes (P) - then + if Ekind (P) = E_Package and then not In_Open_Scopes (P) then Priv_Id := First_Private_Entity (P); end if; @@ -7202,9 +7157,7 @@ package body Sem_Ch8 is -- of the stack is related to the current compilation. Scop := Current_Scope; - while Present (Scop) - and then Scop /= Standard_Standard - loop + while Present (Scop) and then Scop /= Standard_Standard loop if Is_Compilation_Unit (Scop) and then not Is_Child_Unit (Scop) then @@ -7495,14 +7448,9 @@ package body Sem_Ch8 is -- name resolution on component associations. (see 4717-008). In such a -- case, look for the visible homonym on the chain. - if In_Instance - and then Present (Homonym (E)) - then + if In_Instance and then Present (Homonym (E)) then E := Homonym (E); - - while Present (E) - and then not In_Open_Scopes (Scope (E)) - loop + while Present (E) and then not In_Open_Scopes (Scope (E)) loop E := Homonym (E); end loop; @@ -7609,16 +7557,14 @@ package body Sem_Ch8 is if No (With_Sys) and then (Nkind (The_Unit) = N_Package_Body - or else (Nkind (The_Unit) = N_Subprogram_Body - and then - not Acts_As_Spec (Cunit (Current_Sem_Unit)))) + or else (Nkind (The_Unit) = N_Subprogram_Body + and then not Acts_As_Spec (Cunit (Current_Sem_Unit)))) then With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit))); end if; - if No (With_Sys) - and then Present (N) - then + if No (With_Sys) and then Present (N) then + -- If we are compiling a subunit, we need to examine its -- context as well (Current_Sem_Unit is the parent unit); @@ -7735,8 +7681,9 @@ package body Sem_Ch8 is else pragma Assert (Nkind (Parent (E)) = N_Defining_Program_Unit_Name - and then - Nkind (Parent (Parent (E))) = N_Package_Specification); + and then + Nkind (Parent (Parent (E))) = + N_Package_Specification); Set_Is_Immediately_Visible (E, Limited_View_Installed (Parent (Parent (E)))); end if; @@ -7746,9 +7693,8 @@ package body Sem_Ch8 is Next_Entity (E); - if not Full_Vis - and then Is_Package_Or_Generic_Package (S) - then + if not Full_Vis and then Is_Package_Or_Generic_Package (S) then + -- We are in the visible part of the package scope exit when E = First_Private_Entity (S); @@ -7798,8 +7744,7 @@ package body Sem_Ch8 is elsif Is_Hidden_Open_Scope (S) then null; - elsif (Ekind (S) = E_Procedure - or else Ekind (S) = E_Function) + elsif Ekind_In (S, E_Procedure, E_Function) and then Has_Completion (S) then Full_Vis := True; @@ -7974,7 +7919,7 @@ package body Sem_Ch8 is Id := First_Entity (P); while Present (Id) and then (Id /= First_Private_Entity (P) - or else Private_With_OK) -- Ada 2005 (AI-262) + or else Private_With_OK) -- Ada 2005 (AI-262) loop Prev := Current_Entity (Id); while Present (Prev) loop @@ -8042,10 +7987,10 @@ package body Sem_Ch8 is elsif Ekind (Prev) = E_Operator and then Operator_Matches_Spec (Prev, Id) and then In_Open_Scopes - (Scope (Base_Type (Etype (First_Formal (Id))))) + (Scope (Base_Type (Etype (First_Formal (Id))))) and then (No (Next_Formal (First_Formal (Id))) - or else Etype (First_Formal (Id)) - = Etype (Next_Formal (First_Formal (Id))) + or else Etype (First_Formal (Id)) = + Etype (Next_Formal (First_Formal (Id))) or else Chars (Prev) = Name_Op_Expon) then goto Next_Usable_Entity; @@ -8074,14 +8019,11 @@ package body Sem_Ch8 is -- On exit, we know entity is not hidden, unless it is private if not Is_Hidden (Id) - and then ((not Is_Child_Unit (Id)) - or else Is_Visible_Lib_Unit (Id)) + and then ((not Is_Child_Unit (Id)) or else Is_Visible_Lib_Unit (Id)) then Set_Is_Potentially_Use_Visible (Id); - if Is_Private_Type (Id) - and then Present (Full_View (Id)) - then + if Is_Private_Type (Id) and then Present (Full_View (Id)) then Set_Is_Potentially_Use_Visible (Full_View (Id)); end if; end if; @@ -8252,12 +8194,10 @@ 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_With_Type (T) and then From_With_Type (Scope (T)) then Error_Msg_N ("incomplete type from limited view " - & "cannot appear in use clause", Id); + & "cannot appear in use clause", Id); -- If the subtype mark designates a subtype in a different package, -- we have to check that the parent type is visible, otherwise the @@ -8321,18 +8261,18 @@ package body Sem_Ch8 is if Warn_On_Redundant_Constructs and then Is_Known_Used - -- with P; with P; use P; - -- package P is package X is package body X is - -- type T ... use P.T; + -- with P; with P; use P; + -- package P is package X is package body X is + -- type T ... use P.T; - -- The compilation unit is the body of X. GNAT first compiles the - -- spec of X, then proceeds to the body. At that point P is marked - -- as use visible. The analysis then reinstalls the spec along with - -- its context. The use clause P.T is now recognized as redundant, - -- but in the wrong context. Do not emit a warning in such cases. - -- Do not emit a warning either if we are in an instance, there is - -- no redundancy between an outer use_clause and one that appears - -- within the generic. + -- The compilation unit is the body of X. GNAT first compiles the + -- spec of X, then proceeds to the body. At that point P is marked + -- as use visible. The analysis then reinstalls the spec along with + -- its context. The use clause P.T is now recognized as redundant, + -- but in the wrong context. Do not emit a warning in such cases. + -- Do not emit a warning either if we are in an instance, there is + -- no redundancy between an outer use_clause and one that appears + -- within the generic. and then not Spec_Reloaded_For_Body and then not In_Instance @@ -8386,7 +8326,6 @@ package body Sem_Ch8 is and then Nkind (Parent (Clause2)) = N_Compilation_Unit then - -- If the unit is a subprogram body that acts as spec, -- the context clause is shared with the constructed -- subprogram spec. Clearly there is no redundancy. diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index be14d47ef5c..1f91d9612e0 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2012, 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- -- @@ -52,7 +52,7 @@ with GNAT.HTable; package body Sem_Dim is ------------------------- - -- Rational arithmetic -- + -- Rational Arithmetic -- ------------------------- type Whole is new Int; @@ -91,7 +91,7 @@ package body Sem_Dim is function "/" (Left, Right : Rational) return Rational; ------------------ - -- System types -- + -- System Types -- ------------------ Max_Number_Of_Dimensions : constant := 7; @@ -144,7 +144,7 @@ package body Sem_Dim is Table_Name => "System_Table"); -------------------- - -- Dimension type -- + -- Dimension Type -- -------------------- type Dimension_Type is @@ -168,7 +168,7 @@ package body Sem_Dim is Equal => "="); ------------------ - -- Symbol types -- + -- Symbol Types -- ------------------ type Symbol_Table_Range is range 0 .. 510; @@ -441,24 +441,17 @@ package body Sem_Dim is -- Analyze_Aspect_Dimension -- ------------------------------ - -- with Dimension => ( - -- [[Symbol =>] SYMBOL,] - -- DIMENSION_VALUE - -- [, DIMENSION_VALUE] - -- [, DIMENSION_VALUE] - -- [, DIMENSION_VALUE] - -- [, DIMENSION_VALUE] - -- [, DIMENSION_VALUE] - -- [, DIMENSION_VALUE]); + -- with Dimension => + -- ([Symbol =>] SYMBOL, DIMENSION_VALUE {, DIMENSION_Value}) -- -- SYMBOL ::= STRING_LITERAL | CHARACTER_LITERAL -- DIMENSION_VALUE ::= -- RATIONAL - -- | others => RATIONAL + -- | others => RATIONAL -- | DISCRETE_CHOICE_LIST => RATIONAL - -- RATIONAL ::= [-] NUMERAL [/ NUMERAL] + -- RATIONAL ::= [-] NUMERIC_LITERAL [/ NUMERIC_LITERAL] -- Note that when the dimensioned type is an integer type, then any -- dimension value must be an integer literal. @@ -468,7 +461,7 @@ package body Sem_Dim is Id : Entity_Id; Aggr : Node_Id) is - Def_Id : constant Entity_Id := Defining_Identifier (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); Processed : array (Dimension_Type'Range) of Boolean := (others => False); -- This array is used when processing ranges or Others_Choice as part of @@ -855,14 +848,7 @@ package body Sem_Dim is -- Analyze_Aspect_Dimension_System -- ------------------------------------- - -- with Dimension_System => ( - -- DIMENSION - -- [, DIMENSION] - -- [, DIMENSION] - -- [, DIMENSION] - -- [, DIMENSION] - -- [, DIMENSION] - -- [, DIMENSION]); + -- with Dimension_System => (DIMENSION {, DIMENSION}); -- DIMENSION ::= ( -- [Unit_Name =>] IDENTIFIER, @@ -957,9 +943,9 @@ package body Sem_Dim is if Present (Component_Associations (Dim_Aggr)) and then Present (Expressions (Dim_Aggr)) then - Error_Msg_N ("mixed positional/named aggregate not allowed " & - "here", - Dim_Aggr); + Error_Msg_N + ("mixed positional/named aggregate not allowed here", + Dim_Aggr); -- Verify each dimension aggregate has three arguments @@ -1039,13 +1025,12 @@ package body Sem_Dim is -- Check the second argument for each dimension aggregate is -- a string or a character. - if not Nkind_In - (Unit_Symbol, - N_String_Literal, - N_Character_Literal) + if not Nkind_In (Unit_Symbol, N_String_Literal, + N_Character_Literal) then - Error_Msg_N ("expected unit symbol (string or character)", - Unit_Symbol); + Error_Msg_N + ("expected unit symbol (string or character)", + Unit_Symbol); else -- String case @@ -1073,14 +1058,12 @@ package body Sem_Dim is -- Check the third argument for each dimension aggregate is -- a string or a character. - if not Nkind_In - (Dim_Symbol, - N_String_Literal, - N_Character_Literal) + if not Nkind_In (Dim_Symbol, N_String_Literal, + N_Character_Literal) then - Error_Msg_N ("expected dimension symbol (string or " & - "character)", - Dim_Symbol); + Error_Msg_N + ("expected dimension symbol (string or character)", + Dim_Symbol); else -- String case diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads index 2fdfd30ee6c..7393bf6cadd 100644 --- a/gcc/ada/sem_dim.ads +++ b/gcc/ada/sem_dim.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2012, 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- -- @@ -102,9 +102,9 @@ package Sem_Dim is Aggr : Node_Id); -- Analyze the contents of aspect Dimension_System. Extract the numerical -- type, unit name and corresponding symbol from each indivitual dimension. - -- Id is the corresponding Aspect_Id (Aspect_Dimension_System) - -- Aggr is the corresponding expression for the aspect Dimension_System - -- declared by the declaration of N. + -- Id is the corresponding Aspect_Id (Aspect_Dimension_System). Aggr is + -- the corresponding expression for the aspect Dimension_System from the + -- declaration of N. procedure Analyze_Dimension (N : Node_Id); -- N may denote any of the following contexts: diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 757e0ee732b..9f80a7dcea1 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.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- -- @@ -44,6 +44,7 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; @@ -536,6 +537,21 @@ package body Sem_Disp is Set_Entity (Name (N), Alias (Subp)); return; + -- An obscure special case: a null procedure may have a class- + -- wide pre/postcondition that includes a call to an abstract + -- subp. Calls within the expression may not have been rewritten + -- as dispatching calls yet, because the null body appears in + -- the current declarative part. The expression will be properly + -- rewritten/reanalyzed when the postcondition procedure is built. + + elsif In_Spec_Expression + and then Is_Subprogram (Current_Scope) + and then + Nkind (Parent (Current_Scope)) = N_Procedure_Specification + and then Null_Present (Parent (Current_Scope)) + then + null; + else -- We need to determine whether the context of the call -- provides a tag to make the call dispatching. This requires @@ -1181,12 +1197,25 @@ package body Sem_Disp is Ovr_Subp := Old_Subp; -- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be - -- overridden by Subp + -- overridden by Subp. This only applies to source subprograms, and + -- their declaration must carry an explicit overriding indicator. if No (Ovr_Subp) and then Ada_Version >= Ada_2012 + and then Comes_From_Source (Subp) + and then + Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration then Ovr_Subp := Find_Hidden_Overridden_Primitive (Subp); + + -- Verify that the proper overriding indicator has been supplied. + + if Present (Ovr_Subp) + and then + not Must_Override (Specification (Unit_Declaration_Node (Subp))) + then + Error_Msg_NE ("missing overriding indicator for&", Subp, Subp); + end if; end if; -- Now it should be a correct primitive operation, put it in the list @@ -1198,9 +1227,7 @@ package body Sem_Disp is Check_Subtype_Conformant (Subp, Ovr_Subp); - if (Chars (Subp) = Name_Initialize - or else Chars (Subp) = Name_Adjust - or else Chars (Subp) = Name_Finalize) + if Nam_In (Chars (Subp), Name_Initialize, Name_Adjust, Name_Finalize) and then Is_Controlled (Tagged_Type) and then not Is_Visibly_Controlled (Tagged_Type) then @@ -1371,11 +1398,10 @@ package body Sem_Disp is Set_DT_Position (Subp, No_Uint); elsif Has_Controlled_Component (Tagged_Type) - and then - (Chars (Subp) = Name_Initialize or else - Chars (Subp) = Name_Adjust or else - Chars (Subp) = Name_Finalize or else - Chars (Subp) = Name_Finalize_Address) + and then Nam_In (Chars (Subp), Name_Initialize, + Name_Adjust, + Name_Finalize, + Name_Finalize_Address) then declare F_Node : constant Node_Id := Freeze_Node (Tagged_Type); @@ -1842,12 +1868,14 @@ package body Sem_Disp is Vis_List : Elist_Id; begin - -- This Ada 2012 rule is valid only for type extensions or private - -- extensions. + -- This Ada 2012 rule applies only for type extensions or private + -- extensions, where the parent type is not in a parent unit, and + -- where an operation is never declared but still inherited. if No (Tag_Typ) or else not Is_Record_Type (Tag_Typ) or else Etype (Tag_Typ) = Tag_Typ + or else In_Open_Scopes (Scope (Etype (Tag_Typ))) then return Empty; end if; @@ -2445,7 +2473,7 @@ package body Sem_Disp is Set_Etype (Call_Node, Etype (Control)); Set_Analyzed (Call_Node); - Expand_Interface_Conversion (Call_Node, Is_Static => False); + Expand_Interface_Conversion (Call_Node); end if; end; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 74cbdf10df6..6d941025c0d 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2012, 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- -- @@ -2021,9 +2021,8 @@ package body Sem_Elab is elsif not Debug_Flag_Dot_UU and then Nkind (N) = N_Attribute_Reference - and then (Attribute_Name (N) = Name_Access - or else - Attribute_Name (N) = Name_Unrestricted_Access) + and then Nam_In (Attribute_Name (N), Name_Access, + Name_Unrestricted_Access) and then Is_Entity_Name (Prefix (N)) and then Is_Subprogram (Entity (Prefix (N))) then @@ -2258,7 +2257,7 @@ package body Sem_Elab is -- in this case, due to the out of order handling in this case. and then (Nkind (Original_Node (N)) /= N_Function_Call - or else not In_Assertion (Original_Node (N))) + or else not In_Assertion_Expression (Original_Node (N))) then if Inst_Case then Error_Msg_NE @@ -3339,9 +3338,11 @@ package body Sem_Elab is if Nkind (Item) = N_Pragma and then Pragma_Name (Item) = Name_Elaborate_All then - -- Return if some previous error on the pragma itself + -- Return if some previous error on the pragma itself. The + -- pragma may be unanalyzed, because of a previous error, or + -- if it is the context of a subunit, inherited by its parent. - if Error_Posted (Item) then + if Error_Posted (Item) or else not Analyzed (Item) then return; end if; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index ab7f3c934ae..94ce100a7c5 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.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- -- @@ -528,9 +528,7 @@ package body Sem_Eval is -- Fixup only required for First/Last attribute reference if Nkind (N) = N_Attribute_Reference - and then (Attribute_Name (N) = Name_First - or else - Attribute_Name (N) = Name_Last) + and then Nam_In (Attribute_Name (N), Name_First, Name_Last) then Xtyp := Etype (Prefix (N)); @@ -697,9 +695,7 @@ package body Sem_Eval is elsif Nkind (Lf) = N_Attribute_Reference and then Attribute_Name (Lf) = Attribute_Name (Rf) - and then (Attribute_Name (Lf) = Name_First - or else - Attribute_Name (Lf) = Name_Last) + and then Nam_In (Attribute_Name (Lf), Name_First, Name_Last) and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name) and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name) and then Entity (Prefix (Lf)) = Entity (Prefix (Rf)) @@ -1357,13 +1353,13 @@ package body Sem_Eval is if Ekind (E) = E_Enumeration_Literal then return True; - -- In Alfa 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. + -- 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 (Alfa_Mode + and then not (SPARK_Mode and then Present (Full_View (E)) and then not In_Open_Scopes (Scope (E))) then @@ -1932,20 +1928,17 @@ package body Sem_Eval is Set_Is_Static_Expression (N, Stat); - if Stat then - - -- If left operand is the empty string, the result is the - -- right operand, including its bounds if anomalous. - - if Left_Len = 0 - and then Is_Array_Type (Etype (Right)) - and then Etype (Right) /= Any_String - then - Set_Etype (N, Etype (Right)); - end if; + -- If left operand is the empty string, the result is the + -- right operand, including its bounds if anomalous. - Fold_Str (N, Folded_Val, Static => True); + if Left_Len = 0 + and then Is_Array_Type (Etype (Right)) + and then Etype (Right) /= Any_String + then + Set_Etype (N, Etype (Right)); end if; + + Fold_Str (N, Folded_Val, Static => Stat); end; end Eval_Concatenation; @@ -3411,11 +3404,12 @@ package body Sem_Eval is -- is too long, or it is null, and the lower bound is type'First. In -- either case it is the upper bound that is out of range of the index -- type. - if Ada_Version >= Ada_95 then if Root_Type (Bas) = Standard_String or else Root_Type (Bas) = Standard_Wide_String + or else + Root_Type (Bas) = Standard_Wide_Wide_String then Xtp := Standard_Positive; else @@ -3428,24 +3422,54 @@ package body Sem_Eval is Lo := Type_Low_Bound (Etype (First_Index (Typ))); end if; + -- Check for string too long + Len := String_Length (Strval (N)); if UI_From_Int (Len) > String_Type_Len (Bas) then - Apply_Compile_Time_Constraint_Error - (N, "string literal too long for}", CE_Length_Check_Failed, - Ent => Bas, - Typ => First_Subtype (Bas)); + + -- Issue message. Note that this message is a warning if the + -- string literal is not marked as static (happens in some cases + -- of folding strings known at compile time, but not static). + -- Furthermore in such cases, we reword the message, since there + -- is no string literal in the source program! + + if Is_Static_Expression (N) then + Apply_Compile_Time_Constraint_Error + (N, "string literal too long for}", CE_Length_Check_Failed, + Ent => Bas, + Typ => First_Subtype (Bas)); + else + Apply_Compile_Time_Constraint_Error + (N, "string value too long for}", CE_Length_Check_Failed, + Ent => Bas, + Typ => First_Subtype (Bas), + Warn => True); + end if; + + -- Test for null string not allowed elsif Len = 0 and then not Is_Generic_Type (Xtp) and then Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp))) then - Apply_Compile_Time_Constraint_Error - (N, "null string literal not allowed for}", - CE_Length_Check_Failed, - Ent => Bas, - Typ => First_Subtype (Bas)); + -- Same specialization of message + + if Is_Static_Expression (N) then + Apply_Compile_Time_Constraint_Error + (N, "null string literal not allowed for}", + CE_Length_Check_Failed, + Ent => Bas, + Typ => First_Subtype (Bas)); + else + Apply_Compile_Time_Constraint_Error + (N, "null string value not allowed for}", + CE_Length_Check_Failed, + Ent => Bas, + Typ => First_Subtype (Bas), + Warn => True); + end if; end if; end if; end Eval_String_Literal; @@ -4091,7 +4115,7 @@ package body Sem_Eval is -- Note that we have to reset Is_Static_Expression both after the -- analyze step (because Resolve will evaluate the literal, which -- will cause semantic errors if it is marked as static), and after - -- the Resolve step (since Resolve in some cases sets this flag). + -- the Resolve step (since Resolve in some cases resets this flag). Analyze (N); Set_Is_Static_Expression (N, Static); @@ -5467,8 +5491,8 @@ package body Sem_Eval is if Raises_Constraint_Error (Expr) then Error_Msg_N - ("expression raises exception, cannot be static " & - "(RM 4.9(34))!", N); + ("\expression raises exception, cannot be static " & + "(RM 4.9(34))", N); return; end if; @@ -5488,8 +5512,8 @@ package body Sem_Eval is and then not Is_RTE (Typ, RE_Bignum) then Error_Msg_N - ("static expression must have scalar or string type " & - "(RM 4.9(2))!", N); + ("\static expression must have scalar or string type " & + "(RM 4.9(2))", N); return; end if; end if; @@ -5497,6 +5521,9 @@ package body Sem_Eval is -- If we got through those checks, test particular node kind case Nkind (N) is + + -- Entity name + when N_Expanded_Name | N_Identifier | N_Operator_Symbol => E := Entity (N); @@ -5504,30 +5531,84 @@ package body Sem_Eval is null; elsif Ekind (E) = E_Constant then - if not Is_Static_Expression (Constant_Value (E)) then - Error_Msg_NE - ("& is not a static constant (RM 4.9(5))!", N, E); - end if; + + -- One case we can give a metter message is when we have a + -- string literal created by concatenating an aggregate with + -- an others expression. + + Entity_Case : declare + CV : constant Node_Id := Constant_Value (E); + CO : constant Node_Id := Original_Node (CV); + + function Is_Aggregate (N : Node_Id) return Boolean; + -- See if node N came from an others aggregate, if so + -- return True and set Error_Msg_Sloc to aggregate. + + ------------------ + -- Is_Aggregate -- + ------------------ + + function Is_Aggregate (N : Node_Id) return Boolean is + begin + if Nkind (Original_Node (N)) = N_Aggregate then + Error_Msg_Sloc := Sloc (Original_Node (N)); + return True; + elsif Is_Entity_Name (N) + and then Ekind (Entity (N)) = E_Constant + and then + Nkind (Original_Node (Constant_Value (Entity (N)))) = + N_Aggregate + then + Error_Msg_Sloc := + Sloc (Original_Node (Constant_Value (Entity (N)))); + return True; + else + return False; + end if; + end Is_Aggregate; + + -- Start of processing for Entity_Case + + begin + if Is_Aggregate (CV) + or else (Nkind (CO) = N_Op_Concat + and then (Is_Aggregate (Left_Opnd (CO)) + or else + Is_Aggregate (Right_Opnd (CO)))) + then + Error_Msg_N ("\aggregate (#) is never static", N); + + elsif not Is_Static_Expression (CV) then + Error_Msg_NE + ("\& is not a static constant (RM 4.9(5))", N, E); + end if; + end Entity_Case; else Error_Msg_NE - ("& is not static constant or named number " & - "(RM 4.9(5))!", N, E); + ("\& is not static constant or named number " + & "(RM 4.9(5))", N, E); end if; + -- Binary operator + when N_Binary_Op | N_Short_Circuit | N_Membership_Test => if Nkind (N) in N_Op_Shift then Error_Msg_N - ("shift functions are never static (RM 4.9(6,18))!", N); + ("\shift functions are never static (RM 4.9(6,18))", N); else Why_Not_Static (Left_Opnd (N)); Why_Not_Static (Right_Opnd (N)); end if; + -- Unary operator + when N_Unary_Op => Why_Not_Static (Right_Opnd (N)); + -- Attribute reference + when N_Attribute_Reference => Why_Not_Static_List (Expressions (N)); @@ -5541,8 +5622,8 @@ package body Sem_Eval is if Attribute_Name (N) = Name_Size then Error_Msg_N - ("size attribute is only static for static scalar type " & - "(RM 4.9(7,8))", N); + ("\size attribute is only static for static scalar type " + & "(RM 4.9(7,8))", N); -- Flag array cases @@ -5554,15 +5635,15 @@ package body Sem_Eval is Attribute_Name (N) /= Name_Length then Error_Msg_N - ("static array attribute must be Length, First, or Last " & - "(RM 4.9(8))!", N); + ("\static array attribute must be Length, First, or Last " + & "(RM 4.9(8))", N); -- Since we know the expression is not-static (we already -- tested for this, must mean array is not static). else Error_Msg_N - ("prefix is non-static array (RM 4.9(8))!", Prefix (N)); + ("\prefix is non-static array (RM 4.9(8))", Prefix (N)); end if; return; @@ -5575,30 +5656,36 @@ package body Sem_Eval is Is_Generic_Type (E) then Error_Msg_N - ("attribute of generic type is never static " & - "(RM 4.9(7,8))!", N); + ("\attribute of generic type is never static " + & "(RM 4.9(7,8))", N); elsif Is_Static_Subtype (E) then null; elsif Is_Scalar_Type (E) then Error_Msg_N - ("prefix type for attribute is not static scalar subtype " & - "(RM 4.9(7))!", N); + ("\prefix type for attribute is not static scalar subtype " + & "(RM 4.9(7))", N); else Error_Msg_N - ("static attribute must apply to array/scalar type " & - "(RM 4.9(7,8))!", N); + ("\static attribute must apply to array/scalar type " + & "(RM 4.9(7,8))", N); end if; + -- String literal + when N_String_Literal => Error_Msg_N - ("subtype of string literal is non-static (RM 4.9(4))!", N); + ("\subtype of string literal is non-static (RM 4.9(4))", N); + + -- Explicit dereference when N_Explicit_Dereference => Error_Msg_N - ("explicit dereference is never static (RM 4.9)!", N); + ("\explicit dereference is never static (RM 4.9)", N); + + -- Function call when N_Function_Call => Why_Not_Static_List (Parameter_Associations (N)); @@ -5608,44 +5695,59 @@ package body Sem_Eval is -- scalar arithmetic operation. if not Is_RTE (Typ, RE_Bignum) then - Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N); + Error_Msg_N ("\non-static function call (RM 4.9(6,18))", N); end if; + -- Parameter assocation (test actual parameter) + when N_Parameter_Association => Why_Not_Static (Explicit_Actual_Parameter (N)); + -- Indexed component + when N_Indexed_Component => - Error_Msg_N - ("indexed component is never static (RM 4.9)!", N); + Error_Msg_N ("\indexed component is never static (RM 4.9)", N); + + -- Procedure call when N_Procedure_Call_Statement => - Error_Msg_N - ("procedure call is never static (RM 4.9)!", N); + Error_Msg_N ("\procedure call is never static (RM 4.9)", N); + + -- Qualified expression (test expression) when N_Qualified_Expression => Why_Not_Static (Expression (N)); + -- Aggregate + when N_Aggregate | N_Extension_Aggregate => - Error_Msg_N - ("an aggregate is never static (RM 4.9)!", N); + Error_Msg_N ("\an aggregate is never static (RM 4.9)", N); + + -- Range when N_Range => Why_Not_Static (Low_Bound (N)); Why_Not_Static (High_Bound (N)); + -- Range constraint, test range expression + when N_Range_Constraint => Why_Not_Static (Range_Expression (N)); + -- Subtype indication, test constraint + when N_Subtype_Indication => Why_Not_Static (Constraint (N)); + -- Selected component + when N_Selected_Component => - Error_Msg_N - ("selected component is never static (RM 4.9)!", N); + Error_Msg_N ("\selected component is never static (RM 4.9)", N); + + -- Slice when N_Slice => - Error_Msg_N - ("slice is never static (RM 4.9)!", N); + Error_Msg_N ("\slice is never static (RM 4.9)", N); when N_Type_Conversion => Why_Not_Static (Expression (N)); @@ -5654,13 +5756,17 @@ package body Sem_Eval is or else not Is_Static_Subtype (Entity (Subtype_Mark (N))) then Error_Msg_N - ("static conversion requires static scalar subtype result " & - "(RM 4.9(9))!", N); + ("\static conversion requires static scalar subtype result " + & "(RM 4.9(9))", N); end if; + -- Unchecked type conversion + when N_Unchecked_Type_Conversion => Error_Msg_N - ("unchecked type conversion is never static (RM 4.9)!", N); + ("\unchecked type conversion is never static (RM 4.9)", N); + + -- All other cases, no reason to give when others => null; diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 06607d77897..66a9e3ecc65 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.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- -- @@ -417,17 +417,17 @@ package Sem_Eval is procedure Why_Not_Static (Expr : Node_Id); -- This procedure may be called after generating an error message that - -- complains that something is non-static. If it finds good reasons, it - -- generates one or more error messages pointing the appropriate offending - -- component of the expression. If no good reasons can be figured out, then - -- no messages are generated. The expectation here is that the caller has - -- already issued a message complaining that the expression is non-static. - -- Note that this message should be placed using Error_Msg_F or - -- Error_Msg_FE, so that it will sort before any messages placed by this - -- call. Note that it is fine to call Why_Not_Static with something that is - -- not an expression, and usually this has no effect, but in some cases - -- (N_Parameter_Association or N_Range), it makes sense for the internal - -- recursive calls. + -- complains that something is non-static. If it finds good reasons, + -- it generates one or more continuation error messages pointing the + -- appropriate offending component of the expression. If no good reasons + -- can be figured out, then no messages are generated. The expectation here + -- is that the caller has already issued a message complaining that the + -- expression is non-static. Note that this message should be placed using + -- Error_Msg_F or Error_Msg_FE, so that it will sort before any messages + -- placed by this call. Note that it is fine to call Why_Not_Static with + -- something that is not an expression, and usually this has no effect, but + -- in some cases (N_Parameter_Association or N_Range), it makes sense for + -- the internal recursive calls. procedure Initialize; -- Initializes the internal data structures. Must be called before each diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index fe3855d33d6..ed607ce53c1 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.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- -- @@ -127,11 +127,9 @@ package body Sem_Intr is -- literal is legal even in Ada 83 mode, where such literals are -- not static. - if Cnam = Name_Import_Address - or else - Cnam = Name_Import_Largest_Value - or else - Cnam = Name_Import_Value + if Nam_In (Cnam, Name_Import_Address, + Name_Import_Largest_Value, + Name_Import_Value) then if Etype (Arg1) = Any_Type or else Raises_Constraint_Error (Arg1) @@ -196,30 +194,13 @@ package body Sem_Intr is begin -- Arithmetic operators - if Nam = Name_Op_Add - or else - Nam = Name_Op_Subtract - or else - Nam = Name_Op_Multiply - or else - Nam = Name_Op_Divide - or else - Nam = Name_Op_Rem - or else - Nam = Name_Op_Mod - or else - Nam = Name_Op_Abs + if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Multiply, + Name_Op_Divide, Name_Op_Rem, Name_Op_Mod, Name_Op_Abs) then T1 := Etype (First_Formal (E)); if No (Next_Formal (First_Formal (E))) then - - if Nam = Name_Op_Add - or else - Nam = Name_Op_Subtract - or else - Nam = Name_Op_Abs - then + if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Abs) then T2 := T1; -- Previous error in declaration @@ -254,17 +235,8 @@ package body Sem_Intr is -- Comparison operators - elsif Nam = Name_Op_Eq - or else - Nam = Name_Op_Ge - or else - Nam = Name_Op_Gt - or else - Nam = Name_Op_Le - or else - Nam = Name_Op_Lt - or else - Nam = Name_Op_Ne + elsif Nam_In (Nam, Name_Op_Eq, Name_Op_Ge, Name_Op_Gt, Name_Op_Le, + Name_Op_Lt, Name_Op_Ne) then T1 := Etype (First_Formal (E)); @@ -370,35 +342,22 @@ package body Sem_Intr is -- Shift cases. We allow user specification of intrinsic shift -- operators for any numeric types. - elsif - Nam = Name_Rotate_Left - or else - Nam = Name_Rotate_Right - or else - Nam = Name_Shift_Left - or else - Nam = Name_Shift_Right - or else - Nam = Name_Shift_Right_Arithmetic + elsif Nam_In (Nam, Name_Rotate_Left, Name_Rotate_Right, Name_Shift_Left, + Name_Shift_Right, Name_Shift_Right_Arithmetic) then Check_Shift (E, N); - elsif - Nam = Name_Exception_Information - or else - Nam = Name_Exception_Message - or else - Nam = Name_Exception_Name + elsif Nam_In (Nam, Name_Exception_Information, + Name_Exception_Message, + Name_Exception_Name) then Check_Exception_Function (E, N); elsif Nkind (E) = N_Defining_Operator_Symbol then Check_Intrinsic_Operator (E, N); - elsif Nam = Name_File - or else Nam = Name_Line - or else Nam = Name_Source_Location - or else Nam = Name_Enclosing_Entity + elsif Nam_In (Nam, Name_File, Name_Line, Name_Source_Location, + Name_Enclosing_Entity) then null; diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb index e2fce979a22..f71a477bf2c 100644 --- a/gcc/ada/sem_mech.adb +++ b/gcc/ada/sem_mech.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. -- -- -- -- 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- -- @@ -110,8 +110,9 @@ package body Sem_Mech is Class := First (Expressions (Mech_Name)); if Nkind (Prefix (Mech_Name)) /= N_Identifier - or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else - Chars (Prefix (Mech_Name)) = Name_Short_Descriptor) + or else + not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor, + Name_Short_Descriptor) or else Present (Next (Class)) then Bad_Mechanism; @@ -129,8 +130,9 @@ package body Sem_Mech is Param := First (Parameter_Associations (Mech_Name)); if Nkind (Name (Mech_Name)) /= N_Identifier - or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else - Chars (Name (Mech_Name)) = Name_Short_Descriptor) + or else + not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor, + Name_Short_Descriptor) or else Present (Next (Param)) or else No (Selector_Name (Param)) or else Chars (Selector_Name (Param)) /= Name_Class @@ -298,12 +300,14 @@ package body Sem_Mech is -- Ada -- --------- - -- Note: all RM defined conventions are treated the same - -- from the point of view of parameter passing mechanism + -- Note: all RM defined conventions are treated the same from + -- the point of view of parameter passing mechanism. Convention + -- Ghost has the same dynamic semantics as convention Ada. when Convention_Ada | Convention_Intrinsic | Convention_Entry | + Convention_Ghost | Convention_Protected | Convention_Stubbed => @@ -484,7 +488,6 @@ package body Sem_Mech is else Set_Mechanism (Formal, By_Reference); end if; - end case; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 32b5130f797..e148d05bbf2 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -168,6 +168,11 @@ package body Sem_Prag is -- Local Subprograms and Variables -- ------------------------------------- + procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id); + -- Subsidiary routine to the analysis of pragmas Depends and Global. Append + -- an input or output item to a list. If the list is empty, a new one is + -- created. + function Adjust_External_Name_Case (N : Node_Id) return Node_Id; -- This routine is used for possible casing adjustment of an explicit -- external name supplied as a string literal (the node N), according to @@ -176,15 +181,58 @@ package body Sem_Prag is -- to Uppercase or Lowercase, then a new string literal with appropriate -- casing is constructed. + function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean; + -- Subsidiary to the analysis of pragma Global and pragma Depends. Query + -- whether a particular item appears in a mixed list of nodes and entities. + -- It is assumed that all nodes in the list have entities. + + 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. + function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; -- If Def_Id refers to a renamed subprogram, then the base subprogram (the -- original one, following the renaming chain) is returned. Otherwise the -- entity is returned unchanged. Should be in Einfo??? + 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. + procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id); -- Preanalyze the boolean expressions in the Requires and Ensures arguments - -- of a Contract_Case or Test_Case pragma if present (possibly Empty). We - -- treat these as spec expressions (i.e. similar to a default expression). + -- of a Test_Case pragma if present (possibly Empty). We treat these as + -- spec expressions (i.e. similar to a default expression). + + 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 rv; -- This is a dummy function called by the processing for pragma Reviewable. @@ -192,11 +240,31 @@ package body Sem_Prag is -- pragma in the source program, a breakpoint on rv catches this place in -- the source, allowing convenient stepping to the point of interest. + 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 -- + -------------- + + procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is + begin + if No (To_List) then + To_List := New_Elmt_List; + end if; + + Append_Unique_Elmt (Item, To_List); + end Add_Item; + ------------------------------- -- Adjust_External_Name_Case -- ------------------------------- @@ -243,31 +311,1390 @@ package body Sem_Prag is end if; end Adjust_External_Name_Case; - ------------------------------ - -- Analyze_CTC_In_Decl_Part -- - ------------------------------ + ----------------------------------------- + -- Analyze_Contract_Cases_In_Decl_Part -- + ----------------------------------------- + + procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id) is + Others_Seen : Boolean := False; + + procedure Analyze_Contract_Case (CCase : Node_Id); + -- Verify the legality of a single contract case + + --------------------------- + -- Analyze_Contract_Case -- + --------------------------- + + procedure Analyze_Contract_Case (CCase : Node_Id) is + Case_Guard : Node_Id; + Conseq : Node_Id; + Extra_Guard : Node_Id; + + begin + if Nkind (CCase) = N_Component_Association then + Case_Guard := First (Choices (CCase)); + Conseq := Expression (CCase); + + -- Each contract case must have exactly one case guard + + Extra_Guard := Next (Case_Guard); + + if Present (Extra_Guard) then + Error_Msg_N + ("contract case may have only one case guard", Extra_Guard); + end if; + + -- Check the placement of "others" (if available) + + if Nkind (Case_Guard) = N_Others_Choice then + if Others_Seen then + Error_Msg_N + ("only one others choice allowed in aspect Contract_Cases", + Case_Guard); + else + Others_Seen := True; + end if; + + elsif Others_Seen then + Error_Msg_N + ("others must be the last choice in aspect Contract_Cases", + N); + end if; + + -- Preanalyze the case guard and consequence + + if Nkind (Case_Guard) /= N_Others_Choice then + Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean); + end if; + + Preanalyze_Assert_Expression (Conseq, Standard_Boolean); + + -- The contract case is malformed + + else + Error_Msg_N ("wrong syntax in contract case", CCase); + end if; + end Analyze_Contract_Case; + + -- 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; + + -- Start of processing for Analyze_Contract_Cases_In_Decl_Part - procedure Analyze_CTC_In_Decl_Part (N : Node_Id; S : Entity_Id) is 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); + Subp_Decl := Find_Related_Subprogram (N); + Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); + All_Cases := Expression (Arg1); - -- Preanalyze the boolean expressions, we treat these as spec - -- expressions (i.e. similar to a default expression). + -- Multiple contract cases appear in aggregate form - Preanalyze_CTC_Args - (N, - Get_Requires_From_CTC_Pragma (N), - Get_Ensures_From_CTC_Pragma (N)); + if Nkind (All_Cases) = N_Aggregate then + if No (Component_Associations (All_Cases)) then + Error_Msg_N ("wrong syntax for aspect Contract_Cases", N); - -- Remove the subprogram from the scope stack now that the pre-analysis - -- of the expressions in the contract case or test case is done. + -- Individual contract cases appear as component associations - End_Scope; - end Analyze_CTC_In_Decl_Part; + else + -- Ensure that the formal parameters are visible when analyzing + -- all clauses. This falls out of the general rule of aspects + -- pertaining 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); + end if; + + CCase := First (Component_Associations (All_Cases)); + while Present (CCase) loop + Analyze_Contract_Case (CCase); + Next (CCase); + end loop; + + if Requires_Profile_Installation (N, Subp_Decl) then + End_Scope; + end if; + end if; + + else + Error_Msg_N ("wrong syntax for aspect Contract_Cases", N); + end if; + end Analyze_Contract_Cases_In_Decl_Part; + + ---------------------------------- + -- Analyze_Depends_In_Decl_Part -- + ---------------------------------- + + 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); + + 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 + -- may appear in multiple input lists. + + 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 + + Subp_Id : Entity_Id; + -- The entity of the subprogram subject to pragma Depends + + Subp_Inputs : Elist_Id := No_Elist; + Subp_Outputs : Elist_Id := No_Elist; + -- Two lists containing the full set of inputs and output of the related + -- subprograms. Note that these lists contain both nodes and entities. + + procedure Analyze_Dependency_Clause + (Clause : Node_Id; + Is_Last : Boolean); + -- Verify the legality of a single dependency clause. Flag Is_Last + -- denotes whether Clause is the last clause in the relation. + + procedure Check_Function_Return; + -- Verify that Funtion'Result appears as one of the outputs + + procedure Check_Mode + (Item : Node_Id; + 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 "+". + + procedure Check_Usage + (Subp_Items : Elist_Id; + Used_Items : Elist_Id; + Is_Input : Boolean); + -- Verify that all items from Subp_Items appear in Used_Items. Emit an + -- 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. + + ------------------------------- + -- Analyze_Dependency_Clause -- + ------------------------------- + + procedure Analyze_Dependency_Clause + (Clause : Node_Id; + Is_Last : Boolean) + is + procedure Analyze_Input_List (Inputs : Node_Id); + -- 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); + -- 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 + -- output and the dependency clause has a "+". Flag Top_Level should + -- 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. + + ------------------------ + -- Analyze_Input_List -- + ------------------------ + + procedure Analyze_Input_List (Inputs : Node_Id) is + Inputs_Seen : Elist_Id := No_Elist; + -- 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 + + Input : Node_Id; + + begin + -- Multiple inputs appear as an aggregate + + if Nkind (Inputs) = N_Aggregate then + if Present (Component_Associations (Inputs)) then + Error_Msg_N + ("nested dependency relations not allowed", Inputs); + + elsif Present (Expressions (Inputs)) then + 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); + + Next (Input); + end loop; + + else + Error_Msg_N ("malformed input dependency list", Inputs); + end if; + + -- Process a solitary input + + else + Analyze_Input_Output + (Item => Inputs, + Is_Input => True, + Self_Ref => False, + Top_Level => False, + Seen => Inputs_Seen, + Null_Seen => Null_Input_Seen); + end if; + + -- Detect an illegal dependency clause of the form + + -- (null =>[+] null) + + if Null_Output_Seen and then Null_Input_Seen then + Error_Msg_N + ("null dependency clause cannot have a null input list", + Inputs); + end if; + end Analyze_Input_List; + + -------------------------- + -- Analyze_Input_Output -- + -------------------------- + + 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) + is + Is_Output : constant Boolean := not Is_Input; + Grouped : Node_Id; + Item_Id : Entity_Id; + + begin + -- Multiple input or output items appear as an aggregate + + if Nkind (Item) = N_Aggregate then + if not Top_Level then + Error_Msg_N ("nested grouping of items not allowed", Item); + + elsif Present (Component_Associations (Item)) then + Error_Msg_N + ("nested dependency relations not allowed", Item); + + -- Recursively analyze the grouped items + + elsif Present (Expressions (Item)) then + 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); + + Next (Grouped); + end loop; + + else + Error_Msg_N ("malformed dependency list", Item); + end if; + + -- Process Function'Result in the context of a dependency clause + + elsif Nkind (Item) = N_Attribute_Reference + and then Attribute_Name (Item) = Name_Result + then + -- 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. + + if not Is_Entity_Name (Prefix (Item)) + or else Ekind (Subp_Id) /= E_Function + or else Entity (Prefix (Item)) /= Subp_Id + then + Error_Msg_Name_1 := Name_Result; + Error_Msg_N + ("prefix of attribute % must denote the enclosing " + & "function", Item); + + -- Function'Result is allowed to appear on the output side of a + -- dependency clause. + + elsif Is_Input then + Error_Msg_N ("function result cannot act as input", Item); + + else + Result_Seen := True; + end if; + + -- Detect multiple uses of null in a single dependency list or + -- throughout the whole relation. Verify the placement of a null + -- output list relative to the other clauses. + + elsif Nkind (Item) = N_Null then + if Null_Seen then + Error_Msg_N + ("multiple null dependency relations not allowed", 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); + end if; + end if; + + -- Default case + + else + Analyze (Item); + + -- Find the entity of the item. If this is a renaming, climb + -- the renaming chain to reach the root object. Renamings of + -- non-entire objects do not yield an entity (Empty). + + Item_Id := Entity_Of (Item); + + if Present (Item_Id) then + if Ekind_In (Item_Id, E_Abstract_State, + E_In_Parameter, + E_In_Out_Parameter, + E_Out_Parameter, + E_Variable) + then + -- Ensure that the item is of the correct mode depending + -- on its function. + + Check_Mode (Item, Item_Id, Is_Input, Self_Ref); + + -- Detect multiple uses of the same state, variable or + -- formal parameter. If this is not the case, add the + -- item to the list of processed relations. + + if Contains (Seen, Item_Id) then + Error_Msg_N ("duplicate use of item", Item); + else + 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. + + if 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 + Add_Item (Item_Id, All_Inputs_Seen); + end if; + + -- When the item renames an entire object, replace the + -- item with a reference to the object. + + if Present (Renamed_Object (Entity (Item))) then + Rewrite (Item, + New_Reference_To (Item_Id, Sloc (Item))); + Analyze (Item); + end if; + + -- All other input/output items are illegal + + else + Error_Msg_N + ("item must denote variable, state or formal " + & "parameter", Item); + end if; + + -- All other input/output items are illegal + + else + Error_Msg_N + ("item must denote variable, state or formal parameter", + Item); + end if; + end if; + end Analyze_Input_Output; + + -- Local variables + + Inputs : Node_Id; + Output : Node_Id; + Self_Ref : Boolean; + + -- Start of processing for Analyze_Dependency_Clause + + begin + Inputs := Expression (Clause); + Self_Ref := False; + + -- An input list with a self-dependency appears as operator "+" where + -- the actuals inputs are the right operand. + + if Nkind (Inputs) = N_Op_Plus then + Inputs := Right_Opnd (Inputs); + Self_Ref := True; + end if; + + -- Process the output_list of a dependency_clause + + 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); + + Next (Output); + end loop; + + -- Process the input_list of a dependency_clause + + Analyze_Input_List (Inputs); + end Analyze_Dependency_Clause; + + ---------------------------- + -- Check_Function_Return -- + ---------------------------- + + procedure Check_Function_Return is + begin + if Ekind (Subp_Id) = E_Function and then not Result_Seen then + Error_Msg_NE + ("result of & must appear in exactly one output list", + N, Subp_Id); + end if; + end Check_Function_Return; + + ---------------- + -- Check_Mode -- + ---------------- + + procedure Check_Mode + (Item : Node_Id; + Item_Id : Entity_Id; + Is_Input : Boolean; + Self_Ref : Boolean) + is + begin + -- 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)) + then + Error_Msg_NE + ("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. + + if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then + if Global_Seen + and then not + (Appears_In (Subp_Inputs, Item_Id) + and then + Appears_In (Subp_Outputs, Item_Id)) + then + Error_Msg_NE ("item & must have mode in out", Item, Item_Id); + end if; + + -- Self-referential parameter + + elsif Ekind (Item_Id) /= E_In_Out_Parameter then + Error_Msg_NE ("item & must have mode in out", Item, Item_Id); + end if; + + -- Regular output + + 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); + end if; + end Check_Mode; + + ----------------- + -- Check_Usage -- + ----------------- + + procedure Check_Usage + (Subp_Items : Elist_Id; + Used_Items : Elist_Id; + Is_Input : Boolean) + is + procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id); + -- Emit an error concerning the erroneous usage of an item + + ----------------- + -- Usage_Error -- + ----------------- + + procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is + begin + if Is_Input then + Error_Msg_NE + ("item & must appear in at least one input list of aspect " + & "Depends", Item, Item_Id); + else + Error_Msg_NE + ("item & must appear in exactly one output list of aspect " + & "Depends", Item, Item_Id); + end if; + end Usage_Error; + + -- Local variables + + Elmt : Elmt_Id; + Item : Node_Id; + Item_Id : Entity_Id; + + -- Start of processing for Check_Usage + + begin + if No (Subp_Items) then + return; + end if; + + -- Each input or output of the subprogram must appear in a dependency + -- relation. + + Elmt := First_Elmt (Subp_Items); + while Present (Elmt) loop + Item := Node (Elmt); + + if Nkind (Item) = N_Defining_Identifier then + Item_Id := Item; + else + Item_Id := Entity (Item); + end if; + + -- The item does not appear in a dependency + + if not Contains (Used_Items, Item_Id) then + if Is_Formal (Item_Id) then + Usage_Error (Item, Item_Id); + + -- States and global variables are not used properly only when + -- the subprogram is subject to pragma Global. + + elsif Global_Seen then + Usage_Error (Item, Item_Id); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end Check_Usage; + + ---------------------- + -- Normalize_Clause -- + ---------------------- + + procedure Normalize_Clause (Clause : Node_Id) is + procedure Create_Or_Modify_Clause + (Output : Node_Id; + Outputs : Node_Id; + Inputs : Node_Id; + After : Node_Id; + In_Place : Boolean; + Multiple : Boolean); + -- Create a brand new clause to represent the self-reference or + -- modify the input and/or output lists of an existing clause. Output + -- denotes a self-referencial output. Outputs is the output list of a + -- clause. Inputs is the input list of a clause. After denotes the + -- clause after which the new clause is to be inserted. Flag In_Place + -- should be set when normalizing the last output of an output list. + -- Flag Multiple should be set when Output comes from a list with + -- multiple items. + + ----------------------------- + -- Create_Or_Modify_Clause -- + ----------------------------- + + procedure Create_Or_Modify_Clause + (Output : Node_Id; + Outputs : Node_Id; + Inputs : Node_Id; + After : Node_Id; + In_Place : Boolean; + Multiple : Boolean) + is + procedure Propagate_Output + (Output : Node_Id; + Inputs : Node_Id); + -- Handle the various cases of output propagation to the input + -- list. Output denotes a self-referencial output item. Inputs is + -- the input list of a clause. + + ---------------------- + -- Propagate_Output -- + ---------------------- + + procedure Propagate_Output + (Output : Node_Id; + Inputs : Node_Id) + is + function In_Input_List + (Item : Entity_Id; + Inputs : List_Id) return Boolean; + -- Determine whether a particulat item appears in the input + -- list of a clause. + + ------------------- + -- In_Input_List -- + ------------------- + + function In_Input_List + (Item : Entity_Id; + Inputs : List_Id) return Boolean + is + Elmt : Node_Id; + + begin + Elmt := First (Inputs); + while Present (Elmt) loop + if Entity_Of (Elmt) = Item then + return True; + end if; + + Next (Elmt); + end loop; + + return False; + end In_Input_List; + + -- Local variables + + Output_Id : constant Entity_Id := Entity_Of (Output); + Grouped : List_Id; + + -- Start of processing for Propagate_Output + + begin + -- The clause is of the form: + + -- (Output =>+ null) + + -- Remove the null input and replace it with a copy of the + -- output: + + -- (Output => Output) + + if Nkind (Inputs) = N_Null then + Rewrite (Inputs, New_Copy_Tree (Output)); + + -- The clause is of the form: + + -- (Output =>+ (Input1, ..., InputN)) + + -- Determine whether the output is not already mentioned in the + -- input list and if not, add it to the list of inputs: + + -- (Output => (Output, Input1, ..., InputN)) + + elsif Nkind (Inputs) = N_Aggregate then + Grouped := Expressions (Inputs); + + if not In_Input_List + (Item => Output_Id, + Inputs => Grouped) + then + Prepend_To (Grouped, New_Copy_Tree (Output)); + end if; + + -- The clause is of the form: + + -- (Output =>+ Input) + + -- If the input does not mention the output, group the two + -- together: + + -- (Output => (Output, Input)) + + elsif Entity_Of (Inputs) /= Output_Id then + Rewrite (Inputs, + Make_Aggregate (Loc, + Expressions => New_List ( + New_Copy_Tree (Output), + New_Copy_Tree (Inputs)))); + end if; + end Propagate_Output; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (Output); + 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. + + if Nkind (Output) = N_Attribute_Reference + and then Attribute_Name (Output) = Name_Result + then + Error_Msg_N ("function result cannot depend on itself", Output); + return; + + -- A null output depending on itself does not require any + -- normalization. + + elsif Nkind (Output) = N_Null then + return; + end if; + + -- When performing the transformation in place, simply add the + -- output to the list of inputs (if not already there). This case + -- arises when dealing with the last output of an output list - + -- we perform the normalization in place to avoid generating a + -- malformed tree. + + if In_Place then + Propagate_Output (Output, Inputs); + + -- A list with multiple outputs is slowly trimmed until only + -- one element remains. When this happens, replace the + -- aggregate with the element itself. + + if Multiple then + Remove (Output); + Rewrite (Outputs, Output); + end if; + + -- Default case + + 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. + + Remove (Output); + + -- Create a new clause of the form: + + -- (Output => Inputs) + + Clause := + 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 it or + -- renormalize it again. + + Set_Analyzed (Clause); + + Propagate_Output + (Output => First (Choices (Clause)), + Inputs => Expression (Clause)); + + Insert_After (After, Clause); + end if; + end Create_Or_Modify_Clause; + + -- Local variables + + Outputs : constant Node_Id := First (Choices (Clause)); + Inputs : Node_Id; + Last_Output : Node_Id; + Next_Output : Node_Id; + Output : Node_Id; + + -- Start of processing for Normalize_Clause + + begin + -- A self-dependency appears as operator "+". Remove the "+" from the + -- tree by moving the real inputs to their proper place. + + if Nkind (Expression (Clause)) = N_Op_Plus then + Rewrite (Expression (Clause), Right_Opnd (Expression (Clause))); + Inputs := Expression (Clause); + + -- Multiple outputs appear as an aggregate + + if Nkind (Outputs) = N_Aggregate then + Last_Output := Last (Expressions (Outputs)); + + Output := First (Expressions (Outputs)); + while Present (Output) loop + + -- Normalization may remove an output from its list, + -- preserve the subsequent output now. + + Next_Output := Next (Output); + + Create_Or_Modify_Clause + (Output => Output, + Outputs => Outputs, + Inputs => Inputs, + After => Clause, + In_Place => Output = Last_Output, + Multiple => True); + + Output := Next_Output; + end loop; + + -- Solitary output + + else + Create_Or_Modify_Clause + (Output => Outputs, + Outputs => Empty, + Inputs => Inputs, + After => Empty, + In_Place => True, + Multiple => False); + end if; + end if; + end Normalize_Clause; + + -- Local variables + + Clause : Node_Id; + Errors : Nat; + Last_Clause : Node_Id; + Subp_Decl : Node_Id; + + -- 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); + + -- Empty dependency list + + if Nkind (Clause) = N_Null then + + -- 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). + + Collect_Subprogram_Inputs_Outputs + (Subp_Id => Subp_Id, + Subp_Inputs => Subp_Inputs, + Subp_Outputs => Subp_Outputs, + Global_Seen => Global_Seen); + + -- Verify that every input or output of the subprogram appear in a + -- dependency. + + Check_Usage (Subp_Inputs, All_Inputs_Seen, True); + Check_Usage (Subp_Outputs, Outputs_Seen, False); + Check_Function_Return; + + -- Dependency clauses appear as component associations of an aggregate + + elsif Nkind (Clause) = N_Aggregate + and then Present (Component_Associations (Clause)) + then + Last_Clause := Last (Component_Associations (Clause)); + + -- 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). + + Collect_Subprogram_Inputs_Outputs + (Subp_Id => Subp_Id, + Subp_Inputs => Subp_Inputs, + Subp_Outputs => Subp_Outputs, + Global_Seen => Global_Seen); + + -- Ensure that the formal parameters are visible when analyzing all + -- clauses. This falls out of the general rule of aspects pertaining + -- 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); + end if; + + Clause := First (Component_Associations (Clause)); + while Present (Clause) loop + 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. + + if not Analyzed (Clause) then + Set_Analyzed (Clause); + + Analyze_Dependency_Clause + (Clause => Clause, + Is_Last => Clause = Last_Clause); + + -- Do not normalize an erroneous clause because the inputs or + -- outputs may denote illegal items. + + if Errors = Serious_Errors_Detected then + Normalize_Clause (Clause); + end if; + end if; + + Next (Clause); + end loop; + + if Requires_Profile_Installation (N, Subp_Decl) then + End_Scope; + end if; + + -- Verify that every input or output of the subprogram appear in a + -- dependency. + + Check_Usage (Subp_Inputs, All_Inputs_Seen, True); + Check_Usage (Subp_Outputs, Outputs_Seen, False); + Check_Function_Return; + + -- The top level dependency relation is malformed + + else + Error_Msg_N ("malformed dependency relation", Clause); + end if; + end Analyze_Depends_In_Decl_Part; + + --------------------------------- + -- Analyze_Global_In_Decl_Part -- + --------------------------------- + + 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. + + Subp_Id : Entity_Id; + -- The entity of the subprogram subject to pragma Global + + Contract_Seen : Boolean := False; + In_Out_Seen : Boolean := False; + Input_Seen : Boolean := False; + Output_Seen : Boolean := False; + -- Flags used to verify the consistency of modes + + procedure Analyze_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. + + ------------------------- + -- Analyze_Global_List -- + ------------------------- + + procedure Analyze_Global_List + (List : Node_Id; + Global_Mode : Name_Id := Name_Input) + is + procedure Analyze_Global_Item + (Item : Node_Id; + Global_Mode : Name_Id); + -- Verify the legality of a single global item declaration. + -- Global_Mode denotes the current mode in effect. + + procedure Check_Duplicate_Mode + (Mode : Node_Id; + Status : in out Boolean); + -- Flag Status denotes whether a particular mode has been seen while + -- processing a global list. This routine verifies that Mode is not a + -- duplicate mode and sets the flag Status. + + procedure Check_Mode_Restriction_In_Enclosing_Context + (Item : Node_Id; + Item_Id : Entity_Id); + -- Verify that an item of mode In_Out or Output does not appear as an + -- input in the Global aspect of an enclosing subprogram. If this is + -- the case, emit an error. Item and Item_Id are respectively the + -- item and its entity. + + procedure Check_Mode_Restriction_In_Function (Mode : Node_Id); + -- Mode denotes either In_Out or Output. Depending on the kind of the + -- related subprogram, emit an error if those two modes apply to a + -- function. + + ------------------------- + -- Analyze_Global_Item -- + ------------------------- + + procedure Analyze_Global_Item + (Item : Node_Id; + Global_Mode : Name_Id) + is + Item_Id : Entity_Id; + + begin + -- Detect one of the following cases + + -- with Global => (null, Name) + -- with Global => (Name_1, null, Name_2) + -- with Global => (Name, null) + + if Nkind (Item) = N_Null then + Error_Msg_N ("cannot mix null and non-null global items", Item); + return; + end if; + + Analyze (Item); + + -- Find the entity of the item. If this is a renaming, climb the + -- renaming chain to reach the root object. Renamings of non- + -- entire objects do not yield an entity (Empty). + + Item_Id := Entity_Of (Item); + + if Present (Item_Id) then + + -- A global item cannot reference a formal parameter. 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; + + -- The only legal references are those to abstract states and + -- variables. + + elsif not Ekind_In (Item_Id, E_Abstract_State, E_Variable) then + Error_Msg_N + ("global item must denote variable or state", Item); + return; + end if; + + -- When the item renames an entire object, replace the item + -- with a reference to the object. + + if Present (Renamed_Object (Entity (Item))) then + Rewrite (Item, New_Reference_To (Item_Id, Sloc (Item))); + Analyze (Item); + end if; + + -- Some form of illegal construct masquerading as a name + + else + Error_Msg_N ("global item must denote variable or state", Item); + return; + end if; + + -- At this point we know that the global item is one of the two + -- valid choices. Perform mode- and usage-specific checks. + + if Ekind (Item_Id) = E_Abstract_State + and then Is_Volatile_State (Item_Id) + then + -- A global item of mode In_Out or Output cannot denote a + -- volatile Input state. + + if Is_Input_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); + + -- A global item of mode In_Out or Input cannot reference a + -- volatile Output state. + + elsif Is_Output_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); + end if; + end if; + + -- Verify that an output does not appear as an input in an + -- enclosing subprogram. + + if Nam_In (Global_Mode, Name_In_Out, Name_Output) then + Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id); + end if; + + -- The same entity might be referenced through various way. Check + -- the entity of the item rather than the item itself. + + if Contains (Seen, Item_Id) then + Error_Msg_N ("duplicate global item", Item); + + -- Add the entity of the current item to the list of processed + -- items. + + else + Add_Item (Item_Id, Seen); + end if; + end Analyze_Global_Item; + + -------------------------- + -- Check_Duplicate_Mode -- + -------------------------- + + procedure Check_Duplicate_Mode + (Mode : Node_Id; + Status : in out Boolean) + is + begin + if Status then + Error_Msg_N ("duplicate global mode", Mode); + end if; + + Status := True; + end Check_Duplicate_Mode; + + ------------------------------------------------- + -- Check_Mode_Restriction_In_Enclosing_Context -- + ------------------------------------------------- + + procedure Check_Mode_Restriction_In_Enclosing_Context + (Item : Node_Id; + Item_Id : Entity_Id) + is + Dummy : Boolean; + Inputs : Elist_Id := No_Elist; + Outputs : Elist_Id := No_Elist; + Subp_Id : Entity_Id; + + begin + -- Traverse the scope stack looking for enclosing subprograms + -- subject to aspect/pragma Global. + + Subp_Id := Scope (Current_Scope); + while Present (Subp_Id) and then Subp_Id /= Standard_Standard loop + if Is_Subprogram (Subp_Id) + and then Has_Aspect (Subp_Id, Aspect_Global) + then + Collect_Subprogram_Inputs_Outputs + (Subp_Id => Subp_Id, + Subp_Inputs => Inputs, + Subp_Outputs => Outputs, + Global_Seen => Dummy); + + -- The item is classified as In_Out or Output but appears as + -- an Input in an enclosing subprogram. + + if Appears_In (Inputs, Item_Id) + and then not Appears_In (Outputs, Item_Id) + then + Error_Msg_NE + ("global item & cannot have mode In_Out or Output", + Item, Item_Id); + Error_Msg_NE + ("\item already appears as input of subprogram &", + Item, Subp_Id); + end if; + end if; + + Subp_Id := Scope (Subp_Id); + end loop; + end Check_Mode_Restriction_In_Enclosing_Context; + + ---------------------------------------- + -- Check_Mode_Restriction_In_Function -- + ---------------------------------------- + + procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is + begin + if Ekind (Subp_Id) = E_Function then + Error_Msg_N + ("global mode & not applicable to functions", Mode); + end if; + end Check_Mode_Restriction_In_Function; + + -- Local variables + + Assoc : Node_Id; + Item : Node_Id; + Mode : Node_Id; + + -- Start of processing for Analyze_Global_List + + begin + -- Single global item declaration + + if Nkind_In (List, 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 + + -- The declaration of a simple global list appear as a collection + -- of expressions. + + if Present (Expressions (List)) then + if Present (Component_Associations (List)) then + Error_Msg_N + ("cannot mix moded and non-moded global lists", List); + end if; + + Item := First (Expressions (List)); + while Present (Item) loop + Analyze_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 + if Present (Expressions (List)) then + Error_Msg_N + ("cannot mix moded and non-moded global lists", List); + end if; + + Assoc := First (Component_Associations (List)); + while Present (Assoc) loop + 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 + Check_Duplicate_Mode (Mode, In_Out_Seen); + Check_Mode_Restriction_In_Function (Mode); + + elsif Chars (Mode) = Name_Input then + Check_Duplicate_Mode (Mode, Input_Seen); + + elsif Chars (Mode) = Name_Output then + Check_Duplicate_Mode (Mode, Output_Seen); + Check_Mode_Restriction_In_Function (Mode); + + else + Error_Msg_N ("invalid mode selector", Mode); + end if; + + else + Error_Msg_N ("invalid mode selector", Mode); + end if; + + -- Items in a moded list appear as a collection of + -- expressions. Reuse the existing machinery to analyze + -- them. + + Analyze_Global_List + (List => Expression (Assoc), + Global_Mode => Chars (Mode)); + + Next (Assoc); + end loop; + + -- Something went horribly wrong, we have a malformed tree + + else + raise Program_Error; + end if; + + -- Any other attempt to declare a global item is erroneous + + else + Error_Msg_N ("malformed global list declaration", List); + end if; + end Analyze_Global_List; + + -- Local variables + + List : Node_Id; + Subp_Decl : Node_Id; + + -- 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); + + -- There is nothing to be done for a null global list + + if Nkind (List) = N_Null then + null; + + -- Analyze the various forms of global lists and items. Note that some + -- of these may be malformed in which case the analysis emits error + -- messages. + + else + -- Ensure that the formal parameters are visible when processing an + -- item. This falls out of the general rule of aspects pertaining to + -- subprogram declarations. + + if Requires_Profile_Installation (N, Subp_Decl) then + Push_Scope (Subp_Id); + Install_Formals (Subp_Id); + end if; + + Analyze_Global_List (List); + + if Requires_Profile_Installation (N, Subp_Decl) then + End_Scope; + end if; + end if; + end Analyze_Global_In_Decl_Part; ------------------------------ -- Analyze_PPC_In_Decl_Part -- @@ -291,9 +1718,7 @@ package body Sem_Prag is -- In ASIS mode, for a pragma generated from a source aspect, also -- analyze the original aspect expression. - if ASIS_Mode - and then Present (Corresponding_Aspect (N)) - then + if ASIS_Mode and then Present (Corresponding_Aspect (N)) then Preanalyze_Assert_Expression (Expression (Corresponding_Aspect (N)), Standard_Boolean); end if; @@ -362,6 +1787,7 @@ package body Sem_Prag is 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 then @@ -401,9 +1827,8 @@ package body Sem_Prag is Error_Msg_Name_2 := Name_Class; Error_Msg_N - ("aspect `%''%` can only be specified for a primitive " & - "operation of a tagged type", - Corresponding_Aspect (N)); + ("aspect `%''%` can only be specified for a primitive " + & "operation of a tagged type", Corresponding_Aspect (N)); end if; Replace_Type (Get_Pragma_Arg (Arg1)); @@ -562,17 +1987,16 @@ 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_Contract_Or_Test_Case; - -- Called to process a contract-case or 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 - -- contract-case and test-case pragmas 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 Spec_CTC_List 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_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_Duplicate_Pragma (E : Entity_Id); -- Check if a rep item of the same name as the current pragma is already @@ -666,8 +2090,8 @@ package body Sem_Prag is -- a package specification (because this is the case where we delay -- analysis till the end of the spec). Then (whether or not it was -- analyzed), the pragma is chained to the subprogram in question - -- (using Spec_PPC_List and Next_Pragma) and control returns to the - -- caller with In_Body set False. + -- (using Pre_Post_Conditions and Next_Pragma) and control returns + -- to the caller with In_Body set False. -- -- The pragma appears at the start of subprogram body declarations -- @@ -704,7 +2128,7 @@ package body Sem_Prag is -- Outputs error message for current pragma. The message contains a % -- that will be replaced with the pragma name, and the flag is placed -- on the pragma itself. Pragma_Exit is then raised. Note: this routine - -- calls Fix_Error (see spec of that function for details). + -- calls Fix_Error (see spec of that procedure for details). procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id); pragma No_Return (Error_Pragma_Arg); @@ -716,7 +2140,7 @@ package body Sem_Prag is -- message is placed using Error_Msg_N, so the message may also contain -- an & insertion character which will reference the given Arg value. -- After placing the message, Pragma_Exit is raised. Note: this routine - -- calls Fix_Error (see spec of that function for details). + -- calls Fix_Error (see spec of that procedure for details). procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id); pragma No_Return (Error_Pragma_Arg); @@ -733,7 +2157,7 @@ package body Sem_Prag is -- the message may also contain an & insertion character which will -- reference the identifier. After placing the message, Pragma_Exit -- is raised. Note: this routine calls Fix_Error (see spec of that - -- function for details). + -- procedure for details). procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id); pragma No_Return (Error_Pragma_Ref); @@ -741,7 +2165,7 @@ package body Sem_Prag is -- a % that will be replaced with the pragma name. The parameter Ref -- must be an entity whose name can be referenced by & and sloc by #. -- After placing the message, Pragma_Exit is raised. Note: this routine - -- calls Fix_Error (see spec of that function for details). + -- calls Fix_Error (see spec of that procedure for details). function Find_Lib_Unit_Name return Entity_Id; -- Used for a library unit pragma to find the entity to which the @@ -763,10 +2187,12 @@ package body Sem_Prag is procedure Fix_Error (Msg : in out String); -- This is called prior to issuing an error message. Msg is a string - -- that typically contains the substring "pragma". If the current pragma - -- comes from an aspect, each such "pragma" substring is replaced with - -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition - -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post). + -- that typically contains the substring "pragma". If the pragma comes + -- from an aspect, each such "pragma" substring is replaced with the + -- characters "aspect", and Error_Msg_Name_1 is set to the name of the + -- aspect (which may be different from the pragma name). If the current + -- pragma results from rewriting another pragma, then Error_Msg_Name_1 + -- is set to the original pragma name. procedure Gather_Associations (Names : Name_List; @@ -1143,6 +2569,7 @@ package body Sem_Prag is OK : Boolean; Ent : constant Entity_Id := Entity (Argx); Scop : constant Entity_Id := Scope (Ent); + begin -- Case of a pragma applied to a compilation unit: pragma must -- occur immediately after the program unit in the compilation. @@ -1239,7 +2666,7 @@ package body Sem_Prag is begin Check_Arg_Is_Identifier (Argx); - if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then + if not Nam_In (Chars (Argx), N1, N2) then Error_Msg_Name_2 := N1; Error_Msg_Name_3 := N2; Error_Pragma_Arg ("argument for pragma% must be% or%", Argx); @@ -1255,10 +2682,7 @@ package body Sem_Prag is begin Check_Arg_Is_Identifier (Argx); - if Chars (Argx) /= N1 - and then Chars (Argx) /= N2 - and then Chars (Argx) /= N3 - then + if not Nam_In (Chars (Argx), N1, N2, N3) then Error_Pragma_Arg ("invalid argument for pragma%", Argx); end if; end Check_Arg_Is_One_Of; @@ -1272,11 +2696,7 @@ package body Sem_Prag is begin Check_Arg_Is_Identifier (Argx); - if Chars (Argx) /= N1 - and then Chars (Argx) /= N2 - and then Chars (Argx) /= N3 - and then Chars (Argx) /= N4 - then + if not Nam_In (Chars (Argx), N1, N2, N3, N4) then Error_Pragma_Arg ("invalid argument for pragma%", Argx); end if; end Check_Arg_Is_One_Of; @@ -1290,12 +2710,7 @@ package body Sem_Prag is begin Check_Arg_Is_Identifier (Argx); - if Chars (Argx) /= N1 - and then Chars (Argx) /= N2 - and then Chars (Argx) /= N3 - and then Chars (Argx) /= N4 - and then Chars (Argx) /= N5 - then + if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then Error_Pragma_Arg ("invalid argument for pragma%", Argx); end if; end Check_Arg_Is_One_Of; @@ -1430,8 +2845,8 @@ package body Sem_Prag is and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic))) then Error_Msg_N - ("component subtype subject to per-object constraint " & - "must be an Unchecked_Union", Comp); + ("component subtype subject to per-object constraint " + & "must be an Unchecked_Union", Comp); -- Ada 2012 (AI05-0026): For an unchecked union type declared within -- the body of a generic unit, or within the body of any of its @@ -1459,189 +2874,6 @@ package body Sem_Prag is end if; end Check_Component; - --------------------------------- - -- Check_Contract_Or_Test_Case -- - --------------------------------- - - procedure Check_Contract_Or_Test_Case is - P : Node_Id; - PO : Node_Id; - - procedure Chain_CTC (PO : Node_Id); - -- If PO is a [generic] subprogram declaration node, then the - -- contract-case or test-case applies to this subprogram and the - -- processing for the pragma is completed. Otherwise the pragma - -- is misplaced. - - --------------- - -- Chain_CTC -- - --------------- - - procedure Chain_CTC (PO : Node_Id) is - S : Entity_Id; - - begin - if Nkind (PO) = N_Abstract_Subprogram_Declaration then - Error_Pragma - ("pragma% cannot be applied to abstract subprogram"); - - elsif Nkind (PO) = N_Entry_Declaration then - Error_Pragma ("pragma% cannot be applied to entry"); - - elsif not Nkind_In (PO, N_Subprogram_Declaration, - N_Generic_Subprogram_Declaration) - then - Pragma_Misplaced; - end if; - - -- Here if we have [generic] subprogram declaration - - S := Defining_Unit_Name (Specification (PO)); - - -- Note: we do not analyze the pragma at this point. Instead we - -- delay this analysis until the end of the declarative part in - -- which the pragma appears. This implements the required delay - -- in this analysis, allowing forward references. The analysis - -- happens at the end of Analyze_Declarations. - - -- There should not be another contract-case or test-case with the - -- same name associated to this subprogram. - - declare - Name : constant String_Id := Get_Name_From_CTC_Pragma (N); - CTC : Node_Id; - - begin - CTC := Spec_CTC_List (Contract (S)); - while Present (CTC) loop - - -- Omit pragma Contract_Cases because it does not introduce - -- a unique case name and it does not follow the syntax of - -- Contract_Case and Test_Case. - - if Pragma_Name (CTC) = Name_Contract_Cases then - null; - - elsif String_Equal - (Name, Get_Name_From_CTC_Pragma (CTC)) - then - Error_Msg_Sloc := Sloc (CTC); - Error_Pragma ("name for pragma% is already used#"); - end if; - - CTC := Next_Pragma (CTC); - end loop; - end; - - -- Chain spec CTC pragma to list for subprogram - - Set_Next_Pragma (N, Spec_CTC_List (Contract (S))); - Set_Spec_CTC_List (Contract (S), N); - end Chain_CTC; - - -- Start of processing for Check_Contract_Or_Test_Case - - begin - -- First check pragma arguments - - GNAT_Pragma; - Check_At_Least_N_Arguments (2); - Check_At_Most_N_Arguments (4); - Check_Arg_Order - ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); - - Check_Optional_Identifier (Arg1, Name_Name); - Check_Arg_Is_Static_Expression (Arg1, Standard_String); - - -- In ASIS mode, for a pragma generated from a source aspect, also - -- analyze the original aspect expression. - - if ASIS_Mode - and then Present (Corresponding_Aspect (N)) - then - Check_Expr_Is_Static_Expression - (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String); - end if; - - Check_Optional_Identifier (Arg2, Name_Mode); - Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness); - - if Arg_Count = 4 then - Check_Identifier (Arg3, Name_Requires); - Check_Identifier (Arg4, Name_Ensures); - - elsif Arg_Count = 3 then - Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures); - end if; - - -- Check pragma placement - - if not Is_List_Member (N) then - Pragma_Misplaced; - end if; - - -- Contract-case or test-case should only appear in package spec unit - - if Get_Source_Unit (N) = No_Unit - or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))), - N_Package_Declaration, - N_Generic_Package_Declaration) - then - Pragma_Misplaced; - 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 contract-case or test-case 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 - null; - - -- Only remaining possibility is subprogram declaration. First - -- check that it is declared directly in a package declaration. - -- This may be either the package declaration for the current unit - -- being defined or a local package declaration. - - elsif not Present (Parent (Parent (PO))) - or else not Present (Parent (Parent (Parent (PO)))) - or else not Nkind_In (Parent (Parent (PO)), - N_Package_Declaration, - N_Generic_Package_Declaration) - then - Pragma_Misplaced; - - else - Chain_CTC (PO); - return; - end if; - end loop; - - -- If we fall through, pragma was misplaced - - Pragma_Misplaced; - end Check_Contract_Or_Test_Case; - ---------------------------- -- Check_Duplicate_Pragma -- ---------------------------- @@ -1914,13 +3146,15 @@ package body Sem_Prag is -- instance can be in a nested scope. The check that protected type -- is itself a library-level declaration is done elsewhere. - -- Note: we omit this check in Codepeer mode to properly handle code - -- prior to AI-0033 (pragmas don't matter to codepeer in any case). + -- Note: we omit this check in Relaxed_RM_Semantics mode to properly + -- handle code prior to AI-0033. Analysis tools typically are not + -- interested in this pragma in any case, so no need to worry too + -- much about its placement. if Inside_A_Generic then if Ekind (Scope (Current_Scope)) = E_Generic_Package and then In_Package_Body (Scope (Current_Scope)) - and then not CodePeer_Mode + and then not Relaxed_RM_Semantics then Error_Pragma ("pragma% cannot be used inside a generic"); end if; @@ -1946,12 +3180,12 @@ package body Sem_Prag is begin if Nkind (Constr) = N_Pragma then Error_Pragma - ("pragma % must appear immediately within the statements " & - "of a loop"); + ("pragma % must appear immediately within the statements " + & "of a loop"); else Error_Pragma_Arg - ("block containing pragma % must appear immediately within " & - "the statements of a loop", Constr); + ("block containing pragma % must appear immediately within " + & "the statements of a loop", Constr); end if; end Placement_Error; @@ -2080,13 +3314,11 @@ package body Sem_Prag is procedure Check_No_Identifiers is Arg_Node : Node_Id; begin - if Arg_Count > 0 then - Arg_Node := Arg1; - while Present (Arg_Node) loop - Check_No_Identifier (Arg_Node); - Next (Arg_Node); - end loop; - end if; + Arg_Node := Arg1; + for J in 1 .. Arg_Count loop + Check_No_Identifier (Arg_Node); + Next (Arg_Node); + end loop; end Check_No_Identifiers; ------------------------ @@ -2095,9 +3327,7 @@ package body Sem_Prag is procedure Check_No_Link_Name is begin - if Present (Arg3) - and then Chars (Arg3) = Name_Link_Name - then + if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then Arg4 := Arg3; end if; @@ -2185,13 +3415,18 @@ package body Sem_Prag is ("aspect % requires ''Class for null procedure"); -- Pre/postconditions are legal on a subprogram body if it is not - -- a completion of a declaration. + -- a completion of a declaration. They are also legal on a stub + -- with no previous declarations (this is checked when processing + -- the corresponding aspects). elsif Nkind (PO) = N_Subprogram_Body and then Acts_As_Spec (PO) then null; + elsif Nkind (PO) = N_Subprogram_Body_Stub then + null; + elsif not Nkind_In (PO, N_Subprogram_Declaration, N_Expression_Function, N_Generic_Subprogram_Declaration, @@ -2220,8 +3455,7 @@ package body Sem_Prag is -- Chain spec PPC pragma to list for subprogram - Set_Next_Pragma (N, Spec_PPC_List (Contract (S))); - Set_Spec_PPC_List (Contract (S), N); + Add_Contract_Item (N, S); -- Return indicating spec case @@ -2248,12 +3482,7 @@ package body Sem_Prag is -- For a pragma PPC in the extended main source unit, record enabled -- status in SCO. - -- This may seem redundant with the call to Check_Enabled occurring - -- later on when the pragma is rewritten into a pragma Check but - -- is actually required in the case of a postcondition within a - -- generic. - - if Check_Enabled (Pname) and then not Split_PPC (N) then + if not Is_Ignored (N) and then not Split_PPC (N) then Set_SCO_Pragma_Enabled (Loc); end if; @@ -2337,9 +3566,7 @@ package body Sem_Prag is -- In ASIS mode, for a pragma generated from a source aspect, -- also analyze the original aspect expression. - if ASIS_Mode - and then Present (Corresponding_Aspect (N)) - then + if ASIS_Mode and then Present (Corresponding_Aspect (N)) then Preanalyze_Assert_Expression (Expression (Corresponding_Aspect (N)), Standard_Boolean); end if; @@ -2355,7 +3582,7 @@ package body Sem_Prag is -- In formal verification mode, analyze pragma expression for -- correctness, as it is not expanded later. - if Alfa_Mode then + if SPARK_Mode then Analyze_PPC_In_Decl_Part (N, Defining_Entity (Unit (Parent (Parent (N))))); end if; @@ -2430,6 +3657,185 @@ package body Sem_Prag is end case; end Check_Static_Constraint; + --------------------- + -- Check_Test_Case -- + --------------------- + + procedure Check_Test_Case is + P : Node_Id; + PO : Node_Id; + + procedure Chain_CTC (PO : Node_Id); + -- If PO is a [generic] subprogram declaration node, then the + -- test-case applies to this subprogram and the processing for + -- the pragma is completed. Otherwise the pragma is misplaced. + + --------------- + -- Chain_CTC -- + --------------- + + procedure Chain_CTC (PO : Node_Id) is + S : Entity_Id; + + begin + if Nkind (PO) = N_Abstract_Subprogram_Declaration then + Error_Pragma + ("pragma% cannot be applied to abstract subprogram"); + + elsif Nkind (PO) = N_Entry_Declaration then + Error_Pragma ("pragma% cannot be applied to entry"); + + elsif not Nkind_In (PO, N_Subprogram_Declaration, + N_Generic_Subprogram_Declaration) + then + Pragma_Misplaced; + end if; + + -- Here if we have [generic] subprogram declaration + + S := Defining_Unit_Name (Specification (PO)); + + -- Note: we do not analyze the pragma at this point. Instead we + -- delay this analysis until the end of the declarative part in + -- which the pragma appears. This implements the required delay + -- in this analysis, allowing forward references. The analysis + -- happens at the end of Analyze_Declarations. + + -- There should not be another test-case with the same name + -- associated to this subprogram. + + declare + Name : constant String_Id := Get_Name_From_CTC_Pragma (N); + CTC : Node_Id; + + begin + CTC := Contract_Test_Cases (Contract (S)); + while Present (CTC) loop + + -- Omit pragma Contract_Cases because it does not introduce + -- a unique case name and it does not follow the syntax of + -- Test_Case. + + if Pragma_Name (CTC) = Name_Contract_Cases then + null; + + elsif String_Equal + (Name, Get_Name_From_CTC_Pragma (CTC)) + then + Error_Msg_Sloc := Sloc (CTC); + Error_Pragma ("name for pragma% is already used#"); + end if; + + CTC := Next_Pragma (CTC); + end loop; + end; + + -- Chain spec CTC pragma to list for subprogram + + Add_Contract_Item (N, S); + end Chain_CTC; + + -- Start of processing for Check_Test_Case + + begin + -- First check pragma arguments + + GNAT_Pragma; + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (4); + Check_Arg_Order + ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); + + Check_Optional_Identifier (Arg1, Name_Name); + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + + -- In ASIS mode, for a pragma generated from a source aspect, also + -- analyze the original aspect expression. + + if ASIS_Mode and then Present (Corresponding_Aspect (N)) then + Check_Expr_Is_Static_Expression + (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String); + end if; + + Check_Optional_Identifier (Arg2, Name_Mode); + Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness); + + if Arg_Count = 4 then + Check_Identifier (Arg3, Name_Requires); + Check_Identifier (Arg4, Name_Ensures); + + elsif Arg_Count = 3 then + Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures); + end if; + + -- Check pragma placement + + if not Is_List_Member (N) then + Pragma_Misplaced; + end if; + + -- Test-case should only appear in package spec unit + + if Get_Source_Unit (N) = No_Unit + or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))), + N_Package_Declaration, + N_Generic_Package_Declaration) + then + Pragma_Misplaced; + 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 test-case 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 + null; + + -- Only remaining possibility is subprogram declaration. First + -- check that it is declared directly in a package declaration. + -- This may be either the package declaration for the current unit + -- being defined or a local package declaration. + + elsif not Present (Parent (Parent (PO))) + or else not Present (Parent (Parent (Parent (PO)))) + or else not Nkind_In (Parent (Parent (PO)), + N_Package_Declaration, + N_Generic_Package_Declaration) + then + Pragma_Misplaced; + + else + Chain_CTC (PO); + return; + end if; + end loop; + + -- If we fall through, pragma was misplaced + + Pragma_Misplaced; + end Check_Test_Case; + -------------------------------------- -- Check_Valid_Configuration_Pragma -- -------------------------------------- @@ -2793,18 +4199,29 @@ package body Sem_Prag is procedure Fix_Error (Msg : in out String) is begin + -- If we have a rewriting of another pragma, go to that pragma + + if Is_Rewrite_Substitution (N) + and then Nkind (Original_Node (N)) = N_Pragma + then + Error_Msg_Name_1 := Pragma_Name (Original_Node (N)); + end if; + + -- Case where pragma comes from an aspect specification + if From_Aspect_Specification (N) then + + -- Change appearence of "pragma" in message to "aspect" + for J in Msg'First .. Msg'Last - 5 loop if Msg (J .. J + 5) = "pragma" then Msg (J .. J + 5) := "aspect"; end if; end loop; - if Error_Msg_Name_1 = Name_Precondition then - Error_Msg_Name_1 := Name_Pre; - elsif Error_Msg_Name_1 = Name_Postcondition then - Error_Msg_Name_1 := Name_Post; - end if; + -- Get name from corresponding aspect + + Error_Msg_Name_1 := Original_Name (N); end if; end Fix_Error; @@ -3410,19 +4827,16 @@ package body Sem_Prag is then -- Give error if same as our pragma or Export/Convention - if Pragma_Name (Decl) = Name_Export - or else - Pragma_Name (Decl) = Name_Convention - or else - Pragma_Name (Decl) = Pragma_Name (N) + if Nam_In (Pragma_Name (Decl), Name_Export, + Name_Convention, + Pragma_Name (N)) then exit; -- Case of Import/Interface or the other way round - elsif Pragma_Name (Decl) = Name_Interface - or else - Pragma_Name (Decl) = Name_Import + elsif Nam_In (Pragma_Name (Decl), Name_Interface, + Name_Import) then -- Here we know that we have Import and Interface. It -- doesn't matter which way round they are. See if @@ -3450,8 +4864,12 @@ package body Sem_Prag is end if; -- Give message if needed if we fall through those tests + -- except on Relaxed_RM_Semantics where we let go: either this + -- is a case accepted/ignored by other Ada compilers (e.g. + -- a mix of Convention and Import), or another error will be + -- generated later (e.g. using both Import and Export). - if Err then + if Err and not Relaxed_RM_Semantics then Error_Pragma_Arg ("at most one Convention/Export/Import pragma is allowed", Arg2); @@ -3474,10 +4892,61 @@ package body Sem_Prag is and then Present (Overridden_Operation (E)) and then C /= Convention (Overridden_Operation (E)) then - Error_Pragma_Arg - ("cannot change convention for " & - "overridden dispatching operation", - Arg1); + -- An attempt to override a subprogram with a ghost subprogram + -- appears as a mismatch in conventions. + + if C = Convention_Ghost then + Error_Msg_N ("ghost subprogram & cannot be overriding", E); + else + Error_Pragma_Arg + ("cannot change convention for overridden dispatching " + & "operation", Arg1); + end if; + end if; + + -- Special checks for Convention_Stdcall + + if C = Convention_Stdcall then + + -- A dispatching call is not allowed. A dispatching subprogram + -- cannot be used to interface to the Win32 API, so in fact + -- this check does not impose any effective restriction. + + if Is_Dispatching_Operation (E) then + Error_Msg_Sloc := Sloc (E); + + -- Note: make this unconditional so that if there is more + -- than one call to which the pragma applies, we get a + -- message for each call. Also don't use Error_Pragma, + -- so that we get multiple messages! + + Error_Msg_N + ("dispatching subprogram# cannot use Stdcall convention!", + Arg1); + + -- Subprogram is allowed, but not a generic subprogram + + elsif not Is_Subprogram (E) + and then not Is_Generic_Subprogram (E) + + -- A variable is OK + + and then Ekind (E) /= E_Variable + + -- An access to subprogram is also allowed + + and then not + (Is_Access_Type (E) + and then Ekind (Designated_Type (E)) = E_Subprogram_Type) + + -- Allow internal call to set convention of subprogram type + + and then not (Ekind (E) = E_Subprogram_Type) + then + Error_Pragma_Arg + ("second argument of pragma% must be subprogram (type)", + Arg2); + end if; end if; -- Set the convention @@ -3591,14 +5060,14 @@ package body Sem_Prag is if C = Convention_Ada_Pass_By_Copy then if not Is_First_Subtype (E) then Error_Pragma_Arg - ("convention `Ada_Pass_By_Copy` only " - & "allowed for types", Arg2); + ("convention `Ada_Pass_By_Copy` only allowed for types", + Arg2); end if; if Is_By_Reference_Type (E) then Error_Pragma_Arg - ("convention `Ada_Pass_By_Copy` not allowed for " - & "by-reference type", Arg1); + ("convention `Ada_Pass_By_Copy` not allowed for by-reference " + & "type", Arg1); end if; end if; @@ -3607,17 +5076,25 @@ package body Sem_Prag is if C = Convention_Ada_Pass_By_Reference then if not Is_First_Subtype (E) then Error_Pragma_Arg - ("convention `Ada_Pass_By_Reference` only " - & "allowed for types", Arg2); + ("convention `Ada_Pass_By_Reference` only allowed for types", + Arg2); end if; if Is_By_Copy_Type (E) then Error_Pragma_Arg - ("convention `Ada_Pass_By_Reference` not allowed for " - & "by-copy type", Arg1); + ("convention `Ada_Pass_By_Reference` not allowed for by-copy " + & "type", Arg1); end if; end if; + -- Ghost special checking + + if Is_Ghost_Subprogram (E) + and then Present (Overridden_Operation (E)) + then + Error_Msg_N ("ghost subprogram & cannot be overriding", E); + end if; + -- Go to renamed subprogram if present, since convention applies to -- the actual renamed entity, not to the renaming entity. If the -- subprogram is inherited, go to parent subprogram. @@ -3648,9 +5125,12 @@ package body Sem_Prag is end if; -- Check that we are not applying this to a specless body + -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada + -- compilers. if Is_Subprogram (E) and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body + and then not Relaxed_RM_Semantics then Error_Pragma ("pragma% requires separate spec and must come before body"); @@ -3707,40 +5187,7 @@ package body Sem_Prag is ("second argument of pragma% must be a subprogram", Arg2); end if; - -- Stdcall case - - if C = Convention_Stdcall then - - -- A dispatching call is not allowed. A dispatching subprogram - -- cannot be used to interface to the Win32 API, so in fact this - -- check does not impose any effective restriction. - - if Is_Dispatching_Operation (E) then - - Error_Pragma - ("dispatching subprograms cannot use Stdcall convention"); - - -- Subprogram is allowed, but not a generic subprogram, and not a - -- dispatching operation. - - elsif not Is_Subprogram (E) - and then not Is_Generic_Subprogram (E) - - -- A variable is OK - - and then Ekind (E) /= E_Variable - - -- An access to subprogram is also allowed - - and then not - (Is_Access_Type (E) - and then Ekind (Designated_Type (E)) = E_Subprogram_Type) - then - Error_Pragma_Arg - ("second argument of pragma% must be subprogram (type)", - Arg2); - end if; - end if; + -- Deal with non-subprogram cases if not Is_Subprogram (E) and then not Is_Generic_Subprogram (E) @@ -3751,7 +5198,7 @@ package body Sem_Prag is Check_First_Subtype (Arg2); Set_Convention_From_Pragma (Base_Type (E)); - -- For subprograms, we must set the convention on the + -- For access subprograms, we must set the convention on the -- internally generated directly designated type as well. if Ekind (E) = E_Access_Subprogram_Type then @@ -3784,8 +5231,8 @@ package body Sem_Prag is Generate_Reference (E, Id, 'i'); end if; - -- If the pragma comes from from an aspect, it only applies - -- to the given entity, not its homonyms. + -- If the pragma comes from from an aspect, it only applies to the + -- given entity, not its homonyms. if From_Aspect_Specification (N) then return; @@ -3800,6 +5247,12 @@ package body Sem_Prag is E1 := Homonym (E1); exit when No (E1) or else Scope (E1) /= Current_Scope; + -- Ignore entry for which convention is already set + + if Has_Convention_Pragma (E1) then + goto Continue; + end if; + -- Do not set the pragma on inherited operations or on formal -- subprograms. @@ -3823,6 +5276,9 @@ package body Sem_Prag is Generate_Reference (E1, Id, 'b'); end if; end if; + + <<Continue>> + null; end loop; end if; end Process_Convention; @@ -4192,9 +5648,7 @@ package body Sem_Prag is elsif Etype (Def_Id) /= Standard_Void_Type and then - (Pname = Name_Export_Procedure - or else - Pname = Name_Import_Procedure) + Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure) then Match := False; @@ -4786,8 +6240,8 @@ package body Sem_Prag is then Error_Msg_Sloc := Sloc (Def_Id); Error_Msg_NE - ("cannot import&, renaming already provided for " & - "declaration #", N, Def_Id); + ("cannot import&, renaming already provided for " + & "declaration #", N, Def_Id); end if; end; @@ -4811,8 +6265,8 @@ package body Sem_Prag is end if; end loop; - -- When the convention is Java or CIL, we also allow Import to be - -- given for packages, generic packages, exceptions, record + -- When the convention is Java or CIL, we also allow Import to + -- be given for packages, generic packages, exceptions, record -- components, and access to subprograms. elsif (C = Convention_Java or else C = Convention_CIL) @@ -5256,7 +6710,7 @@ package body Sem_Prag is elsif not Effective and then Warn_On_Redundant_Constructs - and then not (Status = Suppressed or Suppress_All_Inlining) + and then not (Status = Suppressed or else Suppress_All_Inlining) then if Inlining_Not_Possible (Subp) then Error_Msg_NE @@ -5729,6 +7183,26 @@ package body Sem_Prag is end if; end; + elsif Id = Name_No_Use_Of_Attribute then + if Nkind (Expr) /= N_Identifier + or else not Is_Attribute_Name (Chars (Expr)) + then + Error_Msg_N ("unknown attribute name?", Expr); + + else + Set_Restriction_No_Use_Of_Attribute (Expr, Warn); + end if; + + elsif Id = Name_No_Use_Of_Pragma then + if Nkind (Expr) /= N_Identifier + or else not Is_Pragma_Name (Chars (Expr)) + then + Error_Msg_N ("unknown pragma name?", Expr); + + else + Set_Restriction_No_Use_Of_Pragma (Expr, Warn); + end if; + -- All other cases of restriction identifier present else @@ -5848,11 +7322,11 @@ package body Sem_Prag is -- Start of processing for Process_Suppress_Unsuppress begin - -- Ignore pragma Suppress/Unsuppress in CodePeer and Alfa modes on + -- Ignore pragma Suppress/Unsuppress in CodePeer and SPARK modes on -- user code: we want to generate checks for analysis purposes, as -- set respectively by -gnatC and -gnatd.F - if (CodePeer_Mode or Alfa_Mode) and then Comes_From_Source (N) then + if (CodePeer_Mode or SPARK_Mode) and then Comes_From_Source (N) then return; end if; @@ -5996,7 +7470,9 @@ package body Sem_Prag is Error_Pragma_Arg ("cannot export entity& that was previously imported", Arg); - elsif Present (Address_Clause (E)) and then not CodePeer_Mode then + elsif Present (Address_Clause (E)) + and then not Relaxed_RM_Semantics + then Error_Pragma_Arg ("cannot export entity& that has an address clause", Arg); end if; @@ -6152,6 +7628,12 @@ package body Sem_Prag is if Is_Exported (E) then Error_Msg_NE ("entity& was previously exported", N, E); + -- Ignore error in CodePeer mode where we treat all imported + -- subprograms as unknown. + + elsif CodePeer_Mode then + goto OK; + -- OK if Import/Interface case elsif Import_Interface_Present (N) then @@ -6286,9 +7768,10 @@ package body Sem_Prag is Class := First (Expressions (Mech_Name)); if Nkind (Prefix (Mech_Name)) /= N_Identifier - or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else - Chars (Prefix (Mech_Name)) = Name_Short_Descriptor) - or else Present (Next (Class)) + or else + not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor, + Name_Short_Descriptor) + or else Present (Next (Class)) then Bad_Mechanism; else @@ -6313,8 +7796,9 @@ package body Sem_Prag is Param := First (Parameter_Associations (Mech_Name)); if Nkind (Name (Mech_Name)) /= N_Identifier - or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else - Chars (Name (Mech_Name)) = Name_Short_Descriptor) + or else + not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor, + Name_Short_Descriptor) or else Present (Next (Param)) or else No (Selector_Name (Param)) or else Chars (Selector_Name (Param)) /= Name_Class @@ -6653,9 +8137,22 @@ package body Sem_Prag is -- Here to start processing for recognized pragma Prag_Id := Get_Pragma_Id (Pname); + Pname := Original_Name (N); - if Present (Corresponding_Aspect (N)) then - Pname := Chars (Identifier (Corresponding_Aspect (N))); + -- Check applicable policy. We skip this for a pragma that came from + -- an aspect, since we already dealt with the Disable case, and we set + -- the Is_Ignored flag at the time the aspect was analyzed. + + if not From_Aspect_Specification (N) then + Check_Applicable_Policy (N); + + -- If pragma is disabled, rewrite as NULL and skip analysis + + if Is_Disabled (N) then + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + raise Pragma_Exit; + end if; end if; -- Preset arguments @@ -6683,6 +8180,8 @@ package body Sem_Prag is end if; end if; + Check_Restriction_No_Use_Of_Pragma (N); + -- An enumeration type defines the pragmas that are supported by the -- implementation. Get_Pragma_Id (in package Prag) transforms a name -- into the corresponding enumeration value for the following case. @@ -6715,20 +8214,21 @@ package body Sem_Prag is -- pragma Abstract_State (ABSTRACT_STATE_LIST) - -- ABSTRACT_STATE_LIST ::= + -- ABSTRACT_STATE_LIST ::= -- null - -- | STATE_NAME_WITH_PROPERTIES {, STATE_NAME_WITH_PROPERTIES} + -- | STATE_NAME_WITH_PROPERTIES {, STATE_NAME_WITH_PROPERTIES} -- STATE_NAME_WITH_PROPERTIES ::= -- STATE_NAME - -- | (STATE_NAME with PROPERTY_LIST) + -- | (STATE_NAME with PROPERTY_LIST) - -- PROPERTY_LIST ::= PROPERTY {, PROPERTY} - -- PROPERTY ::= SIMPLE_PROPERTY - -- | NAME_VALUE_PROPERTY - -- SIMPLE_PROPERTY ::= IDENTIFIER - -- NAME_VALUE_PROPERTY ::= IDENTIFIER => EXPRESSION - -- STATE_NAME ::= DEFINING_IDENTIFIER + -- PROPERTY_LIST ::= PROPERTY {, PROPERTY} + -- PROPERTY ::= SIMPLE_PROPERTY | NAME_VALUE_PROPERTY + + -- SIMPLE_PROPERTY ::= IDENTIFIER + -- NAME_VALUE_PROPERTY ::= IDENTIFIER => EXPRESSION + + -- STATE_NAME ::= DEFINING_IDENTIFIER when Pragma_Abstract_State => Abstract_State : declare Pack_Id : Entity_Id; @@ -6796,23 +8296,23 @@ package body Sem_Prag is -- declare additional states. if Null_Seen then - Error_Msg_Name_1 := Chars (Pack_Id); - Error_Msg_N ("package % has null abstract state", State); + Error_Msg_NE + ("package & has null abstract state", State, Pack_Id); -- Null states appear as internally generated entities 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 -- non-null states. if Non_Null_Seen then - Error_Msg_Name_1 := Chars (Pack_Id); - Error_Msg_N - ("package % has non-null abstract state", State); + Error_Msg_NE + ("package & has non-null abstract state", + State, Pack_Id); end if; -- Simple state declaration @@ -6858,15 +8358,10 @@ package body Sem_Prag is -- Volatile requires exactly one Input or Output - if Volatile_Seen - and then - ((Input_Seen and then Output_Seen) -- both - or else - (not Input_Seen and then not Output_Seen)) -- none - then + if Volatile_Seen and then Input_Seen = Output_Seen then Error_Msg_N - ("property Volatile requires exactly one Input or " & - "Output", State); + ("property Volatile requires exactly one Input or " + & "Output", State); end if; -- Either Input or Output require Volatile @@ -6940,6 +8435,13 @@ package body Sem_Prag is Pop_Scope; end if; + -- Verify whether the state introduces an illegal hidden state + -- within a package subject to a null abstract state. + + if Formal_Extensions then + Check_No_Hidden_State (Id); + end if; + -- Associate the state with its related package if No (Abstract_States (Pack_Id)) then @@ -6974,12 +8476,14 @@ package body Sem_Prag is Par := Unit (Par); end if; - if Nkind (Par) /= N_Package_Declaration then + if not Nkind_In (Par, N_Generic_Package_Declaration, + N_Package_Declaration) + then Pragma_Misplaced; return; end if; - Pack_Id := Defining_Unit_Name (Specification (Par)); + Pack_Id := Defining_Entity (Par); State := Expression (Arg1); -- Multiple abstract states appear as an aggregate @@ -7266,9 +8770,9 @@ package body Sem_Prag is end if; end Annotate; - --------------------------- - -- Assert/Assert_And_Cut -- - --------------------------- + ------------------------------------------------- + -- Assert/Assert_And_Cut/Assume/Loop_Invariant -- + ------------------------------------------------- -- pragma Assert -- ( [Check => ] Boolean_EXPRESSION @@ -7278,16 +8782,32 @@ package body Sem_Prag is -- ( [Check => ] Boolean_EXPRESSION -- [, [Message =>] Static_String_EXPRESSION]); - when Pragma_Assert | Pragma_Assert_And_Cut => Assert : declare + -- pragma Assume + -- ( [Check => ] Boolean_EXPRESSION + -- [, [Message =>] Static_String_EXPRESSION]); + + -- pragma Loop_Invariant + -- ( [Check => ] Boolean_EXPRESSION + -- [, [Message =>] Static_String_EXPRESSION]); + + when Pragma_Assert | + Pragma_Assert_And_Cut | + Pragma_Assume | + Pragma_Loop_Invariant => + Assert : declare Expr : Node_Id; Newa : List_Id; begin + -- Assert is an Ada 2005 RM-defined pragma + if Prag_Id = Pragma_Assert then Ada_2005_Pragma; - else -- Pragma_Assert_And_Cut + + -- The remaining ones are GNAT pragmas + + else GNAT_Pragma; - S14_Pragma; end if; Check_At_Least_N_Arguments (1); @@ -7295,25 +8815,37 @@ package body Sem_Prag is Check_Arg_Order ((Name_Check, Name_Message)); Check_Optional_Identifier (Arg1, Name_Check); - -- We treat pragma Assert as equivalent to: + -- Special processing for Loop_Invariant + + if Prag_Id = Pragma_Loop_Invariant then - -- pragma Check (Assertion, condition [, msg]); + -- Check restricted placement, must be within a loop - -- So rewrite pragma in this manner, transfer the message - -- argument if present, and analyze the result + Check_Loop_Pragma_Placement; + + -- Do preanalyze to deal with embedded Loop_Entry attribute + + Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean); + end if; - -- Pragma Assert_And_Cut is treated exactly like pragma Assert by - -- the frontend. Formal verification tools may use it to "cut" the - -- paths through the code, to make verification tractable. When - -- dealing with a semantically analyzed tree, the information that - -- a Check node N corresponds to a source Assert_And_Cut pragma - -- can be retrieved from the pragma kind of Original_Node(N). + -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating + -- a corresponding Check pragma: + + -- pragma Check (name, condition [, msg]); + + -- Where name is the identifier matching the pragma name. So + -- rewrite pragma in this manner, transfer the message argument + -- if present, and analyze the result + + -- Note: When dealing with a semantically analyzed tree, the + -- information that a Check node N corresponds to a source Assert, + -- Assume, or Assert_And_Cut pragma can be retrieved from the + -- pragma kind of Original_Node(N). Expr := Get_Pragma_Arg (Arg1); Newa := New_List ( Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Assertion)), - + Expression => Make_Identifier (Loc, Pname)), Make_Pragma_Argument_Association (Sloc (Expr), Expression => Expr)); @@ -7333,71 +8865,168 @@ package body Sem_Prag is -- Assertion_Policy -- ---------------------- - -- pragma Assertion_Policy (Check | Disable | Ignore) + -- pragma Assertion_Policy (POLICY_IDENTIFIER); + + -- The following form is Ada 2012 only, but we allow it in all modes + + -- Pragma Assertion_Policy ( + -- ASSERTION_KIND => POLICY_IDENTIFIER + -- {, ASSERTION_KIND => POLICY_IDENTIFIER}); + + -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND + + -- RM_ASSERTION_KIND ::= Assert | + -- Static_Predicate | + -- Dynamic_Predicate | + -- Pre | + -- Pre'Class | + -- Post | + -- Post'Class | + -- Type_Invariant | + -- Type_Invariant'Class + + -- ID_ASSERTION_KIND ::= Assert_And_Cut | + -- Assume | + -- Contract_Cases | + -- Debug | + -- Loop_Invariant | + -- Loop_Variant | + -- Postcondition | + -- Precondition | + -- Predicate | + -- 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 + -- identically named aspects and pragmas, depending on the specified + -- policy identifier: + + -- POLICY_IDENTIFIER ::= Check | Disable | Ignore + + -- Note: Check and Ignore are language-defined. Disable is a GNAT + -- implementation defined addition that results in totally ignoring + -- the corresponding assertion. If Disable is specified, then the + -- argument of the assertion is not even analyzed. This is useful + -- when the aspect/pragma argument references entities in a with'ed + -- package that is replaced by a dummy package in the final build. + + -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class, + -- and Type_Invariant'Class were recognized by the parser and + -- transformed into references to the special internal identifiers + -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special + -- processing is required here. when Pragma_Assertion_Policy => Assertion_Policy : declare + LocP : Source_Ptr; Policy : Node_Id; + Arg : Node_Id; + Kind : Name_Id; begin Ada_2005_Pragma; - Check_Valid_Configuration_Pragma; - Check_Arg_Count (1); - Check_No_Identifiers; - Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore); - -- We treat pragma Assertion_Policy as equivalent to: + -- This can always appear as a configuration pragma - -- pragma Check_Policy (Assertion, policy) + if Is_Configuration_Pragma then + null; - -- So rewrite the pragma in that manner and link on to the chain - -- of Check_Policy pragmas, marking the pragma as analyzed. + -- It can also appear in a declarative part or package spec in Ada + -- 2012 mode. We allow this in other modes, but in that case we + -- consider that we have an Ada 2012 pragma on our hands. - Policy := Get_Pragma_Arg (Arg1); + else + Check_Is_In_Decl_Part_Or_Package_Spec; + Ada_2012_Pragma; + end if; - Rewrite (N, - Make_Pragma (Loc, - Chars => Name_Check_Policy, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Assertion)), + -- One argument case with no identifier (first form above) - Make_Pragma_Argument_Association (Loc, - Expression => - Make_Identifier (Sloc (Policy), Chars (Policy)))))); + if Arg_Count = 1 + and then (Nkind (Arg1) /= N_Pragma_Argument_Association + or else Chars (Arg1) = No_Name) + then + Check_Arg_Is_One_Of + (Arg1, Name_Check, Name_Disable, Name_Ignore); - Set_Analyzed (N); - Set_Next_Pragma (N, Opt.Check_Policy_List); - Opt.Check_Policy_List := N; - end Assertion_Policy; + -- Treat one argument Assertion_Policy as equivalent to: - ------------ - -- Assume -- - ------------ + -- pragma Check_Policy (Assertion, policy) - -- pragma Assume (boolean_EXPRESSION); + -- So rewrite pragma in that manner and link on to the chain + -- of Check_Policy pragmas, marking the pragma as analyzed. - when Pragma_Assume => Assume : declare - begin - GNAT_Pragma; - S14_Pragma; - Check_Arg_Count (1); + Policy := Get_Pragma_Arg (Arg1); + + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check_Policy, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Assertion)), - -- Pragma Assume is transformed into pragma Check in the following - -- manner: + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Sloc (Policy), Chars (Policy)))))); + Analyze (N); - -- pragma Check (Assume, Expr); + -- Here if we have two or more arguments - Rewrite (N, - Make_Pragma (Loc, - Chars => Name_Check, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Assume)), + else + Check_At_Least_N_Arguments (1); + Ada_2012_Pragma; - Make_Pragma_Argument_Association (Loc, - Expression => Relocate_Node (Expression (Arg1)))))); - Analyze (N); - end Assume; + -- Loop through arguments + + Arg := Arg1; + while Present (Arg) loop + LocP := Sloc (Arg); + + -- Kind must be specified + + if Nkind (Arg) /= N_Pragma_Argument_Association + or else Chars (Arg) = No_Name + then + Error_Pragma_Arg + ("missing assertion kind for pragma%", Arg); + end if; + + -- Check Kind and Policy have allowed forms + + Kind := Chars (Arg); + + if not Is_Valid_Assertion_Kind (Kind) then + Error_Pragma_Arg + ("invalid assertion kind for pragma%", Arg); + end if; + + Check_Arg_Is_One_Of + (Arg, Name_Check, Name_Disable, Name_Ignore); + + -- We rewrite the Assertion_Policy pragma as a series of + -- Check_Policy pragmas: + + -- Check_Policy (Kind, Policy); + + Insert_Action (N, + Make_Pragma (LocP, + Chars => Name_Check_Policy, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (LocP, + Expression => Make_Identifier (LocP, Kind)), + Make_Pragma_Argument_Association (LocP, + Expression => Get_Pragma_Arg (Arg))))); + + Arg := Next (Arg); + end loop; + + -- Rewrite the Assertion_Policy pragma as null since we have + -- now inserted all the equivalent Check pragmas. + + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + end if; + end Assertion_Policy; ------------------------------ -- Assume_No_Invalid_Values -- @@ -7593,8 +9222,7 @@ package body Sem_Prag is -- unit (RM E.4.1(4)). Error_Pragma - ("pragma% not in Remote_Call_Interface or " & - "Remote_Types unit"); + ("pragma% not in Remote_Call_Interface or Remote_Types unit"); end if; if Ekind (Nm) = E_Procedure @@ -7818,14 +9446,24 @@ package body Sem_Prag is -- Check -- ----------- - -- pragma Check ([Name =>] IDENTIFIER, + -- pragma Check ([Name =>] CHECK_KIND, -- [Check =>] Boolean_EXPRESSION -- [,[Message =>] String_EXPRESSION]); + -- CHECK_KIND ::= IDENTIFIER | + -- Pre'Class | + -- Post'Class | + -- Invariant'Class | + -- Type_Invariant'Class + + -- The identifiers Assertions and Statement_Assertions are not + -- allowed, since they have special meaning for Check_Policy. + when Pragma_Check => Check : declare Expr : Node_Id; Eloc : Source_Ptr; Cname : Name_Id; + Str : Node_Id; Check_On : Boolean; -- Set True if category of assertions referenced by Name enabled @@ -7839,21 +9477,69 @@ package body Sem_Prag is if Arg_Count = 3 then Check_Optional_Identifier (Arg3, Name_Message); - Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String); + Str := Get_Pragma_Arg (Arg3); end if; + Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1)); Check_Arg_Is_Identifier (Arg1); + Cname := Chars (Get_Pragma_Arg (Arg1)); - -- Completely ignore if disabled + -- Check forbidden name Assertions or Statement_Assertions - if Check_Disabled (Chars (Get_Pragma_Arg (Arg1))) then - Rewrite (N, Make_Null_Statement (Loc)); - Analyze (N); - return; + case Cname is + when Name_Assertions => + Error_Pragma_Arg + ("""Assertions"" is not allowed as a check kind " + & "for pragma%", Arg1); + + when Name_Statement_Assertions => + Error_Pragma_Arg + ("""Statement_Assertions"" is not allowed as a check kind " + & "for pragma%", Arg1); + + when others => + null; + end case; + + -- Set Check_On to indicate check status + + -- If this comes from an aspect, we have already taken care of + -- the policy active when the aspect was analyzed, and Is_Ignored + -- is set appropriately already. + + if From_Aspect_Specification (N) then + Check_On := not Is_Ignored (N); + + -- Otherwise check the status right now + + else + case Check_Kind (Cname) is + when Name_Ignore => + Check_On := False; + + when Name_Check => + Check_On := True; + + -- For disable, rewrite pragma as null statement and skip + -- rest of the analysis of the pragma. + + when Name_Disable => + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + raise Pragma_Exit; + + -- No other possibilities + + when others => + raise Program_Error; + end case; end if; - Cname := Chars (Get_Pragma_Arg (Arg1)); - Check_On := Check_Enabled (Cname); + -- If check kind was not Disable, then continue pragma analysis + + Expr := Get_Pragma_Arg (Arg2); + + -- Deal with SCO generation case Cname is when Name_Predicate | @@ -7875,28 +9561,51 @@ package body Sem_Prag is end if; end case; - -- If expansion is active and the check is not enabled then we - -- rewrite the Check as: + -- Deal with analyzing the string argument. + + if Arg_Count = 3 then + + -- If checks are not on we don't want any expansion (since + -- such expansion would not get properly deleted) but + -- we do want to analyze (to get proper references). + -- The Preanalyze_And_Resolve routine does just what we want + + if not Check_On then + Preanalyze_And_Resolve (Str, Standard_String); + + -- Otherwise we need a proper analysis and expansion + + else + Analyze_And_Resolve (Str, Standard_String); + end if; + end if; + + -- Now you might think we could just do the same with the Boolean + -- expression if checks are off (and expansion is on) and then + -- rewrite the check as a null statement. This would work but we + -- would lose the useful warnings about an assertion being bound + -- to fail even if assertions are turned off. + + -- So instead we wrap the boolean expression in an if statement + -- that looks like: -- if False and then condition then -- null; -- end if; - -- The reason we do this rewriting during semantic analysis rather - -- than as part of normal expansion is that we cannot analyze and - -- expand the code for the boolean expression directly, or it may - -- cause insertion of actions that would escape the attempt to - -- suppress the check code. + -- The reason we do this rewriting during semantic analysis + -- rather than as part of normal expansion is that we cannot + -- analyze and expand the code for the boolean expression + -- directly, or it may cause insertion of actions that would + -- escape the attempt to suppress the check code. -- Note that the Sloc for the if statement corresponds to the - -- argument condition, not the pragma itself. The reason for this - -- is that we may generate a warning if the condition is False at - -- compile time, and we do not want to delete this warning when we - -- delete the if statement. - - Expr := Get_Pragma_Arg (Arg2); + -- argument condition, not the pragma itself. The reason for + -- this is that we may generate a warning if the condition is + -- False at compile time, and we do not want to delete this + -- warning when we delete the if statement. - if Expander_Active and then not Check_On then + if Expander_Active and not Check_On then Eloc := Sloc (Expr); Rewrite (N, @@ -7908,9 +9617,12 @@ package body Sem_Prag is Then_Statements => New_List ( Make_Null_Statement (Eloc)))); + In_Assertion_Expr := In_Assertion_Expr + 1; Analyze (N); + In_Assertion_Expr := In_Assertion_Expr - 1; - -- Check is active + -- Check is active or expansion not active. In these cases we can + -- just go ahead and analyze the boolean with no worries. else In_Assertion_Expr := In_Assertion_Expr + 1; @@ -7961,22 +9673,36 @@ package body Sem_Prag is -- Check_Policy -- ------------------ - -- pragma Check_Policy ( - -- [Name =>] IDENTIFIER, - -- [Policy =>] POLICY_IDENTIFIER); + -- This is the old style syntax, which is still allowed in all modes: + + -- pragma Check_Policy ([Name =>] CHECK_KIND + -- [Policy =>] POLICY_IDENTIFIER); + + -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore - -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | DISABLE | IGNORE + -- CHECK_KIND ::= IDENTIFIER | + -- Pre'Class | + -- Post'Class | + -- Type_Invariant'Class | + -- Invariant'Class - -- Note: this is a configuration pragma, but it is allowed to appear - -- anywhere else. + -- This is the new style syntax, compatible with Assertion_Policy + -- and also allowed in all modes. - when Pragma_Check_Policy => + -- Pragma Check_Policy ( + -- CHECK_KIND => POLICY_IDENTIFIER + -- {, CHECK_KIND => POLICY_IDENTIFIER}); + + -- Note: the identifiers Name and Policy are not allowed as + -- Check_Kind values. This avoids ambiguities between the old and + -- new form syntax. + + when Pragma_Check_Policy => Check_Policy : declare + Kind : Node_Id; + + begin GNAT_Pragma; - Check_Arg_Count (2); - Check_Optional_Identifier (Arg1, Name_Name); - Check_Optional_Identifier (Arg2, Name_Policy); - Check_Arg_Is_One_Of - (Arg2, Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore); + Check_At_Least_N_Arguments (1); -- A Check_Policy pragma can appear either as a configuration -- pragma, or in a declarative part or a package spec (see RM @@ -7987,8 +9713,91 @@ package body Sem_Prag is Check_Is_In_Decl_Part_Or_Package_Spec; end if; - Set_Next_Pragma (N, Opt.Check_Policy_List); - Opt.Check_Policy_List := N; + -- Figure out if we have the old or new syntax. We have the + -- old syntax if the first argument has no identifier, or the + -- identifier is Name. + + if Nkind (Arg1) /= N_Pragma_Argument_Association + or else Nam_In (Chars (Arg1), No_Name, Name_Name) + then + -- Old syntax + + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Name); + Kind := Get_Pragma_Arg (Arg1); + Rewrite_Assertion_Kind (Kind); + Check_Arg_Is_Identifier (Arg1); + + -- Check forbidden check kind + + if Nam_In (Chars (Kind), Name_Name, Name_Policy) then + Error_Msg_Name_2 := Chars (Kind); + Error_Pragma_Arg + ("pragma% does not allow% as check name", Arg1); + end if; + + -- Check policy + + Check_Optional_Identifier (Arg2, Name_Policy); + Check_Arg_Is_One_Of + (Arg2, + Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore); + + -- And chain pragma on the Check_Policy_List for search + + Set_Next_Pragma (N, Opt.Check_Policy_List); + Opt.Check_Policy_List := N; + + -- For the new syntax, what we do is to convert each argument to + -- an old syntax equivalent. We do that because we want to chain + -- old style Check_Policy pragmas for the search (we don't want + -- to have to deal with multiple arguments in the search). + + else + declare + Arg : Node_Id; + Argx : Node_Id; + LocP : Source_Ptr; + + begin + Arg := Arg1; + while Present (Arg) loop + LocP := Sloc (Arg); + Argx := Get_Pragma_Arg (Arg); + + -- Kind must be specified + + if Nkind (Arg) /= N_Pragma_Argument_Association + or else Chars (Arg) = No_Name + then + Error_Pragma_Arg + ("missing assertion kind for pragma%", Arg); + end if; + + -- Construct equivalent old form syntax Check_Policy + -- pragma and insert it to get remaining checks. + + Insert_Action (N, + Make_Pragma (LocP, + Chars => Name_Check_Policy, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (LocP, + Expression => + Make_Identifier (LocP, Chars (Arg))), + Make_Pragma_Argument_Association (Sloc (Argx), + Expression => Argx)))); + + Arg := Next (Arg); + end loop; + + -- Rewrite original Check_Policy pragma to null, since we + -- have converted it into a series of old syntax pragmas. + + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + end; + end if; + end Check_Policy; --------------------- -- CIL_Constructor -- @@ -8204,8 +10013,8 @@ package body Sem_Prag is and then not Is_Array_Type (Typ) then Error_Pragma_Arg - ("Name parameter of pragma% must identify record or " & - "array type", Name); + ("Name parameter of pragma% must identify record or " + & "array type", Name); end if; -- An explicit Component_Alignment pragma overrides an @@ -8218,21 +10027,6 @@ package body Sem_Prag is end if; end Component_AlignmentP; - ------------------- - -- Contract_Case -- - ------------------- - - -- pragma Contract_Case - -- ([Name =>] Static_String_EXPRESSION - -- ,[Mode =>] MODE_TYPE - -- [, Requires => Boolean_EXPRESSION] - -- [, Ensures => Boolean_EXPRESSION]); - - -- MODE_TYPE ::= Nominal | Robustness - - when Pragma_Contract_Case => - Check_Contract_Or_Test_Case; - -------------------- -- Contract_Cases -- -------------------- @@ -8248,162 +10042,45 @@ package body Sem_Prag is -- CONSEQUENCE ::= boolean_EXPRESSION when Pragma_Contract_Cases => Contract_Cases : declare - procedure Chain_Contract_Cases (Subp_Decl : Node_Id); - -- Chain pragma Contract_Cases to the contract of a subprogram. - -- Subp_Decl is the declaration of the subprogram. - - -------------------------- - -- Chain_Contract_Cases -- - -------------------------- - - procedure Chain_Contract_Cases (Subp_Decl : Node_Id) is - Subp : constant Entity_Id := - Defining_Unit_Name (Specification (Subp_Decl)); - CTC : Node_Id; - - begin - Check_Duplicate_Pragma (Subp); - CTC := Spec_CTC_List (Contract (Subp)); - while Present (CTC) loop - if Chars (Pragma_Identifier (CTC)) = Pname then - Error_Msg_Name_1 := Pname; - Error_Msg_Sloc := Sloc (CTC); - - if From_Aspect_Specification (CTC) then - Error_Msg_NE - ("aspect% for & previously given#", N, Subp); - else - Error_Msg_NE - ("pragma% for & duplicates pragma#", N, Subp); - end if; - - raise Pragma_Exit; - end if; - - CTC := Next_Pragma (CTC); - end loop; - - -- Prepend pragma Contract_Cases to the contract - - Set_Next_Pragma (N, Spec_CTC_List (Contract (Subp))); - Set_Spec_CTC_List (Contract (Subp), N); - end Chain_Contract_Cases; - - -- Local variables - - Case_Guard : Node_Id; - Decl : Node_Id; - Extra : Node_Id; - Others_Seen : Boolean := False; - Contract_Case : Node_Id; - Subp_Decl : Node_Id; - - -- Start of processing for Contract_Cases + Subp_Decl : Node_Id; + Subp_Id : Entity_Id; begin GNAT_Pragma; - S14_Pragma; Check_Arg_Count (1); - -- Completely ignore if disabled - - if Check_Disabled (Pname) then - Rewrite (N, Make_Null_Statement (Loc)); - Analyze (N); - return; - end if; + -- Ensure the proper placement of the pragma. Contract_Cases must + -- be associated with a subprogram declaration or a body that acts + -- as a spec. - -- Check the placement of the pragma + Subp_Decl := Find_Related_Subprogram (N, Check_Duplicates => True); - if not Is_List_Member (N) then + if Nkind (Subp_Decl) /= N_Subprogram_Declaration + and then (Nkind (Subp_Decl) /= N_Subprogram_Body + or else not Acts_As_Spec (Subp_Decl)) + then Pragma_Misplaced; - end if; - - -- Pragma Contract_Cases must be associated with a subprogram - - Decl := N; - while Present (Prev (Decl)) loop - Decl := Prev (Decl); - - if Nkind (Decl) in N_Generic_Declaration then - Subp_Decl := Decl; - else - Subp_Decl := Original_Node (Decl); - end if; - - -- Skip prior pragmas - - if Nkind (Subp_Decl) = N_Pragma then - null; - - -- Skip internally generated code - - elsif not Comes_From_Source (Subp_Decl) then - null; - - -- We have found the related subprogram - - elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) - then - exit; - - else - Pragma_Misplaced; - end if; - end loop; - - -- All contract cases must appear as an aggregate - - if Nkind (Expression (Arg1)) /= N_Aggregate then - Error_Pragma ("wrong syntax for pragma %"); return; end if; - -- Verify the legality of individual contract cases + Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); - Contract_Case := - First (Component_Associations (Expression (Arg1))); - while Present (Contract_Case) loop - if Nkind (Contract_Case) /= N_Component_Association then - Error_Pragma_Arg - ("wrong syntax in contract case", Contract_Case); - return; - end if; + -- The pragma is analyzed at the end of the declarative part which + -- contains the related subprogram. Reset the analyzed flag. - Case_Guard := First (Choices (Contract_Case)); + Set_Analyzed (N, False); - -- Each contract case must have exactly on case guard + -- When the aspect/pragma appears on a subprogram body, perform + -- the full analysis now. - Extra := Next (Case_Guard); - if Present (Extra) then - Error_Pragma_Arg - ("contract case may have only one case guard", Extra); - return; - end if; + if Nkind (Subp_Decl) = N_Subprogram_Body then + Analyze_Contract_Cases_In_Decl_Part (N); - -- Check the placement of "others" (if available) + -- Chain the pragma on the contract for further processing - if Nkind (Case_Guard) = N_Others_Choice then - if Others_Seen then - Error_Pragma_Arg - ("only one others choice allowed in pragma %", - Case_Guard); - return; - else - Others_Seen := True; - end if; - - elsif Others_Seen then - Error_Pragma_Arg - ("others must be the last choice in pragma %", N); - return; - end if; - - Next (Contract_Case); - end loop; - - Chain_Contract_Cases (Subp_Decl); + else + Add_Contract_Item (N, Subp_Id); + end if; end Contract_Cases; ---------------- @@ -8491,10 +10168,9 @@ package body Sem_Prag is GNAT_Pragma; if Warn_On_Obsolescent_Feature then - -- Following message is obsolete ??? Error_Msg_N - ("'G'N'A'T pragma cpp'_class is now obsolete and has no " & - "effect; replace it by pragma import?j?", N); + ("'G'N'A'T pragma cpp'_class is now obsolete and has no " + & "effect; replace it by pragma import?j?", N); end if; Check_Arg_Count (1); @@ -8557,8 +10233,8 @@ package body Sem_Prag is then if Scope (Def_Id) /= Scope (Etype (Def_Id)) then Error_Msg_N - ("'C'P'P constructor must be defined in the scope of " & - "its returned type", Arg1); + ("'C'P'P constructor must be defined in the scope of " + & "its returned type", Arg1); end if; if Arg_Count >= 2 then @@ -8618,8 +10294,8 @@ package body Sem_Prag is if Warn_On_Obsolescent_Feature then Error_Msg_N - ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " & - "no effect?j?", N); + ("'G'N'A'T pragma cpp'_virtual is now obsolete and has no " + & "effect?j?", N); end if; end CPP_Virtual; @@ -8633,8 +10309,8 @@ package body Sem_Prag is if Warn_On_Obsolescent_Feature then Error_Msg_N - ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " & - "no effect?j?", N); + ("'G'N'A'T pragma cpp'_vtable is now obsolete and has no " + & "effect?j?", N); end if; end CPP_Vtable; @@ -8741,20 +10417,16 @@ package body Sem_Prag is begin GNAT_Pragma; - -- Skip analysis if disabled - - if Debug_Pragmas_Disabled then - Rewrite (N, Make_Null_Statement (Loc)); - Analyze (N); - return; - end if; + -- The condition for executing the call is that the expander + -- is active and that we are not ignoring this debug pragma. Cond := New_Occurrence_Of - (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active), + (Boolean_Literals + (Expander_Active and then not Is_Ignored (N)), Loc); - if Debug_Pragmas_Enabled then + if not Is_Ignored (N) then Set_SCO_Pragma_Enabled (Loc); end if; @@ -8833,16 +10505,91 @@ package body Sem_Prag is -- Debug_Policy -- ------------------ - -- pragma Debug_Policy (Check | Ignore) + -- pragma Debug_Policy (On | Off | Check | Disable | Ignore) when Pragma_Debug_Policy => GNAT_Pragma; Check_Arg_Count (1); - Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore); - Debug_Pragmas_Enabled := - Chars (Get_Pragma_Arg (Arg1)) = Name_Check; - Debug_Pragmas_Disabled := - Chars (Get_Pragma_Arg (Arg1)) = Name_Disable; + Check_No_Identifiers; + Check_Arg_Is_Identifier (Arg1); + + -- Exactly equivalent to pragma Check_Policy (Debug, arg), so + -- rewrite it that way, and let the rest of the checking come + -- from analyzing the rewritten pragma. + + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check_Policy, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Debug)), + + Make_Pragma_Argument_Association (Loc, + Expression => Get_Pragma_Arg (Arg1))))); + Analyze (N); + + ------------- + -- Depends -- + ------------- + + -- pragma 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 + + when Pragma_Depends => Depends : declare + Subp_Decl : Node_Id; + Subp_Id : Entity_Id; + + begin + GNAT_Pragma; + S14_Pragma; + Check_Arg_Count (1); + + -- Ensure the proper placement of the pragma. Depends must be + -- associated with a subprogram declaration or a body that acts + -- as a spec. + + Subp_Decl := Find_Related_Subprogram (N, Check_Duplicates => True); + + if Nkind (Subp_Decl) /= N_Subprogram_Declaration + and then (Nkind (Subp_Decl) /= N_Subprogram_Body + or else not Acts_As_Spec (Subp_Decl)) + then + Pragma_Misplaced; + 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. + + if Nkind (Subp_Decl) = N_Subprogram_Body then + Analyze_Depends_In_Decl_Part (N); + + -- Chain the pragma on the contract for further processing + + else + Add_Contract_Item (N, Subp_Id); + end if; + end Depends; --------------------- -- Detect_Blocking -- @@ -9325,8 +11072,8 @@ package body Sem_Prag is Present (Source_Location) then Error_Pragma - ("parameter profile and source location cannot " & - "be used together in pragma%"); + ("parameter profile and source location cannot be used " + & "together in pragma%"); end if; Process_Eliminate_Pragma @@ -10036,325 +11783,20 @@ package body Sem_Prag is -- pragma Global (GLOBAL_SPECIFICATION) - -- GLOBAL_SPECIFICATION ::= MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST} - -- | GLOBAL_LIST - -- | null - -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST - -- MODE_SELECTOR ::= Input | Output | In_Out | Contract_In - -- GLOBAL_LIST ::= GLOBAL_ITEM - -- | (GLOBAL_ITEM {, GLOBAL_ITEM}) - -- GLOBAL_ITEM ::= NAME - - when Pragma_Global => Global : declare - Subp_Id : Entity_Id; - - 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. - - -- Flags used to verify the consistency of modes - - Contract_Seen : Boolean := False; - In_Out_Seen : Boolean := False; - Input_Seen : Boolean := False; - Output_Seen : Boolean := False; - - procedure Analyze_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. - - ------------------------- - -- Analyze_Global_List -- - ------------------------- - - procedure Analyze_Global_List - (List : Node_Id; - Global_Mode : Name_Id := Name_Input) - is - procedure Analyze_Global_Item - (Item : Node_Id; - Global_Mode : Name_Id); - -- Verify the legality of a single global item declaration. - -- Global_Mode denotes the current mode in effect. - - procedure Check_Duplicate_Mode - (Mode : Node_Id; - Status : in out Boolean); - -- Flag Status denotes whether a particular mode has been seen - -- while processing a global list. This routine verifies that - -- Mode is not a duplicate mode and sets the flag Status. - - procedure Check_Mode_Restriction_In_Function (Mode : Node_Id); - -- Mode denotes either In_Out or Output. Depending on the kind - -- of the related subprogram, emit an error if those two modes - -- apply to a function. - - ------------------------- - -- Analyze_Global_Item -- - ------------------------- - - procedure Analyze_Global_Item - (Item : Node_Id; - Global_Mode : Name_Id) - is - function Is_Duplicate_Item (Id : Entity_Id) return Boolean; - -- Determine whether Id has already been processed - - ----------------------- - -- Is_Duplicate_Item -- - ----------------------- - - function Is_Duplicate_Item (Id : Entity_Id) return Boolean is - Item_Elmt : Elmt_Id; - - begin - if Present (Seen) then - Item_Elmt := First_Elmt (Seen); - while Present (Item_Elmt) loop - if Node (Item_Elmt) = Id then - return True; - end if; - - Next_Elmt (Item_Elmt); - end loop; - end if; - - return False; - end Is_Duplicate_Item; - - -- Local declarations - - Id : Entity_Id; - - -- Start of processing for Analyze_Global_Item - - begin - -- Detect one of the following cases - - -- with Global => (null, Name) - -- with Global => (Name_1, null, Name_2) - -- with Global => (Name, null) - - if Nkind (Item) = N_Null then - Error_Msg_N - ("cannot mix null and non-null global items", Item); - return; - end if; - - Analyze (Item); - - if Is_Entity_Name (Item) then - Id := Entity (Item); - - -- A global item cannot reference a formal parameter. Do - -- this check first to provide a better error diagnostic. - - if Is_Formal (Id) then - Error_Msg_N - ("global item cannot reference formal parameter", - Item); - return; - - -- The only legal references are those to abstract states - -- and variables. - - elsif not Ekind_In (Entity (Item), E_Abstract_State, - E_Variable) - then - Error_Msg_N - ("global item must denote variable or state", Item); - return; - end if; - - -- Some form of illegal construct masquerading as a name - - else - Error_Msg_N - ("global item must denote variable or state", Item); - return; - end if; - - -- The same entity might be referenced through various way. - -- Check the entity of the item rather than the item itself. - - if Is_Duplicate_Item (Id) then - Error_Msg_N ("duplicate global item", Item); - - -- Add the entity of the current item to the list of - -- processed items. - - else - if No (Seen) then - Seen := New_Elmt_List; - end if; - - Append_Elmt (Id, Seen); - end if; - - if Ekind (Id) = E_Abstract_State - and then Is_Volatile_State (Id) - then - -- A global item of mode In_Out or Output cannot denote a - -- volatile Input state. - - if Is_Input_State (Id) - and then (Global_Mode = Name_In_Out - or else - Global_Mode = Name_Output) - then - Error_Msg_N - ("global item of mode In_Out or Output cannot " & - "reference Volatile Input state", Item); - - -- A global item of mode In_Out or Input cannot reference - -- a volatile Output state. - - elsif Is_Output_State (Id) - and then (Global_Mode = Name_In_Out - or else - Global_Mode = Name_Input) - then - Error_Msg_N - ("global item of mode In_Out or Input cannot " - & "reference Volatile Output state", Item); - end if; - end if; - end Analyze_Global_Item; - - -------------------------- - -- Check_Duplicate_Mode -- - -------------------------- - - procedure Check_Duplicate_Mode - (Mode : Node_Id; - Status : in out Boolean) - is - begin - if Status then - Error_Msg_N ("duplicate global mode", Mode); - end if; - - Status := True; - end Check_Duplicate_Mode; - - ---------------------------------------- - -- Check_Mode_Restriction_In_Function -- - ---------------------------------------- - - procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is - begin - if Ekind (Subp_Id) = E_Function then - Error_Msg_Name_1 := Chars (Mode); - Error_Msg_N - ("global mode % not applicable to functions", Mode); - end if; - end Check_Mode_Restriction_In_Function; - - -- Local variables - - Assoc : Node_Id; - Item : Node_Id; - Mode : Node_Id; - - -- Start of processing for Analyze_Global_List - - begin - -- Single global item declaration - - if Nkind_In (List, 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 - - -- The declaration of a simple global list appear as a - -- collection of expressions. - - if Present (Expressions (List)) then - if Present (Component_Associations (List)) then - Error_Msg_N - ("cannot mix moded and non-moded global lists", - List); - end if; - - Item := First (Expressions (List)); - while Present (Item) loop - Analyze_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 - if Present (Expressions (List)) then - Error_Msg_N - ("cannot mix moded and non-moded global lists", - List); - end if; - - Assoc := First (Component_Associations (List)); - while Present (Assoc) loop - 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 - Check_Duplicate_Mode (Mode, In_Out_Seen); - Check_Mode_Restriction_In_Function (Mode); - - elsif Chars (Mode) = Name_Input then - Check_Duplicate_Mode (Mode, Input_Seen); - - elsif Chars (Mode) = Name_Output then - Check_Duplicate_Mode (Mode, Output_Seen); - Check_Mode_Restriction_In_Function (Mode); - - else - Error_Msg_N ("invalid mode selector", Mode); - end if; - - else - Error_Msg_N ("invalid mode selector", Mode); - end if; - - -- Items in a moded list appear as a collection of - -- expressions. Reuse the existing machinery to - -- analyze them. - - Analyze_Global_List - (List => Expression (Assoc), - Global_Mode => Chars (Mode)); - - Next (Assoc); - end loop; - - -- Something went horribly wrong, we have a malformed tree - - else - raise Program_Error; - end if; - - -- Any other attempt to declare a global item is erroneous - - else - Error_Msg_N ("malformed global list declaration", List); - end if; - end Analyze_Global_List; + -- GLOBAL_SPECIFICATION ::= + -- null + -- | GLOBAL_LIST + -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST} - -- Local variables + -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST - List : Node_Id; - Subp : Node_Id; + -- MODE_SELECTOR ::= Input | Output | In_Out | Contract_In + -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM}) + -- GLOBAL_ITEM ::= NAME - -- Start of processing for Global + when Pragma_Global => Global : declare + Subp_Decl : Node_Id; + Subp_Id : Entity_Id; begin GNAT_Pragma; @@ -10362,38 +11804,31 @@ package body Sem_Prag is Check_Arg_Count (1); -- Ensure the proper placement of the pragma. Global must be - -- associated with a subprogram declaration. + -- associated with a subprogram declaration or a body that acts + -- as a spec. - Subp := Parent (Corresponding_Aspect (N)); + Subp_Decl := Find_Related_Subprogram (N, Check_Duplicates => True); - if Nkind (Subp) /= N_Subprogram_Declaration then + if Nkind (Subp_Decl) /= N_Subprogram_Declaration + and then (Nkind (Subp_Decl) /= N_Subprogram_Body + or else not Acts_As_Spec (Subp_Decl)) + then Pragma_Misplaced; return; end if; - Subp_Id := Defining_Unit_Name (Specification (Subp)); - List := Expression (Arg1); + Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); - -- There is nothing to be done for a null global list + -- When the aspect/pragma appears on a subprogram body, perform + -- the full analysis now. - if Nkind (List) = N_Null then - null; + if Nkind (Subp_Decl) = N_Subprogram_Body then + Analyze_Global_In_Decl_Part (N); - -- Analyze the various forms of global lists and items. Note that - -- some of these may be malformed in which case the analysis emits - -- error messages. + -- Chain the pragma on the contract for further processing else - -- Ensure that the formal parameters are visible when - -- processing an item. This falls out of the general rule of - -- aspects pertaining to subprogram declarations. - - Push_Scope (Subp_Id); - Install_Formals (Subp_Id); - - Analyze_Global_List (List); - - Pop_Scope; + Add_Contract_Item (N, Subp_Id); end if; end Global; @@ -10608,8 +12043,8 @@ package body Sem_Prag is null; else Error_Pragma_Arg - ("controlling formal must be of synchronized " & - "tagged type", Arg1); + ("controlling formal must be of synchronized tagged type", + Arg1); return; end if; @@ -10637,8 +12072,8 @@ package body Sem_Prag is and then Is_Task_Interface (Typ) then Error_Pragma_Arg - ("implementation kind By_Protected_Procedure cannot be " & - "applied to a task interface primitive", Arg2); + ("implementation kind By_Protected_Procedure cannot be " + & "applied to a task interface primitive", Arg2); return; end if; @@ -11088,11 +12523,11 @@ package body Sem_Prag is Check_Restriction (No_Initialize_Scalars, N); -- Initialize_Scalars creates false positives in CodePeer, and - -- incorrect negative results in Alfa mode, so ignore this pragma + -- incorrect negative results in SPARK mode, so ignore this pragma -- in these modes. if not Restriction_Active (No_Initialize_Scalars) - and then not (CodePeer_Mode or Alfa_Mode) + and then not (CodePeer_Mode or SPARK_Mode) then Init_Or_Norm_Scalars := True; Initialize_Scalars := True; @@ -11123,10 +12558,10 @@ package body Sem_Prag is when Pragma_Inline_Always => GNAT_Pragma; - -- Pragma always active unless in CodePeer or Alfa mode, since + -- Pragma always active unless in CodePeer or SPARK mode, since -- this causes walk order issues. - if not (CodePeer_Mode or Alfa_Mode) then + if not (CodePeer_Mode or SPARK_Mode) then Process_Inline (Enabled); end if; @@ -11460,8 +12895,8 @@ package body Sem_Prag is Int_Val > Expr_Value (Type_High_Bound (Int_Id)) then Error_Pragma_Arg - ("value not in range of type " & - """Ada.Interrupts.Interrupt_'I'D""", Arg1); + ("value not in range of type " + & """Ada.Interrupts.Interrupt_'I'D""", Arg1); end if; end if; @@ -11567,8 +13002,8 @@ package body Sem_Prag is elsif In_Private_Part (Current_Scope) then Error_Pragma_Arg - ("pragma% only allowed for private type " & - "declared in visible part", Arg1); + ("pragma% only allowed for private type declared in " + & "visible part", Arg1); else Error_Pragma_Arg @@ -11576,12 +13011,13 @@ package body Sem_Prag is end if; -- Note that the type has at least one invariant, and also that - -- it has inheritable invariants if we have Invariant'Class. - -- Build the corresponding invariant procedure declaration, so - -- that calls to it can be generated before the body is built - -- (for example wihin an expression function). + -- it has inheritable invariants if we have Invariant'Class + -- or Type_Invariant'Class. Build the corresponding invariant + -- procedure declaration, so that calls to it can be generated + -- before the body is built (e.g. within an expression function). PDecl := Build_Invariant_Procedure_Declaration (Typ); + Insert_After (N, PDecl); Analyze (PDecl); @@ -11661,12 +13097,12 @@ package body Sem_Prag is if Ekind (Def_Id) /= E_Function then if VM_Target = JVM_Target then Error_Pragma_Arg - ("pragma% requires function returning a " & - "'Java access type", Def_Id); + ("pragma% requires function returning a 'Java access " + & "type", Def_Id); else Error_Pragma_Arg - ("pragma% requires function returning a " & - "'C'I'L access type", Def_Id); + ("pragma% requires function returning a 'C'I'L access " + & "type", Def_Id); end if; end if; @@ -11762,8 +13198,8 @@ package body Sem_Prag is then Error_Msg_Name_1 := Pname; Error_Msg_N - ("first formal of % function must be a named access" & - " to subprogram type", + ("first formal of % function must be a named access " + & "to subprogram type", Parameter_Type (Parent (This_Formal))); -- Warning: We should reject anonymous access types because @@ -11779,9 +13215,8 @@ package body Sem_Prag is then Error_Msg_Name_1 := Pname; Error_Msg_N - ("first formal of % function must be a named access" & - " type", - Parameter_Type (Parent (This_Formal))); + ("first formal of % function must be a named access " + & "type", Parameter_Type (Parent (This_Formal))); elsif Atree.Convention (Designated_Type (Etype (This_Formal))) /= Convention @@ -11790,14 +13225,12 @@ package body Sem_Prag is if Convention = Convention_Java then Error_Msg_N - ("pragma% requires convention 'Cil in designated" & - " type", - Parameter_Type (Parent (This_Formal))); + ("pragma% requires convention 'Cil in designated " + & "type", Parameter_Type (Parent (This_Formal))); else Error_Msg_N - ("pragma% requires convention 'Java in designated" & - " type", - Parameter_Type (Parent (This_Formal))); + ("pragma% requires convention 'Java in designated " + & "type", Parameter_Type (Parent (This_Formal))); end if; elsif No (Expression (Parent (This_Formal))) @@ -11826,13 +13259,13 @@ package body Sem_Prag is if Atree.Convention (Etype (Def_Id)) /= Convention then if Convention = Convention_Java then Error_Pragma_Arg - ("pragma% requires function returning a " & - "'Java access type", Arg1); + ("pragma% requires function returning a 'Java " + & "access type", Arg1); else pragma Assert (Convention = Convention_CIL); Error_Pragma_Arg - ("pragma% requires function returning a " & - "'C'I'L access type", Arg1); + ("pragma% requires function returning a 'C'I'L " + & "access type", Arg1); end if; end if; @@ -11847,12 +13280,12 @@ package body Sem_Prag is if Convention = Convention_Java then Error_Pragma_Arg - ("pragma% requires function returning a named" & - "'Java access type", Arg1); + ("pragma% requires function returning a named " + & "'Java access type", Arg1); else Error_Pragma_Arg - ("pragma% requires function returning a named" & - "'C'I'L access type", Arg1); + ("pragma% requires function returning a named " + & "'C'I'L access type", Arg1); end if; end if; end if; @@ -12379,46 +13812,6 @@ package body Sem_Prag is Set_Standard_Fpt_Formats; end Long_Float; - -------------------- - -- Loop_Invariant -- - -------------------- - - -- pragma Loop_Invariant ( boolean_EXPRESSION ); - - when Pragma_Loop_Invariant => Loop_Invariant : declare - begin - GNAT_Pragma; - S14_Pragma; - Check_Arg_Count (1); - Check_Loop_Pragma_Placement; - - -- Completely ignore if disabled - - if Check_Disabled (Pname) then - Rewrite (N, Make_Null_Statement (Loc)); - Analyze (N); - return; - end if; - - Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean); - - -- Transform pragma Loop_Invariant into equivalent pragma Check - -- Generate: - -- pragma Check (Loop_Invaraint, Arg1); - - -- Seems completely wrong to hijack pragma Check this way ??? - - Rewrite (N, - Make_Pragma (Loc, - Chars => Name_Check, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Loop_Invariant)), - Relocate_Node (Arg1)))); - - Analyze (N); - end Loop_Invariant; - ------------------- -- Loop_Optimize -- ------------------- @@ -12434,12 +13827,14 @@ package body Sem_Prag is GNAT_Pragma; Check_At_Least_N_Arguments (1); Check_No_Identifiers; + Hint := First (Pragma_Argument_Associations (N)); while Present (Hint) loop Check_Arg_Is_One_Of (Hint, Name_No_Unroll, Name_Unroll, Name_No_Vector, Name_Vector); Next (Hint); end loop; + Check_Loop_Pragma_Placement; end Loop_Optimize; @@ -12459,29 +13854,21 @@ package body Sem_Prag is begin GNAT_Pragma; - S14_Pragma; Check_At_Least_N_Arguments (1); Check_Loop_Pragma_Placement; - -- Completely ignore if disabled - - if Check_Disabled (Pname) then - Rewrite (N, Make_Null_Statement (Loc)); - Analyze (N); - return; - end if; - -- Process all increasing / decreasing expressions Variant := First (Pragma_Argument_Associations (N)); while Present (Variant) loop - if Chars (Variant) /= Name_Decreases - and then Chars (Variant) /= Name_Increases + if not Nam_In (Chars (Variant), Name_Decreases, + Name_Increases) then Error_Pragma_Arg ("wrong change modifier", Variant); end if; - Preanalyze_And_Resolve (Expression (Variant), Any_Discrete); + Preanalyze_Assert_Expression + (Expression (Variant), Any_Discrete); Next (Variant); end loop; @@ -12809,10 +14196,10 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; -- Normalize_Scalars creates false positives in CodePeer, and - -- incorrect negative results in Alfa mode, so ignore this pragma + -- incorrect negative results in SPARK mode, so ignore this pragma -- in these modes. - if not (CodePeer_Mode or Alfa_Mode) then + if not (CodePeer_Mode or SPARK_Mode) then Normalize_Scalars := True; Init_Or_Norm_Scalars := True; end if; @@ -12875,8 +14262,8 @@ package body Sem_Prag is loop if No (Ent) then Error_Pragma - ("pragma % entity name does not match any " & - "enumeration literal"); + ("pragma % entity name does not match any " + & "enumeration literal"); elsif Chars (Ent) = Chars (Ename) then Set_Entity (Ename, Ent); @@ -13264,7 +14651,7 @@ package body Sem_Prag is -- complex front-end expansions related to pragma Pack, -- so disable handling of pragma Pack in these cases. - if CodePeer_Mode or Alfa_Mode then + if CodePeer_Mode or SPARK_Mode then null; -- Don't attempt any packing for VM targets. We possibly @@ -13414,12 +14801,22 @@ package body Sem_Prag is Check_First_Subtype (Arg1); Ent := Entity (Get_Pragma_Arg (Arg1)); - if not (Is_Private_Type (Ent) - or else - Is_Protected_Type (Ent) - or else - (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))) + -- The pragma may come from an aspect on a private declaration, + -- even if the freeze point at which this is analyzed in the + -- private part after the full view. + + if Has_Private_Declaration (Ent) + and then From_Aspect_Specification (N) then + null; + + elsif Is_Private_Type (Ent) + or else Is_Protected_Type (Ent) + or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent)) + then + null; + + else Error_Pragma_Arg ("pragma % can only be applied to private, formal derived or " & "protected type", @@ -13434,8 +14831,8 @@ package body Sem_Prag is and then not Has_Preelaborable_Initialization (Ent) then Error_Msg_N - ("protected type & does not have preelaborable " & - "initialization", Ent); + ("protected type & does not have preelaborable " + & "initialization", Ent); -- Otherwise mark the type as definitely having preelaborable -- initialization. @@ -13552,7 +14949,7 @@ package body Sem_Prag is Check_Precondition_Postcondition (In_Body); - -- When the pragma is a source contruct and appears inside a body, + -- When the pragma is a source construct appearing inside a body, -- preanalyze the boolean_expression to detect illegal forward -- references: @@ -13583,10 +14980,20 @@ package body Sem_Prag is Check_Precondition_Postcondition (In_Body); -- If in spec, nothing more to do. If in body, then we convert the - -- pragma to pragma Check (Precondition, cond [, msg]). Note we do - -- this whether or not precondition checks are enabled. That works - -- fine since pragma Check will do this check, and will also - -- analyze the condition itself in the proper context. + -- pragma to an equivalent pragam Check. Note we do this whether + -- or not precondition checks are enabled. That works fine since + -- pragma Check will do this check, and will also analyze the + -- condition itself in the proper context. + + -- The form of the pragma Check is either: + + -- pragma Check (Precondition, cond [, msg]) + -- or + -- pragma Check (Pre, cond [, msg]) + + -- We use the Pre form if this pragma derived from a Pre aspect. + -- This is needed to make sure that the right set of Policy + -- pragmas are checked. if In_Body then Rewrite (N, @@ -13594,7 +15001,7 @@ package body Sem_Prag is Chars => Name_Check, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Precondition)), + Expression => Make_Identifier (Loc, Pname)), Make_Pragma_Argument_Association (Sloc (Arg1), Expression => Relocate_Node (Get_Pragma_Arg (Arg1)))))); @@ -13808,7 +15215,7 @@ package body Sem_Prag is -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. - Preanalyze_Spec_Expression (Arg, Standard_Integer); + Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority)); if not Is_Static_Expression (Arg) then Check_Restriction (Static_Priorities, Arg); @@ -13894,8 +15301,8 @@ package body Sem_Prag is elsif Lower_Val > Upper_Val then Error_Pragma - ("last_priority_expression must be greater than" & - " or equal to first_priority_expression"); + ("last_priority_expression must be greater than or equal to " + & "first_priority_expression"); -- Store the new policy, but always preserve System_Location since -- we like the error message with the run-time name. @@ -14737,8 +16144,8 @@ package body Sem_Prag is or else In_Package_Body (Current_Scope) then Error_Pragma - ("pragma% can only apply to type declared immediately " & - "within a package declaration"); + ("pragma% can only apply to type declared immediately " + & "within a package declaration"); end if; -- A simple storage pool type must be an immutably limited record @@ -14976,8 +16383,8 @@ package body Sem_Prag is or else Present (Next_Formal (First_Formal (Ent))) then Error_Pragma_Arg - ("argument for pragma% must be" & - " function of one argument", Arg); + ("argument for pragma% must be function of one argument", + Arg); end if; end Check_OK_Stream_Convert_Function; @@ -15483,7 +16890,7 @@ package body Sem_Prag is -- MODE_TYPE ::= Nominal | Robustness when Pragma_Test_Case => - Check_Contract_Or_Test_Case; + Check_Test_Case; -------------------------- -- Thread_Local_Storage -- @@ -16071,14 +17478,36 @@ package body Sem_Prag is -- Warnings -- -------------- - -- pragma Warnings (On | Off); - -- pragma Warnings (On | Off, LOCAL_NAME); - -- pragma Warnings (static_string_EXPRESSION); - -- pragma Warnings (On | Off, STRING_LITERAL); + -- pragma Warnings (On | Off [,REASON]); + -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]); + -- pragma Warnings (static_string_EXPRESSION [,REASON]); + -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]); + + -- REASON ::= Reason => Static_String_Expression when Pragma_Warnings => Warnings : begin GNAT_Pragma; Check_At_Least_N_Arguments (1); + + -- See if last argument is labeled Reason. If so, make sure we + -- have a static string expression, but otherwise just ignore + -- the REASON argument by decreasing Num_Args by 1 (all the + -- remaining tests look only at the first Num_Args arguments). + + declare + Last_Arg : constant Node_Id := + Last (Pragma_Argument_Associations (N)); + begin + if Nkind (Last_Arg) = N_Pragma_Argument_Association + and then Chars (Last_Arg) = Name_Reason + then + Check_Arg_Is_Static_Expression (Last_Arg, Standard_String); + Arg_Count := Arg_Count - 1; + end if; + end; + + -- Now proceed with REASON taken care of and eliminated + Check_No_Identifiers; -- If debug flag -gnatd.i is set, pragma is ignored @@ -16100,10 +17529,7 @@ package body Sem_Prag is -- On/Off one argument case was processed by parser if Nkind (Argx) = N_Identifier - and then - (Chars (Argx) = Name_On - or else - Chars (Argx) = Name_Off) + and then Nam_In (Chars (Argx), Name_On, Name_Off) then null; @@ -16111,8 +17537,8 @@ package body Sem_Prag is elsif not Is_Static_String_Expression (Arg1) then Error_Pragma_Arg - ("argument of pragma% must be On/Off or " & - "static string expression", Arg1); + ("argument of pragma% must be On/Off or static string " + & "expression", Arg1); -- One argument string expression case @@ -16156,8 +17582,8 @@ package body Sem_Prag is if not Set_Dot_Warning_Switch (Chr) then Error_Pragma_Arg - ("invalid warning switch character " & - '.' & Chr, Arg1); + ("invalid warning switch character " + & '.' & Chr, Arg1); end if; -- Non-Dot case @@ -16250,8 +17676,8 @@ package body Sem_Prag is elsif not Is_Static_String_Expression (Arg2) then Error_Pragma_Arg - ("second argument of pragma% must be entity " & - "name or static string expression", Arg2); + ("second argument of pragma% must be entity name " + & "or static string expression", Arg2); -- String literal case @@ -16290,9 +17716,8 @@ package body Sem_Prag is if Err then Error_Msg - ("??pragma Warnings On with no " & - "matching Warnings Off", - Loc); + ("??pragma Warnings On with no matching " + & "Warnings Off", Loc); end if; end if; end if; @@ -16371,84 +17796,305 @@ package body Sem_Prag is when Pragma_Exit => null; end Analyze_Pragma; - -------------------- - -- Check_Disabled -- - -------------------- + ------------------------------------ + -- Analyze_Test_Case_In_Decl_Part -- + ------------------------------------ + + procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id; S : Entity_Id) is + begin + -- Install formals and push subprogram spec onto scope stack so that we + -- can see the formals from the pragma. + + Push_Scope (S); + Install_Formals (S); + + -- Preanalyze the boolean expressions, we treat these as spec + -- expressions (i.e. similar to a default expression). + + if Pragma_Name (N) = Name_Test_Case then + Preanalyze_CTC_Args + (N, + Get_Requires_From_CTC_Pragma (N), + Get_Ensures_From_CTC_Pragma (N)); + end if; + + -- Remove the subprogram from the scope stack now that the pre-analysis + -- of the expressions in the contract case or test case is done. + + End_Scope; + end Analyze_Test_Case_In_Decl_Part; - function Check_Disabled (Nam : Name_Id) return Boolean is + ---------------- + -- Appears_In -- + ---------------- + + function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is + Elmt : Elmt_Id; + Id : Entity_Id; + + begin + if Present (List) then + Elmt := First_Elmt (List); + while Present (Elmt) loop + if Nkind (Node (Elmt)) = N_Defining_Identifier then + Id := Node (Elmt); + else + Id := Entity (Node (Elmt)); + end if; + + if Id = Item_Id then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + return False; + end Appears_In; + + ---------------- + -- Check_Kind -- + ---------------- + + function Check_Kind (Nam : Name_Id) return Name_Id is PP : Node_Id; begin -- Loop through entries in check policy list PP := Opt.Check_Policy_List; - loop - -- If there are no specific entries that matched, then nothing is - -- disabled, so return False. + while Present (PP) loop + declare + PPA : constant List_Id := Pragma_Argument_Associations (PP); + Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA))); - if No (PP) then - return False; - - -- Here we have an entry see if it matches + begin + if Nam = Pnm + or else (Pnm = Name_Assertion + and then Is_Valid_Assertion_Kind (Nam)) + or else (Pnm = Name_Statement_Assertions + and then Nam_In (Nam, Name_Assert, + Name_Assert_And_Cut, + Name_Assume, + Name_Loop_Invariant)) + then + case (Chars (Get_Pragma_Arg (Last (PPA)))) is + when Name_On | Name_Check => + return Name_Check; + when Name_Off | Name_Ignore => + return Name_Ignore; + when Name_Disable => + return Name_Disable; + when others => + raise Program_Error; + end case; - else - declare - PPA : constant List_Id := Pragma_Argument_Associations (PP); - begin - if Nam = Chars (Get_Pragma_Arg (First (PPA))) then - return Chars (Get_Pragma_Arg (Last (PPA))) = Name_Disable; - else - PP := Next_Pragma (PP); - end if; - end; - end if; + else + PP := Next_Pragma (PP); + end if; + end; end loop; - end Check_Disabled; - ------------------- - -- Check_Enabled -- - ------------------- + -- If there are no specific entries that matched, then we let the + -- setting of assertions govern. Note that this provides the needed + -- compatibility with the RM for the cases of assertion, invariant, + -- precondition, predicate, and postcondition. - function Check_Enabled (Nam : Name_Id) return Boolean is - PP : Node_Id; + if Assertions_Enabled then + return Name_Check; + else + return Name_Ignore; + end if; + end Check_Kind; + + ----------------------------- + -- Check_Applicable_Policy -- + ----------------------------- + + procedure Check_Applicable_Policy (N : Node_Id) is + PP : Node_Id; + Policy : Name_Id; + + Ename : constant Name_Id := Original_Name (N); begin + -- No effect if not valid assertion kind name + + if not Is_Valid_Assertion_Kind (Ename) then + return; + end if; + -- Loop through entries in check policy list PP := Opt.Check_Policy_List; - loop - -- If there are no specific entries that matched, then we let the - -- setting of assertions govern. Note that this provides the needed - -- compatibility with the RM for the cases of assertion, invariant, - -- precondition, predicate, and postcondition. + while Present (PP) loop + declare + PPA : constant List_Id := Pragma_Argument_Associations (PP); + Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA))); + + begin + if Ename = Pnm or else Pnm = Name_Assertion then + Policy := Chars (Get_Pragma_Arg (Last (PPA))); - if No (PP) then - return Assertions_Enabled; + case Policy is + when Name_Off | Name_Ignore => + Set_Is_Ignored (N, True); - -- Here we have an entry see if it matches + when Name_Disable => + Set_Is_Ignored (N, True); + Set_Is_Disabled (N, True); + + when others => + null; + end case; + + return; + end if; + + PP := Next_Pragma (PP); + end; + end loop; + + -- If there are no specific entries that matched, then we let the + -- setting of assertions govern. Note that this provides the needed + -- compatibility with the RM for the cases of assertion, invariant, + -- precondition, predicate, and postcondition. + + if not Assertions_Enabled then + Set_Is_Ignored (N); + end if; + end Check_Applicable_Policy; + + --------------------------------------- + -- Collect_Subprogram_Inputs_Outputs -- + --------------------------------------- + + 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) + is + procedure Collect_Global_List + (List : Node_Id; + Mode : Name_Id := Name_Input); + -- Collect all relevant items from a global list + + ------------------------- + -- Collect_Global_List -- + ------------------------- + + procedure Collect_Global_List + (List : Node_Id; + Mode : Name_Id := Name_Input) + is + procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id); + -- Add an item to the proper subprogram input or output collection + + ------------------------- + -- Collect_Global_Item -- + ------------------------- + + procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is + begin + if Nam_In (Mode, Name_In_Out, Name_Input) then + Add_Item (Item, Subp_Inputs); + end if; + + if Nam_In (Mode, Name_In_Out, Name_Output) then + Add_Item (Item, Subp_Outputs); + end if; + end Collect_Global_Item; + + -- Local variables + + Assoc : Node_Id; + Item : Node_Id; + + -- Start of processing for Collect_Global_List + + begin + -- Single global item declaration + + if Nkind_In (List, N_Identifier, N_Selected_Component) then + Collect_Global_Item (List, Mode); + + -- Simple global list or moded global list declaration else - declare - PPA : constant List_Id := Pragma_Argument_Associations (PP); + if Present (Expressions (List)) then + Item := First (Expressions (List)); + while Present (Item) loop + Collect_Global_Item (Item, Mode); + Next (Item); + end loop; - begin - if Nam = Chars (Get_Pragma_Arg (First (PPA))) then - case (Chars (Get_Pragma_Arg (Last (PPA)))) is - when Name_On | Name_Check => - return True; - when Name_Off | Name_Ignore => - return False; - when others => - raise Program_Error; - end case; + else + Assoc := First (Component_Associations (List)); + while Present (Assoc) loop + Collect_Global_List + (List => Expression (Assoc), + Mode => Chars (First (Choices (Assoc)))); + Next (Assoc); + end loop; + end if; + end if; + end Collect_Global_List; - else - PP := Next_Pragma (PP); - end if; - end; + -- Local variables + + Formal : Entity_Id; + Global : Node_Id; + List : Node_Id; + + -- Start of processing for Collect_Subprogram_Inputs_Outputs + + begin + Global_Seen := False; + + -- Process all formal parameters + + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then + Add_Item (Formal, Subp_Inputs); + end if; + + if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then + Add_Item (Formal, Subp_Outputs); end if; + + Next_Formal (Formal); end loop; - end Check_Enabled; + + -- If the subprogram is subject to pragma Global, traverse all global + -- lists and gather the relevant items. + + Global := Find_Aspect (Subp_Id, Aspect_Global); + if Present (Global) then + Global_Seen := True; + + -- Retrieve the pragma as it contains the analyzed lists + + Global := Aspect_Rep_Item (Global); + 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); + end if; + + -- Nothing to be done for a null global list + + if Nkind (List) /= N_Null then + Collect_Global_List (List); + end if; + end if; + end Collect_Subprogram_Inputs_Outputs; --------------------------------- -- Delay_Config_Pragma_Analyze -- @@ -16456,11 +18102,99 @@ package body Sem_Prag is function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is begin - return Pragma_Name (N) = Name_Interrupt_State - or else - Pragma_Name (N) = Name_Priority_Specific_Dispatching; + return Nam_In (Pragma_Name (N), Name_Interrupt_State, + Name_Priority_Specific_Dispatching); end Delay_Config_Pragma_Analyze; + ----------------------------- + -- Find_Related_Subprogram -- + ----------------------------- + + function Find_Related_Subprogram + (Prag : Node_Id; + Check_Duplicates : 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; + + 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 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. + + pragma Assert (Is_List_Member (Prag)); + + Elmt := Prag; + loop + Elmt := Prev (Elmt); + exit when No (Elmt); + + -- 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. + + 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 + Error_Msg_Name_1 := Nam; + Error_Msg_Sloc := Sloc (Subp_Decl); + Error_Msg_N ("pragma % duplicates pragma declared #", Prag); + end if; + + -- Skip internally generated code + + elsif not Comes_From_Source (Subp_Decl) then + null; + + -- Otherwise we have a declaration to return + + else + return Subp_Decl; + end if; + 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). + + -- The pragma is associated with a library-level subprogram + + if Nkind (Context) = N_Compilation_Unit_Aux then + return Unit (Parent (Context)); + + -- The pragma appears inside the declarative part of a subprogram body + + elsif Nkind (Context) = N_Subprogram_Body then + return Context; + + -- Otherwise no subprogram found, return original pragma + + else + return Prag; + end if; + end Find_Related_Subprogram; + ------------------------- -- Get_Base_Subprogram -- ------------------------- @@ -16583,7 +18317,7 @@ package body Sem_Prag is Pragma_Assert => -1, Pragma_Assert_And_Cut => -1, Pragma_Assertion_Policy => 0, - Pragma_Assume => 0, + Pragma_Assume => -1, Pragma_Assume_No_Invalid_Values => 0, Pragma_Attribute_Definition => +3, Pragma_Asynchronous => -1, @@ -16609,7 +18343,6 @@ package body Sem_Prag is Pragma_Complete_Representation => 0, Pragma_Complex_Representation => 0, Pragma_Component_Alignment => -1, - Pragma_Contract_Case => -1, Pragma_Contract_Cases => -1, Pragma_Controlled => 0, Pragma_Convention => 0, @@ -16618,6 +18351,7 @@ package body Sem_Prag is Pragma_Debug_Policy => 0, Pragma_Detect_Blocking => -1, Pragma_Default_Storage_Pool => -1, + Pragma_Depends => -1, Pragma_Disable_Atomic_Synchronization => -1, Pragma_Discard_Names => 0, Pragma_Dispatching_Domain => -1, @@ -16899,6 +18633,45 @@ package body Sem_Prag is end if; end Is_Pragma_String_Literal; + ----------------------------- + -- Is_Valid_Assertion_Kind -- + ----------------------------- + + function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is + begin + case Nam is + when + -- RM defined + + Name_Assert | + Name_Static_Predicate | + Name_Dynamic_Predicate | + Name_Pre | + Name_uPre | + Name_Post | + Name_uPost | + Name_Type_Invariant | + Name_uType_Invariant | + + -- Impl defined + + Name_Assert_And_Cut | + Name_Assume | + Name_Contract_Cases | + Name_Debug | + Name_Invariant | + Name_uInvariant | + Name_Loop_Invariant | + Name_Loop_Variant | + Name_Postcondition | + Name_Precondition | + Name_Predicate | + Name_Statement_Assertions => return True; + + when others => return False; + end case; + end Is_Valid_Assertion_Kind; + ----------------------------------------- -- Make_Aspect_For_PPC_In_Gen_Sub_Decl -- ----------------------------------------- @@ -16975,6 +18748,66 @@ 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 -- ------------------------- @@ -17038,6 +18871,35 @@ package body Sem_Prag is end Process_Compilation_Unit_Pragmas; + ---------------------------- + -- Rewrite_Assertion_Kind -- + ---------------------------- + + procedure Rewrite_Assertion_Kind (N : Node_Id) is + Nam : Name_Id; + + begin + if Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Class + and then Nkind (Prefix (N)) = N_Identifier + then + case Chars (Prefix (N)) is + when Name_Pre => + Nam := Name_uPre; + when Name_Post => + Nam := Name_uPost; + when Name_Type_Invariant => + Nam := Name_uType_Invariant; + when Name_Invariant => + Nam := Name_uInvariant; + when others => + return; + end case; + + Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam)); + end if; + end Rewrite_Assertion_Kind; + -------- -- rv -- -------- @@ -17047,6 +18909,44 @@ 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 9df7d5ab711..3b8a3bcbc89 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.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- -- @@ -38,13 +38,14 @@ package Sem_Prag is procedure Analyze_Pragma (N : Node_Id); -- Analyze procedure for pragma reference node N - procedure Analyze_CTC_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..."). + procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id); + -- 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 + + procedure Analyze_Global_In_Decl_Part (N : Node_Id); + -- Perform full analysis of delayed pragma Global procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id); -- Special analyze routine for precondition/postcondition pragma that @@ -54,22 +55,53 @@ package Sem_Prag is -- of the expressions in the pragma as "spec expressions" (see section -- in Sem "Handling of Default and Per-Object Expressions..."). - function Check_Disabled (Nam : Name_Id) return Boolean; - -- This function is used in connection with pragmas Assertion, Check, - -- Precondition, and Postcondition, to determine if Check pragmas (or - -- corresponding Assert, Precondition, or Postcondition pragmas) are - -- currently disabled (as set by a Check_Policy or Assertion_Policy pragma - -- with the Disable argument). - - function Check_Enabled (Nam : Name_Id) return Boolean; - -- This function is used in connection with pragmas Assertion, Check, - -- Precondition, and Postcondition, to determine if Check pragmas (or - -- corresponding Assert, Precondition, or Postcondition pragmas) are - -- currently active, as determined by the presence of -gnata on the - -- command line (which sets the default), and the appearance of pragmas - -- Check_Policy and Assertion_Policy as configuration pragmas either in - -- a configuration pragma file, or at the start of the current unit. - -- True is returned if the specified check is enabled. + 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..."). + + function Check_Kind (Nam : Name_Id) return Name_Id; + -- This function is used in connection with pragmas Assert, Check, + -- and assertion aspects and pragmas, to determine if Check pragmas + -- (or corresponding assertion aspects or pragmas) are currently active + -- as determined by the presence of -gnata on the command line (which + -- sets the default), and the appearance of pragmas Check_Policy and + -- Assertion_Policy as configuration pragmas either in a configuration + -- pragma file, or at the start of the current unit, or locally given + -- Check_Policy and Assertion_Policy pragmas that are currently active. + -- + -- The value returned is one of the names Check, Ignore, Disable (On + -- returns Check, and Off returns Ignore). + -- + -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class, + -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost, + -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre, + -- _Post, _Invariant, or _Type_Invariant, which are special names used + -- in identifiers to represent these attribute references. + + procedure Check_Applicable_Policy (N : Node_Id); + -- N is either an N_Aspect or an N_Pragma node. There are two cases. If + -- the name of the aspect or pragma is not one of those recognized as + -- an assertion kind by an Assertion_Policy pragma, then the call has + -- no effect. Note that in the case of a pragma derived from an aspect, + -- the name we use for the purpose of this procedure is the aspect name, + -- which may be different from the pragma name (e.g. Precondition for + -- Pre aspect). In addition, 'Class aspects are recognized (and the + -- corresponding special names used in the processing). + -- + -- If the name is a valid assertion kind name, then the Check_Policy pragma + -- chain is checked for a matching entry (or for an Assertion entry which + -- matches all possibilities). If a matching entry is found then the policy + -- is checked. If it is Off, Ignore, or Disable, then the Is_Ignored flag + -- is set in the aspect or pragma node. Additionally for policy Disable, + -- the Is_Disabled flag is set. + -- + -- If no matching Check_Policy pragma is found then the effect depends on + -- whether -gnata was used, if so, then the call has no effect, otherwise + -- Is_Ignored (but not Is_Disabled) is set True. function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean; -- N is a pragma appearing in a configuration pragma file. Most such @@ -85,6 +117,16 @@ package Sem_Prag is -- Initializes data structures used for pragma processing. Must be called -- before analyzing each new main source program. + function Is_Config_Static_String (Arg : Node_Id) return Boolean; + -- This is called for a configuration pragma that requires either string + -- literal or a concatenation of string literals. We cannot use normal + -- static string processing because it is too early in the case of the + -- pragma appearing in a configuration pragmas file. If Arg is of an + -- appropriate form, then this call obtains the string (doing any necessary + -- concatenations) and places it in Name_Buffer, setting Name_Len to its + -- length, and then returns True. If it is not of the correct form, then an + -- appropriate error message is posted, and False is returned. + function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean; -- The node N is a node for an entity and the issue is whether the -- occurrence is a reference for the purposes of giving warnings about @@ -101,15 +143,12 @@ package Sem_Prag is -- False is returned, then the argument is treated as an entity reference -- to the operator. - function Is_Config_Static_String (Arg : Node_Id) return Boolean; - -- This is called for a configuration pragma that requires either string - -- literal or a concatenation of string literals. We cannot use normal - -- static string processing because it is too early in the case of the - -- pragma appearing in a configuration pragmas file. If Arg is of an - -- appropriate form, then this call obtains the string (doing any necessary - -- concatenations) and places it in Name_Buffer, setting Name_Len to its - -- length, and then returns True. If it is not of the correct form, then an - -- appropriate error message is posted, and False is returned. + function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean; + -- Returns True if Nam is one of the names recognized as a valid assertion + -- kind by the Assertion_Policy pragma. Note that the 'Class cases are + -- represented by the corresponding special names Name_uPre, Name_uPost, + -- Name_uInviarnat, and Name_uType_Invariant (_Pre, _Post, _Invariant, + -- and _Type_Invariant). procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id); -- This routine makes aspects from precondition or postcondition pragmas diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4fcbee93a2c..b4a654a24cc 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1005,9 +1005,9 @@ package body Sem_Res is -- functions, this is never a parameterless call (RM 4.1.4(6)). if Nkind (Parent (N)) = N_Attribute_Reference - and then (Attribute_Name (Parent (N)) = Name_Address or else - Attribute_Name (Parent (N)) = Name_Code_Address or else - Attribute_Name (Parent (N)) = Name_Access) + and then Nam_In (Attribute_Name (Parent (N)), Name_Address, + Name_Code_Address, + Name_Access) then return False; end if; @@ -1373,7 +1373,7 @@ package body Sem_Res is elsif In_Instance then null; - elsif (Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide) + elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) then @@ -1385,7 +1385,7 @@ package body Sem_Res is -- available. elsif Ada_Version >= Ada_2005 - and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) + and then Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type then null; @@ -1496,9 +1496,7 @@ package body Sem_Res is and then not In_Instance then if Is_Fixed_Point_Type (Typ) - and then (Op_Name = Name_Op_Multiply - or else - Op_Name = Name_Op_Divide) + and then Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) then -- Already checked above @@ -1534,7 +1532,7 @@ package body Sem_Res is -- the equality node will not resolve any remaining ambiguity, and it -- assumes that the first operand is not overloaded. - if (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) + if Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) and then Ekind (Func) = E_Function and then Is_Overloaded (Act1) then @@ -1668,16 +1666,16 @@ package body Sem_Res is -- and reexpanded later on. We will also have more information at that -- point for possible suppression of individual checks. - -- However, in Alfa mode, most expansion is suppressed, and this - -- later reanalysis and reexpansion may not occur. Alfa mode does + -- However, in SPARK mode, most expansion is suppressed, and this + -- later reanalysis and reexpansion may not occur. SPARK mode does -- require the setting of checking flags for proof purposes, so we - -- do the Alfa preanalysis without suppressing checks. + -- do the SPARK preanalysis without suppressing checks. - -- This special handling for Alfa mode is required for example in the + -- This special handling for SPARK mode is required for example in the -- case of Ada 2012 constructs such as quantified expressions, which are -- expanded in two separate steps. - if Alfa_Mode then + if SPARK_Mode then Analyze_And_Resolve (N, T); else Analyze_And_Resolve (N, T, Suppress => All_Checks); @@ -1947,9 +1945,9 @@ package body Sem_Res is -- access-to-subprogram type. if Nkind (N) = N_Attribute_Reference - and then (Attribute_Name (N) = Name_Access or else - Attribute_Name (N) = Name_Unrestricted_Access or else - Attribute_Name (N) = Name_Unchecked_Access) + and then Nam_In (Attribute_Name (N), Name_Access, + Name_Unrestricted_Access, + Name_Unchecked_Access) and then Comes_From_Source (N) and then Is_Entity_Name (Prefix (N)) and then Is_Subprogram (Entity (Prefix (N))) @@ -2060,7 +2058,17 @@ package body Sem_Res is Analyze_Dimension (N); return; - -- Return if type = Any_Type (previous error encountered) + -- A Raise_Expression takes its type from context. The Etype was set + -- to Any_Type, reflecting the fact that the expression itself does + -- not specify any possible interpretation. So we set the type to the + -- resolution type here and now. We need to do this before Resolve sees + -- the Any_Type value. + + elsif Nkind (N) = N_Raise_Expression then + Set_Etype (N, Typ); + + -- Any other case of Any_Type as the Etype value means that we had + -- a previous error. elsif Etype (N) = Any_Type then Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)"); @@ -2299,9 +2307,8 @@ package body Sem_Res is and then Scope (It.Nam) = Standard_Standard then Error_Msg_N - ("\\possible interpretation as " & - "universal_fixed operation " & - "(RM 4.5.5 (19))", N); + ("\\possible interpretation as universal_fixed " + & "operation (RM 4.5.5 (19))", N); else Error_Msg_N ("\\possible interpretation (predefined)#!", N); @@ -2589,8 +2596,9 @@ package body Sem_Res is end if; Error_Msg_Node_2 := Typ; - Error_Msg_NE ("no visible interpretation of&" & - " matches expected type&", N, Subp_Name); + Error_Msg_NE + ("no visible interpretation of& " + & "matches expected type&", N, Subp_Name); end; if All_Errors_Mode then @@ -2804,7 +2812,16 @@ package body Sem_Res is when N_Qualified_Expression => Resolve_Qualified_Expression (N, Ctx_Type); - when N_Quantified_Expression => null; + -- Why is the following null, needs a comment ??? + + when N_Quantified_Expression + => null; + + -- Nothing to do for Raise_Expression, since we took care of + -- setting the Etype earlier, and no other processing is needed. + + when N_Raise_Expression + => null; when N_Raise_xxx_Error => Set_Etype (N, Ctx_Type); @@ -3513,8 +3530,8 @@ package body Sem_Res is or else Is_By_Reference_Type (Etype (Expression (A))) then Error_Msg_N - ("view conversion between unrelated by reference " & - "array types not allowed (\'A'I-00246)", A); + ("view conversion between unrelated by reference " + & "array types not allowed (\'A'I-00246)", A); -- In Ada 2005 mode, check view conversion component -- type cannot be private, tagged, or volatile. Note @@ -3595,11 +3612,11 @@ package body Sem_Res is and then not Same_Ancestor (Etype (F), Etype (Expression (A))) and then (Is_Limited_Type (Etype (F)) - or else Is_Limited_Type (Etype (Expression (A)))) + or else Is_Limited_Type (Etype (Expression (A)))) then Error_Msg_N - ("conversion between unrelated limited array types " & - "not allowed (\A\I-00246)", A); + ("conversion between unrelated limited array types " + & "not allowed (\A\I-00246)", A); if Is_Limited_Type (Etype (F)) then Explain_Limited_Type (Etype (F), A); @@ -3648,15 +3665,19 @@ package body Sem_Res is Establish_Transient_Scope (A, False); end if; end; + + if Ekind (Etype (F)) = E_Anonymous_Access_Type then + Check_Restriction (No_Access_Parameter_Allocators, A); + end if; end if; - -- (Ada 2005): The call may be to a primitive operation of - -- a tagged synchronized type, declared outside of the type. - -- In this case the controlling actual must be converted to - -- its corresponding record type, which is the formal type. - -- The actual may be a subtype, either because of a constraint - -- or because it is a generic actual, so use base type to - -- locate concurrent type. + -- (Ada 2005): The call may be to a primitive operation of a + -- tagged synchronized type, declared outside of the type. In + -- this case the controlling actual must be converted to its + -- corresponding record type, which is the formal type. The + -- actual may be a subtype, either because of a constraint or + -- because it is a generic actual, so use base type to locate + -- concurrent type. F_Typ := Base_Type (Etype (F)); @@ -3925,10 +3946,14 @@ package body Sem_Res is -- Apply predicate checks, unless this is a call to the -- predicate check function itself, which would cause an - -- infinite recursion. + -- infinite recursion, or it is a call to an initialization + -- procedure whose operand is of course an unfinished object. if not (Ekind (Nam) = E_Function - and then Has_Predicates (Nam)) + and then (Is_Predicate_Function (Nam) + or else + Is_Predicate_Function_M (Nam))) + and then not Is_Init_Proc (Nam) then Apply_Predicate_Check (A, F_Typ); end if; @@ -4078,8 +4103,8 @@ package body Sem_Res is and then No (Non_Limited_View (Desig)) then Error_Msg_NE - ("premature use of incomplete type& " & - "in dispatching call", A, Desig); + ("premature use of incomplete type& " + & "in dispatching call", A, Desig); end if; end; end if; @@ -4137,12 +4162,12 @@ package body Sem_Res is -- If it is a named association, treat the selector_name as a -- proper identifier, and mark the corresponding entity. Ignore - -- this reference in Alfa mode, as it refers to an entity not in + -- 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. if Nkind (Parent (A)) = N_Parameter_Association - and then not Alfa_Mode + and then not SPARK_Mode then Set_Entity (Selector_Name (Parent (A)), F); Generate_Reference (F, Selector_Name (Parent (A))); @@ -4269,8 +4294,8 @@ package body Sem_Res is Error_Msg_N ("type of allocator cannot be abstract", N); end if; - -- For qualified expression, resolve the expression using the - -- given subtype (nothing to do for type mark, subtype indication) + -- For qualified expression, resolve the expression using the given + -- subtype (nothing to do for type mark, subtype indication) if Nkind (E) = N_Qualified_Expression then if Is_Class_Wide_Type (Etype (E)) @@ -4284,8 +4309,8 @@ package body Sem_Res is Resolve (Expression (E), Etype (E)); Check_Unset_Reference (Expression (E)); - -- A qualified expression requires an exact match of the type, - -- class-wide matching is not allowed. + -- A qualified expression requires an exact match of the type. + -- Class-wide matching is not allowed. if (Is_Class_Wide_Type (Etype (Expression (E))) or else Is_Class_Wide_Type (Etype (E))) @@ -4314,8 +4339,8 @@ package body Sem_Res is (Etype (Pool), Name_Simple_Storage_Pool_Type)) then Error_Msg_N - ("limited function calls not yet supported in simple " & - "storage pool allocators", Expression (E)); + ("limited function calls not yet supported in simple " + & "storage pool allocators", Expression (E)); end if; end; end if; @@ -4326,9 +4351,9 @@ package body Sem_Res is -- deeper than the type of the allocator (in contrast to access -- parameters, where the level of the actual can be arbitrary). - -- We can't use Valid_Conversion to perform this check because - -- in general the type of the allocator is unrelated to the type - -- of the access discriminant. + -- We can't use Valid_Conversion to perform this check because in + -- general the type of the allocator is unrelated to the type of + -- the access discriminant. if Ekind (Typ) /= E_Anonymous_Access_Type or else Is_Local_Anonymous_Access (Typ) @@ -4462,10 +4487,11 @@ package body Sem_Res is Deepest_Type_Access_Level (Typ) then if In_Instance_Body then - Error_Msg_N ("??type in allocator has deeper level than" & - " designated class-wide type", E); - Error_Msg_N ("\??Program_Error will be raised at run time", - E); + Error_Msg_N + ("??type in allocator has deeper level than " + & "designated class-wide type", E); + Error_Msg_N + ("\??Program_Error will be raised at run time", E); Rewrite (N, Make_Raise_Program_Error (Sloc (N), Reason => PE_Accessibility_Check_Failed)); @@ -4476,8 +4502,8 @@ package body Sem_Res is -- type. A run-time check will be performed in the instance. elsif not Is_Generic_Type (Exp_Typ) then - Error_Msg_N ("type in allocator has deeper level than" & - " designated class-wide type", E); + Error_Msg_N ("type in allocator has deeper level than " + & "designated class-wide type", E); end if; end if; end; @@ -4530,6 +4556,8 @@ package body Sem_Res is Defining_Identifier (Associated_Node_For_Itype (Typ)); begin + Check_Restriction (No_Coextensions, N); + -- Ada 2012 AI05-0052: If the designated type of the allocator -- is limited, then the allocator shall not be used to define -- the value of an access discriminant unless the discriminated @@ -4744,8 +4772,7 @@ package body Sem_Res is Resolve (N, Any_Fixed); elsif Is_Fixed_Point_Type (B_Typ) - and then (T = Universal_Real - or else Is_Fixed_Point_Type (T)) + and then (T = Universal_Real or else Is_Fixed_Point_Type (T)) and then Is_Overloaded (N) then -- C * F(X) in a fixed context, where C is a real literal or a @@ -4853,7 +4880,7 @@ package body Sem_Res is and then Is_Fixed_Point_Type (B_Typ)) or else (Is_Fixed_Point_Type (B_Typ) and then (Is_Integer_Or_Universal (L) - or else + or else Is_Integer_Or_Universal (R)))) and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) then @@ -4947,7 +4974,7 @@ package body Sem_Res is else if (TL = Universal_Integer or else TL = Universal_Real) - and then + and then (TR = Universal_Integer or else TR = Universal_Real) then Check_For_Visible_Operator (N, B_Typ); @@ -5039,8 +5066,8 @@ package body Sem_Res is and then not Machine_Overflows_On_Target then Error_Msg_N - ("float division by zero, " & - "may generate '+'/'- infinity??", Right_Opnd (N)); + ("float division by zero, may generate " + & "'+'/'- infinity??", Right_Opnd (N)); -- For all other cases, we get a Constraint_Error @@ -5111,7 +5138,7 @@ package body Sem_Res is -- In this case, the back end has to generate additional tests. if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg)) - or else + or else (Nkind (N) = N_Op_Mod and then (LNeg or RNeg)) then Check_Restriction (No_Implicit_Conditionals, N); @@ -5350,22 +5377,24 @@ package body Sem_Res is Check_Internal_Protected_Use (N, Nam); - -- Freeze the subprogram name if not in a spec-expression. Note that we - -- freeze procedure calls as well as function calls. Procedure calls are - -- not frozen according to the rules (RM 13.14(14)) because it is - -- impossible to have a procedure call to a non-frozen procedure in pure - -- Ada, but in the code that we generate in the expander, this rule - -- needs extending because we can generate procedure calls that need - -- freezing. + -- Freeze the subprogram name if not in a spec-expression. Note that + -- we freeze procedure calls as well as function calls. Procedure calls + -- are not frozen according to the rules (RM 13.14(14)) because it is + -- impossible to have a procedure call to a non-frozen procedure in + -- pure Ada, but in the code that we generate in the expander, this + -- rule needs extending because we can generate procedure calls that + -- need freezing. -- In Ada 2012, expression functions may be called within pre/post -- conditions of subsequent functions or expression functions. Such - -- calls do not freeze when they appear within generated bodies, which - -- would place the freeze node in the wrong scope. An expression - -- function is frozen in the usual fashion, by the appearance of a real - -- body, or at the end of a declarative part. + -- calls do not freeze when they appear within generated bodies, + -- (including the body of another expression function) which would + -- place the freeze node in the wrong scope. An expression function + -- is frozen in the usual fashion, by the appearance of a real body, + -- or at the end of a declarative part. if Is_Entity_Name (Subp) and then not In_Spec_Expression + and then not Is_Expression_Function (Current_Scope) and then (not Is_Expression_Function (Entity (Subp)) or else Scope (Entity (Subp)) = Current_Scope) @@ -5870,19 +5899,13 @@ package body Sem_Res is -- In formal mode, the primitive operations of a tagged type or type -- extension do not include functions that return the tagged type. - -- Commented out as the call to Is_Inherited_Operation_For_Type may - -- cause an error because the type entity of the parent node of - -- Entity (Name (N) may not be set. ??? - -- So why not just add a guard ??? - --- if Nkind (N) = N_Function_Call --- and then Is_Tagged_Type (Etype (N)) --- and then Is_Entity_Name (Name (N)) --- and then Is_Inherited_Operation_For_Type --- (Entity (Name (N)), Etype (N)) --- then --- Check_SPARK_Restriction ("function not inherited", N); --- end if; + if Nkind (N) = N_Function_Call + and then Is_Tagged_Type (Etype (N)) + and then Is_Entity_Name (Name (N)) + and then Is_Inherited_Operation_For_Type (Entity (Name (N)), Etype (N)) + then + Check_SPARK_Restriction ("function not inherited", N); + end if; -- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is -- class-wide and the call dispatches on result in a context that does @@ -6798,11 +6821,18 @@ package body Sem_Res is -- impose an expected type (as can be the case in an equality operation) -- the expression must be rejected. + procedure Explain_Redundancy (N : Node_Id); + -- Attempt to explain the nature of a redundant comparison with True. If + -- the expression N is too complex, this routine issues a general error + -- message. + function Find_Unique_Access_Type return Entity_Id; - -- In the case of allocators, make a last-ditch attempt to find a single - -- access type with the right designated type. This is semantically - -- dubious, and of no interest to any real code, but c48008a makes it - -- all worthwhile. + -- In the case of allocators and access attributes, the context must + -- provide an indication of the specific access type to be used. If + -- one operand is of such a "generic" access type, check whether there + -- is a specific visible access type that has the same designated type. + -- This is semantically dubious, and of no interest to any real code, + -- but c48008a makes it all worthwhile. ------------------------- -- Check_If_Expression -- @@ -6825,6 +6855,72 @@ package body Sem_Res is end if; end Check_If_Expression; + ------------------------ + -- Explain_Redundancy -- + ------------------------ + + procedure Explain_Redundancy (N : Node_Id) is + Error : Name_Id; + Val : Node_Id; + Val_Id : Entity_Id; + + begin + Val := N; + + -- Strip the operand down to an entity + + loop + if Nkind (Val) = N_Selected_Component then + Val := Selector_Name (Val); + else + exit; + end if; + end loop; + + -- The construct denotes an entity + + if Is_Entity_Name (Val) and then Present (Entity (Val)) then + Val_Id := Entity (Val); + + -- Do not generate an error message when the comparison is done + -- against the enumeration literal Standard.True. + + if Ekind (Val_Id) /= E_Enumeration_Literal then + + -- Build a customized error message + + Name_Len := 0; + Add_Str_To_Name_Buffer ("?r?"); + + if Ekind (Val_Id) = E_Component then + Add_Str_To_Name_Buffer ("component "); + + elsif Ekind (Val_Id) = E_Constant then + Add_Str_To_Name_Buffer ("constant "); + + elsif Ekind (Val_Id) = E_Discriminant then + Add_Str_To_Name_Buffer ("discriminant "); + + elsif Is_Formal (Val_Id) then + Add_Str_To_Name_Buffer ("parameter "); + + elsif Ekind (Val_Id) = E_Variable then + Add_Str_To_Name_Buffer ("variable "); + end if; + + Add_Str_To_Name_Buffer ("& is always True!"); + Error := Name_Find; + + Error_Msg_NE (Get_Name_String (Error), Val, Val_Id); + end if; + + -- The construct is too complex to disect, issue a general message + + else + Error_Msg_N ("?r?expression is always True!", Val); + end if; + end Explain_Redundancy; + ----------------------------- -- Find_Unique_Access_Type -- ----------------------------- @@ -6835,9 +6931,14 @@ package body Sem_Res is S : Entity_Id; begin - if Ekind (Etype (R)) = E_Allocator_Type then + if Ekind_In (Etype (R), E_Allocator_Type, + E_Access_Attribute_Type) + then Acc := Designated_Type (Etype (R)); - elsif Ekind (Etype (L)) = E_Allocator_Type then + + elsif Ekind_In (Etype (L), E_Allocator_Type, + E_Access_Attribute_Type) + then Acc := Designated_Type (Etype (L)); else return Empty; @@ -6949,12 +7050,13 @@ package body Sem_Res is if Warn_On_Redundant_Constructs and then Comes_From_Source (N) + and then Comes_From_Source (R) and then Is_Entity_Name (R) and then Entity (R) = Standard_True - and then Comes_From_Source (R) then Error_Msg_N -- CODEFIX - ("?r?comparison with True is redundant!", R); + ("?r?comparison with True is redundant!", N); + Explain_Redundancy (Original_Node (R)); end if; Check_Unset_Reference (L); @@ -8776,8 +8878,6 @@ package body Sem_Res is and then Ekind_In (Entity (S), E_Component, E_Discriminant) and then Present (Original_Record_Component (Entity (S))) and then Ekind (Original_Record_Component (Entity (S))) = E_Component - and then Present (Discriminant_Checking_Func - (Original_Record_Component (Entity (S)))) and then not Discriminant_Checks_Suppressed (T) and then not Init_Component then @@ -8880,27 +8980,32 @@ package body Sem_Res is Orig : constant Node_Id := Original_Node (Parent (N)); begin + -- Special handling of Asssert pragma + if Nkind (Orig) = N_Pragma and then Pragma_Name (Orig) = Name_Assert then - -- Don't want to warn if original condition is explicit False - declare Expr : constant Node_Id := Original_Node (Expression (First (Pragma_Argument_Associations (Orig)))); + begin + -- Don't warn if original condition is explicit False, + -- since obviously the failure is expected in this case. + if Is_Entity_Name (Expr) and then Entity (Expr) = Standard_False then null; - else - -- Issue warning. We do not want the deletion of the - -- IF/AND-THEN to take this message with it. We achieve - -- this by making sure that the expanded code points to - -- the Sloc of the expression, not the original pragma. + -- Issue warning. We do not want the deletion of the + -- IF/AND-THEN to take this message with it. We achieve this + -- by making sure that the expanded code points to the Sloc + -- of the expression, not the original pragma. + + else -- Note: Use Error_Msg_F here rather than Error_Msg_N. -- The source location of the expression is not usually -- the best choice here. For example, it gets located on @@ -9737,7 +9842,7 @@ package body Sem_Res is N); else - Expand_Interface_Conversion (N, Is_Static => False); + Expand_Interface_Conversion (N); end if; -- Conversion to interface type @@ -9750,29 +9855,18 @@ package body Sem_Res is Opnd := Etype (Opnd); end if; - if not Interface_Present_In_Ancestor - (Typ => Opnd, - Iface => Target) + if Is_Class_Wide_Type (Opnd) + or else Interface_Present_In_Ancestor + (Typ => Opnd, + Iface => Target) then - if Is_Class_Wide_Type (Opnd) then - - -- The static analysis is not enough to know if the - -- interface is implemented or not. Hence we must pass - -- the work to the expander to generate code to evaluate - -- the conversion at run time. - - Expand_Interface_Conversion (N, Is_Static => False); - - else - Error_Msg_Name_1 := Chars (Etype (Target)); - Error_Msg_Name_2 := Chars (Opnd); - Error_Msg_N - ("wrong interface conversion (% is not a progenitor " & - "of %)", N); - end if; - - else Expand_Interface_Conversion (N); + else + Error_Msg_Name_1 := Chars (Etype (Target)); + Error_Msg_Name_2 := Chars (Opnd); + Error_Msg_N + ("wrong interface conversion (% is not a progenitor " + & "of %)", N); end if; end if; end; @@ -9785,7 +9879,9 @@ package body Sem_Res is if Has_Predicates (Target_Typ) then if Nkind (Parent (N)) = N_Function_Call and then Present (Name (Parent (N))) - and then Has_Predicates (Entity (Name (Parent (N)))) + and then (Is_Predicate_Function (Entity (Name (Parent (N)))) + or else + Is_Predicate_Function_M (Entity (Name (Parent (N))))) then null; @@ -10480,22 +10576,19 @@ package body Sem_Res is Operand : Node_Id; Report_Errs : Boolean := True) return Boolean is - Target_Type : constant Entity_Id := Base_Type (Target); - Opnd_Type : Entity_Id := Etype (Operand); + Target_Type : constant Entity_Id := Base_Type (Target); + Opnd_Type : Entity_Id := Etype (Operand); + Inc_Ancestor : Entity_Id; function Conversion_Check (Valid : Boolean; Msg : String) return Boolean; -- Little routine to post Msg if Valid is False, returns Valid value - -- The following are badly named, this kind of overloading is actively - -- confusing in reading code, please rename to something like - -- Error_Msg_N_If_Reporting ??? - - procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id); + procedure Conversion_Error_N (Msg : String; N : Node_Or_Entity_Id); -- If Report_Errs, then calls Errout.Error_Msg_N with its arguments - procedure Error_Msg_NE + procedure Conversion_Error_NE (Msg : String; N : Node_Or_Entity_Id; E : Node_Or_Entity_Id); @@ -10532,37 +10625,37 @@ package body Sem_Res is and then not In_Instance then - Error_Msg_N (Msg, Operand); + Conversion_Error_N (Msg, Operand); end if; return Valid; end Conversion_Check; - ----------------- - -- Error_Msg_N -- - ----------------- + ------------------------ + -- Conversion_Error_N -- + ------------------------ - procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is + procedure Conversion_Error_N (Msg : String; N : Node_Or_Entity_Id) is begin if Report_Errs then - Errout.Error_Msg_N (Msg, N); + Error_Msg_N (Msg, N); end if; - end Error_Msg_N; + end Conversion_Error_N; - ------------------ - -- Error_Msg_NE -- - ------------------ + ------------------------- + -- Conversion_Error_NE -- + ------------------------- - procedure Error_Msg_NE + procedure Conversion_Error_NE (Msg : String; N : Node_Or_Entity_Id; E : Node_Or_Entity_Id) is begin if Report_Errs then - Errout.Error_Msg_NE (Msg, N, E); + Error_Msg_NE (Msg, N, E); end if; - end Error_Msg_NE; + end Conversion_Error_NE; ---------------------------- -- Valid_Array_Conversion -- @@ -10590,7 +10683,7 @@ package body Sem_Res is if Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type) then - Error_Msg_N + Conversion_Error_N ("incompatible number of dimensions for conversion", Operand); return False; @@ -10612,7 +10705,7 @@ package body Sem_Res is and then (Root_Type (Target_Index_Type) /= Root_Type (Opnd_Index_Type)) then - Error_Msg_N + Conversion_Error_N ("incompatible index types for array conversion", Operand); return False; @@ -10646,10 +10739,10 @@ package body Sem_Res is Deepest_Type_Access_Level (Opnd_Type) then if In_Instance_Body then - Error_Msg_N - ("??source array type has " & - "deeper accessibility level than target", Operand); - Error_Msg_N + Conversion_Error_N + ("??source array type has deeper accessibility " + & "level than target", Operand); + Conversion_Error_N ("\??Program_Error will be raised at run time", Operand); Rewrite (N, @@ -10661,9 +10754,9 @@ package body Sem_Res is -- Conversion not allowed because of accessibility levels else - Error_Msg_N - ("source array type has " & - "deeper accessibility level than target", Operand); + Conversion_Error_N + ("source array type has deeper accessibility " + & "level than target", Operand); return False; end if; @@ -10674,7 +10767,7 @@ package body Sem_Res is -- All other cases where component base types do not match else - Error_Msg_N + Conversion_Error_N ("incompatible component types for array conversion", Operand); return False; @@ -10688,7 +10781,7 @@ package body Sem_Res is if not Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) then - Error_Msg_N + Conversion_Error_N ("component subtypes must statically match", Operand); return False; end if; @@ -10751,7 +10844,7 @@ package body Sem_Res is return True; else - Error_Msg_NE + Conversion_Error_NE ("invalid tagged conversion, not compatible with}", N, First_Subtype (Opnd_Type)); return False; @@ -10818,7 +10911,7 @@ package body Sem_Res is It1 := It; if No (It.Typ) then - Error_Msg_N ("illegal operand in conversion", Operand); + Conversion_Error_N ("illegal operand in conversion", Operand); return False; end if; @@ -10830,7 +10923,8 @@ package body Sem_Res is It1 := Disambiguate (Operand, I1, I, Any_Type); if It1 = No_Interp then - Error_Msg_N ("ambiguous operand in conversion", Operand); + Conversion_Error_N + ("ambiguous operand in conversion", Operand); -- If the interpretation involves a standard operator, use -- the location of the type, which may be user-defined. @@ -10841,7 +10935,7 @@ package body Sem_Res is Error_Msg_Sloc := Sloc (It.Nam); end if; - Error_Msg_N -- CODEFIX + Conversion_Error_N -- CODEFIX ("\\possible interpretation#!", Operand); if Sloc (N1) = Standard_Location then @@ -10850,7 +10944,7 @@ package body Sem_Res is Error_Msg_Sloc := Sloc (N1); end if; - Error_Msg_N -- CODEFIX + Conversion_Error_N -- CODEFIX ("\\possible interpretation#!", Operand); return False; @@ -10862,6 +10956,13 @@ package body Sem_Res is end; end if; + -- If we are within a child unit, check whether the type of the + -- expression has an ancestor in a parent unit, in which case it + -- belongs to its derivation class even if the ancestor is private. + -- See RM 7.3.1 (5.2/3). + + Inc_Ancestor := Get_Incomplete_View_Of_Ancestor (Opnd_Type); + -- Numeric types if Is_Numeric_Type (Target_Type) then @@ -10890,7 +10991,10 @@ package body Sem_Res is else return Conversion_Check - (Is_Numeric_Type (Opnd_Type), + (Is_Numeric_Type (Opnd_Type) + or else + (Present (Inc_Ancestor) + and then Is_Numeric_Type (Inc_Ancestor)), "illegal operand for numeric conversion"); end if; @@ -10901,8 +11005,10 @@ package body Sem_Res is or else Opnd_Type = Any_Composite or else Opnd_Type = Any_String then - Error_Msg_N ("illegal operand for array conversion", Operand); + Conversion_Error_N + ("illegal operand for array conversion", Operand); return False; + else return Valid_Array_Conversion; end if; @@ -10933,14 +11039,14 @@ package body Sem_Res is -- will be generated by Expand_N_Type_Conversion. if In_Instance_Body then - Error_Msg_N + Conversion_Error_N ("??cannot convert local pointer to non-local access type", Operand); - Error_Msg_N + Conversion_Error_N ("\??Program_Error will be raised at run time", Operand); else - Error_Msg_N + Conversion_Error_N ("cannot convert local pointer to non-local access type", Operand); return False; @@ -10966,16 +11072,16 @@ package body Sem_Res is -- will be generated by Expand_N_Type_Conversion. if In_Instance_Body then - Error_Msg_N - ("??cannot convert access discriminant to non-local" & - " access type", Operand); - Error_Msg_N + Conversion_Error_N + ("??cannot convert access discriminant to non-local " + & "access type", Operand); + Conversion_Error_N ("\??Program_Error will be raised at run time", Operand); else - Error_Msg_N - ("cannot convert access discriminant to non-local" & - " access type", Operand); + Conversion_Error_N + ("cannot convert access discriminant to non-local " + & "access type", Operand); return False; end if; end if; @@ -10992,7 +11098,7 @@ package body Sem_Res is Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then - Error_Msg_N + Conversion_Error_N ("discriminant has deeper accessibility level than target", Operand); return False; @@ -11017,7 +11123,7 @@ package body Sem_Res is if Is_Access_Constant (Opnd_Type) and then not Is_Access_Constant (Target_Type) then - Error_Msg_N + Conversion_Error_N ("access-to-constant operand type not allowed", Operand); return False; end if; @@ -11057,9 +11163,9 @@ package body Sem_Res is if Nkind (Associated_Node_For_Itype (Opnd_Type)) = N_Object_Declaration then - Error_Msg_N - ("implicit conversion of stand-alone anonymous " & - "access object not allowed", Operand); + Conversion_Error_N + ("implicit conversion of stand-alone anonymous " + & "access object not allowed", Operand); return False; -- Implicit conversions aren't allowed for anonymous access @@ -11071,9 +11177,9 @@ package body Sem_Res is N_Function_Specification, N_Procedure_Specification) then - Error_Msg_N - ("implicit conversion of anonymous access formal " & - "not allowed", Operand); + Conversion_Error_N + ("implicit conversion of anonymous access formal " + & "not allowed", Operand); return False; -- This is a case where there's an enclosing object whose @@ -11084,9 +11190,9 @@ package body Sem_Res is elsif Object_Access_Level (Operand) = Scope_Depth (Standard_Standard) then - Error_Msg_N - ("implicit conversion of anonymous access value " & - "not allowed", Operand); + Conversion_Error_N + ("implicit conversion of anonymous access value " + & "not allowed", Operand); return False; -- In other cases, the level of the operand's type must be @@ -11096,9 +11202,9 @@ package body Sem_Res is elsif Type_Access_Level (Opnd_Type) > Deepest_Type_Access_Level (Target_Type) then - Error_Msg_N - ("implicit conversion of anonymous access value " & - "violates accessibility", Operand); + Conversion_Error_N + ("implicit conversion of anonymous access value " + & "violates accessibility", Operand); return False; end if; end if; @@ -11111,17 +11217,17 @@ package body Sem_Res is -- will be generated by Expand_N_Type_Conversion. if In_Instance_Body then - Error_Msg_N + Conversion_Error_N ("??cannot convert local pointer to non-local access type", Operand); - Error_Msg_N + Conversion_Error_N ("\??Program_Error will be raised at run time", Operand); else -- Avoid generation of spurious error message if not Error_Posted (N) then - Error_Msg_N + Conversion_Error_N ("cannot convert local pointer to non-local access type", Operand); end if; @@ -11149,17 +11255,17 @@ package body Sem_Res is -- will be generated by Expand_N_Type_Conversion. if In_Instance_Body then - Error_Msg_N - ("??cannot convert access discriminant to non-local" - & " access type", Operand); - Error_Msg_N + Conversion_Error_N + ("??cannot convert access discriminant to non-local " + & "access type", Operand); + Conversion_Error_N ("\??Program_Error will be raised at run time", Operand); else - Error_Msg_N - ("cannot convert access discriminant to non-local" & - " access type", Operand); + Conversion_Error_N + ("cannot convert access discriminant to non-local " + & "access type", Operand); return False; end if; end if; @@ -11175,7 +11281,7 @@ package body Sem_Res is Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then - Error_Msg_N + Conversion_Error_N ("discriminant has deeper accessibility level than target", Operand); return False; @@ -11226,7 +11332,7 @@ package body Sem_Res is else if not Same_Base then - Error_Msg_NE + Conversion_Error_NE ("target designated type not compatible with }", N, Base_Type (Opnd)); return False; @@ -11251,10 +11357,10 @@ package body Sem_Res is and then Known_Static_RM_Size (Opnd) and then RM_Size (Target) /= RM_Size (Opnd) then - Error_Msg_NE + Conversion_Error_NE ("target designated subtype not compatible with }", N, Opnd); - Error_Msg_NE + Conversion_Error_NE ("\because sizes of the two designated subtypes differ", N, Opnd); return False; @@ -11292,12 +11398,12 @@ package body Sem_Res is or else not Is_Entity_Name (Name (Parent (N))) or else not Is_Return_Object (Entity (Name (Parent (N))))) then - Error_Msg_N + Conversion_Error_N ("illegal attempt to store anonymous access to subprogram", Operand); - Error_Msg_N - ("\value has deeper accessibility than any master " & - "(RM 3.10.2 (13))", + Conversion_Error_N + ("\value has deeper accessibility than any master " + & "(RM 3.10.2 (13))", Operand); Error_Msg_NE @@ -11316,7 +11422,7 @@ package body Sem_Res is if Type_Access_Level (Opnd_Type) > Deepest_Type_Access_Level (Target_Type) then - Error_Msg_N + Conversion_Error_N ("operand type has deeper accessibility level than target", Operand); @@ -11338,9 +11444,9 @@ package body Sem_Res is end loop; if T_Gen /= O_Gen then - Error_Msg_N - ("target type must be declared in same generic body" - & " as operand type", N); + Conversion_Error_N + ("target type must be declared in same generic body " + & "as operand type", N); end if; end; end if; @@ -11397,14 +11503,14 @@ package body Sem_Res is elsif Ekind (Target_Type) = E_Access_Type and then Is_Access_Type (Opnd_Type) then - Error_Msg_N ("target type must be general access type!", N); - Error_Msg_NE -- CODEFIX + Conversion_Error_N ("target type must be general access type!", N); + Conversion_Error_NE -- CODEFIX ("add ALL to }!", N, Target_Type); return False; else - Error_Msg_NE ("invalid conversion, not compatible with }", - N, Opnd_Type); + Conversion_Error_NE + ("invalid conversion, not compatible with }", N, Opnd_Type); return False; end if; end Valid_Conversion; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 5f86561b148..78e49224e59 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.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- -- @@ -780,7 +780,7 @@ package body Sem_Type is RA : Entity_Id; begin - -- Retrieve parent subtype from subtype declaration for actual. + -- Retrieve parent subtype from subtype declaration for actual if Nkind (Par) = N_Subtype_Declaration and then not Comes_From_Source (Par) @@ -793,7 +793,7 @@ package body Sem_Type is end if; end if; - -- Otherwise actual is not the actual of an enclosing instance. + -- Otherwise actual is not the actual of an enclosing instance return T; end Real_Actual; @@ -1313,7 +1313,7 @@ package body Sem_Type is -- Determine whether a subprogram is an actual in an enclosing instance. -- An overloading between such a subprogram and one declared outside the -- instance is resolved in favor of the first, because it resolved in - -- the generic. Within the instance the eactual is represented by a + -- the generic. Within the instance the actual is represented by a -- constructed subprogram renaming. function Matches (Actual, Formal : Node_Id) return Boolean; @@ -2028,7 +2028,7 @@ package body Sem_Type is elsif (Nkind (N) = N_Function_Call and then Nkind (Name (N)) = N_Expanded_Name and then (Chars (Predef_Subp) /= Name_Op_Expon - or else Hides_Op (User_Subp, Predef_Subp)) + or else Hides_Op (User_Subp, Predef_Subp)) and then Scope (User_Subp) = Entity (Prefix (Name (N)))) or else Hides_Op (User_Subp, Predef_Subp) then @@ -2048,8 +2048,8 @@ package body Sem_Type is -- Ditto in Ada 2012, where an ambiguity may arise for an operation -- on a partial view that is completed with a fixed point type. See -- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the - -- user-defined subprogram so that a client of the package has the - -- same resulution as the body of the package. + -- user-defined type and subprogram, so that a client of the package + -- has the same resolution as the body of the package. else if (In_Open_Scopes (Scope (User_Subp)) @@ -2057,15 +2057,13 @@ package body Sem_Type is and then not In_Instance then if Is_Fixed_Point_Type (Typ) - and then (Chars (Nam1) = Name_Op_Multiply - or else Chars (Nam1) = Name_Op_Divide) + and then Nam_In (Chars (Nam1), Name_Op_Multiply, Name_Op_Divide) and then (Ada_Version = Ada_83 - or else - (Ada_Version >= Ada_2012 - and then - In_Same_Declaration_List - (Typ, Unit_Declaration_Node (User_Subp)))) + or else (Ada_Version >= Ada_2012 + and then In_Same_Declaration_List + (First_Subtype (Typ), + Unit_Declaration_Node (User_Subp)))) then if It2.Nam = Predef_Subp then return It1; @@ -2079,9 +2077,7 @@ package body Sem_Type is -- declared in the same declarative list as the type. The node -- may be an operator or a function call. - elsif (Chars (Nam1) = Name_Op_Eq - or else - Chars (Nam1) = Name_Op_Ne) + elsif Nam_In (Chars (Nam1), Name_Op_Eq, Name_Op_Ne) and then Ada_Version >= Ada_2005 and then Etype (User_Subp) = Standard_Boolean and then Ekind (Operand_Type) = E_Anonymous_Access_Type @@ -3059,10 +3055,7 @@ package body Sem_Type is elsif Num = 1 then T1 := Etype (First_Formal (New_S)); - if Op_Name = Name_Op_Subtract - or else Op_Name = Name_Op_Add - or else Op_Name = Name_Op_Abs - then + if Nam_In (Op_Name, Name_Op_Subtract, Name_Op_Add, Name_Op_Abs) then return Base_Type (T1) = Base_Type (T) and then Is_Numeric_Type (T); @@ -3080,26 +3073,24 @@ package body Sem_Type is T1 := Etype (First_Formal (New_S)); T2 := Etype (Next_Formal (First_Formal (New_S))); - if Op_Name = Name_Op_And or else Op_Name = Name_Op_Or - or else Op_Name = Name_Op_Xor - then + if Nam_In (Op_Name, Name_Op_And, Name_Op_Or, Name_Op_Xor) then return Base_Type (T1) = Base_Type (T2) and then Base_Type (T1) = Base_Type (T) and then Valid_Boolean_Arg (Base_Type (T)); - elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then + elsif Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) then return Base_Type (T1) = Base_Type (T2) and then not Is_Limited_Type (T1) and then Is_Boolean_Type (T); - elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le - or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge + elsif Nam_In (Op_Name, Name_Op_Lt, Name_Op_Le, + Name_Op_Gt, Name_Op_Ge) then return Base_Type (T1) = Base_Type (T2) and then Valid_Comparison_Arg (T1) and then Is_Boolean_Type (T); - elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then + elsif Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then return Base_Type (T1) = Base_Type (T2) and then Base_Type (T1) = Base_Type (T) and then Is_Numeric_Type (T); @@ -3152,7 +3143,7 @@ package body Sem_Type is and then Is_Floating_Point_Type (T2) and then Base_Type (T2) = Base_Type (T)); - elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then + elsif Nam_In (Op_Name, Name_Op_Mod, Name_Op_Rem) then return Base_Type (T1) = Base_Type (T2) and then Base_Type (T1) = Base_Type (T) and then Is_Integer_Type (T); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ae6fe607c88..c914703f894 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -83,7 +83,7 @@ package body Sem_Util is NCT_Hash_Tables_Used : Boolean := False; -- Set to True if hash tables are in use - NCT_Table_Entries : Nat; + NCT_Table_Entries : Nat := 0; -- Count entries in table to see if threshold is reached NCT_Hash_Table_Setup : Boolean := False; @@ -208,6 +208,43 @@ package body Sem_Util is Append_Elmt (A, L); end Add_Access_Type_To_Process; + ----------------------- + -- Add_Contract_Item -- + ----------------------- + + procedure Add_Contract_Item (Item : Node_Id; Subp_Id : Entity_Id) is + Items : constant Node_Id := Contract (Subp_Id); + Nam : Name_Id; + + begin + if Present (Items) and then Nkind (Item) = N_Pragma then + Nam := Pragma_Name (Item); + + if Nam_In (Nam, Name_Precondition, Name_Postcondition) then + Set_Next_Pragma (Item, Pre_Post_Conditions (Items)); + Set_Pre_Post_Conditions (Items, Item); + + 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); + + elsif Nam_In (Nam, Name_Depends, Name_Global) then + Set_Next_Pragma (Item, Classifications (Items)); + Set_Classifications (Items, Item); + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + + -- The subprogram has not been properly decorated or the item is illegal + + else + raise Program_Error; + end if; + end Add_Contract_Item; + ---------------------------- -- Add_Global_Declaration -- ---------------------------- @@ -412,9 +449,10 @@ package body Sem_Util is -------------------------------- procedure Bad_Predicated_Subtype_Use - (Msg : String; - N : Node_Id; - Typ : Entity_Id) + (Msg : String; + N : Node_Id; + Typ : Entity_Id; + Suggest_Static : Boolean := False) is begin if Has_Predicates (Typ) then @@ -428,6 +466,13 @@ package body Sem_Util is else Error_Msg_FE (Msg, N, Typ); end if; + + -- Emit an optional suggestion on how to remedy the error if the + -- context warrants it. + + if Suggest_Static and then Present (Static_Predicate (Typ)) then + Error_Msg_FE ("\predicate of & should be marked static", N, Typ); + end if; end if; end Bad_Predicated_Subtype_Use; @@ -1220,6 +1265,114 @@ package body Sem_Util is end if; end Cannot_Raise_Constraint_Error; + ----------------------------------------- + -- Check_Dynamically_Tagged_Expression -- + ----------------------------------------- + + procedure Check_Dynamically_Tagged_Expression + (Expr : Node_Id; + Typ : Entity_Id; + Related_Nod : Node_Id) + is + begin + pragma Assert (Is_Tagged_Type (Typ)); + + -- In order to avoid spurious errors when analyzing the expanded code, + -- this check is done only for nodes that come from source and for + -- actuals of generic instantiations. + + if (Comes_From_Source (Related_Nod) + or else In_Generic_Actual (Expr)) + and then (Is_Class_Wide_Type (Etype (Expr)) + or else Is_Dynamically_Tagged (Expr)) + and then Is_Tagged_Type (Typ) + and then not Is_Class_Wide_Type (Typ) + then + Error_Msg_N ("dynamically tagged expression not allowed!", Expr); + end if; + end Check_Dynamically_Tagged_Expression; + + ----------------------------------------------- + -- Check_Expression_Against_Static_Predicate -- + ----------------------------------------------- + + procedure Check_Expression_Against_Static_Predicate + (Expr : Node_Id; + Typ : Entity_Id) + is + begin + -- When the predicate is static and the value of the expression is known + -- at compile time, evaluate the predicate check. A type is non-static + -- when it has aspect Dynamic_Predicate. + + if Compile_Time_Known_Value (Expr) + and then Has_Predicates (Typ) + and then Present (Static_Predicate (Typ)) + and then not Has_Dynamic_Predicate_Aspect (Typ) + then + -- Either -gnatc is enabled or the expression is ok + + if Operating_Mode < Generate_Code + or else Eval_Static_Predicate_Check (Expr, Typ) + then + null; + + -- The expression is prohibited by the static predicate + + else + Error_Msg_NE + ("?static expression fails static predicate check on &", + Expr, Typ); + end if; + end if; + end Check_Expression_Against_Static_Predicate; + + -------------------------- + -- Check_Fully_Declared -- + -------------------------- + + procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is + begin + if Ekind (T) = E_Incomplete_Type then + + -- 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) + and then Present (Non_Limited_View (T)) + and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type + then + -- The non-limited view is fully declared + null; + + else + Error_Msg_NE + ("premature usage of incomplete}", N, First_Subtype (T)); + end if; + + -- Need comments for these tests ??? + + elsif Has_Private_Component (T) + and then not Is_Generic_Type (Root_Type (T)) + and then not In_Spec_Expression + then + -- Special case: if T is the anonymous type created for a single + -- task or protected object, use the name of the source object. + + if Is_Concurrent_Type (T) + and then not Comes_From_Source (T) + and then Nkind (N) = N_Object_Declaration + then + Error_Msg_NE ("type of& has incomplete component", N, + Defining_Identifier (N)); + + else + Error_Msg_NE + ("premature usage of incomplete}", N, First_Subtype (T)); + end if; + end if; + end Check_Fully_Declared; + ------------------------------------- -- Check_Function_Writable_Actuals -- ------------------------------------- @@ -1971,79 +2124,6 @@ package body Sem_Util is end loop Outer; end Check_Later_Vs_Basic_Declarations; - ----------------------------------------- - -- Check_Dynamically_Tagged_Expression -- - ----------------------------------------- - - procedure Check_Dynamically_Tagged_Expression - (Expr : Node_Id; - Typ : Entity_Id; - Related_Nod : Node_Id) - is - begin - pragma Assert (Is_Tagged_Type (Typ)); - - -- In order to avoid spurious errors when analyzing the expanded code, - -- this check is done only for nodes that come from source and for - -- actuals of generic instantiations. - - if (Comes_From_Source (Related_Nod) - or else In_Generic_Actual (Expr)) - and then (Is_Class_Wide_Type (Etype (Expr)) - or else Is_Dynamically_Tagged (Expr)) - and then Is_Tagged_Type (Typ) - and then not Is_Class_Wide_Type (Typ) - then - Error_Msg_N ("dynamically tagged expression not allowed!", Expr); - end if; - end Check_Dynamically_Tagged_Expression; - - -------------------------- - -- Check_Fully_Declared -- - -------------------------- - - procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is - begin - if Ekind (T) = E_Incomplete_Type then - - -- 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) - and then Present (Non_Limited_View (T)) - and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type - then - -- The non-limited view is fully declared - null; - - else - Error_Msg_NE - ("premature usage of incomplete}", N, First_Subtype (T)); - end if; - - -- Need comments for these tests ??? - - elsif Has_Private_Component (T) - and then not Is_Generic_Type (Root_Type (T)) - and then not In_Spec_Expression - then - -- Special case: if T is the anonymous type created for a single - -- task or protected object, use the name of the source object. - - if Is_Concurrent_Type (T) - and then not Comes_From_Source (T) - and then Nkind (N) = N_Object_Declaration - then - Error_Msg_NE ("type of& has incomplete component", N, - Defining_Identifier (N)); - - else - Error_Msg_NE - ("premature usage of incomplete}", N, First_Subtype (T)); - end if; - end if; - end Check_Fully_Declared; - ------------------------- -- Check_Nested_Access -- ------------------------- @@ -2088,6 +2168,97 @@ package body Sem_Util is end if; end Check_Nested_Access; + --------------------------- + -- Check_No_Hidden_State -- + --------------------------- + + procedure Check_No_Hidden_State (Id : Entity_Id) is + function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean; + -- Determine whether the entity of a package denoted by Pkg has a null + -- abstract state. + + ----------------------------- + -- Has_Null_Abstract_State -- + ----------------------------- + + function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is + States : constant Elist_Id := Abstract_States (Pkg); + + begin + -- Check first available state of related package. A null abstract + -- state always appears as the sole element of the state list. + + return + Present (States) + and then Is_Null_State (Node (First_Elmt (States))); + end Has_Null_Abstract_State; + + -- Local variables + + Context : Entity_Id := Empty; + Not_Visible : Boolean := False; + Scop : Entity_Id; + + -- Start of processing for Check_No_Hidden_State + + begin + pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); + + -- Find the proper context where the object or state appears + + Scop := Scope (Id); + while Present (Scop) loop + Context := Scop; + + -- Keep track of the context's visibility + + Not_Visible := Not_Visible or else In_Private_Part (Context); + + -- Prevent the search from going too far + + if Context = Standard_Standard then + return; + + -- Objects and states that appear immediately within a subprogram or + -- inside a construct nested within a subprogram do not introduce a + -- hidden state. They behave as local variable declarations. + + elsif Is_Subprogram (Context) then + return; + + -- When examining a package body, use the entity of the spec as it + -- carries the abstract state declarations. + + elsif Ekind (Context) = E_Package_Body then + Context := Spec_Entity (Context); + end if; + + -- Stop the traversal when a package subject to a null abstract state + -- has been found. + + if Ekind_In (Context, E_Generic_Package, E_Package) + and then Has_Null_Abstract_State (Context) + then + exit; + end if; + + Scop := Scope (Scop); + end loop; + + -- At this point we know that there is at least one package with a null + -- abstract state in visibility. Emit an error message unconditionally + -- if the entity being processed is a state because the placement of the + -- related package is irrelevant. This is not the case for objects as + -- the intermediate context matters. + + if Present (Context) + and then (Ekind (Id) = E_Abstract_State or else Not_Visible) + then + Error_Msg_N ("cannot introduce hidden state &", Id); + Error_Msg_NE ("\package & has null abstract state", Id, Context); + end if; + end Check_No_Hidden_State; + ------------------------------------------ -- Check_Potentially_Blocking_Operation -- ------------------------------------------ @@ -4703,6 +4874,41 @@ package body Sem_Util is raise Program_Error; end Find_Corresponding_Discriminant; + ------------------------------------ + -- Find_Loop_In_Conditional_Block -- + ------------------------------------ + + function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is + Stmt : Node_Id; + + begin + Stmt := N; + + if Nkind (Stmt) = N_If_Statement then + Stmt := First (Then_Statements (Stmt)); + end if; + + pragma Assert (Nkind (Stmt) = N_Block_Statement); + + -- Inspect the statements of the conditional block. In general the loop + -- should be the first statement in the statement sequence of the block, + -- but the finalization machinery may have introduced extra object + -- declarations. + + Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); + while Present (Stmt) loop + if Nkind (Stmt) = N_Loop_Statement then + return Stmt; + end if; + + Next (Stmt); + end loop; + + -- The expansion of attribute 'Loop_Entry produced a malformed block + + raise Program_Error; + end Find_Loop_In_Conditional_Block; + -------------------------- -- Find_Overlaid_Entity -- -------------------------- @@ -5380,6 +5586,55 @@ package body Sem_Util is end if; end Get_Generic_Entity; + ------------------------------------- + -- Get_Incomplete_View_Of_Ancestor -- + ------------------------------------- + + function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is + Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + Par_Scope : Entity_Id; + Par_Type : Entity_Id; + + begin + -- The incomplete view of an ancestor is only relevant for private + -- derived types in child units. + + if not Is_Derived_Type (E) + or else not Is_Child_Unit (Cur_Unit) + then + return Empty; + + else + Par_Scope := Scope (Cur_Unit); + if No (Par_Scope) then + return Empty; + end if; + + Par_Type := Etype (Base_Type (E)); + + -- Traverse list of ancestor types until we find one declared in + -- a parent or grandparent unit (two levels seem sufficient). + + while Present (Par_Type) loop + if Scope (Par_Type) = Par_Scope + or else Scope (Par_Type) = Scope (Par_Scope) + then + return Par_Type; + + elsif not Is_Derived_Type (Par_Type) then + return Empty; + + else + Par_Type := Etype (Base_Type (Par_Type)); + end if; + end loop; + + -- If none found, there is no relevant ancestor type. + + return Empty; + end if; + end Get_Incomplete_View_Of_Ancestor; + ---------------------- -- Get_Index_Bounds -- ---------------------- @@ -5563,49 +5818,58 @@ package body Sem_Util is --------------------------- function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is - Nam : Node_Id; - Proc : Entity_Id; + Subp : Node_Id; + Subp_Id : Entity_Id; begin if Nkind (Nod) = N_Accept_Statement then - Nam := Entry_Direct_Name (Nod); + Subp := Entry_Direct_Name (Nod); + + elsif Nkind (Nod) = N_Slice then + Subp := Prefix (Nod); + + else + Subp := Name (Nod); + end if; + + -- Strip the subprogram call + + loop + if Nkind_In (Subp, N_Explicit_Dereference, + N_Indexed_Component, + N_Selected_Component) + then + Subp := Prefix (Subp); - -- For an entry call, the prefix of the call is a selected component. - -- Need additional code for internal calls ??? + elsif Nkind_In (Subp, N_Type_Conversion, + N_Unchecked_Type_Conversion) + then + Subp := Expression (Subp); - elsif Nkind (Nod) = N_Entry_Call_Statement then - if Nkind (Name (Nod)) = N_Selected_Component then - Nam := Entity (Selector_Name (Name (Nod))); else - Nam := Empty; + exit; end if; + end loop; - else - Nam := Name (Nod); - end if; + -- Extract the entity of the subprogram call - if Nkind (Nam) = N_Explicit_Dereference then - Proc := Etype (Prefix (Nam)); - elsif Is_Entity_Name (Nam) then - Proc := Entity (Nam); - else - return Empty; - end if; + if Is_Entity_Name (Subp) then + Subp_Id := Entity (Subp); - if Is_Object (Proc) then - Proc := Etype (Proc); - end if; + if Ekind (Subp_Id) = E_Access_Subprogram_Type then + Subp_Id := Directly_Designated_Type (Subp_Id); + end if; - if Ekind (Proc) = E_Access_Subprogram_Type then - Proc := Directly_Designated_Type (Proc); - end if; + if Is_Subprogram (Subp_Id) then + return Subp_Id; + else + return Empty; + end if; + + -- The search did not find a construct that denotes a subprogram - if not Is_Subprogram (Proc) - and then Ekind (Proc) /= E_Subprogram_Type - then - return Empty; else - return Proc; + return Empty; end if; end Get_Subprogram_Entity; @@ -7665,6 +7929,20 @@ package body Sem_Util is end if; end Is_Atomic_Object; + ------------------------------------ + -- Is_Body_Or_Package_Declaration -- + ------------------------------------ + + function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is + begin + return Nkind_In (N, N_Entry_Body, + N_Package_Body, + N_Package_Declaration, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body); + end Is_Body_Or_Package_Declaration; + ----------------------- -- Is_Bounded_String -- ----------------------- @@ -7698,6 +7976,29 @@ package body Sem_Util is or else Is_Task_Interface (T)); end Is_Concurrent_Interface; + ----------------------- + -- Is_Constant_Bound -- + ----------------------- + + function Is_Constant_Bound (Exp : Node_Id) return Boolean is + begin + if Compile_Time_Known_Value (Exp) then + return True; + + elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then + return Is_Constant_Object (Entity (Exp)) + or else Ekind (Entity (Exp)) = E_Enumeration_Literal; + + elsif Nkind (Exp) in N_Binary_Op then + return Is_Constant_Bound (Left_Opnd (Exp)) + and then Is_Constant_Bound (Right_Opnd (Exp)) + and then Scope (Entity (Exp)) = Standard_Standard; + + else + return False; + end if; + end Is_Constant_Bound; + -------------------------------------- -- Is_Controlling_Limited_Procedure -- -------------------------------------- @@ -7885,7 +8186,7 @@ package body Sem_Util is -- designated object is known to be constrained. if Ekind (Prefix_Type) = E_Access_Type - and then not Effectively_Has_Constrained_Partial_View + and then not Object_Type_Has_Constrained_Partial_View (Typ => Designated_Type (Prefix_Type), Scop => Current_Scope) then @@ -7922,10 +8223,20 @@ package body Sem_Util is then return True; + -- If the prefix is of an access type at this point, then we want + -- to return False, rather than calling this function recursively + -- on the access object (which itself might be a discriminant- + -- dependent component of some other object, but that isn't + -- relevant to checking the object passed to us). This avoids + -- issuing wrong errors when compiling with -gnatc, where there + -- can be implicit dereferences that have not been expanded. + + elsif Is_Access_Type (Etype (Prefix (Object))) then + return False; + else return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object)); - end if; elsif Nkind (Object) = N_Indexed_Component @@ -8027,19 +8338,25 @@ package body Sem_Util is ---------------------------- function Is_Expression_Function (Subp : Entity_Id) return Boolean is - Decl : constant Node_Id := Unit_Declaration_Node (Subp); + Decl : Node_Id; begin - return Ekind (Subp) = E_Function - and then Nkind (Decl) = N_Subprogram_Declaration - and then - (Nkind (Original_Node (Decl)) = N_Expression_Function - or else - (Present (Corresponding_Body (Decl)) - and then - Nkind (Original_Node - (Unit_Declaration_Node (Corresponding_Body (Decl)))) - = N_Expression_Function)); + if Ekind (Subp) /= E_Function then + return False; + + else + Decl := Unit_Declaration_Node (Subp); + return Nkind (Decl) = N_Subprogram_Declaration + and then + (Nkind (Original_Node (Decl)) = N_Expression_Function + or else + (Present (Corresponding_Body (Decl)) + and then + Nkind (Original_Node + (Unit_Declaration_Node + (Corresponding_Body (Decl)))) = + N_Expression_Function)); + end if; end Is_Expression_Function; -------------- @@ -8367,8 +8684,10 @@ package body Sem_Util is Typ : Entity_Id) return Boolean is begin + -- Check that the operation has been created by the type declaration + return Is_Inherited_Operation (E) - and then Etype (Parent (E)) = Typ; + and then Defining_Identifier (Parent (E)) = Typ; end Is_Inherited_Operation_For_Type; ----------------- @@ -8383,9 +8702,8 @@ package body Sem_Util is begin if Is_Class_Wide_Type (Typ) and then - (Chars (Etype (Typ)) = Name_Forward_Iterator - or else - Chars (Etype (Typ)) = Name_Reversible_Iterator) + Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator, + Name_Reversible_Iterator) and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) @@ -8469,7 +8787,7 @@ package body Sem_Util is begin return Is_Class_Wide_Type (Typ) - and then Is_Limited_Type (Typ); + and then (Is_Limited_Type (Typ) or else From_With_Type (Typ)); end Is_Limited_Class_Wide_Type; --------------------------------- @@ -8548,9 +8866,7 @@ package body Sem_Util is -- Attributes 'Input and 'Result produce objects when N_Attribute_Reference => - return Attribute_Name (N) = Name_Input - or else - Attribute_Name (N) = Name_Result; + return Nam_In (Attribute_Name (N), Name_Input, Name_Result); when N_Selected_Component => return @@ -8610,10 +8926,10 @@ package body Sem_Util is begin Note_Possible_Modification (AV, Sure => True); - -- We must reject parenthesized variable names. The check for - -- Comes_From_Source is present because there are currently - -- cases where the compiler violates this rule (e.g. passing - -- a task object to its controlled Initialize routine). + -- We must reject parenthesized variable names. Comes_From_Source is + -- checked because there are currently cases where the compiler violates + -- this rule (e.g. passing a task object to its controlled Initialize + -- routine). This should be properly documented in sinfo??? if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then return False; @@ -8626,12 +8942,13 @@ package body Sem_Util is -- Unchecked conversions are allowed only if they come from the -- generated code, which sometimes uses unchecked conversions for out -- parameters in cases where code generation is unaffected. We tell - -- source unchecked conversions by seeing if they are rewrites of an - -- original Unchecked_Conversion function call, or of an explicit - -- conversion of a function call. + -- source unchecked conversions by seeing if they are rewrites of + -- an original Unchecked_Conversion function call, or of an explicit + -- conversion of a function call or an aggregate (as may happen in the + -- expansion of a packed array aggregate). elsif Nkind (AV) = N_Unchecked_Type_Conversion then - if Nkind (Original_Node (AV)) = N_Function_Call then + if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then return False; elsif Comes_From_Source (AV) @@ -9432,6 +9749,69 @@ package body Sem_Util is and then Get_Name_String (Chars (T)) = "valuetype"; end Is_Value_Type; + ---------------------------- + -- Is_Variable_Size_Array -- + ---------------------------- + + function Is_Variable_Size_Array (E : Entity_Id) return Boolean is + Idx : Node_Id; + + begin + pragma Assert (Is_Array_Type (E)); + + -- Check if some index is initialized with a non-constant value + + Idx := First_Index (E); + while Present (Idx) loop + if Nkind (Idx) = N_Range then + if not Is_Constant_Bound (Low_Bound (Idx)) + or else not Is_Constant_Bound (High_Bound (Idx)) + then + return True; + end if; + end if; + + Idx := Next_Index (Idx); + end loop; + + return False; + end Is_Variable_Size_Array; + + ----------------------------- + -- Is_Variable_Size_Record -- + ----------------------------- + + function Is_Variable_Size_Record (E : Entity_Id) return Boolean is + Comp : Entity_Id; + Comp_Typ : Entity_Id; + + begin + pragma Assert (Is_Record_Type (E)); + + Comp := First_Entity (E); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + -- Recursive call if the record type has discriminants + + if Is_Record_Type (Comp_Typ) + and then Has_Discriminants (Comp_Typ) + and then Is_Variable_Size_Record (Comp_Typ) + then + return True; + + elsif Is_Array_Type (Comp_Typ) + and then Is_Variable_Size_Array (Comp_Typ) + then + return True; + end if; + + Next_Entity (Comp); + end loop; + + return False; + end Is_Variable_Size_Record; + --------------------- -- Is_VMS_Operator -- --------------------- @@ -9445,11 +9825,10 @@ package body Sem_Util is return Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) and then - ((Present_System_Aux - and then Scope (Op) = System_Aux_Id) - or else - (True_VMS_Target - and then Scope (Scope (Op)) = RTU_Entity (System))); + ((Present_System_Aux and then Scope (Op) = System_Aux_Id) + or else + (True_VMS_Target + and then Scope (Scope (Op)) = RTU_Entity (System))); end Is_VMS_Operator; ----------------- @@ -11831,8 +12210,8 @@ package body Sem_Util is -- In formal verification mode, keep track of all reads and -- writes through explicit dereferences. - if Alfa_Mode then - Alfa.Generate_Dereference (N, 'm'); + if SPARK_Mode then + SPARK_Specific.Generate_Dereference (N, 'm'); end if; if Nkind (P) = N_Selected_Component @@ -11928,7 +12307,7 @@ 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 Alfa_Mode then + if Modification_Comes_From_Source or else SPARK_Mode then Generate_Reference (Ent, Exp, 'm'); -- If the target of the assignment is the bound variable @@ -12009,7 +12388,7 @@ package body Sem_Util is function Is_Interface_Conversion (N : Node_Id) return Boolean; -- Determine whether N is a construct of the form -- Some_Type (Operand._tag'Address) - -- This construct appears in the context of dispatching calls + -- This construct appears in the context of dispatching calls. function Reference_To (Obj : Node_Id) return Node_Id; -- An explicit dereference is created when removing side-effects from @@ -12621,6 +13000,43 @@ package body Sem_Util is Set_Sloc (Endl, Loc); end Process_End_Label; + ---------------- + -- Referenced -- + ---------------- + + function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is + Seen : Boolean := False; + + function Is_Reference (N : Node_Id) return Traverse_Result; + -- Determine whether node N denotes a reference to Id. If this is the + -- case, set global flag Seen to True and stop the traversal. + + ------------------ + -- Is_Reference -- + ------------------ + + function Is_Reference (N : Node_Id) return Traverse_Result is + begin + if Is_Entity_Name (N) + and then Present (Entity (N)) + and then Entity (N) = Id + then + Seen := True; + return Abandon; + else + return OK; + end if; + end Is_Reference; + + procedure Inspect_Expression is new Traverse_Proc (Is_Reference); + + -- Start of processing for Referenced + + begin + Inspect_Expression (Expr); + return Seen; + end Referenced; + ------------------------------------ -- References_Generic_Formal_Type -- ------------------------------------ @@ -12984,6 +13400,19 @@ package body Sem_Util is else Desc := P; P := Parent (P); + + -- A special Ada 2012 case: the original node may be part + -- of the else_actions of a conditional expression, in which + -- case it might not have been expanded yet, and appears in + -- a non-syntactic list of actions. In that case it is clearly + -- not safe to save a value. + + if No (P) + and then Is_List_Member (Desc) + and then No (Parent (List_Containing (Desc))) + then + return False; + end if; end if; end loop; end; @@ -13357,9 +13786,10 @@ package body Sem_Util is -- the entities within it). if (Is_Implementation_Defined (Val) - and then not (Ekind_In (Val, E_Package, E_Generic_Package) - and then Is_Library_Level_Entity (Val))) - or else Is_Implementation_Defined (Scope (Val)) + or else + Is_Implementation_Defined (Scope (Val))) + and then not (Ekind_In (Val, E_Package, E_Generic_Package) + and then Is_Library_Level_Entity (Val)) then Check_Restriction (No_Implementation_Identifiers, N); end if; @@ -13657,6 +14087,33 @@ package body Sem_Util is and then not Is_Formal (Entity (R2)); end Statically_Different; + -------------------------------------- + -- Subject_To_Loop_Entry_Attributes -- + -------------------------------------- + + function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is + Stmt : Node_Id; + + begin + Stmt := N; + + -- The expansion mechanism transform a loop subject to at least one + -- 'Loop_Entry attribute into a conditional block. Infinite loops lack + -- the conditional part. + + if Nkind_In (Stmt, N_Block_Statement, N_If_Statement) + and then Nkind (Original_Node (N)) = N_Loop_Statement + then + Stmt := Original_Node (N); + end if; + + return + Nkind (Stmt) = N_Loop_Statement + and then Present (Identifier (Stmt)) + and then Present (Entity (Identifier (Stmt))) + and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); + end Subject_To_Loop_Entry_Attributes; + ----------------------------- -- Subprogram_Access_Level -- ----------------------------- @@ -14359,9 +14816,7 @@ package body Sem_Util is return False; elsif not Ekind_In (E, E_Discriminant, E_Component) - or else (Chars (E) = Name_uTag - or else - Chars (E) = Name_uParent) + or else Nam_In (Chars (E), Name_uTag, Name_uParent) then Next_Entity (E); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 0a9ff0af8f5..7ea5657aa2b 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -43,6 +43,11 @@ 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_Global_Declaration (N : Node_Id); -- These procedures adds a declaration N at the library level, to be -- elaborated before any other code in the unit. It is used for example @@ -117,19 +122,21 @@ package Sem_Util is -- is an error. procedure Bad_Predicated_Subtype_Use - (Msg : String; - N : Node_Id; - Typ : Entity_Id); + (Msg : String; + N : Node_Id; + Typ : Entity_Id; + Suggest_Static : Boolean := False); -- This is called when Typ, a predicated subtype, is used in a context - -- which does not allow the use of a predicated subtype. Msg is passed - -- to Error_Msg_FE to output an appropriate message using N as the - -- location, and Typ as the entity. The caller must set up any insertions - -- other than the & for the type itself. Note that if Typ is a generic - -- actual type, then the message will be output as a warning, and a - -- raise Program_Error is inserted using Insert_Action with node N as - -- the insertion point. Node N also supplies the source location for - -- construction of the raise node. If Typ is NOT a type with predicates - -- this call has no effect. + -- which does not allow the use of a predicated subtype. Msg is passed to + -- Error_Msg_FE to output an appropriate message using N as the location, + -- and Typ as the entity. The caller must set up any insertions other than + -- the & for the type itself. Note that if Typ is a generic actual type, + -- then the message will be output as a warning, and a raise Program_Error + -- is inserted using Insert_Action with node N as the insertion point. Node + -- N also supplies the source location for construction of the raise node. + -- If Typ does not have any predicates, the call has no effect. Set flag + -- Suggest_Static when the context warrants an advice on how to avoid the + -- use error. function Build_Actual_Subtype (T : Entity_Id; @@ -163,14 +170,14 @@ package Sem_Util is -- the compilation unit, and install it in the Elaboration_Entity field -- of Spec_Id, the entity for the compilation unit. - procedure Build_Explicit_Dereference - (Expr : Node_Id; - Disc : Entity_Id); - -- AI05-139: Names with implicit dereference. If the expression N is a - -- reference type and the context imposes the corresponding designated - -- type, convert N into N.Disc.all. Such expressions are always over- - -- loaded with both interpretations, and the dereference interpretation - -- carries the name of the reference discriminant. + procedure Build_Explicit_Dereference + (Expr : Node_Id; + Disc : Entity_Id); + -- AI05-139: Names with implicit dereference. If the expression N is a + -- reference type and the context imposes the corresponding designated + -- type, convert N into N.Disc.all. Such expressions are always over- + -- loaded with both interpretations, and the dereference interpretation + -- carries the name of the reference discriminant. function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean; -- Returns True if the expression cannot possibly raise Constraint_Error. @@ -178,6 +185,25 @@ package Sem_Util is -- not necessarily mean that CE could be raised, but a response of True -- means that for sure CE cannot be raised. + procedure Check_Dynamically_Tagged_Expression + (Expr : Node_Id; + Typ : Entity_Id; + Related_Nod : Node_Id); + -- Check wrong use of dynamically tagged expression + + procedure Check_Expression_Against_Static_Predicate + (Expr : Node_Id; + Typ : Entity_Id); + -- Determine whether an arbitrary expression satisfies the static predicate + -- of a type. The routine does nothing if Expr is not known at compile time + -- or Typ lacks a static predicate, otherwise it may emit a warning if the + -- expression is prohibited by the predicate. + + procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id); + -- Verify that the full declaration of type T has been seen. If not, place + -- error message on node N. Used in object declarations, type conversions + -- and qualified expressions. + procedure Check_Function_Writable_Actuals (N : Node_Id); -- (Ada 2012): If the construct N has two or more direct constituents that -- are names or expressions whose evaluation may occur in an arbitrary @@ -210,22 +236,15 @@ package Sem_Util is -- remains in the Examiner (JB01-005). Note that the Examiner does not -- count package declarations in later declarative items. - procedure Check_Dynamically_Tagged_Expression - (Expr : Node_Id; - Typ : Entity_Id; - Related_Nod : Node_Id); - -- Check wrong use of dynamically tagged expression - - procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id); - -- Verify that the full declaration of type T has been seen. If not, place - -- error message on node N. Used in object declarations, type conversions - -- and qualified expressions. - procedure Check_Nested_Access (Ent : Entity_Id); -- Check whether Ent denotes an entity declared in an uplevel scope, which -- is accessed inside a nested procedure, and set Has_Up_Level_Access flag -- accordingly. This is currently only enabled for VM_Target /= No_VM. + procedure Check_No_Hidden_State (Id : Entity_Id); + -- Determine whether object or state Id introduces a hidden state. If this + -- is the case, emit an error. + procedure Check_Potentially_Blocking_Operation (N : Node_Id); -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. @@ -469,8 +488,13 @@ package Sem_Util is -- analyzed. Subsequent uses of this id on a different type denotes the -- discriminant at the same position in this new type. + function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id; + -- Find the nested loop statement in a conditional block. Loops subject to + -- attribute 'Loop_Entry are transformed into blocks. Parts of the original + -- loop are nested within the block. + procedure Find_Overlaid_Entity - (N : Node_Id; + (N : Node_Id; Ent : out Entity_Id; Off : out Boolean); -- The node N should be an address representation clause. Determines if @@ -575,13 +599,19 @@ package Sem_Util is -- Otherwise return Empty. Expression N should have been resolved already. function Get_Ensures_From_CTC_Pragma (N : Node_Id) return Node_Id; - -- Return the Ensures component of Contract_Case or Test_Case pragma N, or - -- Empty otherwise. + -- Return the Ensures component of Test_Case pragma N, or Empty otherwise + -- Bad name now that this no longer applies to Contract_Case ??? function Get_Generic_Entity (N : Node_Id) return Entity_Id; -- Returns the true generic entity in an instantiation. If the name in the -- instantiation is a renaming, the function returns the renamed generic. + function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id; + -- Implements the notion introduced ever-so briefly in RM 7.3.1 (5.2/3): + -- in a child unit a derived type is within the derivation class of an + -- ancestor declared in a parent unit, even if there is an intermediate + -- derivation that does not see the full view of that ancestor. + procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id); -- This procedure assigns to L and H respectively the values of the low and -- high bounds of node N, which must be a range, subtype indication, or the @@ -610,7 +640,8 @@ package Sem_Util is -- Sem_Ch8 for further details on handling of entity visibility. function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id; - -- Return the Name component of Contract_Case or Test_Case pragma N + -- Return the Name component of Test_Case pragma N + -- Bad name now that this no longer applies to Contract_Case ??? function Get_Pragma_Id (N : Node_Id) return Pragma_Id; pragma Inline (Get_Pragma_Id); @@ -628,8 +659,8 @@ package Sem_Util is -- with any other kind of entity. function Get_Requires_From_CTC_Pragma (N : Node_Id) return Node_Id; - -- Return the Requires component of Contract_Case or Test_Case pragma N, or - -- Empty otherwise. + -- Return the Requires component of Test_Case pragma N, or Empty otherwise + -- Bad name now that this no longer applies to Contract_Case ??? function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id; -- Nod is either a procedure call statement, or a function call, or an @@ -843,10 +874,19 @@ 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_Body_Or_Package_Declaration (N : Node_Id) return Boolean; + -- Determine whether node N denotes a body or a package declaration + function Is_Bounded_String (T : Entity_Id) return Boolean; -- True if T is a bounded string type. Used to make sure "=" composes -- properly for bounded string types. + function Is_Constant_Bound (Exp : Node_Id) return Boolean; + -- Exp is the expression for an array bound. Determines whether the + -- bound is a compile-time known value, or a constant entity, or an + -- enumeration literal, or an expression composed of constant-bound + -- subexpressions which are evaluated by means of standard operators. + function Is_Controlling_Limited_Procedure (Proc_Nam : Entity_Id) return Boolean; -- Ada 2005 (AI-345): Determine whether Proc_Nam is a primitive procedure @@ -878,8 +918,9 @@ package Sem_Util is -- it is of protected, synchronized or task kind. function Is_Expression_Function (Subp : Entity_Id) return Boolean; - -- Predicate to determine whether a function entity comes from a rewritten - -- expression function, and should be inlined unconditionally. + -- Predicate to determine whether a scope entity comes from a rewritten + -- expression function call, and should be inlined unconditionally. Also + -- used to determine that such a call does not constitute a freeze point. function Is_False (U : Uint) return Boolean; pragma Inline (Is_False); @@ -922,7 +963,10 @@ package Sem_Util is -- i.e. a library unit or an entity declared in a library package. function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean; - -- Determine whether a given arbitrary type is a limited class-wide type + -- Determine whether a given type is a limited class-wide type, in which + -- case it needs a Master_Id, because extensions of its designated type + -- may include task components. A class-wide type that comes from a + -- limited view must be treated in the same way. function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean; -- Determines whether Expr is a reference to a variable or IN OUT mode @@ -1038,6 +1082,12 @@ package Sem_Util is -- object that is accessed directly, as opposed to the other CIL objects -- that are accessed through managed pointers. + function Is_Variable_Size_Array (E : Entity_Id) return Boolean; + -- Returns true if E has variable size components + + function Is_Variable_Size_Record (E : Entity_Id) return Boolean; + -- Returns true if E has variable size components + function Is_VMS_Operator (Op : Entity_Id) return Boolean; -- Determine whether an operator is one of the intrinsics defined -- in the DEC system extension. @@ -1286,9 +1336,9 @@ package Sem_Util is -- S2. Otherwise, it is S itself. function Object_Access_Level (Obj : Node_Id) return Uint; - -- Return the accessibility level of the view of the object Obj. - -- For convenience, qualified expressions applied to object names - -- are also allowed as actuals for this function. + -- Return the accessibility level of the view of the object Obj. For + -- convenience, qualified expressions applied to object names are also + -- allowed as actuals for this function. function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean; -- Returns True if the names of both entities correspond with matching @@ -1316,6 +1366,9 @@ package Sem_Util is -- parameter Ent gives the entity to which the End_Label refers, -- and to which cross-references are to be generated. + function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean; + -- Determine whether entity Id is referenced within expression Expr + function References_Generic_Formal_Type (N : Node_Id) return Boolean; -- Returns True if the expression Expr contains any references to a -- generic type. This can only happen within a generic template. @@ -1435,7 +1488,8 @@ package Sem_Util is procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id); -- This procedure has the same calling sequence as Set_Entity, but -- if Style_Check is set, then it calls a style checking routine which - -- can check identifier spelling style. + -- can check identifier spelling style. This procedure also takes care + -- of checking the restriction No_Implementation_Identifiers. procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id); pragma Inline (Set_Name_Entity_Id); @@ -1495,6 +1549,10 @@ package Sem_Util is -- Return True if it can be statically determined that the Expressions -- E1 and E2 refer to different objects + function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean; + -- Determine whether node N is a loop statement subject to at least one + -- 'Loop_Entry attribute. + function Subprogram_Access_Level (Subp : Entity_Id) return Uint; -- Return the accessibility level of the view denoted by Subp diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index be4532e609a..68c3ca89b51 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2012, 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- -- @@ -643,6 +643,13 @@ package body Sem_Warn is else Expression := Condition (Exit_Stmt); end if; + + -- If an unconditional exit statement is the last statement in the + -- loop, assume that no warning is needed, without any attempt at + -- checking whether the exit is reachable. + + elsif Exit_Stmt = Last (Statements (Loop_Statement)) then + return; end if; Exit_Stmt := Next_Exit_Statement (Exit_Stmt); @@ -1758,8 +1765,8 @@ package body Sem_Warn is SE : constant Entity_Id := Scope (E); function Within_Postcondition return Boolean; - -- Returns True iff N is within a Postcondition or - -- Ensures component in a Contract_Case or Test_Case. + -- Returns True iff N is within a Postcondition, an + -- Ensures component in a Test_Case, or a Contract_Cases. -------------------------- -- Within_Postcondition -- @@ -1772,7 +1779,9 @@ package body Sem_Warn is Nod := Parent (N); while Present (Nod) loop if Nkind (Nod) = N_Pragma - and then Pragma_Name (Nod) = Name_Postcondition + and then Nam_In (Pragma_Name (Nod), + Name_Postcondition, + Name_Contract_Cases) then return True; @@ -1781,9 +1790,7 @@ package body Sem_Warn is if Nkind (P) = N_Pragma and then - (Pragma_Name (P) = Name_Contract_Case - or else - Pragma_Name (P) = Name_Test_Case) + Pragma_Name (P) = Name_Test_Case and then Nod = Get_Ensures_From_CTC_Pragma (P) then @@ -3219,9 +3226,8 @@ package body Sem_Warn is -- node, since assert pragmas get rewritten at analysis time. elsif Nkind (Original_Node (P)) = N_Pragma - and then (Pragma_Name (Original_Node (P)) = Name_Assert - or else - Pragma_Name (Original_Node (P)) = Name_Check) + and then Nam_In (Pragma_Name (Original_Node (P)), Name_Assert, + Name_Check) then return; end if; diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb new file mode 100755 index 00000000000..db08f0d4e7b --- /dev/null +++ b/gcc/ada/set_targ.adb @@ -0,0 +1,839 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E T _ T A R G -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Get_Targ; use Get_Targ; +with Opt; use Opt; +with Output; use Output; + +with System; use System; +with System.OS_Lib; use System.OS_Lib; + +with Unchecked_Conversion; + +package body Set_Targ is + + -------------------------------------------------------- + -- Data Used to Read/Write Target Dependent Info File -- + -------------------------------------------------------- + + -- Table of string names written to file + + subtype Str is String; + + S_Bits_BE : constant Str := "Bits_BE"; + S_Bits_Per_Unit : constant Str := "Bits_Per_Unit"; + S_Bits_Per_Word : constant Str := "Bits_Per_Word"; + S_Bytes_BE : constant Str := "Bytes_BE"; + S_Char_Size : constant Str := "Char_Size"; + S_Double_Float_Alignment : constant Str := "Double_Float_Alignment"; + S_Double_Scalar_Alignment : constant Str := "Double_Scalar_Alignment"; + S_Double_Size : constant Str := "Double_Size"; + S_Float_Size : constant Str := "Float_Size"; + S_Float_Words_BE : constant Str := "Float_Words_BE"; + S_Int_Size : constant Str := "Int_Size"; + S_Long_Double_Size : constant Str := "Long_Double_Size"; + S_Long_Long_Size : constant Str := "Long_Long_Size"; + S_Long_Size : constant Str := "Long_Size"; + S_Maximum_Alignment : constant Str := "Maximum_Alignment"; + S_Max_Unaligned_Field : constant Str := "Max_Unaligned_Field"; + S_Pointer_Size : constant Str := "Pointer_Size"; + S_Short_Size : constant Str := "Short_Size"; + S_Strict_Alignment : constant Str := "Strict_Alignment"; + S_System_Allocator_Alignment : constant Str := "System_Allocator_Alignment"; + S_Wchar_T_Size : constant Str := "Wchar_T_Size"; + S_Words_BE : constant Str := "Words_BE"; + + -- Table of names + + type AStr is access all String; + + DTN : constant array (Nat range <>) of AStr := ( + S_Bits_BE 'Unrestricted_Access, + S_Bits_Per_Unit 'Unrestricted_Access, + S_Bits_Per_Word 'Unrestricted_Access, + S_Bytes_BE 'Unrestricted_Access, + S_Char_Size 'Unrestricted_Access, + S_Double_Float_Alignment 'Unrestricted_Access, + S_Double_Scalar_Alignment 'Unrestricted_Access, + S_Double_Size 'Unrestricted_Access, + S_Float_Size 'Unrestricted_Access, + S_Float_Words_BE 'Unrestricted_Access, + S_Int_Size 'Unrestricted_Access, + S_Long_Double_Size 'Unrestricted_Access, + S_Long_Long_Size 'Unrestricted_Access, + S_Long_Size 'Unrestricted_Access, + S_Maximum_Alignment 'Unrestricted_Access, + S_Max_Unaligned_Field 'Unrestricted_Access, + S_Pointer_Size 'Unrestricted_Access, + S_Short_Size 'Unrestricted_Access, + S_Strict_Alignment 'Unrestricted_Access, + S_System_Allocator_Alignment 'Unrestricted_Access, + S_Wchar_T_Size 'Unrestricted_Access, + S_Words_BE 'Unrestricted_Access); + + -- Table of corresponding value pointers + + DTV : constant array (Nat range <>) of System.Address := ( + Bits_BE 'Address, + Bits_Per_Unit 'Address, + Bits_Per_Word 'Address, + Bytes_BE 'Address, + Char_Size 'Address, + Double_Float_Alignment 'Address, + Double_Scalar_Alignment 'Address, + Double_Size 'Address, + Float_Size 'Address, + Float_Words_BE 'Address, + Int_Size 'Address, + Long_Double_Size 'Address, + Long_Long_Size 'Address, + Long_Size 'Address, + Maximum_Alignment 'Address, + Max_Unaligned_Field 'Address, + Pointer_Size 'Address, + Short_Size 'Address, + Strict_Alignment 'Address, + System_Allocator_Alignment 'Address, + Wchar_T_Size 'Address, + Words_BE 'Address); + + DTR : array (Nat range DTV'Range) of Boolean := (others => False); + -- Table of flags used to validate that all values are present in file + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Fail (E : String); + pragma No_Return (Fail); + -- Terminate program with fatal error message passed as parameter + + procedure Register_Float_Type + (Name : C_String; + Digs : Natural; + Complex : Boolean; + Count : Natural; + Float_Rep : Float_Rep_Kind; + Size : Positive; + Alignment : Natural); + pragma Convention (C, Register_Float_Type); + -- Call back to allow the back end to register available types. This call + -- back makes entries in the FPT_Mode_Table for any floating point types + -- reported by the back end. Name is the name of the type as a normal + -- format Null-terminated string. Digs is the number of digits, where 0 + -- means it is not a fpt type (ignored during registration). Complex is + -- non-zero if the type has real and imaginary parts (also ignored during + -- registration). Count is the number of elements in a vector type (zero = + -- not a vector, registration ignores vectors). Float_Rep shows the kind of + -- floating-point type, and Size/Alignment are the size/alignment in bits. + -- + -- So to summarize, the only types that are actually registered have Digs + -- non-zero, Complex zero (false), and Count zero (not a vector). + + ---------- + -- Fail -- + ---------- + + procedure Fail (E : String) is + E_Fatal : constant := 4; + -- Code for fatal error + begin + Write_Str (E); + Write_Eol; + OS_Exit (E_Fatal); + end Fail; + + ------------------------- + -- Register_Float_Type -- + ------------------------- + + procedure Register_Float_Type + (Name : C_String; + Digs : Natural; + Complex : Boolean; + Count : Natural; + Float_Rep : Float_Rep_Kind; + Size : Positive; + Alignment : Natural) + is + T : String (1 .. Name'Length); + Last : Natural := 0; + + procedure Dump; + -- Dump information given by the back end for the type to register + + ---------- + -- Dump -- + ---------- + + procedure Dump is + begin + Write_Str ("type " & T (1 .. Last) & " is "); + + if Count > 0 then + Write_Str ("array (1 .. "); + Write_Int (Int (Count)); + + if Complex then + Write_Str (", 1 .. 2"); + end if; + + Write_Str (") of "); + + elsif Complex then + Write_Str ("array (1 .. 2) of "); + end if; + + if Digs > 0 then + Write_Str ("digits "); + Write_Int (Int (Digs)); + Write_Line (";"); + + Write_Str ("pragma Float_Representation ("); + + case Float_Rep is + when IEEE_Binary => + Write_Str ("IEEE"); + + when VAX_Native => + case Digs is + when 6 => + Write_Str ("VAXF"); + + when 9 => + Write_Str ("VAXD"); + + when 15 => + Write_Str ("VAXG"); + + when others => + Write_Str ("VAX_"); + Write_Int (Int (Digs)); + end case; + + when AAMP => Write_Str ("AAMP"); + end case; + + Write_Line (", " & T (1 .. Last) & ");"); + + else + Write_Str ("mod 2**"); + Write_Int (Int (Size / Positive'Max (1, Count))); + Write_Line (";"); + end if; + + Write_Str ("for " & T (1 .. Last) & "'Size use "); + Write_Int (Int (Size)); + Write_Line (";"); + + Write_Str ("for " & T (1 .. Last) & "'Alignment use "); + Write_Int (Int (Alignment / 8)); + Write_Line (";"); + Write_Eol; + end Dump; + + -- Start of processing for Register_Float_Type + + begin + -- Acquire name + + for J in T'Range loop + T (J) := Name (Name'First + J - 1); + + if T (J) = ASCII.NUL then + Last := J - 1; + exit; + end if; + end loop; + + -- Dump info if debug flag set + + if Debug_Flag_Dot_B then + Dump; + end if; + + -- Acquire entry if non-vector non-complex fpt type (digits non-zero) + + if Digs > 0 and then not Complex and then Count = 0 then + Num_FPT_Modes := Num_FPT_Modes + 1; + FPT_Mode_Table (Num_FPT_Modes) := + (NAME => new String'(T (1 .. Last)), + DIGS => Digs, + FLOAT_REP => Float_Rep, + SIZE => Size, + ALIGNMENT => Alignment); + end if; + end Register_Float_Type; + + ----------------------------------- + -- Write_Target_Dependent_Values -- + ----------------------------------- + + -- We do this at the System.Os_Lib level, since we have to do the read at + -- that level anyway, so it is easier and more consistent to follow the + -- same path for the write. + + procedure Write_Target_Dependent_Values is + Fdesc : File_Descriptor; + OK : Boolean; + + Buffer : String (1 .. 80); + Buflen : Natural; + -- Buffer used to build line one of file + + type ANat is access all Natural; + -- Pointer to Nat or Pos value (it is harmless to treat Pos values and + -- Nat values as Natural via Unchecked_Conversion). + + function To_ANat is new Unchecked_Conversion (Address, ANat); + + procedure AddC (C : Character); + -- Add one character to buffer + + procedure AddN (N : Natural); + -- Add representation of integer N to Buffer, updating Buflen. N + -- must be less than 1000, and output is 3 characters with leading + -- spaces as needed. + + procedure Write_Line; + -- Output contents of Buffer (1 .. Buflen) followed by a New_Line, + -- and set Buflen back to zero, ready to write next line. + + ---------- + -- AddC -- + ---------- + + procedure AddC (C : Character) is + begin + Buflen := Buflen + 1; + Buffer (Buflen) := C; + end AddC; + + ---------- + -- AddN -- + ---------- + + procedure AddN (N : Natural) is + begin + if N > 999 then + raise Program_Error; + end if; + + if N > 99 then + AddC (Character'Val (48 + N / 100)); + else + AddC (' '); + end if; + + if N > 9 then + AddC (Character'Val (48 + N / 10 mod 10)); + else + AddC (' '); + end if; + + AddC (Character'Val (48 + N mod 10)); + end AddN; + + ---------------- + -- Write_Line -- + ---------------- + + procedure Write_Line is + begin + AddC (ASCII.LF); + + if Buflen /= Write (Fdesc, Buffer'Address, Buflen) then + Delete_File (Target_Dependent_Info_Write_Name'Address, OK); + Fail ("disk full writing file " + & Target_Dependent_Info_Write_Name.all); + end if; + + Buflen := 0; + end Write_Line; + + -- Start of processing for Write_Target_Dependent_Values + + begin + Fdesc := + Create_File (Target_Dependent_Info_Write_Name.all'Address, Text); + + if Fdesc = Invalid_FD then + Fail ("cannot create file " & Target_Dependent_Info_Write_Name.all); + end if; + + -- Loop through values + + for J in DTN'Range loop + + -- Output name + + Buflen := DTN (J)'Length; + Buffer (1 .. Buflen) := DTN (J).all; + + -- Line up values + + while Buflen < 26 loop + AddC (' '); + end loop; + + AddC (' '); + AddC (' '); + + -- Output value and write line + + AddN (To_ANat (DTV (J)).all); + Write_Line; + end loop; + + -- Blank line to separate sections + + Write_Line; + + -- Write lines for registered FPT types + + for J in 1 .. Num_FPT_Modes loop + declare + E : FPT_Mode_Entry renames FPT_Mode_Table (J); + begin + Buflen := E.NAME'Last; + Buffer (1 .. Buflen) := E.NAME.all; + + -- Pad out to line up values + + while Buflen < 11 loop + AddC (' '); + end loop; + + AddC (' '); + AddC (' '); + + AddN (E.DIGS); + AddC (' '); + AddC (' '); + + case E.FLOAT_REP is + when IEEE_Binary => + AddC ('I'); + when VAX_Native => + AddC ('V'); + when AAMP => + AddC ('A'); + end case; + + AddC (' '); + + AddN (E.SIZE); + AddC (' '); + + AddN (E.ALIGNMENT); + Write_Line; + end; + end loop; + + -- Close file + + Close (Fdesc, OK); + + if not OK then + Fail ("disk full writing file " + & Target_Dependent_Info_Write_Name.all); + end if; + end Write_Target_Dependent_Values; + +-- Package Initialization, set target dependent values. This must be done +-- early on, before we start accessing various compiler packages, since +-- these values are used all over the place. + +begin + -- First step: see if the -gnateT switch is present. As we have noted, + -- this has to be done very early, so can not depend on the normal circuit + -- for reading switches and setting switches in Opt. The following code + -- will set Opt.Target_Dependent_Info_Read_Name if the switch -gnateT=name + -- is present in the options string. + + declare + type Arg_Array is array (Nat) of Big_String_Ptr; + type Arg_Array_Ptr is access Arg_Array; + -- Types to access compiler arguments + + save_argc : Nat; + pragma Import (C, save_argc); + -- Saved value of argc (number of arguments), imported from misc.c + + save_argv : Arg_Array_Ptr; + pragma Import (C, save_argv); + -- Saved value of argv (argument pointers), imported from misc.c + + gnat_argc : Nat; + gnat_argv : Arg_Array_Ptr; + pragma Import (C, gnat_argc); + pragma Import (C, gnat_argv); + -- If save_argv is not set, default to gnat_argc/argv + + argc : Nat; + argv : Arg_Array_Ptr; + + function Len_Arg (Arg : Big_String_Ptr) return Nat; + -- Determine length of argument Arg (a nul terminated C string). + + ------------- + -- Len_Arg -- + ------------- + + function Len_Arg (Arg : Big_String_Ptr) return Nat is + begin + for J in 1 .. Nat'Last loop + if Arg (Natural (J)) = ASCII.NUL then + return J - 1; + end if; + end loop; + + raise Program_Error; + end Len_Arg; + + begin + if save_argv /= null then + argv := save_argv; + argc := save_argc; + else + -- Case of a non gcc compiler, e.g. gnat2why or gnat2scil + argv := gnat_argv; + argc := gnat_argc; + end if; + + -- Loop through arguments looking for -gnateT, also look for -gnatd.b + + for Arg in 1 .. argc - 1 loop + declare + Argv_Ptr : constant Big_String_Ptr := argv (Arg); + Argv_Len : constant Nat := Len_Arg (Argv_Ptr); + + begin + if Argv_Len > 8 + and then Argv_Ptr (1 .. 8) = "-gnateT=" + then + Opt.Target_Dependent_Info_Read_Name := + new String'(Argv_Ptr (9 .. Natural (Argv_Len))); + + elsif Argv_Len >= 8 + and then Argv_Ptr (1 .. 8) = "-gnatd.b" + then + Debug_Flag_Dot_B := True; + end if; + end; + end loop; + end; + + -- If the switch is not set, we get all values from the back end + + if Opt.Target_Dependent_Info_Read_Name = null then + + -- Set values by direct calls to the back end + + Bits_BE := Get_Bits_BE; + Bits_Per_Unit := Get_Bits_Per_Unit; + Bits_Per_Word := Get_Bits_Per_Word; + Bytes_BE := Get_Bytes_BE; + Char_Size := Get_Char_Size; + Double_Float_Alignment := Get_Double_Float_Alignment; + Double_Scalar_Alignment := Get_Double_Scalar_Alignment; + Double_Size := Get_Double_Size; + Float_Size := Get_Float_Size; + Float_Words_BE := Get_Float_Words_BE; + Int_Size := Get_Int_Size; + Long_Double_Size := Get_Long_Double_Size; + Long_Long_Size := Get_Long_Long_Size; + Long_Size := Get_Long_Size; + Maximum_Alignment := Get_Maximum_Alignment; + Max_Unaligned_Field := Get_Max_Unaligned_Field; + Pointer_Size := Get_Pointer_Size; + Short_Size := Get_Short_Size; + Strict_Alignment := Get_Strict_Alignment; + System_Allocator_Alignment := Get_System_Allocator_Alignment; + Wchar_T_Size := Get_Wchar_T_Size; + Words_BE := Get_Words_BE; + + -- Register floating-point types from the back end + + Register_Back_End_Types (Register_Float_Type'Access); + + -- Case of reading the target dependent values from file + + -- This is bit more complex than might be expected, because it has to be + -- done very early. All kinds of packages depend on these values, and we + -- can't wait till the normal processing of reading command line switches + -- etc to read the file. We do this at the System.OS_Lib level since it is + -- too early to be using Osint directly. + + else + Read_Target_Dependent_Values : declare + File_Desc : File_Descriptor; + N : Natural; + + type ANat is access all Natural; + -- Pointer to Nat or Pos value (it is harmless to treat Pos values + -- as Nat via Unchecked_Conversion). + + function To_ANat is new Unchecked_Conversion (Address, ANat); + + VP : ANat; + + Buffer : String (1 .. 2000); + Buflen : Natural; + -- File information and length (2000 easily enough!) + + Nam_Buf : String (1 .. 40); + Nam_Len : Natural; + + procedure Check_Spaces; + -- Checks that we have one or more spaces and skips them + + procedure FailN (S : String); + -- Calls Fail adding " name in file xxx", where name is the currently + -- gathered name in Nam_Buf, surrounded by quotes, and xxx is the + -- name of the file. + + procedure Get_Name; + -- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls + -- Skip_Spaces to skip any following spaces. Note that the name is + -- terminated by a sequence of at least two spaces. + + function Get_Nat return Natural; + -- N on entry points to decimal integer, scan out decimal integer + -- and return it, leaving N pointing to following space or LF. + + procedure Skip_Spaces; + -- Skip past spaces + + ------------------ + -- Check_Spaces -- + ------------------ + + procedure Check_Spaces is + begin + if N > Buflen or else Buffer (N) /= ' ' then + FailN ("missing space for"); + end if; + + Skip_Spaces; + return; + end Check_Spaces; + + ----------- + -- FailN -- + ----------- + + procedure FailN (S : String) is + begin + Fail (S & " """ & Nam_Buf (1 .. Nam_Len) & """ in file " + & Target_Dependent_Info_Read_Name.all); + end FailN; + + -------------- + -- Get_Name -- + -------------- + + procedure Get_Name is + begin + Nam_Len := 0; + + -- Scan out name and put it in Nam_Buf + + loop + if N > Buflen or else Buffer (N) = ASCII.LF then + FailN ("incorrectly formatted line for"); + end if; + + -- Name is terminated by two blanks + + exit when N < Buflen and then Buffer (N .. N + 1) = " "; + + Nam_Len := Nam_Len + 1; + + if Nam_Len > Nam_Buf'Last then + Fail ("name too long"); + end if; + + Nam_Buf (Nam_Len) := Buffer (N); + N := N + 1; + end loop; + + Check_Spaces; + end Get_Name; + + ------------- + -- Get_Nat -- + ------------- + + function Get_Nat return Natural is + Result : Natural := 0; + + begin + loop + if N > Buflen + or else Buffer (N) not in '0' .. '9' + or else Result > 999 + then + FailN ("bad value for"); + end if; + + Result := Result * 10 + (Character'Pos (Buffer (N)) - 48); + N := N + 1; + + exit when N <= Buflen + and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' '); + end loop; + + return Result; + end Get_Nat; + + ----------------- + -- Skip_Spaces -- + ----------------- + + procedure Skip_Spaces is + begin + while N <= Buflen and Buffer (N) = ' ' loop + N := N + 1; + end loop; + end Skip_Spaces; + + -- Start of processing for Read_Target_Dependent_Values + + begin + File_Desc := Open_Read (Target_Dependent_Info_Read_Name.all, Text); + + if File_Desc = Invalid_FD then + Fail ("cannot read file " & Target_Dependent_Info_Read_Name.all); + end if; + + Buflen := Read (File_Desc, Buffer'Address, Buffer'Length); + + if Buflen = Buffer'Length then + Fail ("file is too long: " & Target_Dependent_Info_Read_Name.all); + end if; + + -- Scan through file for properly formatted entries in first section + + N := 1; + while N <= Buflen and then Buffer (N) /= ASCII.LF loop + Get_Name; + + -- Validate name and get corresponding value pointer + + VP := null; + + for J in DTN'Range loop + if DTN (J).all = Nam_Buf (1 .. Nam_Len) then + VP := To_ANat (DTV (J)); + DTR (J) := True; + exit; + end if; + end loop; + + if VP = null then + FailN ("unrecognized name"); + end if; + + -- Scan out value + + VP.all := Get_Nat; + + if N > Buflen or else Buffer (N) /= ASCII.LF then + FailN ("misformatted line for"); + end if; + + N := N + 1; -- skip LF + end loop; + + -- Fall through this loop when all lines in first section read. + -- Check that values have been supplied for all entries. + + for J in DTR'Range loop + if not DTR (J) then + Fail ("missing entry for " & DTN (J).all & " in file " + & Target_Dependent_Info_Read_Name.all); + end if; + end loop; + + -- Now acquire FPT entries + + if N >= Buflen then + Fail ("missing entries for FPT modes in file " + & Target_Dependent_Info_Read_Name.all); + end if; + + if Buffer (N) = ASCII.LF then + N := N + 1; + else + Fail ("missing blank line in file " + & Target_Dependent_Info_Read_Name.all); + end if; + + Num_FPT_Modes := 0; + while N <= Buflen loop + Get_Name; + + Num_FPT_Modes := Num_FPT_Modes + 1; + + declare + E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes); + + begin + E.NAME := new String'(Nam_Buf (1 .. Nam_Len)); + + E.DIGS := Get_Nat; + Check_Spaces; + + case Buffer (N) is + when 'I' => + E.FLOAT_REP := IEEE_Binary; + when 'V' => + E.FLOAT_REP := VAX_Native; + when 'A' => + E.FLOAT_REP := AAMP; + when others => + FailN ("bad float rep field for"); + end case; + + N := N + 1; + Check_Spaces; + + E.SIZE := Get_Nat; + Check_Spaces; + + E.ALIGNMENT := Get_Nat; + + if Buffer (N) /= ASCII.LF then + FailN ("junk at end of line for"); + end if; + + N := N + 1; + end; + end loop; + end Read_Target_Dependent_Values; + end if; +end Set_Targ; diff --git a/gcc/ada/set_targ.ads b/gcc/ada/set_targ.ads new file mode 100755 index 00000000000..a14fbcbce3e --- /dev/null +++ b/gcc/ada/set_targ.ads @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E T _ T A R G -- +-- -- +-- S p e c -- +-- -- +-- 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package handles setting target dependent parameters. If the -gnatet +-- switch is not set, then these values are taken from the back end (via the +-- routines in Get_Targ, and the enumerate_modes routine in misc.c). If the +-- switch is set, then the values are read from the target.atp file in the +-- current directory (usually written with the Write_Target_Dependent_Values +-- procedure defined in this package). + +-- Note that all these values return sizes of C types with corresponding +-- names. This allows GNAT to define the corresponding Ada types to have +-- the same representation. There is one exception: the representation +-- of Wide_Character_Type uses twice the size of a C char, instead of the +-- size of wchar_t, since this corresponds to expected Ada usage. + +with Einfo; use Einfo; +with Types; use Types; + +package Set_Targ is + + ----------------------------- + -- Target-Dependent Values -- + ----------------------------- + + -- The following is a table of target dependent values. In normal operation + -- these values are set by calling the appropriate C backend routines that + -- interface to back end routines that determine target characteristics. + + -- If the -gnateT switch is used, then any values that are read from the + -- file target.atp in the current directory overwrite values set from the + -- back end. 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. + + -- Note: fields marked with a question mark are boolean fields, where a + -- value of 0 is False, and a value of 1 is True. + + 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? + + ------------------------------------- + -- Registered Floating-Point Types -- + ------------------------------------- + + -- This table contains the list of modes supported by the back-end as + -- provided by the back end routine enumerate_modes in misc.c. Note that + -- we only store floating-point modes (see Register_Float_Type). + + type FPT_Mode_Entry is record + NAME : String_Ptr; -- Name of mode (no null character at end) + DIGS : Natural; -- Digits for floating-point type + FLOAT_REP : Float_Rep_Kind; -- Float representation + SIZE : Natural; -- Size in bits + ALIGNMENT : Natural; -- Alignment in bits + end record; + + FPT_Mode_Table : array (1 .. 1000) of FPT_Mode_Entry; + Num_FPT_Modes : Natural := 0; + -- Table containing the supported modes and number of entries + + ----------------- + -- Subprograms -- + ----------------- + + procedure Write_Target_Dependent_Values; + -- This routine writes the file target.atp in the current directory with + -- the values of the global target parameters as listed above, and as set + -- by prior calls to Initialize/Read_Target_Dependent_Values. The format + -- of the target.atp file is as follows + -- + -- First come the values of the variables defined in this spec: + -- + -- One line per value + -- + -- name value + -- + -- where name is the name of the parameter, spelled out in full, + -- and cased as in the above list, and 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 declarations in this spec). + -- + -- 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. + -- + -- One line per registered mode + -- + -- name digs float_rep size alignment + -- + -- where name is the string name of the type (which can have single + -- spaces embedded in the name (e.g. long double). The name is followed + -- by at least two blanks. The following fields are as described above + -- for a Mode_Entry (where float_rep is I/V/A for IEEE-754-Binary, + -- Vax_Native, AAMP), fields are separated by at least one blank, and + -- a LF character immediately follows the alignment field. + +end Set_Targ; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 3d5a64434f2..c8eab8a9536 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.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- -- @@ -423,6 +423,14 @@ package body Sinfo is return Flag6 (N); end Class_Present; + function Classifications + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + return Node3 (N); + end Classifications; + function Comes_From_Extended_Return_Statement (N : Node_Id) return Boolean is begin @@ -585,6 +593,14 @@ package body Sinfo is return Flag16 (N); end Context_Pending; + function Contract_Test_Cases + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + return Node2 (N); + end Contract_Test_Cases; + function Controlling_Argument (N : Node_Id) return Node_Id is begin @@ -602,6 +618,14 @@ package body Sinfo is return Flag14 (N); end Conversion_OK; + function Convert_To_Return_False + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Expression); + return Flag13 (N); + end Convert_To_Return_False; + function Corresponding_Aspect (N : Node_Id) return Node_Id is begin @@ -1233,6 +1257,7 @@ package body Sinfo is or else NT (N).Nkind = N_Parameter_Specification or else NT (N).Nkind = N_Pragma_Argument_Association or else NT (N).Nkind = N_Qualified_Expression + or else NT (N).Nkind = N_Raise_Expression or else NT (N).Nkind = N_Raise_Statement or else NT (N).Nkind = N_Simple_Return_Statement or else NT (N).Nkind = N_Type_Conversion @@ -1631,13 +1656,13 @@ package body Sinfo is return Flag16 (N); end Import_Interface_Present; - function In_Assertion + function In_Assertion_Expression (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Function_Call); return Flag4 (N); - end In_Assertion; + end In_Assertion_Expression; function In_Present (N : Node_Id) return Boolean is @@ -1731,6 +1756,15 @@ package body Sinfo is return Flag16 (N); end Is_Controlling_Actual; + function Is_Disabled + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + return Flag15 (N); + end Is_Disabled; + function Is_Delayed_Aspect (N : Node_Id) return Boolean is begin @@ -1789,6 +1823,15 @@ package body Sinfo is return Flag4 (N); end Is_Folded_In_Parser; + function Is_Ignored + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + return Flag9 (N); + end Is_Ignored; + function Is_In_Discriminant_Check (N : Node_Id) return Boolean is begin @@ -2130,6 +2173,7 @@ package body Sinfo is or else NT (N).Nkind = N_Package_Renaming_Declaration or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Raise_Expression or else NT (N).Nkind = N_Raise_Statement or else NT (N).Nkind = N_Requeue_Statement or else NT (N).Nkind = N_Subprogram_Renaming_Declaration @@ -2466,6 +2510,14 @@ package body Sinfo is return List4 (N); end Pragmas_Before; + function Pre_Post_Conditions + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + return Node1 (N); + end Pre_Post_Conditions; + function Prefix (N : Node_Id) return Node_Id is begin @@ -2804,22 +2856,6 @@ package body Sinfo is return Node1 (N); end Source_Type; - function Spec_PPC_List - (N : Node_Id) return Node_Id is - begin - pragma Assert (False - or else NT (N).Nkind = N_Contract); - return Node1 (N); - end Spec_PPC_List; - - function Spec_CTC_List - (N : Node_Id) return Node_Id is - begin - pragma Assert (False - or else NT (N).Nkind = N_Contract); - return Node2 (N); - end Spec_CTC_List; - function Specification (N : Node_Id) return Node_Id is begin @@ -3504,8 +3540,16 @@ package body Sinfo is Set_Flag6 (N, Val); end Set_Class_Present; + procedure Set_Classifications + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Classifications; + procedure Set_Comes_From_Extended_Return_Statement - (N : Node_Id; Val : Boolean := True) is + (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False or else NT (N).Nkind = N_Simple_Return_Statement); @@ -3666,6 +3710,14 @@ package body Sinfo is Set_Flag16 (N, Val); end Set_Context_Pending; + procedure Set_Contract_Test_Cases + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_Contract_Test_Cases; + procedure Set_Controlling_Argument (N : Node_Id; Val : Node_Id) is begin @@ -3683,6 +3735,14 @@ package body Sinfo is Set_Flag14 (N, Val); end Set_Conversion_OK; + procedure Set_Convert_To_Return_False + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Raise_Expression); + Set_Flag13 (N, Val); + end Set_Convert_To_Return_False; + procedure Set_Corresponding_Aspect (N : Node_Id; Val : Node_Id) is begin @@ -4305,6 +4365,7 @@ package body Sinfo is or else NT (N).Nkind = N_Parameter_Specification or else NT (N).Nkind = N_Pragma_Argument_Association or else NT (N).Nkind = N_Qualified_Expression + or else NT (N).Nkind = N_Raise_Expression or else NT (N).Nkind = N_Raise_Statement or else NT (N).Nkind = N_Simple_Return_Statement or else NT (N).Nkind = N_Type_Conversion @@ -4703,13 +4764,13 @@ package body Sinfo is Set_Flag16 (N, Val); end Set_Import_Interface_Present; - procedure Set_In_Assertion + procedure Set_In_Assertion_Expression (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False or else NT (N).Nkind = N_Function_Call); Set_Flag4 (N, Val); - end Set_In_Assertion; + end Set_In_Assertion_Expression; procedure Set_In_Present (N : Node_Id; Val : Boolean := True) is @@ -4813,6 +4874,15 @@ package body Sinfo is Set_Flag14 (N, Val); end Set_Is_Delayed_Aspect; + procedure Set_Is_Disabled + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + Set_Flag15 (N, Val); + end Set_Is_Disabled; + procedure Set_Is_Dynamic_Coextension (N : Node_Id; Val : Boolean := True) is begin @@ -4861,6 +4931,15 @@ package body Sinfo is Set_Flag4 (N, Val); end Set_Is_Folded_In_Parser; + procedure Set_Is_Ignored + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + Set_Flag9 (N, Val); + end Set_Is_Ignored; + procedure Set_Is_In_Discriminant_Check (N : Node_Id; Val : Boolean := True) is begin @@ -5202,6 +5281,7 @@ package body Sinfo is or else NT (N).Nkind = N_Package_Renaming_Declaration or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Raise_Expression or else NT (N).Nkind = N_Raise_Statement or else NT (N).Nkind = N_Requeue_Statement or else NT (N).Nkind = N_Subprogram_Renaming_Declaration @@ -5538,6 +5618,14 @@ package body Sinfo is Set_List4_With_Parent (N, Val); end Set_Pragmas_Before; + procedure Set_Pre_Post_Conditions + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + Set_Node1 (N, Val); -- semantic field, no parent set + end Set_Pre_Post_Conditions; + procedure Set_Prefix (N : Node_Id; Val : Node_Id) is begin @@ -5876,22 +5964,6 @@ package body Sinfo is Set_Node1 (N, Val); -- semantic field, no parent set end Set_Source_Type; - procedure Set_Spec_PPC_List - (N : Node_Id; Val : Node_Id) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Contract); - Set_Node1 (N, Val); -- semantic field, no parent set - end Set_Spec_PPC_List; - - procedure Set_Spec_CTC_List - (N : Node_Id; Val : Node_Id) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Contract); - Set_Node2 (N, Val); -- semantic field, no parent set - end Set_Spec_CTC_List; - procedure Set_Specification (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 20fb08c4071..10b6e81062a 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.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- -- @@ -720,6 +720,12 @@ package Sinfo is -- direct conversion of the underlying integer result, with no regard to -- the small operand. + -- Convert_To_Return_False (Flag13-Sem) + -- Present in N_Raise_Expression nodes that appear in the body of the + -- special predicateM function used to test a predicate in the context + -- of a membership test, where raise expression results in returning a + -- value of False rather than raising an exception. + -- Corresponding_Aspect (Node3-Sem) -- Present in N_Pragma node. Used to point back to the source aspect from -- the corresponding pragma. This field is Empty for source pragmas. @@ -801,7 +807,10 @@ package Sinfo is -- This flag is set on N_Selected_Component nodes to indicate that a -- discriminant check is required using the discriminant check routine -- associated with the selector. The actual check is generated by the - -- expander when processing selected components. + -- expander when processing selected components. In the case of + -- Unchecked_Union, the flag is also set, but no discriminant check + -- routine is associated with the selector, and the expander does not + -- generate a check. -- Do_Division_Check (Flag13-Sem) -- This flag is set on a division operator (/ mod rem) to indicate @@ -1218,7 +1227,7 @@ package Sinfo is -- pragma of the other kind is also present. This is used to avoid -- generating some unwanted error messages. - -- In_Assertion (Flag4-Sem) + -- In_Assertion_Expression (Flag4-Sem) -- This flag is present in N_Function_Call nodes. It is set if the -- function is called from within an assertion expression. This is -- used to avoid some bogus warnings about early elaboration. @@ -1277,6 +1286,14 @@ package Sinfo is -- a dispatching call. It is off in all other cases. See Sem_Disp for -- details of its use. + -- Is_Disabled (Flag15-Sem) + -- A flag set in an N_Aspect_Specification or N_Pragma node if there was + -- a Check_Policy or Assertion_Policy (or in the case of a Debug_Pragma) + -- a Debug_Policy pragma that resulted in totally disabling the flagged + -- aspect or policy as a result of using the GNAT-defined policy DISABLE. + -- If this flag is set, the aspect or policy is not analyzed for semantic + -- correctness, so any expressions etc will not be marked as analyzed. + -- Is_Dynamic_Coextension (Flag18-Sem) -- Present in allocator nodes, to indicate that this is an allocator -- for an access discriminant of a dynamically allocated object. The @@ -1299,6 +1316,20 @@ package Sinfo is -- objects. The wrapper prevents interference between exception handlers -- and At_End handlers. + -- Is_Ignored (Flag9-Sem) + -- A flag set in an N_Aspect_Specification or N_Pragma node if there was + -- a Check_Policy or Assertion_Policy (or in the case of a Debug_Pragma) + -- a Debug_Policy pragma that specified a policy of IGNORE, DISABLE, or + -- OFF, for the pragma/aspect. If there was a Policy pragma specifying + -- a Policy of ON or CHECK, then this flag is reset. If no Policy pragma + -- gives a policy for the aspect or pragma, then there are two cases. For + -- an assertion aspect or pragma (one of the assertion kinds allowed in + -- an Assertion_Policy pragma), then Is_Ignored is set if assertions are + -- ignored because of the absence of a -gnata switch. For any other + -- aspects or pragmas, the flag is off. If this flag is set, the + -- aspect/pragma is fully analyzed and checked for other syntactic + -- and semantic errors, but it does not have any semantic effect. + -- Is_In_Discriminant_Check (Flag11-Sem) -- This flag is present in a selected component, and is used to indicate -- that the reference occurs within a discriminant check. The @@ -1383,10 +1414,10 @@ package Sinfo is -- Label_Construct (Node2-Sem) -- Used in an N_Implicit_Label_Declaration node. Refers to an N_Label, -- N_Block_Statement or N_Loop_Statement node to which the label - -- declaration applies. This is not currently used in the compiler - -- itself, but it is useful in the implementation of ASIS queries. - -- This field is left empty for the special labels generated as part - -- of expanding raise statements with a local exception handler. + -- declaration applies. This attribute is used both in the compiler and + -- in the implementation of ASIS queries. The field is left empty for the + -- special labels generated as part of expanding raise statements with a + -- local exception handler. -- Library_Unit (Node4-Sem) -- In a stub node, Library_Unit points to the compilation unit node of @@ -2076,11 +2107,13 @@ package Sinfo is -- Corresponding_Aspect (Node3-Sem) (set to Empty if not present) -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) + -- Class_Present (Flag6) set if from Aspect with 'Class -- From_Aspect_Specification (Flag13-Sem) -- Is_Delayed_Aspect (Flag14-Sem) + -- Is_Disabled (Flag15-Sem) + -- Is_Ignored (Flag9-Sem) -- Import_Interface_Present (Flag16-Sem) -- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set - -- Class_Present (Flag6) set if from Aspect with 'Class -- Note: we should have a section on what pragmas are passed on to -- the back end to be processed. This section should note that pragma @@ -2103,6 +2136,30 @@ package Sinfo is -- [pragma_argument_IDENTIFIER =>] NAME -- | [pragma_argument_IDENTIFIER =>] EXPRESSION + -- In Ada 2012, there are two more possibilities: + + -- PRAGMA_ARGUMENT_ASSOCIATION ::= + -- [pragma_argument_ASPECT_MARK =>] NAME + -- | [pragma_argument_ASPECT_MARK =>] EXPRESSION + + -- where the interesting allowed cases (which do not fit the syntax of + -- the first alternative above) are + + -- ASPECT_MARK => Pre'Class | + -- Post'Class | + -- Type_Invariant'Class | + -- Invariant'Class + + -- We allow this special usage in all Ada modes, but it would be a + -- pain to allow these aspects to pervade the pragma syntax, and the + -- representation of pragma nodes internally. So what we do is to + -- replace these ASPECT_MARK forms with identifiers whose name is one + -- of the special internal names _Pre, _Post or _Type_Invariant. + + -- We do a similar replacement of these Aspect_Mark forms in the + -- Expression of a pragma argument association for the cases of + -- the first arguments of any Check pragmas and Check_Policy pragmas + -- N_Pragma_Argument_Association -- Sloc points to first token in association -- Chars (Name1) (set to No_Name if no pragma argument identifier) @@ -3545,6 +3602,7 @@ package Sinfo is -- RELATION ::= -- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST + -- | RAISE_EXPRESSION -- MEMBERSHIP_CHOICE_LIST ::= -- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE} @@ -4673,7 +4731,7 @@ package Sinfo is -------------------------- -- SUBPROGRAM_BODY ::= - -- SUBPROGRAM_SPECIFICATION is + -- SUBPROGRAM_SPECIFICATION [ASPECT_SPECIFICATIONS] is -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS @@ -4762,7 +4820,7 @@ package Sinfo is -- actual parameter part) -- First_Named_Actual (Node4-Sem) -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching) - -- In_Assertion (Flag4-Sem) + -- In_Assertion_Expression (Flag4-Sem) -- Is_Expanded_Build_In_Place_Call (Flag11-Sem) -- Do_Tag_Check (Flag13-Sem) -- No_Elaboration_Check (Flag14-Sem) @@ -6119,7 +6177,8 @@ package Sinfo is -- In Ada 2005, we have - -- RAISE_STATEMENT ::= raise; | raise exception_NAME [with EXPRESSION]; + -- RAISE_STATEMENT ::= + -- raise; | raise exception_NAME [with string_EXPRESSION]; -- N_Raise_Statement -- Sloc points to RAISE @@ -6127,6 +6186,19 @@ package Sinfo is -- Expression (Node3) (set to Empty if no expression present) -- From_At_End (Flag4-Sem) + ---------------------------- + -- 11.3 Raise Expression -- + ---------------------------- + + -- RAISE_EXPRESSION ::= raise exception_NAME [with string_EXPRESSION] + + -- N_Raise_Expression + -- Sloc points to RAISE + -- Name (Node2) (always present) + -- Expression (Node3) (set to Empty if no expression present) + -- Convert_To_Return_False (Flag13-Sem) + -- plus fields for expression + ------------------------------- -- 12.1 Generic Declaration -- ------------------------------- @@ -6688,6 +6760,8 @@ package Sinfo is -- Split_PPC (Flag17) Set if split pre/post attribute -- Is_Boolean_Aspect (Flag16-Sem) -- Is_Delayed_Aspect (Flag14-Sem) + -- Is_Disabled (Flag15-Sem) + -- Is_Ignored (Flag9-Sem) -- Note: Aspect_Specification is an Ada 2012 feature @@ -6698,6 +6772,9 @@ package Sinfo is -- a copy of the expression for visibility analysis, see spec of -- Sem_Ch13 for full details of this usage. + -- In the case of aspects of the form xxx'Class, the aspect identifier + -- is for xxx, and Class_Present is set to True. + -- Note: When a Pre or Post aspect specification is processed, it is -- broken into AND THEN sections. The left most section has Split_PPC -- set to False, indicating that it is the original specification (e.g. @@ -6961,22 +7038,23 @@ package Sinfo is -- N_Contract -- Sloc points to the subprogram's name - -- Spec_PPC_List (Node1) (set to Empty if none) - -- Spec_CTC_List (Node2) (set to Empty if none) - - -- Spec_PPC_List points to a list of Precondition and Postcondition - -- pragma nodes for preconditions and postconditions declared in the - -- spec of the entry/subprogram. The last pragma encountered is at the - -- head of this list, so it is in reverse order of textual appearance. - -- Note that this includes precondition/postcondition pragmas generated - -- to correspond to Pre/Post aspects. - - -- Spec_CTC_List points to a list of Contract_Case and Test_Case pragma - -- nodes for contract-cases and test-cases declared in the spec of the - -- entry/subprogram. The last pragma encountered is at the head of this - -- list, so it is in reverse order of textual appearance. Note that - -- this includes contract-case and test-case pragmas generated from - -- Contract_Case and Test_Case aspects. + -- Pre_Post_Conditions (Node1) (set to Empty if none) + -- Contract_Test_Cases (Node2) (set to Empty if none) + -- 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 of LIFO fashion. + + -- Contract_Test_Cases contains a collection of pragmas that correspond + -- to aspects/pragmas Contract_Cases and Test_Case. The ordering in the + -- list is of 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 + -- of LIFO fashion. ------------------- -- Expanded_Name -- @@ -7043,14 +7121,18 @@ package Sinfo is -- Expression (Node3) -- plus fields for expression - -- Note: the actions list is always non-null, since we would - -- never have created this node if there weren't some actions. + -- Note: the actions list is always non-null, since we would never have + -- created this node if there weren't some actions. -- Note: Expression may be a Null_Statement, in which case the -- N_Expression_With_Actions has type Standard_Void_Type. However some -- backends do not support such expression-with-actions occurring -- outside of a proper (non-void) expression, so this should just be - -- used as an intermediate representation within the front-end. + -- used as an intermediate representation within the front-end. Also + -- note that this is really an irregularity (expressions and statements + -- are not interchangeable, and in particular an N_Null_Statement is + -- not a proper expression), and in the long term all cases of this + -- idiom should instead use a new node kind N_Compound_Statement. -------------------- -- Free Statement -- @@ -7664,6 +7746,7 @@ package Sinfo is N_Allocator, N_Case_Expression, N_Extension_Aggregate, + N_Raise_Expression, N_Range, N_Real_Literal, N_Reference, @@ -8224,6 +8307,9 @@ package Sinfo is function Class_Present (N : Node_Id) return Boolean; -- Flag6 + function Classifications + (N : Node_Id) return Node_Id; -- Node3 + function Comes_From_Extended_Return_Statement (N : Node_Id) return Boolean; -- Flag18 @@ -8278,12 +8364,18 @@ package Sinfo is function Context_Items (N : Node_Id) return List_Id; -- List1 + function Contract_Test_Cases + (N : Node_Id) return Node_Id; -- Node2 + function Controlling_Argument (N : Node_Id) return Node_Id; -- Node1 function Conversion_OK (N : Node_Id) return Boolean; -- Flag14 + function Convert_To_Return_False + (N : Node_Id) return Boolean; -- Flag13 + function Corresponding_Aspect (N : Node_Id) return Node_Id; -- Node3 @@ -8596,7 +8688,7 @@ package Sinfo is function Import_Interface_Present (N : Node_Id) return Boolean; -- Flag16 - function In_Assertion + function In_Assertion_Expression (N : Node_Id) return Boolean; -- Flag4 function In_Present @@ -8635,6 +8727,9 @@ package Sinfo is function Is_Delayed_Aspect (N : Node_Id) return Boolean; -- Flag14 + function Is_Disabled + (N : Node_Id) return Boolean; -- Flag15 + function Is_Dynamic_Coextension (N : Node_Id) return Boolean; -- Flag18 @@ -8653,6 +8748,9 @@ package Sinfo is function Is_Folded_In_Parser (N : Node_Id) return Boolean; -- Flag4 + function Is_Ignored + (N : Node_Id) return Boolean; -- Flag9 + function Is_In_Discriminant_Check (N : Node_Id) return Boolean; -- Flag11 @@ -8863,6 +8961,9 @@ package Sinfo is function Pragmas_Before (N : Node_Id) return List_Id; -- List4 + function Pre_Post_Conditions + (N : Node_Id) return Node_Id; -- Node1 + function Prefix (N : Node_Id) return Node_Id; -- Node3 @@ -8971,12 +9072,6 @@ package Sinfo is function Source_Type (N : Node_Id) return Entity_Id; -- Node1 - function Spec_PPC_List - (N : Node_Id) return Node_Id; -- Node1 - - function Spec_CTC_List - (N : Node_Id) return Node_Id; -- Node2 - function Specification (N : Node_Id) return Node_Id; -- Node1 @@ -9205,6 +9300,9 @@ package Sinfo is procedure Set_Class_Present (N : Node_Id; Val : Boolean := True); -- Flag6 + procedure Set_Classifications + (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Comes_From_Extended_Return_Statement (N : Node_Id; Val : Boolean := True); -- Flag18 @@ -9259,12 +9357,18 @@ package Sinfo is procedure Set_Context_Pending (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Contract_Test_Cases + (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Controlling_Argument (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Conversion_OK (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Convert_To_Return_False + (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Corresponding_Aspect (N : Node_Id; Val : Node_Id); -- Node3 @@ -9574,7 +9678,7 @@ package Sinfo is procedure Set_Import_Interface_Present (N : Node_Id; Val : Boolean := True); -- Flag16 - procedure Set_In_Assertion + procedure Set_In_Assertion_Expression (N : Node_Id; Val : Boolean := True); -- Flag4 procedure Set_In_Present @@ -9613,6 +9717,12 @@ package Sinfo is procedure Set_Is_Delayed_Aspect (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Is_Disabled + (N : Node_Id; Val : Boolean := True); -- Flag15 + + procedure Set_Is_Ignored + (N : Node_Id; Val : Boolean := True); -- Flag9 + procedure Set_Is_Dynamic_Coextension (N : Node_Id; Val : Boolean := True); -- Flag18 @@ -9841,6 +9951,9 @@ package Sinfo is procedure Set_Pragmas_Before (N : Node_Id; Val : List_Id); -- List4 + procedure Set_Pre_Post_Conditions + (N : Node_Id; Val : Node_Id); -- Node1 + procedure Set_Prefix (N : Node_Id; Val : Node_Id); -- Node3 @@ -9949,12 +10062,6 @@ package Sinfo is procedure Set_Source_Type (N : Node_Id; Val : Entity_Id); -- Node1 - procedure Set_Spec_PPC_List - (N : Node_Id; Val : Node_Id); -- Node1 - - procedure Set_Spec_CTC_List - (N : Node_Id; Val : Node_Id); -- Node2 - procedure Set_Specification (N : Node_Id; Val : Node_Id); -- Node1 @@ -11348,6 +11455,13 @@ package Sinfo is 4 => False, -- unused 5 => False), -- unused + N_Raise_Expression => + (1 => False, -- unused + 2 => True, -- Name (Node2) + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + N_Generic_Subprogram_Declaration => (1 => True, -- Specification (Node1) 2 => True, -- Generic_Formal_Declarations (List2) @@ -11594,9 +11708,9 @@ package Sinfo is 5 => False), -- Etype (Node5-Sem) N_Contract => - (1 => False, -- Spec_PPC_List (Node1) - 2 => False, -- Spec_CTC_List (Node2) - 3 => False, -- unused + (1 => False, -- Pre_Post_Conditions (Node1) + 2 => False, -- Contract_Test_Cases (Node2) + 3 => False, -- Classifications (Node3) 4 => False, -- unused 5 => False), -- unused @@ -11839,6 +11953,7 @@ package Sinfo is pragma Inline (Choice_Parameter); pragma Inline (Choices); pragma Inline (Class_Present); + pragma Inline (Classifications); pragma Inline (Comes_From_Extended_Return_Statement); pragma Inline (Compile_Time_Known_Aggregate); pragma Inline (Component_Associations); @@ -11857,7 +11972,9 @@ package Sinfo is pragma Inline (Context_Installed); pragma Inline (Context_Items); pragma Inline (Context_Pending); + pragma Inline (Contract_Test_Cases); pragma Inline (Controlling_Argument); + pragma Inline (Convert_To_Return_False); pragma Inline (Conversion_OK); pragma Inline (Corresponding_Aspect); pragma Inline (Corresponding_Body); @@ -11964,7 +12081,7 @@ package Sinfo is pragma Inline (Interface_Present); pragma Inline (Includes_Infinities); pragma Inline (Import_Interface_Present); - pragma Inline (In_Assertion); + pragma Inline (In_Assertion_Expression); pragma Inline (In_Present); pragma Inline (Inherited_Discriminant); pragma Inline (Instance_Spec); @@ -11977,12 +12094,14 @@ package Sinfo is pragma Inline (Is_Component_Right_Opnd); pragma Inline (Is_Controlling_Actual); pragma Inline (Is_Delayed_Aspect); + pragma Inline (Is_Disabled); pragma Inline (Is_Dynamic_Coextension); pragma Inline (Is_Elsif); pragma Inline (Is_Entry_Barrier_Function); pragma Inline (Is_Expanded_Build_In_Place_Call); pragma Inline (Is_Finalization_Wrapper); pragma Inline (Is_Folded_In_Parser); + pragma Inline (Is_Ignored); pragma Inline (Is_In_Discriminant_Check); pragma Inline (Is_Machine_Number); pragma Inline (Is_Null_Loop); @@ -12052,6 +12171,7 @@ package Sinfo is pragma Inline (Pragma_Identifier); pragma Inline (Pragmas_After); pragma Inline (Pragmas_Before); + pragma Inline (Pre_Post_Conditions); pragma Inline (Prefix); pragma Inline (Premature_Use); pragma Inline (Present_Expr); @@ -12088,8 +12208,6 @@ package Sinfo is pragma Inline (Selector_Names); pragma Inline (Shift_Count_OK); pragma Inline (Source_Type); - pragma Inline (Spec_PPC_List); - pragma Inline (Spec_CTC_List); pragma Inline (Specification); pragma Inline (Split_PPC); pragma Inline (Statements); @@ -12143,26 +12261,27 @@ package Sinfo is pragma Inline (Set_All_Present); pragma Inline (Set_Alternatives); pragma Inline (Set_Ancestor_Part); - pragma Inline (Set_Atomic_Sync_Required); pragma Inline (Set_Array_Aggregate); pragma Inline (Set_Aspect_Rep_Item); pragma Inline (Set_Assignment_OK); pragma Inline (Set_Associated_Node); pragma Inline (Set_At_End_Proc); + pragma Inline (Set_Atomic_Sync_Required); pragma Inline (Set_Attribute_Name); pragma Inline (Set_Aux_Decls_Node); pragma Inline (Set_Backwards_OK); pragma Inline (Set_Bad_Is_Detected); - pragma Inline (Set_Body_To_Inline); pragma Inline (Set_Body_Required); - pragma Inline (Set_By_Ref); + pragma Inline (Set_Body_To_Inline); pragma Inline (Set_Box_Present); + pragma Inline (Set_By_Ref); pragma Inline (Set_Char_Literal_Value); pragma Inline (Set_Chars); pragma Inline (Set_Check_Address_Alignment); pragma Inline (Set_Choice_Parameter); pragma Inline (Set_Choices); pragma Inline (Set_Class_Present); + pragma Inline (Set_Classifications); pragma Inline (Set_Comes_From_Extended_Return_Statement); pragma Inline (Set_Compile_Time_Known_Aggregate); pragma Inline (Set_Component_Associations); @@ -12181,8 +12300,10 @@ package Sinfo is pragma Inline (Set_Context_Installed); pragma Inline (Set_Context_Items); pragma Inline (Set_Context_Pending); + pragma Inline (Set_Contract_Test_Cases); pragma Inline (Set_Controlling_Argument); pragma Inline (Set_Conversion_OK); + pragma Inline (Set_Convert_To_Return_False); pragma Inline (Set_Corresponding_Aspect); pragma Inline (Set_Corresponding_Body); pragma Inline (Set_Corresponding_Formal_Spec); @@ -12193,8 +12314,8 @@ package Sinfo is pragma Inline (Set_Dcheck_Function); pragma Inline (Set_Declarations); pragma Inline (Set_Default_Expression); - pragma Inline (Set_Default_Storage_Pool); pragma Inline (Set_Default_Name); + pragma Inline (Set_Default_Storage_Pool); pragma Inline (Set_Defining_Identifier); pragma Inline (Set_Defining_Unit_Name); pragma Inline (Set_Delay_Alternative); @@ -12210,16 +12331,16 @@ package Sinfo is pragma Inline (Set_Discriminant_Type); pragma Inline (Set_Do_Accessibility_Check); pragma Inline (Set_Do_Discriminant_Check); - pragma Inline (Set_Do_Length_Check); pragma Inline (Set_Do_Division_Check); + pragma Inline (Set_Do_Length_Check); pragma Inline (Set_Do_Overflow_Check); pragma Inline (Set_Do_Range_Check); pragma Inline (Set_Do_Storage_Check); pragma Inline (Set_Do_Tag_Check); - pragma Inline (Set_Elaborate_Present); pragma Inline (Set_Elaborate_All_Desirable); pragma Inline (Set_Elaborate_All_Present); pragma Inline (Set_Elaborate_Desirable); + pragma Inline (Set_Elaborate_Present); pragma Inline (Set_Elaboration_Boolean); pragma Inline (Set_Else_Actions); pragma Inline (Set_Else_Statements); @@ -12266,13 +12387,14 @@ package Sinfo is pragma Inline (Set_Has_Created_Identifier); pragma Inline (Set_Has_Dereference_Action); pragma Inline (Set_Has_Dynamic_Length_Check); + pragma Inline (Set_Has_Dynamic_Range_Check); pragma Inline (Set_Has_Init_Expression); pragma Inline (Set_Has_Local_Raise); - pragma Inline (Set_Has_Dynamic_Range_Check); pragma Inline (Set_Has_No_Elaboration_Code); pragma Inline (Set_Has_Pragma_Suppress_All); pragma Inline (Set_Has_Private_View); pragma Inline (Set_Has_Relative_Deadline_Pragma); + pragma Inline (Set_Has_Self_Reference); pragma Inline (Set_Has_Storage_Size_Pragma); pragma Inline (Set_Has_Wide_Character); pragma Inline (Set_Has_Wide_Wide_Character); @@ -12281,16 +12403,15 @@ package Sinfo is pragma Inline (Set_High_Bound); pragma Inline (Set_Identifier); pragma Inline (Set_Implicit_With); - pragma Inline (Set_Includes_Infinities); - pragma Inline (Set_Interface_List); - pragma Inline (Set_Interface_Present); pragma Inline (Set_Import_Interface_Present); - pragma Inline (Set_In_Assertion); + pragma Inline (Set_In_Assertion_Expression); pragma Inline (Set_In_Present); + pragma Inline (Set_Includes_Infinities); pragma Inline (Set_Inherited_Discriminant); pragma Inline (Set_Instance_Spec); + pragma Inline (Set_Interface_List); + pragma Inline (Set_Interface_Present); pragma Inline (Set_Intval); - pragma Inline (Set_Iterator_Specification); pragma Inline (Set_Is_Accessibility_Actual); pragma Inline (Set_Is_Asynchronous_Call_Block); pragma Inline (Set_Is_Boolean_Aspect); @@ -12298,12 +12419,14 @@ package Sinfo is pragma Inline (Set_Is_Component_Right_Opnd); pragma Inline (Set_Is_Controlling_Actual); pragma Inline (Set_Is_Delayed_Aspect); + pragma Inline (Set_Is_Disabled); pragma Inline (Set_Is_Dynamic_Coextension); pragma Inline (Set_Is_Elsif); pragma Inline (Set_Is_Entry_Barrier_Function); pragma Inline (Set_Is_Expanded_Build_In_Place_Call); pragma Inline (Set_Is_Finalization_Wrapper); pragma Inline (Set_Is_Folded_In_Parser); + pragma Inline (Set_Is_Ignored); pragma Inline (Set_Is_In_Discriminant_Check); pragma Inline (Set_Is_Machine_Number); pragma Inline (Set_Is_Null_Loop); @@ -12311,22 +12434,22 @@ package Sinfo is pragma Inline (Set_Is_Power_Of_2_For_Shift); pragma Inline (Set_Is_Prefixed_Call); pragma Inline (Set_Is_Protected_Subprogram_Body); - pragma Inline (Set_Has_Self_Reference); pragma Inline (Set_Is_Static_Coextension); pragma Inline (Set_Is_Static_Expression); pragma Inline (Set_Is_Subprogram_Descriptor); pragma Inline (Set_Is_Task_Allocation_Block); pragma Inline (Set_Is_Task_Master); pragma Inline (Set_Iteration_Scheme); + pragma Inline (Set_Iterator_Specification); pragma Inline (Set_Itype); pragma Inline (Set_Kill_Range_Check); + pragma Inline (Set_Label_Construct); pragma Inline (Set_Last_Bit); pragma Inline (Set_Last_Name); - pragma Inline (Set_Library_Unit); - pragma Inline (Set_Label_Construct); pragma Inline (Set_Left_Opnd); - pragma Inline (Set_Limited_View_Installed); + pragma Inline (Set_Library_Unit); pragma Inline (Set_Limited_Present); + pragma Inline (Set_Limited_View_Installed); pragma Inline (Set_Literals); pragma Inline (Set_Local_Raise_Not_OK); pragma Inline (Set_Local_Raise_Statements); @@ -12354,9 +12477,9 @@ package Sinfo is pragma Inline (Set_No_Initialization); pragma Inline (Set_No_Minimize_Eliminate); pragma Inline (Set_No_Truncation); - pragma Inline (Set_Null_Present); pragma Inline (Set_Null_Exclusion_Present); pragma Inline (Set_Null_Exclusion_In_Return_Present); + pragma Inline (Set_Null_Present); pragma Inline (Set_Null_Record_Present); pragma Inline (Set_Object_Definition); pragma Inline (Set_Of_Present); @@ -12365,8 +12488,8 @@ package Sinfo is pragma Inline (Set_Others_Discrete_Choices); pragma Inline (Set_Out_Present); pragma Inline (Set_Parameter_Associations); - pragma Inline (Set_Parameter_Specifications); pragma Inline (Set_Parameter_List_Truncated); + pragma Inline (Set_Parameter_Specifications); pragma Inline (Set_Parameter_Type); pragma Inline (Set_Parent_Spec); pragma Inline (Set_Position); @@ -12374,6 +12497,7 @@ package Sinfo is pragma Inline (Set_Pragma_Identifier); pragma Inline (Set_Pragmas_After); pragma Inline (Set_Pragmas_Before); + pragma Inline (Set_Pre_Post_Conditions); pragma Inline (Set_Prefix); pragma Inline (Set_Premature_Use); pragma Inline (Set_Present_Expr); @@ -12409,38 +12533,35 @@ package Sinfo is pragma Inline (Set_Selector_Names); pragma Inline (Set_Shift_Count_OK); pragma Inline (Set_Source_Type); - pragma Inline (Set_Spec_PPC_List); - pragma Inline (Set_Spec_CTC_List); - pragma Inline (Set_Specification); pragma Inline (Set_Split_PPC); pragma Inline (Set_Statements); pragma Inline (Set_Storage_Pool); - pragma Inline (Set_Subpool_Handle_Name); pragma Inline (Set_Strval); + pragma Inline (Set_Subpool_Handle_Name); pragma Inline (Set_Subtype_Indication); pragma Inline (Set_Subtype_Mark); pragma Inline (Set_Subtype_Marks); pragma Inline (Set_Suppress_Assignment_Checks); pragma Inline (Set_Suppress_Loop_Warnings); pragma Inline (Set_Synchronized_Present); + pragma Inline (Set_TSS_Elist); pragma Inline (Set_Tagged_Present); pragma Inline (Set_Target_Type); pragma Inline (Set_Task_Definition); pragma Inline (Set_Task_Present); pragma Inline (Set_Then_Actions); pragma Inline (Set_Then_Statements); + pragma Inline (Set_Treat_Fixed_As_Integer); pragma Inline (Set_Triggering_Alternative); pragma Inline (Set_Triggering_Statement); - pragma Inline (Set_Treat_Fixed_As_Integer); - pragma Inline (Set_TSS_Elist); pragma Inline (Set_Type_Definition); pragma Inline (Set_Unit); pragma Inline (Set_Unknown_Discriminants_Present); pragma Inline (Set_Unreferenced_In_Spec); + pragma Inline (Set_Used_Operations); pragma Inline (Set_Variant_Part); pragma Inline (Set_Variants); pragma Inline (Set_Visible_Declarations); - pragma Inline (Set_Used_Operations); pragma Inline (Set_Was_Originally_Stub); pragma Inline (Set_Withed_Body); diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index 9255395ffe4..5a6cfbaada7 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -147,14 +147,15 @@ package body Snames is case N is when Name_Ada => return Convention_Ada; when Name_Ada_Pass_By_Copy => return Convention_Ada_Pass_By_Copy; - when Name_Ada_Pass_By_Reference => - return Convention_Ada_Pass_By_Reference; + when Name_Ada_Pass_By_Reference => return + Convention_Ada_Pass_By_Reference; when Name_Assembler => return Convention_Assembler; when Name_C => return Convention_C; when Name_CIL => return Convention_CIL; when Name_COBOL => return Convention_COBOL; when Name_CPP => return Convention_CPP; when Name_Fortran => return Convention_Fortran; + when Name_Ghost => return Convention_Ghost; when Name_Intrinsic => return Convention_Intrinsic; when Name_Java => return Convention_Java; when Name_Stdcall => return Convention_Stdcall; @@ -192,6 +193,7 @@ package body Snames is when Convention_CPP => return Name_CPP; when Convention_Entry => return Name_Entry; when Convention_Fortran => return Name_Fortran; + when Convention_Ghost => return Name_Ghost; when Convention_Intrinsic => return Name_Intrinsic; when Convention_Java => return Name_Java; when Convention_Protected => return Name_Protected; @@ -293,14 +295,14 @@ package body Snames is exit when Preset_Names (P_Index) = '#'; end loop; - -- Make sure that number of names in standard table is correct. If - -- this check fails, run utility program XSNAMES to construct a new - -- properly matching version of the body. + -- Make sure that number of names in standard table is correct. If this + -- check fails, run utility program XSNAMES to construct a new properly + -- matching version of the body. pragma Assert (Discard_Name = Last_Predefined_Name); - -- Initialize the convention identifiers table with the standard - -- set of synonyms that we recognize for conventions. + -- Initialize the convention identifiers table with the standard set of + -- synonyms that we recognize for conventions. Convention_Identifiers.Init; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 5e5d1a2743c..ef983a7fbea 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -165,9 +165,12 @@ package Snames is Name_uFinalizer : constant Name_Id := N + $; Name_uIdepth : constant Name_Id := N + $; Name_uInit : constant Name_Id := N + $; + Name_uInvariant : constant Name_Id := N + $; Name_uMaster : constant Name_Id := N + $; Name_uObject : constant Name_Id := N + $; + Name_uPost : constant Name_Id := N + $; Name_uPostconditions : constant Name_Id := N + $; + Name_uPre : constant Name_Id := N + $; Name_uPriority : constant Name_Id := N + $; Name_uProcess_ATSD : constant Name_Id := N + $; Name_uRelative_Deadline : constant Name_Id := N + $; @@ -182,6 +185,7 @@ package Snames is Name_uTask_Info : constant Name_Id := N + $; Name_uTask_Name : constant Name_Id := N + $; Name_uTrace_Sp : constant Name_Id := N + $; + Name_uType_Invariant : constant Name_Id := N + $; -- Names of predefined primitives used in the expansion of dispatching -- requeue and select statements, Abort, 'Callable and 'Terminated. @@ -407,9 +411,7 @@ package Snames is Name_License : constant Name_Id := N + $; -- GNAT Name_Locking_Policy : constant Name_Id := N + $; Name_Long_Float : constant Name_Id := N + $; -- VMS - Name_Loop_Invariant : constant Name_Id := N + $; -- GNAT Name_Loop_Optimize : constant Name_Id := N + $; -- GNAT - Name_Loop_Variant : constant Name_Id := N + $; -- GNAT Name_No_Run_Time : constant Name_Id := N + $; -- GNAT Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT Name_Normalize_Scalars : constant Name_Id := N + $; @@ -469,7 +471,6 @@ package Snames is Name_Common_Object : constant Name_Id := N + $; -- GNAT Name_Complete_Representation : constant Name_Id := N + $; -- GNAT Name_Complex_Representation : constant Name_Id := N + $; -- GNAT - Name_Contract_Case : constant Name_Id := N + $; -- GNAT Name_Contract_Cases : constant Name_Id := N + $; -- GNAT Name_Controlled : constant Name_Id := N + $; Name_Convention : constant Name_Id := N + $; @@ -485,6 +486,7 @@ package Snames is -- pragma. Name_Debug : constant Name_Id := N + $; -- GNAT + Name_Depends : constant Name_Id := N + $; -- GNAT Name_Elaborate : constant Name_Id := N + $; -- Ada 83 Name_Elaborate_All : constant Name_Id := N + $; Name_Elaborate_Body : constant Name_Id := N + $; @@ -544,6 +546,8 @@ package Snames is -- of the type Pragma_Id, and the functions Get_Pragma_Id and Is_Pragma_Id -- correctly recognize and process Lock_Free. Lock_Free is a GNAT pragma. + Name_Loop_Invariant : constant Name_Id := N + $; -- GNAT + Name_Loop_Variant : constant Name_Id := N + $; -- GNAT Name_Machine_Attribute : constant Name_Id := N + $; -- GNAT Name_Main : constant Name_Id := N + $; -- GNAT Name_Main_Storage : constant Name_Id := N + $; -- GNAT @@ -637,6 +641,7 @@ package Snames is Name_COBOL : constant Name_Id := N + $; Name_CPP : constant Name_Id := N + $; Name_Fortran : constant Name_Id := N + $; + Name_Ghost : constant Name_Id := N + $; Name_Intrinsic : constant Name_Id := N + $; Name_Java : constant Name_Id := N + $; Name_Stdcall : constant Name_Id := N + $; @@ -720,6 +725,8 @@ package Snames is Name_Name : constant Name_Id := N + $; Name_NCA : constant Name_Id := N + $; Name_No : constant Name_Id := N + $; + Name_No_Access_Parameter_Allocators : constant Name_Id := N + $; + Name_No_Coextensions : constant Name_Id := N + $; Name_No_Dependence : constant Name_Id := N + $; Name_No_Dynamic_Attachment : constant Name_Id := N + $; Name_No_Dynamic_Interrupts : constant Name_Id := N + $; @@ -727,8 +734,11 @@ package Snames is Name_No_Requeue : constant Name_Id := N + $; Name_No_Requeue_Statements : constant Name_Id := N + $; Name_No_Specification_Of_Aspect : constant Name_Id := N + $; + Name_No_Standard_Allocators_After_Elaboration : constant Name_Id := N + $; Name_No_Task_Attributes : constant Name_Id := N + $; Name_No_Task_Attributes_Package : constant Name_Id := N + $; + Name_No_Use_Of_Attribute : constant Name_Id := N + $; + Name_No_Use_Of_Pragma : constant Name_Id := N + $; Name_No_Unroll : constant Name_Id := N + $; Name_No_Vector : constant Name_Id := N + $; Name_Nominal : constant Name_Id := N + $; @@ -736,6 +746,7 @@ package Snames is Name_Optional : constant Name_Id := N + $; Name_Policy : constant Name_Id := N + $; Name_Parameter_Types : constant Name_Id := N + $; + Name_Reason : constant Name_Id := N + $; Name_Reference : constant Name_Id := N + $; Name_Requires : constant Name_Id := N + $; Name_Restricted : constant Name_Id := N + $; @@ -751,6 +762,7 @@ package Snames is Name_Simple_Barriers : constant Name_Id := N + $; Name_Spec_File_Name : constant Name_Id := N + $; Name_State : constant Name_Id := N + $; + Name_Statement_Assertions : constant Name_Id := N + $; Name_Static : constant Name_Id := N + $; Name_Stack_Size : constant Name_Id := N + $; Name_Strict : constant Name_Id := N + $; @@ -1071,6 +1083,7 @@ package Snames is Name_Index_Check : constant Name_Id := N + $; Name_Length_Check : constant Name_Id := N + $; Name_Overflow_Check : constant Name_Id := N + $; + Name_Predicate_Check : constant Name_Id := N + $; -- GNAT Name_Range_Check : constant Name_Id := N + $; Name_Storage_Check : constant Name_Id := N + $; Name_Tag_Check : constant Name_Id := N + $; @@ -1204,7 +1217,6 @@ package Snames is Name_Archive_Suffix : constant Name_Id := N + $; Name_Binder : constant Name_Id := N + $; Name_Body_Suffix : constant Name_Id := N + $; - Name_Build_Slaves : constant Name_Id := N + $; Name_Builder : constant Name_Id := N + $; Name_Clean : constant Name_Id := N + $; Name_Compiler : constant Name_Id := N + $; @@ -1614,11 +1626,12 @@ package Snames is type Convention_Id is ( -- The native-to-Ada (non-foreign) conventions come first. These include - -- the ones defined in the RM, plus Stubbed. + -- the ones defined in the RM, plus Ghost and Stubbed. Convention_Ada, Convention_Intrinsic, Convention_Entry, + Convention_Ghost, Convention_Protected, Convention_Stubbed, @@ -1710,9 +1723,7 @@ package Snames is Pragma_License, Pragma_Locking_Policy, Pragma_Long_Float, - Pragma_Loop_Invariant, Pragma_Loop_Optimize, - Pragma_Loop_Variant, Pragma_No_Run_Time, Pragma_No_Strict_Aliasing, Pragma_Normalize_Scalars, @@ -1765,7 +1776,6 @@ package Snames is Pragma_Common_Object, Pragma_Complete_Representation, Pragma_Complex_Representation, - Pragma_Contract_Case, Pragma_Contract_Cases, Pragma_Controlled, Pragma_Convention, @@ -1774,6 +1784,7 @@ package Snames is Pragma_CPP_Virtual, Pragma_CPP_Vtable, Pragma_Debug, + Pragma_Depends, Pragma_Elaborate, Pragma_Elaborate_All, Pragma_Elaborate_Body, @@ -1815,6 +1826,8 @@ package Snames is Pragma_Linker_Options, Pragma_Linker_Section, Pragma_List, + Pragma_Loop_Invariant, + Pragma_Loop_Variant, Pragma_Machine_Attribute, Pragma_Main, Pragma_Main_Storage, diff --git a/gcc/ada/alfa.adb b/gcc/ada/spark_xrefs.adb index 6aceb1ba025..8049c7ee534 100644 --- a/gcc/ada/alfa.adb +++ b/gcc/ada/spark_xrefs.adb @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- A L F A -- +-- S P A R K _ X R E F S -- -- -- -- B o d y -- -- -- --- 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- -- @@ -23,25 +23,25 @@ -- -- ------------------------------------------------------------------------------ -with Output; use Output; -with Put_Alfa; +with Output; use Output; +with Put_SPARK_Xrefs; -package body Alfa is +package body SPARK_Xrefs is - ----------- - -- dalfa -- - ----------- + ------------ + -- dspark -- + ------------ - procedure dalfa is + procedure dspark is begin - -- Dump Alfa file table + -- Dump SPARK cross-reference file table - Write_Line ("Alfa File Table"); - Write_Line ("---------------"); + Write_Line ("SPARK Xrefs File Table"); + Write_Line ("----------------------"); - for Index in 1 .. Alfa_File_Table.Last loop + for Index in 1 .. SPARK_File_Table.Last loop declare - AFR : Alfa_File_Record renames Alfa_File_Table.Table (Index); + AFR : SPARK_File_Record renames SPARK_File_Table.Table (Index); begin Write_Str (" "); @@ -63,15 +63,15 @@ package body Alfa is end; end loop; - -- Dump Alfa scope table + -- Dump SPARK cross-reference scope table Write_Eol; - Write_Line ("Alfa Scope Table"); - Write_Line ("----------------"); + Write_Line ("SPARK Xrefs Scope Table"); + Write_Line ("-----------------------"); - for Index in 1 .. Alfa_Scope_Table.Last loop + for Index in 1 .. SPARK_Scope_Table.Last loop declare - ASR : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); + ASR : SPARK_Scope_Record renames SPARK_Scope_Table.Table (Index); begin Write_Str (" "); @@ -103,15 +103,15 @@ package body Alfa is end; end loop; - -- Dump Alfa cross-reference table + -- Dump SPARK cross-reference table Write_Eol; - Write_Line ("Alfa Xref Table"); - Write_Line ("---------------"); + Write_Line ("SPARK Xref Table"); + Write_Line ("----------------"); - for Index in 1 .. Alfa_Xref_Table.Last loop + for Index in 1 .. SPARK_Xref_Table.Last loop declare - AXR : Alfa_Xref_Record renames Alfa_Xref_Table.Table (Index); + AXR : SPARK_Xref_Record renames SPARK_Xref_Table.Table (Index); begin Write_Str (" "); @@ -140,24 +140,24 @@ package body Alfa is Write_Eol; end; end loop; - end dalfa; + end dspark; ---------------- -- Initialize -- ---------------- - procedure Initialize_Alfa_Tables is + procedure Initialize_SPARK_Tables is begin - Alfa_File_Table.Init; - Alfa_Scope_Table.Init; - Alfa_Xref_Table.Init; - end Initialize_Alfa_Tables; + SPARK_File_Table.Init; + SPARK_Scope_Table.Init; + SPARK_Xref_Table.Init; + end Initialize_SPARK_Tables; - ----------- - -- palfa -- - ----------- + ------------ + -- pspark -- + ------------ - procedure palfa is + procedure pspark is procedure Write_Info_Char (C : Character) renames Write_Char; -- Write one character; @@ -192,12 +192,12 @@ package body Alfa is Write_Int (N); end Write_Info_Nat; - procedure Debug_Put_Alfa is new Put_Alfa; + procedure Debug_Put_SPARK_Xrefs is new Put_SPARK_Xrefs; - -- Start of processing for palfa + -- Start of processing for pspark begin - Debug_Put_Alfa; - end palfa; + Debug_Put_SPARK_Xrefs; + end pspark; -end Alfa; +end SPARK_Xrefs; diff --git a/gcc/ada/alfa.ads b/gcc/ada/spark_xrefs.ads index 26c8247ccc6..2b0a7082954 100644 --- a/gcc/ada/alfa.ads +++ b/gcc/ada/spark_xrefs.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- A L F A -- +-- S P A R K _ X R E F S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2012, 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- -- @@ -23,42 +23,45 @@ -- -- ------------------------------------------------------------------------------ --- This package defines tables used to store information needed for the Alfa --- mode. It is used by procedures in Lib.Xref.Alfa to build the Alfa --- information before writing it out to the ALI file, and by Get_Alfa/Put_Alfa --- to read and write the text form that is used in the ALI file. +-- This package defines tables used to store information needed for the SPARK +-- mode. It is used by procedures in Lib.Xref.SPARK_Specific to build the +-- SPARK specific cross-references information before writing it out to the +-- ALI file, and by Get_SPARK_Xrefs/Put_SPARK_Xrefs to read and write the text +-- form that is used in the ALI file. with Types; use Types; with GNAT.Table; -package Alfa is +package SPARK_Xrefs is - -- Alfa information can exist in one of two forms. In the ALI file, it is - -- represented using a text format that is described in this specification. - -- Internally it is stored using three tables Alfa_Xref_Table, - -- Alfa_Scope_Table and Alfa_File_Table, which are also defined in this - -- unit. + -- SPARK cross-reference information can exist in one of two forms. In the + -- ALI file, it is represented using a text format that is described in + -- this specification. Internally it is stored using three tables + -- SPARK_Xref_Table, SPARK_Scope_Table and SPARK_File_Table, which are also + -- defined in this unit. - -- Lib.Xref.Alfa is part of the compiler. It extracts Alfa information from - -- the complete set of cross-references generated during compilation. + -- Lib.Xref.SPARK_Specific is part of the compiler. It extracts SPARK + -- cross-reference information from the complete set of cross-references + -- generated during compilation. - -- Get_Alfa reads the text lines in ALI format and populates the internal - -- tables with corresponding information. + -- Get_SPARK_Xrefs reads the text lines in ALI format and populates the + -- internal tables with corresponding information. - -- Put_Alfa reads the internal tables and generates text lines in the ALI - -- format. + -- Put_SPARK_Xrefs reads the internal tables and generates text lines in + -- the ALI format. - --------------------- - -- Alfa ALI Format -- - --------------------- + ---------------------------- + -- SPARK Xrefs ALI Format -- + ---------------------------- - -- Alfa information is generated on a unit-by-unit basis in the ALI file, - -- using lines that start with the identifying character F ("Formal"). - -- These lines are generated if one of the -gnatd.E (SPARK generation mode) - -- or gnatd.F (Why generation mode) switches is set. + -- SPARK cross-reference information is generated on a unit-by-unit basis + -- in the ALI file, using lines that start with the identifying character F + -- ("Formal"). These lines are generated if -gnatd.E or -gnatd.F (Why + -- generation mode) switches are set. - -- The Alfa information follows the cross-reference information, so it - -- needs not be read by tools like gnatbind, gnatmake etc. + -- The SPARK cross-reference information comes after the shared + -- cross-reference information, so it needs not be read by tools like + -- gnatbind, gnatmake etc. -- ------------------- -- -- Scope Section -- @@ -86,8 +89,9 @@ package Alfa is -- Note: the filename is redundant in that it could be deduced from the -- corresponding D line, but it is convenient at least for human - -- reading of the Alfa information, and means that the Alfa information - -- can stand on its own without needing other parts of the ALI file. + -- reading of the SPARK cross-reference information, and means that + -- the SPARK cross-reference information can stand on its own without + -- needing other parts of the ALI file. -- The optional unit filename is given only for subunits. @@ -187,13 +191,13 @@ package Alfa is -- Xref Table -- ---------------- - -- The following table records Alfa cross-references + -- The following table records SPARK cross-references type Xref_Index is new Int; -- Used to index values in this table. Values start at 1 and are assigned -- sequentially as entries are constructed. - type Alfa_Xref_Record is record + type SPARK_Xref_Record is record Entity_Name : String_Ptr; -- Pointer to entity name in ALI file @@ -233,8 +237,8 @@ package Alfa is -- Column number for the reference end record; - package Alfa_Xref_Table is new GNAT.Table ( - Table_Component_Type => Alfa_Xref_Record, + package SPARK_Xref_Table is new GNAT.Table ( + Table_Component_Type => SPARK_Xref_Record, Table_Index_Type => Xref_Index, Table_Low_Bound => 1, Table_Initial => 2000, @@ -251,7 +255,7 @@ package Alfa is -- Used to index values in this table. Values start at 1 and are assigned -- sequentially as entries are constructed. - type Alfa_Scope_Record is record + type SPARK_Scope_Record is record Scope_Name : String_Ptr; -- Pointer to scope name in ALI file @@ -294,8 +298,8 @@ package Alfa is -- Entity (subprogram or package) for the scope end record; - package Alfa_Scope_Table is new GNAT.Table ( - Table_Component_Type => Alfa_Scope_Record, + package SPARK_Scope_Table is new GNAT.Table ( + Table_Component_Type => SPARK_Scope_Record, Table_Index_Type => Scope_Index, Table_Low_Bound => 1, Table_Initial => 200, @@ -312,7 +316,7 @@ package Alfa is -- Used to index values in this table. Values start at 1 and are assigned -- sequentially as entries are constructed. - type Alfa_File_Record is record + type SPARK_File_Record is record File_Name : String_Ptr; -- Pointer to file name in ALI file @@ -330,8 +334,8 @@ package Alfa is -- Ending index in Scope table for this unit end record; - package Alfa_File_Table is new GNAT.Table ( - Table_Component_Type => Alfa_File_Record, + package SPARK_File_Table is new GNAT.Table ( + Table_Component_Type => SPARK_File_Record, Table_Index_Type => File_Index, Table_Low_Bound => 1, Table_Initial => 20, @@ -349,15 +353,15 @@ package Alfa is -- Subprograms -- ----------------- - procedure Initialize_Alfa_Tables; + procedure Initialize_SPARK_Tables; -- Reset tables for a new compilation - procedure dalfa; - -- Debug routine to dump internal Alfa tables. This is a raw format dump - -- showing exactly what the tables contain. + procedure dspark; + -- Debug routine to dump internal SPARK cross-reference tables. This is a + -- raw format dump showing exactly what the tables contain. - procedure palfa; - -- Debugging procedure to output contents of Alfa binary tables in the - -- format in which they appear in an ALI file. + procedure pspark; + -- Debugging procedure to output contents of SPARK cross-reference binary + -- tables in the format in which they appear in an ALI file. -end Alfa; +end SPARK_Xrefs; diff --git a/gcc/ada/alfa_test.adb b/gcc/ada/spark_xrefs_test.adb index 9e3f78d642e..6ad4de2c158 100644 --- a/gcc/ada/alfa_test.adb +++ b/gcc/ada/spark_xrefs_test.adb @@ -2,11 +2,11 @@ -- -- -- GNAT SYSTEM UTILITIES -- -- -- --- A L F A _ T E S T -- +-- S P A R K _ X R E F S _ T E S T -- -- -- -- B o d y -- -- -- --- 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- -- @@ -23,33 +23,34 @@ -- -- ------------------------------------------------------------------------------ --- This utility program is used to test proper operation of the Get_Alfa and --- Put_Alfa units. To run it, compile any source file with switch -gnatd.E or --- -gnatd.F to get an ALI file file.ALI containing Alfa information. Then run --- this utility using: +-- This utility program is used to test proper operation of the +-- Get_SPARK_Xrefs and Put_SPARK_Xrefs units. To run it, compile any source +-- file with switch -gnatd.E or -gnatd.F to get an ALI file file.ALI +-- containing SPARK information. Then run this utility using: --- Alfa_Test file.ali +-- spark_xrefs_test file.ali --- This test will read the Alfa information from the ALI file, and use --- Get_Alfa to store this in binary form in the internal tables in Alfa. Then --- Put_Alfa is used to write the information from these tables back into text --- form. This output is compared with the original Alfa information in the ALI --- file and the two should be identical. If not an error message is output. +-- This test will read the SPARK cross-reference information from the ALI +-- file, and use Get_SPARK_Xrefs to store this in binary form in the internal +-- tables in SPARK_Xrefs. Then Put_SPARK_Xrefs is used to write the +-- information from these tables back into text form. This output is compared +-- with the original SPARK cross-reference information in the ALI file and the +-- two should be identical. If not an error message is output. -with Get_Alfa; -with Put_Alfa; +with Get_SPARK_Xrefs; +with Put_SPARK_Xrefs; -with Alfa; use Alfa; -with Types; use Types; +with SPARK_Xrefs; use SPARK_Xrefs; +with Types; use Types; with Ada.Command_Line; use Ada.Command_Line; with Ada.Streams; use Ada.Streams; with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; with Ada.Text_IO; -with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.OS_Lib; use GNAT.OS_Lib; -procedure Alfa_Test is +procedure SPARK_Xrefs_Test is Infile : File_Type; Name1 : String_Access; Outfile_1 : File_Type; @@ -67,7 +68,7 @@ procedure Alfa_Test is begin if Argument_Count /= 1 then - Ada.Text_IO.Put_Line ("Usage: alfa_test FILE.ali"); + Ada.Text_IO.Put_Line ("Usage: spark_xrefs_test FILE.ali"); raise Stop; end if; @@ -143,8 +144,9 @@ begin end if; end Put_Char; - -- Subprograms used by Get_Alfa (these also copy the output to Outfile_1 - -- for later comparison with the output generated by Put_Alfa). + -- Subprograms used by Get_SPARK_Xrefs (these also copy the output to + -- Outfile_1 for later comparison with the output generated by + -- Put_SPARK_Xrefs). function Getc return Character; function Nextc return Character; @@ -190,7 +192,8 @@ begin C := Getc; end Skipc; - -- Subprograms used by Put_Alfa, which write information to Outfile_2 + -- Subprograms used by Put_SPARK_Xrefs, which write information to + -- Outfile_2. function Write_Info_Col return Positive; procedure Write_Info_Char (C : Character); @@ -247,10 +250,10 @@ begin Write_Info_Char (LF); end Write_Info_Terminate; - -- Local instantiations of Put_Alfa and Get_Alfa + -- Local instantiations of Put_SPARK_Xrefs and Get_SPARK_Xrefs - procedure Get_Alfa_Info is new Get_Alfa; - procedure Put_Alfa_Info is new Put_Alfa; + procedure Get_SPARK_Xrefs_Info is new Get_SPARK_Xrefs; + procedure Put_SPARK_Xrefs_Info is new Put_SPARK_Xrefs; -- Start of processing for Process @@ -277,15 +280,16 @@ begin Set_Index (Infile, Index (Infile) - 1); - -- Read Alfa information to internal Alfa tables, also copying Alfa info - -- to Outfile_1. + -- Read SPARK cross-reference information to internal SPARK tables, also + -- copying SPARK xrefs info to Outfile_1. - Initialize_Alfa_Tables; - Get_Alfa_Info; + Initialize_SPARK_Tables; + Get_SPARK_Xrefs_Info; - -- Write Alfa information from internal Alfa tables to Outfile_2 + -- Write SPARK cross-reference information from internal SPARK tables to + -- Outfile_2. - Put_Alfa_Info; + Put_SPARK_Xrefs_Info; -- Junk blank line (see comment at end of Lib.Writ) @@ -314,4 +318,4 @@ begin exception when Stop => null; -end Alfa_Test; +end SPARK_Xrefs_Test; diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 27173504aed..8526716e08e 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -1993,6 +1993,7 @@ package body Sprint is if not Has_Parens then Write_Char ('('); end if; + Write_Str_With_Col_Check_Sloc ("if "); Sprint_Node (Condition); Write_Str_With_Col_Check (" then "); @@ -2498,7 +2499,8 @@ package body Sprint is Write_Str_With_Col_Check_Sloc ("package "); Sprint_Node (Defining_Unit_Name (Node)); - if Nkind (Parent (Node)) = N_Package_Declaration + if Nkind_In (Parent (Node), N_Package_Declaration, + N_Generic_Package_Declaration) and then Has_Aspects (Parent (Node)) then Sprint_Aspect_Specifications @@ -2763,6 +2765,32 @@ package body Sprint is Write_Str (" => "); Sprint_Node (Condition (Node)); + when N_Raise_Expression => + declare + Has_Parens : constant Boolean := Paren_Count (Node) > 0; + + begin + -- The syntax for raise_expression does not include parentheses + -- but sometimes parentheses are required, so unconditionally + -- generate them here unless already present. + + if not Has_Parens then + Write_Char ('('); + end if; + + Write_Str_With_Col_Check_Sloc ("raise "); + Sprint_Node (Name (Node)); + + if Present (Expression (Node)) then + Write_Str_With_Col_Check (" with "); + Sprint_Node (Expression (Node)); + end if; + + if not Has_Parens then + Write_Char (')'); + end if; + end; + when N_Raise_Constraint_Error => -- This node can be used either as a subexpression or as a @@ -3277,7 +3305,10 @@ package body Sprint is -- Print aspects, except for special case of package declaration, -- where the aspects are printed inside the package specification. - if Has_Aspects (Node) and Nkind (Node) /= N_Package_Declaration then + if Has_Aspects (Node) + and then not Nkind_In (Node, N_Package_Declaration, + N_Generic_Package_Declaration) + then Sprint_Aspect_Specifications (Node, Semicolon => True); end if; diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads index 16f388d5fe6..33a184ccfbc 100644 --- a/gcc/ada/stand.ads +++ b/gcc/ada/stand.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- -- @@ -362,10 +362,23 @@ package Stand is -- identifier references to prevent cascaded errors. Any_Type : Entity_Id; - -- Used to represent some unknown type. Plays an important role in - -- avoiding cascaded errors, since any node that remains labeled with - -- this type corresponds to an already issued error message. Any_Type - -- is propagated to avoid cascaded errors from a single type error. + -- Used to represent some unknown type. Any_Type is the type of an + -- unresolved operator, and it is the type of a node where a type error + -- has been detected. Any_Type plays an important role in avoiding cascaded + -- errors, because it is compatible with all other types, and is propagated + -- to any expression that has a subexpression of Any_Type. When resolving + -- operators, Any_Type is the initial type of the node before any of its + -- candidate interpretations has been examined. If after examining all of + -- them the type is still Any_Type, the node has no possible interpretation + -- and an error can be emitted (and Any_Type will be propagated upwards). + -- + -- There is one situation in which Any_Type is used to legitimately + -- represent a case where the type is not known pre-resolution, and that + -- is for the N_Raise_Expression node. In this case, the Etype being set to + -- Any_Type is normal and does not represent an error. In particular, it is + -- compatible with the type of any constituent of the enclosing expression, + -- if any. The type is eventually replaced with the type of the context, + -- which plays no role in the resolution of the Raise_Expression. Any_Access : Entity_Id; -- Used to resolve the overloaded literal NULL diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb index 886043bd8c3..7b78a164395 100644 --- a/gcc/ada/stylesw.adb +++ b/gcc/ada/stylesw.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- -- @@ -161,10 +161,12 @@ package body Stylesw is Add ('b', Style_Check_Blanks_At_End); Add ('B', Style_Check_Boolean_And_Or); - if Style_Check_Comments_Spacing = 2 then - Add ('c', Style_Check_Comments); - elsif Style_Check_Comments_Spacing = 1 then - Add ('C', Style_Check_Comments); + if Style_Check_Comments then + if Style_Check_Comments_Spacing = 2 then + Add ('c', Style_Check_Comments); + elsif Style_Check_Comments_Spacing = 1 then + Add ('C', Style_Check_Comments); + end if; end if; Add ('d', Style_Check_DOS_Line_Terminator); diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 2ac486bd30f..96416a5e546 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.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- -- @@ -147,6 +147,10 @@ package body Switch.C is First_Char : Positive; -- Marks start of switch to be stored + First_Ptr : Positive; + -- Save position of first character after -gnatd (for checking that + -- debug flags that must come first are first, in particular -gnatd.b), + begin Ptr := Switch_Chars'First; @@ -274,30 +278,31 @@ package body Switch.C is case C is + -- -gnata (assertions enabled) + when 'a' => Ptr := Ptr + 1; Assertions_Enabled := True; - Debug_Pragmas_Enabled := True; - -- Processing for A switch + -- -gnatA (disregard gnat.adc) when 'A' => Ptr := Ptr + 1; Config_File := False; - -- Processing for b switch + -- -gnatb (brief messages to stderr) when 'b' => Ptr := Ptr + 1; Brief_Output := True; - -- Processing for B switch + -- -gnatB (assume no invalid values) when 'B' => Ptr := Ptr + 1; Assume_No_Invalid_Values := True; - -- Processing for c switch + -- -gnatc (check syntax and semantics only) when 'c' => if not First_Switch then @@ -308,7 +313,7 @@ package body Switch.C is Ptr := Ptr + 1; Operating_Mode := Check_Semantics; - -- Processing for C switch + -- -gnatC (Generate CodePeer information) when 'C' => Ptr := Ptr + 1; @@ -326,11 +331,12 @@ package body Switch.C is Warning_Mode := Suppress; end if; - -- Processing for d switch + -- -gnatd (compiler debug options) when 'd' => Store_Switch := False; Dot := False; + First_Ptr := Ptr + 1; -- Note: for the debug switch, the remaining characters in this -- switch field must all be debug flags, since all valid switch @@ -347,9 +353,25 @@ package body Switch.C is C in 'a' .. 'z' or else C in 'A' .. 'Z' then + -- Case of dotted flag + if Dot then Set_Dotted_Debug_Flag (C); Store_Compilation_Switch ("-gnatd." & C); + + -- Special check, -gnatd.b must come first + + if C = 'b' + and then (Ptr /= First_Ptr + 1 + or else not First_Switch) + then + Osint.Fail + ("-gnatd.b must be first if combined " + & "with other switches"); + end if; + + -- Not a dotted flag + else Set_Debug_Flag (C); Store_Compilation_Switch ("-gnatd" & C); @@ -367,7 +389,7 @@ package body Switch.C is return; - -- Processing for D switch + -- -gnatD (debug expanded code) when 'D' => Ptr := Ptr + 1; @@ -403,6 +425,8 @@ package body Switch.C is -- -gnatea (initial delimiter of explicit switches) + -- This is an internal switch + -- All switches that come before -gnatea have been added by -- the GCC driver and are not stored in the ALI file. -- See also -gnatez below. @@ -562,6 +586,8 @@ package body Switch.C is -- -gnateO= (object path file) + -- This is an internal switch + when 'O' => Store_Switch := False; Ptr := Ptr + 1; @@ -570,7 +596,6 @@ package body Switch.C is if Ptr >= Max or else Switch_Chars (Ptr) /= '=' then Bad_Switch ("-gnateO"); - else Object_Path_File_Name := new String'(Switch_Chars (Ptr + 1 .. Max)); @@ -621,12 +646,52 @@ package body Switch.C is Generate_SCO_Instance_Table := True; Ptr := Ptr + 1; - -- -gnatet (generate target dependent information) + -- -gnatet (write target dependent information) when 't' => - Generate_Target_Dependent_Info := True; + if not First_Switch then + Osint.Fail + ("-gnatet must not be combined with other switches"); + end if; + + -- Check for '=' + + Ptr := Ptr + 1; + + if Ptr >= Max or else Switch_Chars (Ptr) /= '=' then + Bad_Switch ("-gnatet"); + else + Target_Dependent_Info_Write_Name := + new String'(Switch_Chars (Ptr + 1 .. Max)); + end if; + + return; + + -- -gnateT (read target dependent information) + + when 'T' => + if not First_Switch then + Osint.Fail + ("-gnateT must not be combined with other switches"); + end if; + + -- Check for '=' + Ptr := Ptr + 1; + if Ptr >= Max or else Switch_Chars (Ptr) /= '=' then + Bad_Switch ("-gnateT"); + else + -- This parameter was stored by Set_Targ earlier + + pragma Assert + (Target_Dependent_Info_Read_Name.all = + Switch_Chars (Ptr + 1 .. Max)); + null; + end if; + + return; + -- -gnateV (validity checks on parameters) when 'V' => @@ -641,6 +706,8 @@ package body Switch.C is -- -gnatez (final delimiter of explicit switches) + -- This is an internal switch + -- All switches that come after -gnatez have been added by -- the GCC driver and are not stored in the ALI file. See -- also -gnatea above. @@ -668,14 +735,14 @@ package body Switch.C is Ptr := Ptr + 1; All_Errors_Mode := True; - -- Processing for F switch + -- -gnatF (overflow of predefined float types) when 'F' => Ptr := Ptr + 1; External_Name_Exp_Casing := Uppercase; External_Name_Imp_Casing := Uppercase; - -- Processing for g switch + -- -gnatg (GNAT implementation mode) when 'g' => Ptr := Ptr + 1; @@ -683,6 +750,7 @@ package body Switch.C is Identifier_Character_Set := 'n'; System_Extend_Unit := Empty; Warning_Mode := Treat_As_Error; + Style_Check_Main := True; -- Set Ada 2012 mode explicitly. We don't want to rely on the -- implicit setting here, since for example, we want @@ -696,7 +764,7 @@ package body Switch.C is Set_GNAT_Mode_Warnings; Set_GNAT_Style_Check_Options; - -- Processing for G switch + -- -gnatG (output generated code) when 'G' => Ptr := Ptr + 1; @@ -709,13 +777,13 @@ package body Switch.C is Sprint_Line_Limit := Nat'Max (Sprint_Line_Limit, 40); end if; - -- Processing for h switch + -- -gnath (help information) when 'h' => Ptr := Ptr + 1; Usage_Requested := True; - -- Processing for i switch + -- -gnati (character set) when 'i' => if Ptr = Max then @@ -740,26 +808,26 @@ package body Switch.C is Bad_Switch ("-gnati" & Switch_Chars (Ptr .. Max)); end if; - -- Processing for I switch + -- -gnatI (ignore representation clauses) when 'I' => Ptr := Ptr + 1; Ignore_Rep_Clauses := True; - -- Processing for j switch + -- -gnatj (messages in limited length lines) when 'j' => Ptr := Ptr + 1; Scan_Nat (Switch_Chars, Max, Ptr, Error_Msg_Line_Length, C); - -- Processing for k switch + -- -gnatk (limit file name length) when 'k' => Ptr := Ptr + 1; Scan_Pos (Switch_Chars, Max, Ptr, Maximum_File_Name_Length, C); - -- Processing for l switch + -- -gnatl (output full source) when 'l' => Ptr := Ptr + 1; @@ -777,19 +845,19 @@ package body Switch.C is end if; end if; - -- Processing for L switch + -- -gnatL (corresponding source text) when 'L' => Ptr := Ptr + 1; Dump_Source_Text := True; - -- Processing for m switch + -- -gnatm (max number or errors/warnings) when 'm' => Ptr := Ptr + 1; Scan_Nat (Switch_Chars, Max, Ptr, Maximum_Messages, C); - -- Processing for n switch + -- -gnatn (enable pragma Inline) when 'n' => Ptr := Ptr + 1; @@ -806,14 +874,14 @@ package body Switch.C is end if; end if; - -- Processing for N switch + -- -gnatN (obsolescent) when 'N' => Ptr := Ptr + 1; Inline_Active := True; Front_End_Inlining := True; - -- Processing for o switch + -- -gnato (overflow checks) when 'o' => Ptr := Ptr + 1; @@ -852,14 +920,16 @@ package body Switch.C is end if; end if; - -- Processing for O switch + -- -gnatO (specify name of the object file) + + -- This is an internal switch when 'O' => Store_Switch := False; Ptr := Ptr + 1; Output_File_Name_Present := True; - -- Processing for p switch + -- -gnatp (suppress all checks) when 'p' => Ptr := Ptr + 1; @@ -890,32 +960,32 @@ package body Switch.C is Opt.Suppress_Checks := True; end if; - -- Processing for P switch + -- -gnatP (periodic poll) when 'P' => Ptr := Ptr + 1; Polling_Required := True; - -- Processing for q switch + -- -gnatq (don't quit) when 'q' => Ptr := Ptr + 1; Try_Semantics := True; - -- Processing for Q switch + -- -gnatQ (always write ALI file) when 'Q' => Ptr := Ptr + 1; Force_ALI_Tree_File := True; Try_Semantics := True; - -- Processing for r switch + -- -gnatr (restrictions as warnings) when 'r' => Ptr := Ptr + 1; Treat_Restrictions_As_Warnings := True; - -- Processing for R switch + -- -gnatR (list rep. info) when 'R' => Back_Annotate_Rep_Info := True; @@ -942,7 +1012,7 @@ package body Switch.C is Ptr := Ptr + 1; end loop; - -- Processing for s switch + -- -gnats (syntax check only) when 's' => if not First_Switch then @@ -953,44 +1023,44 @@ package body Switch.C is Ptr := Ptr + 1; Operating_Mode := Check_Syntax; - -- Processing for S switch + -- -gnatS (print package Standard) when 'S' => Print_Standard := True; Ptr := Ptr + 1; - -- Processing for t switch + -- -gnatt (output tree) when 't' => Ptr := Ptr + 1; Tree_Output := True; Back_Annotate_Rep_Info := True; - -- Processing for T switch + -- -gnatT (change start of internal table sizes) when 'T' => Ptr := Ptr + 1; Scan_Pos (Switch_Chars, Max, Ptr, Table_Factor, C); - -- Processing for u switch + -- -gnatu (list units for compilation) when 'u' => Ptr := Ptr + 1; List_Units := True; - -- Processing for U switch + -- -gnatU (unique tags) when 'U' => Ptr := Ptr + 1; Unique_Error_Tag := True; - -- Processing for v switch + -- -gnatv (verbose mode) when 'v' => Ptr := Ptr + 1; Verbose_Mode := True; - -- Processing for V switch + -- -gnatV (validity checks) when 'V' => Store_Switch := False; @@ -1020,7 +1090,7 @@ package body Switch.C is Ptr := Max + 1; - -- Processing for w switch + -- -gnatw (warning modes) when 'w' => Store_Switch := False; @@ -1060,7 +1130,7 @@ package body Switch.C is return; - -- Processing for W switch + -- -gnatW (wide character encoding method) when 'W' => Ptr := Ptr + 1; @@ -1085,13 +1155,13 @@ package body Switch.C is Ptr := Ptr + 1; - -- Processing for x switch + -- -gnatx (suppress cross-ref information) when 'x' => Ptr := Ptr + 1; Xref_Active := False; - -- Processing for X switch + -- -gnatX (language extensions) when 'X' => Ptr := Ptr + 1; @@ -1099,10 +1169,11 @@ package body Switch.C is Ada_Version := Ada_Version_Type'Last; Ada_Version_Explicit := Ada_Version_Type'Last; - -- Processing for y switch + -- -gnaty (style checks) when 'y' => Ptr := Ptr + 1; + Style_Check_Main := True; if Ptr > Max then Set_Default_Style_Check_Options; @@ -1145,7 +1216,7 @@ package body Switch.C is end; end if; - -- Processing for z switch + -- -gnatz (stub generation) when 'z' => @@ -1185,7 +1256,7 @@ package body Switch.C is Osint.Fail ("only one -gnatz* switch allowed"); end if; - -- Processing for Z switch + -- -gnatZ (obsolescent) when 'Z' => Ptr := Ptr + 1; @@ -1196,7 +1267,7 @@ package body Switch.C is -- version switch is added, Switch.M.Normalize_Compiler_Switches -- must be updated. - -- Processing for 83 switch + -- -gnat83 when '8' => if Ptr = Max then @@ -1213,7 +1284,7 @@ package body Switch.C is Ada_Version_Explicit := Ada_Version; end if; - -- Processing for 95 switch + -- -gnat95 when '9' => if Ptr = Max then @@ -1230,7 +1301,7 @@ package body Switch.C is Ada_Version_Explicit := Ada_Version; end if; - -- Processing for 05 switch + -- -gnat05 when '0' => if Ptr = Max then @@ -1247,7 +1318,7 @@ package body Switch.C is Ada_Version_Explicit := Ada_Version; end if; - -- Processing for 12 switch + -- -gnat12 when '1' => if Ptr = Max then @@ -1264,7 +1335,7 @@ package body Switch.C is Ada_Version_Explicit := Ada_Version; end if; - -- Processing for 2005 and 2012 switches + -- -gnat2005 and -gnat2012 when '2' => if Ptr > Max - 3 then diff --git a/gcc/ada/system-vms-ia64.ads b/gcc/ada/system-vms-ia64.ads index bdf2b2cb7ab..2f1c27c9ff1 100644 --- a/gcc/ada/system-vms-ia64.ads +++ b/gcc/ada/system-vms-ia64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- -- -- --- 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 -- @@ -144,6 +144,7 @@ private Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := True; + VAX_Float : constant Boolean := False; Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := True; diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 5ed84083a8a..ce3da1cb737 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2012, 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- -- @@ -68,6 +68,7 @@ package body Targparm is SSL, -- Suppress_Standard_Library UAM, -- Use_Ada_Main_Program_Name VMS, -- OpenVMS + VXF, -- VAX Float ZCD); -- ZCX_By_Default Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False); @@ -105,6 +106,7 @@ package body Targparm is SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library"; UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name"; VMS_Str : aliased constant Source_Buffer := "OpenVMS"; + VXF_Str : aliased constant Source_Buffer := "VAX_Float"; ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default"; -- The following defines a set of pointers to the above strings, @@ -142,6 +144,7 @@ package body Targparm is SSL_Str'Access, UAM_Str'Access, VMS_Str'Access, + VXF_Str'Access, ZCD_Str'Access); ----------------------- @@ -600,6 +603,7 @@ package body Targparm is when SNZ => Signed_Zeros_On_Target := Result; when UAM => Use_Ada_Main_Program_Name_On_Target := Result; when VMS => OpenVMS_On_Target := Result; + when VXF => VAX_Float_On_Target := Result; when ZCD => ZCX_By_Default_On_Target := Result; goto Line_Loop_Continue; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index 52a6ee45235..17c934a0ab1 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -206,6 +206,9 @@ package Targparm is OpenVMS_On_Target : Boolean := False; -- Set to True if target is OpenVMS + VAX_Float_On_Target : Boolean := False; + -- Set to True if target float format is VAX Float + RTX_RTSS_Kernel_Module_On_Target : Boolean := False; -- Set to True if target is RTSS module for RTX @@ -436,7 +439,7 @@ package Targparm is -- the source program may not contain explicit 64-bit shifts. In addition, -- the code generated for packed arrays will avoid the use of long shifts. - Support_Nondefault_SSO_On_Target : Boolean := False; + Support_Nondefault_SSO_On_Target : Boolean := True; -- If True, the back end supports the non-default Scalar_Storage_Order -- (i.e. allows non-confirming Scalar_Storage_Order attribute definition -- clauses). diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 3343d7c81c5..01ea5d56cbd 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.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- -- @@ -174,9 +174,8 @@ package body Tbuild is Attribute_Name => Attribute_Name); begin - pragma Assert (Attribute_Name = Name_Address - or else - Attribute_Name = Name_Unrestricted_Access); + pragma Assert (Nam_In (Attribute_Name, Name_Address, + Name_Unrestricted_Access)); Set_Must_Be_Byte_Aligned (N, True); return N; end Make_Byte_Aligned_Attribute_Reference; diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads index 1f5b90059eb..3692d1ec650 100644 --- a/gcc/ada/tree_io.ads +++ b/gcc/ada/tree_io.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- -- @@ -47,7 +47,7 @@ package Tree_IO is Tree_Format_Error : exception; -- Raised if a format error is detected in the input file - ASIS_Version_Number : constant := 30; + ASIS_Version_Number : constant := 32; -- ASIS Version. This is used to check for consistency between the compiler -- used to generate trees and an ASIS application that is reading the -- trees. It must be incremented whenever a change is made to the tree @@ -59,6 +59,9 @@ package Tree_IO is -- 29 Changes in Sem_Ch3 (tree copying in case of discriminant constraint -- for concurrent types). -- 30 Add Check_Float_Overflow boolean to tree file + -- 31 Remove read/write of Debug_Pragmas_Disabled/Debug_Pragmas_Enabled + -- 32 Change the way entities are changed through Next_Entity field in + -- the hierarchy of child units procedure Tree_Read_Initialize (Desc : File_Descriptor); -- Called to initialize reading of a tree file. This call must be made diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 64dbf2dd536..4de6b8529f1 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.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- -- @@ -215,6 +215,27 @@ package body Treepr is -- descendents are to be printed. Prefix_Str is to be added to all -- printed lines. + ------- + -- p -- + ------- + + function p (N : Union_Id) return Node_Or_Entity_Id is + begin + case N is + when List_Low_Bound .. List_High_Bound - 1 => + return Nlists.Parent (List_Id (N)); + + when Node_Range => + return Atree.Parent (Node_Or_Entity_Id (N)); + + when others => + Write_Int (Int (N)); + Write_Str (" is not a Node_Id or List_Id value"); + Write_Eol; + return Empty; + end case; + end p; + -------- -- pe -- -------- diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads index 212c49155b5..d33e93bb21e 100644 --- a/gcc/ada/treepr.ads +++ b/gcc/ada/treepr.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- -- @@ -62,16 +62,27 @@ package Treepr is -- The following debugging procedures are intended to be called from gdb + function p (N : Union_Id) return Node_Or_Entity_Id; + pragma Export (Ada, p); + -- Returns parent of a list or node (depending on the value of N). If N + -- is neither a list nor a node id, then prints a message to that effect + -- and returns Empty. + + procedure pn (N : Union_Id); + -- Prints a node, node list, uint, or anything else that falls under + -- the definition of Union_Id. Historically this was only for printing + -- nodes, hence the name. + procedure pp (N : Union_Id); pragma Export (Ada, pp); - -- Prints a node, node list, uint, or anything else that falls under - -- Union_Id. + -- Identical to pn, present for historical reasons procedure ppp (N : Node_Id); pragma Export (Ada, ppp); -- Same as Print_Node_Subtree - -- The following are no longer needed; you can use pp or ppp instead + -- The following are no longer really needed, now that pn will print + -- anything you throw at it! procedure pe (E : Elist_Id); pragma Export (Ada, pe); @@ -84,10 +95,6 @@ package Treepr is -- on the left and add a minus sign. This just saves some typing in the -- debugger. - procedure pn (N : Union_Id); - pragma Export (Ada, pn); - -- Same as pp - procedure pt (N : Node_Id); pragma Export (Ada, pt); -- Same as ppp diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads index be0162d6b44..5e27cbd2e58 100644 --- a/gcc/ada/ttypes.ads +++ b/gcc/ada/ttypes.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- -- @@ -26,7 +26,8 @@ -- This package contains constants describing target properties with Types; use Types; -with Get_Targ; use Get_Targ; +with Get_Targ; +with Set_Targ; package Ttypes is @@ -92,18 +93,6 @@ package Ttypes is -- than referencing System.Storage_Unit, or Standard'Storage_Unit, both of -- which would yield the host value. - ---------------------------------------------- - -- Target-Dependent Information in ALI File -- - ---------------------------------------------- - - -- If the flag Generate_Target_Dependent_Info is set (e.g. by use of the - -- -gnatT switch), then the ALI file contains T lines representing each of - -- the constants defined in this package (see Lib-Writ spec for details). - - -- These T lines use a code consisting of four upper case letters to - -- identify the constant whose value is output. These four letter codes - -- may be found as a comment in the declaration of each constant. - --------------------------------------------------- -- Target-Dependent Values for Types in Standard -- --------------------------------------------------- @@ -113,65 +102,64 @@ package Ttypes is -- example, on some machines, Short_Float may be the same as Float, and -- Long_Long_Float may be the same as Long_Float. - Standard_Short_Short_Integer_Size : constant Pos := -- SINS - Get_Char_Size; - Standard_Short_Short_Integer_Width : constant Pos := -- SINW - Width_From_Size + Standard_Short_Short_Integer_Size : constant Pos := + Set_Targ.Char_Size; + Standard_Short_Short_Integer_Width : constant Pos := + Get_Targ.Width_From_Size (Standard_Short_Short_Integer_Size); - Standard_Short_Integer_Size : constant Pos := -- SHIS - Get_Short_Size; - Standard_Short_Integer_Width : constant Pos := -- SHIW - Width_From_Size + Standard_Short_Integer_Size : constant Pos := + Set_Targ.Short_Size; + Standard_Short_Integer_Width : constant Pos := + Get_Targ.Width_From_Size (Standard_Short_Integer_Size); - Standard_Integer_Size : constant Pos := -- INTS - Get_Int_Size; - Standard_Integer_Width : constant Pos := -- INTW - Width_From_Size + Standard_Integer_Size : constant Pos := + Set_Targ.Int_Size; + Standard_Integer_Width : constant Pos := + Get_Targ.Width_From_Size (Standard_Integer_Size); - Standard_Long_Integer_Size : constant Pos := -- LINS - Get_Long_Size; - Standard_Long_Integer_Width : constant Pos := -- LINW - Width_From_Size + Standard_Long_Integer_Size : constant Pos := + Set_Targ.Long_Size; + Standard_Long_Integer_Width : constant Pos := + Get_Targ.Width_From_Size (Standard_Long_Integer_Size); - Standard_Long_Long_Integer_Size : constant Pos := -- LLIS - Get_Long_Long_Size; - Standard_Long_Long_Integer_Width : constant Pos := -- LLIW - Width_From_Size + Standard_Long_Long_Integer_Size : constant Pos := + Set_Targ.Long_Long_Size; + Standard_Long_Long_Integer_Width : constant Pos := + Get_Targ.Width_From_Size (Standard_Long_Long_Integer_Size); - Standard_Short_Float_Size : constant Pos := -- SFLS - Get_Float_Size; - Standard_Short_Float_Digits : constant Pos := -- SFLD - Digits_From_Size + Standard_Short_Float_Size : constant Pos := + Set_Targ.Float_Size; + Standard_Short_Float_Digits : constant Pos := + Get_Targ.Digits_From_Size (Standard_Short_Float_Size); - Standard_Float_Size : constant Pos := -- FLTS - Get_Float_Size; - Standard_Float_Digits : constant Pos := -- FLTD - Digits_From_Size + Standard_Float_Size : constant Pos := + Set_Targ.Float_Size; + Standard_Float_Digits : constant Pos := + Get_Targ.Digits_From_Size (Standard_Float_Size); - Standard_Long_Float_Size : constant Pos := -- LFLS - Get_Double_Size; - Standard_Long_Float_Digits : constant Pos := -- LFLD - Digits_From_Size + Standard_Long_Float_Size : constant Pos := + Set_Targ.Double_Size; + Standard_Long_Float_Digits : constant Pos := + Get_Targ.Digits_From_Size (Standard_Long_Float_Size); - Standard_Long_Long_Float_Size : constant Pos := -- LLFS - Get_Long_Double_Size; - Standard_Long_Long_Float_Digits : constant Pos := -- LLFD - Digits_From_Size + Standard_Long_Long_Float_Size : constant Pos := + Set_Targ.Long_Double_Size; + Standard_Long_Long_Float_Digits : constant Pos := + Get_Targ.Digits_From_Size (Standard_Long_Long_Float_Size); - Standard_Character_Size : constant Pos := -- CHAS - Get_Char_Size; + Standard_Character_Size : constant Pos := Set_Targ.Char_Size; - Standard_Wide_Character_Size : constant Pos := 16; -- WCHS - Standard_Wide_Wide_Character_Size : constant Pos := 32; -- WWCS + Standard_Wide_Character_Size : constant Pos := 16; + Standard_Wide_Wide_Character_Size : constant Pos := 32; -- Standard wide character sizes -- Note: there is no specific control over the representation of @@ -187,19 +175,18 @@ package Ttypes is -- Target-Dependent Values for Types in System -- ------------------------------------------------- - System_Address_Size : constant Pos := Get_Pointer_Size; -- ADRS + System_Address_Size : constant Pos := Set_Targ.Pointer_Size; -- System.Address'Size (also size of all thin pointers) - System_Max_Binary_Modulus_Power : constant Pos := -- MBMP + System_Max_Binary_Modulus_Power : constant Pos := Standard_Long_Long_Integer_Size; - System_Max_Nonbinary_Modulus_Power : constant Pos := -- MNMP - Standard_Integer_Size; + System_Max_Nonbinary_Modulus_Power : constant Pos := Standard_Integer_Size; - System_Storage_Unit : constant Pos := Get_Bits_Per_Unit; -- SUNI - System_Word_Size : constant Pos := Get_Bits_Per_Word; -- WRDS + System_Storage_Unit : constant Pos := Set_Targ.Bits_Per_Unit; + System_Word_Size : constant Pos := Set_Targ.Bits_Per_Word; - System_Tick_Nanoseconds : constant Pos := 1_000_000_000; -- TICK + System_Tick_Nanoseconds : constant Pos := 1_000_000_000; -- Value of System.Tick in nanoseconds. At the moment, this is a fixed -- constant (with value of 1.0 seconds), but later we should add this -- value to the GCC configuration file so that its value can be made @@ -209,25 +196,25 @@ package Ttypes is -- Target-Dependent Values for Types in Interfaces -- ----------------------------------------------------- - Interfaces_Wchar_T_Size : constant Pos := Get_Wchar_T_Size; -- WCTS + Interfaces_Wchar_T_Size : constant Pos := Set_Targ.Wchar_T_Size; ---------------------------------------- -- Other Target-Dependent Definitions -- ---------------------------------------- - Maximum_Alignment : constant Pos := Get_Maximum_Alignment; -- MAXA + Maximum_Alignment : constant Pos := Set_Targ.Maximum_Alignment; -- The maximum alignment, in storage units, that an object or type may -- require on the target machine. - System_Allocator_Alignment : constant Pos := -- ALLA - Get_System_Allocator_Alignment; + System_Allocator_Alignment : constant Pos := + Set_Targ.System_Allocator_Alignment; -- The alignment in storage units of addresses returned by malloc - Max_Unaligned_Field : constant Pos := Get_Max_Unaligned_Field; -- MUNF + Max_Unaligned_Field : constant Pos := Set_Targ.Max_Unaligned_Field; -- The maximum supported size in bits for a field that is not aligned -- on a storage unit boundary. - Bytes_Big_Endian : Boolean := Get_Bytes_BE /= 0; -- BEND + Bytes_Big_Endian : Boolean := Set_Targ.Bytes_BE /= 0; -- Important note: for Ada purposes, the important setting is the bytes -- endianness (Bytes_Big_Endian), not the bits value (Bits_Big_Endian). -- This is because Ada bit addressing must be compatible with the byte @@ -237,22 +224,26 @@ package Ttypes is -- and thus relevant only to the back end. Note that this is a variable -- rather than a constant, since it can be modified (flipped) by -gnatd8. - Target_Strict_Alignment : Boolean := -- STRA - Get_Strict_Alignment /= 0; + Target_Strict_Alignment : Boolean := + Set_Targ.Strict_Alignment /= 0; -- True if instructions will fail if data is misaligned. Note that this -- is a variable rather than a constant since it can be modified (set to -- True) if the debug flag -gnatd.A is used. - Target_Double_Float_Alignment : constant Nat := -- DFLA - Get_Double_Float_Alignment; + Target_Double_Float_Alignment : constant Nat := + Set_Targ.Double_Float_Alignment; -- The default alignment of "double" floating-point types, i.e. floating -- point types whose size is equal to 64 bits, or 0 if this alignment is - -- not specifically capped. + -- not lower than the largest power of 2 multiple of System.Storage_Unit + -- that does not exceed either the object size of the type or the maximum + -- allowed alignment. - Target_Double_Scalar_Alignment : constant Nat := -- DSCA - Get_Double_Scalar_Alignment; + Target_Double_Scalar_Alignment : constant Nat := + Set_Targ.Double_Scalar_Alignment; -- The default alignment of "double" or larger scalar types, i.e. scalar -- types whose size is greater or equal to 64 bits, or 0 if this alignment - -- is not specifically capped. + -- is not lower than the largest power of 2 multiple of System.Storage_Unit + -- that does not exceed either the object size of the type or the maximum + -- allowed alignment. end Ttypes; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index a63e10c97e8..9ec2d5e5984 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.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- -- @@ -102,8 +102,8 @@ package Types is -- Graphic characters, as defined in ARM subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR; - -- Line terminator characters (LF, VT, FF, CR). For further details, - -- see the extensive discussion of line termination in the Sinput spec. + -- Line terminator characters (LF, VT, FF, CR). For further details, see + -- the extensive discussion of line termination in the Sinput spec. subtype Upper_Half_Character is Character range Character'Val (16#80#) .. Character'Val (16#FF#); @@ -577,7 +577,7 @@ package Types is -- the source file (we assume that the host system has the concept of a -- file time stamp which is modified when a file is modified). These -- time stamps are used to ensure consistency of the set of units that - -- constitutes a library. Time stamps are 12 character strings with + -- constitutes a library. Time stamps are 14-character strings with -- with the following format: -- YYYYMMDDHHMMSS @@ -666,15 +666,16 @@ package Types is Index_Check : constant := 8; Length_Check : constant := 9; Overflow_Check : constant := 10; - Range_Check : constant := 11; - Storage_Check : constant := 12; - Tag_Check : constant := 13; - Validity_Check : constant := 14; + Predicate_Check : constant := 11; + Range_Check : constant := 12; + Storage_Check : constant := 13; + Tag_Check : constant := 14; + Validity_Check : constant := 15; -- Values used to represent individual predefined checks (including the -- setting of Atomic_Synchronization, which is implemented internally using - -- a "check" whose name is Atomic_Synchronization. + -- a "check" whose name is Atomic_Synchronization). - All_Checks : constant := 15; + All_Checks : constant := 16; -- Value used to represent All_Checks value subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks; diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index 77a36ca095f..d450164ee4c 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -94,6 +94,7 @@ gcc -c ^ GNAT COMPILE -gnatn2 ^ /INLINE=PRAGMA_LEVEL_2 -gnatN ^ /INLINE=FULL -gnato ^ /CHECKS=OVERFLOW +-gnato? ^ /OVERFLOW_CHECKS=? -gnato?? ^ /OVERFLOW_CHECKS=?? -gnatp ^ /CHECKS=SUPPRESS_ALL -gnat-p ^ /CHECKS=UNSUPPRESS_ALL diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads index 54fe8ffe14d..d9d63eaeca5 100644 --- a/gcc/ada/urealp.ads +++ b/gcc/ada/urealp.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- -- @@ -46,7 +46,7 @@ package Urealp is -- use the UR_Eq function). -- A Ureal value represents an arbitrary precision universal real value, - -- stored internally using four components + -- stored internally using four components: -- the numerator (Uint, always non-negative) -- the denominator (Uint, always non-zero, always positive if base = 0) @@ -125,7 +125,7 @@ package Urealp is -- Returns value 10.0 ** 36 function Ureal_M_10_36 return Ureal; - -- Returns value -(10.0 + -- Returns value -10.0 ** 36 ----------------- -- Subprograms -- diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 08a41c28069..dd0f2af33e4 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -167,10 +167,7 @@ begin Write_Switch_Char ("Dnn"); Write_Line ("Debug expanded generated code (max line length = nn)"); - -- Line for -gnatea switch - - Write_Switch_Char ("ea"); - Write_Line ("Delimiter for automatically added switches (internal switch)"); + -- No line for -gnatea : internal switch -- Line for -gnateA switch @@ -227,10 +224,7 @@ begin Write_Switch_Char ("em=?"); Write_Line ("Specify mapping file, e.g. -gnatem=mapping"); - -- Line for -gnateO=? - - Write_Switch_Char ("eO=?"); - Write_Line ("Specify an object path file (internal switch)"); + -- No line for -gnateO=? : internal switch -- Line for -gnatep switch @@ -249,8 +243,13 @@ begin -- Line for -gnatet switch - Write_Switch_Char ("et"); - Write_Line ("Generate target dependent information in ALI file"); + Write_Switch_Char ("et=?"); + Write_Line ("Write target dependent information file ?, e.g. gnatet=tdf"); + + -- Line for -gnateT switch + + Write_Switch_Char ("eT=?"); + Write_Line ("Read target dependent information file ?, e.g. gnateT=tdf"); -- Line for -gnateV switch @@ -262,10 +261,7 @@ begin Write_Switch_Char ("eY"); Write_Line ("Ignore all Style_Checks pragmas in source"); - -- Line for -gnatez switch - - Write_Switch_Char ("ez"); - Write_Line ("Delimiter for automatically added switches (internal switch)"); + -- No line for -gnatez : internal switch -- Line for -gnatE switch @@ -355,10 +351,7 @@ begin Write_Line ("Set mode for general/assertion expressions separately"); - -- Line for -gnatO switch - - Write_Switch_Char ("O nm "); - Write_Line ("Set name of output ali file (internal switch)"); + -- No line for -gnatO : internal switch -- Line for -gnatp switch @@ -584,8 +577,8 @@ begin -- Line for -gnatW switch - Write_Switch_Char ("W"); - Write_Str ("Wide character encoding method ("); + Write_Switch_Char ("W?"); + Write_Str ("Wide character encoding method (?="); for J in WC_Encoding_Method loop Write_Char (WC_Encoding_Letters (J)); diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index e2d92603239..91ee51db119 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2012, 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- -- @@ -4287,6 +4287,18 @@ package VMS_Data is -- ification field in the image header. It overrides any pragma Ident -- specified string. + S_Link_NoInhib : aliased constant S := "/NOINHIBIT-EXEC " & + "--for-linker=--noinhibit-exec"; + -- /NOINHIBIT-EXEC (D) + -- + -- Preserve executable if there are warnings. This is the default. + + S_Link_Inhib : aliased constant S := "/INHIBIT-EXEC " & + "--for-linker=--inhibit-exec"; + -- /INHIBIT-EXEC + -- + -- Remove executable if there are warnings. + S_Link_Libdir : aliased constant S := "/LIBDIR=*" & "-L*"; -- /LIBDIR=(directory, ...) @@ -4326,12 +4338,6 @@ package VMS_Data is -- This may be used when a link is rerun with different options, -- but there is no need to recompile the binder generated file. - S_Link_Noinhib : aliased constant S := "/NOINHIBIT-EXEC " & - "--for-linker=--noinhibit-exec"; - -- /NOINHIBIT-EXEC - -- - -- Delete executable if there are errors or warnings. - S_Link_Nofiles : aliased constant S := "/NOSTART_FILES " & "-nostartfiles"; -- /NOSTART_FILES @@ -4407,12 +4413,13 @@ package VMS_Data is S_Link_Forlink 'Access, S_Link_Force 'Access, S_Link_Ident 'Access, + S_Link_NoInhib 'Access, + S_Link_Inhib 'Access, S_Link_Libdir 'Access, S_Link_Library 'Access, S_Link_Mess 'Access, S_Link_Nocomp 'Access, S_Link_Nofiles 'Access, - S_Link_Noinhib 'Access, S_Link_Project 'Access, S_Link_Return 'Access, S_Link_Static 'Access, @@ -6636,18 +6643,24 @@ package VMS_Data is -- ification field in the image header. It overrides any pragma Ident -- specified string. + S_Shared_NoInhib : aliased constant S := "/NOINHIBIT-IMAGE " & + "--for-linker=--noinhibit-exec"; + -- /NOINHIBIT-EXEC (D) + -- + -- Preserve image if there are warnings. This is the default. + + S_Shared_Inhib : aliased constant S := "/INHIBIT-IMAGE " & + "--for-linker=--inhibit-exec"; + -- /INHIBIT-EXEC + -- + -- Remove image if there are warnings. + S_Shared_Nofiles : aliased constant S := "/NOSTART_FILES " & "-nostartfiles"; -- /NOSTART_FILES -- -- Link in default image initialization and startup functions. - S_Shared_Noinhib : aliased constant S := "/NOINHIBIT-IMAGE " & - "--for-linker=--noinhibit-exec"; - -- /NOINHIBIT-IMAGE - -- - -- Delete image if there are errors or warnings. - S_Shared_Verb : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) @@ -6667,8 +6680,9 @@ package VMS_Data is (S_Shared_Debug 'Access, S_Shared_Image 'Access, S_Shared_Ident 'Access, + S_Shared_NoInhib 'Access, + S_Shared_Inhib 'Access, S_Shared_Nofiles 'Access, - S_Shared_Noinhib 'Access, S_Shared_Verb 'Access, S_Shared_ZZZZZ 'Access); diff --git a/gcc/ada/xgnatugn.adb b/gcc/ada/xgnatugn.adb index ab168170f0c..4706701e9b1 100644 --- a/gcc/ada/xgnatugn.adb +++ b/gcc/ada/xgnatugn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-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- -- @@ -85,12 +85,6 @@ -- output. A line containing this escape sequence may not also contain -- a ^alpha^beta^ sequence. --- Process @ifset and @ifclear for the target flags (unw, vms); --- this is because we have menu problems if we let makeinfo handle --- these ifset/ifclear pairs. --- Note: @ifset/@ifclear commands for the edition flags (FSFEDITION, --- PROEDITION, GPLEDITION) are passed through unchanged - with Ada.Command_Line; use Ada.Command_Line; with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; @@ -129,6 +123,7 @@ procedure Xgnatugn is procedure Put_Line (F : Sfile; S : String); -- Local version of Put_Line ensures Unix style line endings + First_Time : Boolean := True; Number_Of_Warnings : Natural := 0; Number_Of_Errors : Natural := 0; Warnings_Enabled : Boolean; @@ -148,10 +143,6 @@ procedure Xgnatugn is (Input : Input_File; At_Character : Natural; Message : String); - procedure Warning - (Input : Input_File; - Message : String); - -- Like Error, but just print a warning message Dictionary_File : aliased Input_File; procedure Read_Dictionary_File; @@ -180,13 +171,11 @@ procedure Xgnatugn is -- Conditional commands for edition are passed through unchanged subtype Target_Type is Flag_Type range UNW .. VMS; - subtype Edition_Type is Flag_Type range FSFEDITION .. GPLEDITION; Target : Target_Type; -- The Target variable is initialized using the command line - Valid_Characters : constant Character_Set := - To_Set (Span => (' ', '~')); + Valid_Characters : constant Character_Set := To_Set (Span => (' ', '~')); -- This array controls which characters are permitted in the input -- file (after line breaks have been removed). Valid characters -- are all printable ASCII characters and the space character. @@ -194,7 +183,7 @@ procedure Xgnatugn is Word_Characters : constant Character_Set := (To_Set (Ranges => (('0', '9'), ('a', 'z'), ('A', 'Z'))) - or To_Set ("?-_~")); + or To_Set ("?-_~")); -- The characters which are permitted in words. Other (valid) -- characters are assumed to be delimiters between words. Note that -- this set has to include all characters of the source words of the @@ -236,47 +225,6 @@ procedure Xgnatugn is -- This subprogram takes a line and rewrites it according to Target. -- It relies on information in Source_File to generate error messages. - type Conditional is (Set, Clear); - procedure Push_Conditional (Cond : Conditional; Flag : Target_Type); - procedure Pop_Conditional (Cond : Conditional); - -- These subprograms deal with conditional processing (@ifset/@ifclear). - -- They rely on information in Source_File to generate error messages. - - function Currently_Excluding return Boolean; - -- Returns true if conditional processing directives imply that the - -- current line should not be included in the output. - - function VMS_Context_Determined return Boolean; - -- Returns true if, in the current conditional preprocessing context, we - -- always have a VMS or a non-VMS version, regardless of the value of - -- Target. - - function In_VMS_Section return Boolean; - -- Returns True if in an "@ifset vms" section - - procedure Check_No_Pending_Conditional; - -- Checks that all preprocessing directives have been properly matched by - -- their @end counterpart. If this is not the case, print an error - -- message. - - -- The following definitions implement a stack to track the conditional - -- preprocessing context. - - type Conditional_Context is record - Starting_Line : Positive; - Cond : Conditional; - Flag : Flag_Type; - Excluding : Boolean; - end record; - - Conditional_Stack_Depth : constant := 3; - - Conditional_Stack : - array (1 .. Conditional_Stack_Depth) of Conditional_Context; - - Conditional_TOS : Natural := 0; - -- Pointer to the Top Of Stack for Conditional_Stack - ----------- -- Usage -- ----------- @@ -415,16 +363,6 @@ procedure Xgnatugn is ------------- procedure Warning - (Input : Input_File; - Message : String) - is - begin - if Warnings_Enabled then - Warning (Input, 0, Message); - end if; - end Warning; - - procedure Warning (Input : Input_File; At_Character : Natural; Message : String) @@ -487,8 +425,9 @@ procedure Xgnatugn is Trim (Line (1 .. Split - 1), Both); Target : constant String := Trim (Line (Split + 1 .. Line'Last), Both); - Two_Spaces : constant Natural := - Index (Source, " "); + + Two_Spaces : constant Natural := Index (Source, " "); + Non_Word_Character : constant Natural := Index (Source, Word_Characters or @@ -524,7 +463,6 @@ procedure Xgnatugn is declare Prefix : String renames Source (Source'First .. J - 1); - begin if not Is_Known_Word (Prefix) then Error (Dictionary_File, @@ -678,7 +616,7 @@ procedure Xgnatugn is (VMS_Second_Character + 1, VMS_Third_Character - 1)); return; end; - end if; -- VMS_Alternative + end if; -- The Word case. Search for characters not in Word_Characters. -- We have found a word if the first non-word character is not @@ -718,7 +656,7 @@ procedure Xgnatugn is procedure Rewrite_Word is First_Word : String - renames Line (Token.Span.First .. Token.Span.Last); + renames Line (Token.Span.First .. Token.Span.Last); begin -- We do not perform any error checking below, so we can just skip @@ -736,7 +674,7 @@ procedure Xgnatugn is -- longest possible sequence we can rewrite. declare - Seq : Token_Span := Token.Span; + Seq : Token_Span := Token.Span; Lost_Space : Boolean := False; begin @@ -746,23 +684,25 @@ procedure Xgnatugn is and then Line (Token.Span.First .. Token.Span.Last) = " " then Next_Token; + if Token.Kind /= Word or else not Is_Known_Word (Line (Seq.First .. Token.Span.Last)) then - -- When we reach this point, the following - -- conditions are true: - -- - -- Seq is a known word. - -- The previous token was a space character. - -- Seq extended to the current token is not a - -- known word. + -- When we reach this point, the following conditions + -- are true: + + -- Seq is a known word + + -- The previous token was a space character + + -- Seq extended to the current token is not a + -- known word. Lost_Space := True; exit; else - -- Extend Seq to cover the current (known) word Seq.Last := Token.Span.Last; @@ -772,10 +712,12 @@ procedure Xgnatugn is else -- When we reach this point, the following conditions -- are true: - -- - -- Seq is a known word. - -- The previous token was a word. - -- The current token is not a space character. + + -- Seq is a known word + + -- The previous token was a word + + -- The current token is not a space character. exit; end if; @@ -804,8 +746,8 @@ procedure Xgnatugn is Next_Token; if Token.Kind = Word - and then Is_Extension (Line (Token.Span.First - .. Token.Span.Last)) + and then + Is_Extension (Line (Token.Span.First .. Token.Span.Last)) then -- We have discovered a file extension. Convert the file -- name to upper case. @@ -848,6 +790,7 @@ procedure Xgnatugn is -- Rewrite_Word would have handled it. Next_Token; + if Token.Kind = Word and then Is_Extension (Line (Token.Span.First .. Token.Span.Last)) @@ -858,6 +801,7 @@ procedure Xgnatugn is else Append (Rewritten_Line, '.'); end if; + else Append (Rewritten_Line, Line (Token.Span.First .. Token.Span.Last)); @@ -887,17 +831,6 @@ procedure Xgnatugn is Maybe_Rewrite_Extension; when VMS_Alternative => - if VMS_Context_Determined then - if (not In_VMS_Section) - or else - Line (Token.VMS.First .. Token.VMS.Last) /= - Line (Token.Non_VMS.First .. Token.Non_VMS.Last) - then - Warning (Source_File, Token.First, - "VMS alternative already determined " - & "by conditionals"); - end if; - end if; if Target = VMS then Append (Rewritten_Line, Line (Token.VMS.First .. Token.VMS.Last)); @@ -905,6 +838,7 @@ procedure Xgnatugn is Append (Rewritten_Line, Line (Token.Non_VMS.First .. Token.Non_VMS.Last)); end if; + Next_Token; when VMS_Error => @@ -921,155 +855,27 @@ procedure Xgnatugn is ------------------------- procedure Process_Source_File is - Ifset : constant String := "@ifset "; - Ifclear : constant String := "@ifclear "; - Endsetclear : constant String := "@end "; - -- Strings to be recognized for conditional processing - begin while not End_Of_File (Source_File.Data) loop declare Line : constant String := Get_Line (Source_File'Access); + Rewritten : constant String := Rewrite_Source_Line (Line); -- We unconditionally rewrite the line so that we can check the -- syntax of all lines, and not only those which are actually -- included in the output. - Have_Conditional : Boolean := False; - -- True if we have encountered a conditional preprocessing - -- directive. - - Cond : Conditional; - -- The kind of the directive - - Flag : Flag_Type; - -- Its flag - begin - -- If the line starts with @ifset or @ifclear, we try to convert - -- the following flag to one of our flag types. If we fail, - -- Have_Conditional remains False. - - if Line'Length >= Ifset'Length - and then Line (1 .. Ifset'Length) = Ifset - then - Cond := Set; - - declare - Arg : constant String := - Trim (Line (Ifset'Length + 1 .. Line'Last), Both); - - begin - Flag := Flag_Type'Value (Arg); - Have_Conditional := True; - - case Flag is - when Target_Type => - if Translate (Target_Type'Image (Flag), - Lower_Case_Map) - /= Arg - then - Error (Source_File, "flag has to be lowercase"); - end if; - - when Edition_Type => - null; - end case; - exception - when Constraint_Error => - Error (Source_File, "unknown flag for '@ifset'"); - end; - - elsif Line'Length >= Ifclear'Length - and then Line (1 .. Ifclear'Length) = Ifclear + if First_Time + and then Line'Length > 3 and then Line (1 .. 3) = "@if" then - Cond := Clear; - - declare - Arg : constant String := - Trim (Line (Ifclear'Length + 1 .. Line'Last), Both); - - begin - Flag := Flag_Type'Value (Arg); - Have_Conditional := True; - - case Flag is - when Target_Type => - if Translate (Target_Type'Image (Flag), - Lower_Case_Map) - /= Arg - then - Error (Source_File, "flag has to be lowercase"); - end if; - - when Edition_Type => - null; - end case; - exception - when Constraint_Error => - Error (Source_File, "unknown flag for '@ifclear'"); - end; + Put_Line (Output_File, "@set " & Argument (1)); + First_Time := False; end if; - if Have_Conditional and (Flag in Target_Type) then - - -- We create a new conditional context and suppress the - -- directive in the output. - - Push_Conditional (Cond, Flag); - - elsif Line'Length >= Endsetclear'Length - and then Line (1 .. Endsetclear'Length) = Endsetclear - and then (Flag in Target_Type) - then - -- The '@end ifset'/'@end ifclear' case is handled here. We - -- have to pop the conditional context. - - declare - First, Last : Natural; - - begin - Find_Token (Source => Line (Endsetclear'Length + 1 - .. Line'Length), - Set => Letter_Set, - Test => Inside, - First => First, - Last => Last); - - if Last = 0 then - Error (Source_File, "'@end' without argument"); - else - if Line (First .. Last) = "ifset" then - Have_Conditional := True; - Cond := Set; - elsif Line (First .. Last) = "ifclear" then - Have_Conditional := True; - Cond := Clear; - end if; - - if Have_Conditional then - Pop_Conditional (Cond); - end if; - - -- We fall through to the ordinary case for other @end - -- directives. - - end if; -- @end without argument - end; - end if; -- Have_Conditional - - if (not Have_Conditional) or (Flag in Edition_Type) then - - -- The ordinary case - - if not Currently_Excluding then - Put_Line (Output_File, Rewritten); - end if; - end if; + Put_Line (Output_File, Rewritten); end; end loop; - - Check_No_Pending_Conditional; end Process_Source_File; --------------------------- @@ -1079,8 +885,7 @@ procedure Xgnatugn is procedure Initialize_Extensions is procedure Add (Extension : String); - -- Adds an extension which is replaced with itself (in upper - -- case). + -- Adds an extension which is replaced with itself (in upper case) procedure Add (Extension, Replacement : String); -- Adds an extension with a custom replacement @@ -1152,148 +957,6 @@ procedure Xgnatugn is return S (Get (Ug_Words, Word)); end Get_Replacement_Word; - ---------------------- - -- Push_Conditional -- - ---------------------- - - procedure Push_Conditional (Cond : Conditional; Flag : Target_Type) is - Will_Exclude : Boolean; - - begin - -- If we are already in an excluding context, inherit this property, - -- otherwise calculate it from scratch. - - if Conditional_TOS > 0 - and then Conditional_Stack (Conditional_TOS).Excluding - then - Will_Exclude := True; - else - case Cond is - when Set => - Will_Exclude := Flag /= Target; - when Clear => - Will_Exclude := Flag = Target; - end case; - end if; - - -- Check if the current directive is pointless because of a previous, - -- enclosing directive. - - for J in 1 .. Conditional_TOS loop - if Conditional_Stack (J).Flag = Flag then - Warning (Source_File, "directive without effect because of line" - & Integer'Image (Conditional_Stack (J).Starting_Line)); - end if; - end loop; - - Conditional_TOS := Conditional_TOS + 1; - Conditional_Stack (Conditional_TOS) := - (Starting_Line => Source_File.Line, - Cond => Cond, - Flag => Flag, - Excluding => Will_Exclude); - end Push_Conditional; - - --------------------- - -- Pop_Conditional -- - --------------------- - - procedure Pop_Conditional (Cond : Conditional) is - begin - if Conditional_TOS > 0 then - case Cond is - when Set => - if Conditional_Stack (Conditional_TOS).Cond /= Set then - Error (Source_File, - "'@end ifset' does not match '@ifclear' at line" - & Integer'Image (Conditional_Stack - (Conditional_TOS).Starting_Line)); - end if; - - when Clear => - if Conditional_Stack (Conditional_TOS).Cond /= Clear then - Error (Source_File, - "'@end ifclear' does not match '@ifset' at line" - & Integer'Image (Conditional_Stack - (Conditional_TOS).Starting_Line)); - end if; - end case; - - Conditional_TOS := Conditional_TOS - 1; - - else - case Cond is - when Set => - Error (Source_File, - "'@end ifset' without corresponding '@ifset'"); - - when Clear => - Error (Source_File, - "'@end ifclear' without corresponding '@ifclear'"); - end case; - end if; - end Pop_Conditional; - - ------------------------- - -- Currently_Excluding -- - ------------------------- - - function Currently_Excluding return Boolean is - begin - return Conditional_TOS > 0 - and then Conditional_Stack (Conditional_TOS).Excluding; - end Currently_Excluding; - - ---------------------------- - -- VMS_Context_Determined -- - ---------------------------- - - function VMS_Context_Determined return Boolean is - begin - for J in 1 .. Conditional_TOS loop - if Conditional_Stack (J).Flag = VMS then - return True; - end if; - end loop; - - return False; - end VMS_Context_Determined; - - -------------------- - -- In_VMS_Section -- - -------------------- - - function In_VMS_Section return Boolean is - begin - for J in 1 .. Conditional_TOS loop - if Conditional_Stack (J).Flag = VMS then - return Conditional_Stack (J).Cond = Set; - end if; - end loop; - - return False; - end In_VMS_Section; - - ---------------------------------- - -- Check_No_Pending_Conditional -- - ---------------------------------- - - procedure Check_No_Pending_Conditional is - begin - for J in 1 .. Conditional_TOS loop - case Conditional_Stack (J).Cond is - when Set => - Error (Source_File, "Missing '@end ifset' for '@ifset' at line" - & Integer'Image (Conditional_Stack (J).Starting_Line)); - - when Clear => - Error (Source_File, - "Missing '@end ifclear' for '@ifclear' at line" - & Integer'Image (Conditional_Stack (J).Starting_Line)); - end case; - end loop; - end Check_No_Pending_Conditional; - -- Start of processing for Xgnatugn Valid_Command_Line : Boolean; diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb index 74b76c9455b..095101f52dc 100644 --- a/gcc/ada/xoscons.adb +++ b/gcc/ada/xoscons.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2012, 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- -- @@ -55,7 +55,6 @@ with XUtil; use XUtil; procedure XOSCons is use Ada.Strings; - use ASCII; Unit_Name : constant String := Argument (1); Tmpl_Name : constant String := Unit_Name & "-tmplt"; @@ -516,7 +515,7 @@ procedure XOSCons is Current_Line := Current_Line + 1; exit when Line (1 .. Last) = "@END_IF"; - if Line (1 .. 4) = "@IF " then + if Last > 4 and then Line (1 .. 4) = "@IF " then Parse_Cond (Line (1 .. Last), Res, Tmpl_File, Ada_Ofile, C_Ofile, Current_Line); diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index 56a28efed00..2afec821079 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -272,18 +272,22 @@ package body Xref_Lib is end if; end if; - File_Ref := - Add_To_Xref_File - (Entity (File_Start .. Line_Start - 1), Visited => True); - Pattern.File_Ref := File_Ref; + declare + File_Name : String := Entity (File_Start .. Line_Start - 1); - Add_Line (Pattern.File_Ref, Line_Num, Col_Num); + begin + Osint.Canonical_Case_File_Name (File_Name); + File_Ref := Add_To_Xref_File (File_Name, Visited => True); + Pattern.File_Ref := File_Ref; + + Add_Line (Pattern.File_Ref, Line_Num, Col_Num); - File_Ref := - Add_To_Xref_File - (ALI_File_Name (Entity (File_Start .. Line_Start - 1)), - Visited => False, - Emit_Warning => True); + File_Ref := + Add_To_Xref_File + (ALI_File_Name (File_Name), + Visited => False, + Emit_Warning => True); + end; end Add_Entity; ------------------- |