diff options
Diffstat (limited to 'gcc')
294 files changed, 13648 insertions, 4506 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 105cfce613a..ffd2855a31b 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,8 +1,157 @@ +2011-08-31 Richard Guenther <rguenther@suse.de> + + * expr.c (expand_expr_real_2): Move COND_EXPR and VEC_COND_EXPR + handling here, from ... + (expand_expr_real_1): ... here. + * gimple-pretty-print.c (dump_ternary_rhs): Handle COND_EXPR + and VEC_COND_EXPR. + * gimple.c (gimple_rhs_class_table): Make COND_EXPR and VEC_COND_EXPR + a GIMPLE_TERNARY_RHS. + * tree-cfg.c (verify_gimple_assign_ternary): Handle COND_EXPR + and VEC_COND_EXPR here ... + (verify_gimple_assign_single): ... not here. + * gimple-fold.c (fold_gimple_assign): Move COND_EXPR folding. + * tree-object-size.c (cond_expr_object_size): Adjust. + (collect_object_sizes_for): Likewise. + * tree-scalar-evolution.c (interpret_expr): Don't handle + ternary RHSs. + * tree-ssa-forwprop.c (forward_propagate_into_cond): Fix and + simplify. + (ssa_forward_propagate_and_combine): Adjust. + * tree-ssa-loop-im.c (move_computations_stmt): Build the COND_EXPR + as ternary. + * tree-ssa-threadedge.c (fold_assignment_stmt): Adjust. + * tree-vect-loop.c (vect_is_simple_reduction_1): Likewise. + * tree-vect-stmt.c (vectorizable_condition): Likewise. + * tree-vrp.c (extract_range_from_cond_expr): Likewise. + (extract_range_from_assignment): Likewise. + +2011-08-31 Richard Sandiford <rdsandiford@googlemail.com> + + * config/i386/i386.md: Use (match_test ...) for attribute tests. + * config/i386/mmx.md: Likewise. + * config/i386/sse.md: Likewise. + * config/i386/predicates.md (call_insn_operand): Use + (not (match_test "...")) instead of (match_test "!...") + * config/i386/constraints.md (w): Likewise. + +2011-08-31 Richard Sandiford <rdsandiford@googlemail.com> + + * doc/md.texi: Describe the use of match_tests in attribute tests. + * rtl.def (MATCH_TEST): Update commentary. + * genattrtab.c (attr_copy_rtx, check_attr_test, clear_struct_flag) + (write_test_expr, walk_attr_value): Handle MATCH_TEST. + +2011-08-31 Richard Sandiford <rdsandiford@googlemail.com> + + * genattrtab.c (attr_rtx_1): Hash SYMBOL_REFs. + (attr_string): Use copy_md_ptr_loc. + +2011-08-31 Martin Jambor <mjambor@suse.cz> + + PR middle-end/49886 + * ipa-inline-analysis.c (compute_inline_parameters): Set + can_change_signature of noes with typde attributes. + * ipa-split.c (split_function): Do not skip any arguments if + can_change_signature is set. + +2011-08-31 Martin Jambor <mjambor@suse.cz> + + * cgraphunit.c (cgraph_redirect_edge_call_stmt_to_callee): Alias + check removed. + +2011-08-31 Richard Guenther <rguenther@suse.de> + + * fold-const.c (extract_muldiv_1): Remove bogus TYPE_IS_SIZETYPE + special-casing. + +2011-08-31 Marc Glisse <marc.glisse@inria.fr> + + * doc/generic.texi (Types for C++): CP_TYPE_QUALS -> cp_type_quals. + +2011-08-31 Tom de Vries <tom@codesourcery.com> + + PR middle-end/43513 + * Makefile.in (tree-ssa-ccp.o): Add $(PARAMS_H) to rule. + * tree-ssa-ccp.c (params.h): Include. + (fold_builtin_alloca_for_var): New function. + (ccp_fold_stmt): Use fold_builtin_alloca_for_var. + +2011-08-30 Uros Bizjak <ubizjak@gmail.com> + + * config/i386/i386.c (ix86_valid_target_attribute_inner_p): + Handle FMA option. + +2011-08-30 Andrew Stubbs <ams@codesourcery.com> + + * config/arm/arm.c (optimal_immediate_sequence_1): Make b1, b2, + b3 and b4 unsigned. + +2011-08-30 Andrew Stubbs <ams@codesourcery.com> + + * config/arm/arm.c (arm_gen_constant): Set can_negate correctly + when code is SET. + +2011-08-30 Richard Guenther <rguenther@suse.de> + + PR middle-end/48571 + * gimple.h (maybe_fold_offset_to_address): Remove. + (maybe_fold_offset_to_reference): Likewise. + (maybe_fold_stmt_addition): Likewise. + (may_propagate_address_into_dereference): Likewise. + * tree-inline.c (remap_gimple_op_r): Do not reconstruct + array references. + * gimple-fold.c (canonicalize_constructor_val): Likewise. + Canonicalize invariant POINTER_PLUS_EXPRs to invariant MEM_REF + addresses instead. + (may_propagate_address_into_dereference): Remove. + (maybe_fold_offset_to_array_ref): Likewise. + (maybe_fold_offset_to_reference): Likewise. + (maybe_fold_offset_to_address): Likewise. + (maybe_fold_stmt_addition): Likewise. + (fold_gimple_assign): Do not reconstruct array references but + instead canonicalize invariant POINTER_PLUS_EXPRs to invariant + MEM_REF addresses. + (gimple_fold_stmt_to_constant_1): Likewise. + * tree-ssa-forwprop.c (forward_propagate_addr_expr_1): Likewise. + * gimplify.c (gimplify_conversion): Likewise. + (gimplify_expr): Likewise. + +2011-08-30 Ilya Tocar <ilya.tocar@intel.com> + + * config/i386/fmaintrin.h: New. + * config.gcc: Add fmaintrin.h. + * config/i386/i386.c + (enum ix86_builtins) <IX86_BUILTIN_VFMADDSS3>: New. + <IX86_BUILTIN_VFMADDSD3>: Likewise. + * config/i386/sse.md (fmai_vmfmadd_<mode>): New. + (*fmai_fmadd_<mode>): Likewise. + (*fmai_fmsub_<mode>): Likewise. + (*fmai_fnmadd_<mode>): Likewise. + (*fmai_fnmsub_<mode>): Likewise. + * config/i386/immintrin.h: Add fmaintrin.h. + +2011-08-30 Bernd Schmidt <bernds@codesourcery.com> + + * genautomata.c (NO_COMB_OPTION): New macro. + (no_comb_flag): New static variable. + (gen_automata_option): Handle NO_COMB_OPTION. + (comb_vect_p): False if no_comb_flag. + (add_vect): Move computation of min/max values. Return early if + no_comb_flag. + * doc/md.texi (automata_option): Document no-comb-vect. + + * config/i386/i386.c (get_pc_thunk_name): Change prefix to + "__x86.get_pc_thunk". + + * bb-reorder.c (insert_section_boundary_note): Only do it if + we reordered the blocks; i.e. not if !optimize_function_for_speed_p. + 2011-08-30 Christian Bruel <christian.bruel@st.com> * coverage.c (coverage_init): Check flag_branch_probabilities instead of flag_profile_use. - + 2011-08-29 Michael Meissner <meissner@linux.vnet.ibm.com> * config/rs6000/rs6000.opt (-msave-toc-indirect): Change default diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 1c548c213c4..9ac8da10af7 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20110830 +20110902 diff --git a/gcc/Makefile.in b/gcc/Makefile.in index eacd15001d4..ddc5632fce0 100644 --- a/gcc/Makefile.in +++ b/gcc/Makefile.in @@ -3227,7 +3227,7 @@ tree-call-cdce.o : tree-call-cdce.c $(CONFIG_H) $(SYSTEM_H) $(TREE_H) \ tree-ssa-ccp.o : tree-ssa-ccp.c $(TREE_FLOW_H) $(CONFIG_H) \ $(SYSTEM_H) $(TREE_H) $(TM_P_H) $(EXPR_H) output.h \ $(DIAGNOSTIC_H) $(FUNCTION_H) $(TIMEVAR_H) $(TM_H) coretypes.h \ - $(TREE_DUMP_H) $(BASIC_BLOCK_H) $(TREE_PASS_H) langhooks.h \ + $(TREE_DUMP_H) $(BASIC_BLOCK_H) $(TREE_PASS_H) langhooks.h $(PARAMS_H) \ tree-ssa-propagate.h value-prof.h $(FLAGS_H) $(TARGET_H) $(DIAGNOSTIC_CORE_H) \ $(DBGCNT_H) tree-pretty-print.h gimple-pretty-print.h gimple-fold.h tree-sra.o : tree-sra.c $(CONFIG_H) $(SYSTEM_H) coretypes.h alloc-pool.h \ diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ca620533c9f..885cbad07ce 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,1331 @@ +2011-09-02 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb: (Analyze_Attribute, case 'Range): when expanding + X'range (N) into X'First (N) .. X'Last (N), do not share the + dimension indicator N, if present. Even though it is a static + constant, its source location may be modified when printing + expanded code under -gnatDL, and node sharing will lead to chaos + in Sprint on large files, by generating a sloc value that does + not correspond to any source file. + +2011-09-02 Bob Duff <duff@adacore.com> + + * einfo.adb: (Has_Xref_Entry): Do not call + Implementation_Base_Type. Lib.Xref has been + rewritten to avoid the need for it, and it was costly. + * s-htable.ads,s-htable.adb: (Present,Set_If_Not_Present): New + functions in support of efficient xref. + * lib-xref-alfa.adb: Misc changes related to Key component of + type Xref_Entry. + * lib-xref.adb: (Add_Entry,etc): Speed improvement. + (New_Entry): Call Implementation_Base_Type, because Has_Xref_Entry + no longer does. This is the one place where it is needed. + +2011-09-02 Johannes Kanig <kanig@adacore.com> + + * g-comlin.adb (Getopt): New optional argument Concatenate to have + similar interface as the other Getopt function. + +2011-09-02 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb: (Expand_Allocator_Expression): Do not generate + a call to Set_Finalize_Address if there is no allocator available. + * exp_util.adb: (Build_Allocate_Deallocate_Proc): Account for + a case of allocator expansion where the allocator is not expanded but + needs a custom allocate routine. Code reformatting. + (Is_Finalizable_Transient): Remove local variables Has_Rens and + Ren_Obj. Code reformatting. + (Is_Renamed): Renamed to Is_Aliased. Add code to detect aliasing + through the use of 'reference. + * sem_ch4.adb: (Analyze_Allocator): Detect allocators generated + as part of build-in-place expansion. They are intentionally marked as + coming from source, but their parents are not. + +2011-09-02 Ed Schonberg <schonberg@adacore.com> + + * sem_ch10.adb (Analyze_With_Clause): If the library unit + is the generated subprogram declaration for a child unit body + that acts as spec, use the original body in the with_clause, + to prevent binding errors. + +2011-09-02 Vincent Celier <celier@adacore.com> + + * gnat_ugn.texi: Adapt documentation of -gnateInnn to new VMS + qualifier /MULTI_UNIT_INDEX= + +2011-09-02 Johannes Kanig <kanig@adacore.com> + + * g-comlin.adb (Getopt): Return when switch is dealt with automatically, + instead of calling the callback function + +2011-09-02 Robert Dewar <dewar@adacore.com> + + * prj-proc.adb, prj.ads, sem_util.adb, s-taprop-linux.adb, + prj-nmsc.adb, prj-util.ads, prj-env.adb: Minor reformatting. + +2011-09-02 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb: (Find_Sources): When the list of sources is + explicitly declared in an extending project, do not warn if a source + for an inherited naming exception is not found. + +2011-09-02 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.adb: (Is_Build_In_Place_Function_Call): Return False if + expansion is inactive. + +2011-09-02 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Note_Possible_Modification): If the entity + being modified is the renaming generated for an Ada2012 iterator + element, the enclosing container or array is modified as well. + +2011-09-02 Jose Ruiz <ruiz@adacore.com> + + * s-taprop-linux.adb (Initialize_Lock, Initialize_TCB, + Initialize): Define and initialize the + mutex attributes and condition variable attributes locally. + +2011-09-02 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Check_File): Mark as Locally_Removed a naming + exception replaced in an extending project. + (Check_Object): No error when the other source is locally removed. + +2011-09-02 Yannick Moy <moy@adacore.com> + + * exp_ch6.adb (Is_Build_In_Place_Function_Call): in Alfa mode, allow + unresolved calls. + +2011-08-31 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Makefile.in: Clean up handling of x86 and x86-64 + run-time files. + * gcc-interface/Make-lang.in: Update dependencies. + +2011-09-01 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb, s-taprop-linux.adb, gnatls.adb: Minor reformatting. + +2011-09-01 Jose Ruiz <ruiz@adacore.com> + + * adaint.h (__gnat_cpu_free): Fix the name of this profile. + * adaint.c (__gnat_cpu_alloc, __gnat_cpu_alloc_size, __gnat_cpu_free, + __gnat_cpu_zero, __gnat_cpu_set): Create version of these subprograms + specific for systems where their glibc version does not define the + routines to handle dynamically allocated CPU sets. + +2011-09-01 Vincent Celier <celier@adacore.com> + + * prj-proc.adb, prj.ads, prj-nmsc.adb, prj-util.adb, prj-util.ads, + prj-env.adb: Implement inheritance of naming exceptions in extending + projects. + +2011-09-01 Romain Berrendonner <berrendo@adacore.com> + + * gnatls.adb: Display simple message instead of content of + gnatlic.adl. + +2011-09-01 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch3.adb: (Build_Derived_Record_Type) Remove the kludgy update of + access discriminant and anonymous access component scopes. + (Inherit_Component): Reuse the itype of an access discriminant + or anonymous access component by copying it in order to set the proper + scope. This is done only when the parent and the derived type + are in different scopes. + (Set_Anonymous_Etype): New routine. + +2011-09-01 Robert Dewar <dewar@adacore.com> + + * a-convec.adb: Minor reformatting throughout. + +2011-09-01 Jose Ruiz <ruiz@adacore.com> + + * adaint.c, adaint.h (__gnat_cpu_alloc, __gnat_cpu_alloc_size, + __gnat_cpu_set_free): Create these wrappers around the CPU_ALLOC, + CPU_ALLOC_SIZE and CPU_FREE linux macros. + (__gnat_cpu_zero, __gnat_cpu_set): Use the CPU_ZERO_S and + CPU_SET_S respectively because we are now using dynamically allocated + CPU sets which are more portable across different glibc versions. + * s-osinte-linux.ads (cpu_set_t_ptr, CPU_ALLOC, CPU_ALLOC_SIZE, + CPU_FREE): Add this type and subprograms to be able to create cpu_set_t + masks dynamically according to the number of processors in the target + platform. + (CPU_ZERO, CPU_SET): They are now mapped to the CPU_ZERO_S and CPU_SET_S + respectively, so we need to pass the size of the masks as + parameters. + * s-taprop-linux.adb (Create_Task, Set_Task_Affinity): Use dynamically + created cpu_set_t masks + with the number of processors available in the target platform, + instead of static bit arrays. It enhances portability because + it uses the information from the target platform. + * sem_ch8.adb: (Attribute_Renaming): When checking whether we + are using a restricted run-time library, use the flag + Configurable_Run_Time_Mode instead of Restricted_Profile. + +2011-09-01 Vincent Celier <celier@adacore.com> + + * ug_words: Add /MULTI_UNIT_INDEX= -> -gnateI + * vms_data.ads: Add new VMS qualifier equivalent for -gnateInnn + +2011-09-01 Nicolas Roche <roche@adacore.com> + + * adaint.c (__gnat_tmp_name): Don't use tmpnam function from the system + on VxWorks in kernel mode. + +2011-09-01 Jose Ruiz <ruiz@adacore.com> + + * s-taprop-linux.adb (Create_Task, Set_Task_Affinity): Use the linux + macros for handling CPU sets (CPU_ZERO, CPU_SET) instead of modifying + directly the bit array. + * s-osinte-linux.ads (CPU_ZERO, CPU_SET): Import these wrappers around + the linux macros with the same name. + * adaint.h, adaint.c (__gnat_cpu_zero, __gnat_cpu_set): Create these + wrappers around the CPU_ZERO and CPU_SET linux macros. + +2011-09-01 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Find_Insertion_List): Removed. + (Process_Transient_Objects): Insert the declarations of the hook + access type and the hook object before the associated transient object. + +2011-09-01 Jose Ruiz <ruiz@adacore.com> + + * sem_ch8.adb (Attribute_Renaming): Add missing check to avoid loading + package System.Aux_Dec when using restricted run-time libraries which + do not have this package. + +2011-09-01 Tristan Gingold <gingold@adacore.com> + + * s-vaflop-vms-alpha.adb: Remove pragma optimize, useless. + +2011-09-01 Bob Duff <duff@adacore.com> + + * sem_attr.adb (Analyze_Access_Attribute): Do not call + Kill_Current_Values for P'Unrestricted_Access, where P is library level + +2011-09-01 Thomas Quinot <quinot@adacore.com> + + * exp_ch5.adb: Minor reformatting + * gnat_ugn.texi: Fix minor typos. + * gcc-interface/Make-lang.in: Update dependencies. + +2011-09-01 Robert Dewar <dewar@adacore.com> + + * inline.adb, sem_aggr.adb: Minor reformatting. + +2011-09-01 Ed Schonberg <schonberg@adacore.com> + + * a-convec.adb: Proper handling of cursors for Ada2012 iterators. + +2011-09-01 Robert Dewar <dewar@adacore.com> + + * prj-proc.adb, exp_ch6.adb, prj-env.adb: Minor reformatting. + +2011-09-01 Bob Duff <duff@adacore.com> + + * sem_aggr.adb (Resolve_Aggregate): Need to treat "in instance + body" the same as "in inlined body", because visibility shouldn't + apply there. + +2011-09-01 Eric Botcazou <ebotcazou@adacore.com> + + * inline.adb (Add_Inlined_Body): Refine previous change. + +2011-09-01 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.ads (Needs_BIP_Alloc_Form): New utility function. + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): + Test for case where call + initializes an object of a return statement before testing for + a constrained call, to ensure that all such cases get handled + by simply passing on the caller's parameters. Also, in that + case call Needs_BIP_Alloc_Form to determine whether to pass on + the BIP_Alloc_Form parameter of the enclosing function rather + than testing Is_Constrained. Add similar tests for the return + of a BIP call to later processing to ensure consistent handling. + (Needs_BIP_Alloc_Form): New utility function. + * sem_ch6.adb: (Create_Extra_Formals): Replace test for adding + a BIP_Alloc_Form formal with call to new utility function + Needs_BIP_Alloc_Form. + +2011-09-01 Pascal Obry <obry@adacore.com> + + * prj-part.adb: Minor reformatting. + +2011-09-01 Vincent Celier <celier@adacore.com> + + * prj-env.adb (Create_Mapping_File.Process): Encode the upper + half character in the unit name. + +2011-09-01 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb: Minor code and comment reformatting. + +2011-09-01 Thomas Quinot <quinot@adacore.com> + + * exp_ch6.adb (Expand_Inlined_Call): Remove redundant tests + for Is_Limited_Type and Is_Tagged_Type in condition checking + for by-reference type. + * inline.adb (Add_Inlined_Body): Only exclude init_procs. Other + subprograms may have a completion because of a previous + Inline_Always clause, but the enclosing package must be marked + inlined for the subprogram body to become visible to the backend. + +2011-09-01 Thomas Quinot <quinot@adacore.com> + + * sem_aux.adb, exp_ch4.adb: Minor reformatting + +2011-09-01 Pascal Obry <obry@adacore.com> + + * prj-proc.adb, prj.ads, sinput-p.adb: Minor reformatting. + +2011-09-01 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Generate references to + the formals of a subprogram stub that acts as a spec. + +2011-09-01 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Expand_Inlined_Call): If an actual is a by_reference + type, declare a renaming for it, not an object declaration. + +2011-09-01 Yannick Moy <moy@adacore.com> + + * ali-util.adb, ali-util.ads (Read_Withed_ALIs): Add parameter + Ignore_Errors to ignore failures to read ALI files when True. + +2011-09-01 Javier Miranda <miranda@adacore.com> + + * exp_ch3.adb (Expand_N_Object_Declaration): Handle non-default + constructor calls associated with non-tagged record types. + +2011-09-01 Robert Dewar <dewar@adacore.com> + + * g-socthi-vms.adb: Minor reformatting. + +2011-09-01 Nicolas Roche <roche@adacore.com> + + * sysdep.c: Don't use macro functions for stdio functions on VxWorks + in order to avoid impact of imcompatible changes. + * cstreams.c: Likewise + * cio.c: Likewise + * aux-io.c: Likewise + +2011-09-01 Yannick Moy <moy@adacore.com> + + * lib-writ.adb (Write_With_Lines): Always output complete information + on "with" line in Alfa mode, as this is required by formal verification + back-end. + +2011-09-01 Tristan Gingold <gingold@adacore.com> + + * g-socthi-vms.adb: Add comments. + +2011-09-01 Pascal Obry <obry@adacore.com> + + * prj.ads: Minor reformatting. + +2011-09-01 Vincent Celier <celier@adacore.com> + + * prj-env.adb (Create_Config_Pragmas_File.Check): Put all naming + exceptions in the config pragmas file. + +2011-09-01 Tristan Gingold <gingold@adacore.com> + + * gnat_ugn.texi: Document GNAT_STACK_SIZE on IVMS. + +2011-09-01 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Find_Insertion_List): New routine. + (Process_Transient_Objects): Add code to handle the abnormal + finalization of a controlled transient associated with a subprogram + call. Since transients are cleaned up right after the associated + context, an exception raised during a subprogram call may bypass the + finalization code. + +2011-09-01 Robert Dewar <dewar@adacore.com> + + * exp_ch6.adb (Expand_Call): Check actual for aliased parameter is + aliased. + +2011-09-01 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb, a-exexda.adb: Minor reformatting. + +2011-09-01 Robert Dewar <dewar@adacore.com> + + * s-taskin.ads, s-tassta.adb, sem_ch13.adb: Minor reformatting. + +2011-09-01 Thomas Quinot <quinot@adacore.com> + + * Makefile.rtl: Move s-oscons.o from GNATRTL_TASKING_OBJS to + GNATRTL_NONTASKING_OBJS. + +2011-09-01 Robert Dewar <dewar@adacore.com> + + * einfo.ads (Is_Aliased): Fix existing documentation and add note on + possibility of this flag being set for formals in Ada 2012 mode. + * par-ch6.adb (P_Formal_Part): Handle aliased for parameters for Ada + 2012. + * sem_ch6.adb (Process_Formals): Handle aliased parameters in Ada 2012 + mode. + * sinfo.adb (Aliased_Present): Allowed in N_Parameter_Specification for + Ada 2012. + * sinfo.ads (Aliased_Present): Allowed in N_Parameter_Specification for + Ada 2012. + +2011-09-01 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Find_Insertion_Node): New routine. Determines the proper + insertion node in a tree of nested Expression_With_Actions nodes. + (Process_Transient_Object): In the case where a complex if statement + has been converted into nested Expression_With_Actions nodes, the + "hook" object and the associated access type must be inserted before + the top most Expression_With_Actions. + +2011-09-01 Robert Dewar <dewar@adacore.com> + + * a-cbprqu.adb, a-cbprqu.ads, a-cuprqu.adb, a-cuprqu.ads, + a-cbsyqu.adb, a-cbsyqu.ads: Minor reformatting. + +2011-09-01 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb: Conditionalize aliasing predicates to Ada2012. + +2011-09-01 Jose Ruiz <ruiz@adacore.com> + + * aspects.ads (Aspect_Id, Aspect_Argument, Aspect_Names): Add the CPU + aspect. + * aspects.adb (Canonical_Aspect): Add entry for the CPU aspect. + * sem_ch13.adb (Analyze_Aspect_Specifications): Analyze the CPU aspect + in a similar way as we do for the Priority or Dispatching_Domain aspect. + * s-mudido-affinity.adb (Dispatching_Domain_Tasks, + Dispatching_Domains_Frozen): Move this local data to package + System.Tasking because with the CPU aspect we need to have access + to this data when creating the task in System.Tasking.Stages.Create_Task + * s-taskin.ads (Dispatching_Domain_Tasks, Dispatching_Domains_Frozen): + Move these variables from the body of + System.Multiprocessors.Dispatching_Domains because with the CPU aspect + we need to have access to this data when creating the task in + System.Tasking.Stages.Create_Task. + * s-taskin.adb (Initialize): Signal the allocation of the environment + task to a CPU, if any, so that we know whether the CPU can be + transferred to a different dispatching domain. + * s-tassta.adb (Create_Task): Check whether the CPU to which this task + is being allocated belongs to the dispatching domain where the task + lives. Signal the allocation of the task to a CPU, if any, so that we + know whether the CPU can be transferred to a different dispatching + domain. + +2011-09-01 Ed Schonberg <schonberg@adacore.com> + + * exp_attr.adb, sem_attr.adb, snames.ads-tmpl: Implementation of + attributes Same_Storage and Overlaps_Storage. + +2011-09-01 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_strm.adb: Remove with and use clause for Opt. + (Build_Array_Input_Function): Remove the version-dependent generation + of the return statement. The Ada 2005 tree is now the default. + +2011-09-01 Yannick Moy <moy@adacore.com> + + * put_alfa.adb: Unconditionnally write files in Alfa section, so that + it is never empty when compiling in Alfa mode. + +2011-09-01 Robert Dewar <dewar@adacore.com> + + * sem_aggr.adb, sem_ch3.adb, a-direct.adb, s-taprop-vxworks.adb, + comperr.adb, exp_ch9.adb, exp_pakd.adb, sem_ch12.adb, freeze.adb, + s-taprop-mingw.adb, s-taprop-linux.adb, s-taprop-solaris.adb, + gnat1drv.adb, a-rbtgbo.adb, exp_dist.adb: Minor reformatting + +2011-09-01 Matthew Heaney <heaney@adacore.com> + + * Makefile.rtl, impunit.adb: Add a-csquin.ads, a-cusyqu.ad[sb], + a-cuprqu.ad[sb], a-cbsyqu.ad[sb], a-cbprqu.ad[sb] + * a-csquin.ads: New Ada 2012 unit that specifies the queue interface + * a-cusyqu.ads, a-cusyqu.adb: New Ada 2012 unit that specifies the + unbounded queue container. + * a-cbsyqu.ads, a-cbsyqu.adb: New Ada 2012 unit that specifies the + bounded queue container. + * a-cuprqu.ads, a-cuprqu.adb: New Ada 2012 unit that specifies the + unbounded priority queue container. + * a-cbprqu.ads, a-cbprqu.adb: New Ada 2012 unit that specifies the + bounded priority queue container. + +2011-08-31 Pascal Obry <obry@adacore.com> + + * a-direct.adb: Do not try to create an UNC path on Windows. + (Create_Path): Skip leading computer name in UNC path if any. + +2011-08-31 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_strm.adb (Build_Record_Or_Elementary_Input_Function): Remove the + version-dependent generation of the return statement. The Ada 2005 tree + is now the default. + +2011-08-31 Thomas Quinot <quinot@adacore.com> + + * rtsfind.ads, exp_dist.adb (Find_Numeric_Representation): Predefined + types Stream_Element_Offset and Storage_Offset have a different native + type depending on whether the platform is 32 or 64 bits. When + exchanging them, always convert to 64 bits. + +2011-08-31 Yannick Moy <moy@adacore.com> + + * debug.adb: Reserve debug option -gnatd.E for passing gnatprove option + --force-alfa to gnat2why. + +2011-08-31 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Save_References): If the node has aspects, save + references within the corresponding expressions in a separate step, + because the aspects are not directly in the tree for the declaration + to which they belong. + +2011-08-31 Arnaud Charlet <charlet@adacore.com> + + * freeze.adb (Freeze_Record_Type): Omit test on variable size component + in CodePeer mode, since representation clauses are partially ignored. + * gcc-interface/Make-lang.in: Update dependencies. + +2011-08-31 Jose Ruiz <ruiz@adacore.com> + + * s-taprop-vxworks.adb, s-taprop-mingw.adb, s-taprop-linux.adb, + s-taprop-solaris.adb (Create_Task): Not_A_Specific_CPU can be assigned + to any dispatching domain. + +2011-08-31 Thomas Quinot <quinot@adacore.com> + + * exp_ch4.adb: Minor reformatting. + +2011-08-31 Bob Duff <duff@adacore.com> + + * sem_ch6.adb (Get_Generic_Parent_Type): Don't query Subtype_Indication + on nodes for which it is not defined. + (Is_Non_Overriding_Operation): Exit the loop when we find a generic + parent type. + +2011-08-31 Bob Duff <duff@adacore.com> + + * sem_ch3.adb (Process_Full_View): Disable legality check if + In_Instance, to avoid spurious errors. + * sem_ch12.adb (Validate_Derived_Type_Instance): Disable legality check + if In_Instance, to avoid spurious errors. + +2011-08-31 Pascal Obry <obry@adacore.com> + + * a-direct.adb: Use Dir_Seps everywhere to properly handle all + directory speparators. + (Compose): Use Dir_Seps to handle both forms. + (Create_Path): Use Dir_Seps instead of explicit check, no semantic + changes. + (Extension): Use Dir_Seps to handle both forms. + +2011-08-31 Pascal Obry <obry@adacore.com> + + * prj-conf.adb: Minor reformatting. + +2011-08-31 Jose Ruiz <ruiz@adacore.com> + + * aspects.ads (Aspect_Id, Aspect_Argument, Aspect_Names): Add the + dispatching domain aspect. + * aspects.adb (Canonical_Aspect): Add entry for the dispatching domain + aspect. + * sem_ch13.adb (Analyze_Aspect_Specifications): Analyze the + Dispatching_Domain aspect in a similar way as we do for the Priority + aspect. + * exp_ch9.adb (Expand_N_Task_Type_Declaration): Add the + Dispatching_Domain component if a Dispatching_Domain pragma or aspect + is present. + (Make_Task_Create_Call): Add the Dispatching_Domain when creating a task + * par-prag.adb (Prag): Add Pragma_Dispatching_Domain as a known pragma. + * sem_prag.adb (Analyze_Pragma): Check the correctness of a pragma + Dispatching_Domain and add it to the task definition. + (Sig_Flags): Add Pragma_Dispatching_Domain. + * rtsfind.ads, rtsfind.adb (RTU_Id, RE_Id, Get_Unit_Name): Add the + support to find the types Dispatching_Domain and + Dispatching_Domain_Access. + * sinfo.ads, sinfo.adb (Has_Pragma_Dispatching_Domain, + Set_Has_Pragma_Dispatching_Domain): Add these subprograms to set and + query the availability of a pragma Dispatching_Domain. + * snames.ads-tmpl (Name_uDispatching_Domain): Add this name required by + the expander to pass the Dispatching_Domain when creating a task. + (Name_Dispatching_Domain): Add this new name for a pragma. + (Pragma_Id): Add the new Pragma_Dispatching_Domain. + * s-tassta.ads, s-tassta.adb (Create_Task): Set the domain to which the + task has been allocated at creation time. + * s-tarest.adb (Create_Restricted_Task): The dispatching domain using + Ravenscar is always null. + * s-taskin.ads, s-taskin.adb (Initialize_ATCB): Set the domain to which + the task has been allocated at creation time. + * s-tporft.adb (Register_Foreign_Thread): A foreign task will not have + a specific dispatching domain. + * s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-vxworks.adb, + s-taprop-mingw.adb (Create_Task): Check whether both Dispatching_Domain + and CPU are specified for the task, and the CPU value is not contained + within the range of processors for the domain. + +2011-08-31 Vincent Celier <celier@adacore.com> + + * make.adb (Original_Gcc) : New constant String_Access. + (Gnatmake): For VM targets, do not use VM version of the compiler if + --GCC= has been specified. + +2011-08-31 Thomas Quinot <quinot@adacore.com> + + * sem_ch5.adb: Minor reformatting. + +2011-08-31 Ed Schonberg <schonberg@adacore.com> + + * exp_pakd.adb (Convert_To_PAT_Type): If prefix is a function call, do + not reanalyze it. + +2011-08-31 Bob Duff <duff@adacore.com> + + * exp_ch4.adb (Expand_N_Selected_Component): Use the full type, in case + the access type is private; we don't care about privacy in expansion. + +2011-08-31 Ed Schonberg <schonberg@adacore.com> + + * sem_aggr.adb (Resolve_Aggregate): In an instance, ignore aggregate + subcomponents tnat may be limited, because they originate in view + conflicts. If the original aggregate is legal and the actuals are + legal, the aggregate itself is legal. + +2011-08-31 Matthew Heaney <heaney@adacore.com> + + * a-rbtgbo.adb (Clear_Tree): Assert representation invariant for lock + status. + +2011-08-31 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb: Set kind of loop parameter properly, to preserve all + errors in B tests. + +2011-08-31 Jose Ruiz <ruiz@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): For the Priority and + Interrupt_Priority aspects, force the analysis of the aspect expression + (when building the equivalent pragma). Otherwise, its analysis is done + too late, after the task or protected object has been created. + * sem_ch9.adb (Analyze_Single_Protected_Declaration, + Analyze_Single_Task_Declaration): Remove the code to move the aspects + to the object declaration because they are needed in the type + declaration. + +2011-08-31 Robert Dewar <dewar@adacore.com> + + * exp_ch5.adb, exp_ch7.ads, sem_ch5.adb, put_scos.adb, s-rannum.adb, + a-rbtgbo.adb, exp_intr.adb, a-cbdlli.adb, a-cbdlli.ads: Minor + reformatting. + +2011-08-31 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_util.adb (Find_Protection_Type): Do not look for fields _object + if the corresponding type is malformed due to restriction violations. + +2011-08-31 Robert Dewar <dewar@adacore.com> + + * s-ransee.ads, s-ransee.adb: Minor reformatting. + +2011-08-31 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Expand_N_Allocator): Correct faulty condition which + would cause the generation of Set_Finalize_Address if the target is a + VM and the designated type is not derived from [Limited_]Controlled. + +2011-08-31 Arnaud Charlet <charlet@adacore.com> + + * comperr.adb, comperr.ads, gnat1drv.adb (Delete_SCIL_Files): New + subprogram. + (Compiler_Abort, Gnat1drv): Call Delete_SCIL_Files in codepeer mode in + case of a compilation error. + +2011-08-31 Hristian Kirtchev <kirtchev@adacore.com> + + * init.c (__gnat_error_handler): Standardize the stack overflow or + erroneous memory access message. + * seh_init.c (__gnat_SEH_error_handler): Standardize the stack overflow + or erroneous memory access message. + +2011-08-31 Robert Dewar <dewar@adacore.com> + + * sem_ch4.adb: Minor reformatting. + * sem_ch6.adb: Minor code reorganization (use Ekind_In). + +2011-08-31 Thomas Quinot <quinot@adacore.com> + + * scos.ads: Minor documentation clarification. + * put_scos.adb: Do not generate SCO unit header line for a unit that + has no SCO lines. + +2011-08-31 Robert Dewar <dewar@adacore.com> + + * a-rbtgbo.adb, alfa_test.adb: Minor reformatting. + +2011-08-31 Tristan Gingold <gingold@adacore.com> + + * exp_ch7.ads, exp_ch7.adb (Finalization_Exception_Data): New type to + hold variables between these following subprograms. + (Build_Exception_Handler, Build_Object_Declarations, + Build_Raise_Statement): Use the above type as parameter. + Make the above adjustments. + * exp_intr.adb (Expand_Unc_Deallocation): Adjust. + +2011-08-31 Pascal Obry <obry@adacore.com> + + * projects.texi: Minor reformatting. + +2011-08-31 Tristan Gingold <gingold@adacore.com> + + * s-ransee.ads, s-ransee.adb: Add system.random_seed unit. + * s-rannum.adb (Reset): Use Get_Seed from s-ransee. + +2011-08-31 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb: Minor code cleanup. + * sem_ch5.adb (Analyze_Iteration_Scheme): Set ekind of loop variable to + prevent cascaded errors. + (Analyze_Loop_Statement): In semantics-only mode, introduce loop + variable of an iterator specification in current scope. + * sem_ch6.adb (Analyze_Return_Statement, Find_what_It_Apples_To): Skip + postconditions on the stack, as they contain no return statements. + +2011-08-31 Yannick Moy <moy@adacore.com> + + * exp_alfa.adb (Expand_Alfa_N_Package_Declaration, + Expand_Alfa_N_Subprogram_Body): Remove useless procedures which simply + call Qualify_Entity_Names. + (Expand_Alfa): call Qualify_Entity_Names in more cases + * lib-xref-alfa.adb: Take into account system package. + * sem_prag.adb Take into account restrictions in Alfa mode, contrary to + CodePeer mode in which we are interested in finding bugs even if + compiler cannot compile source. + * sem_util.adb, sem_util.ads (Unique_Entity): Take into account case of + deferred constant. + +2011-08-31 Gary Dismukes <dismukes@adacore.com> + + * sem_ch3.adb (Constrain_Concurrent): Retrieve Base_Type of the subtype + denoted by the subtype mark to ensure getting the concurrent type in + the case where the subtype mark denotes a private subtype of a + concurrent type (needed when using -gnatc). + (Process_Subtype): For the processing specific to type kinds, case on + the Base_Type kind of the Subtype_Mark_Id, to handle cases where the + subtype denotes a private subtype whose base type is nonprivate (needed + for subtypes of private fulfilled by task types when compiling with + -gnatc). + +2011-08-31 Gary Dismukes <dismukes@adacore.com> + + * sem_disp.adb (Check_Dispatching_Operation): Bypass registration of + late primitives that override interface operations when the full + expander is not active, to avoid blowups in Register_Primitive when + types don't have associated secondary dispatch tables. + +2011-08-31 Yannick Moy <moy@adacore.com> + + * alfa_test.adb: Code clean up. + +2011-08-31 Marc Sango <sango@adacore.com> + + * restrict.adb (Check_SPARK_Restriction): Change Comes_From_Source (N) + by Comes_From_Source (Original_Node (N)) in order to treat also the + nodes which have been rewritten. + * sem_ch4.adb (Analyze_Explicit_Dereference, Analyze_Slice): Guard the + explicit dereference and slice violation in spark mode on the nodes + coming only from the source code. + +2011-08-31 Robert Dewar <dewar@adacore.com> + + * exp_ch5.adb, exp_alfa.ads, prj.ads, sem_attr.adb, + lib-xref-alfa.adb: Minor reformatting. + +2011-08-31 Matthew Heaney <heaney@adacore.com> + + * a-crbltr.ads (Tree_Type): Default-initialize the Nodes component. + +2011-08-31 Javier Miranda <miranda@adacore.com> + + * sem_ch4.adb (Try_Object_Operation): Addition of one formal to search + only for class-wide subprograms conflicting with entities of concurrent + tagged types. + +2011-08-31 Matthew Heaney <heaney@adacore.com> + + * a-rbtgbo.adb (Generic_Allocate): Initialize pointer components of + node to null value. + +2011-08-31 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch12.adb (Insert_Freeze_Node_For_Instance): Provide a more + general description of the routine. + +2011-08-31 Ed Schonberg <schonberg@adacore.com> + + * a-cbdlli.adb, a-cbdlli.ads: Add iterator machinery to bounded + doubly-linked lists. + +2011-08-31 Gary Dismukes <dismukes@adacore.com> + + * exp_ch5.adb (Expand_N_Assignment_Statement): When a discriminant + check is needed for a left-hand side that is a dereference, and the + base type is private without discriminants (whereas the full type does + have discriminants), an extra retrieval of the underlying type may be + needed in the case where the subtype is a record subtype whose base + type is private. Update comments. + +2011-08-31 Javier Miranda <miranda@adacore.com> + + * sem_ch4.adb (Try_Object_Operation): When a dispatching primitive is + found check if there is a class-wide subprogram covering the primitive. + +2011-08-31 Yannick Moy <moy@adacore.com> + + * sem_res.adb: Further cases where full expansion test is needed, + rather than expansion test. + +2011-08-31 Pascal Obry <obry@adacore.com> + + * prj-attr.adb: Fix Source_File_Switches attribute kind (must be a list) + +2011-08-31 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb: Handle iterators over derived container types. + +2011-08-31 Hristian Kirtchev <kirtchev@adacore.com> + + * einfo.ads, einfo.adb: Add new flag Has_Anonymous_Master. + (Has_Anonymous_Master): New routine. + (Set_Has_Anonymous_Master): New routine. + (Write_Entity_Flags): Add an entry for Has_Anonymous_Master. + * exp_ch4.adb: Add with and use clause for Sem_Ch8. + (Current_Anonymous_Master): New routine. + (Current_Unit_First_Declaration): Removed. + (Current_Unit_Scope): Removed. + (Expand_N_Allocator): Anonymous access-to-controlled types now chain + their objects on a per-unit heterogeneous finalization master. + +2011-08-31 Matthew Heaney <heaney@adacore.com> + + * a-cbhama.adb, a-cbhase.adb (Insert): Check for zero-length buckets + array. + +2011-08-31 Jose Ruiz <ruiz@adacore.com> + + * s-taprop-linux.adb (Create_Task): Avoid changing the affinity mask + when not needed. + +2011-08-31 Gary Dismukes <dismukes@adacore.com> + + * sem_disp.adb (Propagate_Tag): Return without propagating in the case + where the actual is an unexpanded call to 'Input. + +2011-08-31 Yannick Moy <moy@adacore.com> + + * sem_ch4.adb: Code clean up. + +2011-08-31 Yannick Moy <moy@adacore.com> + + * exp_alfa.adb, exp_alfa.ads: Minor correction of copyright notice. + +2011-08-31 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Build_Array_Deep_Procs): Do not generate Deep_Finalize + and TSS primitive Finalize_Address if finalization is suppressed. + (Build_Record_Deep_Procs): Do not generate Deep_Finalize and TSS + primitive Finalize_Address if finalization is suppressed. + +2011-08-31 Jose Ruiz <ruiz@adacore.com> + + * s-mudido-affinity.adb, s-taprop-linux.adb, s-taprop-mingw.adb, + s-taprop-solaris.adb, s-taprop-vxworks.adb (Set_Task_Affinity): Make + sure that the underlying task has already been created before trying + to change its affinity. + (Set_CPU): Use the term processor instead of CPU, as we do in + Assign_Task. + +2011-08-31 Vincent Celier <celier@adacore.com> + + * prj-attr.adb: New Compiler attribute Source_File_Switches. + * prj-nmsc.adb (Process_Compiler): Process attribute + Source_File_Switches. + * prj.ads (Language_Config): New name list component + Name_Source_File_Switches. + * snames.ads-tmpl (Name_Source_File_Switches): New standard name. + +2011-08-31 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Analyze_Attribute, case 'Old): If prefix may be a + discriminated component of an actual, expand at once to prevent + ouf-of-order references with generated subtypes. + +2011-08-31 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb (Add_Alfa_Xrefs): Do not take into account read + reference to operator in Alfa xrefs. + +2011-08-31 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch12.adb (Freeze_Subprogram_Body): Add code to handle the case + where the parent instance was frozen before the current instance due to + the presence of a source body. Update calls to Insert_After_Last_Decl. + (Insert_After_Last_Decl): Renamed to Insert_Freeze_Node_For_Instance. + Update the comment which illustrates the purpose of the routine. + Package instances are now frozen by source bodies which appear after + the instance. This ensures that entities coming from within the + instance are available for use in the said bodies. + (Install_Body): Add code to handle the case where the parent instance + was frozen before the current instance due to the presence of a source + body. Update calls to Insert_After_Last_Decl. + +2011-08-31 Jose Ruiz <ruiz@adacore.com> + + * s-taprop-linux.adb (Set_Task_Affinity): Avoid the use of anonymous + access types. + * affinity.c (__gnat_set_affinity_mask): Declare index variable. + +2011-08-31 Yannick Moy <moy@adacore.com> + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Refine expander test in + full-expander test. + * alfa.adb, alfa.ads, alfa_test.adb, ali.adb, debug.adb, errout.adb, + errout.ads, erroutc.adb, expander.adb, exp_ch4.adb, exp_ch7.adb, + freeze.adb, get_alfa.adb, get_alfa.ads, gnat1drv.adb, lib-writ.adb, + lib-writ.ads, lib-xref.adb, lib-xref.ads, lib-xref-alfa.adb, opt.adb, + opt.ads, put_alfa.adb, put_alfa.ads, restrict.adb, sem_ch12.adb, + sem_ch13.adb, sem_ch3.adb, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, + sem_prag.adb, sem_res.adb, sem_util.adb: Minor reformatting, renaming + ALFA in Alfa (we dropped acronym). + * einfo.adb (Primitive_Operations): Correctly return list of primitive + operations in a case where it returned previously No_Elist. + +2011-08-31 Robert Dewar <dewar@adacore.com> + + * s-taprop-vxworks.adb, sem_ch5.adb, s-taprop-tru64.adb, exp_alfa.adb, + s-taprop-vms.adb, bindgen.adb, s-mudido.adb, s-mudido.ads, + sem_res.adb, expander.adb, s-taprop-mingw.adb, s-taprop-linux.adb, + s-taprop-solaris.adb, s-mudido-affinity.adb, vms_conv.adb, + s-taprop-irix.adb, s-taprop.ads, s-taskin.adb, s-taskin.ads, + s-taprop-hpux-dce.adb, a-chtgbo.adb, s-taprop-posix.adb: Minor + reformatting. + +2011-08-31 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch12 (Check_Private_View): Revert previous change. + * sem_res.adb (Conversion_Check): Do not emit the error message if the + conversion is in a generic instance. + +2011-08-31 Matthew Heaney <heaney@adacore.com> + + * a-cbhase.adb (Symmetric_Difference): Dereference correct node array. + * a-chtgbo.adb (Free): Allow 0 as index value. + +2011-08-31 Matthew Heaney <heaney@adacore.com> + + * a-cborma.adb (Insert): Add comment to explain why no element + assignment. + +2011-08-31 Gary Dismukes <dismukes@adacore.com> + + * sem_util.adb (Find_Body_Discriminal): Test whether the scope of the + spec discriminant is already a concurrent type, in which case just use + it, otherwise fetch the Corresponding_Concurrent_Type as before. + +2011-08-30 Eric Botcazou <ebotcazou@adacore.com> + + * system-irix-n64.ads, system-linux-armeb.ads, system-linux-armel.ads, + system-linux-mips.ads, system-linux-mipsel.ads, + system-linux-mips64el.ads, system-linux-ppc64.ads, + system-linux-sparcv9.ads, system-rtems.ads: Remove GCC_ZCX_Support. + +2011-08-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/ada-tree.h (TYPE_EXTRA_SUBTYPE_P): Add internal check. + * gcc-interface/utils2.c (build_binary_op): Tighten condition. + (build_unary_op): Likewise. + +2011-08-30 Eric Botcazou <ebotcazou@adacore.com> + + * raise-gcc.c: Do not include coretypes.h and tm.h. + (setup_to_install): Remove test for compiler macro. + * targext.c: Document use for the library. + * gcc-interface/Makefile.in: Fix comment on the use of IN_GCC. + +2011-08-30 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <object>: Do not convert + the expression to the nominal type if the latter is a record type with + a variant part and the type of the former is a record type without one. + +2011-08-30 Yannick Moy <moy@adacore.com> + + * exp_aggr.adb, exp_ch11.adb, exp_prag.adb: Remove early exit during + expansion in Alfa mode. + * exp_ch6.adb, exp_ch6.ads (Expand_Actuals): Make subprogram public + * exp_alfa.adb, exp_alfa.ads: New package defining light expansion for + Alfa mode. + * gnat1drv.adb (Adjust_Global_Switches): Update Comment. + * sem_res.adb: Ditto. + * gcc-interface/Make-lang.in: Update dependencies. + +2011-08-30 Thomas Quinot <quinot@adacore.com> + + * g-socket.ads: Minor documentation adjustment. + +2011-08-30 Robert Dewar <dewar@adacore.com> + + * exp_ch9.adb, s-tassta.adb, s-secsta.adb: Minor reformatting. + +2011-08-30 Yannick Moy <moy@adacore.com> + + * exp_ch6_light.adb, exp_ch6_light.ads, exp_attr_light.adb, + exp_attr_light.ads, exp_ch7_light.adb, exp_ch7_light.ads, + exp_light.adb, exp_light.ads, exp_prag.adb, expander.adb, + gnat1drv.adb, exp_ch11.adb, exp_ch6.adb, exp_ch6.ads, exp_aggr.adb: + Revert change which introduced files for "light" + expansion, to be replaced by a single file for Alfa expansion. + +2011-08-30 Robert Dewar <dewar@adacore.com> + + * opt.ads, s-soflin.adb, exp_ch9.adb, sem_res.adb: Update comment. + Minor code reorg/reformatting. + +2011-08-30 Yannick Moy <moy@adacore.com> + + * opt.adb, opt.ads (Full_Expander_Active): New function defines a + common shorthand for (Expander_Active and not ALFA_Mode) that can be + used for testing full expansion, that is active expansion not in the + reduced mode for Alfa + * exp_ch4.adb, exp_ch9.adb, exp_disp.adb, sem_ch10.adb, sem_ch12.adb, + sem_ch6.adb, sem_ch9.adb, sem_res.adb: Use newly defined "flag" instead + of the verbose (Expander_Active and not ALFA_Mode) + +2011-08-30 Tristan Gingold <gingold@adacore.com> + + * s-parame-vms-alpha.ads, s-parame-hpux.ads, s-tassta.adb, + s-tarest.adb, s-parame-vms-ia64.ads, s-soflin.adb, s-secsta.adb, + s-secsta.ads, s-parame.ads, s-parame-vxworks.ads, s-parame-ae653.ads: + Renames Ratio to Percentage, and Sec_Stack_Ratio to Sec_Stack_Percentage + +2011-08-30 Gary Dismukes <dismukes@adacore.com> + + * sem_res.adb (Valid_Conversion): Revise test for implicit anonymous + access conversions to check that the conversion is a rewritten node, + rather than just having Comes_From_Source set to False, which wasn't + sufficient. + +2011-08-30 Robert Dewar <dewar@adacore.com> + + * exp_ch9.adb, sem_ch9.adb, sem_ch6.adb, exp_disp.adb, + g-socket.ads: Minor reformatting. + +2011-08-30 Thomas Quinot <quinot@adacore.com> + + * sem_util.adb: Minor reformatting. + +2011-08-30 Tristan Gingold <gingold@adacore.com> + + * raise-gcc.c: Never catch exception if _UA_FORCE_UNWIND flag is set, + to be compliant with the ABI. + +2011-08-30 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch12.adb (Check_Private_View): Exchange the private and full view + of a designated type when the related access type is an actual in an + instance. This ensures that the full view of designated type is + available when inside the body of the instance. + +2011-08-30 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (May_Be_Lvalue): To determine whether a reference may be + in a position to be modified, a slice is treated like an indexed + component. + +2011-08-30 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c, g-socket.ads: Adjust maximum allowed value for + field tv_sec in struct timeval. + +2011-08-30 Yannick Moy <moy@adacore.com> + + * exp_ch9.adb, exp_disp.adb, sem_ch9.adb, sem_res.adb: Protect several + blocks of code doing full expansion, previously only guarded by + Expander_Active, by anding the test that ALFA_Mode is not set + +2011-08-30 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Return_Type): If the return type is incomplete, + add the function to the list of private dependents, for subsequent + legality check on Taft amendment types. + * sem_ch12.adb (Analyze_Formal_Incomplete_Type): Initialize + Private_Dependents, as for other incomplete types. + * sem_util.adb (Wrong_Type): Avoid cascaded errors when a + Taft-amendment type is used as the return type of a function. + +2011-08-30 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Check_Abstract_Overriding): Code cleanup: replace code + which emits an error by a call to a new routine which report the error. + * exp_ch9.adb (Build_Wrapper_Spec): Build the wrapper even if the + entity does not cover an existing interface. + * errout.ads, errout.adb (Error_Msg_PT): New routine. Used to factorize + code. + * sem_ch6.adb (Check_Conformance): Add specific error for wrappers of + protected procedures or entries whose mode is not conformant. + (Check_Synchronized_Overriding): Code cleanup: replace code which emits + an error by a call to a new routine which report the error. + +2011-08-30 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Minor change. + * exp_attr_light.adb: Minor reformatting. + +2011-08-30 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb: Patch inheritance of aspects in + Complete_Private_Subtype, to avoid infinite loop. + +2011-08-30 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Add_Internal_Interface_Entities): If serious errors have + been reported and a subprogram covering an interface primitive is not + found then skip generating the internal entity. Done to avoid crashing + the frontend. + (Check_Abstract_Overriding): Change text of error of wrong formal of + protected subprogram or entry. Done for consistency to emit exactly the + same error reported by Check_Synchronized_Overriding. In addition, the + error is restricted to protected types (bug found working on AI05-0090) + +2011-08-30 Yannick Moy <moy@adacore.com> + + * exp_aggr.adb, exp_ch11.adb, exp_prag.adb: Remove early exit during + expansion in Alfa mode. + * exp_ch6.adb, exp_ch6.ads (Expand_Actuals): Make subprogram public. + * exp_light.adb, exp_light.ads: New package defining light expansion. + * expander.adb (Expand): Call light expansion in Alfa mode + * exp_ch6_light.adb, exp_ch6_light.ads: Light expansion of chapter 6 + constructs. + * exp_ch7_light.adb, exp_ch7_light.ads: Light expansion of chapter 7 + constructs. + * exp_attr_light.adb, exp_attr_light.ads: Light expansion of attributes + * gnat1drv.adb (Adjust_Global_Switches): Comment + +2011-08-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb: Minor refactoring. + +2011-08-30 Yannick Moy <moy@adacore.com> + + * exp_ch9.adb (Expand_Entry_Barrier): Do not perform expansion in Alfa + mode. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not perform + expansion in Alfa mode. + * sem_ch9.adb (Analyze_Entry_Body): Do not perform expansion in Alfa + mode. + +2011-08-30 Robert Dewar <dewar@adacore.com> + + * debug_a.adb: Update comment. + +2011-08-30 Robert Dewar <dewar@adacore.com> + + * exp_ch5.adb, sem_ch3.adb, sem_ch5.adb, einfo.adb, checks.adb, + sem_util.adb, sem_util.ads, sem_res.adb, s-stposu.adb, sem_attr.adb, + exp_ch4.adb, exp_ch6.adb, lib-xref-alfa.adb, + sem_ch8.adb, sem_disp.adb, exp_ch3.adb: Minor reformatting + +2011-08-30 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Add section on C.6(16) implementation advice for pragma + volatile. + +2011-08-30 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch3.adb (Expand_Freeze_Array_Type): Correct the call to + Build_Finalization_Master by supplying an insertion node and enclosing + scope. In its old version, the call did not generate a finalization + master. + (Expand_Freeze_Record_Type): Add local variable Has_AACC. Add code to + recognize anonymous access-to-controlled components. Rewrite the + machinery which creates finalization masters to service anonymous + access-to-controlled components of a record type. In its current state, + only one heterogeneous master is necessary to handle multiple anonymous + components. + (Freeze_Type): Comment reformatting. + * rtsfind.ads: Add RE_Set_Is_Heterogeneous to tables RE_Id and + RE_Unit_Table. + * s-stposu.adb (Allocate_Any_Controlled): Rewrite the machinery which + associates TSS primitive Finalize_Address with either the master itself + or with the internal hash table depending on the mode of operation of + the master. + +2011-08-30 Javier Miranda <miranda@adacore.com> + + * exp_ch3.adb (Make_Eq_If): If the etype of the _parent component is an + interface type then do not generate code to compare this component. + Required since they have no components and their equality operator is + abstract. + +2011-08-30 Steve Baird <baird@adacore.com> + + * sem_util.ads (Deepest_Type_Access_Level): New function; for the type + of a saooaaat (i.e, a stand-alone object of an anonymous access type), + returns the (static) accessibility level of the object. Otherwise, the + same as Type_Access_Level. + (Dynamic_Accessibility_Level): New function; given an expression which + could occur as the rhs of an assignment to a saooaaat (i.e., an + expression of an access-to-object type), return the new value for the + saooaaat's associated Extra_Accessibility object. + (Effective_Extra_Accessibility): New function; same as + Einfo.Extra_Accessibility except that object renames are looked through. + * sem_util.adb + (Deepest_Type_Access_Level): New function; see sem_util.ads description. + (Dynamic_Accessibility_Level): New function; see sem_util.ads + description. + (Effective_Extra_Accessibility): New function; see sem_util.ads + description. + * einfo.ads (Is_Local_Anonymous_Access): Update comments. + (Extra_Accessibility): Update comments. + (Init_Object_Size_Align): New procedure; same as Init_Size_Align + except RM_Size field (which is only for types) is unaffected. + * einfo.adb + (Extra_Accessibility): Expand domain to allow objects, not just formals. + (Set_Extra_Accessibility): Expand domain to allow objects, not just + formals. + (Init_Size): Add assertion that we are not trashing the + Extra_Accessibility attribute of an object. + (Init_Size_Align): Add assertion that we are not trashing the + Extra_Accessibility attribute of an object. + (Init_Object_Size_Align): New procedure; see einfo.ads description. + * sem_ch3.adb (Find_Type_Of_Object): Set Is_Local_Anonymous_Access + differently for the type of a (non-library-level) saooaaat depending + whether Ada_Version < Ada_2012. This is the only point where Ada_Version + is queried in this set of changes - everything else (in particular, + setting of the Extra_Accessibility attribute in exp_ch3.adb) is + driven off of the setting of the Is_Local_Anonymous_Access attribute. + The special treatment of library-level saooaaats is an optimization, + not required for correctnesss. This is based on the observation that the + Ada2012 rules (static and dynamic) for saooaaats turn out to be + equivalent to the Ada2005 rules in the case of a library-level saooaaat. + * exp_ch3.adb + (Expand_N_Object_Declaration): If Is_Local_Anonymous_Access is + false for the type of a saooaaat, declare and initialize its + accessibility level object and set the Extra_Accessibility attribute + of the saooaaat to refer to this object. + * checks.adb (Apply_Accessibility_Check): Add Ada 2012 saooaaat support. + * exp_ch4.adb (Expand_N_In): Replace some Extra_Accessibility calls with + calls to Effective_Extra_Accessibility in order to support + renames of saooaaats. + (Expand_N_Type_Conversion): Add new local function, + Has_Extra_Accessibility, and call it when determining whether an + accessibility check is needed. + It returns True iff Present (Effective_Extra_Accessibility (Id)) would + evaluate to True (without raising an exception). + * exp_ch5.adb + (Expand_N_Assignment_Statement): When assigning to an Ada2012 + saooaaat, update its associated Extra_Accessibility object (if + it has one). This includes an accessibility check. + * exp_ch6.adb (Add_Call_By_Copy_Code): When parameter copy-back updates + a saooaaat, update its Extra_Accessibility object too (if it + has one). + (Expand_Call): Replace a couple of calls to Type_Access_Level + with calls to Dynamic_Access_Level to handle cases where + passing a literal (any literal) is incorrect. + * sem_attr.adb (Resolve_Attribute): Handle the static accessibility + checks associated with "Saooaat := Some_Object'Access;"; this must + be rejected if Some_Object is declared in a more nested scope + than Saooaat. + * sem_ch5.adb (Analyze_Assignment): Force accessibility checking for an + assignment to a saooaaat even if Is_Local_Anonymous_Access + returns False for its type (indicating a 2012-style saooaaat). + * sem_ch8.adb + (Analyze_Object_Renaming): Replace a call to Init_Size_Align + (which is only appropriate for objects, not types) with a call + of Init_Object_Size_Align in order to avoid trashing the + Extra_Accessibility attribute of a rename (the two attributes + share storage). + * sem_res.adb + (Valid_Conversion) Replace six calls to Type_Access_Level with + calls to Deepest_Type_Access_Level. This is a bit tricky. For an + Ada2012 non-library-level saooaaat, the former returns library level + while the latter returns the (static) accessibility level of the + saooaaat. A type conversion to the anonymous type of a saooaaat + can only occur as part of an assignment to the saooaaat, so we + know that such a conversion must be in a lhs context, so Deepest + yields the result that we need. If such a conversion could occur, + say, as the operand of an equality operator, then this might not + be right. Also add a test so that static accessibilty checks are + performed for converting to a saooaaat's type even if + Is_Local_Anonymous_Access yields False for the type. + +2011-08-30 Javier Miranda <miranda@adacore.com> + + * sem_disp.adb (Check_Dispatching_Operation): Complete condition that + controls generation of a warning associated with late declaration of + dispatching functions. Required to avoid generating spurious + warnings. + +2011-08-30 Gary Dismukes <dismukes@adacore.com> + + * sem_ch6.adb (Check_Return_Subtype_Indication): Issue error if the + return object has an anonymous access type and the function's type is + a named access type. + * sem_ch8.adb (Analyze_Object_Renaming): Suppress error about renaming + conversions on implicit conversions, since such conversions can occur + for anonymous access cases due to expansion. Issue error for attempt + to rename an anonymous expression as an object of a named access type. + * sem_res.ads (Valid_Conversion): Add defaulted parameter Report_Errs, + to indicate whether this function should report errors on invalid + conversions. + * sem_res.adb (Resolve): For Ada 2012, in the case where the type of + the expression is of an anonymous access type and the expected type is + a named general access type, rewrite the expression as a type + conversion, unless this is an expression of a membership test. + (Valid_Conversion.Error_Msg_N): New procedure that conditions the + calling of Error_Msg_N on new formal Report_Errs. + (Valid_Conversion.Error_Msg_NE): New procedure that conditions the + calling of Error_Msg_NE on new formal Report_Errs. + (Valid_Conversion): Move declaration of this function to the package + spec, to allow calls from membership test processing. For Ada 2012, + enforce legality restrictions on implicit conversions of anonymous + access values to general access types, disallowing such conversions in + cases where the expression has a dynamic accessibility level (access + parameters, stand-alone anonymous access objects, or a component of a + dereference of one of the first two cases). + * sem_type.adb (Covers): For Ada 2012, allow an anonymous access type + in the context of a named general access expected type. + * exp_ch4.adb Add with and use of Exp_Ch2. + (Expand_N_In): Add processing for membership tests applied to + expressions of an anonymous access type. First, Valid_Conversion is + called to check whether the test is statically False, and then the + conversion is expanded to test that the expression's accessibility + level is no deeper than that of the tested type. In the case of + anonymous access-to-tagged types, a tagged membership test is applied + as well. + (Tagged_Membership): Extend to handle access type cases, applying the + test to the designated types. + * exp_ch6.adb (Expand_Call): When creating an extra actual for an + accessibility level, and the actual is a 'Access applied to a current + instance, pass the accessibility level of the type of the current + instance rather than applying Object_Access_Level to the prefix. Add a + ??? comment, since this level isn't quite right either (will eventually + need to pass an implicit level parameter to init procs). + +2011-08-30 Bob Duff <duff@adacore.com> + + * s-taskin.ads: Minor comment fix. + +2011-08-30 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Check_Parameterless_Call): If the node is a selected + component and the selector is a dispatching operation, check if it is + a prefixed call before rewriting as a parameterless function call. + 2011-08-29 Jakub Jelinek <jakub@redhat.com> * gcc-interface/Makefile.in (../stamp-gnatlib1-$(RTSDIR)): Copy @@ -1220,7 +2548,7 @@ system-solaris-x86_64.ads, system-mingw-x86_64.ads, system-vxworks-mips.ads, system-linux-sparc.ads, system-vms-ia64.ads, system-freebsd-x86.ads, system-aix.ads, system-darwin-x86_64.ads, - system-vxworks-x86.ads: Remove GCC_ZCX_Support + system-vxworks-x86.ads: Remove GCC_ZCX_Support. * s-taprop-posix.adb, s-taprop-irix.adb, s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-linux.adb, s-taprop-solaris.adb: Ditto. * opt.ads: Adjust comment. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index eac13f7eacd..30a95065153 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1,5 +1,5 @@ # Makefile.rtl for GNU Ada Compiler (GNAT). -# Copyright (C) 2003-2010, Free Software Foundation, Inc. +# Copyright (C) 2003-2011, Free Software Foundation, Inc. #This file is part of GCC. @@ -48,7 +48,7 @@ GNATRTL_TASKING_OBJS= \ s-inmaop$(objext) \ s-interr$(objext) \ s-intman$(objext) \ - s-oscons$(objext) \ + s-mudido$(objext) \ s-osinte$(objext) \ s-proinf$(objext) \ s-solita$(objext) \ @@ -93,6 +93,8 @@ GNATRTL_NONTASKING_OBJS= \ a-cbdlli$(objext) \ a-cbmutr$(objext) \ a-cborma$(objext) \ + a-cbprqu$(objext) \ + a-cbsyqu$(objext) \ a-cdlili$(objext) \ a-cfdlli$(objext) \ a-cfhama$(objext) \ @@ -143,6 +145,9 @@ GNATRTL_NONTASKING_OBJS= \ a-crdlli$(objext) \ a-comutr$(objext) \ a-cimutr$(objext) \ + a-csquin$(objext) \ + a-cuprqu$(objext) \ + a-cusyqu$(objext) \ a-cwila1$(objext) \ a-cwila9$(objext) \ a-decima$(objext) \ @@ -536,6 +541,7 @@ GNATRTL_NONTASKING_OBJS= \ s-memory$(objext) \ s-multip$(objext) \ s-os_lib$(objext) \ + s-oscons$(objext) \ s-osprim$(objext) \ s-pack03$(objext) \ s-pack05$(objext) \ @@ -602,6 +608,7 @@ GNATRTL_NONTASKING_OBJS= \ s-powtab$(objext) \ s-purexc$(objext) \ s-rannum$(objext) \ + s-ransee$(objext) \ s-regexp$(objext) \ s-regpat$(objext) \ s-restri$(objext) \ diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index 61615a0c89b..a8a7c5eafbc 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -30,6 +30,22 @@ with System; use type System.Address; package body Ada.Containers.Bounded_Doubly_Linked_Lists is + type Iterator is new + List_Iterator_Interfaces.Reversible_Iterator with record + Container : List_Access; + Node : Count_Type; + end record; + + 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 -- @@ -526,6 +542,15 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return Cursor'(Container'Unrestricted_Access, Container.First); end First; + function First (Object : Iterator) return Cursor is + begin + if Object.Container = null then + return No_Element; + else + return (Object.Container, Object.Container.First); + end if; + end First; + ------------------- -- First_Element -- ------------------- @@ -1021,6 +1046,7 @@ 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; @@ -1030,6 +1056,28 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is B := B - 1; end Iterate; + function Iterate + (Container : List) + return List_Iterator_Interfaces.Reversible_Iterator'class + is + begin + if Container.Length = 0 then + return Iterator'(null, Count_Type'First); + else + return Iterator'(Container'Unrestricted_Access, Container.First); + end if; + end Iterate; + + function Iterate + (Container : List; + Start : Cursor) + return List_Iterator_Interfaces.Reversible_Iterator'class + is + It : constant Iterator := (Container'Unrestricted_Access, Start.Node); + begin + return It; + end Iterate; + ---------- -- Last -- ---------- @@ -1043,6 +1091,15 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return Cursor'(Container'Unrestricted_Access, Container.Last); end Last; + function Last (Object : Iterator) return Cursor is + begin + if Object.Container = null then + return No_Element; + else + return (Object.Container, Object.Container.Last); + end if; + end Last; + ------------------ -- Last_Element -- ------------------ @@ -1133,6 +1190,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is end; end Next; + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + Nodes : Node_Array renames Position.Container.Nodes; + Node : constant Count_Type := Nodes (Position.Node).Next; + begin + if Position.Node = Object.Container.Last then + return No_Element; + else + return (Object.Container, Node); + end if; + end Next; + ------------- -- Prepend -- ------------- @@ -1175,6 +1246,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is end; end Previous; + function Previous + (Object : Iterator; + Position : Cursor) return Cursor + is + Nodes : Node_Array renames Position.Container.Nodes; + Node : constant Count_Type := Nodes (Position.Node).Prev; + begin + if Position.Node = 0 then + return No_Element; + else + return (Object.Container, Node); + end if; + end Previous; + ------------------- -- Query_Element -- ------------------- @@ -1257,6 +1342,52 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is raise Program_Error with "attempt to stream list cursor"; end Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Constant_Reference (Container : List; Position : Cursor) + return Constant_Reference_Type is + begin + pragma Unreferenced (Container); + + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return (Element => + Position.Container.Nodes (Position.Node).Element'Unrestricted_Access); + end Constant_Reference; + + function Reference (Container : List; Position : Cursor) + return Reference_Type is + begin + pragma Unreferenced (Container); + + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return (Element => + Position.Container.Nodes (Position.Node).Element'Unrestricted_Access); + end Reference; + --------------------- -- Replace_Element -- --------------------- @@ -2001,4 +2132,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is raise Program_Error with "attempt to stream list cursor"; end Write; + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + end Ada.Containers.Bounded_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cbdlli.ads b/gcc/ada/a-cbdlli.ads index 2e5d96cd58d..0443c304a8a 100644 --- a/gcc/ada/a-cbdlli.ads +++ b/gcc/ada/a-cbdlli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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 -- @@ -31,7 +31,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -private with Ada.Streams; +with Ada.Streams; use Ada.Streams; +with Ada.Iterator_Interfaces; generic type Element_Type is private; @@ -43,7 +44,12 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is pragma Pure; pragma Remote_Types; - type List (Capacity : Count_Type) is tagged private; + type List (Capacity : Count_Type) is tagged private with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + pragma Preelaborable_Initialization (List); type Cursor is private; @@ -53,6 +59,11 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is No_Element : constant Cursor; + function Has_Element (Position : Cursor) return Boolean; + + package List_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + function "=" (Left, Right : List) return Boolean; function Length (Container : List) return Count_Type; @@ -129,6 +140,15 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is procedure Reverse_Elements (Container : in out List); + function Iterate + (Container : List) + return List_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate + (Container : List; + Start : Cursor) + return List_Iterator_Interfaces.Reversible_Iterator'class; + procedure Swap (Container : in out List; I, J : Cursor); @@ -183,8 +203,6 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is (Container : List; Item : Element_Type) return Boolean; - function Has_Element (Position : Cursor) return Boolean; - procedure Iterate (Container : List; Process : not null access procedure (Position : Cursor)); @@ -205,6 +223,48 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is end Generic_Sorting; + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type (Element : not null access Element_Type) is + private + with + Implicit_Dereference => Element; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + function Constant_Reference + (Container : List; Position : Cursor) -- SHOULD BE ALIASED + return Constant_Reference_Type; + + function Reference + (Container : List; Position : Cursor) -- SHOULD BE ALIASED + return Reference_Type; + private pragma Inline (Next); @@ -228,8 +288,6 @@ private Lock : Natural := 0; end record; - use Ada.Streams; - procedure Read (Stream : not null access Root_Stream_Type'Class; Item : out List); @@ -263,6 +321,12 @@ private for Cursor'Write use Write; + type Constant_Reference_Type + (Element : not null access constant Element_Type) is null record; + + type Reference_Type + (Element : not null access Element_Type) is null record; + Empty_List : constant List := (Capacity => 0, others => <>); No_Element : constant Cursor := Cursor'(null, 0); diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb index 629c1041ed9..d7c75d44aaf 100644 --- a/gcc/ada/a-cbhama.adb +++ b/gcc/ada/a-cbhama.adb @@ -513,6 +513,11 @@ package body Ada.Containers.Bounded_Hashed_Maps is procedure Assign_Key (Node : in out Node_Type) is begin Node.Key := Key; + + -- Note that we do not also assign the element component of the node + -- here, because this version of Insert does not accept an element + -- parameter. + -- Node.Element := New_Item; end Assign_Key; @@ -530,20 +535,17 @@ package body Ada.Containers.Bounded_Hashed_Maps is -- Start of processing for Insert begin - -- ??? - -- if HT_Ops.Capacity (HT) = 0 then - -- HT_Ops.Reserve_Capacity (HT, 1); - -- end if; + -- The buckets array length is specified by the user as a discriminant + -- of the container type, so it is possible for the buckets array to + -- have a length of zero. We must check for this case specifically, in + -- order to prevent divide-by-zero errors later, when we compute the + -- buckets array index value for a key, given its hash value. + + if Container.Buckets'Length = 0 then + raise Capacity_Error with "No capacity for insertion"; + end if; Local_Insert (Container, Key, Position.Node, Inserted); - - -- ??? - -- if Inserted - -- and then HT.Length > HT_Ops.Capacity (HT) - -- then - -- HT_Ops.Reserve_Capacity (HT, HT.Length); - -- end if; - Position.Container := Container'Unchecked_Access; end Insert; @@ -590,20 +592,17 @@ package body Ada.Containers.Bounded_Hashed_Maps is -- Start of processing for Insert begin - -- ?? - -- if HT_Ops.Capacity (HT) = 0 then - -- HT_Ops.Reserve_Capacity (HT, 1); - -- end if; + -- The buckets array length is specified by the user as a discriminant + -- of the container type, so it is possible for the buckets array to + -- have a length of zero. We must check for this case specifically, in + -- order to prevent divide-by-zero errors later, when we compute the + -- buckets array index value for a key, given its hash value. + + if Container.Buckets'Length = 0 then + raise Capacity_Error with "No capacity for insertion"; + end if; Local_Insert (Container, Key, Position.Node, Inserted); - - -- ??? - -- if Inserted - -- and then HT.Length > HT_Ops.Capacity (HT) - -- then - -- HT_Ops.Reserve_Capacity (HT, HT.Length); - -- end if; - Position.Container := Container'Unchecked_Access; end Insert; diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index 3b85e2effef..d2d5b6c53b5 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -710,19 +710,17 @@ package body Ada.Containers.Bounded_Hashed_Sets is -- Start of processing for Insert begin - -- ??? - -- if HT_Ops.Capacity (HT) = 0 then - -- HT_Ops.Reserve_Capacity (HT, 1); - -- end if; + -- The buckets array length is specified by the user as a discriminant + -- of the container type, so it is possible for the buckets array to + -- have a length of zero. We must check for this case specifically, in + -- order to prevent divide-by-zero errors later, when we compute the + -- buckets array index value for an element, given its hash value. + + if Container.Buckets'Length = 0 then + raise Capacity_Error with "No capacity for insertion"; + end if; Local_Insert (Container, New_Item, Node, Inserted); - - -- ??? - -- if Inserted - -- and then HT.Length > HT_Ops.Capacity (HT) - -- then - -- HT_Ops.Reserve_Capacity (HT, HT.Length); - -- end if; end Insert; ------------------ @@ -1274,7 +1272,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is ------------- procedure Process (R_Node : Count_Type) is - N : Node_Type renames Left.Nodes (R_Node); + N : Node_Type renames Right.Nodes (R_Node); X : Count_Type; B : Boolean; diff --git a/gcc/ada/a-cborma.adb b/gcc/ada/a-cborma.adb index 89ec1310405..4cc2686bb22 100644 --- a/gcc/ada/a-cborma.adb +++ b/gcc/ada/a-cborma.adb @@ -773,7 +773,16 @@ package body Ada.Containers.Bounded_Ordered_Maps is begin Node.Key := Key; - -- Why is the following commented out ??? + -- Were this insertion operation to accept an element parameter, this + -- is the point where the element value would be used, to update the + -- element component of the new node. However, this insertion + -- operation is special, in the sense that it does not accept an + -- element parameter. Rather, this version of Insert allocates a node + -- (inserting it among the active nodes of the container in the + -- normal way, with the node's position being determined by the Key), + -- and passes back a cursor designating the node. It is then up to + -- the caller to assign a value to the node's element. + -- Node.Element := New_Item; end Assign; diff --git a/gcc/ada/a-cbprqu.adb b/gcc/ada/a-cbprqu.adb new file mode 100644 index 00000000000..ca049128005 --- /dev/null +++ b/gcc/ada/a-cbprqu.adb @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_PRIORITY_QUEUES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Bounded_Priority_Queues is + + package body Implementation is + + ------------- + -- Dequeue -- + ------------- + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type) + is + begin + Element := List.Container.First_Element; + List.Container.Delete_First; + end Dequeue; + + ------------- + -- Enqueue -- + ------------- + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type) + is + P : constant Queue_Priority := Get_Priority (New_Item); + + C : List_Types.Cursor; + use List_Types; + + Count : Count_Type; + + begin + C := List.Container.First; + while Has_Element (C) loop + -- ??? + -- if Before (P, Get_Priority (List.Constant_Reference (C))) then + if Before (P, Get_Priority (Element (C))) then + List.Container.Insert (C, New_Item); + exit; + end if; + + Next (C); + end loop; + + if not Has_Element (C) then + List.Container.Append (New_Item); + end if; + + Count := List.Container.Length; + + if Count > List.Max_Length then + List.Max_Length := Count; + end if; + end Enqueue; + + ------------ + -- Length -- + ------------ + + function Length (List : List_Type) return Count_Type is + begin + return List.Container.Length; + end Length; + + ---------------- + -- Max_Length -- + ---------------- + + function Max_Length (List : List_Type) return Count_Type is + begin + return List.Max_Length; + end Max_Length; + + end Implementation; + + protected body Queue is + + ------------------ + -- Current_Use -- + ------------------ + + function Current_Use return Count_Type is + begin + return List.Length; + end Current_Use; + + -------------- + -- Dequeue -- + -------------- + + entry Dequeue (Element : out Queue_Interfaces.Element_Type) + when List.Length > 0 + is + begin + List.Dequeue (Element); + end Dequeue; + + -- ??? + -- entry Dequeue_Only_High_Priority + -- (Low_Priority : Queue_Priority; + -- Element : out Queue_Interfaces.Element_Type) when True + -- is + -- begin + -- null; + -- end Dequeue_Only_High_Priority; + + -------------- + -- Enqueue -- + -------------- + + entry Enqueue (New_Item : Queue_Interfaces.Element_Type) + when List.Length < Capacity + is + begin + List.Enqueue (New_Item); + end Enqueue; + + --------------- + -- Peak_Use -- + --------------- + + function Peak_Use return Count_Type is + begin + return List.Max_Length; + end Peak_Use; + + end Queue; + +end Ada.Containers.Bounded_Priority_Queues; diff --git a/gcc/ada/a-cbprqu.ads b/gcc/ada/a-cbprqu.ads new file mode 100644 index 00000000000..9caef3482c2 --- /dev/null +++ b/gcc/ada/a-cbprqu.ads @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_PRIORITY_QUEUES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; + +with Ada.Containers.Synchronized_Queue_Interfaces; +with Ada.Containers.Bounded_Doubly_Linked_Lists; + +generic + with package Queue_Interfaces is + new Ada.Containers.Synchronized_Queue_Interfaces (<>); + + type Queue_Priority is private; + + with function Get_Priority + (Element : Queue_Interfaces.Element_Type) return Queue_Priority is <>; + + with function Before + (Left, Right : Queue_Priority) return Boolean is <>; + + Default_Capacity : Count_Type; + Default_Ceiling : System.Any_Priority := System.Priority'Last; + +package Ada.Containers.Bounded_Priority_Queues is + pragma Preelaborate; + + package Implementation is + + type List_Type (Capacity : Count_Type) is tagged limited private; + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type); + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type); + + function Length (List : List_Type) return Count_Type; + + function Max_Length (List : List_Type) return Count_Type; + + private + + -- We need a better data structure here, such as a proper heap. ??? + + package List_Types is new Bounded_Doubly_Linked_Lists + (Element_Type => Queue_Interfaces.Element_Type, + "=" => Queue_Interfaces."="); + + type List_Type (Capacity : Count_Type) is tagged limited record + Container : List_Types.List (Capacity); + Max_Length : Count_Type := 0; + end record; + + end Implementation; + + protected type Queue + (Capacity : Count_Type := Default_Capacity; + Ceiling : System.Any_Priority := Default_Ceiling) + -- ??? + -- with Priority => Ceiling is new Queue_Interfaces.Queue with + is new Queue_Interfaces.Queue with + + overriding + entry Enqueue (New_Item : Queue_Interfaces.Element_Type); + + overriding + entry Dequeue (Element : out Queue_Interfaces.Element_Type); + + -- ??? + -- not overriding + -- entry Dequeue_Only_High_Priority + -- (Low_Priority : Queue_Priority; + -- Element : out Queue_Interfaces.Element_Type); + + overriding + function Current_Use return Count_Type; + + overriding + function Peak_Use return Count_Type; + + private + + List : Implementation.List_Type (Capacity); + + end Queue; + +end Ada.Containers.Bounded_Priority_Queues; diff --git a/gcc/ada/a-cbsyqu.adb b/gcc/ada/a-cbsyqu.adb new file mode 100644 index 00000000000..cb2cbc5d4f7 --- /dev/null +++ b/gcc/ada/a-cbsyqu.adb @@ -0,0 +1,168 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_SYNCHRONIZED_QUEUES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Bounded_Synchronized_Queues is + + package body Implementation is + + ------------- + -- Dequeue -- + ------------- + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type) + is + EE : Element_Array renames List.Elements; + + begin + Element := EE (List.First); + List.Length := List.Length - 1; + + if List.Length = 0 then + List.First := 0; + List.Last := 0; + + elsif List.First <= List.Last then + List.First := List.First + 1; + + else + List.First := List.First + 1; + + if List.First > List.Capacity then + List.First := 1; + end if; + end if; + end Dequeue; + + ------------- + -- Enqueue -- + ------------- + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type) + is + begin + if List.Length >= List.Capacity then + raise Capacity_Error with "No capacity for insertion"; + end if; + + if List.Length = 0 then + List.Elements (1) := New_Item; + List.First := 1; + List.Last := 1; + + elsif List.First <= List.Last then + if List.Last < List.Capacity then + List.Elements (List.Last + 1) := New_Item; + List.Last := List.Last + 1; + + else + List.Elements (1) := New_Item; + List.Last := 1; + end if; + + else + List.Elements (List.Last + 1) := New_Item; + List.Last := List.Last + 1; + end if; + + List.Length := List.Length + 1; + + if List.Length > List.Max_Length then + List.Max_Length := List.Length; + end if; + end Enqueue; + + ------------ + -- Length -- + ------------ + + function Length (List : List_Type) return Count_Type is + begin + return List.Length; + end Length; + + ---------------- + -- Max_Length -- + ---------------- + + function Max_Length (List : List_Type) return Count_Type is + begin + return List.Max_Length; + end Max_Length; + + end Implementation; + + protected body Queue is + + ----------------- + -- Current_Use -- + ----------------- + + function Current_Use return Count_Type is + begin + return List.Length; + end Current_Use; + + ------------- + -- Dequeue -- + ------------- + + entry Dequeue (Element : out Queue_Interfaces.Element_Type) + when List.Length > 0 + is + begin + List.Dequeue (Element); + end Dequeue; + + ------------- + -- Enqueue -- + ------------- + + entry Enqueue (New_Item : Queue_Interfaces.Element_Type) + when List.Length < Capacity + is + begin + List.Enqueue (New_Item); + end Enqueue; + + -------------- + -- Peak_Use -- + -------------- + + function Peak_Use return Count_Type is + begin + return List.Max_Length; + end Peak_Use; + + end Queue; + +end Ada.Containers.Bounded_Synchronized_Queues; diff --git a/gcc/ada/a-cbsyqu.ads b/gcc/ada/a-cbsyqu.ads new file mode 100644 index 00000000000..26e86bc1801 --- /dev/null +++ b/gcc/ada/a-cbsyqu.ads @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_SYNCHRONIZED_QUEUES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; +with Ada.Containers.Synchronized_Queue_Interfaces; + +generic + with package Queue_Interfaces is + new Ada.Containers.Synchronized_Queue_Interfaces (<>); + + Default_Capacity : Count_Type; + Default_Ceiling : System.Any_Priority := System.Priority'Last; + +package Ada.Containers.Bounded_Synchronized_Queues is + pragma Preelaborate; + + package Implementation is + + type List_Type (Capacity : Count_Type) is tagged limited private; + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type); + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type); + + function Length (List : List_Type) return Count_Type; + + function Max_Length (List : List_Type) return Count_Type; + + private + + -- Need proper heap data structure here ??? + + type Element_Array is + array (Count_Type range <>) of Queue_Interfaces.Element_Type; + + type List_Type (Capacity : Count_Type) is tagged limited record + First, Last : Count_Type := 0; + Length : Count_Type := 0; + Max_Length : Count_Type := 0; + Elements : Element_Array (1 .. Capacity) := (others => <>); + end record; + + end Implementation; + + protected type Queue + (Capacity : Count_Type := Default_Capacity; + Ceiling : System.Any_Priority := Default_Ceiling) + -- ??? + -- with Priority => Ceiling is new Queue_Interfaces.Queue with + is new Queue_Interfaces.Queue with + + overriding + entry Enqueue (New_Item : Queue_Interfaces.Element_Type); + + overriding + entry Dequeue (Element : out Queue_Interfaces.Element_Type); + + overriding + function Current_Use return Count_Type; + + overriding + function Peak_Use return Count_Type; + + private + + List : Implementation.List_Type (Capacity); + + end Queue; + +end Ada.Containers.Bounded_Synchronized_Queues; diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb index a4254697044..9e7da11e7e6 100644 --- a/gcc/ada/a-chtgbo.adb +++ b/gcc/ada/a-chtgbo.adb @@ -136,15 +136,27 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is (HT : in out Hash_Table_Type'Class; X : Count_Type) is - pragma Assert (X > 0); + N : Nodes_Type renames HT.Nodes; + + begin + -- This subprogram "deallocates" a node by relinking the node off of the + -- active list and onto the free list. Previously it would flag index + -- value 0 as an error. The precondition was weakened, so that index + -- value 0 is now allowed, and this value is interpreted to mean "do + -- nothing". This makes its behavior analogous to the behavior of + -- Ada.Unchecked_Conversion, and allows callers to avoid having to add + -- special-case checks at the point of call. + + if X = 0 then + return; + end if; + pragma Assert (X <= HT.Capacity); - N : Nodes_Type renames HT.Nodes; -- pragma Assert (N (X).Prev >= 0); -- node is active -- Find a way to mark a node as active vs. inactive; we could -- use a special value in Color_Type for this. ??? - begin -- The hash table actually contains two data structures: a list for -- the "active" nodes that contain elements that have been inserted -- onto the container, and another for the "inactive" nodes of the free diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 08220e9e36b..00a5404c2ba 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -37,18 +37,20 @@ package body Ada.Containers.Vectors is procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); - type Iterator is new - Vector_Iterator_Interfaces.Reversible_Iterator with record + type Iterator is new Vector_Iterator_Interfaces.Reversible_Iterator with + record Container : Vector_Access; Index : Index_Type; end record; 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; + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; --------- -- "&" -- @@ -125,6 +127,7 @@ package body Ada.Containers.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. @@ -153,6 +156,7 @@ package body Ada.Containers.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. @@ -209,8 +213,7 @@ package body Ada.Containers.Vectors is -- basis for knowing how much larger, so we just allocate the minimum -- amount of storage. - -- Here we handle the easy case first, when the vector parameter (Left) - -- is empty. + -- Handle easy case first, when the vector parameter (Left) is empty if Left.Is_Empty then declare @@ -245,9 +248,7 @@ package body Ada.Containers.Vectors is 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); @@ -261,8 +262,7 @@ package body Ada.Containers.Vectors is -- basis for knowing how much larger, so we just allocate the minimum -- amount of storage. - -- Here we handle the easy case first, when the vector parameter (Right) - -- is empty. + -- Handle easy case first, when the vector parameter (Right) is empty if Right.Is_Empty then declare @@ -440,9 +440,9 @@ package body Ada.Containers.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; ----------- @@ -454,9 +454,9 @@ package body Ada.Containers.Vectors is if Container.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (vector is busy)"; + else + Container.Last := No_Index; end if; - - Container.Last := No_Index; end Clear; -------------- @@ -711,13 +711,11 @@ 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.Index > Position.Container.Last then + elsif Position.Index > Position.Container.Last then raise Constraint_Error with "Position cursor is out of range"; + else + return Position.Container.Elements.EA (Position.Index); end if; - - return Position.Container.Elements.EA (Position.Index); end Element; -------------- @@ -794,15 +792,18 @@ package body Ada.Containers.Vectors is begin if Is_Empty (Container) then return No_Element; + else + return (Container'Unchecked_Access, Index_Type'First); end if; - - return (Container'Unchecked_Access, Index_Type'First); end First; function First (Object : Iterator) return Cursor is - C : constant Cursor := (Object.Container, Index_Type'First); begin - return C; + if Is_Empty (Object.Container.all) then + return No_Element; + else + return Cursor'(Object.Container, Index_Type'First); + end if; end First; ------------------- @@ -813,9 +814,9 @@ package body Ada.Containers.Vectors is begin if Container.Last = No_Index then raise Constraint_Error with "Container is empty"; + else + return Container.Elements.EA (Index_Type'First); end if; - - return Container.Elements.EA (Index_Type'First); end First_Element; ----------------- @@ -847,8 +848,8 @@ package body Ada.Containers.Vectors is declare EA : Elements_Array renames Container.Elements.EA; begin - for I in Index_Type'First .. Container.Last - 1 loop - if EA (I + 1) < EA (I) then + for J in Index_Type'First .. Container.Last - 1 loop + if EA (J + 1) < EA (J) then return False; end if; end loop; @@ -1041,10 +1042,12 @@ package body Ada.Containers.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. @@ -1052,6 +1055,7 @@ package body Ada.Containers.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. @@ -1076,6 +1080,7 @@ package body Ada.Containers.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. @@ -1083,6 +1088,7 @@ package body Ada.Containers.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. @@ -1169,6 +1175,7 @@ package body Ada.Containers.Vectors is -- whether there is enough unused storage for the new items. if New_Length <= Container.Elements.EA'Length then + -- In this case, we're inserting elements into a vector that has -- already allocated an internal array, and the existing array has -- enough unused storage for the new items. @@ -1178,6 +1185,7 @@ package body Ada.Containers.Vectors is begin if Before > Container.Last then + -- The new items are being appended to the vector, so no -- sliding of existing elements is required. @@ -1225,6 +1233,7 @@ package body Ada.Containers.Vectors is end loop; if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion -- will occur. (This is not a problem, as there is never a need to -- have more capacity than the maximum container length.) @@ -1279,6 +1288,7 @@ package body Ada.Containers.Vectors is DA (Before .. Index - 1) := (others => New_Item); DA (Index .. New_Last) := SA (Before .. Container.Last); end if; + exception when others => Free (Dst); @@ -1321,6 +1331,7 @@ package body Ada.Containers.Vectors is Insert_Space (Container, Before, Count => N); if N = 0 then + -- There's nothing else to do here (vetting of parameters was -- performed already in Insert_Space), so we simply return. @@ -1338,6 +1349,7 @@ package body Ada.Containers.Vectors is end if; if Container'Address /= New_Item'Address then + -- This is the simple case. New_Item denotes an object different -- from Container, so there's nothing special we need to do to copy -- the source items to their destination, because all of the source @@ -1383,6 +1395,7 @@ package body Ada.Containers.Vectors is Container.Elements.EA (Before .. K) := Src; if Src'Length = N then + -- The new items were effectively appended to the container, so we -- have already copied all of the items that need to be copied. -- We return early here, even though the source slice below is @@ -1533,10 +1546,10 @@ package body Ada.Containers.Vectors is if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; + else + Index := Container.Last + 1; end if; - Index := Container.Last + 1; - else Index := Before.Index; end if; @@ -1697,10 +1710,12 @@ package body Ada.Containers.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. @@ -1708,6 +1723,7 @@ package body Ada.Containers.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. @@ -1732,6 +1748,7 @@ package body Ada.Containers.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. @@ -1739,6 +1756,7 @@ package body Ada.Containers.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. @@ -1824,6 +1842,7 @@ package body Ada.Containers.Vectors is -- whether there is enough unused storage for the new items. if New_Last <= Container.Elements.Last then + -- In this case, we're inserting space into a vector that has already -- allocated an internal array, and the existing array has enough -- unused storage for the new items. @@ -1833,6 +1852,7 @@ package body Ada.Containers.Vectors is begin 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. We use the wider of Index_Type'Base and @@ -1873,6 +1893,7 @@ package body Ada.Containers.Vectors is end loop; if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion -- will occur. (This is not a problem, as there is never a need to -- have more capacity than the maximum container length.) @@ -1911,6 +1932,7 @@ package body Ada.Containers.Vectors is SA (Index_Type'First .. Before - 1); 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. @@ -1923,6 +1945,7 @@ package body Ada.Containers.Vectors is DA (Index .. New_Last) := SA (Before .. Container.Last); end if; + exception when others => Free (Dst); @@ -1935,6 +1958,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 @@ -1984,10 +2008,10 @@ package body Ada.Containers.Vectors is if Container.Last = Index_Type'Last then raise Constraint_Error with "vector is already at its maximum length"; + else + Index := Container.Last + 1; end if; - Index := Container.Last + 1; - else Index := Before.Index; end if; @@ -2033,7 +2057,8 @@ package body Ada.Containers.Vectors is B := B - 1; end Iterate; - function Iterate (Container : Vector) + function Iterate + (Container : Vector) return Vector_Iterator_Interfaces.Reversible_Iterator'Class is It : constant Iterator := (Container'Unchecked_Access, Index_Type'First); @@ -2041,11 +2066,12 @@ package body Ada.Containers.Vectors is return It; end Iterate; - function Iterate (Container : Vector; Start : Cursor) + function Iterate + (Container : Vector; + Start : Cursor) return Vector_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := - (Container'Unchecked_Access, Start.Index); + It : constant Iterator := (Container'Unchecked_Access, Start.Index); begin return It; end Iterate; @@ -2058,15 +2084,18 @@ package body Ada.Containers.Vectors is begin if Is_Empty (Container) then return No_Element; + else + return (Container'Unchecked_Access, Container.Last); end if; - - return (Container'Unchecked_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is - C : constant Cursor := (Object.Container, Object.Container.Last); begin - return C; + if Is_Empty (Object.Container.all) then + return No_Element; + else + return Cursor'(Object.Container, Object.Container.Last); + end if; end Last; ------------------ @@ -2077,9 +2106,9 @@ package body Ada.Containers.Vectors is begin if Container.Last = No_Index then raise Constraint_Error with "Container is empty"; + else + return Container.Elements.EA (Container.Last); end if; - - return Container.Elements.EA (Container.Last); end Last_Element; ---------------- @@ -2167,13 +2196,11 @@ package body Ada.Containers.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 @@ -2364,8 +2391,10 @@ package body Ada.Containers.Vectors is --------------- function Constant_Reference - (Container : Vector; Position : Cursor) -- SHOULD BE ALIASED - return Constant_Reference_Type is + (Container : Vector; + Position : Cursor) -- SHOULD BE ALIASED + return Constant_Reference_Type + is begin pragma Unreferenced (Container); @@ -2383,14 +2412,16 @@ package body Ada.Containers.Vectors is end Constant_Reference; function Constant_Reference - (Container : Vector; Position : Index_Type) - return Constant_Reference_Type is + (Container : Vector; + Position : Index_Type) + return Constant_Reference_Type + is begin if (Position) > Container.Last then raise Constraint_Error with "Index is out of range"; + else + return (Element => Container.Elements.EA (Position)'Access); end if; - - return (Element => Container.Elements.EA (Position)'Access); end Constant_Reference; function Reference (Container : Vector; Position : Cursor) @@ -2415,9 +2446,9 @@ package body Ada.Containers.Vectors is begin if Position > Container.Last then raise Constraint_Error with "Index is out of range"; + else + return (Element => Container.Elements.EA (Position)'Access); end if; - - return (Element => Container.Elements.EA (Position)'Access); end Reference; --------------------- @@ -2491,10 +2522,12 @@ package body Ada.Containers.Vectors is -- container length. if Capacity = 0 then + -- This is a request to trim back storage, to the minimum amount -- possible given the current state of the container. if N = 0 then + -- The container is empty, so in this unique case we can -- deallocate the entire internal array. Note that an empty -- container can never be busy, so there's no need to check the @@ -2502,6 +2535,7 @@ package body Ada.Containers.Vectors is declare X : Elements_Access := Container.Elements; + begin -- First we remove the internal array from the container, to -- handle the case when the deallocation raises an exception. @@ -2515,6 +2549,7 @@ package body Ada.Containers.Vectors is end; elsif N < Container.Elements.EA'Length then + -- The container is not empty, and the current length is less than -- the current capacity, so there's storage available to trim. In -- this case, we allocate a new internal array having a length @@ -2571,6 +2606,7 @@ package body Ada.Containers.Vectors is -- any possibility of overflow. 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. @@ -2599,6 +2635,7 @@ package body Ada.Containers.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 Capacity. @@ -2637,6 +2674,7 @@ package body Ada.Containers.Vectors is -- this is a request for expansion or contraction of storage. if Container.Elements = null then + -- The container is empty (it doesn't even have an internal array), -- so this represents a request to allocate (expand) storage having -- the given capacity. @@ -2646,11 +2684,13 @@ package body Ada.Containers.Vectors is end if; if Capacity <= N then + -- This is a request to trim back storage, but only to the limit of -- what's already in the container. (Reserve_Capacity never deletes -- active elements, it only reclaims excess storage.) if N < Container.Elements.EA'Length then + -- The container is not empty (because the requested capacity is -- positive, and less than or equal to the container length), and -- the current length is less than the current capacity, so @@ -2703,6 +2743,7 @@ package body Ada.Containers.Vectors is -- current capacity is. if Capacity = Container.Elements.EA'Length then + -- The requested capacity matches the existing capacity, so there's -- nothing to do here. We treat this case as a no-op, and simply -- return without checking the busy bit. @@ -2756,6 +2797,7 @@ package body Ada.Containers.Vectors is declare X : Elements_Access := Container.Elements; + begin -- First we isolate the old internal array, and replace it in the -- container with the new internal array. @@ -2977,9 +3019,9 @@ package body Ada.Containers.Vectors is begin if Index not in Index_Type'First .. Container.Last then return No_Element; + else + return Cursor'(Container'Unchecked_Access, Index); end if; - - return Cursor'(Container'Unchecked_Access, Index); end To_Cursor; -------------- @@ -3021,6 +3063,7 @@ package body Ada.Containers.Vectors is -- create a Last index value greater than Index_Type'Last. 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. @@ -3049,6 +3092,7 @@ package body Ada.Containers.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. @@ -3109,6 +3153,7 @@ package body Ada.Containers.Vectors is -- create a Last index value greater than Index_Type'Last. 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. diff --git a/gcc/ada/a-crbltr.ads b/gcc/ada/a-crbltr.ads index 30ceff71cc9..2991d36ee06 100644 --- a/gcc/ada/a-crbltr.ads +++ b/gcc/ada/a-crbltr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +53,13 @@ package Ada.Containers.Red_Black_Trees is package Generic_Bounded_Tree_Types is type Nodes_Type is array (Count_Type range <>) of Node_Type; + -- Note that objects of type Tree_Type are logically initialized (in the + -- sense that representation invariants of type are satisfied by dint of + -- default initialization), even without the Nodes component also having + -- its own initialization expression. We only initializae the Nodes + -- component here in order to prevent spurious compiler warnings about + -- the container object not being fully initialized. + type Tree_Type (Capacity : Count_Type) is tagged record First : Count_Type := 0; Last : Count_Type := 0; @@ -61,7 +68,7 @@ package Ada.Containers.Red_Black_Trees is Busy : Natural := 0; Lock : Natural := 0; Free : Count_Type'Base := -1; - Nodes : Nodes_Type (1 .. Capacity); + Nodes : Nodes_Type (1 .. Capacity) := (others => <>); end record; end Generic_Bounded_Tree_Types; diff --git a/gcc/ada/a-csquin.ads b/gcc/ada/a-csquin.ads new file mode 100644 index 00000000000..4a544d43188 --- /dev/null +++ b/gcc/ada/a-csquin.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.SYNCHRONIZED_QUEUE_INTERFACES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +generic + type Element_Type is private; + +package Ada.Containers.Synchronized_Queue_Interfaces is + pragma Pure; + + type Queue is synchronized interface; + + procedure Enqueue + (Container : in out Queue; + New_Item : Element_Type) is abstract; + -- with Is_Synchronized => By_Entry; ??? + + procedure Dequeue + (Container : in out Queue; + Element : out Element_Type) is abstract; + -- with Is_Synchronized => By_Entry; ??? + + function Current_Use (Container : Queue) return Count_Type is abstract; + + function Peak_Use (Container : Queue) return Count_Type is abstract; + +end Ada.Containers.Synchronized_Queue_Interfaces; diff --git a/gcc/ada/a-cuprqu.adb b/gcc/ada/a-cuprqu.adb new file mode 100644 index 00000000000..c1da3ee49cf --- /dev/null +++ b/gcc/ada/a-cuprqu.adb @@ -0,0 +1,222 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.UNBOUNDED_PRIORITY_QUEUES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body Ada.Containers.Unbounded_Priority_Queues is + + package body Implementation is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + ------------- + -- Dequeue -- + ------------- + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type) + is + X : Node_Access; + + begin + Element := List.First.Element; + + X := List.First; + List.First := List.First.Next; + + if List.First = null then + List.Last := null; + end if; + + List.Length := List.Length - 1; + + Free (X); + end Dequeue; + + ------------- + -- Enqueue -- + ------------- + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type) + is + P : constant Queue_Priority := Get_Priority (New_Item); + + Node : Node_Access; + Prev : Node_Access; + + begin + Node := new Node_Type'(New_Item, null); + + if List.First = null then + List.First := Node; + List.Last := List.First; + + else + Prev := List.First; + + if Before (P, Get_Priority (Prev.Element)) then + Node.Next := List.First; + List.First := Node; + + else + while Prev.Next /= null loop + if Before (P, Get_Priority (Prev.Next.Element)) then + Node.Next := Prev.Next; + Prev.Next := Node; + + exit; + end if; + + Prev := Prev.Next; + end loop; + + if Prev.Next = null then + List.Last.Next := Node; + List.Last := Node; + end if; + end if; + end if; + + List.Length := List.Length + 1; + + if List.Length > List.Max_Length then + List.Max_Length := List.Length; + end if; + end Enqueue; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (List : in out List_Type) is + X : Node_Access; + begin + while List.First /= null loop + X := List.First; + List.First := List.First.Next; + Free (X); + end loop; + end Finalize; + + ------------------------ + -- Have_High_Priority -- + ------------------------ + + -- ??? + -- function Have_High_Priority + -- (List : List_Type; + -- Low_Priority : Queue_Priority) return Boolean + -- is + -- begin + -- if List.Length = 0 then + -- return False; + -- end if; + -- return Before (Get_Priority (List.First.Element), Low_Priority); + -- end Have_High_Priority; + + ------------ + -- Length -- + ------------ + + function Length (List : List_Type) return Count_Type is + begin + return List.Length; + end Length; + + ---------------- + -- Max_Length -- + ---------------- + + function Max_Length (List : List_Type) return Count_Type is + begin + return List.Max_Length; + end Max_Length; + + end Implementation; + + protected body Queue is + + ----------------- + -- Current_Use -- + ----------------- + + function Current_Use return Count_Type is + begin + return List.Length; + end Current_Use; + + ------------- + -- Dequeue -- + ------------- + + entry Dequeue (Element : out Queue_Interfaces.Element_Type) + when List.Length > 0 + is + begin + List.Dequeue (Element); + end Dequeue; + + -- ??? + -- entry Dequeue_Only_High_Priority + -- (Low_Priority : Queue_Priority; + -- Element : out Queue_Interfaces.Element_Type) when True + -- is + -- begin + -- null; + -- end Dequeue_Only_High_Priority; + + ------------- + -- Enqueue -- + ------------- + + entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is + begin + List.Enqueue (New_Item); + end Enqueue; + + -------------- + -- Peak_Use -- + -------------- + + function Peak_Use return Count_Type is + begin + return List.Max_Length; + end Peak_Use; + + end Queue; + +end Ada.Containers.Unbounded_Priority_Queues; diff --git a/gcc/ada/a-cuprqu.ads b/gcc/ada/a-cuprqu.ads new file mode 100644 index 00000000000..ac5b19e5373 --- /dev/null +++ b/gcc/ada/a-cuprqu.ads @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.UNBOUNDED_PRIORITY_QUEUES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; +with Ada.Containers.Synchronized_Queue_Interfaces; +with Ada.Finalization; + +generic + with package Queue_Interfaces is + new Ada.Containers.Synchronized_Queue_Interfaces (<>); + + type Queue_Priority is private; + + with function Get_Priority + (Element : Queue_Interfaces.Element_Type) return Queue_Priority is <>; + + with function Before + (Left, Right : Queue_Priority) return Boolean is <>; + + Default_Ceiling : System.Any_Priority := System.Priority'Last; + +package Ada.Containers.Unbounded_Priority_Queues is + pragma Preelaborate; + + package Implementation is + + type List_Type is tagged limited private; + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type); + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type); + + function Length (List : List_Type) return Count_Type; + + function Max_Length (List : List_Type) return Count_Type; + + private + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is limited record + Element : Queue_Interfaces.Element_Type; + Next : Node_Access; + end record; + + type List_Type is new Ada.Finalization.Limited_Controlled with record + First, Last : Node_Access; + Length : Count_Type := 0; + Max_Length : Count_Type := 0; + end record; + + overriding + procedure Finalize (List : in out List_Type); + + -- ??? + -- not overriding + -- function Have_High_Priority + -- (List : List_Type; + -- Low_Priority : Queue_Priority) return Boolean; + + end Implementation; + + protected type Queue (Ceiling : System.Any_Priority := Default_Ceiling) + -- ??? + -- with Priority => Ceiling is new Queue_Interfaces.Queue with + is new Queue_Interfaces.Queue with + + overriding + entry Enqueue (New_Item : Queue_Interfaces.Element_Type); + + overriding + entry Dequeue (Element : out Queue_Interfaces.Element_Type); + + -- ??? + -- not overriding + -- entry Dequeue_Only_High_Priority + -- (Low_Priority : Queue_Priority; + -- Element : out Queue_Interfaces.Element_Type); + + overriding + function Current_Use return Count_Type; + + overriding + function Peak_Use return Count_Type; + + private + + List : Implementation.List_Type; + + end Queue; + +end Ada.Containers.Unbounded_Priority_Queues; diff --git a/gcc/ada/a-cusyqu.adb b/gcc/ada/a-cusyqu.adb new file mode 100644 index 00000000000..6a8e0d8506e --- /dev/null +++ b/gcc/ada/a-cusyqu.adb @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.UNBOUNDED_SYNCHRONIZED_QUEUES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body Ada.Containers.Unbounded_Synchronized_Queues is + + package body Implementation is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + ------------- + -- Dequeue -- + ------------- + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type) + is + X : Node_Access; + + begin + Element := List.First.Element; + + X := List.First; + List.First := List.First.Next; + + if List.First = null then + List.Last := null; + end if; + + List.Length := List.Length - 1; + + Free (X); + end Dequeue; + + ------------- + -- Enqueue -- + ------------- + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type) + is + Node : Node_Access; + + begin + Node := new Node_Type'(New_Item, null); + + if List.First = null then + List.First := Node; + List.Last := List.First; + + else + List.Last.Next := Node; + List.Last := Node; + end if; + + List.Length := List.Length + 1; + + if List.Length > List.Max_Length then + List.Max_Length := List.Length; + end if; + end Enqueue; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (List : in out List_Type) is + X : Node_Access; + + begin + while List.First /= null loop + X := List.First; + List.First := List.First.Next; + Free (X); + end loop; + end Finalize; + + ------------ + -- Length -- + ------------ + + function Length (List : List_Type) return Count_Type is + begin + return List.Length; + end Length; + + ---------------- + -- Max_Length -- + ---------------- + + function Max_Length (List : List_Type) return Count_Type is + begin + return List.Max_Length; + end Max_Length; + + end Implementation; + + protected body Queue is + + ----------------- + -- Current_Use -- + ----------------- + + function Current_Use return Count_Type is + begin + return List.Length; + end Current_Use; + + ------------- + -- Dequeue -- + ------------- + + entry Dequeue (Element : out Queue_Interfaces.Element_Type) + when List.Length > 0 + is + begin + List.Dequeue (Element); + end Dequeue; + + ------------- + -- Enqueue -- + ------------- + + entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is + begin + List.Enqueue (New_Item); + end Enqueue; + + -------------- + -- Peak_Use -- + -------------- + + function Peak_Use return Count_Type is + begin + return List.Max_Length; + end Peak_Use; + + end Queue; + +end Ada.Containers.Unbounded_Synchronized_Queues; diff --git a/gcc/ada/a-cusyqu.ads b/gcc/ada/a-cusyqu.ads new file mode 100644 index 00000000000..a8a2dda160c --- /dev/null +++ b/gcc/ada/a-cusyqu.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.UNBOUNDED_SYNCHRONIZED_QUEUES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; +with Ada.Containers.Synchronized_Queue_Interfaces; +with Ada.Finalization; + +generic + with package Queue_Interfaces is + new Ada.Containers.Synchronized_Queue_Interfaces (<>); + + Default_Ceiling : System.Any_Priority := System.Priority'Last; + +package Ada.Containers.Unbounded_Synchronized_Queues is + pragma Preelaborate; + + package Implementation is + + type List_Type is tagged limited private; + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type); + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type); + + function Length (List : List_Type) return Count_Type; + + function Max_Length (List : List_Type) return Count_Type; + + private + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is limited record + Element : Queue_Interfaces.Element_Type; + Next : Node_Access; + end record; + + type List_Type is new Ada.Finalization.Limited_Controlled with record + First, Last : Node_Access; + Length : Count_Type := 0; + Max_Length : Count_Type := 0; + end record; + + overriding + procedure Finalize (List : in out List_Type); + + end Implementation; + + protected type Queue (Ceiling : System.Any_Priority := Default_Ceiling) + -- ??? + -- with Priority => Ceiling is new Queue_Interfaces.Queue with + is new Queue_Interfaces.Queue with + + overriding + entry Enqueue (New_Item : Queue_Interfaces.Element_Type); + + overriding + entry Dequeue (Element : out Queue_Interfaces.Element_Type); + + overriding + function Current_Use return Count_Type; + + overriding + function Peak_Use return Count_Type; + + private + + List : Implementation.List_Type; + + end Queue; + +end Ada.Containers.Unbounded_Synchronized_Queues; diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb index 6bb499ee2e8..e27bb3fdd6d 100644 --- a/gcc/ada/a-direct.adb +++ b/gcc/ada/a-direct.adb @@ -32,7 +32,7 @@ with Ada.Calendar; use Ada.Calendar; with Ada.Calendar.Formatting; use Ada.Calendar.Formatting; with Ada.Directories.Validity; use Ada.Directories.Validity; -with Ada.Strings.Maps; +with Ada.Strings.Maps; use Ada.Strings.Maps; with Ada.Strings.Fixed; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Unchecked_Conversion; @@ -61,8 +61,7 @@ package body Ada.Directories is pragma Import (C, Dir_Separator, "__gnat_dir_separator"); -- Running system default directory separator - Dir_Seps : constant Ada.Strings.Maps.Character_Set := - Ada.Strings.Maps.To_Set ("/\"); + Dir_Seps : constant Character_Set := Strings.Maps.To_Set ("/\"); -- UNIX and DOS style directory separators Max_Path : Integer; @@ -175,7 +174,7 @@ package body Ada.Directories is -- Add a directory separator if needed - if Last /= 0 and then Result (Last) /= Dir_Separator then + if Last /= 0 and then not Is_In (Result (Last), Dir_Seps) then Last := Last + 1; Result (Last) := Dir_Separator; end if; @@ -436,6 +435,7 @@ package body Ada.Directories is New_Dir : String (1 .. New_Directory'Length + 1); Last : Positive := 1; + Start : Positive := 1; begin -- First, the invalid case @@ -451,23 +451,35 @@ package body Ada.Directories is New_Dir (1 .. New_Directory'Length) := New_Directory; New_Dir (New_Dir'Last) := Directory_Separator; + -- If host is windows, and the first two characters are directory + -- separators, we have an UNC path. Skip it. + + if Directory_Separator = '\' + and then New_Dir'Length > 2 + and then Is_In (New_Dir (1), Dir_Seps) + and then Is_In (New_Dir (2), Dir_Seps) + then + Start := 2; + loop + Start := Start + 1; + exit when Start = New_Dir'Last + or else Is_In (New_Dir (Start), Dir_Seps); + end loop; + end if; + -- Create, if necessary, each directory in the path - for J in 2 .. New_Dir'Last loop + for J in Start + 1 .. New_Dir'Last loop -- Look for the end of an intermediate directory - if New_Dir (J) /= Dir_Separator and then - New_Dir (J) /= '/' - then + if not Is_In (New_Dir (J), Dir_Seps) then Last := J; -- We have found a new intermediate directory each time we find -- a first directory separator. - elsif New_Dir (J - 1) /= Dir_Separator and then - New_Dir (J - 1) /= '/' - then + elsif not Is_In (New_Dir (J - 1), Dir_Seps) then -- No need to create the directory if it already exists @@ -664,7 +676,7 @@ package body Ada.Directories is -- If a directory separator is found before a dot, there is no -- extension. - if Name (Pos) = Dir_Separator then + if Is_In (Name (Pos), Dir_Seps) then return Empty_String; elsif Name (Pos) = '.' then diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index 69a1accc465..37cb115988d 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -433,7 +433,8 @@ package body Exception_Data is ------------------------------ function Exception_Info_Maxlength - (X : Exception_Occurrence) return Natural is + (X : Exception_Occurrence) return Natural + is begin return Basic_Exception_Info_Maxlength (X) @@ -447,14 +448,15 @@ package body Exception_Data is procedure Append_Info_Exception_Message (X : Exception_Occurrence; Info : in out String; - Ptr : in out Natural) is + Ptr : in out Natural) + is begin if X.Id = Null_Id then raise Constraint_Error; end if; declare - Len : constant Natural := Exception_Message_Length (X); + Len : constant Natural := Exception_Message_Length (X); Msg : constant String (1 .. Len) := X.Msg (1 .. Len); begin Append_Info_String (Msg, Info, Ptr); @@ -476,7 +478,7 @@ package body Exception_Data is end if; declare - Len : constant Natural := Exception_Name_Length (Id); + Len : constant Natural := Exception_Name_Length (Id); Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len); begin Append_Info_String (Name, Info, Ptr); @@ -497,7 +499,8 @@ package body Exception_Data is --------------------------- function Exception_Name_Length - (Id : Exception_Id) return Natural is + (Id : Exception_Id) return Natural + is begin -- What is stored in the internal Name buffer includes a terminating -- null character that we never care about. @@ -516,7 +519,8 @@ package body Exception_Data is ------------------------------ function Exception_Message_Length - (X : Exception_Occurrence) return Natural is + (X : Exception_Occurrence) return Natural + is begin return X.Msg_Length; end Exception_Message_Length; @@ -530,7 +534,6 @@ package body Exception_Data is is Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X)); Ptr : Natural := Info'First - 1; - begin Append_Info_Basic_Exception_Traceback (X, Info, Ptr); return Info (Info'First .. Ptr); @@ -545,7 +548,6 @@ package body Exception_Data is is Info : String (1 .. Exception_Info_Maxlength (X)); Ptr : Natural := Info'First - 1; - begin Append_Info_Exception_Information (X, Info, Ptr); return Info (Info'First .. Ptr); @@ -596,9 +598,9 @@ package body Exception_Data is if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then Excep.Msg (Excep.Msg_Length + 1) := ':'; Excep.Msg_Length := Excep.Msg_Length + Size; + Val := Number; Size := 0; - while Val > 0 loop Remind := Val rem 10; Val := Val / 10; @@ -658,8 +660,7 @@ package body Exception_Data is Len : constant Natural := Natural'Min (Message'Length, Exception_Msg_Max_Length); First : constant Integer := Message'First; - Excep : constant EOA := Get_Current_Excep.all; - + Excep : constant EOA := Get_Current_Excep.all; begin Excep.Exception_Raised := False; Excep.Msg_Length := Len; @@ -667,7 +668,6 @@ package body Exception_Data is Excep.Id := Id; Excep.Num_Tracebacks := 0; Excep.Pid := Local_Partition_ID; - end Set_Exception_Msg; ---------------------------------- diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb index 60a84a0c397..d66571396c7 100644 --- a/gcc/ada/a-rbtgbo.adb +++ b/gcc/ada/a-rbtgbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 +59,18 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is "attempt to tamper with cursors (container is busy)"; end if; - Tree.First := 0; - Tree.Last := 0; - Tree.Root := 0; + -- The lock status (which monitors "element tampering") always implies + -- that the busy status (which monitors "cursor tampering") is set too; + -- this is a representation invariant. Thus if the busy bit is not set, + -- then the lock bit must not be set either. + + pragma Assert (Tree.Lock = 0); + + Tree.First := 0; + Tree.Last := 0; + Tree.Root := 0; Tree.Length := 0; - -- Tree.Busy - -- Tree.Lock - Tree.Free := -1; + Tree.Free := -1; end Clear_Tree; ------------------ @@ -76,8 +81,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is (Tree : in out Tree_Type'Class; Node : Count_Type) is - - -- CLR p274 + -- CLR p. 274 X : Count_Type; W : Count_Type; @@ -143,7 +147,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is end if; if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) - and then + and then (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) then Set_Color (N (W), Red); @@ -187,7 +191,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is (Tree : in out Tree_Type'Class; Node : Count_Type) is - -- CLR p273 + -- CLR p. 273 X, Y : Count_Type; @@ -203,9 +207,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is end if; pragma Assert (Tree.Length > 0); - pragma Assert (Tree.Root /= 0); + pragma Assert (Tree.Root /= 0); pragma Assert (Tree.First /= 0); - pragma Assert (Tree.Last /= 0); + pragma Assert (Tree.Last /= 0); pragma Assert (Parent (N (Tree.Root)) = 0); pragma Assert ((Tree.Length > 1) @@ -330,12 +334,13 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is Set_Right (N (Parent (N (Z))), Y); end if; - Set_Left (N (Y), Left (N (Z))); + Set_Left (N (Y), Left (N (Z))); Set_Parent (N (Left (N (Y))), Y); - Set_Right (N (Y), Z); + Set_Right (N (Y), Z); + Set_Parent (N (Z), Y); - Set_Left (N (Z), 0); - Set_Right (N (Z), 0); + Set_Left (N (Z), 0); + Set_Right (N (Z), 0); declare Y_Color : constant Color_Type := Color (N (Y)); @@ -417,13 +422,13 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is pragma Assert (Parent (N (Y)) /= Z); Y_Parent : constant Count_Type := Parent (N (Y)); - Y_Color : constant Color_Type := Color (N (Y)); + Y_Color : constant Color_Type := Color (N (Y)); begin Set_Parent (N (Y), Parent (N (Z))); - Set_Left (N (Y), Left (N (Z))); - Set_Right (N (Y), Right (N (Z))); - Set_Color (N (Y), Color (N (Z))); + Set_Left (N (Y), Left (N (Z))); + Set_Right (N (Y), Right (N (Z))); + Set_Color (N (Y), Color (N (Z))); if Tree.Root = Z then Tree.Root := Y; @@ -443,9 +448,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is end if; Set_Parent (N (Z), Y_Parent); - Set_Color (N (Z), Y_Color); - Set_Left (N (Z), 0); - Set_Right (N (Z), 0); + Set_Color (N (Z), Y_Color); + Set_Left (N (Z), 0); + Set_Right (N (Z), 0); end Delete_Swap; ---------- @@ -526,11 +531,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is -- node onto the head of the free store. -- ??? - -- See the comments above for an optimization opportunity. If - -- the next link for a node on the free store is negative, then - -- this means the remaining nodes on the free store are - -- physically contiguous, starting as the absolute value of - -- that index value. + -- See the comments above for an optimization opportunity. If the + -- next link for a node on the free store is negative, then this + -- means the remaining nodes on the free store are physically + -- contiguous, starting as the absolute value of that index value. Tree.Free := abs Tree.Free; @@ -586,6 +590,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is Set_Element (N (Node)); Tree.Free := Tree.Free - 1; end if; + + -- When a node is allocated from the free store, its pointer components + -- (the links to other nodes in the tree) must also be initialized (to + -- 0, the equivalent of null). This simplifies the post-allocation + -- handling of nodes inserted into terminal positions. + + Set_Parent (N (Node), Parent => 0); + Set_Left (N (Node), Left => 0); + Set_Right (N (Node), Right => 0); end Generic_Allocate; ------------------- @@ -683,9 +696,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is Set_Color (N (Node), Black); - Tree.Root := Node; - Tree.First := Node; - Tree.Last := Node; + Tree.Root := Node; + Tree.First := Node; + Tree.Last := Node; Tree.Length := 1; for J in Count_Type range 2 .. Len loop @@ -743,8 +756,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is procedure Process (Node : Count_Type); pragma Inline (Process); - procedure Iterate is - new Generic_Iteration (Process); + procedure Iterate is new Generic_Iteration (Process); ------------- -- Process -- @@ -767,7 +779,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is ----------------- procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is - -- CLR p266 + -- CLR p. 266 N : Nodes_Type renames Tree.Nodes; @@ -792,7 +804,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is Set_Right (N (Parent (N (X))), Y); end if; - Set_Left (N (Y), X); + Set_Left (N (Y), X); Set_Parent (N (X), Y); end Left_Rotate; @@ -804,7 +816,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type is - -- CLR p248 + -- CLR p. 248 X : Count_Type := Node; Y : Count_Type; @@ -829,7 +841,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type is - -- CLR p248 + -- CLR p. 248 X : Count_Type := Node; Y : Count_Type; @@ -855,7 +867,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is Node : Count_Type) return Count_Type is begin - -- CLR p249 + -- CLR p. 249 if Node = 0 then return 0; @@ -922,7 +934,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is (Tree : in out Tree_Type'Class; Node : Count_Type) is - -- CLR p.268 + -- CLR p. 268 N : Nodes_Type renames Tree.Nodes; @@ -1010,7 +1022,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is Set_Right (N (Parent (N (Y))), X); end if; - Set_Right (N (X), Y); + Set_Right (N (X), Y); Set_Parent (N (Y), X); end Right_Rotate; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 556101df2e2..7e701f53c14 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -1240,6 +1240,23 @@ __gnat_tmp_name (char *tmp_filename) sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir); close (mkstemp(tmp_filename)); +#elif defined (__vxworks) && !(defined (__RTP__) || defined (VTHREADS)) + int index; + char * pos; + ushort_t t; + static ushort_t seed = 0; /* used to generate unique name */ + + /* generate unique name */ + strcpy (tmp_filename, "tmp"); + + /* fill up the name buffer from the last position */ + index = 5; + pos = tmp_filename + strlen (tmp_filename) + index; + *pos = '\0'; + + seed++; + for (t = seed; 0 <= --index; t >>= 3) + *--pos = '0' + (t & 07); #else tmpnam (tmp_filename); #endif @@ -3770,6 +3787,75 @@ void *__gnat_lwp_self (void) { return (void *) syscall (__NR_gettid); } + +#include <sched.h> + +/* glibc versions earlier than 2.7 do not define the routines to handle + dynamically allocated CPU sets. For these targets, we use the static + versions. */ + +#ifdef CPU_ALLOC + +/* Dynamic cpu sets */ + +cpu_set_t *__gnat_cpu_alloc (size_t count) +{ + return CPU_ALLOC (count); +} + +size_t __gnat_cpu_alloc_size (size_t count) +{ + return CPU_ALLOC_SIZE (count); +} + +void __gnat_cpu_free (cpu_set_t *set) +{ + CPU_FREE (set); +} + +void __gnat_cpu_zero (size_t count, cpu_set_t *set) +{ + CPU_ZERO_S (count, set); +} + +void __gnat_cpu_set (int cpu, size_t count, cpu_set_t *set) +{ + /* Ada handles CPU numbers starting from 1, while C identifies the first + CPU by a 0, so we need to adjust. */ + CPU_SET_S (cpu - 1, count, set); +} + +#else + +/* Static cpu sets */ + +cpu_set_t *__gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED) +{ + return (cpu_set_t *) xmalloc (sizeof (cpu_set_t)); +} + +size_t __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED) +{ + return sizeof (cpu_set_t); +} + +void __gnat_cpu_free (cpu_set_t *set) +{ + free (set); +} + +void __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED, cpu_set_t *set) +{ + CPU_ZERO (set); +} + +void __gnat_cpu_set (int cpu, size_t count ATTRIBUTE_UNUSED, cpu_set_t *set) +{ + /* Ada handles CPU numbers starting from 1, while C identifies the first + CPU by a 0, so we need to adjust. */ + CPU_SET (cpu - 1, set); +} +#endif #endif #ifdef __cplusplus diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 3ceecaac63a..12e671f2f11 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -245,8 +245,23 @@ extern int __gnat_number_of_cpus (void); extern void __gnat_os_filename (char *, char *, char *, int *, char *, int *); + +extern char * __gnat_locate_executable_file (char *, char *); +extern char * __gnat_locate_file_with_predicate (char *, char *, + int (*)(char*)); + #if defined (linux) extern void *__gnat_lwp_self (void); + +/* Routines for interface to required CPU set primitives */ + +#include <sched.h> + +extern cpu_set_t *__gnat_cpu_alloc (size_t); +extern size_t __gnat_cpu_alloc_size (size_t); +extern void __gnat_cpu_free (cpu_set_t *); +extern void __gnat_cpu_zero (size_t, cpu_set_t *); +extern void __gnat_cpu_set (int, size_t, cpu_set_t *); #endif #if defined (_WIN32) diff --git a/gcc/ada/affinity.c b/gcc/ada/affinity.c new file mode 100644 index 00000000000..215a6144f03 --- /dev/null +++ b/gcc/ada/affinity.c @@ -0,0 +1,63 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * A F F I N I T Y * + * * + * C Implementation File * + * * + * Copyright (C) 2005-2011, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * <http://www.gnu.org/licenses/>. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* VxWorks SMP CPU affinity */ + +#include "taskLib.h" +#include "cpuset.h" + +extern int __gnat_set_affinity (int tid, unsigned cpu); +extern int __gnat_set_affinity_mask (int tid, unsigned mask); + +int + __gnat_set_affinity (int tid, unsigned cpu) +{ + cpuset_t cpuset; + + CPUSET_ZERO(cpuset); + CPUSET_SET(cpuset, cpu); + return taskCpuAffinitySet (tid, cpuset); +} + +int +__gnat_set_affinity_mask (int tid, unsigned mask) +{ + int index; + cpuset_t cpuset; + + CPUSET_ZERO(cpuset); + + for (index = 0; index < sizeof (unsigned) * 8; index++) + if (mask & (1 << index)) + CPUSET_SET(cpuset, index); + + return taskCpuAffinitySet (tid, cpuset); +} diff --git a/gcc/ada/alfa.adb b/gcc/ada/alfa.adb index 6fd1d8f8aae..6aceb1ba025 100644 --- a/gcc/ada/alfa.adb +++ b/gcc/ada/alfa.adb @@ -24,9 +24,9 @@ ------------------------------------------------------------------------------ with Output; use Output; -with Put_ALFA; +with Put_Alfa; -package body ALFA is +package body Alfa is ----------- -- dalfa -- @@ -34,14 +34,14 @@ package body ALFA is procedure dalfa is begin - -- Dump ALFA file table + -- Dump Alfa file table - Write_Line ("ALFA File Table"); + Write_Line ("Alfa File Table"); Write_Line ("---------------"); - for Index in 1 .. ALFA_File_Table.Last loop + for Index in 1 .. Alfa_File_Table.Last loop declare - AFR : ALFA_File_Record renames ALFA_File_Table.Table (Index); + AFR : Alfa_File_Record renames Alfa_File_Table.Table (Index); begin Write_Str (" "); @@ -63,15 +63,15 @@ package body ALFA is end; end loop; - -- Dump ALFA scope table + -- Dump Alfa scope table Write_Eol; - Write_Line ("ALFA Scope Table"); + Write_Line ("Alfa Scope Table"); Write_Line ("----------------"); - for Index in 1 .. ALFA_Scope_Table.Last loop + for Index in 1 .. Alfa_Scope_Table.Last loop declare - ASR : ALFA_Scope_Record renames ALFA_Scope_Table.Table (Index); + ASR : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); begin Write_Str (" "); @@ -103,15 +103,15 @@ package body ALFA is end; end loop; - -- Dump ALFA cross-reference table + -- Dump Alfa cross-reference table Write_Eol; - Write_Line ("ALFA Xref Table"); + Write_Line ("Alfa Xref Table"); Write_Line ("---------------"); - for Index in 1 .. ALFA_Xref_Table.Last loop + for Index in 1 .. Alfa_Xref_Table.Last loop declare - AXR : ALFA_Xref_Record renames ALFA_Xref_Table.Table (Index); + AXR : Alfa_Xref_Record renames Alfa_Xref_Table.Table (Index); begin Write_Str (" "); @@ -146,12 +146,12 @@ package body ALFA is -- Initialize -- ---------------- - procedure Initialize_ALFA_Tables is + procedure Initialize_Alfa_Tables is begin - ALFA_File_Table.Init; - ALFA_Scope_Table.Init; - ALFA_Xref_Table.Init; - end Initialize_ALFA_Tables; + Alfa_File_Table.Init; + Alfa_Scope_Table.Init; + Alfa_Xref_Table.Init; + end Initialize_Alfa_Tables; ----------- -- palfa -- @@ -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_Alfa is new Put_Alfa; -- Start of processing for palfa begin - Debug_Put_ALFA; + Debug_Put_Alfa; end palfa; -end ALFA; +end Alfa; diff --git a/gcc/ada/alfa.ads b/gcc/ada/alfa.ads index 3c45c14dedc..95c4be3d902 100644 --- a/gcc/ada/alfa.ads +++ b/gcc/ada/alfa.ads @@ -23,41 +23,41 @@ -- -- ------------------------------------------------------------------------------ --- 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 +-- 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. with Types; use Types; with GNAT.Table; -package ALFA is +package Alfa is - -- ALFA information can exist in one of two forms. In the ALI file, it 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 + -- Internally it is stored using three tables Alfa_Xref_Table, + -- Alfa_Scope_Table and Alfa_File_Table, which are also defined in this -- unit. - -- Lib.Xref.ALFA is part of the compiler. It extracts ALFA information from + -- Lib.Xref.Alfa is part of the compiler. It extracts Alfa information from -- the complete set of cross-references generated during compilation. - -- Get_ALFA reads the text lines in ALI format and populates the internal + -- Get_Alfa 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 + -- Put_Alfa reads the internal tables and generates text lines in the ALI -- format. --------------------- - -- ALFA ALI Format -- + -- Alfa ALI Format -- --------------------- - -- ALFA information is generated on a unit-by-unit basis in the ALI file, + -- 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. - -- The ALFA information follows the cross-reference information, so it + -- The Alfa information follows the cross-reference information, so it -- needs not be read by tools like gnatbind, gnatmake etc. -- ------------------- @@ -86,7 +86,7 @@ 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 + -- reading of the Alfa information, and means that the Alfa information -- can stand on its own without needing other parts of the ALI file. -- FS . scope line type col entity (-> spec-file . spec-scope)? @@ -186,13 +186,13 @@ package ALFA is -- Xref Table -- ---------------- - -- The following table records ALFA cross-references + -- The following table records Alfa 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 Alfa_Xref_Record is record Entity_Name : String_Ptr; -- Pointer to entity name in ALI file @@ -232,8 +232,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 Alfa_Xref_Table is new GNAT.Table ( + Table_Component_Type => Alfa_Xref_Record, Table_Index_Type => Xref_Index, Table_Low_Bound => 1, Table_Initial => 2000, @@ -250,7 +250,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 Alfa_Scope_Record is record Scope_Name : String_Ptr; -- Pointer to scope name in ALI file @@ -293,8 +293,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 Alfa_Scope_Table is new GNAT.Table ( + Table_Component_Type => Alfa_Scope_Record, Table_Index_Type => Scope_Index, Table_Low_Bound => 1, Table_Initial => 200, @@ -311,7 +311,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 Alfa_File_Record is record File_Name : String_Ptr; -- Pointer to file name in ALI file @@ -325,8 +325,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 Alfa_File_Table is new GNAT.Table ( + Table_Component_Type => Alfa_File_Record, Table_Index_Type => File_Index, Table_Low_Bound => 1, Table_Initial => 20, @@ -344,15 +344,15 @@ package ALFA is -- Subprograms -- ----------------- - procedure Initialize_ALFA_Tables; + procedure Initialize_Alfa_Tables; -- Reset tables for a new compilation procedure dalfa; - -- Debug routine to dump internal ALFA tables. This is a raw format dump + -- Debug routine to dump internal Alfa 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 + -- Debugging procedure to output contents of Alfa binary tables in the -- format in which they appear in an ALI file. -end ALFA; +end Alfa; diff --git a/gcc/ada/alfa_test.adb b/gcc/ada/alfa_test.adb index 40c18a8caff..9e3f78d642e 100644 --- a/gcc/ada/alfa_test.adb +++ b/gcc/ada/alfa_test.adb @@ -23,23 +23,23 @@ -- -- ------------------------------------------------------------------------------ --- 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 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: --- ALFA_Test file.ali +-- Alfa_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 +-- 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. -with Get_ALFA; -with Put_ALFA; +with Get_Alfa; +with Put_Alfa; -with ALFA; use ALFA; +with Alfa; use Alfa; with Types; use Types; with Ada.Command_Line; use Ada.Command_Line; @@ -47,15 +47,22 @@ with Ada.Streams; use Ada.Streams; with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; with Ada.Text_IO; -procedure ALFA_Test is +with GNAT.OS_Lib; use GNAT.OS_Lib; + +procedure Alfa_Test is Infile : File_Type; + Name1 : String_Access; Outfile_1 : File_Type; + Name2 : String_Access; Outfile_2 : File_Type; C : Character; Stop : exception; -- Terminate execution + Diff_Exec : constant String_Access := Locate_Exec_On_Path ("diff"); + Diff_Result : Integer; + use ASCII; begin @@ -64,9 +71,12 @@ begin raise Stop; end if; - Create (Outfile_1, Out_File, "log1"); - Create (Outfile_2, Out_File, "log2"); + Name1 := new String'(Argument (1) & ".1"); + Name2 := new String'(Argument (1) & ".2"); + Open (Infile, In_File, Argument (1)); + Create (Outfile_1, Out_File, Name1.all); + Create (Outfile_2, Out_File, Name2.all); -- Read input file till we get to first 'F' line @@ -133,8 +143,8 @@ 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_Alfa (these also copy the output to Outfile_1 + -- for later comparison with the output generated by Put_Alfa). function Getc return Character; function Nextc return Character; @@ -180,7 +190,7 @@ begin C := Getc; end Skipc; - -- Subprograms used by Put_ALFA, which write information to Outfile_2 + -- Subprograms used by Put_Alfa, which write information to Outfile_2 function Write_Info_Col return Positive; procedure Write_Info_Char (C : Character); @@ -237,10 +247,10 @@ begin Write_Info_Char (LF); end Write_Info_Terminate; - -- Local instantiations of Put_ALFA and Get_ALFA + -- Local instantiations of Put_Alfa and Get_Alfa - procedure Get_ALFA_Info is new Get_ALFA; - procedure Put_ALFA_Info is new Put_ALFA; + procedure Get_Alfa_Info is new Get_Alfa; + procedure Put_Alfa_Info is new Put_Alfa; -- Start of processing for Process @@ -267,66 +277,41 @@ begin Set_Index (Infile, Index (Infile) - 1); - -- Read ALFA information to internal ALFA tables, also copying ALFA info + -- Read Alfa information to internal Alfa tables, also copying Alfa info -- to Outfile_1. - Initialize_ALFA_Tables; - Get_ALFA_Info; + Initialize_Alfa_Tables; + Get_Alfa_Info; - -- Write ALFA information from internal ALFA tables to Outfile_2 + -- Write Alfa information from internal Alfa tables to Outfile_2 - Put_ALFA_Info; + Put_Alfa_Info; -- Junk blank line (see comment at end of Lib.Writ) Write_Info_Terminate; - -- Now Outfile_1 and Outfile_2 should be identical - - Compare_Files : declare - Line : Natural; - Col : Natural; - C1 : Character; - C2 : Character; - - begin - Reset (Outfile_1, In_File); - Reset (Outfile_2, In_File); + -- Flush to disk - -- Loop to compare the two files + Close (Outfile_1); + Close (Outfile_2); - Line := 1; - Col := 1; - loop - C1 := Get_Char (Outfile_1); - C2 := Get_Char (Outfile_2); - exit when C1 = EOF or else C1 /= C2; - - if C1 = LF then - Line := Line + 1; - Col := 1; - else - Col := Col + 1; - end if; - end loop; + -- Now Outfile_1 and Outfile_2 should be identical - -- If we reached the end of file, then the files were identical, - -- otherwise, we have a failure in the comparison. + Diff_Result := + Spawn (Diff_Exec.all, + Argument_String_To_List + ("-u " & Name1.all & " " & Name2.all).all); - if C1 = EOF then - -- Success: exit silently + if Diff_Result /= 0 then + Ada.Text_IO.Put_Line ("diff(1) exit status" & Diff_Result'Img); + end if; - null; + OS_Exit (Diff_Result); - else - Ada.Text_IO.Put_Line - (Argument (1) & ": failure, files log1 and log2 differ at line" - & Line'Img & " column" & Col'Img); - end if; - end Compare_Files; end Process; exception when Stop => null; -end ALFA_Test; +end Alfa_Test; diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index a040d30fa23..0b43200f14e 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -212,7 +212,10 @@ package body ALI.Util is -- Read_Withed_ALIs -- ---------------------- - procedure Read_Withed_ALIs (Id : ALI_Id) is + procedure Read_Withed_ALIs + (Id : ALI_Id; + Ignore_Errors : Boolean := False) + is Afile : File_Name_Type; Text : Text_Buffer_Ptr; Idread : ALI_Id; @@ -234,59 +237,67 @@ package body ALI.Util is then Text := Read_Library_Info (Afile); - -- Return with an error if source cannot be found. We used to - -- skip this check when we did not compile library generics - -- separately, but we now always do, so there is no special - -- case here anymore. + -- Unless Ignore_Errors is true, return with an error if source + -- cannot be found. We used to skip this check when we did not + -- compile library generics separately, but we now always do, + -- so there is no special case here anymore. if Text = null then - Error_Msg_File_1 := Afile; - Error_Msg_File_2 := Withs.Table (W).Sfile; - Error_Msg ("{ not found, { must be compiled"); - Set_Name_Table_Info (Afile, Int (No_Unit_Id)); - return; - end if; - - -- Enter in ALIs table - Idread := - Scan_ALI - (F => Afile, - T => Text, - Ignore_ED => False, - Err => False); - - Free (Text); - - if ALIs.Table (Idread).Compile_Errors then - Error_Msg_File_1 := Withs.Table (W).Sfile; - Error_Msg ("{ had errors, must be fixed, and recompiled"); - Set_Name_Table_Info (Afile, Int (No_Unit_Id)); + if not Ignore_Errors then + Error_Msg_File_1 := Afile; + Error_Msg_File_2 := Withs.Table (W).Sfile; + Error_Msg ("{ not found, { must be compiled"); + Set_Name_Table_Info (Afile, Int (No_Unit_Id)); + return; + end if; - elsif ALIs.Table (Idread).No_Object then - Error_Msg_File_1 := Withs.Table (W).Sfile; - Error_Msg ("{ must be recompiled"); - Set_Name_Table_Info (Afile, Int (No_Unit_Id)); - end if; + else + -- Enter in ALIs table + + Idread := + Scan_ALI + (F => Afile, + T => Text, + Ignore_ED => False, + Err => False); + + Free (Text); + + if ALIs.Table (Idread).Compile_Errors + and then not Ignore_Errors + then + Error_Msg_File_1 := Withs.Table (W).Sfile; + Error_Msg ("{ had errors, must be fixed, and recompiled"); + Set_Name_Table_Info (Afile, Int (No_Unit_Id)); + + elsif ALIs.Table (Idread).No_Object + and then not Ignore_Errors + then + Error_Msg_File_1 := Withs.Table (W).Sfile; + Error_Msg ("{ must be recompiled"); + Set_Name_Table_Info (Afile, Int (No_Unit_Id)); + end if; - -- If the Unit is an Interface to a Stand-Alone Library, - -- set the Interface flag in the Withs table, so that its - -- dependant are not considered for elaboration order. + -- If the Unit is an Interface to a Stand-Alone Library, + -- set the Interface flag in the Withs table, so that its + -- dependant are not considered for elaboration order. - if ALIs.Table (Idread).SAL_Interface then - Withs.Table (W).SAL_Interface := True; - Interface_Library_Unit := True; + if ALIs.Table (Idread).SAL_Interface then + Withs.Table (W).SAL_Interface := True; + Interface_Library_Unit := True; - -- Set the entry in the Interfaces hash table, so that other - -- units that import this unit will set the flag in their - -- entry in the Withs table. + -- Set the entry in the Interfaces hash table, so that + -- other units that import this unit will set the flag + -- in their entry in the Withs table. - Interfaces.Set (Afile, True); + Interfaces.Set (Afile, True); - else - -- Otherwise, recurse to get new dependents + else + -- Otherwise, recurse to get new dependents - Read_Withed_ALIs (Idread); + Read_Withed_ALIs (Idread); + end if; end if; -- If the ALI file has already been processed and is an interface, diff --git a/gcc/ada/ali-util.ads b/gcc/ada/ali-util.ads index cbdb14f7075..707fec7f1f6 100644 --- a/gcc/ada/ali-util.ads +++ b/gcc/ada/ali-util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -100,11 +100,15 @@ package ALI.Util is -- Subprograms for Manipulating ALI Information -- -------------------------------------------------- - procedure Read_Withed_ALIs (Id : ALI_Id); + procedure Read_Withed_ALIs + (Id : ALI_Id; + Ignore_Errors : Boolean := False); -- Process an ALI file which has been read and scanned by looping through -- all withed units in the ALI file, checking if they have been processed. -- Each unit that has not yet been processed will be read, scanned, and - -- processed recursively. + -- processed recursively. If Ignore_Errors is True, then failure to read an + -- ALI file is not reported as an error, and scanning continues with other + -- ALI files. procedure Set_Source_Table (A : ALI_Id); -- Build source table entry corresponding to the ALI file whose id is A diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index e998aeee0aa..2b90ed7e6c1 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -56,7 +56,7 @@ package body ALI is 'S' => True, -- specific dispatching 'Y' => True, -- limited_with 'C' => True, -- SCO information - 'F' => True, -- ALFA information + 'F' => True, -- Alfa information others => False); -------------------- @@ -2442,7 +2442,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 Alfa). Check_Unknown_Line; diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index f2159db7291..48a1c89e700 100755 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -219,10 +219,12 @@ package body Aspects is Aspect_Bit_Order => Aspect_Bit_Order, Aspect_Component_Size => Aspect_Component_Size, Aspect_Constant_Indexing => Aspect_Constant_Indexing, + 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_Discard_Names => Aspect_Discard_Names, + Aspect_Dispatching_Domain => Aspect_Dispatching_Domain, Aspect_Dynamic_Predicate => Aspect_Predicate, Aspect_External_Tag => Aspect_External_Tag, Aspect_Favor_Top_Level => Aspect_Favor_Top_Level, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index ecf74ba4d20..fc110d6ba95 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -50,9 +50,11 @@ package Aspects is Aspect_Bit_Order, Aspect_Component_Size, Aspect_Constant_Indexing, + Aspect_CPU, Aspect_Default_Component_Value, Aspect_Default_Iterator, Aspect_Default_Value, + Aspect_Dispatching_Domain, Aspect_Dynamic_Predicate, Aspect_External_Tag, Aspect_Implicit_Dereference, @@ -187,9 +189,11 @@ package Aspects is Aspect_Bit_Order => Expression, Aspect_Component_Size => Expression, Aspect_Constant_Indexing => Name, + Aspect_CPU => Expression, Aspect_Default_Component_Value => Expression, Aspect_Default_Iterator => Name, Aspect_Default_Value => Expression, + Aspect_Dispatching_Domain => Expression, Aspect_Dynamic_Predicate => Expression, Aspect_External_Tag => Expression, Aspect_Implicit_Dereference => Name, @@ -246,10 +250,12 @@ package Aspects is Aspect_Compiler_Unit => Name_Compiler_Unit, Aspect_Component_Size => Name_Component_Size, Aspect_Constant_Indexing => Name_Constant_Indexing, + 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_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_Tag => Name_External_Tag, diff --git a/gcc/ada/aux-io.c b/gcc/ada/aux-io.c index a7ab20b87bf..6ff415def98 100644 --- a/gcc/ada/aux-io.c +++ b/gcc/ada/aux-io.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2009 Free Software Foundation, Inc. * + * Copyright (C) 1992-2011, Free Software Foundation, Inc. * * * * GNAT is 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,16 @@ #include "system.h" #endif +/* Don't use macros versions of this functions on VxWorks since they cause + imcompatible changes in some VxWorks versions */ +#ifdef __vxworks +#undef getchar +#undef putchar +#undef feof +#undef ferror +#undef fileno +#endif + /* Function wrappers are needed to access the values from Ada which are defined as C macros. */ diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 2a161fad534..f5a2bdcecad 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -71,6 +71,13 @@ package body Bindgen is -- to do this unconditionally, since it drags in the System.Restrictions -- unit unconditionally, which is unpleasand, especially for ZFP etc.) + Dispatching_Domains_Used : Boolean; + -- Flag indicating whether multiprocessor dispatching domains are used in + -- the closure of the partition. This is set by + -- Check_Dispatching_Domains_Used, and is used to call the routine to + -- disallow the creation of new dispatching domains just before calling + -- the main procedure from the environment task. + Lib_Final_Built : Boolean := False; -- Flag indicating whether the finalize_library rountine has been built @@ -233,10 +240,21 @@ package body Bindgen is -- Local Subprograms -- ----------------------- + procedure Check_File_In_Partition + (File_Name : String; + Flag : out Boolean); + -- If the file indicated by File_Name is in the partition the Flag is set + -- to True, False otherwise. + procedure Check_System_Restrictions_Used; -- Sets flag System_Restrictions_Used (Set to True if and only if the unit -- System.Restrictions is present in the partition, otherwise False). + procedure Check_Dispatching_Domains_Used; + -- Sets flag Dispatching_Domains_Used to True when using the unit + -- System.Multiprocessors.Dispatching_Domains is present in the partition, + -- otherwise set to False. + procedure Gen_Adainit; -- Generates the Adainit procedure @@ -372,19 +390,40 @@ package body Bindgen is -- contents of statement buffer up to Last, and reset Last to 0 ------------------------------------ - -- Check_System_Restrictions_Used -- + -- Check_Dispatching_Domains_Used -- ------------------------------------ - procedure Check_System_Restrictions_Used is + procedure Check_Dispatching_Domains_Used is + begin + Check_File_In_Partition ("s-mudido.ads", Dispatching_Domains_Used); + end Check_Dispatching_Domains_Used; + + ----------------------------- + -- Check_File_In_Partition -- + ----------------------------- + + procedure Check_File_In_Partition + (File_Name : String; + Flag : out Boolean) + is begin for J in Units.First .. Units.Last loop - if Get_Name_String (Units.Table (J).Sfile) = "s-restri.ads" then - System_Restrictions_Used := True; + if Get_Name_String (Units.Table (J).Sfile) = File_Name then + Flag := True; return; end if; end loop; - System_Restrictions_Used := False; + Flag := False; + end Check_File_In_Partition; + + ------------------------------------ + -- Check_System_Restrictions_Used -- + ------------------------------------ + + procedure Check_System_Restrictions_Used is + begin + Check_File_In_Partition ("s-restri.ads", System_Restrictions_Used); end Check_System_Restrictions_Used; ------------------ @@ -664,6 +703,16 @@ package body Bindgen is & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);"); end if; + -- When dispatching domains are used then we need to signal it + -- before calling the main procedure. + + if Dispatching_Domains_Used then + WBI (" procedure Freeze_Dispatching_Domains;"); + WBI (" pragma Import"); + WBI (" (Ada, Freeze_Dispatching_Domains, " & + """__gnat_freeze_dispatching_domains"");"); + end if; + WBI (" begin"); WBI (" if Is_Elaborated then"); WBI (" return;"); @@ -900,6 +949,12 @@ package body Bindgen is Gen_Elab_Calls; + -- From this point, no new dispatching domain can be created. + + if Dispatching_Domains_Used then + WBI (" Freeze_Dispatching_Domains;"); + end if; + -- Case of main program is CIL function or procedure if VM_Target = CLI_Target @@ -2037,6 +2092,7 @@ package body Bindgen is -- Generate output file in appropriate language Check_System_Restrictions_Used; + Check_Dispatching_Domains_Used; Gen_Output_File_Ada (Filename); end Gen_Output_File; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 2f3b11bfed4..3eb0c4ec141 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -479,11 +479,27 @@ package body Checks is Insert_Node : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Param_Ent : constant Entity_Id := Param_Entity (N); + Param_Ent : Entity_Id := Param_Entity (N); Param_Level : Node_Id; Type_Level : Node_Id; begin + if Ada_Version >= Ada_2012 + and then not Present (Param_Ent) + and then Is_Entity_Name (N) + and then Ekind_In (Entity (N), E_Constant, E_Variable) + and then Present (Effective_Extra_Accessibility (Entity (N))) + then + Param_Ent := Entity (N); + while Present (Renamed_Object (Param_Ent)) loop + + -- Renamed_Object must return an Entity_Name here + -- because of preceding "Present (E_E_A (...))" test. + + Param_Ent := Entity (Renamed_Object (Param_Ent)); + end loop; + end if; + if Inside_A_Generic then return; @@ -494,7 +510,8 @@ package body Checks is elsif Present (Param_Ent) and then Present (Extra_Accessibility (Param_Ent)) - and then UI_Gt (Object_Access_Level (N), Type_Access_Level (Typ)) + and then UI_Gt (Object_Access_Level (N), + Deepest_Type_Access_Level (Typ)) and then not Accessibility_Checks_Suppressed (Param_Ent) and then not Accessibility_Checks_Suppressed (Typ) then @@ -502,7 +519,7 @@ package body Checks is New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc); Type_Level := - Make_Integer_Literal (Loc, Type_Access_Level (Typ)); + Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ)); -- Raise Program_Error if the accessibility level of the access -- parameter is deeper than the level of the target access type. diff --git a/gcc/ada/cio.c b/gcc/ada/cio.c index 73e54270f0d..2564e4d3c47 100644 --- a/gcc/ada/cio.c +++ b/gcc/ada/cio.c @@ -54,9 +54,14 @@ extern "C" { #undef stdout #endif -#ifdef VTHREADS -#undef putchar +/* Don't use macros versions of this functions on VxWorks since they cause + imcompatible changes in some VxWorks versions */ +#ifdef __vxworks #undef getchar +#undef putchar +#undef feof +#undef ferror +#undef fileno #endif #ifdef RTX diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index da6c8a688ed..d21b3ecb34f 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,18 +23,20 @@ -- -- ------------------------------------------------------------------------------ --- This package contains routines called when a fatal internal compiler --- error is detected. Calls to these routines cause termination of the --- current compilation with appropriate error output. +-- This package contains routines called when a fatal internal compiler error +-- is detected. Calls to these routines cause termination of the current +-- compilation with appropriate error output. with Atree; use Atree; with Debug; use Debug; with Errout; use Errout; with Gnatvsn; use Gnatvsn; +with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Output; use Output; +with Sinfo; use Sinfo; with Sinput; use Sinput; with Sprint; use Sprint; with Sdefault; use Sdefault; @@ -44,6 +46,7 @@ with Types; use Types; with Ada.Exceptions; use Ada.Exceptions; +with System.OS_Lib; use System.OS_Lib; with System.Soft_Links; use System.Soft_Links; package body Comperr is @@ -144,6 +147,12 @@ package body Comperr is end if; end if; + -- If we are in CodePeer mode, we must also delete SCIL files + + if CodePeer_Mode then + Delete_SCIL_Files; + end if; + -- If any errors have already occurred, then we guess that the abort -- may well be caused by previous errors, and we don't make too much -- fuss about it, since we want to let programmer fix the errors first. @@ -422,9 +431,42 @@ package body Comperr is Source_Dump; raise Unrecoverable_Error; end if; - end Compiler_Abort; + ----------------------- + -- Delete_SCIL_Files -- + ----------------------- + + procedure Delete_SCIL_Files is + Main : Node_Id; + Success : Boolean; + pragma Unreferenced (Success); + + begin + -- If parsing was not successful, no Main_Unit is available, so return + -- immediately. + + if Main_Source_File = No_Source_File then + return; + end if; + + -- Retrieve unit name, and remove old versions of SCIL/<unit>.scil and + -- SCIL/<unit>__body.scil + + Main := Unit (Cunit (Main_Unit)); + + if Nkind (Main) = N_Subprogram_Body then + Get_Name_String (Chars (Defining_Unit_Name (Specification (Main)))); + else + Get_Name_String (Chars (Defining_Unit_Name (Main))); + end if; + + Delete_File + ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scil", Success); + Delete_File + ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scil", Success); + end Delete_SCIL_Files; + ----------------- -- Repeat_Char -- ----------------- diff --git a/gcc/ada/comperr.ads b/gcc/ada/comperr.ads index 04a60621897..a45faf16245 100644 --- a/gcc/ada/comperr.ads +++ b/gcc/ada/comperr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +50,9 @@ package Comperr is -- end exception (with possible message stored in TSD.Current_Excep, -- and negative (an unused value) for a GCC abort. + procedure Delete_SCIL_Files; + -- Delete SCIL files associated with the main unit + ------------------------------ -- Use of gnat_bug.box File -- ------------------------------ diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c index 3477cf4e616..9b2e9b272b5 100644 --- a/gcc/ada/cstreams.c +++ b/gcc/ada/cstreams.c @@ -70,6 +70,16 @@ extern "C" { #endif +/* Don't use macros versions of this functions on VxWorks since they cause + imcompatible changes in some VxWorks versions */ +#ifdef __vxworks +#undef getchar +#undef putchar +#undef feof +#undef ferror +#undef fileno +#endif + /* The _IONBF value in MINGW32 stdio.h is wrong. */ #if defined (WINNT) || defined (_WINNT) #if OLD_MINGW diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 6f9a7d68d49..2e565b94054 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -122,8 +122,8 @@ package body Debug is -- d.B -- d.C Generate concatenation call, do not generate inline code -- d.D - -- d.E - -- d.F ALFA mode + -- d.E Force Alfa mode for gnat2why + -- d.F Alfa mode -- d.G Precondition only mode for gnat2why -- d.H Standard package only mode for gnat2why -- d.I SCIL generation mode @@ -580,7 +580,11 @@ 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.F ALFA mode. Generate AST in a form suitable for formal verification, + -- 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 + -- 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. diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb index 35b7f002553..43455b910d9 100644 --- a/gcc/ada/debug_a.adb +++ b/gcc/ada/debug_a.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -75,6 +75,8 @@ package body Debug_A is -- Now push the new element + -- Why is this done unconditionally??? + Debug_A_Depth := Debug_A_Depth + 1; if Debug_A_Depth <= Max_Node_Ids then @@ -101,6 +103,8 @@ package body Debug_A is -- We look down the stack to find something with a decent Sloc. (If -- we find nothing, just leave it unchanged which is not so terrible) + -- This seems nasty overhead for the normal case ??? + for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop if Sloc (Node_Ids (J)) > No_Location then Current_Error_Node := Node_Ids (J); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 753dd4bfc91..494f31b9f1c 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -521,8 +521,8 @@ package body Einfo is -- Has_Implicit_Dereference Flag251 -- Is_Processed_Transient Flag252 + -- Has_Anonymous_Master Flag253 - -- (unused) Flag253 -- (unused) Flag254 ----------------------- @@ -1038,7 +1038,8 @@ package body Einfo is function Extra_Accessibility (Id : E) return E is begin - pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + pragma Assert + (Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant)); return Node13 (Id); end Extra_Accessibility; @@ -1182,6 +1183,13 @@ package body Einfo is return Flag201 (Id); end Has_Anon_Block_Suffix; + function Has_Anonymous_Master (Id : E) return B is + begin + pragma Assert + (Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure)); + return Flag253 (Id); + end Has_Anonymous_Master; + function Has_Atomic_Components (Id : E) return B is begin return Flag86 (Implementation_Base_Type (Id)); @@ -1591,7 +1599,7 @@ package body Einfo is function Has_Xref_Entry (Id : E) return B is begin - return Flag182 (Implementation_Base_Type (Id)); + return Flag182 (Id); end Has_Xref_Entry; function Hiding_Loop_Variable (Id : E) return E is @@ -3506,7 +3514,8 @@ package body Einfo is procedure Set_Extra_Accessibility (Id : E; V : E) is begin - pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); + pragma Assert + (Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant)); Set_Node13 (Id, V); end Set_Extra_Accessibility; @@ -3660,6 +3669,13 @@ package body Einfo is Set_Flag201 (Id, V); end Set_Has_Anon_Block_Suffix; + procedure Set_Has_Anonymous_Master (Id : E; V : B := True) is + begin + pragma Assert + (Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure)); + Set_Flag253 (Id, V); + end Set_Has_Anonymous_Master; + procedure Set_Has_Atomic_Components (Id : E; V : B := True) is begin pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id)); @@ -5459,12 +5475,23 @@ package body Einfo is Set_Uint14 (Id, No_Uint); -- Normalized_Position end Init_Component_Location; + ---------------------------- + -- Init_Object_Size_Align -- + ---------------------------- + + procedure Init_Object_Size_Align (Id : E) is + begin + Set_Uint12 (Id, Uint_0); -- Esize + Set_Uint14 (Id, Uint_0); -- Alignment + end Init_Object_Size_Align; + --------------- -- Init_Size -- --------------- procedure Init_Size (Id : E; V : Int) is begin + pragma Assert (not Is_Object (Id)); Set_Uint12 (Id, UI_From_Int (V)); -- Esize Set_Uint13 (Id, UI_From_Int (V)); -- RM_Size end Init_Size; @@ -5475,6 +5502,7 @@ package body Einfo is procedure Init_Size_Align (Id : E) is begin + pragma Assert (not Is_Object (Id)); Set_Uint12 (Id, Uint_0); -- Esize Set_Uint13 (Id, Uint_0); -- RM_Size Set_Uint14 (Id, Uint_0); -- Alignment @@ -6907,7 +6935,14 @@ package body Einfo is if Is_Concurrent_Type (Id) then if Present (Corresponding_Record_Type (Id)) then return Direct_Primitive_Operations - (Corresponding_Record_Type (Id)); + (Corresponding_Record_Type (Id)); + + -- If expansion is disabled the corresponding record type is absent, + -- but if the type has ancestors it may have primitive operations. + + elsif Is_Tagged_Type (Id) then + return Direct_Primitive_Operations (Id); + else return No_Elist; end if; @@ -7397,6 +7432,7 @@ package body Einfo is W ("Has_Alignment_Clause", Flag46 (Id)); W ("Has_All_Calls_Remote", Flag79 (Id)); W ("Has_Anon_Block_Suffix", Flag201 (Id)); + W ("Has_Anonymous_Master", Flag253 (Id)); W ("Has_Atomic_Components", Flag86 (Id)); W ("Has_Biased_Representation", Flag139 (Id)); W ("Has_Completion", Flag26 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index c60fdd1aeb0..c0dda86ca66 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1341,6 +1341,13 @@ package Einfo is -- more anonymous blocks and the Chars field contains a name with an -- anonymous block suffix (see Exp_Dbug for further details). +-- Has_Anonymous_Master (Flag253) +-- Present in units (top-level functions and procedures, library-level +-- packages). Set to True if the associated unit contains a heterogeneous +-- finalization master. The master's name is of the form <unit>AM and it +-- services anonymous access-to-controlled types with an undetermined +-- lifetime. + -- Has_Atomic_Components (Flag86) [implementation base type only] -- Present in all types and objects. Set only for an array type or -- an array object if a valid pragma Atomic_Components applies to the @@ -1990,8 +1997,9 @@ package Einfo is -- of pragma Ada_12 or Ada_2012. -- Is_Aliased (Flag15) --- Present in objects whose declarations carry the keyword aliased, --- and on record components that have the keyword. +-- Present in all entities. Set for objects and types whose declarations +-- carry the keyword aliased, and on record components that have the +-- keyword. For Ada 2012, also applies to formal parameters. -- Is_AST_Entry (Flag132) -- Present in entry entities. Set if a valid pragma AST_Entry applies @@ -2446,10 +2454,11 @@ package Einfo is -- Is_Local_Anonymous_Access (Flag194) -- Present in access types. Set for an anonymous access type to indicate -- that the type is created for a record component with an access --- definition, an array component, or a stand-alone object. Such --- anonymous types have an accessibility level equal to that of the +-- definition, an array component, or (pre-Ada2012) a stand-alone object. +-- Such anonymous types have an accessibility level equal to that of the -- declaration in which they appear, unlike the anonymous access types --- that are created for access parameters and access discriminants. +-- that are created for access parameters, access discriminants, and +-- (as of Ada2012) stand-alone objects. -- Is_Machine_Code_Subprogram (Flag137) -- Present in subprogram entities. Set to indicate that the subprogram @@ -4765,6 +4774,7 @@ package Einfo is -- Is_Ada_2005_Only (Flag185) -- Is_Ada_2012_Only (Flag199) -- Is_Bit_Packed_Array (Flag122) (base type only) + -- Is_Aliased (Flag15) -- Is_Character_Type (Flag63) -- Is_Child_Unit (Flag73) -- Is_Compilation_Unit (Flag149) @@ -4986,7 +4996,6 @@ package Einfo is -- Component_Alignment (special) (base type only) -- Has_Component_Size_Clause (Flag68) (base type only) -- Has_Pragma_Pack (Flag121) (impl base type only) - -- Is_Aliased (Flag15) -- Is_Constrained (Flag12) -- Next_Index (synth) -- Number_Dimensions (synth) @@ -5050,6 +5059,7 @@ package Einfo is -- Discriminal_Link (Node10) (discriminals only) -- Full_View (Node11) -- Esize (Uint12) + -- Extra_Accessibility (Node13) (constants only) -- Alignment (Uint14) -- Return_Flag_Or_Transient_Decl (Node15) (constants only) -- Actual_Subtype (Node17) @@ -5237,6 +5247,7 @@ package Einfo is -- Delay_Cleanups (Flag114) -- Delay_Subprogram_Descriptors (Flag50) -- Discard_Names (Flag88) + -- Has_Anonymous_Master (Flag253) -- Has_Completion (Flag26) -- Has_Controlling_Result (Flag98) -- Has_Invariants (Flag232) @@ -5427,6 +5438,7 @@ package Einfo is -- Elaborate_Body_Desirable (Flag210) (non-generic case only) -- From_With_Type (Flag159) -- Has_All_Calls_Remote (Flag79) + -- Has_Anonymous_Master (Flag253) -- Has_Completion (Flag26) -- Has_Forward_Instantiation (Flag175) -- Has_Master_Entity (Flag21) @@ -5437,10 +5449,10 @@ package Einfo is -- Is_Instantiated (Flag126) -- Is_Private_Descendant (Flag53) -- Is_Visible_Child_Unit (Flag116) - -- Is_Wrapper_Package (synth) (non-generic case only) -- Renamed_In_Spec (Flag231) (non-generic case only) - -- Scope_Depth (synth) -- Static_Elaboration_Desired (Flag77) (non-generic case only) + -- Is_Wrapper_Package (synth) (non-generic case only) + -- Scope_Depth (synth) -- E_Package_Body -- Handler_Records (List10) (non-generic case only) @@ -5450,9 +5462,10 @@ package Einfo is -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) -- Finalizer (Node24) (non-generic case only) - -- Scope_Depth (synth) -- Delay_Subprogram_Descriptors (Flag50) + -- Has_Anonymous_Master (Flag253) -- Has_Subprogram_Descriptor (Flag93) + -- Scope_Depth (synth) -- E_Private_Type -- E_Private_Subtype @@ -5503,6 +5516,7 @@ package Einfo is -- Delay_Cleanups (Flag114) -- Delay_Subprogram_Descriptors (Flag50) -- Discard_Names (Flag88) + -- Has_Anonymous_Master (Flag253) -- Has_Completion (Flag26) -- Has_Invariants (Flag232) -- Has_Master_Entity (Flag21) @@ -6071,6 +6085,7 @@ package Einfo is function Has_Alignment_Clause (Id : E) return B; function Has_All_Calls_Remote (Id : E) return B; function Has_Anon_Block_Suffix (Id : E) return B; + function Has_Anonymous_Master (Id : E) return B; function Has_Atomic_Components (Id : E) return B; function Has_Biased_Representation (Id : E) return B; function Has_Completion (Id : E) return B; @@ -6658,6 +6673,7 @@ package Einfo is procedure Set_Has_Alignment_Clause (Id : E; V : B := True); procedure Set_Has_All_Calls_Remote (Id : E; V : B := True); procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True); + procedure Set_Has_Anonymous_Master (Id : E; V : B := True); procedure Set_Has_Atomic_Components (Id : E; V : B := True); procedure Set_Has_Biased_Representation (Id : E; V : B := True); procedure Set_Has_Completion (Id : E; V : B := True); @@ -7017,6 +7033,10 @@ package Einfo is -- This procedure initializes both size fields and the alignment -- field to all be Unknown. + procedure Init_Object_Size_Align (Id : E); + -- Same as Init_Size_Align except RM_Size field (which is only for types) + -- is unaffected. + procedure Init_Size (Id : E; V : Int); -- Initialize both the Esize and RM_Size fields of E to V @@ -7354,6 +7374,7 @@ package Einfo is pragma Inline (Has_Alignment_Clause); pragma Inline (Has_All_Calls_Remote); pragma Inline (Has_Anon_Block_Suffix); + pragma Inline (Has_Anonymous_Master); pragma Inline (Has_Atomic_Components); pragma Inline (Has_Biased_Representation); pragma Inline (Has_Completion); @@ -7797,6 +7818,7 @@ package Einfo is pragma Inline (Set_Has_Alignment_Clause); pragma Inline (Set_Has_All_Calls_Remote); pragma Inline (Set_Has_Anon_Block_Suffix); + pragma Inline (Set_Has_Anonymous_Master); pragma Inline (Set_Has_Atomic_Components); pragma Inline (Set_Has_Biased_Representation); pragma Inline (Set_Has_Completion); diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 39d73027840..88482898a92 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -617,6 +617,23 @@ package body Errout is Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1; end Error_Msg_CRT; + ------------------ + -- Error_Msg_PT -- + ------------------ + + procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id) is + begin + -- Error message below needs rewording (remember comma in -gnatj + -- mode) ??? + + Error_Msg_NE + ("first formal of & must be of mode `OUT`, `IN OUT` or " & + "access-to-variable", Typ, Subp); + Error_Msg_N + ("\in order to be overridden by protected procedure or entry " & + "(RM 9.4(11.9/2))", Typ); + end Error_Msg_PT; + ----------------- -- Error_Msg_F -- ----------------- @@ -2832,10 +2849,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 Alfa mode, -- since pragma Pack is also ignored in these configurations. - if CodePeer_Mode or ALFA_Mode then + if CodePeer_Mode or Alfa_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 ef3dcc47c29..ddf34f79f03 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -495,8 +495,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 Alfa used in + -- error messages about the Alfa 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 @@ -801,6 +801,10 @@ package Errout is -- run-time mode or no run-time mode (as appropriate). In the former case, -- the name of the library is output if available. + procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id); + -- Posts an error on the protected type declaration Typ indicating wrong + -- mode of the first formal of protected type primitive Subp. + procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg; -- Debugging routine to dump an error message diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 593b71ceb27..649238018a1 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -955,12 +955,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 Alfa - elsif Name_Len = 4 and then Name_Buffer (1 .. 4) = "ALFA" then + elsif Name_Len = 4 and then Name_Buffer (1 .. 4) = "Alfa" then Set_Msg_Name_Buffer; - -- Neither RM nor ALFA: case appropriately and add surrounding quotes + -- Neither RM nor Alfa: 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 037a8dcc6ea..a54ebe8b297 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4664,12 +4664,6 @@ package body Exp_Aggr is Check_Same_Aggr_Bounds (N, 1); end if; - -- In formal verification mode, leave the aggregate non-expanded - - if ALFA_Mode then - return; - end if; - -- STEP 2 -- Here we test for is packed array aggregate that we can handle at diff --git a/gcc/ada/exp_alfa.adb b/gcc/ada/exp_alfa.adb new file mode 100644 index 00000000000..04c8484cb0c --- /dev/null +++ b/gcc/ada/exp_alfa.adb @@ -0,0 +1,245 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A L F A -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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 Atree; use Atree; +with Einfo; use Einfo; +with Exp_Attr; use Exp_Attr; +with Exp_Ch6; use Exp_Ch6; +with Exp_Dbug; use Exp_Dbug; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sem_Res; use Sem_Res; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; + +package body Exp_Alfa is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Expand_Alfa_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); + -- Expand attributes 'Old and 'Result only + + procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id); + -- Insert conversion on function return if necessary + + procedure Expand_Alfa_Simple_Function_Return (N : Node_Id); + -- Expand simple return from function + + ----------------- + -- Expand_Alfa -- + ----------------- + + procedure Expand_Alfa (N : Node_Id) is + begin + case Nkind (N) is + + when N_Package_Body | + N_Package_Declaration | + N_Subprogram_Body | + N_Block_Statement => + Qualify_Entity_Names (N); + + when N_Simple_Return_Statement => + Expand_Alfa_N_Simple_Return_Statement (N); + + when N_Function_Call | + N_Procedure_Call_Statement => + Expand_Alfa_Call (N); + + when N_Attribute_Reference => + Expand_Alfa_N_Attribute_Reference (N); + + when others => + null; + end case; + end Expand_Alfa; + + ---------------------- + -- Expand_Alfa_Call -- + ---------------------- + + procedure Expand_Alfa_Call (N : Node_Id) is + Call_Node : constant Node_Id := N; + Parent_Subp : Entity_Id; + Subp : Entity_Id; + + begin + -- Ignore if previous error + + if Nkind (Call_Node) in N_Has_Etype + and then Etype (Call_Node) = Any_Type + then + return; + end if; + + -- Call using access to subprogram with explicit dereference + + if Nkind (Name (Call_Node)) = N_Explicit_Dereference then + Subp := Etype (Name (Call_Node)); + Parent_Subp := Empty; + + -- Case of call to simple entry, where the Name is a selected component + -- whose prefix is the task, and whose selector name is the entry name + + elsif Nkind (Name (Call_Node)) = N_Selected_Component then + Subp := Entity (Selector_Name (Name (Call_Node))); + Parent_Subp := Empty; + + -- Case of call to member of entry family, where Name is an indexed + -- component, with the prefix being a selected component giving the + -- task and entry family name, and the index being the entry index. + + elsif Nkind (Name (Call_Node)) = N_Indexed_Component then + Subp := Entity (Selector_Name (Prefix (Name (Call_Node)))); + Parent_Subp := Empty; + + -- Normal case + + else + Subp := Entity (Name (Call_Node)); + Parent_Subp := Alias (Subp); + end if; + + -- Various expansion activities for actuals are carried out + + Expand_Actuals (N, Subp); + + -- If the subprogram is a renaming, replace it in the call with the name + -- of the actual subprogram being called. + + if Present (Parent_Subp) then + Parent_Subp := Ultimate_Alias (Parent_Subp); + + -- The below setting of Entity is suspect, see F109-018 discussion??? + + Set_Entity (Name (Call_Node), Parent_Subp); + end if; + + end Expand_Alfa_Call; + + --------------------------------------- + -- Expand_Alfa_N_Attribute_Reference -- + --------------------------------------- + + procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id) is + Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); + + begin + case Id is + when Attribute_Old | + Attribute_Result => + Expand_N_Attribute_Reference (N); + + when others => + null; + end case; + end Expand_Alfa_N_Attribute_Reference; + + ------------------------------------------- + -- Expand_Alfa_N_Simple_Return_Statement -- + ------------------------------------------- + + procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id) is + begin + -- Defend against previous errors (i.e. the return statement calls a + -- function that is not available in configurable runtime). + + if Present (Expression (N)) + and then Nkind (Expression (N)) = N_Empty + then + return; + end if; + + -- Distinguish the function and non-function cases: + + case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is + + when E_Function | + E_Generic_Function => + Expand_Alfa_Simple_Function_Return (N); + + when E_Procedure | + E_Generic_Procedure | + E_Entry | + E_Entry_Family | + E_Return_Statement => + -- Expand_Non_Function_Return (N); + null; + + when others => + raise Program_Error; + end case; + + exception + when RE_Not_Available => + return; + end Expand_Alfa_N_Simple_Return_Statement; + + ---------------------------------------- + -- Expand_Alfa_Simple_Function_Return -- + ---------------------------------------- + + procedure Expand_Alfa_Simple_Function_Return (N : Node_Id) is + Scope_Id : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + -- The function we are returning from + + R_Type : constant Entity_Id := Etype (Scope_Id); + -- The result type of the function + + Exp : constant Node_Id := Expression (N); + pragma Assert (Present (Exp)); + + Exptyp : constant Entity_Id := Etype (Exp); + -- The type of the expression (not necessarily the same as R_Type) + + begin + -- Check the result expression of a scalar function against the subtype + -- of the function by inserting a conversion. This conversion must + -- eventually be performed for other classes of types, but for now it's + -- only done for scalars. + -- ??? + + if Is_Scalar_Type (Exptyp) then + Rewrite (Exp, Convert_To (R_Type, Exp)); + + -- The expression is resolved to ensure that the conversion gets + -- expanded to generate a possible constraint check. + + Analyze_And_Resolve (Exp, R_Type); + end if; + end Expand_Alfa_Simple_Function_Return; + +end Exp_Alfa; diff --git a/gcc/ada/exp_alfa.ads b/gcc/ada/exp_alfa.ads new file mode 100644 index 00000000000..a5c07864be1 --- /dev/null +++ b/gcc/ada/exp_alfa.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A L F A -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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 implements a light expansion which is used in formal +-- verification mode. Instead of a complete expansion of nodes for code +-- generation, this Alfa expansion targets generation of intermediate code +-- for formal verification. + +-- Expand_Alfa is called directly by Expander.Expand. + +-- Alfa expansion has three main objectives: + +-- 1. Perform limited expansion to explicit some Ada rules and constructs +-- (translate 'Old and 'Result, replace renamings by renamed, insert +-- conversions, expand actuals in calls to introduce temporaries) + +-- 2. Facilitate treatment for the formal verification back-end (fully +-- qualify names) + +-- 3. Avoid the introduction of low-level code that is difficult to analyze +-- formally, as typically done in the full expansion for high-level +-- constructs (tasking, dispatching) + +with Types; use Types; + +package Exp_Alfa is + + procedure Expand_Alfa (N : Node_Id); + +end Exp_Alfa; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index c03a040fdaf..c38a3844a78 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3091,6 +3091,100 @@ package body Exp_Attr is Rewrite (N, New_Occurrence_Of (Tnn, Loc)); end Old; + ---------------------- + -- Overlaps_Storage -- + ---------------------- + + when Attribute_Overlaps_Storage => Overlaps_Storage : declare + Loc : constant Source_Ptr := Sloc (N); + + X : constant Node_Id := Prefix (N); + Y : constant Node_Id := First (Expressions (N)); + -- The argumens + + X_Addr, Y_Addr : Node_Id; + -- the expressions for their integer addresses + + X_Size, Y_Size : Node_Id; + -- the expressions for their sizes + + Cond : Node_Id; + + begin + -- Attribute expands into: + + -- if X'Address < Y'address then + -- (X'address + X'Size - 1) >= Y'address + -- else + -- (Y'address + Y'size - 1) >= X'Address + -- end if; + + -- with the proper address operations. We convert addresses to + -- integer addresses to use predefined arithmetic. The size is + -- expressed in storage units. + + X_Addr := + Unchecked_Convert_To (RTE (RE_Integer_Address), + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => New_Copy_Tree (X))); + + Y_Addr := + Unchecked_Convert_To (RTE (RE_Integer_Address), + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => New_Copy_Tree (Y))); + + X_Size := + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Size, + Prefix => New_Copy_Tree (X)), + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit)); + + Y_Size := + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Size, + Prefix => New_Copy_Tree (Y)), + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit)); + + Cond := + Make_Op_Le (Loc, + Left_Opnd => X_Addr, + Right_Opnd => Y_Addr); + + Rewrite (N, + Make_Conditional_Expression (Loc, + New_List ( + Cond, + + Make_Op_Ge (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => X_Addr, + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => X_Size, + Right_Opnd => Make_Integer_Literal (Loc, 1))), + Right_Opnd => Y_Addr), + + Make_Op_Ge (Loc, + Make_Op_Add (Loc, + Left_Opnd => Y_Addr, + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => Y_Size, + Right_Opnd => Make_Integer_Literal (Loc, 1))), + Right_Opnd => X_Addr)))); + + Analyze_And_Resolve (N, Standard_Boolean); + end Overlaps_Storage; + ------------ -- Output -- ------------ @@ -3916,6 +4010,73 @@ package body Exp_Attr is when Attribute_Rounding => Expand_Fpt_Attribute_R (N); + ------------------ + -- Same_Storage -- + ------------------ + + when Attribute_Same_Storage => Same_Storage : declare + Loc : constant Source_Ptr := Sloc (N); + + X : constant Node_Id := Prefix (N); + Y : constant Node_Id := First (Expressions (N)); + -- The argumens + + X_Addr, Y_Addr : Node_Id; + -- the expressions for their addresses + + X_Size, Y_Size : Node_Id; + -- the expressions for their sizes + + begin + -- The attribute is expanded as: + + -- (X'address = Y'address) + -- and then (X'Size = Y'Size) + + -- If both arguments have the same Etype the second conjunct can be + -- omitted. + + X_Addr := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => New_Copy_Tree (X)); + + Y_Addr := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Address, + Prefix => New_Copy_Tree (Y)); + + X_Size := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Size, + Prefix => New_Copy_Tree (X)); + + Y_Size := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Size, + Prefix => New_Copy_Tree (Y)); + + if Etype (X) = Etype (Y) then + Rewrite (N, + (Make_Op_Eq (Loc, + Left_Opnd => X_Addr, + Right_Opnd => Y_Addr))); + else + Rewrite (N, + Make_Op_And (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => X_Addr, + Right_Opnd => Y_Addr), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => X_Size, + Right_Opnd => Y_Size))); + end if; + + Analyze_And_Resolve (N, Standard_Boolean); + end Same_Storage; + ------------- -- Scaling -- ------------- diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index caf66cca0e0..dca021f9237 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1673,7 +1673,6 @@ package body Exp_Ch11 is if VM_Target = No_VM and then not CodePeer_Mode - and then not ALFA_Mode and then Exception_Mechanism = Back_End_Exceptions then return; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 361b2a4797f..464fdef4024 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5129,9 +5129,13 @@ package body Exp_Ch3 is Loc)))); end; - elsif Is_Tagged_Type (Typ) - and then Is_CPP_Constructor_Call (Expr) - then + -- Handle C++ constructor calls. Note that we do not check that + -- Typ is a tagged type since the equivalent Ada type of a C++ + -- class that has no virtual methods is a non-tagged limited + -- record type. + + elsif Is_CPP_Constructor_Call (Expr) then + -- The call to the initialization procedure does NOT freeze the -- object being initialized. @@ -5261,6 +5265,52 @@ package body Exp_Ch3 is end if; end if; + if Nkind (N) = N_Object_Declaration + and then Nkind (Object_Definition (N)) = N_Access_Definition + and then not Is_Local_Anonymous_Access (Etype (Def_Id)) + then + -- An Ada 2012 stand-alone object of an anonymous access type + + declare + Loc : constant Source_Ptr := Sloc (N); + + Level : constant Entity_Id := + Make_Defining_Identifier (Sloc (N), + Chars => + New_External_Name (Chars (Def_Id), Suffix => "L")); + + Level_Expr : Node_Id; + Level_Decl : Node_Id; + + begin + Set_Ekind (Level, Ekind (Def_Id)); + Set_Etype (Level, Standard_Natural); + Set_Scope (Level, Scope (Def_Id)); + + if No (Expr) then + + -- Set accessibility level of null + + Level_Expr := + Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard)); + + else + Level_Expr := Dynamic_Accessibility_Level (Expr); + end if; + + Level_Decl := Make_Object_Declaration (Loc, + Defining_Identifier => Level, + Object_Definition => New_Occurrence_Of (Standard_Natural, Loc), + Expression => Level_Expr, + Constant_Present => Constant_Present (N), + Has_Init_Expression => True); + + Insert_Action_After (Init_After, Level_Decl); + + Set_Extra_Accessibility (Def_Id, Level); + end; + end if; + -- Exception on library entity not available exception @@ -5481,14 +5531,18 @@ package body Exp_Ch3 is then Build_Slice_Assignment (Typ); end if; + end if; - -- ??? Now that masters acts as heterogeneous lists, it might be - -- worthwhile to revisit the global master approach. + -- Create a finalization master to service the anonymous access + -- components of the array. - elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) + if Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Designated_Type (Comp_Typ)) then - Build_Finalization_Master (Comp_Typ); + Build_Finalization_Master + (Typ => Comp_Typ, + Ins_Node => Parent (Typ), + Encl_Scope => Scope (Typ)); end if; end if; @@ -5902,6 +5956,7 @@ package body Exp_Ch3 is Type_Decl : constant Node_Id := Parent (Def_Id); Comp : Entity_Id; Comp_Typ : Entity_Id; + Has_AACC : Boolean; Predef_List : List_Id; Renamed_Eq : Node_Id := Empty; @@ -5970,7 +6025,9 @@ package body Exp_Ch3 is -- Update task and controlled component flags, because some of the -- component types may have been private at the point of the record - -- declaration. + -- declaration. Detect anonymous access-to-controlled components. + + Has_AACC := False; Comp := First_Component (Def_Id); while Present (Comp) loop @@ -5988,6 +6045,14 @@ package body Exp_Ch3 is and then Is_Controlled (Comp_Typ))) then Set_Has_Controlled_Component (Def_Id); + + -- Non-self-referential anonymous access-to-controlled component + + elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Designated_Type (Comp_Typ)) + and then Designated_Type (Comp_Typ) /= Def_Id + then + Has_AACC := True; end if; Next_Component (Comp); @@ -6355,28 +6420,103 @@ package body Exp_Ch3 is end; end if; - -- Processing for components of anonymous access type that designate - -- a controlled type. + -- Create a heterogeneous finalization master to service the anonymous + -- access-to-controlled components of the record type. - Comp := First_Component (Def_Id); - while Present (Comp) loop - Comp_Typ := Etype (Comp); + if Has_AACC then + declare + Encl_Scope : constant Entity_Id := Scope (Def_Id); + Ins_Node : constant Node_Id := Parent (Def_Id); + Loc : constant Source_Ptr := Sloc (Def_Id); + Fin_Mas_Id : Entity_Id; - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Directly_Designated_Type (Comp_Typ)) + Attributes_Set : Boolean := False; + Master_Built : Boolean := False; + -- Two flags which control the creation and initialization of a + -- common heterogeneous master. - -- Avoid self-references + begin + Comp := First_Component (Def_Id); + while Present (Comp) loop + Comp_Typ := Etype (Comp); - and then Directly_Designated_Type (Comp_Typ) /= Def_Id - then - Build_Finalization_Master - (Typ => Comp_Typ, - Ins_Node => Parent (Def_Id), - Encl_Scope => Scope (Def_Id)); - end if; + -- A non-self-referential anonymous access-to-controlled + -- component. - Next_Component (Comp); - end loop; + if Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Designated_Type (Comp_Typ)) + and then Designated_Type (Comp_Typ) /= Def_Id + then + if VM_Target = No_VM then + + -- Build a homogeneous master for the first anonymous + -- access-to-controlled component. This master may be + -- converted into a heterogeneous collection if more + -- components are to follow. + + if not Master_Built then + Master_Built := True; + + -- All anonymous access-to-controlled types allocate + -- on the global pool. + + Set_Associated_Storage_Pool (Comp_Typ, + Get_Global_Pool_For_Access_Type (Comp_Typ)); + + Build_Finalization_Master + (Typ => Comp_Typ, + Ins_Node => Ins_Node, + Encl_Scope => Encl_Scope); + + Fin_Mas_Id := Finalization_Master (Comp_Typ); + + -- Subsequent anonymous access-to-controlled components + -- reuse the already available master. + + else + -- All anonymous access-to-controlled types allocate + -- on the global pool. + + Set_Associated_Storage_Pool (Comp_Typ, + Get_Global_Pool_For_Access_Type (Comp_Typ)); + + -- Shared the master among multiple components + + Set_Finalization_Master (Comp_Typ, Fin_Mas_Id); + + -- Convert the master into a heterogeneous collection. + -- Generate: + -- + -- Set_Is_Heterogeneous (<Fin_Mas_Id>); + + if not Attributes_Set then + Attributes_Set := True; + + Insert_Action (Ins_Node, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (RTE (RE_Set_Is_Heterogeneous), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Fin_Mas_Id, Loc)))); + end if; + end if; + + -- Since .NET/JVM targets do not support heterogeneous + -- masters, each component must have its own master. + + else + Build_Finalization_Master + (Typ => Comp_Typ, + Ins_Node => Ins_Node, + Encl_Scope => Encl_Scope); + end if; + end if; + + Next_Component (Comp); + end loop; + end; + end if; end Expand_Freeze_Record_Type; ------------------------------ @@ -6669,16 +6809,16 @@ package body Exp_Ch3 is end if; -- For access-to-controlled types (including class-wide types and - -- Taft-amendment types which potentially have controlled + -- Taft-amendment types, which potentially have controlled -- components), expand the list controller object that will store - -- the dynamically allocated objects. Do not do this - -- transformation for expander-generated access types, but do it - -- for types that are the full view of types derived from other - -- private types. Also suppress the list controller in the case - -- of a designated type with convention Java, since this is used - -- when binding to Java API specs, where there's no equivalent of - -- a finalization list and we don't want to pull in the - -- finalization support if not needed. + -- the dynamically allocated objects. Don't do this transformation + -- for expander-generated access types, but do it for types that + -- are the full view of types derived from other private types. + -- Also suppress the list controller in the case of a designated + -- type with convention Java, since this is used when binding to + -- Java API specs, where there's no equivalent of a finalization + -- list and we don't want to pull in the finalization support if + -- not needed. if not Comes_From_Source (Def_Id) and then not Has_Private_Declaration (Def_Id) @@ -6697,8 +6837,8 @@ package body Exp_Ch3 is then null; - -- The machinery assumes that incomplete or private types are - -- always completed by a controlled full vies. + -- Assume that incomplete and private types are always completed + -- by a controlled full view. elsif Needs_Finalization (Desig_Type) or else @@ -7999,14 +8139,20 @@ package body Exp_Ch3 is Field_Name := Chars (Defining_Identifier (C)); -- The tags must not be compared: they are not part of the value. - -- Ditto for the controller component, if present. + -- Ditto for parent interfaces because their equality operator is + -- abstract. -- Note also that in the following, we use Make_Identifier for -- the component names. Use of New_Reference_To to identify the -- components would be incorrect because the wrong entities for -- discriminants could be picked up in the private type case. - if Field_Name /= Name_uTag then + if Field_Name = Name_uParent + and then Is_Interface (Etype (Defining_Identifier (C))) + then + null; + + elsif Field_Name /= Name_uTag then Evolve_Or_Else (Cond, Make_Op_Ne (Loc, Left_Opnd => diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e3f9412393b..3c6754b26bb 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -31,6 +31,7 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Atag; use Exp_Atag; +with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; @@ -57,6 +58,7 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -91,13 +93,11 @@ package body Exp_Ch4 is -- If a boolean array assignment can be done in place, build call to -- corresponding library procedure. - function Current_Unit_First_Declaration return Node_Id; - -- Return the current unit's first declaration. If the declaration list is - -- empty, the routine generates a null statement and returns it. - - function Current_Unit_Scope return Entity_Id; - -- Return the scope of the current unit. If the current unit is a body, - -- return the scope of the spec. + function Current_Anonymous_Master return Entity_Id; + -- Return the entity of the heterogeneous finalization master belonging to + -- the current unit (either function, package or procedure). This master + -- services all anonymous access-to-controlled types. If the current unit + -- does not have such master, create one. procedure Displace_Allocator_Pointer (N : Node_Id); -- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and @@ -375,79 +375,166 @@ package body Exp_Ch4 is return; end Build_Boolean_Array_Proc_Call; - ------------------------------------ - -- Current_Unit_First_Declaration -- - ------------------------------------ + ------------------------------ + -- Current_Anonymous_Master -- + ------------------------------ - function Current_Unit_First_Declaration return Node_Id is - Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit)); - Decl : Node_Id; - Decls : List_Id; + function Current_Anonymous_Master return Entity_Id is + Decls : List_Id; + Fin_Mas_Id : Entity_Id; + Loc : Source_Ptr; + Subp_Body : Node_Id; + Unit_Decl : Node_Id; + Unit_Id : Entity_Id; begin - if Nkind (Sem_U) = N_Package_Declaration then - Sem_U := Specification (Sem_U); - Decls := Visible_Declarations (Sem_U); + Unit_Id := Cunit_Entity (Current_Sem_Unit); + + -- Find the entity of the current unit + + if Ekind (Unit_Id) = E_Subprogram_Body then + + -- When processing subprogram bodies, the proper scope is always that + -- of the spec. + + Subp_Body := Unit_Id; + while Present (Subp_Body) + and then Nkind (Subp_Body) /= N_Subprogram_Body + loop + Subp_Body := Parent (Subp_Body); + end loop; + + Unit_Id := Corresponding_Spec (Subp_Body); + end if; + + Loc := Sloc (Unit_Id); + Unit_Decl := Unit (Cunit (Current_Sem_Unit)); + + -- Find the declarations list of the current unit + + if Nkind (Unit_Decl) = N_Package_Declaration then + Unit_Decl := Specification (Unit_Decl); + Decls := Visible_Declarations (Unit_Decl); if No (Decls) then - Decl := Make_Null_Statement (Sloc (Sem_U)); - Decls := New_List (Decl); - Set_Visible_Declarations (Sem_U, Decls); + Decls := New_List (Make_Null_Statement (Loc)); + Set_Visible_Declarations (Unit_Decl, Decls); elsif Is_Empty_List (Decls) then - Decl := Make_Null_Statement (Sloc (Sem_U)); - Append_To (Decls, Decl); - - else - Decl := First (Decls); + Append_To (Decls, Make_Null_Statement (Loc)); end if; else - Decls := Declarations (Sem_U); + Decls := Declarations (Unit_Decl); if No (Decls) then - Decl := Make_Null_Statement (Sloc (Sem_U)); - Decls := New_List (Decl); - Set_Declarations (Sem_U, Decls); + Decls := New_List (Make_Null_Statement (Loc)); + Set_Declarations (Unit_Decl, Decls); elsif Is_Empty_List (Decls) then - Decl := Make_Null_Statement (Sloc (Sem_U)); - Append_To (Decls, Decl); - - else - Decl := First (Decls); + Append_To (Decls, Make_Null_Statement (Loc)); end if; end if; - return Decl; - end Current_Unit_First_Declaration; + -- The current unit has an existing anonymous master, traverse its + -- declarations and locate the entity. - ------------------------ - -- Current_Unit_Scope -- - ------------------------ + if Has_Anonymous_Master (Unit_Id) then + Fin_Mas_Id := First_Entity (Unit_Id); + while Present (Fin_Mas_Id) loop - function Current_Unit_Scope return Entity_Id is - Scop_Id : Entity_Id := Cunit_Entity (Current_Sem_Unit); - Subp_Bod : Node_Id; - - begin - if Ekind (Scop_Id) = E_Subprogram_Body then + -- Look for the first variable whose type is Finalization_Master - -- When processing subprogram bodies, the proper scope is always - -- that of the spec. + if Ekind (Fin_Mas_Id) = E_Variable + and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master) + then + return Fin_Mas_Id; + end if; - Subp_Bod := Scop_Id; - while Present (Subp_Bod) - and then Nkind (Subp_Bod) /= N_Subprogram_Body - loop - Subp_Bod := Parent (Subp_Bod); + Next_Entity (Fin_Mas_Id); end loop; - Scop_Id := Corresponding_Spec (Subp_Bod); - end if; + raise Program_Error; - return Scop_Id; - end Current_Unit_Scope; + -- Create a new anonymous master + + else + declare + First_Decl : constant Node_Id := First (Decls); + Action : Node_Id; + + begin + -- Since the master and its associated initialization is inserted + -- at top level, use the scope of the unit when analyzing. + + Push_Scope (Unit_Id); + + -- Create the finalization master + + Fin_Mas_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Unit_Id), "AM")); + + -- Generate: + -- <Fin_Mas_Id> : Finalization_Master; + + Action := + Make_Object_Declaration (Loc, + Defining_Identifier => Fin_Mas_Id, + Object_Definition => + New_Reference_To (RTE (RE_Finalization_Master), Loc)); + + Insert_Before_And_Analyze (First_Decl, Action); + + -- Mark the unit to prevent the generation of multiple masters + + Set_Has_Anonymous_Master (Unit_Id); + + -- Do not set the base pool and mode of operation on .NET/JVM + -- since those targets do not support pools and all VM masters + -- are heterogeneous by default. + + if VM_Target = No_VM then + + -- Generate: + -- Set_Base_Pool + -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access); + + Action := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Set_Base_Pool), Loc), + + Parameter_Associations => New_List ( + New_Reference_To (Fin_Mas_Id, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (RTE (RE_Global_Pool_Object), Loc), + Attribute_Name => Name_Unrestricted_Access))); + + Insert_Before_And_Analyze (First_Decl, Action); + + -- Generate: + -- Set_Is_Heterogeneous (<Fin_Mas_Id>); + + Action := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Set_Is_Heterogeneous), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Fin_Mas_Id, Loc))); + + Insert_Before_And_Analyze (First_Decl, Action); + end if; + + -- Restore the original state of the scope stack + + Pop_Scope; + + return Fin_Mas_Id; + end; + end if; + end Current_Anonymous_Master; -------------------------------- -- Displace_Allocator_Pointer -- @@ -1050,11 +1137,14 @@ package body Exp_Ch4 is -- Since .NET/JVM compilers do not support address arithmetic, -- this call is skipped. The same is done for CodePeer because - -- primitive Finalize_Address is never generated. + -- primitive Finalize_Address is never generated. Do not create + -- this call if there is no allocator available any more. if VM_Target = No_VM and then not CodePeer_Mode and then Present (Finalization_Master (PtrT)) + and then Present (Temp_Decl) + and then Nkind (Expression (Temp_Decl)) = N_Allocator then Insert_Action (N, Make_Set_Finalize_Address_Call @@ -3372,18 +3462,15 @@ package body Exp_Ch4 is 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)); + Set_Associated_Storage_Pool + (PtrT, Get_Global_Pool_For_Access_Type (PtrT)); end if; -- The finalization master must be inserted and analyzed as part of -- the current semantic unit. if No (Finalization_Master (PtrT)) then - Build_Finalization_Master - (Typ => PtrT, - Ins_Node => Current_Unit_First_Declaration, - Encl_Scope => Current_Unit_Scope); + Set_Finalization_Master (PtrT, Current_Anonymous_Master); end if; end if; @@ -3865,13 +3952,13 @@ package body Exp_Ch4 is -- Types derived from [Limited_]Controlled are the only -- ones considered since they have fields Prev and Next. - if VM_Target /= No_VM - and then Is_Controlled (T) - then - Insert_Action (N, - Make_Attach_Call - (Obj_Ref => New_Copy_Tree (Init_Arg1), - Ptr_Typ => PtrT)); + if VM_Target /= No_VM then + if Is_Controlled (T) then + Insert_Action (N, + Make_Attach_Call + (Obj_Ref => New_Copy_Tree (Init_Arg1), + Ptr_Typ => PtrT)); + end if; -- Default case, generate: @@ -4099,8 +4186,8 @@ package body Exp_Ch4 is 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 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; @@ -4331,10 +4418,35 @@ package body Exp_Ch4 is ------------------------------ procedure Process_Transient_Object (Decl : Node_Id) is - Ins_Nod : constant Node_Id := Parent (N); - -- To avoid the insertion of generated code in the list of Actions, - -- Insert_Action must look at the parent field of the EWA. + function Find_Insertion_Node return Node_Id; + -- Complex conditions in if statements may be converted into nested + -- EWAs. In this case, any generated code must be inserted before the + -- if statement to ensure proper visibility of the hook objects. This + -- routine returns the top most short circuit operator or the parent + -- of the EWA if no nesting was detected. + + ------------------------- + -- Find_Insertion_Node -- + ------------------------- + + function Find_Insertion_Node return Node_Id is + Par : Node_Id; + + begin + -- Climb up the branches of a complex condition + + Par := N; + while Nkind_In (Parent (Par), N_And_Then, N_Op_Not, N_Or_Else) loop + Par := Parent (Par); + end loop; + + return Par; + end Find_Insertion_Node; + + -- Local variables + + Ins_Node : constant Node_Id := Find_Insertion_Node; Loc : constant Source_Ptr := Sloc (Decl); Obj_Id : constant Entity_Id := Defining_Identifier (Decl); Obj_Typ : constant Entity_Id := Etype (Obj_Id); @@ -4345,9 +4457,11 @@ package body Exp_Ch4 is Temp_Decl : Node_Id; Temp_Id : Node_Id; + -- Start of processing for Process_Transient_Object + begin - -- Step 1: Create the access type which provides a reference to - -- the transient object. + -- Step 1: Create the access type which provides a reference to the + -- transient object. if Is_Access_Type (Obj_Typ) then Desig_Typ := Directly_Designated_Type (Obj_Typ); @@ -4363,13 +4477,13 @@ package body Exp_Ch4 is Ptr_Decl := Make_Full_Type_Declaration (Loc, Defining_Identifier => Ptr_Id, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => - Ekind (Obj_Typ) = E_General_Access_Type, - Subtype_Indication => New_Reference_To (Desig_Typ, Loc))); + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => + Ekind (Obj_Typ) = E_General_Access_Type, + Subtype_Indication => New_Reference_To (Desig_Typ, Loc))); - Insert_Action (Ins_Nod, Ptr_Decl); + Insert_Action (Ins_Node, Ptr_Decl); Analyze (Ptr_Decl); -- Step 2: Create a temporary which acts as a hook to the transient @@ -4384,16 +4498,16 @@ package body Exp_Ch4 is Defining_Identifier => Temp_Id, Object_Definition => New_Reference_To (Ptr_Id, Loc)); - Insert_Action (Ins_Nod, Temp_Decl); + Insert_Action (Ins_Node, Temp_Decl); Analyze (Temp_Decl); - -- Mark this temporary as created for the purposes of "exporting" the + -- Mark this temporary as created for the purposes of exporting the -- transient declaration out of the Actions list. This signals the -- machinery in Build_Finalizer to recognize this special case. Set_Return_Flag_Or_Transient_Decl (Temp_Id, Decl); - -- Step 3: "Hook" the transient object to the temporary + -- Step 3: Hook the transient object to the temporary if Is_Access_Type (Obj_Typ) then Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc)); @@ -4415,6 +4529,8 @@ package body Exp_Ch4 is Expression => Expr)); end Process_Transient_Object; + -- Local variables + Decl : Node_Id; -- Start of processing for Expand_N_Expression_With_Actions @@ -4955,6 +5071,124 @@ package body Exp_Ch4 is Rewrite (N, Cond); Analyze_And_Resolve (N, Restyp); end if; + + -- Ada 2012 (AI05-0149): Handle membership tests applied to an + -- expression of an anonymous access type. This can involve an + -- accessibility test and a tagged type membership test in the + -- case of tagged designated types. + + if Ada_Version >= Ada_2012 + and then Is_Acc + and then Ekind (Ltyp) = E_Anonymous_Access_Type + then + declare + Expr_Entity : Entity_Id := Empty; + New_N : Node_Id; + Param_Level : Node_Id; + Type_Level : Node_Id; + + begin + if Is_Entity_Name (Lop) then + Expr_Entity := Param_Entity (Lop); + + if not Present (Expr_Entity) then + Expr_Entity := Entity (Lop); + end if; + end if; + + -- If a conversion of the anonymous access value to the + -- tested type would be illegal, then the result is False. + + if not Valid_Conversion + (Lop, Rtyp, Lop, Report_Errs => False) + then + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + Analyze_And_Resolve (N, Restyp); + + -- Apply an accessibility check if the access object has an + -- associated access level and when the level of the type is + -- less deep than the level of the access parameter. This + -- only occur for access parameters and stand-alone objects + -- of an anonymous access type. + + else + if Present (Expr_Entity) + and then + Present + (Effective_Extra_Accessibility (Expr_Entity)) + and then UI_Gt (Object_Access_Level (Lop), + Type_Access_Level (Rtyp)) + then + Param_Level := + New_Occurrence_Of + (Effective_Extra_Accessibility (Expr_Entity), Loc); + + Type_Level := + Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); + + -- Return True only if the accessibility level of the + -- expression entity is not deeper than the level of + -- the tested access type. + + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => Make_Op_Le (Loc, + Left_Opnd => Param_Level, + Right_Opnd => Type_Level))); + + Analyze_And_Resolve (N); + end if; + + -- If the designated type is tagged, do tagged membership + -- operation. + + -- *** NOTE: we have to check not null before doing the + -- tagged membership test (but maybe that can be done + -- inside Tagged_Membership?). + + if Is_Tagged_Type (Typ) then + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Obj, + Right_Opnd => Make_Null (Loc)))); + + -- No expansion will be performed when VM_Target, as + -- the VM back-ends will handle the membership tests + -- directly (tags are not explicitly represented in + -- Java objects, so the normal tagged membership + -- expansion is not what we want). + + if Tagged_Type_Expansion then + + -- Note that we have to pass Original_Node, because + -- the membership test might already have been + -- rewritten by earlier parts of membership test. + + Tagged_Membership + (Original_Node (N), SCIL_Node, New_N); + + -- Update decoration of relocated node referenced + -- by the SCIL node. + + if Generate_SCIL and then Present (SCIL_Node) then + Set_SCIL_Node (New_N, SCIL_Node); + end if; + + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => New_N)); + + Analyze_And_Resolve (N, Restyp); + end if; + end if; + end if; + end; + end if; end; end if; @@ -6173,7 +6407,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 Alfa_Mode then return; end if; @@ -7139,10 +7373,9 @@ package body Exp_Ch4 is end; end if; - -- Only array types need any other processing. In formal verification - -- mode, no other processing is done. + -- Only array types need any other processing - if not Is_Array_Type (Typ) or else ALFA_Mode then + if not Is_Array_Type (Typ) then return; end if; @@ -7598,13 +7831,6 @@ package body Exp_Ch4 is Test : Node_Id; begin - -- Do not expand quantified expressions in ALFA mode - -- why not??? - - if ALFA_Mode then - return; - end if; - Decl := Make_Object_Declaration (Loc, Defining_Identifier => Tnn, @@ -7653,11 +7879,6 @@ package body Exp_Ch4 is Statements => New_List (Test), End_Label => Empty)); - -- The components of the scheme have already been analyzed, and the loop - -- parameter declaration has been processed. - - Set_Analyzed (Iteration_Scheme (Last (Actions))); - Rewrite (N, Make_Expression_With_Actions (Loc, Expression => New_Occurrence_Of (Tnn, Loc), @@ -7731,6 +7952,12 @@ package body Exp_Ch4 is -- Insert explicit dereference if required if Is_Access_Type (Ptyp) then + + -- First set prefix type to proper access type, in case it currently + -- has a private (non-access) view of this type. + + Set_Etype (P, Ptyp); + Insert_Explicit_Dereference (P); Analyze_And_Resolve (P, Designated_Type (Ptyp)); @@ -8163,6 +8390,10 @@ package body Exp_Ch4 is procedure Real_Range_Check; -- Handles generation of range check for real target value + function Has_Extra_Accessibility (Id : Entity_Id) return Boolean; + -- True iff Present (Effective_Extra_Accessibility (Id)) successfully + -- evaluates to True. + ----------------------------------- -- Handle_Changed_Representation -- ----------------------------------- @@ -8462,6 +8693,22 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Btyp); end Real_Range_Check; + ----------------------------- + -- Has_Extra_Accessibility -- + ----------------------------- + + -- Returns true for a formal of an anonymous access type or for + -- an Ada 2012-style stand-alone object of an anonymous access type. + + function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is + begin + if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then + return Present (Effective_Extra_Accessibility (Id)); + else + return False; + end if; + end Has_Extra_Accessibility; + -- Start of processing for Expand_N_Type_Conversion begin @@ -8620,13 +8867,7 @@ package body Exp_Ch4 is -- as tagged type checks). if Is_Entity_Name (Operand) - and then - (Is_Formal (Entity (Operand)) - or else - (Present (Renamed_Object (Entity (Operand))) - and then Is_Entity_Name (Renamed_Object (Entity (Operand))) - and then Is_Formal - (Entity (Renamed_Object (Entity (Operand)))))) + and then Has_Extra_Accessibility (Entity (Operand)) and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type and then (Nkind (Original_Node (N)) /= N_Attribute_Reference or else Attribute_Name (Original_Node (N)) = Name_Access) @@ -10909,6 +11150,15 @@ package body Exp_Ch4 is Left_Type := Available_View (Etype (Left)); Right_Type := Available_View (Etype (Right)); + -- In the case where the type is an access type, the test is applied + -- using the designated types (needed in Ada 2012 for implicit anonymous + -- access conversions, for AI05-0149). + + if Is_Access_Type (Right_Type) then + Left_Type := Designated_Type (Left_Type); + Right_Type := Designated_Type (Right_Type); + end if; + if Is_Class_Wide_Type (Left_Type) then Left_Type := Root_Type (Left_Type); end if; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 366140e9580..291d68e7b3e 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -62,17 +62,17 @@ with Validsw; use Validsw; package body Exp_Ch5 is function Change_Of_Representation (N : Node_Id) return Boolean; - -- Determine if the right hand side of the assignment N is a type - -- conversion which requires a change of representation. Called - -- only for the array and record cases. + -- Determine if the right hand side of assignment N is a type conversion + -- which requires a change of representation. Called only for the array + -- and record cases. procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id); -- N is an assignment which assigns an array value. This routine process -- the various special cases and checks required for such assignments, -- including change of representation. Rhs is normally simply the right - -- hand side of the assignment, except that if the right hand side is - -- a type conversion or a qualified expression, then the Rhs is the - -- actual expression inside any such type conversions or qualifications. + -- hand side of the assignment, except that if the right hand side is a + -- type conversion or a qualified expression, then the RHS is the actual + -- expression inside any such type conversions or qualifications. function Expand_Assign_Array_Loop (N : Node_Id; @@ -1788,9 +1788,8 @@ package body Exp_Ch5 is -- If the type is private without discriminants, and the full type -- has discriminants (necessarily with defaults) a check may still be - -- necessary if the Lhs is aliased. The private determinants must be + -- necessary if the Lhs is aliased. The private discriminants must be -- visible to build the discriminant constraints. - -- What is a "determinant"??? -- Only an explicit dereference that comes from source indicates -- aliasing. Access to formals of protected operations and entries @@ -1802,11 +1801,28 @@ package body Exp_Ch5 is and then Comes_From_Source (Lhs) then declare - Lt : constant Entity_Id := Etype (Lhs); + Lt : constant Entity_Id := Etype (Lhs); + Ubt : Entity_Id := Base_Type (Typ); + begin - Set_Etype (Lhs, Typ); - Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); - Apply_Discriminant_Check (Rhs, Typ, Lhs); + -- In the case of an expander-generated record subtype whose base + -- type still appears private, Typ will have been set to that + -- private type rather than the underlying record type (because + -- Underlying type will have returned the record subtype), so it's + -- necessary to apply Underlying_Type again to the base type to + -- get the record type we need for the discriminant check. Such + -- subtypes can be created for assignments in certain cases, such + -- as within an instantiation passed this kind of private type. + -- It would be good to avoid this special test, but making changes + -- to prevent this odd form of record subtype seems difficult. ??? + + if Is_Private_Type (Ubt) then + Ubt := Underlying_Type (Ubt); + end if; + + Set_Etype (Lhs, Ubt); + Rewrite (Rhs, OK_Convert_To (Base_Type (Ubt), Rhs)); + Apply_Discriminant_Check (Rhs, Ubt, Lhs); Set_Etype (Lhs, Lt); end; @@ -1885,6 +1901,71 @@ package body Exp_Ch5 is Apply_Constraint_Check (Rhs, Etype (Lhs)); end if; + -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a + -- stand-alone obj of an anonymous access type. + + if Is_Access_Type (Typ) + and then Is_Entity_Name (Lhs) + and then Present (Effective_Extra_Accessibility (Entity (Lhs))) then + declare + function Lhs_Entity return Entity_Id; + -- Look through renames to find the underlying entity. + -- For assignment to a rename, we don't care about the + -- Enclosing_Dynamic_Scope of the rename declaration. + + ---------------- + -- Lhs_Entity -- + ---------------- + + function Lhs_Entity return Entity_Id is + Result : Entity_Id := Entity (Lhs); + + begin + while Present (Renamed_Object (Result)) loop + + -- Renamed_Object must return an Entity_Name here + -- because of preceding "Present (E_E_A (...))" test. + + Result := Entity (Renamed_Object (Result)); + end loop; + + return Result; + end Lhs_Entity; + + -- Local Declarations + + Access_Check : constant Node_Id := + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Dynamic_Accessibility_Level (Rhs), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => + Scope_Depth + (Enclosing_Dynamic_Scope + (Lhs_Entity)))), + Reason => PE_Accessibility_Check_Failed); + + Access_Level_Update : constant Node_Id := + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of + (Effective_Extra_Accessibility + (Entity (Lhs)), Loc), + Expression => + Dynamic_Accessibility_Level (Rhs)); + + begin + if not Accessibility_Checks_Suppressed (Entity (Lhs)) then + Insert_Action (N, Access_Check); + end if; + + Insert_Action (N, Access_Level_Update); + end; + end if; + -- Case of assignment to a bit packed array element. If there is a -- change of representation this must be expanded into components, -- otherwise this is a bit-field assignment. @@ -2824,7 +2905,7 @@ package body Exp_Ch5 is Loc : constant Source_Ptr := Sloc (N); Container : constant Node_Id := Name (I_Spec); - Container_Typ : constant Entity_Id := Etype (Container); + Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); Cursor : Entity_Id; Iterator : Entity_Id; New_Loop : Node_Id; @@ -2891,14 +2972,17 @@ package body Exp_Ch5 is -- Processing for containers else - -- For an iterator of the form "Of" then name is some expression, - -- which is transformed into a call to the default iterator. + -- For an "of" iterator the name is a container expression, which + -- is transformed into a call to the default iterator. + + -- For an iterator of the form "in" the name is a function call + -- that delivers an iterator type. - -- For an iterator of the form "in" then name is a function call - -- that delivers an iterator. + -- In both cases, analysis of the iterator has introduced an object + -- declaration to capture the domain, so that Container is an entity. -- The for loop is expanded into a while loop which uses a container - -- specific cursor to examine each element. + -- specific cursor to desgnate each element. -- Iter : Iterator_Type := Container.Iterate; -- Cursor : Cursor_type := First (Iter); @@ -2906,7 +2990,7 @@ package body Exp_Ch5 is -- declare -- -- the block is added when Element_Type is controlled - -- Obj : Pack.Element_Type := Element (Iterator); + -- Obj : Pack.Element_Type := Element (Cursor); -- -- for the "of" loop form -- begin -- <original loop statements> @@ -2917,7 +3001,7 @@ package body Exp_Ch5 is -- If "reverse" is present, then the initialization of the cursor -- uses Last and the step becomes Prev. Pack is the name of the - -- package which instantiates the container. + -- scope where the container package is instantiated. declare Element_Type : constant Entity_Id := Etype (Id); @@ -2928,19 +3012,30 @@ package body Exp_Ch5 is Name_Step : Name_Id; begin - -- The type of the iterator is the return type of the Iterate -- function used. For the "of" form this is the default iterator -- for the type, otherwise it is the type of the explicit - -- function used in the loop. + -- function used in the iterator specification. The most common + -- case will be an Iterate function in the container package. - Iter_Type := Etype (Name (I_Spec)); + -- The primitive operations of the container type may not be + -- use-visible, so we introduce the name of the enclosing package + -- in the declarations below. The Iterator type is declared in a + -- an instance within the container package itself. - if Is_Entity_Name (Container) then - Pack := Scope (Etype (Container)); + -- If the container type is a derived type, the cursor type is + -- found in the package of the parent type. + if Is_Derived_Type (Container_Typ) then + Pack := Scope (Root_Type (Container_Typ)); else - Pack := Scope (Entity (Name (Container))); + Pack := Scope (Container_Typ); + end if; + + Iter_Type := Etype (Name (I_Spec)); + + if Is_Iterator (Iter_Type) then + Pack := Scope (Pack); end if; -- The "of" case uses an internally generated cursor whose type @@ -2982,8 +3077,6 @@ package body Exp_Ch5 is Container_Arg := New_Copy_Tree (Container); else - Pack := Scope (Default_Iter); - Container_Arg := Make_Type_Conversion (Loc, Subtype_Mark => @@ -3057,10 +3150,12 @@ package body Exp_Ch5 is end; -- X in Iterate (S) : type of iterator is type of explicitly - -- given Iterate function. + -- given Iterate function, and the loop variable is the cursor. + -- It will be assigned in the loop and must be a variable. else Cursor := Id; + Set_Ekind (Cursor, E_Variable); end if; Iterator := Make_Temporary (Loc, 'I'); @@ -3130,9 +3225,12 @@ package body Exp_Ch5 is End_Label => Empty); -- Create the declarations for Iterator and cursor and insert then - -- before the source loop. Generate: + -- before the source loop. Given that the domain of iteration is + -- already an entity, the iterator is just a renaming of that + -- entity. Possible optimization ??? + -- Generate: - -- I : Iterator_Type := Iterate (Container); + -- I : Iterator_Type renames Container; -- C : Pack.Cursor_Type := Container.[First | Last]; declare @@ -3141,11 +3239,12 @@ package body Exp_Ch5 is begin Decl1 := - Make_Object_Declaration (Loc, + Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Iterator, - Object_Definition => New_Occurrence_Of (Iter_Type, Loc), - Expression => Relocate_Node (Name (I_Spec))); - Set_Assignment_OK (Decl1); + Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), + Name => Relocate_Node (Name (I_Spec))); + + -- Create declaration for cursor Decl2 := Make_Object_Declaration (Loc, @@ -3160,8 +3259,7 @@ package body Exp_Ch5 is Set_Assignment_OK (Decl2); - Insert_Actions (N, - New_List (Decl1, Decl2)); + Insert_Actions (N, New_List (Decl1, Decl2)); end; -- The Iterator is not modified in the source, but of course will diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 8073ff568fd..75746422125 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -156,36 +156,6 @@ package body Exp_Ch6 is -- the values are not changed for the call, we know immediately that -- we have an infinite recursion. - procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id); - -- For each actual of an in-out or out parameter which is a numeric - -- (view) conversion of the form T (A), where A denotes a variable, - -- we insert the declaration: - -- - -- Temp : T[ := T (A)]; - -- - -- prior to the call. Then we replace the actual with a reference to Temp, - -- and append the assignment: - -- - -- A := TypeA (Temp); - -- - -- after the call. Here TypeA is the actual type of variable A. For out - -- parameters, the initial declaration has no expression. If A is not an - -- entity name, we generate instead: - -- - -- Var : TypeA renames A; - -- Temp : T := Var; -- omitting expression for out parameter. - -- ... - -- Var := TypeA (Temp); - -- - -- For other in-out parameters, we emit the required constraint checks - -- before and/or after the call. - -- - -- For all parameter modes, actuals that denote components and slices of - -- packed arrays are expanded into suitable temporaries. - -- - -- For non-scalar objects that are possibly unaligned, add call by copy - -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). - procedure Expand_Ctrl_Function_Call (N : Node_Id); -- N is a function call which returns a controlled object. Transform the -- call into a temporary which retrieves the returned object from the @@ -1201,10 +1171,49 @@ package body Exp_Ch6 is Set_Assignment_OK (Lhs); - Append_To (Post_Call, - Make_Assignment_Statement (Loc, - Name => Lhs, - Expression => Expr)); + if Is_Access_Type (E_Formal) + and then Is_Entity_Name (Lhs) + and then + Present (Effective_Extra_Accessibility (Entity (Lhs))) + then + -- Copyback target is an Ada 2012 stand-alone object + -- of an anonymous access type + + pragma Assert (Ada_Version >= Ada_2012); + + if Type_Access_Level (E_Formal) > + Object_Access_Level (Lhs) + then + Append_To (Post_Call, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + end if; + + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Expr)); + + -- We would like to somehow suppress generation of the + -- extra_accessibility assignment generated by the expansion + -- of the above assignment statement. It's not a correctness + -- issue because the following assignment renders it dead, + -- but generating back-to-back assignments to the same + -- target is undesirable. ??? + + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of ( + Effective_Extra_Accessibility (Entity (Lhs)), Loc), + Expression => Make_Integer_Literal (Loc, + Type_Access_Level (E_Formal)))); + + else + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Expr)); + end if; end; end if; end Add_Call_By_Copy_Code; @@ -2199,8 +2208,8 @@ 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???) - Formal := First_Formal (Subp); - Actual := First_Actual (Call_Node); + Formal := First_Formal (Subp); + Actual := First_Actual (Call_Node); Param_Count := 1; while Present (Formal) loop @@ -2226,7 +2235,7 @@ package body Exp_Ch6 is CW_Interface_Formals_Present or else (Ekind (Etype (Formal)) = E_Class_Wide_Type - and then Is_Interface (Etype (Etype (Formal)))) + and then Is_Interface (Etype (Etype (Formal)))) or else (Ekind (Etype (Formal)) = E_Anonymous_Access_Type and then Is_Interface (Directly_Designated_Type @@ -2406,8 +2415,7 @@ package body Exp_Ch6 is else Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => Type_Access_Level (Etype (Prev_Orig))), + (Dynamic_Accessibility_Level (Prev_Orig), Extra_Accessibility (Formal)); end if; @@ -2436,12 +2444,40 @@ package body Exp_Ch6 is -- For X'Access, pass on the level of the prefix X when Attribute_Access => - Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => - Object_Access_Level - (Prefix (Prev_Orig))), - Extra_Accessibility (Formal)); + + -- If this is an Access attribute applied to the + -- the current instance object passed to a type + -- initialization procedure, then use the level + -- of the type itself. This is not really correct, + -- as there should be an extra level parameter + -- passed in with _init formals (only in the case + -- where the type is immutably limited), but we + -- don't have an easy way currently to create such + -- an extra formal (init procs aren't ever frozen). + -- For now we just use the level of the type, + -- which may be too shallow, but that works better + -- than passing Object_Access_Level of the type, + -- which can be one level too deep in some cases. + -- ??? + + if Is_Entity_Name (Prefix (Prev_Orig)) + and then Is_Type (Entity (Prefix (Prev_Orig))) + then + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => + Type_Access_Level + (Entity (Prefix (Prev_Orig)))), + Extra_Accessibility (Formal)); + + else + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => + Object_Access_Level + (Prefix (Prev_Orig))), + Extra_Accessibility (Formal)); + end if; -- Treat the unchecked attributes as library-level @@ -2470,15 +2506,15 @@ package body Exp_Ch6 is Intval => Scope_Depth (Current_Scope) + 1), Extra_Accessibility (Formal)); - -- For other cases we simply pass the level of the actual's - -- access type. The type is retrieved from Prev rather than - -- Prev_Orig, because in some cases Prev_Orig denotes an - -- original expression that has not been analyzed. + -- For most other cases we simply pass the level of the + -- actual's access type. The type is retrieved from + -- Prev rather than Prev_Orig, because in some cases + -- Prev_Orig denotes an original expression that has + -- not been analyzed. when others => Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => Type_Access_Level (Etype (Prev))), + (Dynamic_Accessibility_Level (Prev), Extra_Accessibility (Formal)); end case; end if; @@ -2503,7 +2539,7 @@ package body Exp_Ch6 is and then Ekind (Formal) /= E_Out_Parameter and then Nkind (Prev) /= N_Raise_Constraint_Error and then (Known_Null (Prev) - or else not Can_Never_Be_Null (Etype (Prev))) + or else not Can_Never_Be_Null (Etype (Prev))) then Install_Null_Excluding_Check (Prev); end if; @@ -2549,10 +2585,10 @@ package body Exp_Ch6 is if Validity_Checks_On then if (Ekind (Formal) = E_In_Parameter - and then Validity_Check_In_Params) + and then Validity_Check_In_Params) or else (Ekind (Formal) = E_In_Out_Parameter - and then Validity_Check_In_Out_Params) + and then Validity_Check_In_Out_Params) then -- If the actual is an indexed component of a packed type (or -- is an indexed or selected component whose prefix recursively @@ -2580,6 +2616,15 @@ package body Exp_Ch6 is end if; end if; + -- For Ada 2012, if a parameter is aliased, the actual must be an + -- aliased object. + + if Is_Aliased (Formal) and then not Is_Aliased_View (Actual) then + Error_Msg_NE + ("actual for aliased formal& must be aliased object", + Actual, Formal); + end if; + -- For IN OUT and OUT parameters, ensure that subscripts are valid -- since this is a left side reference. We only do this for calls -- from the source program since we assume that compiler generated @@ -2631,9 +2676,7 @@ package body Exp_Ch6 is -- or IN OUT parameter! We do reset the Is_Known_Valid flag -- since the subprogram could have returned in invalid value. - if (Ekind (Formal) = E_Out_Parameter - or else - Ekind (Formal) = E_In_Out_Parameter) + if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) and then Is_Assignable (Ent) then Sav := Last_Assignment (Ent); @@ -4143,8 +4186,7 @@ package body Exp_Ch6 is -- code will have the same semantics. if Ekind (F) = E_In_Parameter - and then not Is_Limited_Type (Etype (A)) - and then not Is_Tagged_Type (Etype (A)) + and then not Is_By_Reference_Type (Etype (A)) and then (not Is_Array_Type (Etype (A)) or else not Is_Object_Reference (A) @@ -4153,9 +4195,9 @@ package body Exp_Ch6 is Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), - Expression => New_A); + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), + Expression => New_A); else Decl := Make_Object_Renaming_Declaration (Loc, @@ -4173,10 +4215,10 @@ package body Exp_Ch6 is end loop; -- Establish target of function call. If context is not assignment or - -- declaration, create a temporary as a target. The declaration for - -- the temporary may be subsequently optimized away if the body is a - -- single expression, or if the left-hand side of the assignment is - -- simple enough, i.e. an entity or an explicit dereference of one. + -- declaration, create a temporary as a target. The declaration for the + -- temporary may be subsequently optimized away if the body is a single + -- expression, or if the left-hand side of the assignment is simple + -- enough, i.e. an entity or an explicit dereference of one. if Ekind (Subp) = E_Function then if Nkind (Parent (N)) = N_Assignment_Statement @@ -6042,7 +6084,7 @@ package body Exp_Ch6 is Build_Protected_Subprogram_Call (N, Name => New_Occurrence_Of (Subp, Sloc (N)), - Rec => Convert_Concurrent (Rec, Etype (Rec)), + Rec => Convert_Concurrent (Rec, Etype (Rec)), External => True); else @@ -6737,6 +6779,18 @@ package body Exp_Ch6 is Function_Id : Entity_Id; begin + -- Return False when the expander is inactive, since awareness of + -- build-in-place treatment is only relevant during expansion. Note that + -- Is_Build_In_Place_Function, which is called as part of this function, + -- is also conditioned this way, but we need to check here as well to + -- avoid blowing up on processing protected calls when expansion is + -- disabled (such as with -gnatc) since those would trip over the raise + -- of Program_Error below. + + if not Expander_Active then + return False; + end if; + -- Step past qualification or unchecked conversion (the latter can occur -- in cases of calls to 'Input). @@ -6755,6 +6809,16 @@ package body Exp_Ch6 is elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then Function_Id := Etype (Name (Exp_Node)); + + -- In Alfa mode, protected subprogram calls are not expanded, so that + -- we may end up with a call that is neither resolved to an entity, + -- nor an indirect call. + + elsif Alfa_Mode then + return False; + + else + raise Program_Error; end if; return Is_Build_In_Place_Function (Function_Id); @@ -7536,54 +7600,26 @@ package body Exp_Ch6 is Result_Subt := Etype (Function_Id); - -- In the constrained case, add an implicit actual to the function call - -- that provides access to the declared object. An unchecked conversion - -- to the (specific) result type of the function is inserted to handle - -- the case where the object is declared with a class-wide type. - - if Is_Constrained (Underlying_Type (Result_Subt)) then - Caller_Object := - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Reference_To (Result_Subt, Loc), - Expression => New_Reference_To (Obj_Def_Id, Loc)); - - -- When the function has a controlling result, an allocation-form - -- parameter must be passed indicating that the caller is allocating - -- the result object. This is needed because such a function can be - -- called as a dispatching operation and must be treated similarly - -- to functions with unconstrained result subtypes. - - Add_Alloc_Form_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - - -- If the function's result subtype is unconstrained and the object is - -- a return object of an enclosing build-in-place function, then the - -- implicit build-in-place parameters of the enclosing function must be - -- passed along to the called function. (Unfortunately, this won't cover - -- the case of extension aggregates where the ancestor part is a build- - -- in-place unconstrained function call that should be passed along the - -- caller's parameters. Currently those get mishandled by reassigning - -- the result of the call to the aggregate return object, when the call - -- result should really be directly built in place in the aggregate and - -- not built in a temporary. ???) - - elsif Is_Return_Object (Defining_Identifier (Object_Decl)) then + -- If the the object is a return object of an enclosing build-in-place + -- function, then the implicit build-in-place parameters of the + -- enclosing function are simply passed along to the called function. + -- (Unfortunately, this won't cover the case of extension aggregates + -- where the ancestor part is a build-in-place unconstrained function + -- call that should be passed along the caller's parameters. Currently + -- those get mishandled by reassigning the result of the call to the + -- aggregate return object, when the call result should really be + -- directly built in place in the aggregate and not in a temporary. ???) + + if Is_Return_Object (Defining_Identifier (Object_Decl)) then Pass_Caller_Acc := True; Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); - -- If the enclosing function has a constrained result type, then - -- caller allocation will be used. + -- When the enclosing function has a BIP_Alloc_Form formal then we + -- pass it along to the callee (such as when the enclosing function + -- has an unconstrained or tagged result type). - if Is_Constrained (Etype (Enclosing_Func)) then - Add_Alloc_Form_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - - -- Otherwise, when the enclosing function has an unconstrained result - -- type, the BIP_Alloc_Form formal of the enclosing function must be - -- passed along to the callee. - - else + if Needs_BIP_Alloc_Form (Enclosing_Func) then Add_Alloc_Form_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, @@ -7591,6 +7627,13 @@ package body Exp_Ch6 is New_Reference_To (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form), Loc)); + + -- Otherwise, if enclosing function has a constrained result subtype, + -- then caller allocation will be used. + + else + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); end if; -- Retrieve the BIPacc formal from the enclosing function and convert @@ -7608,6 +7651,26 @@ package body Exp_Ch6 is (Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access), Loc)); + -- In the constrained case, add an implicit actual to the function call + -- that provides access to the declared object. An unchecked conversion + -- to the (specific) result type of the function is inserted to handle + -- the case where the object is declared with a class-wide type. + + elsif Is_Constrained (Underlying_Type (Result_Subt)) then + Caller_Object := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Result_Subt, Loc), + Expression => New_Reference_To (Obj_Def_Id, Loc)); + + -- When the function has a controlling result, an allocation-form + -- parameter must be passed indicating that the caller is allocating + -- the result object. This is needed because such a function can be + -- called as a dispatching operation and must be treated similarly + -- to functions with unconstrained result subtypes. + + Add_Alloc_Form_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); + -- In other unconstrained cases, pass an indication to do the allocation -- on the secondary stack and set Caller_Object to Empty so that a null -- value will be passed for the caller's object address. A transient @@ -7667,11 +7730,14 @@ package body Exp_Ch6 is -- The access type and its accompanying object must be inserted after -- the object declaration in the constrained case, so that the function -- call can be passed access to the object. In the unconstrained case, - -- the access type and object must be inserted before the object, since - -- the object declaration is rewritten to be a renaming of a dereference - -- of the access object. + -- or if the object declaration is for a return object, the access type + -- and object must be inserted before the object, since the object + -- declaration is rewritten to be a renaming of a dereference of the + -- access object. - if Is_Constrained (Underlying_Type (Result_Subt)) then + if Is_Constrained (Underlying_Type (Result_Subt)) + and then not Is_Return_Object (Defining_Identifier (Object_Decl)) + then Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl); else Insert_Action (Object_Decl, Ptr_Typ_Decl); @@ -7691,11 +7757,18 @@ package body Exp_Ch6 is Object_Definition => New_Reference_To (Ref_Type, Loc), Expression => New_Expr)); - if Is_Constrained (Underlying_Type (Result_Subt)) then + -- If the result subtype of the called function is constrained and + -- is not itself the return expression of an enclosing BIP function, + -- then mark the object as having no initialization. + + if Is_Constrained (Underlying_Type (Result_Subt)) + and then not Is_Return_Object (Defining_Identifier (Object_Decl)) + then Set_Expression (Object_Decl, Empty); Set_No_Initialization (Object_Decl); - -- In case of an unconstrained result subtype, rewrite the object + -- In case of an unconstrained result subtype, or if the call is the + -- return expression of an enclosing BIP function, rewrite the object -- declaration as an object renaming where the renamed object is a -- dereference of <function_Call>'reference: -- @@ -7787,4 +7860,15 @@ package body Exp_Ch6 is and then Needs_Finalization (Func_Typ); end Needs_BIP_Finalization_Master; + -------------------------- + -- Needs_BIP_Alloc_Form -- + -------------------------- + + function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is + pragma Assert (Is_Build_In_Place_Function (Func_Id)); + Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); + begin + return not Is_Constrained (Func_Typ) or else Is_Tagged_Type (Func_Typ); + end Needs_BIP_Alloc_Form; + end Exp_Ch6; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 1896ce21069..29dc27322d9 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -37,6 +37,36 @@ package Exp_Ch6 is procedure Expand_N_Subprogram_Body_Stub (N : Node_Id); procedure Expand_N_Subprogram_Declaration (N : Node_Id); + procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id); + -- For each actual of an in-out or out parameter which is a numeric + -- (view) conversion of the form T (A), where A denotes a variable, + -- we insert the declaration: + -- + -- Temp : T[ := T (A)]; + -- + -- prior to the call. Then we replace the actual with a reference to Temp, + -- and append the assignment: + -- + -- A := TypeA (Temp); + -- + -- after the call. Here TypeA is the actual type of variable A. For out + -- parameters, the initial declaration has no expression. If A is not an + -- entity name, we generate instead: + -- + -- Var : TypeA renames A; + -- Temp : T := Var; -- omitting expression for out parameter. + -- ... + -- Var := TypeA (Temp); + -- + -- For other in-out parameters, we emit the required constraint checks + -- before and/or after the call. + -- + -- For all parameter modes, actuals that denote components and slices of + -- packed arrays are expanded into suitable temporaries. + -- + -- For non-scalar objects that are possibly unaligned, add call by copy + -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). + procedure Expand_Call (N : Node_Id); -- This procedure contains common processing for Expand_N_Function_Call, -- Expand_N_Procedure_Statement, and Expand_N_Entry_Call. @@ -168,7 +198,11 @@ package Exp_Ch6 is -- node applied to such a function call. function Needs_BIP_Finalization_Master (Func_Id : Entity_Id) return Boolean; - -- Ada 2005 (AI-318-02): Return True if the function needs a finalization - -- master implicit parameter. + -- Ada 2005 (AI-318-02): Return True if the function needs an implicit + -- finalization master implicit parameter. + + function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean; + -- Ada 2005 (AI-318-02): Return True if the function needs an implicit + -- BIP_Alloc_Form parameter (see type BIP_Formal_Kind). end Exp_Ch6; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 730ac6b86dc..73ae23da94c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -434,21 +434,26 @@ package body Exp_Ch7 is Stmts => Make_Deep_Array_Body (Adjust_Case, Typ))); end if; - Set_TSS (Typ, - Make_Deep_Proc - (Prim => Finalize_Case, - Typ => Typ, - Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); + -- Do not generate Deep_Finalize and Finalize_Address if finalization is + -- suppressed since these routine will not be used. - -- Create TSS primitive Finalize_Address for non-VM targets. JVM and - -- .NET do not support address arithmetic and unchecked conversions. - - if VM_Target = No_VM then + if not Restriction_Active (No_Finalization) then Set_TSS (Typ, Make_Deep_Proc - (Prim => Address_Case, + (Prim => Finalize_Case, Typ => Typ, - Stmts => Make_Deep_Array_Body (Address_Case, Typ))); + Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); + + -- Create TSS primitive Finalize_Address for non-VM targets. JVM and + -- .NET do not support address arithmetic and unchecked conversions. + + if VM_Target = No_VM then + Set_TSS (Typ, + Make_Deep_Proc + (Prim => Address_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Address_Case, Typ))); + end if; end if; end Build_Array_Deep_Procs; @@ -706,36 +711,35 @@ package body Exp_Ch7 is ----------------------------- function Build_Exception_Handler - (Loc : Source_Ptr; - E_Id : Entity_Id; - Raised_Id : Entity_Id; + (Data : Finalization_Exception_Data; For_Library : Boolean := False) return Node_Id is Actuals : List_Id; Proc_To_Call : Entity_Id; begin - pragma Assert (Present (E_Id)); - pragma Assert (Present (Raised_Id)); + pragma Assert (Present (Data.E_Id)); + pragma Assert (Present (Data.Raised_Id)); -- Generate: -- Get_Current_Excep.all.all Actuals := New_List ( - Make_Explicit_Dereference (Loc, + Make_Explicit_Dereference (Data.Loc, Prefix => - Make_Function_Call (Loc, + Make_Function_Call (Data.Loc, Name => - Make_Explicit_Dereference (Loc, + Make_Explicit_Dereference (Data.Loc, Prefix => - New_Reference_To (RTE (RE_Get_Current_Excep), Loc))))); + New_Reference_To (RTE (RE_Get_Current_Excep), + Data.Loc))))); if For_Library and then not Restricted_Profile then Proc_To_Call := RTE (RE_Save_Library_Occurrence); else Proc_To_Call := RTE (RE_Save_Occurrence); - Prepend_To (Actuals, New_Reference_To (E_Id, Loc)); + Prepend_To (Actuals, New_Reference_To (Data.E_Id, Data.Loc)); end if; -- Generate: @@ -749,23 +753,23 @@ package body Exp_Ch7 is -- end if; return - Make_Exception_Handler (Loc, + Make_Exception_Handler (Data.Loc, Exception_Choices => - New_List (Make_Others_Choice (Loc)), + New_List (Make_Others_Choice (Data.Loc)), Statements => New_List ( - Make_If_Statement (Loc, + Make_If_Statement (Data.Loc, Condition => - Make_Op_Not (Loc, - Right_Opnd => New_Reference_To (Raised_Id, Loc)), + Make_Op_Not (Data.Loc, + Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)), Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => New_Reference_To (Raised_Id, Loc), - Expression => New_Reference_To (Standard_True, Loc)), + Make_Assignment_Statement (Data.Loc, + Name => New_Reference_To (Data.Raised_Id, Data.Loc), + Expression => New_Reference_To (Standard_True, Data.Loc)), - Make_Procedure_Call_Statement (Loc, + Make_Procedure_Call_Statement (Data.Loc, Name => - New_Reference_To (Proc_To_Call, Loc), + New_Reference_To (Proc_To_Call, Data.Loc), Parameter_Associations => Actuals))))); end Build_Exception_Handler; @@ -1047,21 +1051,14 @@ package body Exp_Ch7 is -- structures right from the start. Entities and lists are created once -- it has been established that N has at least one controlled object. - Abort_Id : Entity_Id := Empty; - -- Entity of local flag. The flag is set when finalization is triggered - -- by an abort. - Components_Built : Boolean := False; -- A flag used to avoid double initialization of entities and lists. If -- the flag is set then the following variables have been initialized: -- - -- Abort_Id -- Counter_Id - -- E_Id -- Finalizer_Decls -- Finalizer_Stmts -- Jump_Alts - -- Raised_Id Counter_Id : Entity_Id := Empty; Counter_Val : Int := 0; @@ -1071,9 +1068,8 @@ package body Exp_Ch7 is -- Declarative region of N (if available). If N is a package declaration -- Decls denotes the visible declarations. - E_Id : Entity_Id := Empty; - -- Entity of the local exception occurence. The first exception which - -- occurred during finalization is stored in E_Id and later reraised. + Finalizer_Data : Finalization_Exception_Data; + -- Data for the exception Finalizer_Decls : List_Id := No_List; -- Local variable declarations. This list holds the label declarations @@ -1135,10 +1131,6 @@ package body Exp_Ch7 is Priv_Decls : List_Id := No_List; -- The private declarations of N if N is a package declaration - Raised_Id : Entity_Id := Empty; - -- Entity for the raised flag. Along with E_Id, the flag is used in the - -- propagation of exceptions which occur during finalization. - Spec_Id : Entity_Id := Empty; Spec_Decls : List_Id := Top_Decls; Stmts : List_Id := No_List; @@ -1212,10 +1204,11 @@ package body Exp_Ch7 is Counter_Id := Make_Temporary (Loc, 'C'); Counter_Typ := Make_Temporary (Loc, 'T'); + Finalizer_Decls := New_List; + if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Build_Object_Declarations + (Finalizer_Data, Finalizer_Decls, Loc, For_Package); end if; -- Since the total number of controlled objects is always known, @@ -1275,7 +1268,6 @@ package body Exp_Ch7 is Analyze (Counter_Decl); end if; - Finalizer_Decls := New_List; Jump_Alts := New_List; end if; @@ -1437,7 +1429,7 @@ package body Exp_Ch7 is and then Exceptions_OK then Append_To (Finalizer_Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; -- Create the jump block which controls the finalization flow @@ -1528,14 +1520,6 @@ package body Exp_Ch7 is -- Abort_Undefer; -- Added if abort is allowed -- end Fin_Id; - if Has_Ctrl_Objs - and then Exceptions_OK - then - Prepend_List_To (Finalizer_Decls, - Build_Object_Declarations - (Loc, Abort_Id, E_Id, Raised_Id, For_Package)); - end if; - -- Create the body of the finalizer Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id)); @@ -2562,7 +2546,7 @@ package body Exp_Ch7 is Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id, For_Package))))); + (Finalizer_Data, For_Package))))); -- When exception handlers are prohibited, the finalization call -- appears unprotected. Any exception raised during finalization @@ -2935,27 +2919,29 @@ package body Exp_Ch7 is -- Build_Object_Declarations -- ------------------------------- - function Build_Object_Declarations - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id; - For_Package : Boolean := False) return List_Id + procedure Build_Object_Declarations + (Data : out Finalization_Exception_Data; + Decls : List_Id; + Loc : Source_Ptr; + For_Package : Boolean := False) is A_Expr : Node_Id; E_Decl : Node_Id; - Result : List_Id; begin + pragma Assert (Decls /= No_List); + if Restriction_Active (No_Exception_Propagation) then - return Empty_List; + Data.Abort_Id := Empty; + Data.E_Id := Empty; + Data.Raised_Id := Empty; + return; end if; - pragma Assert (Present (Abort_Id)); - pragma Assert (Present (E_Id)); - pragma Assert (Present (Raised_Id)); - - Result := New_List; + Data.Abort_Id := Make_Temporary (Loc, 'A'); + Data.E_Id := Make_Temporary (Loc, 'E'); + Data.Raised_Id := Make_Temporary (Loc, 'R'); + Data.Loc := Loc; -- In certain scenarios, finalization can be triggered by an abort. If -- the finalization itself fails and raises an exception, the resulting @@ -2985,9 +2971,9 @@ package body Exp_Ch7 is -- Generate: -- Abort_Id : constant Boolean := <A_Expr>; - Append_To (Result, + Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => Abort_Id, + Defining_Identifier => Data.Abort_Id, Constant_Present => True, Object_Definition => New_Reference_To (Standard_Boolean, Loc), Expression => A_Expr)); @@ -2997,23 +2983,21 @@ package body Exp_Ch7 is E_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => E_Id, + Defining_Identifier => Data.E_Id, Object_Definition => New_Reference_To (RTE (RE_Exception_Occurrence), Loc)); Set_No_Initialization (E_Decl); - Append_To (Result, E_Decl); + Append_To (Decls, E_Decl); -- Generate: -- Raised_Id : Boolean := False; - Append_To (Result, + Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => Raised_Id, + Defining_Identifier => Data.Raised_Id, Object_Definition => New_Reference_To (Standard_Boolean, Loc), Expression => New_Reference_To (Standard_False, Loc))); - - return Result; end Build_Object_Declarations; --------------------------- @@ -3021,10 +3005,7 @@ package body Exp_Ch7 is --------------------------- function Build_Raise_Statement - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id) return Node_Id + (Data : Finalization_Exception_Data) return Node_Id is Stmt : Node_Id; @@ -3034,12 +3015,12 @@ package body Exp_Ch7 is if RTE_Available (RE_Raise_From_Controlled_Operation) then Stmt := - Make_Procedure_Call_Statement (Loc, + Make_Procedure_Call_Statement (Data.Loc, Name => New_Reference_To - (RTE (RE_Raise_From_Controlled_Operation), Loc), + (RTE (RE_Raise_From_Controlled_Operation), Data.Loc), Parameter_Associations => - New_List (New_Reference_To (E_Id, Loc))); + New_List (New_Reference_To (Data.E_Id, Data.Loc))); -- Restricted runtime: exception messages are not supported and hence -- Raise_From_Controlled_Operation is not supported. Raise Program_Error @@ -3047,7 +3028,7 @@ package body Exp_Ch7 is else Stmt := - Make_Raise_Program_Error (Loc, + Make_Raise_Program_Error (Data.Loc, Reason => PE_Finalize_Raised_Exception); end if; @@ -3059,13 +3040,13 @@ package body Exp_Ch7 is -- end if; return - Make_If_Statement (Loc, + Make_If_Statement (Data.Loc, Condition => - Make_And_Then (Loc, - Left_Opnd => New_Reference_To (Raised_Id, Loc), + Make_And_Then (Data.Loc, + Left_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc), Right_Opnd => - Make_Op_Not (Loc, - Right_Opnd => New_Reference_To (Abort_Id, Loc))), + Make_Op_Not (Data.Loc, + Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc))), Then_Statements => New_List (Stmt)); end Build_Raise_Statement; @@ -3090,21 +3071,26 @@ package body Exp_Ch7 is Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); end if; - Set_TSS (Typ, - Make_Deep_Proc - (Prim => Finalize_Case, - Typ => Typ, - Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); - - -- Create TSS primitive Finalize_Address for non-VM targets. JVM and - -- .NET do not support address arithmetic and unchecked conversions. + -- Do not generate Deep_Finalize and Finalize_Address if finalization is + -- suppressed since these routine will not be used. - if VM_Target = No_VM then + if not Restriction_Active (No_Finalization) then Set_TSS (Typ, Make_Deep_Proc - (Prim => Address_Case, + (Prim => Finalize_Case, Typ => Typ, - Stmts => Make_Deep_Record_Body (Address_Case, Typ))); + Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); + + -- Create TSS primitive Finalize_Address for non-VM targets. JVM and + -- .NET do not support address arithmetic and unchecked conversions. + + if VM_Target = No_VM then + Set_TSS (Typ, + Make_Deep_Proc + (Prim => Address_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Address_Case, Typ))); + end if; end if; end Build_Record_Deep_Procs; @@ -3504,7 +3490,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 Alfa_Mode and then Nkind (Wrap_Node) = N_Pragma and then Get_Pragma_Id (Wrap_Node) = Pragma_Check then @@ -4212,18 +4198,23 @@ package body Exp_Ch7 is Last_Object : Node_Id; Related_Node : Node_Id) is - Abort_Id : Entity_Id; + Requires_Hooking : constant Boolean := + Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement); + Built : Boolean := False; - Desig : Entity_Id; - E_Id : Entity_Id; + Desig_Typ : Entity_Id; Fin_Block : Node_Id; + Fin_Data : Finalization_Exception_Data; + Fin_Decls : List_Id; Last_Fin : Node_Id := Empty; Loc : Source_Ptr; Obj_Id : Entity_Id; Obj_Ref : Node_Id; Obj_Typ : Entity_Id; - Raised_Id : Entity_Id; Stmt : Node_Id; + Stmts : List_Id; + Temp_Id : Entity_Id; begin -- Examine all objects in the list First_Object .. Last_Object @@ -4239,35 +4230,140 @@ package body Exp_Ch7 is and then Stmt /= Related_Node then - Loc := Sloc (Stmt); - Obj_Id := Defining_Identifier (Stmt); - Obj_Typ := Base_Type (Etype (Obj_Id)); - Desig := Obj_Typ; + Loc := Sloc (Stmt); + Obj_Id := Defining_Identifier (Stmt); + Obj_Typ := Base_Type (Etype (Obj_Id)); + Desig_Typ := Obj_Typ; Set_Is_Processed_Transient (Obj_Id); -- Handle access types - if Is_Access_Type (Desig) then - Desig := Available_View (Designated_Type (Desig)); + if Is_Access_Type (Desig_Typ) then + Desig_Typ := Available_View (Designated_Type (Desig_Typ)); end if; -- Create the necessary entities and declarations the first -- time around. if not Built then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Fin_Decls := New_List; - Insert_List_Before_And_Analyze (First_Object, - Build_Object_Declarations - (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Object_Declarations (Fin_Data, Fin_Decls, Loc); + Insert_List_Before_And_Analyze (First_Object, Fin_Decls); Built := True; end if; + -- Transient variables associated with subprogram calls need + -- extra processing. These variables are usually created right + -- before the call and finalized immediately after the call. + -- If an exception occurs during the call, the clean up code + -- is skipped due to the sudden change in control and the + -- transient is never finalized. + + -- To handle this case, such variables are "exported" to the + -- enclosing sequence of statements where their corresponding + -- "hooks" are picked up by the finalization machinery. + + if Requires_Hooking then + declare + Expr : Node_Id; + Ptr_Id : Entity_Id; + + begin + -- Step 1: Create an access type which provides a + -- reference to the transient object. Generate: + + -- Ann : access [all] <Desig_Typ>; + + Ptr_Id := Make_Temporary (Loc, 'A'); + + Insert_Action (Stmt, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Id, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => + Ekind (Obj_Typ) = E_General_Access_Type, + Subtype_Indication => + New_Reference_To (Desig_Typ, Loc)))); + + -- Step 2: Create a temporary which acts as a hook to + -- the transient object. Generate: + + -- Temp : Ptr_Id := null; + + Temp_Id := Make_Temporary (Loc, 'T'); + + Insert_Action (Stmt, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Object_Definition => + New_Reference_To (Ptr_Id, Loc))); + + -- Mark the temporary as a transient hook. This signals + -- the machinery in Build_Finalizer to recognize this + -- special case. + + Set_Return_Flag_Or_Transient_Decl (Temp_Id, Stmt); + + -- Step 3: Hook the transient object to the temporary + + if Is_Access_Type (Obj_Typ) then + Expr := + Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc)); + else + Expr := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Obj_Id, Loc), + Attribute_Name => Name_Unrestricted_Access); + end if; + + -- Generate: + -- Temp := Ptr_Id (Obj_Id); + -- <or> + -- Temp := Obj_Id'Unrestricted_Access; + + Insert_After_And_Analyze (Stmt, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Temp_Id, Loc), + Expression => Expr)); + end; + end if; + + Stmts := New_List; + + -- The transient object is about to be finalized by the clean + -- up code following the subprogram call. In order to avoid + -- double finalization, clear the hook. + -- Generate: + -- Temp := null; + + if Requires_Hooking then + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (Temp_Id, Loc), + Expression => Make_Null (Loc))); + end if; + + -- Generate: + -- [Deep_]Finalize (Obj_Ref); + + Obj_Ref := New_Reference_To (Obj_Id, Loc); + + if Is_Access_Type (Obj_Typ) then + Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); + end if; + + Append_To (Stmts, + Make_Final_Call + (Obj_Ref => Obj_Ref, + Typ => Desig_Typ)); + + -- Generate: + -- [Temp := null;] -- begin -- [Deep_]Finalize (Obj_Ref); @@ -4280,23 +4376,14 @@ package body Exp_Ch7 is -- end if; -- end; - Obj_Ref := New_Reference_To (Obj_Id, Loc); - - if Is_Access_Type (Obj_Typ) then - Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); - end if; - Fin_Block := Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Final_Call - (Obj_Ref => Obj_Ref, - Typ => Desig)), - + Statements => Stmts, Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Fin_Data)))); + Insert_After_And_Analyze (Last_Object, Fin_Block); -- The raise statement must be inserted after all the @@ -4361,7 +4448,7 @@ package body Exp_Ch7 is and then Present (Last_Fin) then Insert_After_And_Analyze (Last_Fin, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Fin_Data)); end if; end Process_Transient_Objects; @@ -4750,20 +4837,19 @@ package body Exp_Ch7 is function Build_Adjust_Or_Finalize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); - Abort_Id : Entity_Id := Empty; - Call : Node_Id; - Comp_Ref : Node_Id; - Core_Loop : Node_Id; - Dim : Int; - E_Id : Entity_Id := Empty; - J : Entity_Id; - Loop_Id : Entity_Id; - Raised_Id : Entity_Id := Empty; - Stmts : List_Id; + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); + Finalizer_Decls : List_Id := No_List; + Finalizer_Data : Finalization_Exception_Data; + Call : Node_Id; + Comp_Ref : Node_Id; + Core_Loop : Node_Id; + Dim : Int; + J : Entity_Id; + Loop_Id : Entity_Id; + Stmts : List_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -4792,9 +4878,8 @@ package body Exp_Ch7 is Build_Indices; if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; Comp_Ref := @@ -4838,7 +4923,7 @@ package body Exp_Ch7 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Call), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); else Core_Loop := Call; end if; @@ -4902,14 +4987,14 @@ package body Exp_Ch7 is if Exceptions_OK then Append_To (Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts))); end Build_Adjust_Or_Finalize_Statements; @@ -4919,24 +5004,23 @@ package body Exp_Ch7 is --------------------------------- function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Final_List : constant List_Id := New_List; - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); - Abort_Id : Entity_Id; - Counter_Id : Entity_Id; - Dim : Int; - E_Id : Entity_Id := Empty; - F : Node_Id; - Fin_Stmt : Node_Id; - Final_Block : Node_Id; - Final_Loop : Node_Id; - Init_Loop : Node_Id; - J : Node_Id; - Loop_Id : Node_Id; - Raised_Id : Entity_Id := Empty; - Stmts : List_Id; + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Final_List : constant List_Id := New_List; + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); + Counter_Id : Entity_Id; + Dim : Int; + F : Node_Id; + Fin_Stmt : Node_Id; + Final_Block : Node_Id; + Final_Loop : Node_Id; + Finalizer_Data : Finalization_Exception_Data; + Finalizer_Decls : List_Id := No_List; + Init_Loop : Node_Id; + J : Node_Id; + Loop_Id : Node_Id; + Stmts : List_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -5071,9 +5155,8 @@ package body Exp_Ch7 is Counter_Id := Make_Temporary (Loc, 'C'); if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; -- Generate the block which houses the finalization call, the index @@ -5102,7 +5185,7 @@ package body Exp_Ch7 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Build_Finalization_Call), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); else Fin_Stmt := Build_Finalization_Call; end if; @@ -5194,14 +5277,14 @@ package body Exp_Ch7 is if Exceptions_OK then Append_To (Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); Append_To (Stmts, Make_Raise_Statement (Loc)); end if; Final_Block := Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); @@ -5573,14 +5656,13 @@ package body Exp_Ch7 is ----------------------------- function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); - Abort_Id : Entity_Id := Empty; - Bod_Stmts : List_Id; - E_Id : Entity_Id := Empty; - Raised_Id : Entity_Id := Empty; - Rec_Def : Node_Id; - Var_Case : Node_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Bod_Stmts : List_Id; + Finalizer_Data : Finalization_Exception_Data; + Finalizer_Decls : List_Id := No_List; + Rec_Def : Node_Id; + Var_Case : Node_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -5644,7 +5726,7 @@ package body Exp_Ch7 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); end if; Append_To (Stmts, Adj_Stmt); @@ -5782,9 +5864,8 @@ package body Exp_Ch7 is begin if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; if Nkind (Typ_Def) = N_Derived_Type_Definition then @@ -5881,7 +5962,7 @@ package body Exp_Ch7 is Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Prepend_To (Bod_Stmts, Adj_Stmt); @@ -5932,7 +6013,7 @@ package body Exp_Ch7 is Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Append_To (Bod_Stmts, @@ -5971,14 +6052,14 @@ package body Exp_Ch7 is else if Exceptions_OK then Append_To (Bod_Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); end if; @@ -5989,15 +6070,14 @@ package body Exp_Ch7 is ------------------------------- function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); - Abort_Id : Entity_Id := Empty; - Bod_Stmts : List_Id; - Counter : Int := 0; - E_Id : Entity_Id := Empty; - Raised_Id : Entity_Id := Empty; - Rec_Def : Node_Id; - Var_Case : Node_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Bod_Stmts : List_Id; + Counter : Int := 0; + Finalizer_Data : Finalization_Exception_Data; + Finalizer_Decls : List_Id := No_List; + Rec_Def : Node_Id; + Var_Case : Node_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -6130,7 +6210,7 @@ package body Exp_Ch7 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); end if; Append_To (Stmts, Fin_Stmt); @@ -6362,9 +6442,8 @@ package body Exp_Ch7 is begin if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; if Nkind (Typ_Def) = N_Derived_Type_Definition then @@ -6463,7 +6542,7 @@ package body Exp_Ch7 is Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Append_To (Bod_Stmts, Fin_Stmt); @@ -6516,7 +6595,7 @@ package body Exp_Ch7 is Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Prepend_To (Bod_Stmts, @@ -6553,14 +6632,14 @@ package body Exp_Ch7 is else if Exceptions_OK then Append_To (Bod_Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); end if; diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index dbebd8ae52a..8ea71916e26 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -40,10 +40,40 @@ package Exp_Ch7 is -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize -- that take care of finalization management at run-time. + -- Support of exceptions from user finalization procedures + + -- There is a specific mechanism to handle these exceptions, continue + -- finalization and then raise PE. This mechanism is used by this package + -- but also by exp_intr for Ada.Unchecked_Deallocation. + + -- There are 3 subprograms to use this mechanism, and the type + -- Finalization_Exception_Data carries internal data between these + -- subprograms: + -- + -- 1. Build_Object_Declaration: create the variables for the next two + -- subprograms. + -- 2. Build_Exception_Handler: create the exception handler for a call + -- to a user finalization procedure. + -- 3. Build_Raise_Stmt: create code to potentially raise a PE exception + -- if an exception was raise in a user finalization procedure. + + type Finalization_Exception_Data is record + Loc : Source_Ptr; + -- Sloc for the added nodes + + Abort_Id : Entity_Id; + -- Boolean variable set to true if the finalization was triggered by + -- an abort. + + E_Id : Entity_Id; + -- Variable containing the exception occurrence raised by user code + + Raised_Id : Entity_Id; + -- Boolean variable set to true if an exception was raised in user code + end record; + function Build_Exception_Handler - (Loc : Source_Ptr; - E_Id : Entity_Id; - Raised_Id : Entity_Id; + (Data : Finalization_Exception_Data; For_Library : Boolean := False) return Node_Id; -- Subsidiary to Build_Finalizer, Make_Deep_Array_Body and Make_Deep_Record -- _Body. Create an exception handler of the following form: @@ -84,15 +114,14 @@ package Exp_Ch7 is -- Build one controlling procedure when a late body overrides one of -- the controlling operations. - function Build_Object_Declarations - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id; - For_Package : Boolean := False) return List_Id; - -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Return a - -- list containing the object declarations of boolean flag Abort_Id, the - -- exception occurrence E_Id and boolean flag Raised_Id. + procedure Build_Object_Declarations + (Data : out Finalization_Exception_Data; + Decls : List_Id; + Loc : Source_Ptr; + For_Package : Boolean := False); + -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Create the + -- list List containing the object declarations of boolean flag Abort_Id, + -- the exception occurrence E_Id and boolean flag Raised_Id. -- -- Abort_Id : constant Boolean := -- Exception_Identity (Get_Current_Excep.all) = @@ -104,10 +133,7 @@ package Exp_Ch7 is -- Raised_Id : Boolean := False; function Build_Raise_Statement - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id) return Node_Id; + (Data : Finalization_Exception_Data) return Node_Id; -- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_ -- Deep_Record_Body. Generate the following conditional raise statement: -- diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 57193cbf74f..3d0652232cb 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -2263,14 +2263,40 @@ package body Exp_Ch9 is end loop Search; end if; - -- If the subprogram to be wrapped is not overriding anything or is not - -- a primitive declared between two views, do not produce anything. This - -- avoids spurious errors involving overriding. + -- Ada 2012 (AI05-0090-1): If no interface primitive is covered by + -- this subprogram and this is not a primitive declared between two + -- views then force the generation of a wrapper. As an optimization, + -- previous versions of the frontend avoid generating the wrapper; + -- however, the wrapper facilitates locating and reporting an error + -- when a duplicate declaration is found later. See example in + -- AI05-0090-1. if No (First_Param) and then not Is_Private_Primitive_Subprogram (Subp_Id) then - return Empty; + if Is_Task_Type + (Corresponding_Concurrent_Type (Obj_Typ)) + then + First_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), + In_Present => True, + Out_Present => False, + Parameter_Type => New_Reference_To (Obj_Typ, Loc)); + + -- For entries and procedures of protected types the mode of + -- the controlling argument must be in-out. + + else + First_Param := + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Name_uO), + In_Present => True, + Out_Present => (Ekind (Subp_Id) /= E_Function), + Parameter_Type => New_Reference_To (Obj_Typ, Loc)); + end if; end if; declare @@ -4878,13 +4904,7 @@ package body Exp_Ch9 is Ldecl2 : Node_Id; begin - -- In formal verification mode, do not expand tasking constructs - - if ALFA_Mode then - return; - end if; - - if Expander_Active then + if Full_Expander_Active then -- If we have no handled statement sequence, we may need to build -- a dummy sequence consisting of a null statement. This can be @@ -4896,7 +4916,7 @@ package body Exp_Ch9 is then Set_Handled_Statement_Sequence (N, Make_Handled_Sequence_Of_Statements (Loc, - New_List (Make_Null_Statement (Loc)))); + Statements => New_List (Make_Null_Statement (Loc)))); end if; -- Create and declare two labels to be placed at the end of the @@ -5206,7 +5226,7 @@ package body Exp_Ch9 is -- barrier just as a protected function, and discard the protected -- version of it because it is never called. - if Expander_Active then + if Full_Expander_Active then B_F := Build_Barrier_Function (N, Ent, Prot); Func := Barrier_Function (Ent); Set_Corresponding_Spec (B_F, Func); @@ -5244,7 +5264,7 @@ package body Exp_Ch9 is -- condition does not reference any of the generated renamings -- within the function. - if Expander_Active + if Full_Expander_Active and then Scope (Entity (Cond)) /= Func then Set_Declarations (B_F, Empty_List); @@ -5296,12 +5316,6 @@ package body Exp_Ch9 is Tasknm : Node_Id; begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - Aggr := Make_Aggregate (Loc, Component_Associations => New_List); Count := 0; @@ -5433,12 +5447,6 @@ package body Exp_Ch9 is -- Start of processing for Expand_N_Accept_Statement begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - -- If accept statement is not part of a list, then its parent must be -- an accept alternative, and, as described above, we do not do any -- expansion for such accept statements at this level. @@ -5889,12 +5897,6 @@ package body Exp_Ch9 is T : Entity_Id; -- Additional status flag begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - Process_Statements_For_Controlled_Objects (Trig); Process_Statements_For_Controlled_Objects (Abrt); @@ -6844,12 +6846,6 @@ package body Exp_Ch9 is S : Entity_Id; -- Primitive operation slot begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - Process_Statements_For_Controlled_Objects (N); if Ada_Version >= Ada_2005 @@ -7166,12 +7162,6 @@ package body Exp_Ch9 is procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - Rewrite (N, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RO_CA_Delay_For), Loc), @@ -7191,12 +7181,6 @@ package body Exp_Ch9 is Typ : Entity_Id; begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then Typ := RTE (RO_CA_Delay_Until); else @@ -7217,12 +7201,6 @@ package body Exp_Ch9 is procedure Expand_N_Entry_Body (N : Node_Id) is begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - -- Associate discriminals with the next protected operation body to be -- expanded. @@ -7244,12 +7222,6 @@ package body Exp_Ch9 is Index : Node_Id; begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - if No_Run_Time_Mode then Error_Msg_CRT ("entry call", N); return; @@ -7306,12 +7278,6 @@ package body Exp_Ch9 is Acc_Ent : Entity_Id; begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - Formal := First_Formal (Entry_Ent); Last_Decl := N; @@ -7580,12 +7546,6 @@ package body Exp_Ch9 is -- Start of processing for Expand_N_Protected_Body begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - if No_Run_Time_Mode then Error_Msg_CRT ("protected body", N); return; @@ -9138,12 +9098,6 @@ package body Exp_Ch9 is -- Start of processing for Expand_N_Requeue_Statement begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - -- Extract the components of the entry call Extract_Entry (N, Concval, Ename, Index); @@ -9730,12 +9684,6 @@ package body Exp_Ch9 is -- Start of processing for Expand_N_Selective_Accept begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - Process_Statements_For_Controlled_Objects (N); -- First insert some declarations before the select. The first is: @@ -10366,12 +10314,6 @@ package body Exp_Ch9 is -- Used to determine the proper location of wrapper body insertions begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - -- Add renaming declarations for discriminals and a declaration for the -- entry family index (if applicable). @@ -10480,12 +10422,14 @@ package body Exp_Ch9 is -- values of this task. The general form of this type declaration is -- type taskV (discriminants) is record - -- _Task_Id : Task_Id; - -- entry_family : array (bounds) of Void; - -- _Priority : Integer := priority_expression; - -- _Size : Size_Type := Size_Type (size_expression); - -- _Task_Info : Task_Info_Type := task_info_expression; - -- _CPU : Integer := cpu_range_expression; + -- _Task_Id : Task_Id; + -- entry_family : array (bounds) of Void; + -- _Priority : Integer := priority_expression; + -- _Size : Size_Type := size_expression; + -- _Task_Info : Task_Info_Type := task_info_expression; + -- _CPU : Integer := cpu_range_expression; + -- _Relative_Deadline : Time_Span := time_span_expression; + -- _Domain : Dispatching_Domain := dd_expression; -- end record; -- The discriminants are present only if the corresponding task type has @@ -10529,6 +10473,11 @@ package body Exp_Ch9 is -- argument that was present in the pragma, and is used to provide the -- Relative_Deadline parameter to the call to Create_Task. + -- The _Domain field is present only if a Dispatching_Domain pragma or + -- aspect appears in the task definition. The expression captures the + -- argument that was present in the pragma or aspect, and is used to + -- provide the Dispatching_Domain parameter to the call to Create_Task. + -- When a task is declared, an instance of the task value record is -- created. The elaboration of this declaration creates the correct bounds -- for the entry families, and also evaluates the size, priority, and @@ -10891,6 +10840,37 @@ package body Exp_Ch9 is (Taskdef, Name_Relative_Deadline)))))))); end if; + -- Add the _Dispatching_Domain component if a Dispatching_Domain pragma + -- or aspect is present. If we are using a restricted run time this + -- component will not be added (dispatching domains are not allowed by + -- the Ravenscar profile). + + if not Restricted_Profile + and then Present (Taskdef) + and then Has_Pragma_Dispatching_Domain (Taskdef) + then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uDispatching_Domain), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Reference_To + (RTE (RE_Dispatching_Domain_Access), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Dispatching_Domain_Access), + Relocate_Node + (Expression + (First + (Pragma_Argument_Associations + (Find_Task_Or_Protected_Pragma + (Taskdef, Name_Dispatching_Domain)))))))); + end if; + Insert_After (Size_Decl, Rec_Decl); -- Analyze the record declaration immediately after construction, @@ -11118,12 +11098,6 @@ package body Exp_Ch9 is S : Entity_Id; -- Primitive operation slot begin - -- Do not expand tasking constructs in formal verification mode - - if ALFA_Mode then - return; - end if; - -- Under the Ravenscar profile, timed entry calls are excluded. An error -- was already reported on spec, so do not attempt to expand the call. @@ -11194,10 +11168,8 @@ package body Exp_Ch9 is Prepend_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - B, - Object_Definition => - New_Reference_To (Standard_Boolean, Loc))); + Defining_Identifier => B, + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); end if; -- Duration and mode processing @@ -11213,15 +11185,19 @@ package body Exp_Ch9 is elsif Is_RTE (D_Type, RO_CA_Time) then D_Disc := Make_Integer_Literal (Loc, 1); - D_Conv := Make_Function_Call (Loc, - New_Reference_To (RTE (RO_CA_To_Duration), Loc), - New_List (New_Copy (Expression (D_Stat)))); + D_Conv := + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RO_CA_To_Duration), Loc), + Parameter_Associations => + New_List (New_Copy (Expression (D_Stat)))); else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); D_Disc := Make_Integer_Literal (Loc, 2); - D_Conv := Make_Function_Call (Loc, - New_Reference_To (RTE (RO_RT_To_Duration), Loc), - New_List (New_Copy (Expression (D_Stat)))); + D_Conv := + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RO_RT_To_Duration), Loc), + Parameter_Associations => + New_List (New_Copy (Expression (D_Stat)))); end if; D := Make_Temporary (Loc, 'D'); @@ -11231,10 +11207,8 @@ package body Exp_Ch9 is Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - D, - Object_Definition => - New_Reference_To (Standard_Duration, Loc))); + Defining_Identifier => D, + Object_Definition => New_Reference_To (Standard_Duration, Loc))); M := Make_Temporary (Loc, 'M'); @@ -11243,22 +11217,17 @@ package body Exp_Ch9 is Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - M, - Object_Definition => - New_Reference_To (Standard_Integer, Loc), - Expression => - D_Disc)); + Defining_Identifier => M, + Object_Definition => New_Reference_To (Standard_Integer, Loc), + Expression => D_Disc)); -- Do the assignment at this stage only because the evaluation of the -- expression must not occur before (see ACVC C97302A). Append_To (Stmts, Make_Assignment_Statement (Loc, - Name => - New_Reference_To (D, Loc), - Expression => - D_Conv)); + Name => New_Reference_To (D, Loc), + Expression => D_Conv)); -- Parameter block processing @@ -11275,8 +11244,8 @@ package body Exp_Ch9 is K := Build_K (Loc, Decls, Obj); Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); - P := Parameter_Block_Pack - (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); + P := + Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); -- Dispatch table slot processing, generate: -- S : Integer; @@ -11302,9 +11271,10 @@ package body Exp_Ch9 is Append_To (Params, New_Copy_Tree (Obj)); Append_To (Params, New_Reference_To (S, Loc)); - Append_To (Params, Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (P, Loc), - Attribute_Name => Name_Address)); + Append_To (Params, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P, Loc), + Attribute_Name => Name_Address)); Append_To (Params, New_Reference_To (D, Loc)); Append_To (Params, New_Reference_To (M, Loc)); Append_To (Params, New_Reference_To (C, Loc)); @@ -11313,12 +11283,10 @@ package body Exp_Ch9 is Append_To (Conc_Typ_Stmts, Make_Procedure_Call_Statement (Loc, Name => - New_Reference_To ( - Find_Prim_Op (Etype (Etype (Obj)), - Name_uDisp_Timed_Select), - Loc), - Parameter_Associations => - Params)); + New_Reference_To + (Find_Prim_Op + (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc), + Parameter_Associations => Params)); -- Generate: -- if C = POK_Protected_Entry @@ -11338,24 +11306,22 @@ package body Exp_Ch9 is Append_To (Conc_Typ_Stmts, Make_If_Statement (Loc, - Condition => + Condition => Make_Or_Else (Loc, - Left_Opnd => + Left_Opnd => Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (C, Loc), + Left_Opnd => New_Reference_To (C, Loc), Right_Opnd => - New_Reference_To (RTE ( - RE_POK_Protected_Entry), Loc)), + New_Reference_To + (RTE (RE_POK_Protected_Entry), Loc)), + Right_Opnd => Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (C, Loc), + Left_Opnd => New_Reference_To (C, Loc), Right_Opnd => New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), - Then_Statements => - Unpack)); + Then_Statements => Unpack)); end if; -- Generate: @@ -11381,33 +11347,30 @@ package body Exp_Ch9 is Make_Or_Else (Loc, Left_Opnd => Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (C, Loc), + Left_Opnd => New_Reference_To (C, Loc), Right_Opnd => New_Reference_To (RTE (RE_POK_Procedure), Loc)), + Right_Opnd => Make_Or_Else (Loc, Left_Opnd => Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (C, Loc), + Left_Opnd => New_Reference_To (C, Loc), Right_Opnd => New_Reference_To (RTE ( RE_POK_Protected_Procedure), Loc)), Right_Opnd => Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (C, Loc), + Left_Opnd => New_Reference_To (C, Loc), Right_Opnd => - New_Reference_To (RTE ( - RE_POK_Task_Procedure), Loc)))), + New_Reference_To + (RTE (RE_POK_Task_Procedure), Loc)))), - Then_Statements => - New_List (E_Call))); + Then_Statements => New_List (E_Call))); Append_To (Conc_Typ_Stmts, Make_If_Statement (Loc, - Condition => New_Reference_To (B, Loc), + Condition => New_Reference_To (B, Loc), Then_Statements => N_Stats, Else_Statements => D_Stats)); @@ -11427,18 +11390,13 @@ package body Exp_Ch9 is Append_To (Stmts, Make_If_Statement (Loc, - Condition => + Condition => Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (K, Loc), + Left_Opnd => New_Reference_To (K, Loc), Right_Opnd => New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)), - - Then_Statements => - Lim_Typ_Stmts, - - Else_Statements => - Conc_Typ_Stmts)); + Then_Statements => Lim_Typ_Stmts, + Else_Statements => Conc_Typ_Stmts)); else -- Skip assignments to temporaries created for in-out parameters. @@ -11455,7 +11413,7 @@ package body Exp_Ch9 is Insert_Before (Stmt, Make_Assignment_Statement (Loc, - Name => New_Reference_To (D, Loc), + Name => New_Reference_To (D, Loc), Expression => D_Conv)); Call := Stmt; @@ -11515,8 +11473,9 @@ package body Exp_Ch9 is Rewrite (Call, Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To ( - RTE (RE_Timed_Protected_Single_Entry_Call), Loc), + Name => + New_Reference_To + (RTE (RE_Timed_Protected_Single_Entry_Call), Loc), Parameter_Associations => Params)); when others => @@ -11541,14 +11500,14 @@ package body Exp_Ch9 is Append_To (Stmts, Make_Implicit_If_Statement (N, - Condition => New_Reference_To (B, Loc), + Condition => New_Reference_To (B, Loc), Then_Statements => E_Stats, Else_Statements => D_Stats)); end if; Rewrite (N, Make_Block_Statement (Loc, - Declarations => Decls, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts))); @@ -11568,7 +11527,7 @@ package body Exp_Ch9 is Error_Msg_CRT ("protected body", N); return; - elsif Expander_Active then + elsif Full_Expander_Active then -- Associate discriminals with the first subprogram or entry body to -- be expanded. @@ -12861,6 +12820,31 @@ package body Exp_Ch9 is New_Reference_To (RTE (RE_Time_Span_Zero), Loc)); end if; + -- Dispatching_Domain parameter. If no Dispatching_Domain pragma or + -- aspect is present, then the dispatching domain is null. If a + -- pragma or aspect is present, then the dispatching domain is taken + -- from the _Dispatching_Domain field of the task value record, + -- which was set from the pragma value. Note that this parameter + -- must not be generated for the restricted profiles since Ravenscar + -- does not allow dispatching domains. + + -- Case where pragma or aspect Dispatching_Domain applies: use given + -- value. + + if Present (Tdef) and then Has_Pragma_Dispatching_Domain (Tdef) then + Append_To (Args, + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Name_uDispatching_Domain))); + + -- No pragma or aspect Dispatching_Domain apply to the task + + else + Append_To (Args, Make_Null (Loc)); + end if; + -- Number of entries. This is an expression of the form: -- n + _Init.a'Length + _Init.a'B'Length + ... diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index b77bb0b89ac..5f9cd8326f1 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -695,13 +695,14 @@ package body Exp_Disp is end if; -- Expand_Dispatching_Call is called directly from the semantics, - -- so we need a check to see whether expansion is active before - -- proceeding. In addition, there is no need to expand the call - -- if we are compiling under restriction No_Dispatching_Calls; - -- the semantic analyzer has previously notified the violation - -- of this restriction. + -- so we only proceed if the expander is active. + + if not Full_Expander_Active + + -- And there is no need to expand the call if we are compiling under + -- restriction No_Dispatching_Calls; the semantic analyzer has + -- previously notified the violation of this restriction. - if not Expander_Active or else Restriction_Active (No_Dispatching_Calls) then return; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index ad3f432b98c..4717d74afac 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -10842,6 +10842,16 @@ package body Exp_Dist is P_Size : constant Uint := Esize (FST); begin + -- Special case: for Stream_Element_Offset and Storage_Offset, + -- always force transmission as a 64-bit value. + + if Is_RTE (FST, RE_Stream_Element_Offset) + or else + Is_RTE (FST, RE_Storage_Offset) + then + return RTE (RE_Unsigned_64); + end if; + if Is_Unsigned_Type (Typ) then if P_Size <= 8 then return RTE (RE_Unsigned_8); diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 07035478bff..2d478467474 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -876,23 +876,23 @@ package body Exp_Intr is -- structures to find and terminate those components. procedure Expand_Unc_Deallocation (N : Node_Id) is - Arg : constant Node_Id := First_Actual (N); - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (Arg); - Desig_T : constant Entity_Id := Designated_Type (Typ); - Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); - Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); - Stmts : constant List_Id := New_List; - - Abort_Id : Entity_Id := Empty; + Arg : constant Node_Id := First_Actual (N); + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (Arg); + Desig_T : constant Entity_Id := Designated_Type (Typ); + Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); + Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); + Stmts : constant List_Id := New_List; + Needs_Fin : constant Boolean := Needs_Finalization (Desig_T); + + Finalizer_Data : Finalization_Exception_Data; + Blk : Node_Id := Empty; Deref : Node_Id; - E_Id : Entity_Id := Empty; Final_Code : List_Id; Free_Arg : Node_Id; Free_Node : Node_Id; Gen_Code : Node_Id; - Raised_Id : Entity_Id := Empty; Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); -- This captures whether we know the argument to be non-null so that @@ -909,7 +909,7 @@ package body Exp_Intr is -- Processing for pointer to controlled type - if Needs_Finalization (Desig_T) then + if Needs_Fin then Deref := Make_Explicit_Dereference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Arg)); @@ -958,30 +958,21 @@ package body Exp_Intr is -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end; - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); - - Append_List_To (Stmts, - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Object_Declarations (Finalizer_Data, Stmts, Loc); Final_Code := New_List ( Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Final_Call ( - Obj_Ref => Deref, - Typ => Desig_T)), + Statements => New_List ( + Make_Final_Call (Obj_Ref => Deref, Typ => Desig_T)), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id))))); + Build_Exception_Handler (Finalizer_Data))))); -- For .NET/JVM, detach the object from the containing finalization -- collection before finalizing it. - if VM_Target /= No_VM - and then Is_Controlled (Desig_T) - then + if VM_Target /= No_VM and then Is_Controlled (Desig_T) then Prepend_To (Final_Code, Make_Detach_Call (New_Copy_Tree (Arg))); end if; @@ -1216,9 +1207,8 @@ package body Exp_Intr is -- Raise_From_Controlled_Operation (E); -- all other cases -- end if; - if Present (Raised_Id) then - Append_To (Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + if Needs_Fin then + Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); end if; -- If we know the argument is non-null, then make a block statement diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 4d3ea068819..8a95ec5c876 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -702,9 +702,11 @@ package body Exp_Pakd is -- see Reset_Packed_Prefix. On the other hand, if the prefix is a simple -- array reference, reanalysis can produce spurious type errors when the -- PAT type is replaced again with the original type of the array. Same - -- for the case of a dereference. The following is correct and minimal, - -- but the handling of more complex packed expressions in actuals is - -- confused. Probably the problem only remains for actuals in calls. + -- for the case of a dereference. Ditto for function calls: expansion + -- may introduce additional actuals which will trigger errors if call is + -- reanalyzed. The following is correct and minimal, but the handling of + -- more complex packed expressions in actuals is confused. Probably the + -- problem only remains for actuals in calls. Set_Etype (Aexp, Packed_Array_Type (Act_ST)); @@ -712,7 +714,7 @@ package body Exp_Pakd is or else (Nkind (Aexp) = N_Indexed_Component and then Is_Entity_Name (Prefix (Aexp))) - or else Nkind (Aexp) = N_Explicit_Dereference + or else Nkind_In (Aexp, N_Explicit_Dereference, N_Function_Call) then Set_Analyzed (Aexp); end if; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 5c3d2ca2777..22e9bb04691 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -321,15 +321,6 @@ package body Exp_Prag is -- be an explicit conditional in the source, not an implicit if, so we -- do not call Make_Implicit_If_Statement. - -- In formal verification mode, we keep the pragma check in the code, - -- and its enclosed expression is not expanded. This requires that no - -- transient scope is introduced for pragma check in this mode in - -- Exp_Ch7.Establish_Transient_Scope. - - if ALFA_Mode then - return; - end if; - -- Case where we generate a direct raise if ((Debug_Flag_Dot_G diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index fe02747705b..d7aba2447a7 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -29,7 +29,6 @@ with Exp_Util; use Exp_Util; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; -with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem_Aux; use Sem_Aux; with Sem_Util; use Sem_Util; @@ -222,23 +221,11 @@ package body Exp_Strm is Make_Identifier (Loc, Name_S), Make_Identifier (Loc, Name_V))); - if Ada_Version >= Ada_2005 then - Stms := New_List ( - Make_Extended_Return_Statement (Loc, - Return_Object_Declarations => New_List (Odecl), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, New_List (Rstmt)))); - else - -- pragma Assert (not Is_Limited_Type (Typ)); - -- Returning a local object, shouldn't happen in the case of a - -- limited type, but currently occurs in DSA stubs in Ada 95 mode??? - - Stms := New_List ( - Odecl, - Rstmt, - Make_Simple_Return_Statement (Loc, - Expression => Make_Identifier (Loc, Name_V))); - end if; + Stms := New_List ( + Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Odecl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, New_List (Rstmt)))); Fnam := Make_Defining_Identifier (Loc, @@ -1120,13 +1107,13 @@ package body Exp_Strm is Fnam : out Entity_Id) is Cn : Name_Id; - J : Pos; - Decls : List_Id; Constr : List_Id; - Obj_Decl : Node_Id; - Stms : List_Id; + Decls : List_Id; Discr : Entity_Id; + J : Pos; + Obj_Decl : Node_Id; Odef : Node_Id; + Stms : List_Id; begin Decls := New_List; @@ -1183,12 +1170,10 @@ package body Exp_Strm is Odef := New_Occurrence_Of (Typ, Loc); end if; - -- For Ada 2005 we create an extended return statement encapsulating - -- the result object and 'Read call, which is needed in general for - -- proper handling of build-in-place results (such as when the result - -- type is inherently limited). - - -- Perhaps we should just generate an extended return in all cases??? + -- Create an extended return statement encapsulating the result object + -- and 'Read call, which is needed in general for proper handling of + -- build-in-place results (such as when the result type is inherently + -- limited). Obj_Decl := Make_Object_Declaration (Loc, @@ -1203,33 +1188,18 @@ package body Exp_Strm is Set_No_Initialization (Obj_Decl); end if; - if Ada_Version >= Ada_2005 then - Stms := New_List ( - Make_Extended_Return_Statement (Loc, - Return_Object_Declarations => New_List (Obj_Decl), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - Make_Identifier (Loc, Name_S), - Make_Identifier (Loc, Name_V))))))); - else - Append_To (Decls, Obj_Decl); - - Stms := New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - Make_Identifier (Loc, Name_S), - Make_Identifier (Loc, Name_V))), - - Make_Simple_Return_Statement (Loc, - Expression => Make_Identifier (Loc, Name_V))); - end if; + Stms := New_List ( + Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Obj_Decl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))))))); Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index d712570d920..65311f8eec3 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -494,13 +494,39 @@ package body Exp_Util is Expr := N; end if; - Ptr_Typ := Base_Type (Etype (Expr)); + -- In certain cases an allocator with a qualified expression may + -- be relocated and used as the initialization expression of a + -- temporary: + + -- before: + -- Obj : Ptr_Typ := new Desig_Typ'(...); + + -- after: + -- Tmp : Ptr_Typ := new Desig_Typ'(...); + -- Obj : Ptr_Typ := Tmp; - -- The allocator may have been rewritten into something else + -- Since the allocator is always marked as analyzed to avoid infinite + -- expansion, it will never be processed by this routine given that + -- the designated type needs finalization actions. Detect this case + -- and complete the expansion of the allocator. - if Nkind (Expr) = N_Allocator then - Proc_To_Call := Procedure_To_Call (Expr); + if Nkind (Expr) = N_Identifier + and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration + and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator + then + Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True); + return; + end if; + + -- The allocator may have been rewritten into something else in which + -- case the expansion performed by this routine does not apply. + + if Nkind (Expr) /= N_Allocator then + return; end if; + + Ptr_Typ := Base_Type (Etype (Expr)); + Proc_To_Call := Procedure_To_Call (Expr); end if; Pool_Id := Associated_Storage_Pool (Ptr_Typ); @@ -2313,6 +2339,15 @@ package body Exp_Util is Typ := Corresponding_Record_Type (Typ); end if; + -- Since restriction violations are not considered serious errors, the + -- expander remains active, but may leave the corresponding record type + -- malformed. In such cases, component _object is not available so do + -- not look for it. + + if not Analyzed (Typ) then + return Empty; + end if; + Comp := First_Component (Typ); while Present (Comp) loop if Chars (Comp) = Name_uObject then @@ -3714,11 +3749,9 @@ package body Exp_Util is (Decl : Node_Id; Rel_Node : Node_Id) return Boolean is - Obj_Id : constant Entity_Id := Defining_Identifier (Decl); - Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); - Desig : Entity_Id := Obj_Typ; - Has_Rens : Boolean := True; - Ren_Obj : Entity_Id; + Obj_Id : constant Entity_Id := Defining_Identifier (Decl); + Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); + Desig : Entity_Id := Obj_Typ; function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean; -- Determine whether transient object Trans_Id is initialized either @@ -3732,14 +3765,15 @@ package body Exp_Util is -- value 1 and BIPaccess is not null. This case creates an aliasing -- between the returned value and the value denoted by BIPaccess. - function Is_Allocated (Trans_Id : Entity_Id) return Boolean; - -- Determine whether transient object Trans_Id is allocated on the heap - - function Is_Renamed + function Is_Aliased (Trans_Id : Entity_Id; First_Stmt : Node_Id) return Boolean; - -- Determine whether transient object Trans_Id has been renamed in the - -- statement list starting from First_Stmt. + -- Determine whether transient object Trans_Id has been renamed or + -- aliased through 'reference in the statement list starting from + -- First_Stmt. + + function Is_Allocated (Trans_Id : Entity_Id) return Boolean; + -- Determine whether transient object Trans_Id is allocated on the heap --------------------------- -- Initialized_By_Access -- @@ -3840,30 +3874,14 @@ package body Exp_Util is return False; end Initialized_By_Aliased_BIP_Func_Call; - ------------------ - -- Is_Allocated -- - ------------------ - - function Is_Allocated (Trans_Id : Entity_Id) return Boolean is - Expr : constant Node_Id := Expression (Parent (Trans_Id)); - - begin - return - Is_Access_Type (Etype (Trans_Id)) - and then Present (Expr) - and then Nkind (Expr) = N_Allocator; - end Is_Allocated; - ---------------- - -- Is_Renamed -- + -- Is_Aliased -- ---------------- - function Is_Renamed + function Is_Aliased (Trans_Id : Entity_Id; First_Stmt : Node_Id) return Boolean is - Stmt : Node_Id; - function Extract_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id; -- Given an object renaming declaration, retrieve the entity of the @@ -3909,26 +3927,30 @@ package body Exp_Util is return Empty; end Extract_Renamed_Object; - -- Start of processing for Is_Renamed - - begin - -- If a previous invocation of this routine has determined that a - -- list has no renamings, then no point in repeating the same scan. - - if not Has_Rens then - return False; - end if; + -- Local variables - -- Assume that the statement list does not have a renaming. This is a - -- minor optimization. + Expr : Node_Id; + Ren_Obj : Entity_Id; + Stmt : Node_Id; - Has_Rens := False; + -- Start of processing for Is_Aliased + begin Stmt := First_Stmt; while Present (Stmt) loop - if Nkind (Stmt) = N_Object_Renaming_Declaration then - Has_Rens := True; - Ren_Obj := Extract_Renamed_Object (Stmt); + if Nkind (Stmt) = N_Object_Declaration then + Expr := Expression (Stmt); + + if Present (Expr) + and then Nkind (Expr) = N_Reference + and then Nkind (Prefix (Expr)) = N_Identifier + and then Entity (Prefix (Expr)) = Trans_Id + then + return True; + end if; + + elsif Nkind (Stmt) = N_Object_Renaming_Declaration then + Ren_Obj := Extract_Renamed_Object (Stmt); if Present (Ren_Obj) and then Ren_Obj = Trans_Id @@ -3941,7 +3963,21 @@ package body Exp_Util is end loop; return False; - end Is_Renamed; + end Is_Aliased; + + ------------------ + -- Is_Allocated -- + ------------------ + + function Is_Allocated (Trans_Id : Entity_Id) return Boolean is + Expr : constant Node_Id := Expression (Parent (Trans_Id)); + + begin + return + Is_Access_Type (Etype (Trans_Id)) + and then Present (Expr) + and then Nkind (Expr) = N_Allocator; + end Is_Allocated; -- Start of processing for Is_Finalizable_Transient @@ -3958,6 +3994,11 @@ package body Exp_Util is and then Requires_Transient_Scope (Desig) and then Nkind (Rel_Node) /= N_Simple_Return_Statement + -- Do not consider renamed or 'reference-d transient objects because + -- the act of renaming extends the object's lifetime. + + and then not Is_Aliased (Obj_Id, Decl) + -- Do not consider transient objects allocated on the heap since they -- are attached to a finalization master. @@ -3976,11 +4017,6 @@ package body Exp_Util is and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id) - -- Do not consider renamed transient objects because the act of - -- renaming extends the object's lifetime. - - and then not Is_Renamed (Obj_Id, Decl) - -- Do not consider conversions of tags to class-wide types and then not Is_Tag_To_CW_Conversion (Obj_Id); diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 95b5d978c67..8dcc19da36b 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -23,29 +23,30 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; -with Debug_A; use Debug_A; -with Errout; use Errout; -with Exp_Aggr; use Exp_Aggr; -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 Errout; use Errout; +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 Table; package body Expander is @@ -126,330 +127,341 @@ package body Expander is else Debug_A_Entry ("expanding ", N); - -- Processing depends on node kind. For full details on the expansion - -- activity required in each case, see bodies of corresponding expand - -- routines. - begin - case Nkind (N) is + -- In Alfa mode we only need a very limited subset of the usual + -- expansions. This limited subset is implemented in Expand_Alfa. - when N_Abort_Statement => - Expand_N_Abort_Statement (N); + if Alfa_Mode then + Expand_Alfa (N); - when N_Accept_Statement => - Expand_N_Accept_Statement (N); + -- Here for normal non-Alfa mode - when N_Aggregate => - Expand_N_Aggregate (N); + else + -- Processing depends on node kind. For full details on the + -- expansion activity required in each case, see bodies of + -- corresponding expand routines. - when N_Allocator => - Expand_N_Allocator (N); + case Nkind (N) is - when N_And_Then => - Expand_N_And_Then (N); + when N_Abort_Statement => + Expand_N_Abort_Statement (N); - when N_Assignment_Statement => - Expand_N_Assignment_Statement (N); + when N_Accept_Statement => + Expand_N_Accept_Statement (N); - when N_Asynchronous_Select => - Expand_N_Asynchronous_Select (N); + when N_Aggregate => + Expand_N_Aggregate (N); - when N_Attribute_Definition_Clause => - Expand_N_Attribute_Definition_Clause (N); + when N_Allocator => + Expand_N_Allocator (N); - when N_Attribute_Reference => - Expand_N_Attribute_Reference (N); + when N_And_Then => + Expand_N_And_Then (N); - when N_Block_Statement => - Expand_N_Block_Statement (N); + when N_Assignment_Statement => + Expand_N_Assignment_Statement (N); - when N_Case_Expression => - Expand_N_Case_Expression (N); + when N_Asynchronous_Select => + Expand_N_Asynchronous_Select (N); - when N_Case_Statement => - Expand_N_Case_Statement (N); + when N_Attribute_Definition_Clause => + Expand_N_Attribute_Definition_Clause (N); - when N_Conditional_Entry_Call => - Expand_N_Conditional_Entry_Call (N); + when N_Attribute_Reference => + Expand_N_Attribute_Reference (N); - when N_Conditional_Expression => - Expand_N_Conditional_Expression (N); + when N_Block_Statement => + Expand_N_Block_Statement (N); - when N_Delay_Relative_Statement => - Expand_N_Delay_Relative_Statement (N); + when N_Case_Expression => + Expand_N_Case_Expression (N); - when N_Delay_Until_Statement => - Expand_N_Delay_Until_Statement (N); + when N_Case_Statement => + Expand_N_Case_Statement (N); - when N_Entry_Body => - Expand_N_Entry_Body (N); + when N_Conditional_Entry_Call => + Expand_N_Conditional_Entry_Call (N); - when N_Entry_Call_Statement => - Expand_N_Entry_Call_Statement (N); + when N_Conditional_Expression => + Expand_N_Conditional_Expression (N); - when N_Entry_Declaration => - Expand_N_Entry_Declaration (N); + when N_Delay_Relative_Statement => + Expand_N_Delay_Relative_Statement (N); - when N_Exception_Declaration => - Expand_N_Exception_Declaration (N); + when N_Delay_Until_Statement => + Expand_N_Delay_Until_Statement (N); - when N_Exception_Renaming_Declaration => - Expand_N_Exception_Renaming_Declaration (N); + when N_Entry_Body => + Expand_N_Entry_Body (N); - when N_Exit_Statement => - Expand_N_Exit_Statement (N); + when N_Entry_Call_Statement => + Expand_N_Entry_Call_Statement (N); - when N_Expanded_Name => - Expand_N_Expanded_Name (N); + when N_Entry_Declaration => + Expand_N_Entry_Declaration (N); - when N_Explicit_Dereference => - Expand_N_Explicit_Dereference (N); + when N_Exception_Declaration => + Expand_N_Exception_Declaration (N); - when N_Expression_With_Actions => - Expand_N_Expression_With_Actions (N); + when N_Exception_Renaming_Declaration => + Expand_N_Exception_Renaming_Declaration (N); - when N_Extended_Return_Statement => - Expand_N_Extended_Return_Statement (N); + when N_Exit_Statement => + Expand_N_Exit_Statement (N); - when N_Extension_Aggregate => - Expand_N_Extension_Aggregate (N); + when N_Expanded_Name => + Expand_N_Expanded_Name (N); - when N_Free_Statement => - Expand_N_Free_Statement (N); + when N_Explicit_Dereference => + Expand_N_Explicit_Dereference (N); - when N_Freeze_Entity => - Expand_N_Freeze_Entity (N); + when N_Expression_With_Actions => + Expand_N_Expression_With_Actions (N); - when N_Full_Type_Declaration => - Expand_N_Full_Type_Declaration (N); + when N_Extended_Return_Statement => + Expand_N_Extended_Return_Statement (N); - when N_Function_Call => - Expand_N_Function_Call (N); + when N_Extension_Aggregate => + Expand_N_Extension_Aggregate (N); - when N_Generic_Instantiation => - Expand_N_Generic_Instantiation (N); + when N_Free_Statement => + Expand_N_Free_Statement (N); - when N_Goto_Statement => - Expand_N_Goto_Statement (N); + when N_Freeze_Entity => + Expand_N_Freeze_Entity (N); - when N_Handled_Sequence_Of_Statements => - Expand_N_Handled_Sequence_Of_Statements (N); + when N_Full_Type_Declaration => + Expand_N_Full_Type_Declaration (N); - when N_Identifier => - Expand_N_Identifier (N); + when N_Function_Call => + Expand_N_Function_Call (N); - when N_Indexed_Component => - Expand_N_Indexed_Component (N); + when N_Generic_Instantiation => + Expand_N_Generic_Instantiation (N); - when N_If_Statement => - Expand_N_If_Statement (N); + when N_Goto_Statement => + Expand_N_Goto_Statement (N); - when N_In => - Expand_N_In (N); + when N_Handled_Sequence_Of_Statements => + Expand_N_Handled_Sequence_Of_Statements (N); - when N_Loop_Statement => - Expand_N_Loop_Statement (N); + when N_Identifier => + Expand_N_Identifier (N); - when N_Not_In => - Expand_N_Not_In (N); + when N_Indexed_Component => + Expand_N_Indexed_Component (N); - when N_Null => - Expand_N_Null (N); + when N_If_Statement => + Expand_N_If_Statement (N); - when N_Object_Declaration => - Expand_N_Object_Declaration (N); + when N_In => + Expand_N_In (N); - when N_Object_Renaming_Declaration => - Expand_N_Object_Renaming_Declaration (N); + when N_Loop_Statement => + Expand_N_Loop_Statement (N); - when N_Op_Add => - Expand_N_Op_Add (N); + when N_Not_In => + Expand_N_Not_In (N); - when N_Op_Abs => - Expand_N_Op_Abs (N); + when N_Null => + Expand_N_Null (N); - when N_Op_And => - Expand_N_Op_And (N); + when N_Object_Declaration => + Expand_N_Object_Declaration (N); - when N_Op_Concat => - Expand_N_Op_Concat (N); + when N_Object_Renaming_Declaration => + Expand_N_Object_Renaming_Declaration (N); - when N_Op_Divide => - Expand_N_Op_Divide (N); + when N_Op_Add => + Expand_N_Op_Add (N); - when N_Op_Eq => - Expand_N_Op_Eq (N); + when N_Op_Abs => + Expand_N_Op_Abs (N); - when N_Op_Expon => - Expand_N_Op_Expon (N); + when N_Op_And => + Expand_N_Op_And (N); - when N_Op_Ge => - Expand_N_Op_Ge (N); + when N_Op_Concat => + Expand_N_Op_Concat (N); - when N_Op_Gt => - Expand_N_Op_Gt (N); + when N_Op_Divide => + Expand_N_Op_Divide (N); - when N_Op_Le => - Expand_N_Op_Le (N); + when N_Op_Eq => + Expand_N_Op_Eq (N); - when N_Op_Lt => - Expand_N_Op_Lt (N); + when N_Op_Expon => + Expand_N_Op_Expon (N); - when N_Op_Minus => - Expand_N_Op_Minus (N); + when N_Op_Ge => + Expand_N_Op_Ge (N); - when N_Op_Mod => - Expand_N_Op_Mod (N); + when N_Op_Gt => + Expand_N_Op_Gt (N); - when N_Op_Multiply => - Expand_N_Op_Multiply (N); + when N_Op_Le => + Expand_N_Op_Le (N); - when N_Op_Ne => - Expand_N_Op_Ne (N); + when N_Op_Lt => + Expand_N_Op_Lt (N); - when N_Op_Not => - Expand_N_Op_Not (N); + when N_Op_Minus => + Expand_N_Op_Minus (N); - when N_Op_Or => - Expand_N_Op_Or (N); + when N_Op_Mod => + Expand_N_Op_Mod (N); - when N_Op_Plus => - Expand_N_Op_Plus (N); + when N_Op_Multiply => + Expand_N_Op_Multiply (N); - when N_Op_Rem => - Expand_N_Op_Rem (N); + when N_Op_Ne => + Expand_N_Op_Ne (N); - when N_Op_Rotate_Left => - Expand_N_Op_Rotate_Left (N); + when N_Op_Not => + Expand_N_Op_Not (N); - when N_Op_Rotate_Right => - Expand_N_Op_Rotate_Right (N); + when N_Op_Or => + Expand_N_Op_Or (N); - when N_Op_Shift_Left => - Expand_N_Op_Shift_Left (N); + when N_Op_Plus => + Expand_N_Op_Plus (N); - when N_Op_Shift_Right => - Expand_N_Op_Shift_Right (N); + when N_Op_Rem => + Expand_N_Op_Rem (N); - when N_Op_Shift_Right_Arithmetic => - Expand_N_Op_Shift_Right_Arithmetic (N); + when N_Op_Rotate_Left => + Expand_N_Op_Rotate_Left (N); - when N_Op_Subtract => - Expand_N_Op_Subtract (N); + when N_Op_Rotate_Right => + Expand_N_Op_Rotate_Right (N); - when N_Op_Xor => - Expand_N_Op_Xor (N); + when N_Op_Shift_Left => + Expand_N_Op_Shift_Left (N); - when N_Or_Else => - Expand_N_Or_Else (N); + when N_Op_Shift_Right => + Expand_N_Op_Shift_Right (N); - when N_Package_Body => - Expand_N_Package_Body (N); + when N_Op_Shift_Right_Arithmetic => + Expand_N_Op_Shift_Right_Arithmetic (N); - when N_Package_Declaration => - Expand_N_Package_Declaration (N); + when N_Op_Subtract => + Expand_N_Op_Subtract (N); - when N_Package_Renaming_Declaration => - Expand_N_Package_Renaming_Declaration (N); + when N_Op_Xor => + Expand_N_Op_Xor (N); - when N_Subprogram_Renaming_Declaration => - Expand_N_Subprogram_Renaming_Declaration (N); + when N_Or_Else => + Expand_N_Or_Else (N); - when N_Pragma => - Expand_N_Pragma (N); + when N_Package_Body => + Expand_N_Package_Body (N); - when N_Procedure_Call_Statement => - Expand_N_Procedure_Call_Statement (N); + when N_Package_Declaration => + Expand_N_Package_Declaration (N); - when N_Protected_Type_Declaration => - Expand_N_Protected_Type_Declaration (N); + when N_Package_Renaming_Declaration => + Expand_N_Package_Renaming_Declaration (N); - when N_Protected_Body => - Expand_N_Protected_Body (N); + when N_Subprogram_Renaming_Declaration => + Expand_N_Subprogram_Renaming_Declaration (N); - when N_Qualified_Expression => - Expand_N_Qualified_Expression (N); + when N_Pragma => + Expand_N_Pragma (N); - when N_Quantified_Expression => - Expand_N_Quantified_Expression (N); + when N_Procedure_Call_Statement => + Expand_N_Procedure_Call_Statement (N); - when N_Raise_Statement => - Expand_N_Raise_Statement (N); + when N_Protected_Type_Declaration => + Expand_N_Protected_Type_Declaration (N); - when N_Raise_Constraint_Error => - Expand_N_Raise_Constraint_Error (N); + when N_Protected_Body => + Expand_N_Protected_Body (N); - when N_Raise_Program_Error => - Expand_N_Raise_Program_Error (N); + when N_Qualified_Expression => + Expand_N_Qualified_Expression (N); - when N_Raise_Storage_Error => - Expand_N_Raise_Storage_Error (N); + when N_Quantified_Expression => + Expand_N_Quantified_Expression (N); - when N_Real_Literal => - Expand_N_Real_Literal (N); + when N_Raise_Statement => + Expand_N_Raise_Statement (N); - when N_Record_Representation_Clause => - Expand_N_Record_Representation_Clause (N); + when N_Raise_Constraint_Error => + Expand_N_Raise_Constraint_Error (N); - when N_Requeue_Statement => - Expand_N_Requeue_Statement (N); + when N_Raise_Program_Error => + Expand_N_Raise_Program_Error (N); - when N_Simple_Return_Statement => - Expand_N_Simple_Return_Statement (N); + when N_Raise_Storage_Error => + Expand_N_Raise_Storage_Error (N); - when N_Selected_Component => - Expand_N_Selected_Component (N); + when N_Real_Literal => + Expand_N_Real_Literal (N); - when N_Selective_Accept => - Expand_N_Selective_Accept (N); + when N_Record_Representation_Clause => + Expand_N_Record_Representation_Clause (N); - when N_Single_Task_Declaration => - Expand_N_Single_Task_Declaration (N); + when N_Requeue_Statement => + Expand_N_Requeue_Statement (N); - when N_Slice => - Expand_N_Slice (N); + when N_Simple_Return_Statement => + Expand_N_Simple_Return_Statement (N); - when N_Subtype_Indication => - Expand_N_Subtype_Indication (N); + when N_Selected_Component => + Expand_N_Selected_Component (N); - when N_Subprogram_Body => - Expand_N_Subprogram_Body (N); + when N_Selective_Accept => + Expand_N_Selective_Accept (N); - when N_Subprogram_Body_Stub => - Expand_N_Subprogram_Body_Stub (N); + when N_Single_Task_Declaration => + Expand_N_Single_Task_Declaration (N); - when N_Subprogram_Declaration => - Expand_N_Subprogram_Declaration (N); + when N_Slice => + Expand_N_Slice (N); - when N_Subprogram_Info => - Expand_N_Subprogram_Info (N); + when N_Subtype_Indication => + Expand_N_Subtype_Indication (N); - when N_Task_Body => - Expand_N_Task_Body (N); + when N_Subprogram_Body => + Expand_N_Subprogram_Body (N); - when N_Task_Type_Declaration => - Expand_N_Task_Type_Declaration (N); + when N_Subprogram_Body_Stub => + Expand_N_Subprogram_Body_Stub (N); - when N_Timed_Entry_Call => - Expand_N_Timed_Entry_Call (N); + when N_Subprogram_Declaration => + Expand_N_Subprogram_Declaration (N); - when N_Type_Conversion => - Expand_N_Type_Conversion (N); + when N_Subprogram_Info => + Expand_N_Subprogram_Info (N); - when N_Unchecked_Expression => - Expand_N_Unchecked_Expression (N); + when N_Task_Body => + Expand_N_Task_Body (N); - when N_Unchecked_Type_Conversion => - Expand_N_Unchecked_Type_Conversion (N); + when N_Task_Type_Declaration => + Expand_N_Task_Type_Declaration (N); - when N_Variant_Part => - Expand_N_Variant_Part (N); + when N_Timed_Entry_Call => + Expand_N_Timed_Entry_Call (N); - -- For all other node kinds, no expansion activity is required + when N_Type_Conversion => + Expand_N_Type_Conversion (N); - when others => null; + when N_Unchecked_Expression => + Expand_N_Unchecked_Expression (N); - end case; + when N_Unchecked_Type_Conversion => + Expand_N_Unchecked_Type_Conversion (N); + + when N_Variant_Part => + Expand_N_Variant_Part (N); + + -- For all other node kinds, no expansion activity required + + when others => + null; + + end case; + end if; exception when RE_Not_Available => diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 4862518137c..a64c0d782a0 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1840,12 +1840,18 @@ package body Freeze is -- if it is variable length. We omit this test in a generic -- context, it will be applied at instantiation time. + -- We also omit this test in CodePeer mode, since we do not + -- have sufficient info on size and representation clauses. + if Present (CC) then Placed_Component := True; if Inside_A_Generic then null; + elsif CodePeer_Mode then + null; + elsif not Size_Known_At_Compile_Time (Underlying_Type (Etype (Comp))) @@ -2246,13 +2252,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 Alfa 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 Alfa_Mode) then -- If implicit packing enabled, do it @@ -3066,7 +3072,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 Alfa_Mode) then Get_Index_Bounds (First_Index (E), Lo, Hi); diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index 5f5855fef8c..cce88b9daed 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -3236,9 +3236,10 @@ package body GNAT.Command_Line is ------------ procedure Getopt - (Config : Command_Line_Configuration; - Callback : Switch_Handler := null; - Parser : Opt_Parser := Command_Line_Parser) + (Config : Command_Line_Configuration; + Callback : Switch_Handler := null; + Parser : Opt_Parser := Command_Line_Parser; + Concatenate : Boolean := True) is Getopt_Switches : String_Access; C : Character := ASCII.NUL; @@ -3290,11 +3291,14 @@ package body GNAT.Command_Line is with "Expected integer parameter for '" & Switch & "'"; end; + return; when Switch_String => Free (Config.Switches (Index).String_Output.all); Config.Switches (Index).String_Output.all := new String'(Parameter); + return; + end case; end if; @@ -3370,7 +3374,7 @@ package body GNAT.Command_Line is loop C := Getopt (Switches => Getopt_Switches.all, - Concatenate => True, + Concatenate => Concatenate, Parser => Parser); if C = '*' then diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index ec842800386..f19d7baea5b 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -703,11 +703,13 @@ package GNAT.Command_Line is -- switch. procedure Getopt - (Config : Command_Line_Configuration; - Callback : Switch_Handler := null; - Parser : Opt_Parser := Command_Line_Parser); + (Config : Command_Line_Configuration; + Callback : Switch_Handler := null; + Parser : Opt_Parser := Command_Line_Parser; + Concatenate : Boolean := True); -- Similar to the standard Getopt function. - -- For each switch found on the command line, this calls Callback. + -- For each switch found on the command line, this calls Callback, if the + -- switch is not handled automatically. -- -- The list of valid switches are the ones from the configuration. The -- switches that were declared through Define_Switch with an Output @@ -715,6 +717,9 @@ package GNAT.Command_Line is -- variable). This function will in fact never call [Callback] if all -- switches were handled automatically and there is nothing left to do. -- + -- The option Concatenate is identical to the one of the standard Getopt + -- function. + -- -- This procedure automatically adds -h and --help to the valid switches, -- to display the help message and raises Exit_From_Command_Line. -- If an invalid switch is specified on the command line, this procedure diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 69b6aefb5bc..01983282ac7 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2010, AdaCore -- +-- Copyright (C) 2001-2011, 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- -- @@ -427,14 +427,14 @@ package GNAT.Sockets is -- Timeval_Duration is a subtype of Standard.Duration because the full -- range of Standard.Duration cannot be represented in the equivalent C - -- structure. Moreover, negative values are not allowed to avoid system - -- incompatibilities. + -- structure (struct timeval). Moreover, negative values are not allowed + -- to avoid system incompatibilities. Immediate : constant Duration := 0.0; - Timeval_Forever : constant := 2.0 ** (SOSC.SIZEOF_tv_sec * 8 - 1) - 1.0; Forever : constant Duration := - Duration'Min (Duration'Last, Timeval_Forever); + Duration'Min (Duration'Last, 1.0 * SOSC.MAX_tv_sec); + -- Largest possible Duration that is also a valid value for struct timeval subtype Timeval_Duration is Duration range Immediate .. Forever; diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index 79d3e6cab00..c075ae542e2 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, AdaCore -- +-- Copyright (C) 2001-2011, 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- -- @@ -40,8 +40,9 @@ package body GNAT.Sockets.Thin is type VMS_Msghdr is new Msghdr; pragma Pack (VMS_Msghdr); - -- On VMS (unlike other platforms), struct msghdr is packed, so a specific - -- derived type is required. + -- On VMS 8.x (unlike other platforms), struct msghdr is packed, so a + -- specific derived type is required. This structure was not packed on + -- VMS 7.3, so sendmsg and recvmsg fail on earlier VMS versions. Non_Blocking_Sockets : aliased Fd_Set; -- When this package is initialized with Process_Blocking_IO set to True, diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index be89eb4591e..2d97a4417e8 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -200,6 +200,7 @@ GNAT_ADA_OBJS = \ ada/erroutc.o \ ada/eval_fat.o \ ada/exp_aggr.o \ + ada/exp_alfa.o \ ada/exp_atag.o \ ada/exp_attr.o \ ada/exp_cg.o \ @@ -1576,22 +1577,24 @@ ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ ada/atree.adb ada/casing.ads ada/comperr.ads ada/comperr.adb \ - ada/csets.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads \ - ada/errout.ads ada/errout.adb ada/erroutc.ads ada/erroutc.adb \ - ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/namet.ads \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ + ada/err_vars.ads ada/errout.ads ada/errout.adb ada/erroutc.ads \ + ada/erroutc.adb ada/fname.ads ada/gnat.ads ada/g-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/namet.ads \ ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads \ ada/output.ads ada/output.adb ada/rident.ads ada/scans.ads \ ada/sdefault.ads ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb \ ada/sinput.ads ada/sinput.adb ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stylesw.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ - ada/treepr.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/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/treepr.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/csets.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/csets.ads \ ada/csets.adb ada/hostparm.ads ada/opt.ads ada/system.ads \ @@ -1606,27 +1609,27 @@ ada/cstand.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/errout.ads ada/errout.adb ada/erroutc.ads ada/erroutc.adb \ ada/exp_ch11.ads ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads \ ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/gnatvsn.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.adb 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/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/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-crc32.ads \ - ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-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/gnat.ads ada/g-byorma.ads ada/g-htable.ads ada/gnatvsn.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.adb \ + 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/scn.ads ada/scn.adb \ + 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/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-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-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 @@ -1771,6 +1774,23 @@ ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_ch6.ads \ + ada/exp_dbug.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/interfac.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/output.ads ada/rtsfind.ads \ + ada/sem_aux.ads ada/sem_aux.adb ada/sem_res.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.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/tbuild.ads \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/exp_atag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ @@ -2201,26 +2221,26 @@ ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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_elab.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/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-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/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_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_elab.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/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-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_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 \ @@ -2286,25 +2306,25 @@ ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib-load.ads \ ada/lib-util.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ 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/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_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/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-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/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.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/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/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.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 @@ -2638,29 +2658,29 @@ ada/expander.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads \ ada/debug_a.ads ada/debug_a.adb ada/einfo.ads ada/elists.ads \ ada/err_vars.ads ada/errout.ads ada/errout.adb ada/erroutc.ads \ - ada/erroutc.adb ada/exp_aggr.ads ada/exp_attr.ads ada/exp_ch11.ads \ - ada/exp_ch12.ads ada/exp_ch13.ads ada/exp_ch2.ads ada/exp_ch3.ads \ - ada/exp_ch4.ads ada/exp_ch5.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_ch8.ads ada/exp_ch9.ads ada/exp_prag.ads ada/exp_tss.ads \ - ada/expander.ads ada/expander.adb ada/fname.ads ada/gnat.ads \ - ada/g-htable.ads ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/lib.ads ada/lib-load.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/opt.ads ada/output.ads 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_prag.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stylesw.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/erroutc.adb 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/expander.adb ada/fname.ads \ + ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads ada/hlo.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/lib.ads \ + ada/lib-load.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads 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_prag.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/fmap.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/fmap.adb \ @@ -2745,35 +2765,35 @@ ada/frontend.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_ch7.ads ada/exp_code.ads ada/exp_dbug.ads ada/exp_pakd.ads \ ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fmap.ads \ ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/frontend.ads \ - ada/frontend.adb ada/get_targ.ads ada/gnat.ads ada/g-dyntab.ads \ - ada/g-dyntab.adb ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hlo.ads ada/hostparm.ads ada/inline.ads ada/inline.adb \ - ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/live.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/osint.ads ada/output.ads ada/par.ads ada/par_sco.ads \ - ada/prep.ads ada/prep.adb ada/prepcomp.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scil_ll.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem.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_elab.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_util.ads ada/sem_warn.ads ada/sem_warn.adb \ - 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/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-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/frontend.adb ada/get_targ.ads ada/gnat.ads ada/g-byorma.ads \ + ada/g-dyntab.ads ada/g-dyntab.adb ada/g-hesorg.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads ada/inline.ads \ + ada/inline.adb ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/live.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/osint.ads ada/output.ads ada/par.ads \ + ada/par_sco.ads ada/prep.ads ada/prep.adb ada/prepcomp.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scil_ll.ads ada/scn.ads ada/scn.adb ada/scng.ads \ + ada/scng.adb 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_elab.ads ada/sem_eval.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_scil.ads ada/sem_util.ads ada/sem_warn.ads \ + ada/sem_warn.adb 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/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-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/g-byorma.o : ada/gnat.ads ada/g-byorma.ads ada/g-byorma.adb \ ada/system.ads @@ -2932,21 +2952,6 @@ ada/inline.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/instpar.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/gnatvsn.ads ada/hostparm.ads ada/instpar.ads ada/instpar.adb \ - ada/interfac.ads ada/namet.ads ada/namet.adb ada/nlists.ads ada/opt.ads \ - ada/output.ads ada/sdefault.ads ada/sinfo.ads ada/sinput.ads \ - ada/sinput.adb ada/sinput-l.ads ada/snames.ads ada/system.ads \ - ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads - ada/interfac.o : ada/interfac.ads ada/system.ads ada/itypes.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -3017,25 +3022,26 @@ ada/lib-load.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ ada/errout.adb ada/erroutc.ads ada/erroutc.adb ada/fname.ads \ - ada/fname-uf.ads ada/gnat.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-load.ads ada/lib-load.adb \ - 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/osint.ads \ - ada/osint-c.ads ada/output.ads ada/par.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/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-crc32.ads ada/s-crc32.adb \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.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-load.ads \ + ada/lib-load.adb 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/osint.ads ada/osint-c.ads ada/output.ads ada/par.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/scans.ads \ + ada/scn.ads ada/scn.adb ada/scng.ads ada/scng.adb ada/sem_aux.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/sinput-l.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/lib-util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -3061,15 +3067,15 @@ ada/lib-writ.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ ada/err_vars.ads ada/errout.ads ada/errout.adb ada/erroutc.ads \ ada/erroutc.adb ada/fname.ads ada/fname-uf.ads ada/gnat.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/namet.adb \ - 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/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/namet.adb 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/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/rident.ads ada/scans.ads ada/scn.ads ada/scn.adb 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-casuti.ads ada/s-crc32.ads \ @@ -3097,27 +3103,27 @@ ada/lib-xref.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-util.adb ada/lib-xref.ads ada/lib-xref.adb \ ada/lib-xref-alfa.adb ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/osint.ads ada/osint-c.ads \ - ada/output.ads ada/par_sco.ads ada/put_alfa.ads ada/put_alfa.adb \ - 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/sem_warn.ads ada/sem_warn.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-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/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.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_sco.ads ada/put_alfa.ads \ + ada/put_alfa.adb 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/sem_warn.ads ada/sem_warn.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-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/uintp.adb 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 \ @@ -3257,33 +3263,33 @@ ada/par.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ ada/errout.ads ada/errout.adb ada/erroutc.ads ada/erroutc.adb \ ada/exp_tss.ads ada/fname.ads ada/fname-uf.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/g-speche.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/namet.ads \ - ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads ada/output.ads \ - ada/par.ads ada/par.adb ada/par-ch10.adb ada/par-ch11.adb \ - ada/par-ch12.adb ada/par-ch13.adb ada/par-ch2.adb ada/par-ch3.adb \ - ada/par-ch4.adb ada/par-ch5.adb ada/par-ch6.adb ada/par-ch7.adb \ - ada/par-ch8.adb ada/par-ch9.adb ada/par-endh.adb ada/par-labl.adb \ - ada/par-load.adb ada/par-prag.adb ada/par-sync.adb ada/par-tchk.adb \ - ada/par-util.adb ada/par_sco.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/scans.ads ada/scans.adb ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem_aux.ads ada/sem_util.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-carun8.ads ada/s-crc32.ads ada/s-crc32.adb 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/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/g-byorma.ads ada/g-hesorg.ads ada/g-htable.ads ada/g-speche.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ + ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/osint.ads \ + ada/output.ads ada/par.ads ada/par.adb ada/par-ch10.adb \ + ada/par-ch11.adb ada/par-ch12.adb ada/par-ch13.adb ada/par-ch2.adb \ + ada/par-ch3.adb ada/par-ch4.adb ada/par-ch5.adb ada/par-ch6.adb \ + ada/par-ch7.adb ada/par-ch8.adb ada/par-ch9.adb ada/par-endh.adb \ + ada/par-labl.adb ada/par-load.adb ada/par-prag.adb ada/par-sync.adb \ + ada/par-tchk.adb ada/par-util.adb ada/par_sco.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/scans.ads ada/scans.adb ada/scn.ads \ + ada/scn.adb ada/scng.ads ada/scng.adb ada/sem_aux.ads ada/sem_util.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-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \ + 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/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/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/atree.ads \ @@ -3327,28 +3333,28 @@ ada/prepcomp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/atree.ads ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads \ ada/einfo.ads ada/einfo.adb ada/err_vars.ads ada/errout.ads \ ada/errout.adb ada/erroutc.ads ada/erroutc.adb ada/fname.ads \ - ada/fname-uf.ads ada/gnat.ads ada/g-dyntab.ads ada/g-dyntab.adb \ - 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-writ.ads ada/lib-writ.adb \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/osint.ads ada/osint-c.ads ada/output.ads \ - ada/par.ads ada/par_sco.ads ada/prep.ads ada/prep.adb ada/prepcomp.ads \ - ada/prepcomp.adb 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/sinput-l.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-casuti.ads \ - ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-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/fname-uf.ads ada/gnat.ads ada/g-byorma.ads ada/g-dyntab.ads \ + ada/g-dyntab.adb 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-writ.ads \ + ada/lib-writ.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads ada/osint-c.ads \ + ada/output.ads ada/par.ads ada/par_sco.ads ada/prep.ads ada/prep.adb \ + ada/prepcomp.ads ada/prepcomp.adb ada/put_alfa.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/scans.ads ada/scn.ads ada/scn.adb \ + ada/scng.ads ada/scng.adb ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-casuti.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-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/put_alfa.o : ada/ada.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 \ @@ -3490,8 +3496,9 @@ ada/s-excdeb.o : ada/ada.ads ada/a-unccon.ads ada/system.ads \ ada/s-except.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-except.ads \ - ada/s-htable.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads + ada/s-except.adb ada/s-htable.ads ada/s-parame.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-traent.ads ada/s-exctab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/system.ads ada/s-exctab.ads ada/s-exctab.adb \ @@ -3627,17 +3634,17 @@ ada/scn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/restrict.adb ada/rident.ads ada/scans.ads ada/scn.ads ada/scn.adb \ 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-carun8.ads \ - ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-utf_32.adb \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/urealp.adb ada/widechar.ads + ada/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-carun8.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-utf_32.adb ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tree_io.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads ada/scng.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -3867,26 +3874,27 @@ ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/inline.ads ada/inline.adb 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/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/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/sem_warn.adb 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-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/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/sem_warn.adb 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-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_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 \ @@ -3936,7 +3944,7 @@ ada/sem_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/par_sco.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/rtsfind.adb 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 \ @@ -4154,30 +4162,30 @@ ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/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_ch13.adb 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_disp.ads ada/sem_dist.ads \ - ada/sem_elim.ads ada/sem_eval.ads 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/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-carun8.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/warnsw.ads \ - ada/widechar.ads + ada/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_aux.adb ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \ + ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch13.adb ada/sem_ch2.ads \ + ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \ + ada/sem_ch6.adb ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads \ + 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/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-carun8.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/warnsw.ads ada/widechar.ads ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -4229,28 +4237,28 @@ ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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_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_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_ch8.adb ada/sem_ch9.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/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-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/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_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_ch8.adb ada/sem_ch9.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/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-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_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -4267,7 +4275,7 @@ ada/sem_ch9.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.adb 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/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_aggr.ads ada/sem_attr.ads \ ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch10.ads \ @@ -4306,7 +4314,7 @@ ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/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/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.adb ada/sem_attr.ads \ ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch10.ads ada/sem_ch11.ads \ @@ -4563,7 +4571,7 @@ ada/sem_res.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.adb 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/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/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_aux.adb ada/sem_cat.ads \ @@ -4798,25 +4806,25 @@ ada/sinput-l.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/err_vars.ads ada/errout.ads ada/errout.adb \ ada/erroutc.ads ada/erroutc.adb ada/fname.ads ada/fname-uf.ads \ - ada/gnat.ads ada/g-dyntab.ads ada/g-dyntab.adb 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/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads \ - ada/output.ads ada/prep.ads ada/prep.adb ada/prepcomp.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/sinput-l.ads \ - ada/sinput-l.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/gnat.ads ada/g-byorma.ads ada/g-dyntab.ads ada/g-dyntab.adb \ + 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/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \ + ada/prep.adb ada/prepcomp.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/scans.ads ada/scn.ads ada/scn.adb ada/scng.ads \ + ada/scng.adb ada/sem_aux.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/sinput-l.ads ada/sinput-l.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sinput.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index ef98039f295..1afe6c00562 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -223,8 +223,9 @@ endif all.indirect: Makefile ../gnat1$(exeext) -# IN_GCC distinguishes between code compiled into GCC itself and other -# programs built during a bootstrap. +# IN_GCC is meant to distinguish between code compiled into GCC itself, i.e. +# for the host, and the rest. But we also use it for the tools (link.c) and +# even break the host/target wall by using it for the library (targext.c). # autoconf inserts -DCROSS_DIRECTORY_STRUCTURE if we are building a cross # compiler which does not use the native libraries and headers. INTERNAL_CFLAGS = @CROSS@ -DIN_GCC @@ -405,10 +406,10 @@ DUMMY_SOCKETS_TARGET_PAIRS = \ g-sothco.adb<g-sothco-dummy.adb \ g-sothco.ads<g-sothco-dummy.ads -# On platform where atomic increment/decrement operations are supported +# On platforms where atomic increment/decrement operations are supported, # special version of Ada.Strings.Unbounded package can be used. -ATOMICS_TARGET_PAIRS += \ +ATOMICS_TARGET_PAIRS = \ a-stunau.adb<a-stunau-shared.adb \ a-suteio.adb<a-suteio-shared.adb \ a-strunb.ads<a-strunb-shared.ads \ @@ -422,10 +423,15 @@ ATOMICS_TARGET_PAIRS += \ a-szunau.adb<a-szunau-shared.adb \ a-szuzti.adb<a-szuzti-shared.adb -ATOMICS_BUILTINS_TARGET_PAIRS += \ +ATOMICS_BUILTINS_TARGET_PAIRS = \ s-atocou.adb<s-atocou-builtin.adb -ATOMICS_X86_TARGET_PAIRS += \ +# Special version of units for x86 and x86-64 platforms. + +X86_TARGET_PAIRS = \ + a-numaux.ads<a-numaux-x86.ads \ + a-numaux.adb<a-numaux-x86.adb \ + g-bytswa.adb<g-bytswa-x86.adb \ s-atocou.adb<s-atocou-x86.adb # Special version of units for x86 and x86-64 platforms. @@ -543,6 +549,7 @@ ifeq ($(strip $(filter-out e500% powerpc% wrs vxworks,$(targ))),) else ifeq ($(strip $(filter-out rtp-smp,$(THREAD_KIND))),) LIBGNAT_TARGET_PAIRS += \ + s-mudido.adb<s-mudido-affinity.adb \ s-vxwext.ads<s-vxwext-rtp.ads \ s-vxwext.adb<s-vxwext-rtp-smp.adb \ s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \ @@ -555,6 +562,7 @@ ifeq ($(strip $(filter-out e500% powerpc% wrs vxworks,$(targ))),) ifeq ($(strip $(filter-out kernel-smp,$(THREAD_KIND))),) LIBGNAT_TARGET_PAIRS += \ s-interr.adb<s-interr-hwint.adb \ + s-mudido.adb<s-mudido-affinity.adb \ s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \ s-vxwext.ads<s-vxwext-kernel.ads \ s-vxwext.adb<s-vxwext-kernel-smp.adb \ @@ -712,11 +720,8 @@ ifeq ($(strip $(filter-out %86 wrs vxworksae vxworksmils,$(targ))),) LIBGNAT_TARGET_PAIRS = \ a-elchha.adb<a-elchha-vxworks-ppc-full.adb \ a-intnam.ads<a-intnam-vxworks.ads \ - a-numaux.ads<a-numaux-x86.ads \ - a-numaux.adb<a-numaux-x86.adb \ a-sytaco.ads<1asytaco.ads \ a-sytaco.adb<1asytaco.adb \ - g-bytswa.adb<g-bytswa-x86.adb \ g-io.adb<g-io-vxworks-ppc-cert.adb \ g-io.ads<g-io-vxworks-ppc-cert.ads \ s-inmaop.adb<s-inmaop-vxworks.adb \ @@ -736,9 +741,9 @@ ifeq ($(strip $(filter-out %86 wrs vxworksae vxworksmils,$(targ))),) s-vxwork.ads<s-vxwork-x86.ads \ g-trasym.ads<g-trasym-unimplemented.ads \ g-trasym.adb<g-trasym-unimplemented.adb \ - system.ads<system-vxworks-x86.ads \ $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_X86_TARGET_PAIRS) + $(X86_TARGET_PAIRS) \ + system.ads<system-vxworks-x86.ads TOOLS_TARGET_PAIRS=\ mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \ @@ -819,8 +824,6 @@ ifeq ($(strip $(filter-out %86 wrs vxworks,$(targ))),) s-inmaop.adb<s-inmaop-vxworks.adb \ s-intman.ads<s-intman-vxworks.ads \ s-intman.adb<s-intman-vxworks.adb \ - a-numaux.adb<a-numaux-x86.adb \ - a-numaux.ads<a-numaux-x86.ads \ s-osprim.adb<s-osprim-vxworks.adb \ s-parame.ads<s-parame-vxworks.ads \ s-parame.adb<s-parame-vxworks.adb \ @@ -830,14 +833,13 @@ ifeq ($(strip $(filter-out %86 wrs vxworks,$(targ))),) s-tasinf.ads<s-tasinf-vxworks.ads \ s-taspri.ads<s-taspri-vxworks.ads \ s-vxwork.ads<s-vxwork-x86.ads \ - g-bytswa.adb<g-bytswa-x86.adb \ g-socthi.ads<g-socthi-vxworks.ads \ g-socthi.adb<g-socthi-vxworks.adb \ g-stsifd.adb<g-stsifd-sockets.adb \ g-trasym.ads<g-trasym-unimplemented.ads \ g-trasym.adb<g-trasym-unimplemented.adb \ $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_X86_TARGET_PAIRS) + $(X86_TARGET_PAIRS) TOOLS_TARGET_PAIRS=\ mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \ @@ -863,6 +865,7 @@ ifeq ($(strip $(filter-out %86 wrs vxworks,$(targ))),) else ifeq ($(strip $(filter-out rtp-smp, $(THREAD_KIND))),) LIBGNAT_TARGET_PAIRS += \ + s-mudido.adb<s-mudido-affinity.adb \ s-vxwext.ads<s-vxwext-rtp.ads \ s-vxwext.adb<s-vxwext-rtp-smp.adb \ s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \ @@ -875,6 +878,7 @@ ifeq ($(strip $(filter-out %86 wrs vxworks,$(targ))),) ifeq ($(strip $(filter-out kernel-smp, $(THREAD_KIND))),) LIBGNAT_TARGET_PAIRS += \ s-interr.adb<s-interr-hwint.adb \ + s-mudido.adb<s-mudido-affinity.adb \ s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \ s-vxwext.ads<s-vxwext-kernel.ads \ s-vxwext.adb<s-vxwext-kernel-smp.adb \ @@ -987,6 +991,7 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(targ))),) a-intnam.ads<a-intnam-solaris.ads \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-solaris.adb \ + s-mudido.adb<s-mudido-affinity.adb \ s-osinte.adb<s-osinte-solaris.adb \ s-osinte.ads<s-osinte-solaris.ads \ s-osprim.adb<s-osprim-solaris.adb \ @@ -1057,11 +1062,10 @@ endif ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(arch) $(osys))),) LIBGNAT_TARGET_PAIRS_COMMON = \ - a-numaux.adb<a-numaux-x86.adb \ - a-numaux.ads<a-numaux-x86.ads \ a-intnam.ads<a-intnam-solaris.ads \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-solaris.adb \ + s-mudido.adb<s-mudido-affinity.adb \ s-osinte.adb<s-osinte-solaris.adb \ s-osinte.ads<s-osinte-solaris.ads \ s-osprim.adb<s-osprim-solaris.adb \ @@ -1073,14 +1077,30 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(arch) $(osys))),) g-soliop.ads<g-soliop-solaris.ads \ $(ATOMICS_TARGET_PAIRS) - ifeq ($(strip $(MULTISUBDIR)),/amd64) - LIBGNAT_TARGET_PAIRS += \ - $(X86_64_TARGET_PAIRS) \ - system.ads<system-solaris-x86_64.ads + LIBGNAT_TARGET_PAIRS_32 = \ + $(X86_TARGET_PAIRS) \ + system.ads<system-solaris-x86.ads + + LIBGNAT_TARGET_PAIRS_64 = \ + $(X86_64_TARGET_PAIRS) \ + system.ads<system-solaris-x86_64.ads + + ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),) + ifeq ($(strip $(MULTISUBDIR)),/amd64) + LIBGNAT_TARGET_PAIRS = \ + $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64) + else + LIBGNAT_TARGET_PAIRS = \ + $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32) + endif else - LIBGNAT_TARGET_PAIRS += \ - $(X86_TARGET_PAIRS) \ - system.ads<system-solaris-x86.ads + ifeq ($(strip $(MULTISUBDIR)),/32) + LIBGNAT_TARGET_PAIRS = \ + $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32) + else + LIBGNAT_TARGET_PAIRS = \ + $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64) + endif endif TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-solaris.adb @@ -1097,17 +1117,14 @@ endif ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-linux.ads \ - a-numaux.adb<a-numaux-x86.adb \ - a-numaux.ads<a-numaux-x86.ads \ a-synbar.adb<a-synbar-posix.adb \ a-synbar.ads<a-synbar-posix.ads \ - g-bytswa.adb<g-bytswa-x86.adb \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-posix.adb \ s-tpopsp.adb<s-tpopsp-tls.adb \ g-sercom.adb<g-sercom-linux.adb \ $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_X86_TARGET_PAIRS) + $(X86_TARGET_PAIRS) ifeq ($(strip $(filter-out marte,$(THREAD_KIND))),) LIBGNAT_TARGET_PAIRS += \ @@ -1146,6 +1163,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) EH_MECHANISM=-gcc else LIBGNAT_TARGET_PAIRS += \ + s-mudido.adb<s-mudido-affinity.adb \ s-osinte.ads<s-osinte-linux.ads \ s-osprim.adb<s-osprim-posix.adb \ s-taprop.adb<s-taprop-linux.adb \ @@ -1173,8 +1191,6 @@ endif ifeq ($(strip $(filter-out %86 kfreebsd%,$(arch) $(osys))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-freebsd.ads \ - a-numaux.adb<a-numaux-x86.adb \ - a-numaux.ads<a-numaux-x86.ads \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-posix.adb \ s-osinte.adb<s-osinte-posix.adb \ @@ -1185,9 +1201,9 @@ ifeq ($(strip $(filter-out %86 kfreebsd%,$(arch) $(osys))),) s-tasinf.adb<s-tasinf-linux.adb \ s-taspri.ads<s-taspri-posix.ads \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ - system.ads<system-freebsd-x86.ads \ $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_X86_TARGET_PAIRS) + $(X86_TARGET_PAIRS) \ + system.ads<system-freebsd-x86.ads TOOLS_TARGET_PAIRS = \ mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \ @@ -1231,9 +1247,6 @@ endif ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-freebsd.ads \ - a-numaux.adb<a-numaux-x86.adb \ - a-numaux.ads<a-numaux-x86.ads \ - g-bytswa.adb<g-bytswa-x86.adb \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-posix.adb \ s-osinte.adb<s-osinte-freebsd.adb \ @@ -1242,9 +1255,35 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) s-taprop.adb<s-taprop-posix.adb \ s-taspri.ads<s-taspri-posix.ads \ s-tpopsp.adb<s-tpopsp-posix.adb \ - system.ads<system-freebsd-x86.ads \ $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_X86_TARGET_PAIRS) + $(X86_TARGET_PAIRS) \ + system.ads<system-freebsd-x86.ads + + TOOLS_TARGET_PAIRS = \ + mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb + GNATLIB_SHARED = gnatlib-shared-dual + + EH_MECHANISM=-gcc + THREADSLIB= -lpthread + GMEM_LIB = gmemlib + LIBRARY_VERSION := $(LIB_VERSION) +endif + +ifeq ($(strip $(filter-out %86_64 freebsd%,$(arch) $(osys))),) + LIBGNAT_TARGET_PAIRS = \ + a-intnam.ads<a-intnam-freebsd.ads \ + s-inmaop.adb<s-inmaop-posix.adb \ + s-intman.adb<s-intman-posix.adb \ + s-osinte.adb<s-osinte-freebsd.adb \ + s-osinte.ads<s-osinte-freebsd.ads \ + s-osprim.adb<s-osprim-posix.adb \ + s-taprop.adb<s-taprop-posix.adb \ + s-taspri.ads<s-taspri-posix.ads \ + s-tpopsp.adb<s-tpopsp-posix.adb \ + g-trasym.adb<g-trasym-dwarf.adb \ + $(ATOMICS_TARGET_PAIRS) \ + $(X86_64_TARGET_PAIRS) \ + system.ads<system-freebsd-x86_64.ads TOOLS_TARGET_PAIRS = \ mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb @@ -1594,28 +1633,25 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) LIBGNAT_TARGET_PAIRS = \ a-dirval.adb<a-dirval-mingw.adb \ a-excpol.adb<a-excpol-abort.adb \ - a-numaux.adb<a-numaux-x86.adb \ - a-numaux.ads<a-numaux-x86.ads \ s-gloloc.adb<s-gloloc-mingw.adb \ s-inmaop.adb<s-inmaop-dummy.adb \ s-memory.adb<s-memory-mingw.adb \ s-taspri.ads<s-taspri-mingw.ads \ s-tasinf.adb<s-tasinf-mingw.adb \ s-tasinf.ads<s-tasinf-mingw.ads \ - g-bytswa.adb<g-bytswa-x86.adb \ g-socthi.ads<g-socthi-mingw.ads \ g-socthi.adb<g-socthi-mingw.adb \ g-stsifd.adb<g-stsifd-sockets.adb \ g-soliop.ads<g-soliop-mingw.ads \ - $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_X86_TARGET_PAIRS) + $(ATOMICS_TARGET_PAIRS) ifeq ($(strip $(filter-out rtx_w32 rtx_rtss,$(THREAD_KIND))),) LIBGNAT_TARGET_PAIRS += \ s-intman.adb<s-intman-dummy.adb \ s-osinte.ads<s-osinte-rtx.ads \ s-osprim.adb<s-osprim-rtx.adb \ - s-taprop.adb<s-taprop-rtx.adb + s-taprop.adb<s-taprop-rtx.adb \ + $(X86_TARGET_PAIRS) EXTRA_GNATRTL_NONTASKING_OBJS = s-win32.o @@ -1639,6 +1675,7 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) g-sercom.adb<g-sercom-mingw.adb \ s-interr.adb<s-interr-sigaction.adb \ s-intman.adb<s-intman-mingw.adb \ + s-mudido.adb<s-mudido-affinity.adb \ s-osinte.ads<s-osinte-mingw.ads \ s-osprim.adb<s-osprim-mingw.adb \ s-taprop.adb<s-taprop-mingw.adb @@ -1646,20 +1683,24 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) ifeq ($(strip $(filter-out x86_64%,$(arch))),) ifeq ($(strip $(MULTISUBDIR)),/32) LIBGNAT_TARGET_PAIRS += \ + $(X86_TARGET_PAIRS) \ system.ads<system-mingw.ads SO_OPTS= -m32 -Wl,-soname, else LIBGNAT_TARGET_PAIRS += \ + $(X86_64_TARGET_PAIRS) \ system.ads<system-mingw-x86_64.ads SO_OPTS = -m64 -Wl,-soname, endif else ifeq ($(strip $(MULTISUBDIR)),/64) LIBGNAT_TARGET_PAIRS += \ + $(X86_64_TARGET_PAIRS) \ system.ads<system-mingw-x86_64.ads SO_OPTS = -m64 -Wl,-soname, else LIBGNAT_TARGET_PAIRS += \ + $(X86_TARGET_PAIRS) \ system.ads<system-mingw.ads SO_OPTS = -m32 -Wl,-soname, endif @@ -1838,6 +1879,7 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(arch) $(osys))),) endif LIBGNAT_TARGET_PAIRS += \ + s-mudido.adb<s-mudido-affinity.adb \ s-osinte.ads<s-osinte-linux.ads \ s-osprim.adb<s-osprim-posix.adb \ s-taprop.adb<s-taprop-linux.adb \ @@ -2006,6 +2048,7 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),) s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-posix.adb \ s-linux.ads<s-linux.ads \ + s-mudido.adb<s-mudido-affinity.adb \ s-osinte.ads<s-osinte-linux.ads \ s-osinte.adb<s-osinte-posix.adb \ s-osprim.adb<s-osprim-posix.adb \ @@ -2096,13 +2139,12 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) a-exetim.adb<a-exetim-posix.adb \ a-exetim.ads<a-exetim-default.ads \ a-intnam.ads<a-intnam-linux.ads \ - a-numaux.adb<a-numaux-x86.adb \ - a-numaux.ads<a-numaux-x86.ads \ a-synbar.adb<a-synbar-posix.adb \ a-synbar.ads<a-synbar-posix.ads \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-posix.adb \ s-linux.ads<s-linux.ads \ + s-mudido.adb<s-mudido-affinity.adb \ s-osinte.ads<s-osinte-linux.ads \ s-osinte.adb<s-osinte-posix.adb \ s-osprim.adb<s-osprim-posix.adb \ @@ -2112,9 +2154,9 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) s-tpopsp.adb<s-tpopsp-tls.adb \ s-taspri.ads<s-taspri-posix.ads \ g-sercom.adb<g-sercom-linux.adb \ - system.ads<system-linux-x86_64.ads \ $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_BUILTINS_TARGET_PAIRS) + $(X86_64_TARGET_PAIRS) \ + system.ads<system-linux-x86_64.ads TOOLS_TARGET_PAIRS = \ mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \ @@ -2144,14 +2186,16 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ g-trasym.ads<g-trasym-unimplemented.ads \ g-trasym.adb<g-trasym-unimplemented.adb \ - a-numaux.ads<a-numaux-x86.ads \ - a-numaux.adb<a-numaux-x86.adb + $(ATOMICS_TARGET_PAIRS) + ifeq ($(strip $(MULTISUBDIR)),/x86_64) LIBGNAT_TARGET_PAIRS += \ - system.ads<system-darwin-x86_64.ads + $(X86_64_TARGET_PAIRS) \ + system.ads<system-darwin-x86_64.ads else LIBGNAT_TARGET_PAIRS += \ - system.ads<system-darwin-x86.ads + $(X86_TARGET_PAIRS) \ + system.ads<system-darwin-x86.ads endif endif @@ -2169,10 +2213,9 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ g-trasym.ads<g-trasym-unimplemented.ads \ g-trasym.adb<g-trasym-unimplemented.adb \ - a-numaux.ads<a-numaux-x86.ads \ - a-numaux.adb<a-numaux-x86.adb \ $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_BUILTINS_TARGET_PAIRS) + $(X86_64_TARGET_PAIRS) \ + system.ads<system-darwin-x86_64.ads ifeq ($(strip $(MULTISUBDIR)),/i386) LIBGNAT_TARGET_PAIRS += \ system.ads<system-darwin-x86.ads diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index 588c852cd95..2d0e6e4945e 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -106,7 +106,7 @@ do { \ /* Nonzero in an arithmetic subtype if this is a subtype not known to the front-end. */ -#define TYPE_EXTRA_SUBTYPE_P(NODE) TYPE_LANG_FLAG_2 (NODE) +#define TYPE_EXTRA_SUBTYPE_P(NODE) TYPE_LANG_FLAG_2 (INTEGER_TYPE_CHECK (NODE)) /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is the type for an object whose type includes its template in addition to diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 512c05ecb15..54903cfc403 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -1124,13 +1124,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) is a padded record whose field is of self-referential size. In the former case, converting will generate unnecessary evaluations of the CONSTRUCTOR to compute the size and in the latter case, we - want to only copy the actual data. */ + want to only copy the actual data. Also don't convert to a record + type with a variant part from a record type without one, to keep + the object simpler. */ if (gnu_expr && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) && !(TYPE_IS_PADDING_P (gnu_type) && CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))) + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))) + && !(TREE_CODE (gnu_type) == RECORD_TYPE + && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE + && get_variant_part (gnu_type) != NULL_TREE + && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE)) gnu_expr = convert (gnu_type, gnu_expr); /* If this is a pointer that doesn't have an initializing expression, @@ -1350,13 +1356,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) is a padded record whose field is of self-referential size. In the former case, converting will generate unnecessary evaluations of the CONSTRUCTOR to compute the size and in the latter case, we - want to only copy the actual data. */ + want to only copy the actual data. Also don't convert to a record + type with a variant part from a record type without one, to keep + the object simpler. */ if (gnu_expr && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) && !(TYPE_IS_PADDING_P (gnu_type) && CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))) + (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))) + && !(TREE_CODE (gnu_type) == RECORD_TYPE + && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE + && get_variant_part (gnu_type) != NULL_TREE + && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE)) gnu_expr = convert (gnu_type, gnu_expr); /* If this name is external or there was a name specified, use it, diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 25e293dd3e6..897f328565d 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -544,7 +544,7 @@ build_binary_op (enum tree_code op_code, tree result_type, operation_type = TREE_TYPE (TYPE_FIELDS (operation_type)); if (operation_type - && !AGGREGATE_TYPE_P (operation_type) + && TREE_CODE (operation_type) == INTEGER_TYPE && TYPE_EXTRA_SUBTYPE_P (operation_type)) operation_type = get_base_type (operation_type); @@ -1002,7 +1002,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) operation_type = TREE_TYPE (TYPE_FIELDS (operation_type)); if (operation_type - && !AGGREGATE_TYPE_P (operation_type) + && TREE_CODE (operation_type) == INTEGER_TYPE && TYPE_EXTRA_SUBTYPE_P (operation_type)) operation_type = get_base_type (operation_type); diff --git a/gcc/ada/get_alfa.adb b/gcc/ada/get_alfa.adb index 6c2391ec9d1..8c90f754d9a 100644 --- a/gcc/ada/get_alfa.adb +++ b/gcc/ada/get_alfa.adb @@ -23,12 +23,12 @@ -- -- ------------------------------------------------------------------------------ -with ALFA; use ALFA; +with Alfa; use Alfa; with Types; use Types; with Ada.IO_Exceptions; use Ada.IO_Exceptions; -procedure Get_ALFA is +procedure Get_Alfa 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 Alfa_File_Table of the current file Cur_Scope_Idx : Scope_Index; - -- Index in ALFA_Scope_Table of the current scope + -- Index in Alfa_Scope_Table of the current scope Name_Str : String (1 .. 32768); Name_Len : Natural := 0; @@ -193,17 +193,17 @@ procedure Get_ALFA is end loop; end Skip_Spaces; --- Start of processing for Get_ALFA +-- Start of processing for Get_Alfa begin - Initialize_ALFA_Tables; + Initialize_Alfa_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 Alfa information while Nextc = 'F' loop Skipc; @@ -212,7 +212,7 @@ begin -- Make sure first line is a File line - if ALFA_File_Table.Last = 0 and then C /= 'D' then + if Alfa_File_Table.Last = 0 and then C /= 'D' then raise Data_Error; end if; @@ -226,9 +226,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 Alfa_File_Table.Last /= 0 then + Alfa_File_Table.Table (Alfa_File_Table.Last).To_Scope := + Alfa_Scope_Table.Last; end if; -- Scan out dependency number and file name @@ -240,10 +240,10 @@ begin -- Make new File table entry (will fill in To_Scope later) - ALFA_File_Table.Append ( + Alfa_File_Table.Append ( (File_Name => new String'(Name_Str (1 .. Name_Len)), File_Num => Cur_File, - From_Scope => ALFA_Scope_Table.Last + 1, + From_Scope => Alfa_Scope_Table.Last + 1, To_Scope => 0)); -- Initialize counter for scopes @@ -300,7 +300,7 @@ begin -- To_Xref later). Initial range (From_Xref .. To_Xref) is -- empty for scopes without entities. - ALFA_Scope_Table.Append ( + Alfa_Scope_Table.Append ( (Scope_Entity => Empty, Scope_Name => new String'(Name_Str (1 .. Name_Len)), File_Num => Cur_File, @@ -332,7 +332,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 Alfa_File_Table.Table (Cur_File_Idx).File_Num /= Cur_File loop Cur_File_Idx := Cur_File_Idx + 1; end loop; @@ -348,21 +348,21 @@ 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; + Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := + Alfa_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 := Alfa_File_Table.Table (Cur_File_Idx).From_Scope; - while ALFA_Scope_Table.Table (Cur_Scope_Idx).Scope_Num /= Cur_Scope + while Alfa_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; + Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := + Alfa_Xref_Table.Last + 1; -- Cross reference entry @@ -437,7 +437,7 @@ begin Rtype = 'm' or else Rtype = 's'); - ALFA_Xref_Table.Append ( + Alfa_Xref_Table.Append ( (Entity_Name => XR_Entity, Entity_Line => XR_Entity_Line, Etype => XR_Entity_Typ, @@ -453,7 +453,7 @@ begin end loop; end; - -- No other ALFA lines are possible + -- No other Alfa lines are possible when others => raise Data_Error; @@ -468,12 +468,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 Alfa_File_Table.Last /= 0 then + Alfa_File_Table.Table (Alfa_File_Table.Last).To_Scope := + Alfa_Scope_Table.Last; end if; if Cur_Scope_Idx /= 0 then - ALFA_Scope_Table.Table (Cur_Scope_Idx).To_Xref := ALFA_Xref_Table.Last; + Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := Alfa_Xref_Table.Last; end if; -end Get_ALFA; +end Get_Alfa; diff --git a/gcc/ada/get_alfa.ads b/gcc/ada/get_alfa.ads index a4660321a65..e8c6a17aa13 100644 --- a/gcc/ada/get_alfa.ads +++ b/gcc/ada/get_alfa.ads @@ -23,8 +23,8 @@ -- -- ------------------------------------------------------------------------------ --- 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 Alfa information from an +-- ALI file and populate the tables defined in package Alfa with the result. generic -- These subprograms provide access to the ALI file. Locating, opening and @@ -46,12 +46,12 @@ 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_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 -- 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 Alfa -- 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/gnat1drv.adb b/gcc/ada/gnat1drv.adb index f371afafa45..b0b90242209 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -390,7 +390,7 @@ procedure Gnat1drv is if Debug_Flag_Dot_FF then - ALFA_Mode := True; + Alfa_Mode := True; -- Turn off inlining, which would confuse formal verification output -- and gain nothing. @@ -406,7 +406,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 Alfa mode, see Restrict.Check_Restriction, and user -- specified Restrictions pragmas are ignored, see -- Sem_Prag.Process_Restrictions_Or_Restriction_Warnings. @@ -435,8 +435,9 @@ procedure Gnat1drv is Polling_Required := False; - -- Set operating mode to Generate_Code to benefit from full front-end - -- expansion (e.g. default arguments). + -- Set operating mode to Generate_Code, but full front-end expansion + -- is not desirable in Alfa mode, so a light expansion is performed + -- instead. Operating_Mode := Generate_Code; @@ -463,7 +464,7 @@ procedure Gnat1drv is Debug_Pragmas_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 Alfa output. Reset_Style_Check_Options; @@ -841,6 +842,12 @@ begin Tree_Gen; end if; + -- In CodePeer mode we delete SCIL files if there is an error + + if CodePeer_Mode then + Comperr.Delete_SCIL_Files; + end if; + Errout.Finalize (Last_Call => True); Exit_Program (E_Errors); end if; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index faf3e839a27..5cc0cb6db2b 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -7857,7 +7857,6 @@ Followed. Executable code is generated in some cases, e.g.@: loops to initialize large arrays. @unnumberedsec C.5(8): Pragma @code{Discard_Names} - @sp 1 @cartouche If the pragma applies to an entity, then the implementation should diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index de51c76781e..145c66ea8e0 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -4130,11 +4130,11 @@ Display full source path name in brief error messages. @cindex @option{-gnateG} (@command{gcc}) Save result of preprocessing in a text file. -@item -gnateInnn +@item ^-gnateI^/MULTI_UNIT_INDEX=^@var{nnn} @cindex @option{-gnateI} (@command{gcc}) Indicates that the source is a multi-unit source and that the index of the -unit to compile is nnn. nnn needs to be a positive number and need to -be a valid index in the multi-unit source. +unit to compile is @var{nnn}. @var{nnn} needs to be a positive number and need +to be a valid index in the multi-unit source. @item -gnatem=@var{path} @cindex @option{-gnatem} (@command{gcc}) @@ -5732,7 +5732,7 @@ as shown in the following example. @emph{Activate warnings on unnecessary Warnings Off pragmas} @cindex @option{-gnatw.w} (@command{gcc}) @cindex Warnings Off control -This switch activates warnings for use of @code{pragma Warnings (Off, entity} +This switch activates warnings for use of @code{pragma Warnings (Off, entity)} where either the pragma is entirely useless (because it suppresses no warnings), or it could be replaced by @code{pragma Unreferenced} or @code{pragma Unmodified}.The default is that these warnings are not given. @@ -5742,7 +5742,7 @@ activated explicitly. @item -gnatw.W @emph{Suppress warnings on unnecessary Warnings Off pragmas} @cindex @option{-gnatw.W} (@command{gcc}) -This switch suppresses warnings for use of @code{pragma Warnings (Off, entity}. +This switch suppresses warnings for use of @code{pragma Warnings (Off, entity)}. @item -gnatwx @emph{Activate warnings on Export/Import pragmas.} @@ -17267,6 +17267,15 @@ A consequence of the @option{/p0image} qualifier is also to makes RMS buffers be placed in P0 space. Refer to @cite{HP OpenVMS Linker Utility Manual} for more details about the @option{/p0image} qualifier and the @option{stack} option. + +@noindent +On Itanium platforms, you can instead assign the @samp{GNAT_STACK_SIZE} and +@samp{GNAT_RBS_SIZE} logicals to the size of the primary and register +stack in kilobytes. For example: + +@smallexample +$ define GNAT_RBS_SIZE 1024 ! Limit the RBS size to 1MB. +@end smallexample @end ifset @node Static Stack Usage Analysis diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index f7f4ddb45fe..5f9f2368993 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -822,41 +822,13 @@ procedure Gnatls is -------------------------------- procedure Output_License_Information is - Params_File_Name : constant String := "gnatlic.adl"; - -- Name of license file - - Lo : constant Source_Ptr := 1; - Hi : Source_Ptr; - Text : Source_Buffer_Ptr; - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Params_File_Name); - Read_Source_File (Name_Find, Lo, Hi, Text); - - if Text /= null then - - -- Omit last character (end-of-file marker) in output - - Write_Str (String (Text (Lo .. Hi - 1))); - Write_Eol; - - -- The following condition is determined at compile time: disable - -- "condition is always true/false" warning. - - pragma Warnings (Off); - elsif Build_Type /= GPL and then Build_Type /= FSF then - pragma Warnings (On); - - Write_Str ("License file missing, please contact AdaCore."); - Write_Eol; - - else - Write_Str ("Please refer to file COPYING in your distribution" - & " for license terms."); - Write_Eol; - - end if; + case Build_Type is + when others => + Write_Str ("Please refer to file COPYING in your distribution" + & " for license terms."); + Write_Eol; + end case; Exit_Program (E_Success); end Output_License_Information; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 87498d85f30..c3d250032fe 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -519,6 +519,11 @@ package body Impunit is "a-comutr", -- Ada.Containers.Multiway_Trees "a-cimutr", -- Ada.Containers.Indefinite_Multiway_Trees "a-cbmutr", -- Ada.Containers.Bounded_Multiway_Trees + "a-csquin", -- Ada.Containers.Synchronized_Queue_Interfaces + "a-cusyqu", -- Ada.Containers.Unbounded_Synchronized_Queues + "a-cuprqu", -- Ada.Containers.Unbounded_Priority_Queues + "a-cbsyqu", -- Ada.Containers.Bounded_Synchronized_Queues + "a-cbprqu", -- Ada.Containers.Bounded_Priority_Queues "a-extiin", -- Ada.Execution_Time.Interrupts "a-iteint", -- Ada.Iterator_Interfaces "a-synbar", -- Ada.Synchronous_Barriers diff --git a/gcc/ada/init.c b/gcc/ada/init.c index a8a94269c33..0e6fb11745c 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -10,20 +10,19 @@ * * * GNAT is 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 2, or (at your option) any later ver- * + * 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 COPYING. If not, write * - * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * - * Boston, MA 02110-1301, USA. * + * or FITNESS FOR A PARTICULAR PURPOSE. * * * - * As a special exception, if you link this file with other files to * - * produce an executable, this file does not by itself cause the resulting * - * executable to be covered by the GNU General Public License. This except- * - * ion does not however invalidate any other reasons why the executable * - * file might be covered by the GNU Public License. * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * <http://www.gnu.org/licenses/>. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * @@ -359,7 +358,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext) ((volatile char *) ((long) si->si_addr & - getpagesize ()))[getpagesize ()]; exception = &storage_error; - msg = "stack overflow (or erroneous memory access)"; + msg = "stack overflow or erroneous memory access"; } break; @@ -645,7 +644,7 @@ __gnat_error_handler (int sig, siginfo_t *si ATTRIBUTE_UNUSED, void *ucontext) that this is quite acceptable, since a "real" SIGSEGV can only occur as the result of an erroneous program. */ exception = &storage_error; - msg = "stack overflow (or erroneous memory access)"; + msg = "stack overflow or erroneous memory access"; break; case SIGBUS: @@ -825,7 +824,7 @@ __gnat_error_handler (int sig, siginfo_t *reason, void *uc ATTRIBUTE_UNUSED) the stack into a guard page, not an attempt to write to .text or something. */ exception = &storage_error; - msg = "SIGSEGV: (stack overflow or erroneous memory access)"; + msg = "SIGSEGV: stack overflow or erroneous memory access"; } else { @@ -1023,7 +1022,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext ATTRIBUTE_UNUSED) ((volatile char *) ((long) si->si_addr & - getpagesize ()))[getpagesize ()]; exception = &storage_error; - msg = "stack overflow (or erroneous memory access)"; + msg = "stack overflow or erroneous memory access"; } break; @@ -1422,7 +1421,7 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs) else { exception = &storage_error; - msg = "stack overflow (or erroneous memory access)"; + msg = "stack overflow or erroneous memory access"; } __gnat_adjust_context_for_raise (SS$_ACCVIO, (void *)mechargs); break; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 0eb8dce6f4f..609c803db69 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -341,10 +341,13 @@ package body Inline is if Is_Generic_Instance (Pack) then null; + -- Do not inline the package if the subprogram is an init proc + -- or other internally generated subprogram, because in that + -- case the subprogram body appears in the same unit that + -- declares the type, and that body is visible to the back end. + elsif not Is_Inlined (Pack) - and then - (not Has_Completion (E) - or else Is_Expression_Function (E)) + and then Comes_From_Source (E) then Set_Is_Inlined (Pack); Inlined_Bodies.Increment_Last; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 64ec01166b1..c8129e9ecbd 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -32,7 +32,7 @@ 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; + use Lib.Xref.Alfa; with Nlists; use Nlists; with Gnatvsn; use Gnatvsn; with Opt; use Opt; @@ -796,6 +796,12 @@ package body Lib.Writ is or else Nkind (Unit (Cunit)) in N_Generic_Renaming_Declaration) and then Generic_May_Lack_ALI (Fname)) + + -- In Alfa mode, always generate the dependencies on ALI + -- files, which are required to compute frame conditions + -- of subprograms. + + or else Alfa_Mode then Write_Info_Tab (25); @@ -1317,11 +1323,11 @@ package body Lib.Writ is SCO_Output; end if; - -- Output ALFA information if needed + -- Output Alfa information if needed - if Opt.Xref_Active and then ALFA_Mode then - Collect_ALFA (Sdep_Table => Sdep_Table, Num_Sdep => Num_Sdep); - Output_ALFA; + if Opt.Xref_Active and then Alfa_Mode then + Collect_Alfa (Sdep_Table => Sdep_Table, Num_Sdep => Num_Sdep); + Output_Alfa; 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 98786f48dc5..f6cf75f6eb5 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -712,10 +712,10 @@ package Lib.Writ is -- reference data. See the spec of Par_SCO for full details of the format. ---------------------- - -- ALFA Information -- + -- Alfa Information -- ---------------------- - -- The ALFA information follows the SCO information. See the spec of Alfa + -- The Alfa information follows the SCO information. See the spec of Alfa -- for full details of the format. ---------------------- diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 32439a02a07..8a29818f37c 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -23,22 +23,23 @@ -- -- ------------------------------------------------------------------------------ -with ALFA; use ALFA; -with Einfo; use Einfo; -with Nmake; use Nmake; -with Put_ALFA; +with Alfa; use Alfa; +with Einfo; use Einfo; +with Nmake; use Nmake; +with Put_Alfa; + with GNAT.HTable; separate (Lib.Xref) -package body ALFA is +package body Alfa is --------------------- -- Local Constants -- --------------------- - -- Table of ALFA_Entities, True for each entity kind used in ALFA + -- Table of Alfa_Entities, True for each entity kind used in Alfa - ALFA_Entities : constant array (Entity_Kind) of Boolean := + Alfa_Entities : constant array (Entity_Kind) of Boolean := (E_Void => False, E_Variable => True, E_Component => False, @@ -134,8 +135,8 @@ package body ALFA is E_Task_Body => False, E_Subprogram_Body => False); - -- True for each reference type used in ALFA - ALFA_References : constant array (Character) of Boolean := + -- True for each reference type used in Alfa + Alfa_References : constant array (Character) of Boolean := ('m' => True, 'r' => True, 's' => True, @@ -157,26 +158,26 @@ package body ALFA is Table_Name => "Drefs"); -- 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. + -- "Heap". These references are added to the regular references when + -- computing Alfa cross-references. ----------------------- -- Local Subprograms -- ----------------------- - procedure Add_ALFA_File (U : Unit_Number_Type; D : Nat); - -- Add file U and all scopes in U to the tables ALFA_File_Table and - -- ALFA_Scope_Table. + procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat); + -- Add file U and all scopes in U to the tables Alfa_File_Table and + -- Alfa_Scope_Table. - procedure Add_ALFA_Scope (N : Node_Id); - -- Add scope N to the table ALFA_Scope_Table + procedure Add_Alfa_Scope (N : Node_Id); + -- Add scope N to the table Alfa_Scope_Table - procedure Add_ALFA_Xrefs; - -- Filter table Xrefs to add all references used in ALFA to the table - -- ALFA_Xref_Table. + procedure Add_Alfa_Xrefs; + -- Filter table Xrefs to add all references used in Alfa to the table + -- Alfa_Xref_Table. - procedure Detect_And_Add_ALFA_Scope (N : Node_Id); - -- Call Add_ALFA_Scope on scopes + procedure Detect_And_Add_Alfa_Scope (N : Node_Id); + -- Call Add_Alfa_Scope on scopes function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range; -- Hash function for hash table @@ -205,10 +206,10 @@ package body ALFA is -- declarations. ------------------- - -- Add_ALFA_File -- + -- Add_Alfa_File -- ------------------- - procedure Add_ALFA_File (U : Unit_Number_Type; D : Nat) is + procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat) is From : Scope_Index; S : constant Source_File_Index := Source_Index (U); @@ -221,9 +222,9 @@ package body ALFA is return; end if; - From := ALFA_Scope_Table.Last + 1; + From := Alfa_Scope_Table.Last + 1; - Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_ALFA_Scope'Access, + Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_Alfa_Scope'Access, Inside_Stubs => False); -- Update scope numbers @@ -233,14 +234,14 @@ package body ALFA is begin Count := 1; - for S in From .. ALFA_Scope_Table.Last loop + for S in From .. Alfa_Scope_Table.Last loop declare - E : Entity_Id renames ALFA_Scope_Table.Table (S).Scope_Entity; + E : Entity_Id renames Alfa_Scope_Table.Table (S).Scope_Entity; begin if Lib.Get_Source_Unit (E) = U then - ALFA_Scope_Table.Table (S).Scope_Num := Count; - ALFA_Scope_Table.Table (S).File_Num := D; + Alfa_Scope_Table.Table (S).Scope_Num := Count; + Alfa_Scope_Table.Table (S).File_Num := D; Count := Count + 1; else @@ -248,7 +249,7 @@ package body ALFA is -- U, for example for scope inside generics that get -- instantiated. - ALFA_Scope_Table.Table (S).Scope_Num := 0; + Alfa_Scope_Table.Table (S).Scope_Num := 0; end if; end; end loop; @@ -259,34 +260,34 @@ package body ALFA is begin Snew := From; - for S in From .. ALFA_Scope_Table.Last loop + for S in From .. Alfa_Scope_Table.Last loop -- Remove those scopes previously marked for removal - if ALFA_Scope_Table.Table (S).Scope_Num /= 0 then - ALFA_Scope_Table.Table (Snew) := ALFA_Scope_Table.Table (S); + if Alfa_Scope_Table.Table (S).Scope_Num /= 0 then + Alfa_Scope_Table.Table (Snew) := Alfa_Scope_Table.Table (S); Snew := Snew + 1; end if; end loop; - ALFA_Scope_Table.Set_Last (Snew - 1); + Alfa_Scope_Table.Set_Last (Snew - 1); end; -- Make entry for new file in file table Get_Name_String (Reference_Name (S)); - ALFA_File_Table.Append ( + Alfa_File_Table.Append ( (File_Name => new String'(Name_Buffer (1 .. Name_Len)), File_Num => D, From_Scope => From, - To_Scope => ALFA_Scope_Table.Last)); - end Add_ALFA_File; + To_Scope => Alfa_Scope_Table.Last)); + end Add_Alfa_File; -------------------- - -- Add_ALFA_Scope -- + -- Add_Alfa_Scope -- -------------------- - procedure Add_ALFA_Scope (N : Node_Id) is + procedure Add_Alfa_Scope (N : Node_Id) is E : constant Entity_Id := Defining_Entity (N); Loc : constant Source_Ptr := Sloc (E); Typ : Character; @@ -343,7 +344,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 ( + Alfa_Scope_Table.Append ( (Scope_Name => new String'(Unique_Name (E)), File_Num => 0, Scope_Num => 0, @@ -355,13 +356,13 @@ package body ALFA is From_Xref => 1, To_Xref => 0, Scope_Entity => E)); - end Add_ALFA_Scope; + end Add_Alfa_Scope; -------------------- - -- Add_ALFA_Xrefs -- + -- Add_Alfa_Xrefs -- -------------------- - procedure Add_ALFA_Xrefs is + procedure Add_Alfa_Xrefs is Cur_Scope_Idx : Scope_Index; From_Xref_Idx : Xref_Index; Cur_Entity : Entity_Id; @@ -455,10 +456,11 @@ package body ALFA is -- Second test: within same unit, sort by location of the scope of -- the entity definition. - elsif Get_Scope_Num (T1.Ent_Scope) /= - Get_Scope_Num (T2.Ent_Scope) + elsif Get_Scope_Num (T1.Key.Ent_Scope) /= + Get_Scope_Num (T2.Key.Ent_Scope) then - return Get_Scope_Num (T1.Ent_Scope) < Get_Scope_Num (T2.Ent_Scope); + return Get_Scope_Num (T1.Key.Ent_Scope) < + Get_Scope_Num (T2.Key.Ent_Scope); -- Third test: within same unit and scope, sort by location of -- entity definition. @@ -469,41 +471,47 @@ package body ALFA is -- Fourth test: if reference is in same unit as entity definition, -- sort first. - elsif T1.Lun /= T2.Lun and then T1.Ent_Scope_File = T1.Lun then + elsif + T1.Key.Lun /= T2.Key.Lun and then T1.Ent_Scope_File = T1.Key.Lun + then return True; - elsif T1.Lun /= T2.Lun and then T2.Ent_Scope_File = T2.Lun then + + elsif + T1.Key.Lun /= T2.Key.Lun and then T2.Ent_Scope_File = T2.Key.Lun + then return False; -- Fifth test: if reference is in same unit and same scope as entity -- definition, sort first. - elsif T1.Ent_Scope_File = T1.Lun - and then T1.Ref_Scope /= T2.Ref_Scope - and then T1.Ent_Scope = T1.Ref_Scope + elsif T1.Ent_Scope_File = T1.Key.Lun + and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope + and then T1.Key.Ent_Scope = T1.Key.Ref_Scope then return True; - elsif T1.Ent_Scope_File = T1.Lun - and then T1.Ref_Scope /= T2.Ref_Scope - and then T2.Ent_Scope = T2.Ref_Scope + elsif T1.Ent_Scope_File = T1.Key.Lun + and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope + and then T2.Key.Ent_Scope = T2.Key.Ref_Scope then return False; -- Sixth test: for same entity, sort by reference location unit - elsif T1.Lun /= T2.Lun then - return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun); + elsif T1.Key.Lun /= T2.Key.Lun then + return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun); -- Seventh test: for same entity, sort by reference location scope - elsif Get_Scope_Num (T1.Ref_Scope) /= - Get_Scope_Num (T2.Ref_Scope) + elsif Get_Scope_Num (T1.Key.Ref_Scope) /= + Get_Scope_Num (T2.Key.Ref_Scope) then - return Get_Scope_Num (T1.Ref_Scope) < Get_Scope_Num (T2.Ref_Scope); + return Get_Scope_Num (T1.Key.Ref_Scope) < + Get_Scope_Num (T2.Key.Ref_Scope); -- Eighth test: order of location within referencing unit - elsif T1.Loc /= T2.Loc then - return T1.Loc < T2.Loc; + elsif T1.Key.Loc /= T2.Key.Loc then + return T1.Key.Loc < T2.Key.Loc; -- Finally, for two locations at the same address prefer the one that -- does NOT have the type 'r', so that a modification or extension @@ -512,7 +520,7 @@ package body ALFA is -- in-out actuals, the read reference follows the modify reference. else - return T2.Typ = 'r'; + return T2.Key.Typ = 'r'; end if; end Lt; @@ -527,12 +535,12 @@ package body ALFA is Heap : Entity_Id; - -- Start of processing for Add_ALFA_Xrefs - begin + -- Start of processing for Add_Alfa_Xrefs - for J in ALFA_Scope_Table.First .. ALFA_Scope_Table.Last loop - Set_Scope_Num (N => ALFA_Scope_Table.Table (J).Scope_Entity, - Num => ALFA_Scope_Table.Table (J).Scope_Num); + begin + for J in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop + Set_Scope_Num (N => Alfa_Scope_Table.Table (J).Scope_Entity, + Num => Alfa_Scope_Table.Table (J).Scope_Num); end loop; -- Set up the pointer vector for the sort @@ -542,7 +550,7 @@ package body ALFA is end loop; -- Add dereferences to the set of regular references, by creating a - -- special "HEAP" variable for these special references. + -- special "Heap" variable for these special references. Name_Len := Name_Of_Heap_Variable'Length; Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable; @@ -558,39 +566,66 @@ package body ALFA is Set_Has_Fully_Qualified_Name (Heap); for J in Drefs.First .. Drefs.Last loop - Xrefs.Increment_Last; - Xrefs.Table (Xrefs.Last) := Drefs.Table (J); - Xrefs.Table (Xrefs.Last).Ent := Heap; + Xrefs.Append (Drefs.Table (J)); + + -- Set entity at this point with newly created "Heap" variable + + Xrefs.Table (Xrefs.Last).Key.Ent := Heap; Nrefs := Nrefs + 1; Rnums (Nrefs) := Xrefs.Last; end loop; - -- Eliminate entries not appropriate for ALFA. Done prior to sorting + -- Eliminate entries not appropriate for Alfa. 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). Eliminate_Before_Sort : declare NR : Nat; - function Is_ALFA_Scope (E : Entity_Id) return Boolean; + function Is_Alfa_Reference + (E : Entity_Id; + Typ : Character) return Boolean; + -- Return whether the reference is adequate for this entity + + function Is_Alfa_Scope (E : Entity_Id) return Boolean; -- Return whether the entity or reference scope is adequate 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 Alfa. + + ----------------------- + -- Is_Alfa_Reference -- + ----------------------- + + function Is_Alfa_Reference + (E : Entity_Id; + Typ : Character) return Boolean + is + begin + -- The only references of interest on callable entities are calls. + -- On non-callable entities, the only references of interest are + -- reads and writes. + + if Ekind (E) in Overloadable_Kind then + return Typ = 's'; + else + return Typ = 'r' or else Typ = 'm'; + end if; + end Is_Alfa_Reference; ------------------- - -- Is_ALFA_Scope -- + -- Is_Alfa_Scope -- ------------------- - function Is_ALFA_Scope (E : Entity_Id) return Boolean is + function Is_Alfa_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_Alfa_Scope; ------------------------ -- Is_Global_Constant -- @@ -609,11 +644,13 @@ package body ALFA is Nrefs := 0; for J in 1 .. NR loop - if ALFA_Entities (Ekind (Xrefs.Table (Rnums (J)).Ent)) - and then ALFA_References (Xrefs.Table (Rnums (J)).Typ) - and then Is_ALFA_Scope (Xrefs.Table (Rnums (J)).Ent_Scope) - and then Is_ALFA_Scope (Xrefs.Table (Rnums (J)).Ref_Scope) - and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Ent) + if Alfa_Entities (Ekind (Xrefs.Table (Rnums (J)).Key.Ent)) + and then Alfa_References (Xrefs.Table (Rnums (J)).Key.Typ) + and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ent_Scope) + and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ref_Scope) + and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Key.Ent) + and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Key.Ent, + Xrefs.Table (Rnums (J)).Key.Typ) then Nrefs := Nrefs + 1; Rnums (Nrefs) := Rnums (J); @@ -665,12 +702,12 @@ package body ALFA is Prevt := 'm'; for J in 1 .. NR loop - if Xrefs.Table (Rnums (J)).Loc /= Crloc + if Xrefs.Table (Rnums (J)).Key.Loc /= Crloc or else (Prevt = 'm' - and then Xrefs.Table (Rnums (J)).Typ = 'r') + and then Xrefs.Table (Rnums (J)).Key.Typ = 'r') then - Crloc := Xrefs.Table (Rnums (J)).Loc; - Prevt := Xrefs.Table (Rnums (J)).Typ; + Crloc := Xrefs.Table (Rnums (J)).Key.Loc; + Prevt := Xrefs.Table (Rnums (J)).Key.Typ; Nrefs := Nrefs + 1; Rnums (Nrefs) := Rnums (J); end if; @@ -683,7 +720,7 @@ package body ALFA is From_Xref_Idx := 1; Cur_Entity := Empty; - if ALFA_Scope_Table.Last = 0 then + if Alfa_Scope_Table.Last = 0 then return; end if; @@ -698,17 +735,17 @@ package body ALFA is function Cur_Scope return Node_Id; -- Return scope entity which corresponds to index Cur_Scope_Idx in - -- table ALFA_Scope_Table. + -- table Alfa_Scope_Table. function Get_Entity_Type (E : Entity_Id) return Character; -- Return a character representing the type of entity function Is_Future_Scope_Entity (E : Entity_Id) return Boolean; - -- Check whether entity E is in ALFA_Scope_Table at index + -- Check whether entity E is in Alfa_Scope_Table at index -- Cur_Scope_Idx or higher. function Is_Past_Scope_Entity (E : Entity_Id) return Boolean; - -- Check whether entity E is in ALFA_Scope_Table at index strictly + -- Check whether entity E is in Alfa_Scope_Table at index strictly -- lower than Cur_Scope_Idx. --------------- @@ -717,7 +754,7 @@ package body ALFA is function Cur_Scope return Node_Id is begin - return ALFA_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity; + return Alfa_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity; end Cur_Scope; --------------------- @@ -742,8 +779,8 @@ package body ALFA is function Is_Future_Scope_Entity (E : Entity_Id) return Boolean is begin - for J in Cur_Scope_Idx .. ALFA_Scope_Table.Last loop - if E = ALFA_Scope_Table.Table (J).Scope_Entity then + for J in Cur_Scope_Idx .. Alfa_Scope_Table.Last loop + if E = Alfa_Scope_Table.Table (J).Scope_Entity then return True; end if; end loop; @@ -763,8 +800,8 @@ package body ALFA is function Is_Past_Scope_Entity (E : Entity_Id) return Boolean is begin - for J in ALFA_Scope_Table.First .. Cur_Scope_Idx - 1 loop - if E = ALFA_Scope_Table.Table (J).Scope_Entity then + for J in Alfa_Scope_Table.First .. Cur_Scope_Idx - 1 loop + if E = Alfa_Scope_Table.Table (J).Scope_Entity then return True; end if; end loop; @@ -780,89 +817,83 @@ 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 Alfa scope table, which reveals either a problem in the -- construction of the scope table, or an erroneous scope for the -- current cross-reference. - pragma Assert (Is_Future_Scope_Entity (XE.Ent_Scope)); + pragma Assert (Is_Future_Scope_Entity (XE.Key.Ent_Scope)); -- Update the range of cross references to which the current scope -- refers to. This may be the empty range only for the first scope -- considered. - if XE.Ent_Scope /= Cur_Scope then - ALFA_Scope_Table.Table (Cur_Scope_Idx).From_Xref := + if XE.Key.Ent_Scope /= Cur_Scope then + Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx; - ALFA_Scope_Table.Table (Cur_Scope_Idx).To_Xref := - ALFA_Xref_Table.Last; - From_Xref_Idx := ALFA_Xref_Table.Last + 1; + Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := + Alfa_Xref_Table.Last; + From_Xref_Idx := Alfa_Xref_Table.Last + 1; end if; - while XE.Ent_Scope /= Cur_Scope loop + while XE.Key.Ent_Scope /= Cur_Scope loop Cur_Scope_Idx := Cur_Scope_Idx + 1; - pragma Assert (Cur_Scope_Idx <= ALFA_Scope_Table.Last); + pragma Assert (Cur_Scope_Idx <= Alfa_Scope_Table.Last); end loop; - if XE.Ent /= Cur_Entity then + if XE.Key.Ent /= Cur_Entity then Cur_Entity_Name := - new String'(Unique_Name (XE.Ent)); + new String'(Unique_Name (XE.Key.Ent)); end if; - if XE.Ent = Heap then - ALFA_Xref_Table.Append ( + if XE.Key.Ent = Heap then + Alfa_Xref_Table.Append ( (Entity_Name => Cur_Entity_Name, Entity_Line => 0, - Etype => Get_Entity_Type (XE.Ent), + Etype => Get_Entity_Type (XE.Key.Ent), Entity_Col => 0, - File_Num => Dependency_Num (XE.Lun), - Scope_Num => Get_Scope_Num (XE.Ref_Scope), - Line => Int (Get_Logical_Line_Number (XE.Loc)), - Rtype => XE.Typ, - Col => Int (Get_Column_Number (XE.Loc)))); + File_Num => Dependency_Num (XE.Key.Lun), + Scope_Num => Get_Scope_Num (XE.Key.Ref_Scope), + Line => Int (Get_Logical_Line_Number (XE.Key.Loc)), + Rtype => XE.Key.Typ, + Col => Int (Get_Column_Number (XE.Key.Loc)))); + else - ALFA_Xref_Table.Append ( + Alfa_Xref_Table.Append ( (Entity_Name => Cur_Entity_Name, Entity_Line => Int (Get_Logical_Line_Number (XE.Def)), - Etype => Get_Entity_Type (XE.Ent), + Etype => Get_Entity_Type (XE.Key.Ent), Entity_Col => Int (Get_Column_Number (XE.Def)), - File_Num => Dependency_Num (XE.Lun), - Scope_Num => Get_Scope_Num (XE.Ref_Scope), - Line => Int (Get_Logical_Line_Number (XE.Loc)), - Rtype => XE.Typ, - Col => Int (Get_Column_Number (XE.Loc)))); + File_Num => Dependency_Num (XE.Key.Lun), + Scope_Num => Get_Scope_Num (XE.Key.Ref_Scope), + Line => Int (Get_Logical_Line_Number (XE.Key.Loc)), + Rtype => XE.Key.Typ, + Col => Int (Get_Column_Number (XE.Key.Loc)))); end if; end Add_One_Xref; end loop; -- Update the range of cross references to which the scope refers to - ALFA_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx; - ALFA_Scope_Table.Table (Cur_Scope_Idx).To_Xref := ALFA_Xref_Table.Last; - end Add_ALFA_Xrefs; + Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx; + Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := Alfa_Xref_Table.Last; + end Add_Alfa_Xrefs; ------------------ - -- Collect_ALFA -- + -- Collect_Alfa -- ------------------ - procedure Collect_ALFA (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat) is + procedure Collect_Alfa (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat) is begin -- Cross-references should have been computed first pragma Assert (Xrefs.Last /= 0); - Initialize_ALFA_Tables; + Initialize_Alfa_Tables; - -- Generate file and scope ALFA information + -- Generate file and scope Alfa information for D in 1 .. Num_Sdep loop - - -- Ignore file for System - - if Units.Table (Sdep_Table (D)).Source_Index /= - System_Source_File_Index - then - Add_ALFA_File (U => Sdep_Table (D), D => D); - end if; + Add_Alfa_File (U => Sdep_Table (D), D => D); end loop; -- Fill in the spec information when relevant @@ -880,9 +911,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 Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop declare - Srec : ALFA_Scope_Record renames ALFA_Scope_Table.Table (S); + Srec : Alfa_Scope_Record renames Alfa_Scope_Table.Table (S); begin Entity_Hash_Table.Set (Srec.Scope_Entity, S); end; @@ -890,9 +921,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 Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop declare - Srec : ALFA_Scope_Record renames ALFA_Scope_Table.Table (S); + Srec : Alfa_Scope_Record renames Alfa_Scope_Table.Table (S); Spec_Entity : constant Entity_Id := Unique_Entity (Srec.Scope_Entity); @@ -907,24 +938,24 @@ package body ALFA is and then Spec_Scope /= 0 then Srec.Spec_File_Num := - ALFA_Scope_Table.Table (Spec_Scope).File_Num; + Alfa_Scope_Table.Table (Spec_Scope).File_Num; Srec.Spec_Scope_Num := - ALFA_Scope_Table.Table (Spec_Scope).Scope_Num; + Alfa_Scope_Table.Table (Spec_Scope).Scope_Num; end if; end; end loop; end; - -- Generate cross reference ALFA information + -- Generate cross reference Alfa information - Add_ALFA_Xrefs; - end Collect_ALFA; + Add_Alfa_Xrefs; + end Collect_Alfa; ------------------------------- - -- Detect_And_Add_ALFA_Scope -- + -- Detect_And_Add_Alfa_Scope -- ------------------------------- - procedure Detect_And_Add_ALFA_Scope (N : Node_Id) is + procedure Detect_And_Add_Alfa_Scope (N : Node_Id) is begin if Nkind_In (N, N_Subprogram_Declaration, N_Subprogram_Body, @@ -932,9 +963,9 @@ package body ALFA is N_Package_Declaration, N_Package_Body) then - Add_ALFA_Scope (N); + Add_Alfa_Scope (N); end if; - end Detect_And_Add_ALFA_Scope; + end Detect_And_Add_Alfa_Scope; ------------------------------------- -- Enclosing_Subprogram_Or_Package -- @@ -1045,22 +1076,22 @@ package body ALFA is Ref_Scope := Enclosing_Subprogram_Or_Package (N); - -- Entity is filled later on with the special "HEAP" variable + -- Entity is filled later on with the special "Heap" variable - Drefs.Table (Indx).Ent := Empty; + Drefs.Table (Indx).Key.Ent := Empty; Drefs.Table (Indx).Def := No_Location; - Drefs.Table (Indx).Loc := Ref; - Drefs.Table (Indx).Typ := Typ; + Drefs.Table (Indx).Key.Loc := Ref; + Drefs.Table (Indx).Key.Typ := Typ; - -- It is as if the special "HEAP" was defined in every scope where it + -- It is as if the special "Heap" was defined in every scope where it -- is referenced. - Drefs.Table (Indx).Eun := Get_Source_Unit (Ref); - Drefs.Table (Indx).Lun := Get_Source_Unit (Ref); + Drefs.Table (Indx).Key.Eun := Get_Source_Unit (Ref); + Drefs.Table (Indx).Key.Lun := Get_Source_Unit (Ref); - Drefs.Table (Indx).Ref_Scope := Ref_Scope; - Drefs.Table (Indx).Ent_Scope := Ref_Scope; + Drefs.Table (Indx).Key.Ref_Scope := Ref_Scope; + Drefs.Table (Indx).Key.Ent_Scope := Ref_Scope; Drefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ref_Scope); end if; end Generate_Dereference; @@ -1372,4 +1403,4 @@ package body ALFA is (Handled_Statement_Sequence (N), Process, Inside_Stubs); end Traverse_Subprogram_Body; -end ALFA; +end Alfa; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index b280ce5d4a7..2dbf5ff23d2 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -44,6 +44,7 @@ with Stand; use Stand; with Table; use Table; with GNAT.Heap_Sort_G; +with GNAT.HTable; package body Lib.Xref is @@ -56,16 +57,13 @@ package body Lib.Xref is subtype Xref_Entry_Number is Int; - type Xref_Entry is record + type Xref_Key is record + -- These are the components of Xref_Entry that participate in hash + -- lookups. + Ent : Entity_Id; -- Entity referenced (E parameter to Generate_Reference) - Def : Source_Ptr; - -- Original source location for entity being referenced. Note that these - -- values are used only during the output process, they are not set when - -- the entries are originally built. This is because private entities - -- can be swapped when the initial call is made. - Loc : Source_Ptr; -- Location of reference (Original_Location (Sloc field of N parameter -- to Generate_Reference). Set to No_Location for the case of a @@ -81,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 Alfa cross-references Ref_Scope : Entity_Id; -- Entity of the closest subprogram or package enclosing the reference @@ -89,9 +87,22 @@ package body Lib.Xref is Ent_Scope : Entity_Id; -- Entity of the closest subprogram or package enclosing the definition, -- which should be located in the same file as the definition itself. + end record; + + type Xref_Entry is record + Key : Xref_Key; Ent_Scope_File : Unit_Number_Type; -- File for entity Ent_Scope + + Def : Source_Ptr; + -- Original source location for entity being referenced. Note that these + -- values are used only during the output process, they are not set when + -- the entries are originally built. This is because private entities + -- can be swapped when the initial call is made. + + HTable_Next : Xref_Entry_Number; + -- For use only by Static_HTable end record; package Xrefs is new Table.Table ( @@ -102,11 +113,49 @@ package body Lib.Xref is Table_Increment => Alloc.Xrefs_Increment, Table_Name => "Xrefs"); + -------------- + -- Xref_Set -- + -------------- + + -- We keep a set of xref entries, in order to avoid inserting duplicate + -- entries into the above Xrefs table. An entry is in Xref_Set if and only + -- if it is in Xrefs. + + Num_Buckets : constant := 2**16; + + subtype Header_Num is Integer range 0 .. Num_Buckets - 1; + type Null_Type is null record; + pragma Unreferenced (Null_Type); + + function Hash (F : Xref_Entry_Number) return Header_Num; + + function Equal (F1, F2 : Xref_Entry_Number) return Boolean; + + procedure HT_Set_Next (E : Xref_Entry_Number; Next : Xref_Entry_Number); + + function HT_Next (E : Xref_Entry_Number) return Xref_Entry_Number; + + function Get_Key (E : Xref_Entry_Number) return Xref_Entry_Number; + + pragma Inline (Hash, Equal, HT_Set_Next, HT_Next, Get_Key); + + package Xref_Set is new GNAT.HTable.Static_HTable ( + Header_Num, + Element => Xref_Entry, + Elmt_Ptr => Xref_Entry_Number, + Null_Ptr => 0, + Set_Next => HT_Set_Next, + Next => HT_Next, + Key => Xref_Entry_Number, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + ---------------------- - -- ALFA Information -- + -- Alfa Information -- ---------------------- - package body ALFA is separate; + package body Alfa is separate; ------------------------ -- Local Subprograms -- @@ -121,14 +170,51 @@ package body Lib.Xref is function Lt (T1, T2 : Xref_Entry) return Boolean; -- Order cross-references + procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type); + -- Add an entry to the tables of Xref_Entries, avoiding duplicates + + --------------- + -- Add_Entry -- + --------------- + + procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type) is + begin + Xrefs.Increment_Last; -- tentative + Xrefs.Table (Xrefs.Last).Key := Key; + + -- Set the entry in Xref_Set, and if newly set, keep the above + -- tentative increment. + + if Xref_Set.Set_If_Not_Present (Xrefs.Last) then + Xrefs.Table (Xrefs.Last).Ent_Scope_File := Ent_Scope_File; + -- Leave Def and HTable_Next uninitialized + + Set_Has_Xref_Entry (Key.Ent); + + -- It was already in Xref_Set, so throw away the tentatively-added + -- entry + + else + Xrefs.Decrement_Last; + end if; + end Add_Entry; + + ----------- + -- Equal -- + ----------- + + function Equal (F1, F2 : Xref_Entry_Number) return Boolean is + Result : constant Boolean := + Xrefs.Table (F1).Key = Xrefs.Table (F2).Key; + begin + return Result; + end Equal; + ------------------------- -- Generate_Definition -- ------------------------- procedure Generate_Definition (E : Entity_Id) is - Loc : Source_Ptr; - Indx : Nat; - begin pragma Assert (Nkind (E) in N_Entity); @@ -159,22 +245,15 @@ package body Lib.Xref is and then In_Extended_Main_Source_Unit (E) and then not Is_Internal_Name (Chars (E)) then - Xrefs.Increment_Last; - Indx := Xrefs.Last; - Loc := Original_Location (Sloc (E)); - - Xrefs.Table (Indx).Ent := E; - Xrefs.Table (Indx).Typ := ' '; - Xrefs.Table (Indx).Def := No_Location; - Xrefs.Table (Indx).Loc := No_Location; - - Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc); - - Xrefs.Table (Indx).Ref_Scope := Empty; - Xrefs.Table (Indx).Ent_Scope := Empty; - Xrefs.Table (Indx).Ent_Scope_File := No_Unit; - - Set_Has_Xref_Entry (E); + Add_Entry + ((Ent => E, + Loc => No_Location, + Typ => ' ', + Eun => Get_Source_Unit (Original_Location (Sloc (E))), + Lun => No_Unit, + Ref_Scope => Empty, + Ent_Scope => Empty), + Ent_Scope_File => No_Unit); if In_Inlined_Body then Set_Referenced (E); @@ -294,14 +373,16 @@ package body Lib.Xref is Set_Ref : Boolean := True; Force : Boolean := False) is - Indx : Nat; Nod : Node_Id; Ref : Source_Ptr; Def : Source_Ptr; Ent : Entity_Id; - Ref_Scope : Entity_Id; - Ent_Scope : Entity_Id; + Actual_Typ : Character := Typ; + + Ref_Scope : Entity_Id; + Ent_Scope : Entity_Id; + Ent_Scope_File : Unit_Number_Type; Call : Node_Id; Formal : Entity_Id; @@ -865,34 +946,33 @@ package body Lib.Xref is Ref := Original_Location (Sloc (Nod)); Def := Original_Location (Sloc (Ent)); - Ref_Scope := ALFA.Enclosing_Subprogram_Or_Package (N); - Ent_Scope := ALFA.Enclosing_Subprogram_Or_Package (Ent); - - Xrefs.Increment_Last; - Indx := Xrefs.Last; - - Xrefs.Table (Indx).Loc := Ref; - - -- Overriding operations are marked with 'P' - - if Typ = 'p' + if Actual_Typ = 'p' and then Is_Subprogram (N) and then Present (Overridden_Operation (N)) then - Xrefs.Table (Indx).Typ := 'P'; - else - Xrefs.Table (Indx).Typ := Typ; + Actual_Typ := 'P'; end if; - Xrefs.Table (Indx).Eun := Get_Source_Unit (Def); - Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref); - Xrefs.Table (Indx).Ent := Ent; + if Alfa_Mode then + Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N); + Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent); + Ent_Scope_File := Get_Source_Unit (Ent_Scope); - Xrefs.Table (Indx).Ref_Scope := Ref_Scope; - Xrefs.Table (Indx).Ent_Scope := Ent_Scope; - Xrefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ent_Scope); + else + Ref_Scope := Empty; + Ent_Scope := Empty; + Ent_Scope_File := No_Unit; + end if; - Set_Has_Xref_Entry (Ent); + Add_Entry + ((Ent => Ent, + Loc => Ref, + Typ => Actual_Typ, + Eun => Get_Source_Unit (Def), + Lun => Get_Source_Unit (Ref), + Ref_Scope => Ref_Scope, + Ent_Scope => Ent_Scope), + Ent_Scope_File => Ent_Scope_File); end if; end Generate_Reference; @@ -957,6 +1037,49 @@ package body Lib.Xref is end loop; end Generate_Reference_To_Generic_Formals; + ------------- + -- Get_Key -- + ------------- + + function Get_Key (E : Xref_Entry_Number) return Xref_Entry_Number is + begin + return E; + end Get_Key; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Xref_Entry_Number) return Header_Num is + -- It is unlikely to have two references to the same entity at the same + -- source location, so the hash function depends only on the Ent and Loc + -- fields. + + XE : Xref_Entry renames Xrefs.Table (F); + type M is mod 2**32; + H : constant M := M'Mod (XE.Key.Ent) + 2**7 * M'Mod (XE.Key.Loc); + begin + return Header_Num (H mod Num_Buckets); + end Hash; + + ----------------- + -- HT_Set_Next -- + ----------------- + + procedure HT_Set_Next (E : Xref_Entry_Number; Next : Xref_Entry_Number) is + begin + Xrefs.Table (E).HTable_Next := Next; + end HT_Set_Next; + + ------------- + -- HT_Next -- + ------------- + + function HT_Next (E : Xref_Entry_Number) return Xref_Entry_Number is + begin + return Xrefs.Table (E).HTable_Next; + end HT_Next; + ---------------- -- Initialize -- ---------------- @@ -974,8 +1097,8 @@ package body Lib.Xref is begin -- First test: if entity is in different unit, sort by unit - if T1.Eun /= T2.Eun then - return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun); + if T1.Key.Eun /= T2.Key.Eun then + return Dependency_Num (T1.Key.Eun) < Dependency_Num (T2.Key.Eun); -- Second test: within same unit, sort by entity Sloc @@ -984,21 +1107,21 @@ package body Lib.Xref is -- Third test: sort definitions ahead of references - elsif T1.Loc = No_Location then + elsif T1.Key.Loc = No_Location then return True; - elsif T2.Loc = No_Location then + elsif T2.Key.Loc = No_Location then return False; -- Fourth test: for same entity, sort by reference location unit - elsif T1.Lun /= T2.Lun then - return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun); + elsif T1.Key.Lun /= T2.Key.Lun then + return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun); -- Fifth test: order of location within referencing unit - elsif T1.Loc /= T2.Loc then - return T1.Loc < T2.Loc; + elsif T1.Key.Loc /= T2.Key.Loc then + return T1.Key.Loc < T2.Key.Loc; -- Finally, for two locations at the same address, we prefer -- the one that does NOT have the type 'r' so that a modification @@ -1008,7 +1131,7 @@ package body Lib.Xref is -- the modify reference. else - return T2.Typ = 'r'; + return T2.Key.Typ = 'r'; end if; end Lt; @@ -1245,7 +1368,7 @@ package body Lib.Xref is begin for J in 1 .. Xrefs.Last loop - Ent := Xrefs.Table (J).Ent; + Ent := Xrefs.Table (J).Key.Ent; if Is_Type (Ent) and then Is_Tagged_Type (Ent) @@ -1283,9 +1406,7 @@ package body Lib.Xref is Handle_Orphan_Type_References : declare J : Nat; Tref : Entity_Id; - Indx : Nat; Ent : Entity_Id; - Loc : Source_Ptr; L, R : Character; pragma Warnings (Off, L); @@ -1302,18 +1423,20 @@ package body Lib.Xref is procedure New_Entry (E : Entity_Id) is begin - if Present (E) - and then not Has_Xref_Entry (E) + pragma Assert (Present (E)); + + if not Has_Xref_Entry (Implementation_Base_Type (E)) and then Sloc (E) > No_Location then - Xrefs.Increment_Last; - Indx := Xrefs.Last; - Loc := Original_Location (Sloc (E)); - Xrefs.Table (Indx).Ent := E; - Xrefs.Table (Indx).Loc := No_Location; - Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc); - Xrefs.Table (Indx).Lun := No_Unit; - Set_Has_Xref_Entry (E); + Add_Entry + ((Ent => E, + Loc => No_Location, + Typ => Character'First, + Eun => Get_Source_Unit (Original_Location (Sloc (E))), + Lun => No_Unit, + Ref_Scope => Empty, + Ent_Scope => Empty), + Ent_Scope_File => No_Unit); end if; end New_Entry; @@ -1326,7 +1449,7 @@ package body Lib.Xref is J := 1; while J <= Xrefs.Last loop - Ent := Xrefs.Table (J).Ent; + Ent := Xrefs.Table (J).Key.Ent; Get_Type_Reference (Ent, Tref, L, R); if Present (Tref) @@ -1393,15 +1516,15 @@ package body Lib.Xref is Prim := Parent_Op (Node (Op)); if Present (Prim) then - Xrefs.Increment_Last; - Indx := Xrefs.Last; - Loc := Original_Location (Sloc (Prim)); - Xrefs.Table (Indx).Ent := Prim; - Xrefs.Table (Indx).Loc := No_Location; - Xrefs.Table (Indx).Eun := - Get_Source_Unit (Sloc (Prim)); - Xrefs.Table (Indx).Lun := No_Unit; - Set_Has_Xref_Entry (Prim); + Add_Entry + ((Ent => Prim, + Loc => No_Location, + Typ => Character'First, + Eun => Get_Source_Unit (Sloc (Prim)), + Lun => No_Unit, + Ref_Scope => Empty, + Ent_Scope => Empty), + Ent_Scope_File => No_Unit); end if; Next_Elmt (Op); @@ -1418,9 +1541,8 @@ package body Lib.Xref is Output_Refs : declare - Nrefs : Nat := Xrefs.Last; - -- Number of references in table. This value may get reset (reduced) - -- when we eliminate duplicate reference entries. + Nrefs : constant Nat := Xrefs.Last; + -- Number of references in table Rnums : array (0 .. Nrefs) of Nat; -- This array contains numbers of references in the Xrefs table. @@ -1523,37 +1645,13 @@ package body Lib.Xref is for J in 1 .. Nrefs loop Rnums (J) := J; Xrefs.Table (J).Def := - Original_Location (Sloc (Xrefs.Table (J).Ent)); + Original_Location (Sloc (Xrefs.Table (J).Key.Ent)); end loop; -- Sort the references Sorting.Sort (Integer (Nrefs)); - -- Eliminate duplicate entries - - declare - NR : constant Nat := Nrefs; - - begin - -- We need this test for NR because if we force ALI file - -- generation in case of errors detected, it may be the case - -- that Nrefs is 0, so we should not reset it here - - if NR >= 2 then - Nrefs := 1; - - for J in 2 .. NR loop - if Xrefs.Table (Rnums (J)) /= - Xrefs.Table (Rnums (Nrefs)) - then - Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (J); - end if; - end loop; - end if; - end; - -- Initialize loop through references Curxu := No_Unit; @@ -1773,7 +1871,7 @@ package body Lib.Xref is -- Start of processing for Output_One_Ref begin - Ent := XE.Ent; + Ent := XE.Key.Ent; Ctyp := Xref_Entity_Letters (Ekind (Ent)); -- Skip reference if it is the only reference to an entity, @@ -1782,10 +1880,10 @@ package body Lib.Xref is -- consisting only of packages with END lines, where no -- entity from the package is actually referenced. - if XE.Typ = 'e' + if XE.Key.Typ = 'e' and then Ent /= Curent and then (Refno = Nrefs or else - Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent) + Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent) and then not In_Extended_Main_Source_Unit (Ent) then @@ -1795,7 +1893,7 @@ package body Lib.Xref is -- For private type, get full view type if Ctyp = '+' - and then Present (Full_View (XE.Ent)) + and then Present (Full_View (XE.Key.Ent)) then Ent := Underlying_Type (Ent); @@ -1813,15 +1911,15 @@ package body Lib.Xref is -- For variable reference, get corresponding type if Ctyp = '*' then - Ent := Etype (XE.Ent); + Ent := Etype (XE.Key.Ent); Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent))); -- If variable is private type, get full view type if Ctyp = '+' - and then Present (Full_View (Etype (XE.Ent))) + and then Present (Full_View (Etype (XE.Key.Ent))) then - Ent := Underlying_Type (Etype (XE.Ent)); + Ent := Underlying_Type (Etype (XE.Key.Ent)); if Present (Ent) then Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent))); @@ -1839,13 +1937,13 @@ package body Lib.Xref is -- Special handling for access parameters and objects of -- an anonymous access type. - if Ekind_In (Etype (XE.Ent), + if Ekind_In (Etype (XE.Key.Ent), E_Anonymous_Access_Type, E_Anonymous_Access_Subprogram_Type, E_Anonymous_Access_Protected_Subprogram_Type) then - if Is_Formal (XE.Ent) - or else Ekind_In (XE.Ent, E_Variable, E_Constant) + if Is_Formal (XE.Key.Ent) + or else Ekind_In (XE.Key.Ent, E_Variable, E_Constant) then Ctyp := 'p'; end if; @@ -1859,8 +1957,8 @@ package body Lib.Xref is -- Special handling for abstract types and operations - if Is_Overloadable (XE.Ent) - and then Is_Abstract_Subprogram (XE.Ent) + if Is_Overloadable (XE.Key.Ent) + and then Is_Abstract_Subprogram (XE.Key.Ent) then if Ctyp = 'U' then Ctyp := 'x'; -- Abstract procedure @@ -1869,10 +1967,10 @@ package body Lib.Xref is Ctyp := 'y'; -- Abstract function end if; - elsif Is_Type (XE.Ent) - and then Is_Abstract_Type (XE.Ent) + elsif Is_Type (XE.Key.Ent) + and then Is_Abstract_Type (XE.Key.Ent) then - if Is_Interface (XE.Ent) then + if Is_Interface (XE.Key.Ent) then Ctyp := 'h'; elsif Ctyp = 'R' then @@ -1887,41 +1985,42 @@ package body Lib.Xref is -- Suppress references to object definitions, used for local -- references. - or else XE.Typ = 'D' - or else XE.Typ = 'I' + or else XE.Key.Typ = 'D' + or else XE.Key.Typ = 'I' -- Suppress self references, except for bodies that act as -- specs. - or else (XE.Loc = XE.Def + or else (XE.Key.Loc = XE.Def and then - (XE.Typ /= 'b' - or else not Is_Subprogram (XE.Ent))) + (XE.Key.Typ /= 'b' + or else not Is_Subprogram (XE.Key.Ent))) -- Also suppress definitions of body formals (we only -- treat these as references, and the references were -- separately recorded). - or else (Is_Formal (XE.Ent) - and then Present (Spec_Entity (XE.Ent))) + or else (Is_Formal (XE.Key.Ent) + and then Present (Spec_Entity (XE.Key.Ent))) then null; else -- Start new Xref section if new xref unit - if XE.Eun /= Curxu then + if XE.Key.Eun /= Curxu then if Write_Info_Col > 1 then Write_Info_EOL; end if; - Curxu := XE.Eun; + Curxu := XE.Key.Eun; Write_Info_Initiate ('X'); Write_Info_Char (' '); - Write_Info_Nat (Dependency_Num (XE.Eun)); + Write_Info_Nat (Dependency_Num (XE.Key.Eun)); Write_Info_Char (' '); - Write_Info_Name (Reference_Name (Source_Index (XE.Eun))); + Write_Info_Name + (Reference_Name (Source_Index (XE.Key.Eun))); end if; -- Start new Entity line if new entity. Note that we @@ -1932,14 +2031,14 @@ package body Lib.Xref is if No (Curent) or else - (XE.Ent /= Curent + (XE.Key.Ent /= Curent and then - (Name_Change (XE.Ent) or else XE.Def /= Curdef)) + (Name_Change (XE.Key.Ent) or else XE.Def /= Curdef)) then - Curent := XE.Ent; + Curent := XE.Key.Ent; Curdef := XE.Def; - Get_Unqualified_Name_String (Chars (XE.Ent)); + Get_Unqualified_Name_String (Chars (XE.Key.Ent)); Curlen := Name_Len; Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen); @@ -2051,7 +2150,7 @@ package body Lib.Xref is declare Ent_Name : constant String := - Exact_Source_Name (Sloc (XE.Ent)); + Exact_Source_Name (Sloc (XE.Key.Ent)); begin for C in Ent_Name'Range loop Write_Info_Char (Ent_Name (C)); @@ -2060,22 +2159,22 @@ package body Lib.Xref is -- See if we have a renaming reference - if Is_Object (XE.Ent) - and then Present (Renamed_Object (XE.Ent)) + if Is_Object (XE.Key.Ent) + and then Present (Renamed_Object (XE.Key.Ent)) then - Rref := Renamed_Object (XE.Ent); + Rref := Renamed_Object (XE.Key.Ent); - elsif Is_Overloadable (XE.Ent) - and then Nkind (Parent (Declaration_Node (XE.Ent))) = - N_Subprogram_Renaming_Declaration + elsif Is_Overloadable (XE.Key.Ent) + and then Nkind (Parent (Declaration_Node (XE.Key.Ent))) + = N_Subprogram_Renaming_Declaration then - Rref := Name (Parent (Declaration_Node (XE.Ent))); + Rref := Name (Parent (Declaration_Node (XE.Key.Ent))); - elsif Ekind (XE.Ent) = E_Package - and then Nkind (Declaration_Node (XE.Ent)) = + elsif Ekind (XE.Key.Ent) = E_Package + and then Nkind (Declaration_Node (XE.Key.Ent)) = N_Package_Renaming_Declaration then - Rref := Name (Declaration_Node (XE.Ent)); + Rref := Name (Declaration_Node (XE.Key.Ent)); else Rref := Empty; @@ -2128,12 +2227,13 @@ package body Lib.Xref is -- Write out information about generic parent, if entity -- is an instance. - if Is_Generic_Instance (XE.Ent) then + if Is_Generic_Instance (XE.Key.Ent) then declare Gen_Par : constant Entity_Id := Generic_Parent (Specification - (Unit_Declaration_Node (XE.Ent))); + (Unit_Declaration_Node + (XE.Key.Ent))); Loc : constant Source_Ptr := Sloc (Gen_Par); Gen_U : constant Unit_Number_Type := Get_Source_Unit (Loc); @@ -2154,15 +2254,16 @@ package body Lib.Xref is -- See if we have a type reference and if so output - Check_Type_Reference (XE.Ent, False); + Check_Type_Reference (XE.Key.Ent, False); -- Additional information for types with progenitors - if Is_Record_Type (XE.Ent) - and then Present (Interfaces (XE.Ent)) + if Is_Record_Type (XE.Key.Ent) + and then Present (Interfaces (XE.Key.Ent)) then declare - Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent)); + Elmt : Elmt_Id := + First_Elmt (Interfaces (XE.Key.Ent)); begin while Present (Elmt) loop Check_Type_Reference (Node (Elmt), True); @@ -2173,11 +2274,11 @@ package body Lib.Xref is -- For array types, list index types as well. (This is -- not C, indexes have distinct types). - elsif Is_Array_Type (XE.Ent) then + elsif Is_Array_Type (XE.Key.Ent) then declare Indx : Node_Id; begin - Indx := First_Index (XE.Ent); + Indx := First_Index (XE.Key.Ent); while Present (Indx) loop Check_Type_Reference (First_Subtype (Etype (Indx)), True); @@ -2189,10 +2290,11 @@ package body Lib.Xref is -- If the entity is an overriding operation, write info -- on operation that was overridden. - if Is_Subprogram (XE.Ent) - and then Present (Overridden_Operation (XE.Ent)) + if Is_Subprogram (XE.Key.Ent) + and then Present (Overridden_Operation (XE.Key.Ent)) then - Output_Overridden_Op (Overridden_Operation (XE.Ent)); + Output_Overridden_Op + (Overridden_Operation (XE.Key.Ent)); end if; -- End of processing for entity output @@ -2204,13 +2306,13 @@ package body Lib.Xref is -- as the previous one, or it is a read-reference that -- indicates that the entity is an in-out actual in a call. - if XE.Loc /= No_Location + if XE.Key.Loc /= No_Location and then - (XE.Loc /= Crloc - or else (Prevt = 'm' and then XE.Typ = 'r')) + (XE.Key.Loc /= Crloc + or else (Prevt = 'm' and then XE.Key.Typ = 'r')) then - Crloc := XE.Loc; - Prevt := XE.Typ; + Crloc := XE.Key.Loc; + Prevt := XE.Key.Typ; -- Start continuation if line full, else blank @@ -2223,25 +2325,26 @@ package body Lib.Xref is -- Output file number if changed - if XE.Lun /= Curru then - Curru := XE.Lun; + if XE.Key.Lun /= Curru then + Curru := XE.Key.Lun; Write_Info_Nat (Dependency_Num (Curru)); Write_Info_Char ('|'); end if; - Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Loc))); - Write_Info_Char (XE.Typ); + Write_Info_Nat + (Int (Get_Logical_Line_Number (XE.Key.Loc))); + Write_Info_Char (XE.Key.Typ); - if Is_Overloadable (XE.Ent) - and then Is_Imported (XE.Ent) - and then XE.Typ = 'b' + if Is_Overloadable (XE.Key.Ent) + and then Is_Imported (XE.Key.Ent) + and then XE.Key.Typ = 'b' then - Output_Import_Export_Info (XE.Ent); + Output_Import_Export_Info (XE.Key.Ent); end if; - Write_Info_Nat (Int (Get_Column_Number (XE.Loc))); + Write_Info_Nat (Int (Get_Column_Number (XE.Key.Loc))); - Output_Instantiation_Refs (Sloc (XE.Ent)); + Output_Instantiation_Refs (Sloc (XE.Key.Ent)); end if; end if; end Output_One_Ref; @@ -2254,4 +2357,9 @@ package body Lib.Xref is end Output_Refs; end Output_References; +begin + -- Reset is necessary because Elmt_Ptr does not default to Null_Ptr, + -- because it's not an access type. + + Xref_Set.Reset; end Lib.Xref; diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index e8a4f3940a5..ecac26fabb3 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -28,7 +28,7 @@ with Einfo; use Einfo; with Lib.Util; use Lib.Util; -with Put_ALFA; +with Put_Alfa; package Lib.Xref is @@ -582,13 +582,13 @@ package Lib.Xref is -- in the pragma is "there". ---------------------- - -- ALFA Information -- + -- Alfa Information -- ---------------------- - -- This package defines procedures for collecting ALFA information and + -- This package defines procedures for collecting Alfa information and -- printing in ALI files. - package ALFA is + package Alfa is function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id; -- Return the closest enclosing subprogram of package @@ -610,17 +610,17 @@ package Lib.Xref is procedure Traverse_All_Compilation_Units (Process : Node_Processing); -- Call Process on all declarations through all compilation units - procedure Collect_ALFA (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat); - -- Collect ALFA information from library units (for files and scopes) + 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. + -- called Alfa. - 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 + 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. - end ALFA; + end Alfa; ----------------- -- Subprograms -- diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index c7e1d070d0f..13777bbf0c5 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -671,7 +671,12 @@ package body Make is -- Compiler, Binder & Linker Data and Subprograms -- ---------------------------------------------------- - Gcc : String_Access := Program_Name ("gcc", "gnatmake"); + Gcc : String_Access := Program_Name ("gcc", "gnatmake"); + Original_Gcc : constant String_Access := Gcc; + -- Original_Gcc is used to check if Gcc has been modified by a switch + -- --GCC=, so that for VM platforms, it is not modified again, as it can + -- result in incorrect error messages if the compiler cannot be found. + Gnatbind : String_Access := Program_Name ("gnatbind", "gnatmake"); Gnatlink : String_Access := Program_Name ("gnatlink", "gnatmake"); -- Default compiler, binder, linker programs @@ -5973,10 +5978,6 @@ package body Make is Gnatlink := Saved_Gnatlink; end if; - Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all); - Gnatbind_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all); - Gnatlink_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all); - Bad_Compilation.Init; -- If project files are used, create the mapping of all the sources, so @@ -6068,16 +6069,29 @@ package body Make is -- instead. Check_Object_Consistency := False; - Gcc := new String'("jvm-gnatcompile"); + + -- Do not modify Gcc is --GCC= was specified + + if Gcc = Original_Gcc then + Gcc := new String'("jvm-gnatcompile"); + end if; when Targparm.CLI_Target => - Gcc := new String'("dotnet-gnatcompile"); + -- Do not modify Gcc is --GCC= was specified + + if Gcc = Original_Gcc then + Gcc := new String'("dotnet-gnatcompile"); + end if; when Targparm.No_VM => raise Program_Error; end case; end if; + Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all); + Gnatbind_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all); + Gnatlink_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all); + -- If we have specified -j switch both from the project file -- and on the command line, the one from the command line takes -- precedence. diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index ed76923d5f0..809816d244c 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -38,6 +38,15 @@ package body Opt is SU : constant := Storage_Unit; -- Shorthand for System.Storage_Unit + -------------------------- + -- Full_Expander_Active -- + -------------------------- + + function Full_Expander_Active return Boolean is + begin + return Expander_Active and not Alfa_Mode; + end Full_Expander_Active; + ---------------------------------- -- Register_Opt_Config_Switches -- ---------------------------------- diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 96c868a9992..d2874d4ad49 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1868,16 +1868,23 @@ package Opt is -- Used to store the ASIS version number read from a tree file to check if -- it is the same as stored in the ASIS version number in Tree_IO. - ---------------------------------- - -- Mode for Formal Verification -- - ---------------------------------- + ----------------------------------- + -- Modes for Formal Verification -- + ----------------------------------- - -- This mode is currently defined through a debug flag - - ALFA_Mode : Boolean := False; + Alfa_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. + -- the Alfa subset of Ada. Set by debug flag -gnatd.F. + + function Full_Expander_Active return Boolean; + pragma Inline (Full_Expander_Active); + -- Returns the value of (Expander_Active and not Alfa_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 + -- expansion, see package Expander. For more information on reduced + -- Alfa expansion, see package Exp_Alfa. private diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index f2758ae125b..85b4024df8c 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -91,6 +91,12 @@ package body Ch4 is -- prefix. The current token is known to be an apostrophe and the -- following token is known to be RANGE. + function P_Unparen_Cond_Case_Quant_Expression return Node_Id; + -- This function is called with Token pointing to IF, CASE, or FOR, in a + -- context that allows a case, conditional, or quantified expression if + -- it is surrounded by parentheses. If not surrounded by parentheses, the + -- expression is still returned, but an error message is issued. + ------------------------- -- Bad_Range_Attribute -- ------------------------- @@ -470,8 +476,8 @@ package body Ch4 is end if; end if; - -- We come here with an OK attribute scanned, and the - -- corresponding Attribute identifier node stored in Ident_Node. + -- We come here with an OK attribute scanned, and corresponding + -- Attribute identifier node stored in Ident_Node. Prefix_Node := Name_Node; Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); @@ -658,7 +664,7 @@ package body Ch4 is Error_Msg ("expect identifier in parameter association", Sloc (Expr_Node)); - Scan; -- past arrow + Scan; -- past arrow elsif not Comma_Present then T_Right_Paren; @@ -1640,18 +1646,18 @@ package body Ch4 is -- This function is identical to the normal P_Expression, except that it -- also permits the appearance of a case, conditional, or quantified - -- expression without the usual surrounding parentheses. + -- expression if the call immediately follows a left paren, and followed + -- by a right parenthesis. These forms are allowed if these conditions + -- are not met, but an error message will be issued. function P_Expression_If_OK return Node_Id is begin - if Token = Tok_Case then - return P_Case_Expression; + -- Case of conditional, case or quantified expression - elsif Token = Tok_If then - return P_Conditional_Expression; + if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then + return P_Unparen_Cond_Case_Quant_Expression; - elsif Token = Tok_For then - return P_Quantified_Expression; + -- Normal case, not case/conditional/quantified expression else return P_Expression; @@ -1749,18 +1755,18 @@ package body Ch4 is end P_Expression_Or_Range_Attribute; -- Version that allows a non-parenthesized case, conditional, or quantified - -- expression + -- expression if the call immediately follows a left paren, and followed + -- by a right parenthesis. These forms are allowed if these conditions + -- are not met, but an error message will be issued. function P_Expression_Or_Range_Attribute_If_OK return Node_Id is begin - if Token = Tok_Case then - return P_Case_Expression; + -- Case of conditional, case or quantified expression - elsif Token = Tok_If then - return P_Conditional_Expression; + if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then + return P_Unparen_Cond_Case_Quant_Expression; - elsif Token = Tok_For then - return P_Quantified_Expression; + -- Normal case, not one of the above expression types else return P_Expression_Or_Range_Attribute; @@ -3059,4 +3065,54 @@ package body Ch4 is end if; end P_Membership_Test; + ------------------------------------------ + -- P_Unparen_Cond_Case_Quant_Expression -- + ------------------------------------------ + + function P_Unparen_Cond_Case_Quant_Expression return Node_Id is + Lparen : constant Boolean := Prev_Token = Tok_Left_Paren; + Result : Node_Id; + + begin + -- Case expression + + if Token = Tok_Case then + Result := P_Case_Expression; + + if not (Lparen and then Token = Tok_Right_Paren) then + Error_Msg_N + ("case expression must be parenthesized!", Result); + end if; + + -- Conditional expression + + elsif Token = Tok_If then + Result := P_Conditional_Expression; + + if not (Lparen and then Token = Tok_Right_Paren) then + Error_Msg_N + ("conditional expression must be parenthesized!", Result); + end if; + + -- Quantified expression + + elsif Token = Tok_For then + Result := P_Quantified_Expression; + + if not (Lparen and then Token = Tok_Right_Paren) then + Error_Msg_N + ("quantified expression must be parenthesized!", Result); + end if; + + -- No other possibility should exist (caller was supposed to check) + + else + raise Program_Error; + end if; + + -- Return expression (possibly after having given message) + + return Result; + end P_Unparen_Cond_Case_Quant_Expression; + end Ch4; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 97dd084302f..167f43e195b 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -1186,8 +1186,8 @@ package body Ch6 is -- FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION}) -- PARAMETER_SPECIFICATION ::= - -- DEFINING_IDENTIFIER_LIST : MODE [NULL_EXCLUSION] SUBTYPE_MARK - -- [:= DEFAULT_EXPRESSION] + -- DEFINING_IDENTIFIER_LIST : [ALIASED] MODE [NULL_EXCLUSION] + -- SUBTYPE_MARK [:= DEFAULT_EXPRESSION] -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION -- [:= DEFAULT_EXPRESSION] @@ -1195,6 +1195,8 @@ package body Ch6 is -- that the initial token is a left parenthesis, and skipped past it, so -- that on entry Token is the first token following the left parenthesis. + -- Note: The ALIASED keyword is allowed only in Ada 2012 mode (AI 142) + -- Error recovery: cannot raise Error_Resync function P_Formal_Part return List_Id is @@ -1235,9 +1237,11 @@ package body Ch6 is if Token /= Tok_Comma then - -- Assume colon if IN or OUT keyword found + -- Assume colon if ALIASED, IN or OUT keyword found - exit Ident_Loop when Token = Tok_In or else Token = Tok_Out; + exit Ident_Loop when Token = Tok_Aliased or else + Token = Tok_In or else + Token = Tok_Out; -- Otherwise scan ahead @@ -1303,6 +1307,18 @@ package body Ch6 is New_Node (N_Parameter_Specification, Ident_Sloc); Set_Defining_Identifier (Specification_Node, Idents (Ident)); + -- Scan possible ALIASED for Ada 2012 (AI-142) + + if Token = Tok_Aliased then + if Ada_Version < Ada_2012 then + Error_Msg_SC ("ALIASED parameter is an Ada2012 feature"); + else + Set_Aliased_Present (Specification_Node); + end if; + + Scan; -- past ALIASED + end if; + -- Scan possible NOT NULL for Ada 2005 (AI-231, AI-447) Not_Null_Sloc := Token_Ptr; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 111dee19b7b..5ab9f94a4a8 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1128,6 +1128,7 @@ begin Pragma_Default_Storage_Pool | Pragma_Dimension | Pragma_Discard_Names | + Pragma_Dispatching_Domain | Pragma_Eliminate | Pragma_Elaborate | Pragma_Elaborate_All | diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 39b8387fb36..0dbb7d988a7 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -691,8 +691,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- semicolon or comma, but does not consume this terminating token. function P_Expression_If_OK return Node_Id; - -- Scans out an expression in a context where a conditional expression - -- is permitted to appear without surrounding parentheses. + -- Scans out an expression allowing an unparenthesized case expression, + -- conditional expression, or quantified expression to appear without + -- enclosing parentheses. However, if such an expression is not preceded + -- by a left paren, and followed by a right paren, an error message will + -- be output noting that parenthesization is required. function P_Expression_No_Right_Paren return Node_Id; -- Scans out an expression in contexts where the expression cannot be @@ -702,6 +705,9 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Expression_Or_Range_Attribute_If_OK return Node_Id; -- Scans out an expression or range attribute where a conditional -- expression is permitted to appear without surrounding parentheses. + -- However, if such an expression is not preceded by a left paren, and + -- followed by a right paren, an error message will be output noting + -- that parenthesization is required. function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id; -- This routine scans out a qualified expression when the caller has diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 0f8608b359c..4dad66d0213 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -190,6 +190,7 @@ package body Prj.Attr is "Latrailing_required_switches#" & "Lapic_option#" & "Sapath_syntax#" & + "Lasource_file_switches#" & "Saobject_file_suffix#" & "Laobject_file_switches#" & "Lamulti_unit_switches#" & diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 76a028e66cd..ae1d0c6ed7a 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -162,12 +162,12 @@ package body Prj.Conf is -- configuration list. declare - Conf_List : String_List_Id := Conf_Attr.Value.Values; - Conf_Elem : String_Element; User_List : constant String_List_Id := User_Attr.Value.Values; - New_List : String_List_Id; - New_Elem : String_Element; + Conf_List : String_List_Id := Conf_Attr.Value.Values; + Conf_Elem : String_Element; + New_List : String_List_Id; + New_Elem : String_Element; begin -- Create new list @@ -525,7 +525,7 @@ package body Prj.Conf is if Proj.Project.Qualifier = Aggregate then declare List : Aggregated_Project_List := - Proj.Project.Aggregated_Projects; + Proj.Project.Aggregated_Projects; begin while List /= null loop Debug_Output @@ -549,12 +549,13 @@ package body Prj.Conf is ------------------ function Check_Target - (Config_File : Project_Id; + (Config_File : Project_Id; Autoconf_Specified : Boolean; - Project_Tree : Prj.Project_Tree_Ref; - Target : String := "") return Boolean + Project_Tree : Prj.Project_Tree_Ref; + Target : String := "") return Boolean is - Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; + Shared : constant Shared_Project_Tree_Data_Access := + Project_Tree.Shared; Variable : constant Variable_Value := Value_Of (Name_Target, Config_File.Decl.Attributes, Shared); @@ -712,6 +713,7 @@ package body Prj.Conf is ------------------------- function Get_Config_Switches return Argument_List_Access is + package Language_Htable is new GNAT.HTable.Simple_HTable (Header_Num => Prj.Header_Num, Element => Name_Id, @@ -731,6 +733,10 @@ package body Prj.Conf is -- Add all --config switches for this project. This is also called -- for aggregate projects. + ------------------------------------- + -- Add_Config_Switches_For_Project -- + ------------------------------------- + procedure Add_Config_Switches_For_Project (Project : Project_Id; Tree : Project_Tree_Ref; @@ -828,9 +834,9 @@ package body Prj.Conf is begin For_Every_Imported_Project - (By => Project, - Tree => Project_Tree, - With_State => Dummy, + (By => Project, + Tree => Project_Tree, + With_State => Dummy, Include_Aggregated => True); Name := Language_Htable.Get_First; @@ -859,10 +865,10 @@ package body Prj.Conf is declare Config_Command : constant String := - "--config=" & Get_Name_String (Name); + "--config=" & Get_Name_String (Name); Runtime_Name : constant String := - Runtime_Name_For (Name); + Runtime_Name_For (Name); begin if Variable = Nil_Variable_Value @@ -876,7 +882,7 @@ package body Prj.Conf is declare Compiler_Command : constant String := - Get_Name_String (Variable.Value); + Get_Name_String (Variable.Value); begin if Is_Absolute_Path (Compiler_Command) then @@ -1245,8 +1251,8 @@ package body Prj.Conf is end if; if Config_File_Path = null then - if (not Allow_Automatic_Generation) and then - Config_File_Name /= "" + if (not Allow_Automatic_Generation) + and then Config_File_Name /= "" then Raise_Invalid_Config ("could not locate main configuration project " @@ -1386,18 +1392,18 @@ package body Prj.Conf is Prj.Initialize (Project_Tree); - Main_Project := No_Project; + Main_Project := No_Project; Automatically_Generated := False; Prj.Part.Parse - (In_Tree => Project_Node_Tree, - Project => User_Project_Node, - Project_File_Name => Project_File_Name, - Errout_Handling => Prj.Part.Finalize_If_Error, - Packages_To_Check => Packages_To_Check, - Current_Directory => Current_Directory, - Is_Config_File => False, - Env => Env); + (In_Tree => Project_Node_Tree, + Project => User_Project_Node, + Project_File_Name => Project_File_Name, + Errout_Handling => Prj.Part.Finalize_If_Error, + Packages_To_Check => Packages_To_Check, + Current_Directory => Current_Directory, + Is_Config_File => False, + Env => Env); if User_Project_Node = Empty_Node then User_Project_Node := Empty_Node; @@ -1442,9 +1448,10 @@ package body Prj.Conf is On_Load_Config : Config_File_Hook := null; Reset_Tree : Boolean := True) is - Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; + Shared : constant Shared_Project_Tree_Data_Access := + Project_Tree.Shared; Main_Config_Project : Project_Id; - Success : Boolean; + Success : Boolean; begin Main_Project := No_Project; @@ -1468,10 +1475,10 @@ package body Prj.Conf is if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then declare Obj_Dir : constant Variable_Value := - Value_Of - (Name_Object_Dir, - Main_Project.Decl.Attributes, - Shared); + Value_Of + (Name_Object_Dir, + Main_Project.Decl.Attributes, + Shared); begin if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then @@ -1523,16 +1530,16 @@ package body Prj.Conf is -- Finish processing the user's project Prj.Proc.Process_Project_Tree_Phase_2 - (In_Tree => Project_Tree, - Project => Main_Project, - Success => Success, - From_Project_Node => User_Project_Node, - From_Project_Node_Tree => Project_Node_Tree, - Env => Env); + (In_Tree => Project_Tree, + Project => Main_Project, + Success => Success, + From_Project_Node => User_Project_Node, + From_Project_Node_Tree => Project_Node_Tree, + Env => Env); if Success then - if Project_Tree.Source_Info_File_Name /= null and then - not Project_Tree.Source_Info_File_Exists + if Project_Tree.Source_Info_File_Name /= null + and then not Project_Tree.Source_Info_File_Exists then Write_Source_Info_File (Project_Tree); end if; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 40f4ae5cb13..6cca2e22cc5 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -526,9 +526,10 @@ package body Prj.Env is while Element (Iter) /= No_Source loop Source := Element (Iter); - if Source.Index >= 1 - and then not Source.Locally_Removed + if not Source.Locally_Removed and then Source.Unit /= null + and then + (Source.Index >= 1 or else Source.Naming_Exception /= No) then Put (Source); end if; @@ -835,7 +836,23 @@ package body Prj.Env is or else Source.Unit /= No_Unit_Index) then if Source.Unit /= No_Unit_Index then - Get_Name_String (Source.Unit.Name); + + -- Put the encoded unit name in the name buffer + + declare + Uname : constant String := + Get_Name_String (Source.Unit.Name); + + begin + Name_Len := 0; + for J in Uname'Range loop + if Uname (J) in Upper_Half_Character then + Store_Encoded_Character (Get_Char_Code (Uname (J))); + else + Add_Char_To_Name_Buffer (Uname (J)); + end if; + end loop; + end; if Source.Language.Config.Kind = Unit_Based then @@ -861,8 +878,7 @@ package body Prj.Env is end case; if Suffix /= No_File then - Add_Str_To_Name_Buffer - (Get_Name_String (Suffix)); + Add_Str_To_Name_Buffer (Get_Name_String (Suffix)); end if; end if; @@ -889,6 +905,8 @@ package body Prj.Env is procedure For_Every_Imported_Project is new For_Every_Project_Imported (State => Integer, Action => Process); + -- Local variables + Dummy : Integer := 0; -- Start of processing for Create_Mapping_File @@ -1326,19 +1344,20 @@ package body Prj.Env is while Unit /= null loop if Unit.File_Names (Spec) /= null + and then not Unit.File_Names (Spec).Locally_Removed and then Unit.File_Names (Spec).File /= No_File and then (Namet.Get_Name_String - (Unit.File_Names (Spec).File) = Original_Name - or else (Unit.File_Names (Spec).Path /= - No_Path_Information + (Unit.File_Names (Spec).File) = Original_Name + or else (Unit.File_Names (Spec).Path /= No_Path_Information and then Namet.Get_Name_String - (Unit.File_Names (Spec).Path.Name) = - Original_Name)) + (Unit.File_Names (Spec).Path.Name) = + Original_Name)) then - Project := Ultimate_Extending_Project_Of - (Unit.File_Names (Spec).Project); + Project := + Ultimate_Extending_Project_Of + (Unit.File_Names (Spec).Project); Path := Unit.File_Names (Spec).Path.Display_Name; if Current_Verbosity > Default then @@ -1350,17 +1369,18 @@ package body Prj.Env is elsif Unit.File_Names (Impl) /= null and then Unit.File_Names (Impl).File /= No_File + and then not Unit.File_Names (Impl).Locally_Removed and then (Namet.Get_Name_String (Unit.File_Names (Impl).File) = Original_Name - or else (Unit.File_Names (Impl).Path /= - No_Path_Information - and then Namet.Get_Name_String - (Unit.File_Names (Impl).Path.Name) = - Original_Name)) + or else (Unit.File_Names (Impl).Path /= No_Path_Information + and then Namet.Get_Name_String + (Unit.File_Names (Impl).Path.Name) = + Original_Name)) then - Project := Ultimate_Extending_Project_Of - (Unit.File_Names (Impl).Project); + Project := + Ultimate_Extending_Project_Of + (Unit.File_Names (Impl).Project); Path := Unit.File_Names (Impl).Path.Display_Name; if Current_Verbosity > Default then diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 0f1699a579d..1a8c2114c47 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -252,13 +252,13 @@ package body Prj.Nmsc is Kind : Source_Kind; File_Name : File_Name_Type; Display_File : File_Name_Type; - Naming_Exception : Boolean := False; - Path : Path_Information := No_Path_Information; - Alternate_Languages : Language_List := null; - Unit : Name_Id := No_Name; - Index : Int := 0; - Locally_Removed : Boolean := False; - Location : Source_Ptr := No_Location); + Naming_Exception : Naming_Exception_Type := No; + Path : Path_Information := No_Path_Information; + Alternate_Languages : Language_List := null; + Unit : Name_Id := No_Name; + Index : Int := 0; + Locally_Removed : Boolean := False; + Location : Source_Ptr := No_Location); -- Add a new source to the different lists: list of all sources in the -- project tree, list of source of a project and list of sources of a -- language. If Path is specified, the file is also added to @@ -628,13 +628,13 @@ package body Prj.Nmsc is Kind : Source_Kind; File_Name : File_Name_Type; Display_File : File_Name_Type; - Naming_Exception : Boolean := False; - Path : Path_Information := No_Path_Information; - Alternate_Languages : Language_List := null; - Unit : Name_Id := No_Name; - Index : Int := 0; - Locally_Removed : Boolean := False; - Location : Source_Ptr := No_Location) + Naming_Exception : Naming_Exception_Type := No; + Path : Path_Information := No_Path_Information; + Alternate_Languages : Language_List := null; + Unit : Name_Id := No_Name; + Index : Int := 0; + Locally_Removed : Boolean := False; + Location : Source_Ptr := No_Location) is Config : constant Language_Config := Lang_Id.Config; UData : Unit_Index; @@ -725,7 +725,7 @@ package body Prj.Nmsc is -- file name in unrelated projects. elsif Is_Extending (Project, Source.Project) then - if not Locally_Removed then + if not Locally_Removed and then Naming_Exception /= Inherited then Source_To_Replace := Source; end if; @@ -854,14 +854,19 @@ package body Prj.Nmsc is if UData = No_Unit_Index then UData := new Unit_Data; UData.Name := Unit; - Units_Htable.Set (Data.Tree.Units_HT, Unit, UData); + + if Naming_Exception /= Inherited then + Units_Htable.Set (Data.Tree.Units_HT, Unit, UData); + end if; end if; Id.Unit := UData; -- Note that this updates Unit information as well - Override_Kind (Id, Kind); + if Naming_Exception /= Inherited then + Override_Kind (Id, Kind); + end if; end if; if Path /= No_Path_Information then @@ -1470,6 +1475,12 @@ package body Prj.Nmsc is Element.Value.Location, Project); end; + when Name_Source_File_Switches => + Put (Into_List => + Lang_Index.Config.Source_File_Switches, + From_List => Element.Value.Values, + In_Tree => Data.Tree); + when Name_Object_File_Suffix => if Get_Name_String (Element.Value.Value) = "" then Error_Msg @@ -2323,7 +2334,7 @@ package body Prj.Nmsc is when Name_Runtime_Source_Dir => - -- Attribute Runtime_Library_Dir (<language>) + -- Attribute Runtime_Source_Dir (<language>) Lang_Index.Config.Runtime_Source_Dir := Element.Value.Value; @@ -3708,7 +3719,7 @@ package body Prj.Nmsc is Kind => Kind, File_Name => File_Name, Display_File => File_Name_Type (Element.Value), - Naming_Exception => True, + Naming_Exception => Yes, Location => Element.Location); else @@ -3754,6 +3765,8 @@ package body Prj.Nmsc is File_Name : File_Name_Type; Source : Source_Id; + Naming_Exception : Naming_Exception_Type; + begin case Kind is when Impl | Sep => @@ -3781,7 +3794,7 @@ package body Prj.Nmsc is if Exceptions = No_Array_Element then Exceptions := Value_Of - (Name_Spec, + (Name_Specification, In_Arrays => Naming.Decl.Arrays, Shared => Shared); end if; @@ -3789,6 +3802,13 @@ package body Prj.Nmsc is while Exceptions /= No_Array_Element loop Element := Shared.Array_Elements.Table (Exceptions); + + if Element.Restricted then + Naming_Exception := Inherited; + else + Naming_Exception := Yes; + end if; + File_Name := Canonical_Case_File_Name (Element.Value.Value); Get_Name_String (Element.Index); @@ -3821,7 +3841,7 @@ package body Prj.Nmsc is Unit => Unit, Index => Index, Location => Element.Value.Location, - Naming_Exception => True); + Naming_Exception => Naming_Exception); end if; Exceptions := Element.Next; @@ -6320,7 +6340,7 @@ package body Prj.Nmsc is Source := Prj.Element (Iter); exit Source_Loop when Source = No_Source; - if Source.Naming_Exception then + if Source.Naming_Exception /= No then NL := Source_Names_Htable.Get (Project.Source_Names, Source.File); @@ -6332,12 +6352,14 @@ package body Prj.Nmsc is No_Name_Location); Remove_Source (Data.Tree, Source, No_Source); - Error_Msg_Name_1 := Name_Id (Source.File); - Error_Msg - (Data.Flags, - "? unknown source file %%", - NL.Location, - Project.Project); + if Source.Naming_Exception = Yes then + Error_Msg_Name_1 := Name_Id (Source.File); + Error_Msg + (Data.Flags, + "? unknown source file %%", + NL.Location, + Project.Project); + end if; Again := True; exit Source_Loop; @@ -6377,51 +6399,55 @@ package body Prj.Nmsc is -- the same file has received the full path, so we need to -- propagate it. - if Source.Naming_Exception - and then Source.Path = No_Path_Information - then - if Source.Unit /= No_Unit_Index then - Found := False; + if Source.Path = No_Path_Information then + if Source.Naming_Exception = Yes then + if Source.Unit /= No_Unit_Index then + Found := False; - if Source.Index /= 0 then -- Only multi-unit files - declare - S : Source_Id := - Source_Files_Htable.Get - (Data.Tree.Source_Files_HT, Source.File); - begin - while S /= null loop - if S.Path /= No_Path_Information then - Source.Path := S.Path; - Found := True; + if Source.Index /= 0 then -- Only multi-unit files + declare + S : Source_Id := + Source_Files_Htable.Get + (Data.Tree.Source_Files_HT, Source.File); - if Current_Verbosity = High then - Debug_Output - ("setting full path for " - & Get_Name_String (Source.File) - & " at" & Source.Index'Img - & " to " - & Get_Name_String (Source.Path.Name)); + begin + while S /= null loop + if S.Path /= No_Path_Information then + Source.Path := S.Path; + Found := True; + + if Current_Verbosity = High then + Debug_Output + ("setting full path for " + & Get_Name_String (Source.File) + & " at" & Source.Index'Img + & " to " + & Get_Name_String (Source.Path.Name)); + end if; + + exit; end if; - exit; - end if; + S := S.Next_With_File_Name; + end loop; + end; + end if; - S := S.Next_With_File_Name; - end loop; - end; + if not Found then + Error_Msg_Name_1 := Name_Id (Source.Display_File); + Error_Msg_Name_2 := Source.Unit.Name; + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "source file %% for unit %% not found", + No_Location, Project.Project); + end if; end if; - if not Found then - Error_Msg_Name_1 := Name_Id (Source.Display_File); - Error_Msg_Name_2 := Source.Unit.Name; - Error_Or_Warning - (Data.Flags, Data.Flags.Missing_Source_Files, - "source file %% for unit %% not found", - No_Location, Project.Project); + if Source.Path = No_Path_Information then + Remove_Source (Data.Tree, Source, No_Source); end if; - end if; - if Source.Path = No_Path_Information then + elsif Source.Naming_Exception = Inherited then Remove_Source (Data.Tree, Source, No_Source); end if; end if; @@ -6654,6 +6680,8 @@ package body Prj.Nmsc is -- If we had another file referencing the same unit (for instance it -- was in an extended project), that source file is in fact invisible -- from now on, and in particular doesn't belong to the same unit. + -- If the source is an inherited naming exception, then it may not + -- really exist: the source potentially replaced is left untouched. if Source.Unit.File_Names (Source.Kind) /= Source then Source.Unit.File_Names (Source.Kind).Unit := No_Unit_Index; @@ -6767,6 +6795,50 @@ package body Prj.Nmsc is Override_Kind (Name_Loc.Source, Sep); end if; end if; + + -- If this is an inherited naming exception, make sure that + -- the naming exception it replaces is no longer a source. + + if Name_Loc.Source.Naming_Exception = Inherited then + declare + Proj : Project_Id := Name_Loc.Source.Project.Extends; + Iter : Source_Iterator; + Src : Source_Id; + begin + while Proj /= No_Project loop + Iter := For_Each_Source (Data.Tree, Proj); + Src := Prj.Element (Iter); + while Src /= No_Source loop + if Src.File = Name_Loc.Source.File then + Src.Replaced_By := Name_Loc.Source; + exit; + end if; + + Next (Iter); + Src := Prj.Element (Iter); + end loop; + + Proj := Proj.Extends; + end loop; + end; + + if Name_Loc.Source.Unit /= No_Unit_Index then + if Name_Loc.Source.Kind = Spec then + Name_Loc.Source.Unit.File_Names (Spec) := + Name_Loc.Source; + + elsif Name_Loc.Source.Kind = Impl then + Name_Loc.Source.Unit.File_Names (Impl) := + Name_Loc.Source; + end if; + + Units_Htable.Set + (Data.Tree.Units_HT, + Name_Loc.Source.Unit.Name, + Name_Loc.Source.Unit); + end if; + + end if; end if; end if; end if; @@ -7511,7 +7583,9 @@ package body Prj.Nmsc is -- the same file it is expected that it has the same object) if Source /= No_Source + and then Source.Replaced_By = No_Source and then Source.Path /= Src.Path + and then Is_Extending (Src.Project, Source.Project) then Error_Msg_File_1 := Src.File; Error_Msg_File_2 := Source.File; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 8985e9711a3..3b07a804648 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -1037,8 +1037,8 @@ package body Prj.Part is Proj_Qualifier := Aggregate; Scan (In_Tree); - if Token = Tok_Identifier and then - Token_Name = Snames.Name_Library + if Token = Tok_Identifier + and then Token_Name = Snames.Name_Library then Proj_Qualifier := Aggregate_Library; Scan (In_Tree); diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 1a4ca34de02..b6049cc8936 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -398,69 +398,62 @@ package body Prj.Proc is Arr := Shared.Arrays.Table (A1); A1 := Arr.Next; - if not Restricted - or else - (Arr.Name /= Snames.Name_Body and then - Arr.Name /= Snames.Name_Spec and then - Arr.Name /= Snames.Name_Implementation and then - Arr.Name /= Snames.Name_Specification) - then - -- Remove the Next component + -- Remove the Next component - Arr.Next := No_Array; - Array_Table.Increment_Last (Shared.Arrays); + Arr.Next := No_Array; + Array_Table.Increment_Last (Shared.Arrays); - -- Create new Array declaration + -- Create new Array declaration - if To.Arrays = No_Array then - To.Arrays := Array_Table.Last (Shared.Arrays); - else - Shared.Arrays.Table (A2).Next := - Array_Table.Last (Shared.Arrays); - end if; + if To.Arrays = No_Array then + To.Arrays := Array_Table.Last (Shared.Arrays); + else + Shared.Arrays.Table (A2).Next := + Array_Table.Last (Shared.Arrays); + end if; - A2 := Array_Table.Last (Shared.Arrays); + A2 := Array_Table.Last (Shared.Arrays); - -- Don't store the array as its first element has not been set yet + -- Don't store the array as its first element has not been set yet - -- Copy the array elements of the array + -- Copy the array elements of the array - E1 := Arr.Value; - Arr.Value := No_Array_Element; - while E1 /= No_Array_Element loop + E1 := Arr.Value; + Arr.Value := No_Array_Element; + while E1 /= No_Array_Element loop - -- Copy the array element + -- Copy the array element - Elm := Shared.Array_Elements.Table (E1); - E1 := Elm.Next; + Elm := Shared.Array_Elements.Table (E1); + E1 := Elm.Next; - -- Remove the Next component + -- Remove the Next component - Elm.Next := No_Array_Element; + Elm.Next := No_Array_Element; - -- Change the location + Elm.Restricted := Restricted; - Elm.Value.Location := New_Loc; - Array_Element_Table.Increment_Last (Shared.Array_Elements); + -- Change the location - -- Create new array element + Elm.Value.Location := New_Loc; + Array_Element_Table.Increment_Last (Shared.Array_Elements); - if Arr.Value = No_Array_Element then - Arr.Value := - Array_Element_Table.Last (Shared.Array_Elements); - else - Shared.Array_Elements.Table (E2).Next := - Array_Element_Table.Last (Shared.Array_Elements); - end if; + -- Create new array element - E2 := Array_Element_Table.Last (Shared.Array_Elements); - Shared.Array_Elements.Table (E2) := Elm; - end loop; + if Arr.Value = No_Array_Element then + Arr.Value := Array_Element_Table.Last (Shared.Array_Elements); + else + Shared.Array_Elements.Table (E2).Next := + Array_Element_Table.Last (Shared.Array_Elements); + end if; - -- Finally, store the new array + E2 := Array_Element_Table.Last (Shared.Array_Elements); + Shared.Array_Elements.Table (E2) := Elm; + end loop; - Shared.Arrays.Table (A2) := Arr; - end if; + -- Finally, store the new array + + Shared.Arrays.Table (A2) := Arr; end loop; end Copy_Package_Declarations; @@ -1940,6 +1933,7 @@ package body Prj.Proc is Shared.Array_Elements.Table (Elem) := (Index => Index_Name, + Restricted => False, Src_Index => Source_Index, Index_Case_Sensitive => not Case_Insensitive (Current, Node_Tree), @@ -1992,7 +1986,7 @@ package body Prj.Proc is Var : Variable_Id := No_Variable; begin - -- First, find the list where to find the variable or attribute. + -- First, find the list where to find the variable or attribute if Is_Attribute then if Pkg /= No_Package then @@ -2009,7 +2003,7 @@ package body Prj.Proc is end if; end if; - -- Loop through the list, to find if it has already been declared. + -- Loop through the list, to find if it has already been declared while Var /= No_Variable and then Shared.Variable_Elements.Table (Var).Name /= Name @@ -2496,7 +2490,7 @@ package body Prj.Proc is Extended_By : Project_Id) is Shared : constant Shared_Project_Tree_Data_Access := - In_Tree.Shared; + In_Tree.Shared; Child_Env : Prj.Tree.Environment; -- Only used for the root aggregate project (if any). This is left @@ -2778,13 +2772,16 @@ package body Prj.Proc is return; end if; - Project := new Project_Data' - (Empty_Project - (Project_Qualifier_Of + Project := + new Project_Data' + (Empty_Project + (Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree))); - In_Tree.Projects := new Project_List_Element' - (Project => Project, - Next => In_Tree.Projects); + + In_Tree.Projects := + new Project_List_Element' + (Project => Project, + Next => In_Tree.Projects); Processed_Projects.Set (Name, Project); @@ -2834,10 +2831,12 @@ package body Prj.Proc is and then In_Tree.Is_Root_Tree then Initialize_And_Copy (Child_Env, Copy_From => Env); + else -- No need to initialize Child_Env, since it will not be -- used anyway by Process_Declarative_Items (only the root -- aggregate can modify it, and it is never read anyway). + null; end if; diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index deec6769e24..c1f9409de15 100644 --- a/gcc/ada/prj-util.adb +++ b/gcc/ada/prj-util.adb @@ -757,8 +757,11 @@ package body Prj.Util is elsif Name_Buffer (1 .. 2) = "I=" then Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len)); - elsif Name_Buffer (1 .. Name_Len) = "N=T" then - Info.Info.Naming_Exception := True; + elsif Name_Buffer (1 .. Name_Len) = "N=Y" then + Info.Info.Naming_Exception := Yes; + + elsif Name_Buffer (1 .. Name_Len) = "N=I" then + Info.Info.Naming_Exception := Inherited; else Report_Error; @@ -1116,8 +1119,11 @@ package body Prj.Util is -- Naming exception ("N=T"); - if Source.Naming_Exception then - Put_Line (File, "N=T"); + if Source.Naming_Exception = Yes then + Put_Line (File, "N=Y"); + + elsif Source.Naming_Exception = Inherited then + Put_Line (File, "N=I"); end if; -- Empty line to indicate end of info on this source diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads index cd2629db5c6..89a6491618f 100644 --- a/gcc/ada/prj-util.ads +++ b/gcc/ada/prj-util.ads @@ -208,9 +208,9 @@ package Prj.Util is Kind : Source_Kind; Display_Path_Name : Name_Id; Path_Name : Name_Id; - Unit_Name : Name_Id := No_Name; - Index : Int := 0; - Naming_Exception : Boolean := False; + Unit_Name : Name_Id := No_Name; + Index : Int := 0; + Naming_Exception : Naming_Exception_Type := No; end record; -- Data read from a source info file for a single source diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 6cd46d323ac..a9943ca773a 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -187,8 +187,9 @@ package Prj is No_Array_Element : constant Array_Element_Id := 0; type Array_Element is record Index : Name_Id; - Src_Index : Int := 0; - Index_Case_Sensitive : Boolean := True; + Restricted : Boolean := False; + Src_Index : Int := 0; + Index_Case_Sensitive : Boolean := True; Value : Variable_Value; Next : Array_Element_Id := No_Array_Element; end record; @@ -235,10 +236,10 @@ package Prj is -- packages) for a project or a package in a project. No_Declarations : constant Declarations := - (Variables => No_Variable, - Attributes => No_Variable, - Arrays => No_Array, - Packages => No_Package); + (Variables => No_Variable, + Attributes => No_Variable, + Arrays => No_Array, + Packages => No_Package); -- Default value of Declarations: indicates that there is no declarations type Package_Element is record @@ -447,6 +448,11 @@ package Prj is -- Value may be Canonical (Unix style) or Host (host syntax, for example -- on VMS for DEC C). + Source_File_Switches : Name_List_Index := No_Name_List; + -- Optional switches to be put before the source file. The source file + -- path name is appended to the last switch in the list. + -- Example: ("-i", ""); + Object_File_Suffix : Name_Id := No_Name; -- Optional alternate object file suffix @@ -575,11 +581,14 @@ package Prj is Include_Compatible_Languages => No_Name_List, Compiler_Driver => No_File, Compiler_Driver_Path => null, - Compiler_Leading_Required_Switches => No_Name_List, - Compiler_Trailing_Required_Switches => No_Name_List, + Compiler_Leading_Required_Switches + => No_Name_List, + Compiler_Trailing_Required_Switches + => No_Name_List, Multi_Unit_Switches => No_Name_List, Multi_Unit_Object_Separator => ' ', Path_Syntax => Canonical, + Source_File_Switches => No_Name_List, Object_File_Suffix => No_Name, Object_File_Switches => No_Name_List, Compilation_PIC_Option => No_Name_List, @@ -671,6 +680,8 @@ package Prj is -- corresponding to an Ada file). In general, these are dependencies that -- cannot be computed automatically by the builder. + type Naming_Exception_Type is (No, Yes, Inherited); + -- Structure to define source data type Source_Data is record @@ -783,7 +794,7 @@ package Prj is Switches_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Switches file time stamp - Naming_Exception : Boolean := False; + Naming_Exception : Naming_Exception_Type := No; -- True if the source has an exceptional name Duplicate_Unit : Boolean := False; @@ -832,7 +843,7 @@ package Prj is Switches => No_File, Switches_Path => No_Path, Switches_TS => Empty_Time_Stamp, - Naming_Exception => False, + Naming_Exception => No, Duplicate_Unit => False, Next_In_Lang => No_Source, Next_With_File_Name => No_Source, @@ -856,14 +867,6 @@ package Prj is Equal => "="); -- Mapping of source paths to source ids - package Unit_Sources_Htable is new Simple_HTable - (Header_Num => Header_Num, - Element => Source_Id, - No_Element => No_Source, - Key => Name_Id, - Hash => Hash, - Equal => "="); - type Lib_Kind is (Static, Dynamic, Relocatable); type Policy is (Autonomous, Compliant, Controlled, Restricted, Direct); @@ -1471,7 +1474,7 @@ package Prj is -- Unit name to Unit_Index (and from there to Source_Id) Source_Files_HT : Source_Files_Htable.Instance; - -- Base source file names to Source_Id list. + -- Base source file names to Source_Id list Source_Paths_HT : Source_Paths_Htable.Instance; -- Full path to Source_Id @@ -1485,7 +1488,7 @@ package Prj is -- True when a source info file has been successfully read Shared : Shared_Project_Tree_Data_Access; - -- The shared data for this tree and all aggregated trees. + -- The shared data for this tree and all aggregated trees Appdata : Project_Tree_Appdata_Access; -- Application-specific data for this tree @@ -1493,7 +1496,7 @@ package Prj is case Is_Root_Tree is when True => Shared_Data : aliased Shared_Project_Tree_Data; - -- Do not access directly, only through Shared. + -- Do not access directly, only through Shared when False => null; @@ -1853,39 +1856,39 @@ private end record; Gprbuild_Flags : constant Processing_Flags := - (Report_Error => null, - When_No_Sources => Warning, - Require_Sources_Other_Lang => True, - Allow_Duplicate_Basenames => False, - Compiler_Driver_Mandatory => True, - Error_On_Unknown_Language => True, - Require_Obj_Dirs => Error, - Allow_Invalid_External => Error, - Missing_Source_Files => Error, - Ignore_Missing_With => False); + (Report_Error => null, + When_No_Sources => Warning, + Require_Sources_Other_Lang => True, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => True, + Error_On_Unknown_Language => True, + Require_Obj_Dirs => Error, + Allow_Invalid_External => Error, + Missing_Source_Files => Error, + Ignore_Missing_With => False); Gprclean_Flags : constant Processing_Flags := - (Report_Error => null, - When_No_Sources => Warning, - Require_Sources_Other_Lang => True, - Allow_Duplicate_Basenames => False, - Compiler_Driver_Mandatory => True, - Error_On_Unknown_Language => True, - Require_Obj_Dirs => Warning, - Allow_Invalid_External => Error, - Missing_Source_Files => Error, - Ignore_Missing_With => False); + (Report_Error => null, + When_No_Sources => Warning, + Require_Sources_Other_Lang => True, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => True, + Error_On_Unknown_Language => True, + Require_Obj_Dirs => Warning, + Allow_Invalid_External => Error, + Missing_Source_Files => Error, + Ignore_Missing_With => False); Gnatmake_Flags : constant Processing_Flags := - (Report_Error => null, - When_No_Sources => Error, - Require_Sources_Other_Lang => False, - Allow_Duplicate_Basenames => False, - Compiler_Driver_Mandatory => False, - Error_On_Unknown_Language => False, - Require_Obj_Dirs => Error, - Allow_Invalid_External => Error, - Missing_Source_Files => Error, - Ignore_Missing_With => False); + (Report_Error => null, + When_No_Sources => Error, + Require_Sources_Other_Lang => False, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => False, + Error_On_Unknown_Language => False, + Require_Obj_Dirs => Error, + Allow_Invalid_External => Error, + Missing_Source_Files => Error, + Ignore_Missing_With => False); end Prj; diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index 2a3e5bc0d8d..6f87ba5a011 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -985,7 +985,6 @@ The following attributes can be defined in package @code{Naming}: other than Ada. They are indexed on the language name, and contain a list of file names respectively for headers and source code. - @end table @ifclear vms @@ -1315,7 +1314,6 @@ There are two main approaches to avoiding this duplication: more qualifiers). @end itemize - @c --------------------------------------------- @node Global Attributes @subsection Global Attributes @@ -1649,7 +1647,6 @@ Other library-related attributes can be used to change the defaults: upon this subsystem. @end table - @c --------------------------------------------- @node Using Library Projects @subsection Using Library Projects @@ -1873,7 +1870,6 @@ included in the library. must exist in the object directory. @end table - @c --------------------------------------------- @node Installing a library with project files @subsection Installing a library with project files @@ -2270,7 +2266,6 @@ aggregate project Agg is for Project_Files use ("myproject.gpr"); end Agg; - with "prj.gpr"; -- searched on Agg'Project_Path project MyProject is ... @@ -2777,7 +2772,6 @@ The current list of qualifiers is: It describes compilers and other tools to @code{gprbuild}. @end table - @c --------------------------------------------- @node Declarations @subsection Declarations @@ -3226,7 +3220,6 @@ A @b{context} may be one of the following: whose selector is a package name in that project. @end itemize - @c --------------------------------------------- @node Attributes @subsection Attributes @@ -3547,7 +3540,6 @@ end MyProj; @noindent - @menu * gnatmake and Project Files:: * The GNAT Driver and Project Files:: @@ -4049,7 +4041,6 @@ When a library project file is specified, switches ^-b^/ACTION=BIND^ and (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 @@ -4490,6 +4481,3 @@ The switches for GPRclean are: @item @option{-Xnm=val} : Specify an external reference for Project Files. @end itemize - - - diff --git a/gcc/ada/put_alfa.adb b/gcc/ada/put_alfa.adb index 20a37d9330f..adb41a8397f 100644 --- a/gcc/ada/put_alfa.adb +++ b/gcc/ada/put_alfa.adb @@ -23,15 +23,15 @@ -- -- ------------------------------------------------------------------------------ -with ALFA; use ALFA; +with Alfa; use Alfa; -procedure Put_ALFA is +procedure Put_Alfa is begin - -- Loop through entries in ALFA_File_Table + -- Loop through entries in Alfa_File_Table - for J in 1 .. ALFA_File_Table.Last loop + for J in 1 .. Alfa_File_Table.Last loop declare - F : ALFA_File_Record renames ALFA_File_Table.Table (J); + F : Alfa_File_Record renames Alfa_File_Table.Table (J); Start : Scope_Index; Stop : Scope_Index; @@ -39,19 +39,17 @@ begin Start := F.From_Scope; Stop := F.To_Scope; - if Start <= Stop then - Write_Info_Initiate ('F'); - Write_Info_Char ('D'); - Write_Info_Char (' '); - Write_Info_Nat (F.File_Num); - Write_Info_Char (' '); + Write_Info_Initiate ('F'); + Write_Info_Char ('D'); + Write_Info_Char (' '); + Write_Info_Nat (F.File_Num); + Write_Info_Char (' '); - for N in F.File_Name'Range loop - Write_Info_Char (F.File_Name (N)); - end loop; + for N in F.File_Name'Range loop + Write_Info_Char (F.File_Name (N)); + end loop; - Write_Info_Terminate; - end if; + Write_Info_Terminate; -- Loop through scope entries for this file @@ -60,7 +58,7 @@ begin pragma Assert (Start <= Stop); declare - S : ALFA_Scope_Record renames ALFA_Scope_Table.Table (Start); + S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Start); begin Write_Info_Initiate ('F'); @@ -98,11 +96,11 @@ begin end; end loop; - -- Loop through entries in ALFA_File_Table + -- Loop through entries in Alfa_File_Table - for J in 1 .. ALFA_File_Table.Last loop + for J in 1 .. Alfa_File_Table.Last loop declare - F : ALFA_File_Record renames ALFA_File_Table.Table (J); + F : Alfa_File_Record renames Alfa_File_Table.Table (J); Start : Scope_Index; Stop : Scope_Index; File : Nat; @@ -121,7 +119,7 @@ begin pragma Assert (Start <= Stop); Output_One_Scope : declare - S : ALFA_Scope_Record renames ALFA_Scope_Table.Table (Start); + S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Start); XStart : Xref_Index; XStop : Xref_Index; @@ -166,8 +164,8 @@ begin pragma Assert (XStart <= XStop); Output_One_Xref : declare - R : ALFA_Xref_Record renames - ALFA_Xref_Table.Table (XStart); + R : Alfa_Xref_Record renames + Alfa_Xref_Table.Table (XStart); begin if R.Entity_Line /= Entity_Line @@ -229,4 +227,4 @@ begin end loop; end; end loop; -end Put_ALFA; +end Put_Alfa; diff --git a/gcc/ada/put_alfa.ads b/gcc/ada/put_alfa.ads index 70db554e2f8..aee4ec384dd 100644 --- a/gcc/ada/put_alfa.ads +++ b/gcc/ada/put_alfa.ads @@ -23,8 +23,8 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the function used to read ALFA information from the --- internal tables defined in package ALFA, and output text information for +-- 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. @@ -52,7 +52,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 +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. diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb index 4706c0045b1..1ff3cb3aefd 100644 --- a/gcc/ada/put_scos.adb +++ b/gcc/ada/put_scos.adb @@ -28,7 +28,11 @@ with SCOs; use SCOs; with Snames; use Snames; procedure Put_SCOs is - Ctr : Nat; + Current_SCO_Unit : SCO_Unit_Index := 0; + -- Initial value must not be a valid unit index + + procedure Write_SCO_Initiate (SU : SCO_Unit_Index); + -- Start SCO line for unit SU, also emitting SCO unit header if necessary procedure Output_Range (T : SCO_Table_Entry); -- Outputs T.From and T.To in line:col-line:col format @@ -72,10 +76,35 @@ procedure Put_SCOs is end loop; end Output_String; + ------------------------ + -- Write_SCO_Initiate -- + ------------------------ + + procedure Write_SCO_Initiate (SU : SCO_Unit_Index) is + SUT : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (SU); + + begin + if Current_SCO_Unit /= SU then + Write_Info_Initiate ('C'); + Write_Info_Char (' '); + Write_Info_Nat (SUT.Dep_Num); + Write_Info_Char (' '); + + Output_String (SUT.File_Name.all); + + Write_Info_Terminate; + + Current_SCO_Unit := SU; + end if; + + Write_Info_Initiate ('C'); + end Write_SCO_Initiate; + -- Start of processing for Put_SCOs begin - -- Loop through entries in SCO_Unit_Table + -- Loop through entries in SCO_Unit_Table. Note that entry 0 is by + -- convention present but unused. for U in 1 .. SCO_Unit_Table.Last loop declare @@ -88,19 +117,6 @@ begin Start := SUT.From; Stop := SUT.To; - -- Write unit header (omitted if no SCOs are generated for this unit) - - if Start <= Stop then - Write_Info_Initiate ('C'); - Write_Info_Char (' '); - Write_Info_Nat (SUT.Dep_Num); - Write_Info_Char (' '); - - Output_String (SUT.File_Name.all); - - Write_Info_Terminate; - end if; - -- Loop through SCO entries for this unit loop @@ -111,6 +127,9 @@ begin T : SCO_Table_Entry renames SCO_Table.Table (Start); Continuation : Boolean; + Ctr : Nat; + -- Counter for statement entries + begin case T.C1 is @@ -127,7 +146,7 @@ begin end if; if Ctr = 0 then - Write_Info_Initiate ('C'); + Write_SCO_Initiate (U); if not Continuation then Write_Info_Char ('S'); Continuation := True; @@ -204,7 +223,7 @@ begin -- For all other cases output decision line else - Write_Info_Initiate ('C'); + Write_SCO_Initiate (U); Write_Info_Char (T.C1); if T.C1 /= 'X' then diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index 6ea59ae1990..0ced5598c14 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -35,14 +35,6 @@ #ifdef IN_RTS #include "tconfig.h" #include "tsystem.h" -/* In the top-of-tree GCC, tconfig does not include tm.h, but in GCC 3.2 - it does. To avoid branching raise.c just for that purpose, we kludge by - looking for a symbol always defined by tm.h and if it's not defined, - we include it. */ -#ifndef FIRST_PSEUDO_REGISTER -#include "coretypes.h" -#include "tm.h" -#endif #include <sys/stat.h> #include <stdarg.h> typedef char bool; @@ -217,7 +209,7 @@ db (int db_code, char * msg_format, ...) static void db_phases (int phases) { - phase_descriptor *a = phase_descriptors; + const phase_descriptor *a = phase_descriptors; if (! (db_accepted_codes() & DB_PHASES)) return; @@ -901,6 +893,7 @@ is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception) static void get_action_description_for (_Unwind_Context *uw_context, _Unwind_Exception *uw_exception, + _Unwind_Action uw_phase, region_descriptor *region, action_descriptor *action) { @@ -965,17 +958,22 @@ get_action_description_for (_Unwind_Context *uw_context, /* Positive filters are for regular handlers. */ else if (ar_filter > 0) { - /* See if the filter we have is for an exception which matches - the one we are propagating. */ - _Unwind_Ptr choice = get_ttype_entry_for (region, ar_filter); - - if (is_handled_by (choice, gnat_exception)) - { - action->kind = handler; - action->ttype_filter = ar_filter; - action->ttype_entry = choice; - return; - } + /* Do not catch an exception if the _UA_FORCE_UNWIND flag is + passed (to follow the ABI). */ + if (!(uw_phase & _UA_FORCE_UNWIND)) + { + /* See if the filter we have is for an exception which + matches the one we are propagating. */ + _Unwind_Ptr choice = get_ttype_entry_for (region, ar_filter); + + if (is_handled_by (choice, gnat_exception)) + { + action->kind = handler; + action->ttype_filter = ar_filter; + action->ttype_entry = choice; + return; + } + } } /* Negative filter values are for C++ exception specifications. @@ -1001,11 +999,6 @@ setup_to_install (_Unwind_Context *uw_context, _Unwind_Ptr uw_landing_pad, int uw_filter) { -#ifndef EH_RETURN_DATA_REGNO - /* We should not be called if the appropriate underlying support is not - there. */ - abort (); -#else /* 1/ exception object pointer, which might be provided back to _Unwind_Resume (and thus to this personality routine) if we are jumping to a cleanup. */ @@ -1020,7 +1013,6 @@ setup_to_install (_Unwind_Context *uw_context, /* Setup the address we should jump at to reach the code where there is the "something" we found. */ _Unwind_SetIP (uw_context, uw_landing_pad); -#endif } /* The following is defined from a-except.adb. Its purpose is to enable @@ -1128,7 +1120,8 @@ PERSONALITY_FUNCTION (version_arg_t version_arg, /* Search the call-site and action-record tables for the action associated with this IP. */ - get_action_description_for (uw_context, uw_exception, ®ion, &action); + get_action_description_for (uw_context, uw_exception, uw_phases, + ®ion, &action); db_action_for (&action, uw_context); /* Whatever the phase, if there is nothing relevant in this frame, diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index acb1cf1260b..1bfe1568d71 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -117,7 +117,7 @@ package body Restrict is Msg_Issued : Boolean; Save_Error_Msg_Sloc : Source_Ptr; begin - if Force or else Comes_From_Source (N) then + if Force or else Comes_From_Source (Original_Node (N)) then if Restriction_Check_Required (SPARK) and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) @@ -145,7 +145,7 @@ package body Restrict is begin pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\'); - if Comes_From_Source (N) then + if Comes_From_Source (Original_Node (N)) then if Restriction_Check_Required (SPARK) and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) @@ -375,12 +375,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 Alfa 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 Alfa_Mode then return; end if; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index d4b07a97db1..bb963d097e8 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -321,6 +321,10 @@ package body Rtsfind is elsif U_Id in System_Child then Name_Buffer (7) := '.'; + if U_Id in System_Multiprocessors_Child then + Name_Buffer (23) := '.'; + end if; + if U_Id in System_Storage_Pools_Child then Name_Buffer (21) := '.'; end if; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index d262e86cae1..bc5556904fc 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -371,6 +371,10 @@ package Rtsfind is System_WWd_Enum, System_WWd_Wchar, + -- Children of System.Multiprocessors + + System_Multiprocessors_Dispatching_Domains, + -- Children of System.Storage_Pools System_Storage_Pools_Subpools, @@ -440,6 +444,11 @@ package Rtsfind is range System_Address_Image .. System_Tasking_Stages; -- Range of values for children or grandchildren of System + subtype System_Multiprocessors_Child is RTU_Id + range System_Multiprocessors_Dispatching_Domains .. + System_Multiprocessors_Dispatching_Domains; + -- Range of values for children of System.Multiprocessors + subtype System_Storage_Pools_Child is RTU_Id range System_Storage_Pools_Subpools .. System_Storage_Pools_Subpools; @@ -546,6 +555,7 @@ package Rtsfind is RE_Root_Stream_Type, -- Ada.Streams RE_Stream_Element, -- Ada.Streams + RE_Stream_Element_Offset, -- Ada.Streams RE_Stream_Access, -- Ada.Streams.Stream_IO @@ -803,6 +813,7 @@ package Rtsfind is RE_Finalization_Master_Ptr, -- System.Finalization_Masters RE_Set_Base_Pool, -- System.Finalization_Masters RE_Set_Finalize_Address, -- System.Finalization_Masters + RE_Set_Is_Heterogeneous, -- System.Finalization_Masters RE_Root_Controlled, -- System.Finalization_Root RE_Root_Controlled_Ptr, -- System.Finalization_Root @@ -1445,6 +1456,8 @@ package Rtsfind is RE_Unspecified_CPU, -- System.Tasking + RE_Dispatching_Domain_Access, -- System.Tasking + RE_Abort_Defer, -- System.Soft_Links RE_Abort_Undefer, -- System.Soft_Links RE_Complete_Master, -- System.Soft_Links @@ -1587,6 +1600,8 @@ package Rtsfind is RE_Width_Wide_Character, -- System.Wid_WChar RE_Width_Wide_Wide_Character, -- System.Wid_WChar + RE_Dispatching_Domain, -- Dispatching_Domains + RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries RE_Protection_Entries, -- Tasking.Protected_Objects.Entries RE_Protection_Entries_Access, -- Tasking.Protected_Objects.Entries @@ -1734,6 +1749,7 @@ package Rtsfind is RE_Root_Stream_Type => Ada_Streams, RE_Stream_Element => Ada_Streams, + RE_Stream_Element_Offset => Ada_Streams, RE_Stream_Access => Ada_Streams_Stream_IO, @@ -1991,6 +2007,7 @@ package Rtsfind is RE_Finalization_Master_Ptr => System_Finalization_Masters, RE_Set_Base_Pool => System_Finalization_Masters, RE_Set_Finalize_Address => System_Finalization_Masters, + RE_Set_Is_Heterogeneous => System_Finalization_Masters, RE_Root_Controlled => System_Finalization_Root, RE_Root_Controlled_Ptr => System_Finalization_Root, @@ -2633,6 +2650,8 @@ package Rtsfind is RE_Unspecified_CPU => System_Tasking, + RE_Dispatching_Domain_Access => System_Tasking, + RE_Abort_Defer => System_Soft_Links, RE_Abort_Undefer => System_Soft_Links, RE_Complete_Master => System_Soft_Links, @@ -2776,6 +2795,9 @@ package Rtsfind is RE_Width_Wide_Character => System_Wid_WChar, RE_Width_Wide_Wide_Character => System_Wid_WChar, + RE_Dispatching_Domain => + System_Multiprocessors_Dispatching_Domains, + RE_Protected_Entry_Body_Array => System_Tasking_Protected_Objects_Entries, RE_Protection_Entries => diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb index 898081c1f26..68a4ac30d04 100644 --- a/gcc/ada/s-htable.adb +++ b/gcc/ada/s-htable.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2010, AdaCore -- +-- Copyright (C) 1995-2011, 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- -- @@ -121,6 +121,15 @@ package body System.HTable is return Iterator_Ptr; end Get_Non_Null; + ------------- + -- Present -- + ------------- + + function Present (K : Key) return Boolean is + begin + return Get (K) /= Null_Ptr; + end Present; + ------------ -- Remove -- ------------ @@ -181,6 +190,32 @@ package body System.HTable is Table (Index) := E; end Set; + ------------------------ + -- Set_If_Not_Present -- + ------------------------ + + function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is + K : constant Key := Get_Key (E); + Index : constant Header_Num := Hash (K); + Elmt : Elmt_Ptr := Table (Index); + + begin + loop + if Elmt = Null_Ptr then + Set_Next (E, Table (Index)); + Table (Index) := E; + + return True; + + elsif Equal (Get_Key (Elmt), K) then + return False; + + else + Elmt := Next (Elmt); + end if; + end loop; + end Set_If_Not_Present; + end Static_HTable; ------------------- diff --git a/gcc/ada/s-htable.ads b/gcc/ada/s-htable.ads index 58def27b1b4..29fb5fbd163 100644 --- a/gcc/ada/s-htable.ads +++ b/gcc/ada/s-htable.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2010, AdaCore -- +-- Copyright (C) 1995-2011, 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- -- @@ -183,6 +183,14 @@ package System.HTable is -- Returns the latest inserted element pointer with the given Key -- or null if none. + function Present (K : Key) return Boolean; + -- True if an element whose Get_Key is K is in the table + + function Set_If_Not_Present (E : Elmt_Ptr) return Boolean; + -- If Present (Get_Key (E)), returns False. Otherwise, does Set (E), and + -- then returns True. Present (Get_Key (E)) is always True afterward, + -- and the result True indicates E is newly Set. + procedure Remove (K : Key); -- Removes the latest inserted element pointer associated with the -- given key if any, does nothing if none. diff --git a/gcc/ada/s-mudido-affinity.adb b/gcc/ada/s-mudido-affinity.adb new file mode 100644 index 00000000000..35239b87c50 --- /dev/null +++ b/gcc/ada/s-mudido-affinity.adb @@ -0,0 +1,386 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Body used on targets where the operating system supports setting task +-- affinities. + +with System.Tasking.Initialization; +with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; + +with Ada.Unchecked_Conversion; + +package body System.Multiprocessors.Dispatching_Domains is + + package ST renames System.Tasking; + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Convert_Ids is new + Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, ST.Task_Id); + + procedure Unchecked_Set_Affinity + (Domain : ST.Dispatching_Domain_Access; + CPU : CPU_Range; + T : ST.Task_Id); + -- Internal procedure to move a task to a target domain and CPU. No checks + -- are performed about the validity of the domain and the CPU because they + -- are done by the callers of this procedure (either Assign_Task or + -- Set_CPU). + + procedure Freeze_Dispatching_Domains; + pragma Export + (Ada, Freeze_Dispatching_Domains, "__gnat_freeze_dispatching_domains"); + -- Signal the time when no new dispatching domains can be created. It + -- should be called before the environment task calls the main procedure + -- (and after the elaboration code), so the binder-generated file needs to + -- import and call this procedure. + + ----------------- + -- Assign_Task -- + ----------------- + + procedure Assign_Task + (Domain : in out Dispatching_Domain; + CPU : CPU_Range := Not_A_Specific_CPU; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + Target : constant ST.Task_Id := Convert_Ids (T); + + use type System.Tasking.Dispatching_Domain_Access; + + begin + -- The exception Dispatching_Domain_Error is propagated if T is already + -- assigned to a Dispatching_Domain other than + -- System_Dispatching_Domain, or if CPU is not one of the processors of + -- Domain (and is not Not_A_Specific_CPU). + + if Target.Common.Domain /= null and then + Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain + then + raise Dispatching_Domain_Error with + "task already in user-defined dispatching domain"; + + elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then + raise Dispatching_Domain_Error with + "processor does not belong to dispatching domain"; + end if; + + -- Assigning a task to System_Dispatching_Domain that is already + -- assigned to that domain has no effect. + + if Domain = System_Dispatching_Domain then + return; + + else + -- Set the task affinity once we know it is possible + + Unchecked_Set_Affinity + (ST.Dispatching_Domain_Access (Domain), CPU, Target); + end if; + end Assign_Task; + + ------------ + -- Create -- + ------------ + + function Create (First, Last : CPU) return Dispatching_Domain is + use type System.Tasking.Dispatching_Domain; + use type System.Tasking.Dispatching_Domain_Access; + use type System.Tasking.Array_Allocated_Tasks; + use type System.Tasking.Task_Id; + + Valid_System_Domain : constant Boolean := + (First > CPU'First + and then + not (System_Dispatching_Domain (CPU'First .. First - 1) = + (CPU'First .. First - 1 => False))) + or else (Last < Number_Of_CPUs + and then not + (System_Dispatching_Domain + (Last + 1 .. Number_Of_CPUs) = + (Last + 1 .. Number_Of_CPUs => False))); + -- Constant that indicates whether there would exist a non-empty system + -- dispatching domain after the creation of this dispatching domain. + + T : ST.Task_Id; + + New_Domain : Dispatching_Domain; + + begin + -- The range of processors for creating a dispatching domain must + -- comply with the following restrictions: + -- - Non-empty range + -- - Not exceeding the range of available processors + -- - Range from the System_Dispatching_Domain + -- - Range does not contain a processor with a task assigned to it + -- - The allocation cannot leave System_Dispatching_Domain empty + -- - The calling task must be the environment task + -- - The call to Create must take place before the call to the main + -- subprogram + + if First > Last then + raise Dispatching_Domain_Error with "empty dispatching domain"; + + elsif Last > Number_Of_CPUs then + raise Dispatching_Domain_Error with + "CPU range not supported by the target"; + + elsif + System_Dispatching_Domain (First .. Last) /= (First .. Last => True) + then + raise Dispatching_Domain_Error with + "CPU range not currently in System_Dispatching_Domain"; + + elsif + ST.Dispatching_Domain_Tasks (First .. Last) /= (First .. Last => 0) + then + raise Dispatching_Domain_Error with "CPU range has tasks assigned"; + + elsif not Valid_System_Domain then + raise Dispatching_Domain_Error with + "would leave System_Dispatching_Domain empty"; + + elsif Self /= Environment_Task then + raise Dispatching_Domain_Error with + "only the environment task can create dispatching domains"; + + elsif ST.Dispatching_Domains_Frozen then + raise Dispatching_Domain_Error with + "cannot create dispatching domain after call to main program"; + end if; + + New_Domain := new ST.Dispatching_Domain'(First .. Last => True); + + -- At this point we need to fix the processors belonging to the system + -- domain, and change the affinity of every task that has been created + -- and assigned to the system domain. + + ST.Initialization.Defer_Abort (Self); + + Lock_RTS; + + System_Dispatching_Domain (First .. Last) := (First .. Last => False); + + -- Iterate the list of tasks belonging to the default system + -- dispatching domain and set the appropriate affinity. + + T := ST.All_Tasks_List; + + while T /= null loop + if T.Common.Domain = null or else + T.Common.Domain = ST.System_Domain + then + Set_Task_Affinity (T); + end if; + + T := T.Common.All_Tasks_Link; + end loop; + + Unlock_RTS; + + ST.Initialization.Undefer_Abort (Self); + + return New_Domain; + end Create; + + ----------------------------- + -- Delay_Until_And_Set_CPU -- + ----------------------------- + + procedure Delay_Until_And_Set_CPU + (Delay_Until_Time : Ada.Real_Time.Time; + CPU : CPU_Range) + is + begin + -- Not supported atomically by the underlying operating systems. + -- Operating systems use to migrate the task immediately after the call + -- to set the affinity. + + delay until Delay_Until_Time; + Set_CPU (CPU); + end Delay_Until_And_Set_CPU; + + -------------------------------- + -- Freeze_Dispatching_Domains -- + -------------------------------- + + procedure Freeze_Dispatching_Domains is + begin + -- Signal the end of the elaboration code + + ST.Dispatching_Domains_Frozen := True; + end Freeze_Dispatching_Domains; + + ------------- + -- Get_CPU -- + ------------- + + function Get_CPU + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return CPU_Range + is + begin + return Convert_Ids (T).Common.Base_CPU; + end Get_CPU; + + ---------------------------- + -- Get_Dispatching_Domain -- + ---------------------------- + + function Get_Dispatching_Domain + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return Dispatching_Domain + is + begin + return Dispatching_Domain (Convert_Ids (T).Common.Domain); + end Get_Dispatching_Domain; + + ------------------- + -- Get_First_CPU -- + ------------------- + + function Get_First_CPU (Domain : Dispatching_Domain) return CPU is + begin + for Proc in Domain'Range loop + if Domain (Proc) then + return Proc; + end if; + end loop; + + -- Should never reach the following return + + return Domain'First; + end Get_First_CPU; + + ------------------ + -- Get_Last_CPU -- + ------------------ + + function Get_Last_CPU (Domain : Dispatching_Domain) return CPU is + begin + for Proc in reverse Domain'Range loop + if Domain (Proc) then + return Proc; + end if; + end loop; + + -- Should never reach the following return + + return Domain'Last; + end Get_Last_CPU; + + ------------- + -- Set_CPU -- + ------------- + + procedure Set_CPU + (CPU : CPU_Range; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + Target : constant ST.Task_Id := Convert_Ids (T); + + use type ST.Dispatching_Domain_Access; + + begin + -- The exception Dispatching_Domain_Error is propagated if CPU is not + -- one of the processors of the Dispatching_Domain on which T is + -- assigned (and is not Not_A_Specific_CPU). + + if CPU /= Not_A_Specific_CPU and then + (CPU not in Target.Common.Domain'Range or else + not Target.Common.Domain (CPU)) + then + raise Dispatching_Domain_Error with + "processor does not belong to the task's dispatching domain"; + end if; + + Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target); + end Set_CPU; + + ---------------------------- + -- Unchecked_Set_Affinity -- + ---------------------------- + + procedure Unchecked_Set_Affinity + (Domain : ST.Dispatching_Domain_Access; + CPU : CPU_Range; + T : ST.Task_Id) + is + Source_CPU : constant CPU_Range := T.Common.Base_CPU; + + use type System.Tasking.Dispatching_Domain_Access; + + begin + Write_Lock (T); + + -- Move to the new domain + + T.Common.Domain := Domain; + + -- Attach the CPU to the task + + T.Common.Base_CPU := CPU; + + -- Change the number of tasks attached to a given task in the system + -- domain if needed. + + if not ST.Dispatching_Domains_Frozen + and then (Domain = null or else Domain = ST.System_Domain) + then + -- Reduce the number of tasks attached to the CPU from which this + -- task is being moved, if needed. + + if Source_CPU /= Not_A_Specific_CPU then + ST.Dispatching_Domain_Tasks (Source_CPU) := + ST.Dispatching_Domain_Tasks (Source_CPU) - 1; + end if; + + -- Increase the number of tasks attached to the CPU to which this + -- task is being moved, if needed. + + if CPU /= Not_A_Specific_CPU then + ST.Dispatching_Domain_Tasks (CPU) := + ST.Dispatching_Domain_Tasks (CPU) + 1; + end if; + end if; + + -- Change the actual affinity calling the operating system level + + Set_Task_Affinity (T); + + Unlock (T); + end Unchecked_Set_Affinity; + +end System.Multiprocessors.Dispatching_Domains; diff --git a/gcc/ada/s-mudido.adb b/gcc/ada/s-mudido.adb new file mode 100644 index 00000000000..990a7bc6342 --- /dev/null +++ b/gcc/ada/s-mudido.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Body used on unimplemented targets, where the operating system does not +-- support setting task affinities. + +package body System.Multiprocessors.Dispatching_Domains is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Freeze_Dispatching_Domains; + pragma Export + (Ada, Freeze_Dispatching_Domains, "__gnat_freeze_dispatching_domains"); + -- Signal the time when no new dispatching domains can be created. It + -- should be called before the environment task calls the main procedure + -- (and after the elaboration code), so the binder-generated file needs to + -- import and call this procedure. + + ----------------- + -- Assign_Task -- + ----------------- + + procedure Assign_Task + (Domain : in out Dispatching_Domain; + CPU : CPU_Range := Not_A_Specific_CPU; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + pragma Unreferenced (Domain, CPU, T); + begin + raise Dispatching_Domain_Error with "dispatching domains not supported"; + end Assign_Task; + + ------------ + -- Create -- + ------------ + + function Create (First, Last : CPU) return Dispatching_Domain is + pragma Unreferenced (First, Last); + begin + raise Dispatching_Domain_Error with "dispatching domains not supported"; + return System_Dispatching_Domain; + end Create; + + ----------------------------- + -- Delay_Until_And_Set_CPU -- + ----------------------------- + + procedure Delay_Until_And_Set_CPU + (Delay_Until_Time : Ada.Real_Time.Time; + CPU : CPU_Range) + is + pragma Unreferenced (Delay_Until_Time, CPU); + begin + raise Dispatching_Domain_Error with "dispatching domains not supported"; + end Delay_Until_And_Set_CPU; + + -------------------------------- + -- Freeze_Dispatching_Domains -- + -------------------------------- + + procedure Freeze_Dispatching_Domains is + begin + null; + end Freeze_Dispatching_Domains; + + ------------- + -- Get_CPU -- + ------------- + + function Get_CPU + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return CPU_Range + is + pragma Unreferenced (T); + begin + return Not_A_Specific_CPU; + end Get_CPU; + + ---------------------------- + -- Get_Dispatching_Domain -- + ---------------------------- + + function Get_Dispatching_Domain + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return Dispatching_Domain + is + pragma Unreferenced (T); + begin + return System_Dispatching_Domain; + end Get_Dispatching_Domain; + + ------------------- + -- Get_First_CPU -- + ------------------- + + function Get_First_CPU (Domain : Dispatching_Domain) return CPU is + pragma Unreferenced (Domain); + begin + return CPU'First; + end Get_First_CPU; + + ------------------ + -- Get_Last_CPU -- + ------------------ + + function Get_Last_CPU (Domain : Dispatching_Domain) return CPU is + pragma Unreferenced (Domain); + begin + return Number_Of_CPUs; + end Get_Last_CPU; + + ------------- + -- Set_CPU -- + ------------- + + procedure Set_CPU + (CPU : CPU_Range; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + pragma Unreferenced (CPU, T); + begin + raise Dispatching_Domain_Error with "dispatching domains not supported"; + end Set_CPU; + +end System.Multiprocessors.Dispatching_Domains; diff --git a/gcc/ada/s-mudido.ads b/gcc/ada/s-mudido.ads new file mode 100644 index 00000000000..635a847d202 --- /dev/null +++ b/gcc/ada/s-mudido.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Real_Time; + +with Ada.Task_Identification; + +private with System.Tasking; + +package System.Multiprocessors.Dispatching_Domains is + -- pragma Preelaborate (Dispatching_Domains); + -- ??? According to AI 167 this unit should be preelaborate, but it cannot + -- be preelaborate because it depends on Ada.Real_Time which is not + -- preelaborate. + + Dispatching_Domain_Error : exception; + + type Dispatching_Domain (<>) is limited private; + + System_Dispatching_Domain : constant Dispatching_Domain; + + function Create (First, Last : CPU) return Dispatching_Domain; + + function Get_First_CPU (Domain : Dispatching_Domain) return CPU; + + function Get_Last_CPU (Domain : Dispatching_Domain) return CPU; + + function Get_Dispatching_Domain + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return Dispatching_Domain; + + procedure Assign_Task + (Domain : in out Dispatching_Domain; + CPU : CPU_Range := Not_A_Specific_CPU; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + + procedure Set_CPU + (CPU : CPU_Range; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + + function Get_CPU + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return CPU_Range; + + procedure Delay_Until_And_Set_CPU + (Delay_Until_Time : Ada.Real_Time.Time; + CPU : CPU_Range); + +private + type Dispatching_Domain is new System.Tasking.Dispatching_Domain_Access; + + System_Dispatching_Domain : constant Dispatching_Domain := + Dispatching_Domain + (System.Tasking.System_Domain); +end System.Multiprocessors.Dispatching_Domains; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 4b5b138a963..fe3b90d1854 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1219,6 +1219,26 @@ CND(IP_PKTINFO, "Get datagram info") CND(SIZEOF_tv_sec, "tv_sec") #define SIZEOF_tv_usec (sizeof tv.tv_usec) CND(SIZEOF_tv_usec, "tv_usec") +/* + + -- Maximum allowed value for tv_sec +*/ + +/** + ** On Solaris and IRIX, field tv_sec in struct timeval has an undocumented + ** hard-wired limit of 100 million. + ** On IA64 HP-UX the limit is 2**31 - 1. + **/ +#if defined (sun) || (defined (__mips) && defined (__sgi)) +# define MAX_tv_sec "100_000_000" + +#elif defined (__hpux__) +# define MAX_tv_sec "16#7fffffff#" + +#else +# define MAX_tv_sec "2 ** (SIZEOF_tv_sec * 8 - 1) - 1" +#endif +CNS(MAX_tv_sec, "") } /* diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads index 02213086b12..18a314bbc97 100644 --- a/gcc/ada/s-osinte-linux.ads +++ b/gcc/ada/s-osinte-linux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -471,6 +471,10 @@ package System.OS_Interface is pragma Import (C, pthread_key_create, "pthread_key_create"); CPU_SETSIZE : constant := 1_024; + -- Size of the cpu_set_t mask on most linux systems (SUSE 11 uses 4_096). + -- This is kept for backward compatibility (System.Task_Info uses it), but + -- the run-time library does no longer rely on static masks, using + -- dynamically allocated masks instead. type bit_field is array (1 .. CPU_SETSIZE) of Boolean; for bit_field'Size use CPU_SETSIZE; @@ -482,10 +486,36 @@ package System.OS_Interface is end record; pragma Convention (C, cpu_set_t); + type cpu_set_t_ptr is access all cpu_set_t; + -- In the run-time library we use this pointer because the size of type + -- cpu_set_t varies depending on the glibc version. Hence, objects of type + -- cpu_set_t are allocated dynamically using the number of processors + -- available in the target machine (value obtained at execution time). + + function CPU_ALLOC (count : size_t) return cpu_set_t_ptr; + pragma Import (C, CPU_ALLOC, "__gnat_cpu_alloc"); + -- Wrapper around the CPU_ALLOC C macro + + function CPU_ALLOC_SIZE (count : size_t) return size_t; + pragma Import (C, CPU_ALLOC_SIZE, "__gnat_cpu_alloc_size"); + -- Wrapper around the CPU_ALLOC_SIZE C macro + + procedure CPU_FREE (cpuset : cpu_set_t_ptr); + pragma Import (C, CPU_FREE, "__gnat_cpu_free"); + -- Wrapper around the CPU_FREE C macro + + procedure CPU_ZERO (count : size_t; cpuset : cpu_set_t_ptr); + pragma Import (C, CPU_ZERO, "__gnat_cpu_zero"); + -- Wrapper around the CPU_ZERO_S C macro + + procedure CPU_SET (cpu : int; count : size_t; cpuset : cpu_set_t_ptr); + pragma Import (C, CPU_SET, "__gnat_cpu_set"); + -- Wrapper around the CPU_SET_S C macro + function pthread_setaffinity_np (thread : pthread_t; cpusetsize : size_t; - cpuset : access cpu_set_t) return int; + cpuset : cpu_set_t_ptr) return int; pragma Import (C, pthread_setaffinity_np, "pthread_setaffinity_np"); pragma Weak_External (pthread_setaffinity_np); -- Use a weak symbol because this function may be available or not, @@ -494,7 +524,7 @@ package System.OS_Interface is function pthread_attr_setaffinity_np (attr : access pthread_attr_t; cpusetsize : size_t; - cpuset : access cpu_set_t) return int; + cpuset : cpu_set_t_ptr) return int; pragma Import (C, pthread_attr_setaffinity_np, "pthread_attr_setaffinity_np"); pragma Weak_External (pthread_attr_setaffinity_np); diff --git a/gcc/ada/s-osinte-solaris.ads b/gcc/ada/s-osinte-solaris.ads index 12c5b4fe654..03a0c4ae47d 100644 --- a/gcc/ada/s-osinte-solaris.ads +++ b/gcc/ada/s-osinte-solaris.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -492,6 +492,24 @@ package System.OS_Interface is obind : processorid_t_ptr) return int; pragma Import (C, processor_bind, "processor_bind"); + type psetid_t is new int; + + function pset_create (pset : access psetid_t) return int; + pragma Import (C, pset_create, "pset_create"); + + function pset_assign + (pset : psetid_t; + proc_id : processorid_t; + opset : access psetid_t) return int; + pragma Import (C, pset_assign, "pset_assign"); + + function pset_bind + (pset : psetid_t; + id_type : int; + id : id_t; + opset : access psetid_t) return int; + pragma Import (C, pset_bind, "pset_bind"); + procedure pthread_init; -- Dummy procedure to share s-intman.adb with other Solaris targets diff --git a/gcc/ada/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads index 384e1e02f25..f5013ea6977 100644 --- a/gcc/ada/s-osinte-vxworks.ads +++ b/gcc/ada/s-osinte-vxworks.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2011, 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- -- @@ -47,6 +47,7 @@ package System.OS_Interface is pragma Preelaborate; subtype int is Interfaces.C.int; + subtype unsigned is Interfaces.C.unsigned; subtype short is Short_Integer; type unsigned_int is mod 2 ** int'Size; type long is new Long_Integer; @@ -493,6 +494,11 @@ package System.OS_Interface is -- For SMP run-times the affinity to CPU. -- For uniprocessor systems return ERROR status. + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int + renames System.VxWorks.Ext.taskMaskAffinitySet; + -- For SMP run-times the affinity to CPU_Set. + -- For uniprocessor systems return ERROR status. + --------------------- -- Multiprocessors -- --------------------- diff --git a/gcc/ada/s-parame-ae653.ads b/gcc/ada/s-parame-ae653.ads index a13ecf38c00..82a5d31562b 100644 --- a/gcc/ada/s-parame-ae653.ads +++ b/gcc/ada/s-parame-ae653.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 System.Parameters is Unspecified_Size : constant Size_Type := Size_Type'First; -- Value used to indicate that no size type is set - subtype Ratio is Size_Type range -1 .. 100; + subtype Percentage is Size_Type range -1 .. 100; Dynamic : constant Size_Type := -1; -- The secondary stack ratio is a constant between 0 and 100 which -- determines the percentage of the allocated task stack that is @@ -70,10 +70,10 @@ package System.Parameters is -- The special value of minus one indicates that the secondary -- stack is to be allocated from the heap instead. - Sec_Stack_Ratio : constant Ratio := 50; + Sec_Stack_Percentage : constant Percentage := 50; -- This constant defines the handling of the secondary stack - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; -- Convenient Boolean for testing for dynamic secondary stack function Default_Stack_Size return Size_Type; diff --git a/gcc/ada/s-parame-hpux.ads b/gcc/ada/s-parame-hpux.ads index da771d90c10..b8511162fff 100644 --- a/gcc/ada/s-parame-hpux.ads +++ b/gcc/ada/s-parame-hpux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 System.Parameters is Unspecified_Size : constant Size_Type := Size_Type'First; -- Value used to indicate that no size type is set - subtype Ratio is Size_Type range -1 .. 100; + subtype Percentage is Size_Type range -1 .. 100; Dynamic : constant Size_Type := -1; -- The secondary stack ratio is a constant between 0 and 100 which -- determines the percentage of the allocated task stack that is @@ -70,10 +70,10 @@ package System.Parameters is -- The special value of minus one indicates that the secondary -- stack is to be allocated from the heap instead. - Sec_Stack_Ratio : constant Ratio := Dynamic; + Sec_Stack_Percentage : constant Percentage := Dynamic; -- This constant defines the handling of the secondary stack - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; -- Convenient Boolean for testing for dynamic secondary stack function Default_Stack_Size return Size_Type; diff --git a/gcc/ada/s-parame-vms-alpha.ads b/gcc/ada/s-parame-vms-alpha.ads index 7799dc1e8b8..359e694d4c5 100644 --- a/gcc/ada/s-parame-vms-alpha.ads +++ b/gcc/ada/s-parame-vms-alpha.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 System.Parameters is Unspecified_Size : constant Size_Type := Size_Type'First; -- Value used to indicate that no size type is set - subtype Ratio is Size_Type range -1 .. 100; + subtype Percentage is Size_Type range -1 .. 100; Dynamic : constant Size_Type := -1; -- The secondary stack ratio is a constant between 0 and 100 which -- determines the percentage of the allocated task stack that is @@ -70,10 +70,10 @@ package System.Parameters is -- The special value of minus one indicates that the secondary -- stack is to be allocated from the heap instead. - Sec_Stack_Ratio : constant Ratio := Dynamic; + Sec_Stack_Percentage : constant Percentage := Dynamic; -- This constant defines the handling of the secondary stack - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; -- Convenient Boolean for testing for dynamic secondary stack function Default_Stack_Size return Size_Type; diff --git a/gcc/ada/s-parame-vms-ia64.ads b/gcc/ada/s-parame-vms-ia64.ads index 8612e4283c1..2726f34b2c4 100644 --- a/gcc/ada/s-parame-vms-ia64.ads +++ b/gcc/ada/s-parame-vms-ia64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 System.Parameters is Unspecified_Size : constant Size_Type := Size_Type'First; -- Value used to indicate that no size type is set - subtype Ratio is Size_Type range -1 .. 100; + subtype Percentage is Size_Type range -1 .. 100; Dynamic : constant Size_Type := -1; -- The secondary stack ratio is a constant between 0 and 100 which -- determines the percentage of the allocated task stack that is @@ -70,10 +70,10 @@ package System.Parameters is -- The special value of minus one indicates that the secondary -- stack is to be allocated from the heap instead. - Sec_Stack_Ratio : constant Ratio := Dynamic; + Sec_Stack_Percentage : constant Percentage := Dynamic; -- This constant defines the handling of the secondary stack - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; -- Convenient Boolean for testing for dynamic secondary stack function Default_Stack_Size return Size_Type; diff --git a/gcc/ada/s-parame-vxworks.ads b/gcc/ada/s-parame-vxworks.ads index 6e959c84ef2..748e7d81b39 100644 --- a/gcc/ada/s-parame-vxworks.ads +++ b/gcc/ada/s-parame-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 System.Parameters is Unspecified_Size : constant Size_Type := Size_Type'First; -- Value used to indicate that no size type is set - subtype Ratio is Size_Type range -1 .. 100; + subtype Percentage is Size_Type range -1 .. 100; Dynamic : constant Size_Type := -1; -- The secondary stack ratio is a constant between 0 and 100 which -- determines the percentage of the allocated task stack that is @@ -70,10 +70,10 @@ package System.Parameters is -- The special value of minus one indicates that the secondary -- stack is to be allocated from the heap instead. - Sec_Stack_Ratio : constant Ratio := Dynamic; + Sec_Stack_Percentage : constant Percentage := Dynamic; -- This constant defines the handling of the secondary stack - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; -- Convenient Boolean for testing for dynamic secondary stack function Default_Stack_Size return Size_Type; diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads index 01e52b2e34f..e4317fafcf6 100644 --- a/gcc/ada/s-parame.ads +++ b/gcc/ada/s-parame.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -64,7 +64,7 @@ package System.Parameters is Unspecified_Size : constant Size_Type := Size_Type'First; -- Value used to indicate that no size type is set - subtype Ratio is Size_Type range -1 .. 100; + subtype Percentage is Size_Type range -1 .. 100; Dynamic : constant Size_Type := -1; -- The secondary stack ratio is a constant between 0 and 100 which -- determines the percentage of the allocated task stack that is @@ -72,10 +72,10 @@ package System.Parameters is -- The special value of minus one indicates that the secondary -- stack is to be allocated from the heap instead. - Sec_Stack_Ratio : constant Ratio := Dynamic; + Sec_Stack_Percentage : constant Percentage := Dynamic; -- This constant defines the handling of the secondary stack - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; -- Convenient Boolean for testing for dynamic secondary stack function Default_Stack_Size return Size_Type; diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb index d85dd2efacf..4e5e1d55797 100644 --- a/gcc/ada/s-rannum.adb +++ b/gcc/ada/s-rannum.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +86,16 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Calendar; use Ada.Calendar; with Ada.Unchecked_Conversion; +with System.Random_Seed; + with Interfaces; use Interfaces; use Ada; package body System.Random_Numbers is - Y2K : constant Calendar.Time := - Calendar.Time_Of - (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); - -- First day of Year 2000 (what is this for???) - Image_Numeral_Length : constant := Max_Image_Width / N; subtype Image_String is String (1 .. Max_Image_Width); @@ -484,11 +480,9 @@ package body System.Random_Numbers is ----------- procedure Reset (Gen : Generator) is - Clock : constant Time := Calendar.Clock; - Duration_Since_Y2K : constant Duration := Clock - Y2K; - X : constant Unsigned_32 := - Unsigned_32'Mod (Unsigned_64 (Duration_Since_Y2K) * 64); + Unsigned_32'Mod (Unsigned_64 (Random_Seed.Get_Seed) * 64); + -- Why * 64 ??? begin Init (Gen, X); diff --git a/gcc/ada/s-ransee.adb b/gcc/ada/s-ransee.adb new file mode 100644 index 00000000000..ad0833a26f2 --- /dev/null +++ b/gcc/ada/s-ransee.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R A N D O M _ S E E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Version used on all systems except Ravenscar where Calendar is unavailable + +with Ada.Calendar; use Ada.Calendar; + +package body System.Random_Seed is + + Y2K : constant Time := + Time_Of (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); + -- First day of Year 2000, to get a duration. + + function Get_Seed return Duration is + begin + return Clock - Y2K; + end Get_Seed; + +end System.Random_Seed; diff --git a/gcc/ada/s-ransee.ads b/gcc/ada/s-ransee.ads new file mode 100644 index 00000000000..ffae8323c04 --- /dev/null +++ b/gcc/ada/s-ransee.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R A N D O M _ S E E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provide a seed for pseudo-random number generation using +-- the clock. + +-- There are two separate implementations of this package: +-- o one based on Ada.Calendar +-- o one based on Ada.Real_Time + +-- This is required because Ada.Calendar cannot be used on ravenscar, but +-- Ada.Real_Time drags in the whole tasking runtime on regular platforms. + +package System.Random_Seed is + + function Get_Seed return Duration; + -- Get a seed based on the clock + +end System.Random_Seed; diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb index 16e9fa0c9fb..0afea184baf 100644 --- a/gcc/ada/s-secsta.adb +++ b/gcc/ada/s-secsta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,6 +33,7 @@ pragma Compiler_Unit; with System.Soft_Links; with System.Parameters; + with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; @@ -44,7 +45,7 @@ package body System.Secondary_Stack is use type System.Parameters.Size_Type; SS_Ratio_Dynamic : constant Boolean := - Parameters.Sec_Stack_Ratio = Parameters.Dynamic; + Parameters.Sec_Stack_Percentage = Parameters.Dynamic; -- There are two entirely different implementations of the secondary -- stack mechanism in this unit, and this Boolean is used to select -- between them (at compile time, so the generated code will contain diff --git a/gcc/ada/s-secsta.ads b/gcc/ada/s-secsta.ads index 7e6d11d51fb..d2da2bcffb1 100644 --- a/gcc/ada/s-secsta.ads +++ b/gcc/ada/s-secsta.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,17 +47,17 @@ package System.Secondary_Stack is Size : Natural := Default_Secondary_Stack_Size); -- Initialize the secondary stack with a main stack of the given Size. -- - -- If System.Parameters.Sec_Stack_Ratio equals Dynamic, Stk is really an - -- OUT parameter that will be allocated on the heap. Then all further + -- If System.Parameters.Sec_Stack_Percentage equals Dynamic, Stk is really + -- an OUT parameter that will be allocated on the heap. Then all further -- allocations which do not overflow the main stack will not generate -- dynamic (de)allocation calls. If the main Stack overflows, a new -- chuck of at least the same size will be allocated and linked to the -- previous chunk. -- - -- Otherwise (Sec_Stack_Ratio between 0 and 100), Stk is an IN parameter - -- that is already pointing to a Stack_Id. The secondary stack in this case - -- is fixed, and any attempt to allocate more than the initial size will - -- result in a Storage_Error being raised. + -- Otherwise (Sec_Stack_Percentage between 0 and 100), Stk is an IN + -- parameter that is already pointing to a Stack_Id. The secondary stack + -- in this case is fixed, and any attempt to allocate more than the initial + -- size will result in a Storage_Error being raised. -- -- Note: the reason that Stk is passed is that SS_Init is called before -- the proper interface is established to obtain the address of the diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb index 27f6e54a575..ca3df4ae544 100644 --- a/gcc/ada/s-soflin.adb +++ b/gcc/ada/s-soflin.adb @@ -120,11 +120,8 @@ package body System.Soft_Links is ---------------- procedure Create_TSD (New_TSD : in out TSD) is - use type Parameters.Size_Type; - - SS_Ratio_Dynamic : constant Boolean := - Parameters.Sec_Stack_Ratio = Parameters.Dynamic; - + use Parameters; + SS_Ratio_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; begin if SS_Ratio_Dynamic then SST.SS_Init diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index 2b4e7fc4044..828c47e6f4e 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -269,25 +269,25 @@ package body System.Storage_Pools.Subpools is Addr := N_Addr + Header_And_Padding; - -- Subpool allocations use heterogeneous masters to manage various - -- controlled objects. Associate a Finalize_Address with the object. - -- This relation pair is deleted when the object is deallocated or - -- when the associated master is finalized. + -- Homogeneous masters service the following: - if Is_Subpool_Allocation then - pragma Assert (not Master.Is_Homogeneous); - - Set_Finalize_Address (Addr, Fin_Address); - Finalize_Address_Table_In_Use := True; - - -- Normal allocations chain objects on homogeneous collections - - else - pragma Assert (Master.Is_Homogeneous); + -- 1) Allocations on / Deallocations from regular pools + -- 2) Named access types + -- 3) Most cases of anonymous access types usage + if Master.Is_Homogeneous then if Finalize_Address (Master.all) = null then Set_Finalize_Address (Master.all, Fin_Address); end if; + + -- Heterogeneous masters service the following: + + -- 1) Allocations on / Deallocations from subpools + -- 2) Certain cases of anonymous access types usage + + else + Set_Finalize_Address (Addr, Fin_Address); + Finalize_Address_Table_In_Use := True; end if; -- Non-controlled allocation diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb index 645e9fd90ba..88f4571f61e 100644 --- a/gcc/ada/s-taprop-dummy.adb +++ b/gcc/ada/s-taprop-dummy.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -346,6 +346,15 @@ package body System.Task_Primitives.Operations is null; end Set_Priority; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + begin + null; + end Set_Task_Affinity; + -------------- -- Set_True -- -------------- diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 164034ec881..6bc89fc087a 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -1241,4 +1241,17 @@ package body System.Task_Primitives.Operations is -- this difference is that sigwait doesn't work when some critical -- signals (SIGABRT, SIGPIPE) are masked. + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index 9d8ac90b59c..bfa425e9b45 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -1342,4 +1342,17 @@ package body System.Task_Primitives.Operations is end if; end Initialize; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index f46736fbf5f..8d381ab9564 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -38,7 +38,6 @@ pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. -with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -98,12 +97,6 @@ package body System.Task_Primitives.Operations is Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - -- The following are effectively constants, but they need to be initialized - -- by calling a pthread_ function. - - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - Foreign_Task_Elaborated : aliased Boolean := True; -- Used to identified fake tasks (i.e., non-Ada Threads) @@ -113,6 +106,10 @@ package body System.Task_Primitives.Operations is Abort_Handler_Installed : Boolean := False; -- True if a handler for the abort signal is installed + Null_Thread_Id : constant pthread_t := pthread_t'Last; + -- Constant to indicate that the thread identifier has not yet been + -- initialized. + -------------------- -- Local Packages -- -------------------- @@ -154,13 +151,8 @@ package body System.Task_Primitives.Operations is -- Local Subprograms -- ----------------------- - subtype unsigned_long is Interfaces.C.unsigned_long; - procedure Abort_Handler (signo : Signal); - function To_pthread_t is new Ada.Unchecked_Conversion - (unsigned_long, System.OS_Interface.pthread_t); - ------------------- -- Abort_Handler -- ------------------- @@ -263,9 +255,13 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Prio); - Result : Interfaces.C.int; + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; begin + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0); + Result := pthread_mutex_init (L, Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -281,9 +277,13 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Level); - Result : Interfaces.C.int; + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; begin + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0); + Result := pthread_mutex_init (L, Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -764,7 +764,9 @@ package body System.Task_Primitives.Operations is -------------------- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is - Result : Interfaces.C.int; + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; begin -- Give the task a unique serial number @@ -773,11 +775,14 @@ package body System.Task_Primitives.Operations is Next_Serial_Number := Next_Serial_Number + 1; pragma Assert (Next_Serial_Number /= 0); - Self_ID.Common.LL.Thread := To_pthread_t (-1); + Self_ID.Common.LL.Thread := Null_Thread_Id; if not Single_Lock then - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0); + + Result := + pthread_mutex_init (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); if Result /= 0 then @@ -786,8 +791,11 @@ package body System.Task_Primitives.Operations is end if; end if; - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0); + + Result := + pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then @@ -820,6 +828,20 @@ package body System.Task_Primitives.Operations is use type System.Multiprocessors.CPU_Range; begin + -- Check whether both Dispatching_Domain and CPU are specified for + -- the task, and the CPU value is not contained within the range of + -- processors for the domain. + + if T.Common.Domain /= null + and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU + and then + (T.Common.Base_CPU not in T.Common.Domain'Range + or else not T.Common.Domain (T.Common.Base_CPU)) + then + Succeeded := False; + return; + end if; + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); @@ -832,8 +854,7 @@ package body System.Task_Primitives.Operations is end if; Result := - pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); + pthread_attr_setstacksize (Attributes'Access, Adjusted_Stack_Size); pragma Assert (Result = 0); Result := @@ -857,28 +878,70 @@ package body System.Task_Primitives.Operations is elsif T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then declare - CPU_Set : aliased cpu_set_t := (bits => (others => False)); + CPUs : constant size_t := + Interfaces.C.size_t + (System.Multiprocessors.Number_Of_CPUs); + CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs); + Size : constant size_t := CPU_ALLOC_SIZE (CPUs); + begin - CPU_Set.bits (Integer (T.Common.Base_CPU)) := True; + CPU_ZERO (Size, CPU_Set); + System.OS_Interface.CPU_SET + (int (T.Common.Base_CPU), Size, CPU_Set); Result := - pthread_attr_setaffinity_np - (Attributes'Access, - CPU_SETSIZE / 8, - CPU_Set'Access); + pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set); pragma Assert (Result = 0); + + CPU_FREE (CPU_Set); end; -- Handle Task_Info - elsif T.Common.Task_Info /= null - and then T.Common.Task_Info.CPU_Affinity /= Task_Info.Any_CPU - then + elsif T.Common.Task_Info /= null then Result := pthread_attr_setaffinity_np (Attributes'Access, CPU_SETSIZE / 8, T.Common.Task_Info.CPU_Affinity'Access); pragma Assert (Result = 0); + + -- Handle dispatching domains + + -- To avoid changing CPU affinities when not needed, we set the + -- affinity only when assigning to a domain other than the default + -- one, or when the default one has been modified. + + elsif T.Common.Domain /= null and then + (T.Common.Domain /= ST.System_Domain + or else T.Common.Domain.all /= + (Multiprocessors.CPU'First .. + Multiprocessors.Number_Of_CPUs => True)) + then + declare + CPUs : constant size_t := + Interfaces.C.size_t + (System.Multiprocessors.Number_Of_CPUs); + CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs); + Size : constant size_t := CPU_ALLOC_SIZE (CPUs); + + begin + CPU_ZERO (Size, CPU_Set); + + -- Set the affinity to all the processors belonging to the + -- dispatching domain. + + for Proc in T.Common.Domain'Range loop + if T.Common.Domain (Proc) then + System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set); + end if; + end loop; + + Result := + pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set); + pragma Assert (Result = 0); + + CPU_FREE (CPU_Set); + end; end if; -- Since the initial signal mask of a thread is inherited from the @@ -891,6 +954,7 @@ package body System.Task_Primitives.Operations is Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN or else Result = ENOMEM); @@ -933,6 +997,7 @@ package body System.Task_Primitives.Operations is if T.Known_Tasks_Index /= -1 then Known_Tasks (T.Known_Tasks_Index) := null; end if; + SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access); Free (Tmp); @@ -971,7 +1036,9 @@ package body System.Task_Primitives.Operations is ---------------- procedure Initialize (S : in out Suspension_Object) is - Result : Interfaces.C.int; + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; begin -- Initialize internal state (always to False (RM D.10(6))) @@ -981,6 +1048,9 @@ package body System.Task_Primitives.Operations is -- Initialize internal mutex + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0); + Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -991,6 +1061,9 @@ package body System.Task_Primitives.Operations is -- Initialize internal condition variable + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0); + Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -1284,12 +1357,6 @@ package body System.Task_Primitives.Operations is end if; end loop; - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0); - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0); - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); -- Initialize the global RTS lock @@ -1328,24 +1395,91 @@ package body System.Task_Primitives.Operations is Abort_Handler_Installed := True; end if; - -- pragma CPU for the environment task + -- pragma CPU and dispatching domains for the environment task + + Set_Task_Affinity (Environment_Task); + end Initialize; + + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + use type System.Multiprocessors.CPU_Range; + + begin + -- Do nothing if there is no support for setting affinities or the + -- underlying thread has not yet been created. If the thread has not + -- yet been created then the proper affinity will be set during its + -- creation. if pthread_setaffinity_np'Address /= System.Null_Address - and then Environment_Task.Common.Base_CPU /= - System.Multiprocessors.Not_A_Specific_CPU + and then T.Common.LL.Thread /= Null_Thread_Id then declare - CPU_Set : aliased cpu_set_t := (bits => (others => False)); + CPUs : constant size_t := + Interfaces.C.size_t + (System.Multiprocessors.Number_Of_CPUs); + CPU_Set : cpu_set_t_ptr := null; + Size : constant size_t := CPU_ALLOC_SIZE (CPUs); + + Result : Interfaces.C.int; + begin - CPU_Set.bits (Integer (Environment_Task.Common.Base_CPU)) := True; - Result := - pthread_setaffinity_np - (Environment_Task.Common.LL.Thread, - CPU_SETSIZE / 8, - CPU_Set'Access); - pragma Assert (Result = 0); + -- We look at the specific CPU (Base_CPU) first, then at the + -- Task_Info field, and finally at the assigned dispatching + -- domain, if any. + + if T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then + + -- Set the affinity to an unique CPU + + CPU_Set := CPU_ALLOC (CPUs); + System.OS_Interface.CPU_ZERO (Size, CPU_Set); + System.OS_Interface.CPU_SET + (int (T.Common.Base_CPU), Size, CPU_Set); + + -- Handle Task_Info + + elsif T.Common.Task_Info /= null then + CPU_Set := T.Common.Task_Info.CPU_Affinity'Access; + + -- Handle dispatching domains + + elsif T.Common.Domain /= null and then + (T.Common.Domain /= ST.System_Domain + or else T.Common.Domain.all /= + (Multiprocessors.CPU'First .. + Multiprocessors.Number_Of_CPUs => True)) + then + -- Set the affinity to all the processors belonging to the + -- dispatching domain. To avoid changing CPU affinities when + -- not needed, we set the affinity only when assigning to a + -- domain other than the default one, or when the default one + -- has been modified. + + CPU_Set := CPU_ALLOC (CPUs); + System.OS_Interface.CPU_ZERO (Size, CPU_Set); + + for Proc in T.Common.Domain'Range loop + System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set); + end loop; + end if; + + -- We set the new affinity if needed. Otherwise, the new task + -- will inherit its creator's CPU affinity mask (according to + -- the documentation of pthread_setaffinity_np), which is + -- consistent with Ada's required semantics. + + if CPU_Set /= null then + Result := + pthread_setaffinity_np (T.Common.LL.Thread, Size, CPU_Set); + pragma Assert (Result = 0); + + CPU_FREE (CPU_Set); + end if; end; end if; - end Initialize; + end Set_Task_Affinity; end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index cbde1f4c90e..ab66a889741 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -131,6 +131,10 @@ package body System.Task_Primitives.Operations is Annex_D : Boolean := False; -- Set to True if running with Annex-D semantics + Null_Thread_Id : constant Thread_Id := 0; + -- Constant to indicate that the thread identifier has not yet been + -- initialized. + ------------------------------------ -- The thread local storage index -- ------------------------------------ @@ -853,7 +857,7 @@ package body System.Task_Primitives.Operations is -- Initialize thread ID to 0, this is needed to detect threads that -- are not yet activated. - Self_ID.Common.LL.Thread := 0; + Self_ID.Common.LL.Thread := Null_Thread_Id; Initialize_Cond (Self_ID.Common.LL.CV'Access); @@ -894,6 +898,20 @@ package body System.Task_Primitives.Operations is use type System.Multiprocessors.CPU_Range; begin + -- Check whether both Dispatching_Domain and CPU are specified for the + -- task, and the CPU value is not contained within the range of + -- processors for the domain. + + if T.Common.Domain /= null + and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU + and then + (T.Common.Base_CPU not in T.Common.Domain'Range + or else not T.Common.Domain (T.Common.Base_CPU)) + then + Succeeded := False; + return; + end if; + pTaskParameter := To_Address (T); Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper); @@ -954,21 +972,7 @@ package body System.Task_Primitives.Operations is -- Step 4: Handle pragma CPU and Task_Info - if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then - - -- The CPU numbering in pragma CPU starts at 1 while the subprogram - -- to set the affinity starts at 0, therefore we must subtract 1. - - Result := SetThreadIdealProcessor - (hTask, ProcessorId (T.Common.Base_CPU) - 1); - pragma Assert (Result = 1); - - elsif T.Common.Task_Info /= null then - if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then - Result := SetThreadIdealProcessor (hTask, T.Common.Task_Info.CPU); - pragma Assert (Result = 1); - end if; - end if; + Set_Task_Affinity (T); -- Step 5: Now, start it for good @@ -1074,10 +1078,6 @@ package body System.Task_Primitives.Operations is Discard : BOOL; pragma Unreferenced (Discard); - Result : DWORD; - - use type System.Multiprocessors.CPU_Range; - begin Environment_Task_Id := Environment_Task; OS_Primitives.Initialize; @@ -1109,20 +1109,9 @@ package body System.Task_Primitives.Operations is Enter_Task (Environment_Task); - -- pragma CPU for the environment task - - if Environment_Task.Common.Base_CPU /= - System.Multiprocessors.Not_A_Specific_CPU - then - -- The CPU numbering in pragma CPU starts at 1 while the subprogram - -- to set the affinity starts at 0, therefore we must subtract 1. + -- pragma CPU and dispatching domains for the environment task - Result := - SetThreadIdealProcessor - (Environment_Task.Common.LL.Thread, - ProcessorId (Environment_Task.Common.Base_CPU) - 1); - pragma Assert (Result = 1); - end if; + Set_Task_Affinity (Environment_Task); end Initialize; --------------------- @@ -1216,6 +1205,7 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : BOOL; + begin SSL.Abort_Defer.all; @@ -1232,6 +1222,7 @@ package body System.Task_Primitives.Operations is Result := SetEvent (S.CV); pragma Assert (Result = Win32.TRUE); + else S.State := True; end if; @@ -1255,6 +1246,7 @@ package body System.Task_Primitives.Operations is EnterCriticalSection (S.L'Access); if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True -- if another task is already waiting on that suspension object -- (ARM D.10 par. 10). @@ -1264,6 +1256,7 @@ package body System.Task_Primitives.Operations is SSL.Abort_Undefer.all; raise Program_Error; + else -- Suspend the task if the state is False. Otherwise, the task -- continues its execution, and the state of the suspension object @@ -1275,6 +1268,7 @@ package body System.Task_Primitives.Operations is LeaveCriticalSection (S.L'Access); SSL.Abort_Undefer.all; + else S.Waiting := True; @@ -1297,8 +1291,7 @@ package body System.Task_Primitives.Operations is -- Check_Exit -- ---------------- - -- Dummy versions. The only currently working versions is for solaris - -- (native). + -- Dummy versions, currently this only works for solaris (native) function Check_Exit (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); @@ -1377,4 +1370,72 @@ package body System.Task_Primitives.Operations is return False; end Continue_Task; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + Result : DWORD; + + use type System.Multiprocessors.CPU_Range; + + begin + -- Do nothing if the underlying thread has not yet been created. If the + -- thread has not yet been created then the proper affinity will be set + -- during its creation. + + if T.Common.LL.Thread = Null_Thread_Id then + null; + + -- pragma CPU + + elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then + + -- The CPU numbering in pragma CPU starts at 1 while the subprogram + -- to set the affinity starts at 0, therefore we must substract 1. + + Result := + SetThreadIdealProcessor + (T.Common.LL.Thread, ProcessorId (T.Common.Base_CPU) - 1); + pragma Assert (Result = 1); + + -- Task_Info + + elsif T.Common.Task_Info /= null then + if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then + Result := + SetThreadIdealProcessor + (T.Common.LL.Thread, T.Common.Task_Info.CPU); + pragma Assert (Result = 1); + end if; + + -- Dispatching domains + + elsif T.Common.Domain /= null + and then (T.Common.Domain /= ST.System_Domain + or else + T.Common.Domain.all /= + (Multiprocessors.CPU'First .. + Multiprocessors.Number_Of_CPUs => True)) + then + declare + CPU_Set : DWORD := 0; + + begin + for Proc in T.Common.Domain'Range loop + if T.Common.Domain (Proc) then + + -- The thread affinity mask is a bit vector in which each + -- bit represents a logical processor. + + CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1); + end if; + end loop; + + Result := SetThreadAffinityMask (T.Common.LL.Thread, CPU_Set); + pragma Assert (Result = 1); + end; + end if; + end Set_Task_Affinity; + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 2372d3d9b29..440d94149b9 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -1449,4 +1449,17 @@ package body System.Task_Primitives.Operations is end if; end Initialize; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 042a9312326..421c60e219e 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -101,6 +101,10 @@ package body System.Task_Primitives.Operations is Abort_Handler_Installed : Boolean := False; -- True if a handler for the abort signal is installed + Null_Thread_Id : constant Thread_Id := Thread_Id'Last; + -- Constant to indicate that the thread identifier has not yet been + -- initialized. + ---------------------- -- Priority Support -- ---------------------- @@ -862,68 +866,12 @@ package body System.Task_Primitives.Operations is ---------------- procedure Enter_Task (Self_ID : Task_Id) is - Result : Interfaces.C.int; - Proc : processorid_t; -- User processor # - Last_Proc : processorid_t; -- Last processor # - - use System.Task_Info; - use type System.Multiprocessors.CPU_Range; - begin Self_ID.Common.LL.Thread := thr_self; Self_ID.Common.LL.LWP := lwp_self; - -- pragma CPU - - if Self_ID.Common.Base_CPU /= - System.Multiprocessors.Not_A_Specific_CPU - then - -- The CPU numbering in pragma CPU starts at 1 while the subprogram - -- to set the affinity starts at 0, therefore we must subtract 1. - - Result := - processor_bind - (P_LWPID, P_MYID, processorid_t (Self_ID.Common.Base_CPU) - 1, - null); - pragma Assert (Result = 0); - - -- Task_Info - - elsif Self_ID.Common.Task_Info /= null then - if Self_ID.Common.Task_Info.New_LWP - and then Self_ID.Common.Task_Info.CPU /= CPU_UNCHANGED - then - Last_Proc := Num_Procs - 1; - - if Self_ID.Common.Task_Info.CPU = ANY_CPU then - Result := 0; - Proc := 0; - while Proc < Last_Proc loop - Result := p_online (Proc, PR_STATUS); - exit when Result = PR_ONLINE; - Proc := Proc + 1; - end loop; - - Result := processor_bind (P_LWPID, P_MYID, Proc, null); - pragma Assert (Result = 0); - - else - -- Use specified processor - - if Self_ID.Common.Task_Info.CPU < 0 - or else Self_ID.Common.Task_Info.CPU > Last_Proc - then - raise Invalid_CPU_Number; - end if; - - Result := - processor_bind - (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null); - pragma Assert (Result = 0); - end if; - end if; - end if; + Set_Task_Affinity (Self_ID); Specific.Set (Self_ID); @@ -973,7 +921,7 @@ package body System.Task_Primitives.Operations is Next_Serial_Number := Next_Serial_Number + 1; pragma Assert (Next_Serial_Number /= 0); - Self_ID.Common.LL.Thread := To_thread_t (-1); + Self_ID.Common.LL.Thread := Null_Thread_Id; if not Single_Lock then Result := @@ -1026,8 +974,23 @@ package body System.Task_Primitives.Operations is -- actual use. use System.Task_Info; + use type System.Multiprocessors.CPU_Range; begin + -- Check whether both Dispatching_Domain and CPU are specified for the + -- task, and the CPU value is not contained within the range of + -- processors for the domain. + + if T.Common.Domain /= null + and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU + and then + (T.Common.Base_CPU not in T.Common.Domain'Range + or else not T.Common.Domain (T.Common.Base_CPU)) + then + Succeeded := False; + return; + end if; + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Page_Size); -- Since the initial signal mask of a thread is inherited from the @@ -1077,7 +1040,7 @@ package body System.Task_Primitives.Operations is Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin - T.Common.LL.Thread := To_thread_t (0); + T.Common.LL.Thread := Null_Thread_Id; if not Single_Lock then Result := mutex_destroy (T.Common.LL.L.L'Access); @@ -1987,4 +1950,116 @@ package body System.Task_Primitives.Operations is return False; end Continue_Task; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + Result : Interfaces.C.int; + Proc : processorid_t; -- User processor # + Last_Proc : processorid_t; -- Last processor # + + use System.Task_Info; + use type System.Multiprocessors.CPU_Range; + + begin + -- Do nothing if the underlying thread has not yet been created. If the + -- thread has not yet been created then the proper affinity will be set + -- during its creation. + + if T.Common.LL.Thread = Null_Thread_Id then + null; + + -- pragma CPU + + elsif T.Common.Base_CPU /= + System.Multiprocessors.Not_A_Specific_CPU + then + -- The CPU numbering in pragma CPU starts at 1 while the subprogram + -- to set the affinity starts at 0, therefore we must substract 1. + + Result := + processor_bind + (P_LWPID, id_t (T.Common.LL.LWP), + processorid_t (T.Common.Base_CPU) - 1, null); + pragma Assert (Result = 0); + + -- Task_Info + + elsif T.Common.Task_Info /= null then + if T.Common.Task_Info.New_LWP + and then T.Common.Task_Info.CPU /= CPU_UNCHANGED + then + Last_Proc := Num_Procs - 1; + + if T.Common.Task_Info.CPU = ANY_CPU then + Result := 0; + + Proc := 0; + while Proc < Last_Proc loop + Result := p_online (Proc, PR_STATUS); + exit when Result = PR_ONLINE; + Proc := Proc + 1; + end loop; + + Result := + processor_bind + (P_LWPID, id_t (T.Common.LL.LWP), Proc, null); + pragma Assert (Result = 0); + + else + -- Use specified processor + + if T.Common.Task_Info.CPU < 0 + or else T.Common.Task_Info.CPU > Last_Proc + then + raise Invalid_CPU_Number; + end if; + + Result := + processor_bind + (P_LWPID, id_t (T.Common.LL.LWP), + T.Common.Task_Info.CPU, null); + pragma Assert (Result = 0); + end if; + end if; + + -- Handle dispatching domains + + elsif T.Common.Domain /= null + and then (T.Common.Domain /= ST.System_Domain + or else T.Common.Domain.all /= + (Multiprocessors.CPU'First .. + Multiprocessors.Number_Of_CPUs => True)) + then + declare + CPU_Set : aliased psetid_t; + Result : int; + + begin + Result := pset_create (CPU_Set'Access); + pragma Assert (Result = 0); + + -- Set the affinity to all the processors belonging to the + -- dispatching domain. + + for Proc in T.Common.Domain'Range loop + + -- The Ada CPU numbering starts at 1 while the subprogram to + -- set the affinity starts at 0, therefore we must substract 1. + + if T.Common.Domain (Proc) then + Result := + pset_assign (CPU_Set, processorid_t (Proc) - 1, null); + pragma Assert (Result = 0); + end if; + end loop; + + Result := + pset_bind (CPU_Set, P_LWPID, id_t (T.Common.LL.LWP), null); + pragma Assert (Result = 0); + end; + end if; + end Set_Task_Affinity; + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index 6c2c527fe11..2fe24419f3d 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -1355,4 +1355,16 @@ package body System.Task_Primitives.Operations is end if; end Initialize; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index 1759c5084c7..1cfafbbb55a 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -1254,4 +1254,16 @@ package body System.Task_Primitives.Operations is Enter_Task (Environment_Task); end Initialize; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 0214efb63cc..ae286498d5c 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -67,8 +67,10 @@ package body System.Task_Primitives.Operations is use System.Parameters; use type System.VxWorks.Ext.t_id; use type Interfaces.C.int; + use type System.OS_Interface.unsigned; subtype int is System.OS_Interface.int; + subtype unsigned is System.OS_Interface.unsigned; Relative : constant := 0; @@ -103,6 +105,10 @@ package body System.Task_Primitives.Operations is Time_Slice_Val : Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + Null_Thread_Id : constant Thread_Id := 0; + -- Constant to indicate that the thread identifier has not yet been + -- initialized. + -------------------- -- Local Packages -- -------------------- @@ -857,7 +863,7 @@ package body System.Task_Primitives.Operations is procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is begin Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY); - Self_ID.Common.LL.Thread := 0; + Self_ID.Common.LL.Thread := Null_Thread_Id; if Self_ID.Common.LL.CV = 0 then Succeeded := False; @@ -883,12 +889,24 @@ package body System.Task_Primitives.Operations is Succeeded : out Boolean) is Adjusted_Stack_Size : size_t; - Result : int := 0; - use System.Task_Info; use type System.Multiprocessors.CPU_Range; begin + -- Check whether both Dispatching_Domain and CPU are specified for the + -- task, and the CPU value is not contained within the range of + -- processors for the domain. + + if T.Common.Domain /= null + and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU + and then + (T.Common.Base_CPU not in T.Common.Domain'Range + or else not T.Common.Domain (T.Common.Base_CPU)) + then + Succeeded := False; + return; + end if; + -- Ask for four extra bytes of stack space so that the ATCB pointer can -- be stored below the stack limit, plus extra space for the frame of -- Task_Wrapper. This is so the user gets the amount of stack requested @@ -952,26 +970,9 @@ package body System.Task_Primitives.Operations is -- Set processor affinity - if T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then - -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while - -- on VxWorks the first CPU is identified by a 0, so we need to - -- adjust. - - Result := - taskCpuAffinitySet - (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1); - - elsif T.Common.Task_Info /= Unspecified_Task_Info then - Result := - taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info); - end if; + Set_Task_Affinity (T); - if Result = -1 then - taskDelete (T.Common.LL.Thread); - T.Common.LL.Thread := -1; - end if; - - if T.Common.LL.Thread = -1 then + if T.Common.LL.Thread <= Null_Thread_Id then Succeeded := False; else Succeeded := True; @@ -998,7 +999,7 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); end if; - T.Common.LL.Thread := 0; + T.Common.LL.Thread := Null_Thread_Id; Result := semDelete (T.Common.LL.CV); pragma Assert (Result = 0); @@ -1273,7 +1274,7 @@ package body System.Task_Primitives.Operations is Thread_Self : Thread_Id) return Boolean is begin - if T.Common.LL.Thread /= 0 + if T.Common.LL.Thread /= Null_Thread_Id and then T.Common.LL.Thread /= Thread_Self then return taskSuspend (T.Common.LL.Thread) = 0; @@ -1291,7 +1292,7 @@ package body System.Task_Primitives.Operations is Thread_Self : Thread_Id) return Boolean is begin - if T.Common.LL.Thread /= 0 + if T.Common.LL.Thread /= Null_Thread_Id and then T.Common.LL.Thread /= Thread_Self then return taskResume (T.Common.LL.Thread) = 0; @@ -1317,7 +1318,7 @@ package body System.Task_Primitives.Operations is C := All_Tasks_List; while C /= null loop - if C.Common.LL.Thread /= 0 + if C.Common.LL.Thread /= Null_Thread_Id and then C.Common.LL.Thread /= Thread_Self then Dummy := Task_Stop (C.Common.LL.Thread); @@ -1335,7 +1336,7 @@ package body System.Task_Primitives.Operations is function Stop_Task (T : ST.Task_Id) return Boolean is begin - if T.Common.LL.Thread /= 0 then + if T.Common.LL.Thread /= Null_Thread_Id then return Task_Stop (T.Common.LL.Thread) = 0; else return True; @@ -1349,7 +1350,7 @@ package body System.Task_Primitives.Operations is function Continue_Task (T : ST.Task_Id) return Boolean is begin - if T.Common.LL.Thread /= 0 then + if T.Common.LL.Thread /= Null_Thread_Id then return Task_Cont (T.Common.LL.Thread) = 0; else return True; @@ -1371,8 +1372,7 @@ package body System.Task_Primitives.Operations is procedure Initialize (Environment_Task : Task_Id) is Result : int; - - use type System.Multiprocessors.CPU_Range; + pragma Unreferenced (Result); begin Environment_Task_Id := Environment_Task; @@ -1413,19 +1413,72 @@ package body System.Task_Primitives.Operations is -- Set processor affinity - if Environment_Task.Common.Base_CPU /= - System.Multiprocessors.Not_A_Specific_CPU - then - -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while - -- on VxWorks the first CPU is identified by a 0, so we need to - -- adjust. + Set_Task_Affinity (Environment_Task); + end Initialize; + + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + Result : int := 0; + pragma Unreferenced (Result); + + use System.Task_Info; + use type System.Multiprocessors.CPU_Range; + + begin + -- Do nothing if the underlying thread has not yet been created. If the + -- thread has not yet been created then the proper affinity will be set + -- during its creation. + + if T.Common.LL.Thread = Null_Thread_Id then + null; + + -- pragma CPU + + elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then + + -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while on + -- VxWorks the first CPU is identified by a 0, so we need to adjust. Result := taskCpuAffinitySet - (Environment_Task.Common.LL.Thread, - int (Environment_Task.Common.Base_CPU) - 1); - pragma Assert (Result /= -1); + (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1); + + -- Task_Info + + elsif T.Common.Task_Info /= Unspecified_Task_Info then + Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info); + + -- Handle dispatching domains + + elsif T.Common.Domain /= null + and then (T.Common.Domain /= ST.System_Domain + or else T.Common.Domain.all /= + (Multiprocessors.CPU'First .. + Multiprocessors.Number_Of_CPUs => True)) + then + declare + CPU_Set : unsigned := 0; + + begin + -- Set the affinity to all the processors belonging to the + -- dispatching domain. + + for Proc in T.Common.Domain'Range loop + if T.Common.Domain (Proc) then + + -- The thread affinity mask is a bit vector in which each + -- bit represents a logical processor. + + CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1); + end if; + end loop; + + Result := taskMaskAffinitySet (T.Common.LL.Thread, CPU_Set); + end; end if; - end Initialize; + end Set_Task_Affinity; end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads index 5c571d41b69..feb6f558c1f 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -543,4 +543,13 @@ package System.Task_Primitives.Operations is -- such functionality. Such functionality is needed by gdb on some targets -- (e.g VxWorks) Return True is the operation is successful + ------------------- + -- Task affinity -- + ------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id); + -- Enforce at the operating system level the task affinity defined in the + -- Ada Task Control Block. Has no effect if the underlying operating system + -- does not support this capability. + end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index 5c83412435f..aab0ac7319e 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2011, 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- -- @@ -184,7 +184,7 @@ package body System.Tasking.Restricted.Stages is Secondary_Stack : aliased SSE.Storage_Array (1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size * - SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100); + SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100); pragma Warnings (Off); Secondary_Stack_Address : System.Address := Secondary_Stack'Address; @@ -505,11 +505,13 @@ package body System.Tasking.Restricted.Stages is Write_Lock (Self_ID); -- With no task hierarchy, the parent of all non-Environment tasks that - -- are created must be the Environment task + -- are created must be the Environment task. Dispatching domains are + -- not allowed in Ravenscar, so the dispatching domain parameter will + -- always be null. Initialize_ATCB (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, - Base_CPU, Task_Info, Size, Created_Task, Success); + Base_CPU, null, Task_Info, Size, Created_Task, Success); -- If we do our job right then there should never be any failures, which -- was probably said about the Titanic; so just to be safe, let's retain diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index d2d29f9246e..17af0620b14 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -99,6 +99,7 @@ package body System.Tasking is Elaborated : Access_Boolean; Base_Priority : System.Any_Priority; Base_CPU : System.Multiprocessors.CPU_Range; + Domain : Dispatching_Domain_Access; Task_Info : System.Task_Info.Task_Info_Type; Stack_Size : System.Parameters.Size_Type; T : Task_Id; @@ -121,6 +122,7 @@ package body System.Tasking is T.Common.Parent := Parent; T.Common.Base_Priority := Base_Priority; T.Common.Base_CPU := Base_CPU; + T.Common.Domain := Domain; T.Common.Current_Priority := 0; T.Common.Protected_Action_Nesting := 0; T.Common.Call := null; @@ -187,6 +189,8 @@ package body System.Tasking is Base_CPU : System.Multiprocessors.CPU_Range; Success : Boolean; + use type System.Multiprocessors.CPU_Range; + begin if Initialized then return; @@ -209,7 +213,7 @@ package body System.Tasking is T := STPO.New_ATCB (0); Initialize_ATCB (null, null, Null_Address, Null_Task, null, Base_Priority, Base_CPU, - Task_Info.Unspecified_Task_Info, 0, T, Success); + null, Task_Info.Unspecified_Task_Info, 0, T, Success); pragma Assert (Success); STPO.Initialize (T); @@ -218,6 +222,34 @@ package body System.Tasking is T.Common.Task_Image_Len := Main_Task_Image'Length; T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image; + -- At program start-up the environment task is allocated to the default + -- system dispatching domain. + -- Make sure that the processors which are not available are not taken + -- into account. Use Number_Of_CPUs to know the exact number of + -- processors in the system at execution time. + + System_Domain := + new Dispatching_Domain' + (Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs => + True); + + T.Common.Domain := System_Domain; + + Dispatching_Domain_Tasks := + new Array_Allocated_Tasks' + (Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs => 0); + + -- Signal that this task is being allocated to a processor + + if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then + + -- Increase the number of tasks attached to the CPU to which this + -- task is allocated. + + Dispatching_Domain_Tasks (Base_CPU) := + Dispatching_Domain_Tasks (Base_CPU) + 1; + end if; + -- Only initialize the first element since others are not relevant -- in ravenscar mode. Rest of the initialization is done in Init_RTS. diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 40772c94d09..8b4e61a89c1 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -375,6 +375,66 @@ package System.Tasking is -- terminates. ------------------------------------ + -- Dispatching domain definitions -- + ------------------------------------ + + -- We need to redefine here these types (already defined in + -- System.Multiprocessor.Dispatching_Domains) for avoiding circular + -- dependencies. + + type Dispatching_Domain is + array (System.Multiprocessors.CPU range <>) of Boolean; + -- A dispatching domain needs to contain the set of processors belonging + -- to it. This is a processor mask where a True indicates that the + -- processor belongs to the dispatching domain. + -- Do not use the full range of CPU_Range because it would create a very + -- long array. This way we can use the exact range of processors available + -- in the system. + + type Dispatching_Domain_Access is access Dispatching_Domain; + + System_Domain : Dispatching_Domain_Access; + -- All processors belong to default system dispatching domain at start up. + -- We use a pointer which creates the actual variable for the reasons + -- explained bellow in Dispatching_Domain_Tasks. + + Dispatching_Domains_Frozen : Boolean := False; + -- True when the main procedure has been called. Hence, no new dispatching + -- domains can be created when this flag is True. + + type Array_Allocated_Tasks is + array (System.Multiprocessors.CPU range <>) of Natural; + -- At start-up time, we need to store the number of tasks attached to + -- concrete processors within the system domain (we can only create + -- dispatching domains with processors belonging to the system domain and + -- without tasks allocated). + + type Array_Allocated_Tasks_Access is access Array_Allocated_Tasks; + + Dispatching_Domain_Tasks : Array_Allocated_Tasks_Access; + -- We need to store whether there are tasks allocated to concrete + -- processors in the default system dispatching domain because we need to + -- check it before creating a new dispatching domain. Two comments about + -- why we use a pointer here and not in package Dispatching_Domains: + -- + -- 1) We use an array created dynamically in procedure Initialize which + -- is called at the beginning of the initialization of the run-time + -- library. Declaring a static array here in the spec would not work + -- across different installations because it would get the value of + -- Number_Of_CPUs from the machine where the run-time library is built, + -- and not from the machine where the application is executed. That is + -- the reason why we create the array (CPU'First .. Number_Of_CPUs) at + -- execution time in the procedure body, ensuring that the function + -- Number_Of_CPUs is executed at execution time (the same trick as we + -- use for System_Domain). + -- + -- 2) We have moved this declaration from package Dispatching_Domains + -- because when we use a pragma CPU, the affinity is passed through the + -- call to Create_Task. Hence, at this point, we may need to update the + -- number of tasks associated to the processor, but we do not want to + -- force a dependency from this package on Dispatching_Domains. + + ------------------------------------ -- Task related other definitions -- ------------------------------------ @@ -396,9 +456,8 @@ package System.Tasking is function Storage_Size (T : Task_Id) return System.Parameters.Size_Type; -- Retrieve from the TCB of the task the allocated size of its stack, - -- either the system default or the size specified by a pragma. This - -- is in general a non-static value that can depend on discriminants - -- of the task. + -- either the system default or the size specified by a pragma. This is in + -- general a non-static value that can depend on discriminants of the task. type Bit_Array is array (Integer range <>) of Boolean; pragma Pack (Bit_Array); @@ -406,8 +465,8 @@ package System.Tasking is subtype Debug_Event_Array is Bit_Array (1 .. 16); Global_Task_Debug_Event_Set : Boolean := False; - -- Set True when running under debugger control and a task debug - -- event signal has been requested. + -- Set True when running under debugger control and a task debug event + -- signal has been requested. ---------------------------------------------- -- Ada_Task_Control_Block (ATCB) definition -- @@ -585,8 +644,8 @@ package System.Tasking is -- Master_Completion_Sleep (phase 1) -- This is the number dependent tasks of a master being completed by - -- Self that are not activated, not terminated, and not waiting on a - -- terminate alternative. + -- Self that are activated, but have not yet terminated, and are not + -- waiting on a terminate alternative. -- Master_Completion_2_Sleep (phase 2) @@ -637,6 +696,16 @@ package System.Tasking is Debug_Events : Debug_Event_Array; -- Word length array of per task debug events, of which 11 kinds are -- currently defined in System.Tasking.Debugging package. + + Domain : Dispatching_Domain_Access; + -- Domain is the dispatching domain to which the task belongs. It is + -- only changed via dispatching domains package. This field is made + -- part of the Common_ATCB, even when restricted run-times (namely + -- Ravenscar) do not use it, because this way the field is always + -- available to the underlying layers to set the affinity and we do not + -- need to do different things depending on the situation. + -- + -- Protection: Self.L end record; --------------------------------------- @@ -1105,6 +1174,7 @@ package System.Tasking is Elaborated : Access_Boolean; Base_Priority : System.Any_Priority; Base_CPU : System.Multiprocessors.CPU_Range; + Domain : Dispatching_Domain_Access; Task_Info : System.Task_Info.Task_Info_Type; Stack_Size : System.Parameters.Size_Type; T : Task_Id; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 61f0c16c63e..224b197eaf8 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -475,6 +475,7 @@ package body System.Tasking.Stages is Task_Info : System.Task_Info.Task_Info_Type; CPU : Integer; Relative_Deadline : Ada.Real_Time.Time_Span; + Domain : Dispatching_Domain_Access; Num_Entries : Task_Entry_Index; Master : Master_Level; State : Task_Procedure_Access; @@ -492,6 +493,8 @@ package body System.Tasking.Stages is Len : Natural; Base_CPU : System.Multiprocessors.CPU_Range; + use type System.Multiprocessors.CPU_Range; + pragma Unreferenced (Relative_Deadline); -- EDF scheduling is not supported by any of the target platforms so -- this parameter is not passed any further. @@ -587,7 +590,7 @@ package body System.Tasking.Stages is end if; Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, - Base_Priority, Base_CPU, Task_Info, Size, T, Success); + Base_Priority, Base_CPU, Domain, Task_Info, Size, T, Success); if not Success then Free (T); @@ -638,12 +641,53 @@ package body System.Tasking.Stages is T.Common.Task_Image_Len := Len; end if; + -- The task inherits the dispatching domain of the parent only if no + -- specific domain has been defined in the spec of the task (using the + -- dispatching domain pragma or aspect). + + if T.Common.Domain /= null then + null; + elsif T.Common.Activator /= null then + T.Common.Domain := T.Common.Activator.Common.Domain; + else + T.Common.Domain := System.Tasking.System_Domain; + end if; + Unlock (Self_ID); Unlock_RTS; - -- Note: we should not call 'new' while holding locks since new - -- may use locks (e.g. RTS_Lock under Windows) itself and cause a - -- deadlock. + -- The CPU associated to the task (if any) must belong to the + -- dispatching domain. + + if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU + and then + (Base_CPU not in T.Common.Domain'Range + or else not T.Common.Domain (Base_CPU)) + then + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Tasking_Error with "CPU not in dispatching domain"; + end if; + + -- To handle the interaction between pragma CPU and dispatching domains + -- we need to signal that this task is being allocated to a processor. + -- This is needed only for tasks belonging to the system domain (the + -- creation of new dispatching domains can only take processors from the + -- system domain) and only before the environment task calls the main + -- procedure (dispatching domains cannot be created after this). + + if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU + and then T.Common.Domain = System.Tasking.System_Domain + and then not System.Tasking.Dispatching_Domains_Frozen + then + -- Increase the number of tasks attached to the CPU to which this + -- task is being moved. + + Dispatching_Domain_Tasks (Base_CPU) := + Dispatching_Domain_Tasks (Base_CPU) + 1; + end if; + + -- Note: we should not call 'new' while holding locks since new may use + -- locks (e.g. RTS_Lock under Windows) itself and cause a deadlock. if Build_Entry_Names then T.Entry_Names := @@ -1023,9 +1067,10 @@ package body System.Tasking.Stages is Secondary_Stack_Size : constant SSE.Storage_Offset := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size * - SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100; + SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100; Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size); + -- Actual area allocated for secondary stack Secondary_Stack_Address : System.Address := Secondary_Stack'Address; -- Address of secondary stack. In the fixed secondary stack case, this @@ -1086,6 +1131,8 @@ package body System.Tasking.Stages is end if; end Search_Fall_Back_Handler; + -- Start of processing for Task_Wrapper + begin pragma Assert (Self_ID.Deferral_Level = 1); diff --git a/gcc/ada/s-tassta.ads b/gcc/ada/s-tassta.ads index 6b8c7d7df3b..9058d068a4a 100644 --- a/gcc/ada/s-tassta.ads +++ b/gcc/ada/s-tassta.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -172,6 +172,7 @@ package System.Tasking.Stages is Task_Info : System.Task_Info.Task_Info_Type; CPU : Integer; Relative_Deadline : Ada.Real_Time.Time_Span; + Domain : Dispatching_Domain_Access; Num_Entries : Task_Entry_Index; Master : Master_Level; State : Task_Procedure_Access; @@ -195,6 +196,8 @@ package System.Tasking.Stages is -- before setting the affinity at run time. -- Relative_Deadline is the relative deadline associated with the created -- task by means of a pragma Relative_Deadline, or 0.0 if none. + -- Domain is the dispatching domain associated with the created task by + -- means of a Dispatching_Domain pragma or aspect, or null if none. -- State is the compiler generated task's procedure body -- Discriminants is a pointer to a limited record whose discriminants -- are those of the task to create. This parameter should be passed as diff --git a/gcc/ada/s-tporft.adb b/gcc/ada/s-tporft.adb index 0158ca28401..1da22901997 100644 --- a/gcc/ada/s-tporft.adb +++ b/gcc/ada/s-tporft.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2011, 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- -- @@ -65,7 +65,7 @@ begin System.Tasking.Initialize_ATCB (Self_Id, null, Null_Address, Null_Task, Foreign_Task_Elaborated'Access, - System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, + System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, null, Task_Info.Unspecified_Task_Info, 0, Self_Id, Succeeded); Unlock_RTS; pragma Assert (Succeeded); diff --git a/gcc/ada/s-vaflop-vms-alpha.adb b/gcc/ada/s-vaflop-vms-alpha.adb index ba607f62d39..d03b04734a5 100644 --- a/gcc/ada/s-vaflop-vms-alpha.adb +++ b/gcc/ada/s-vaflop-vms-alpha.adb @@ -35,11 +35,6 @@ with System.Machine_Code; use System.Machine_Code; package body System.Vax_Float_Operations is - -- Ensure this gets compiled with -O to avoid extra (and possibly - -- improper) memory stores. - - pragma Optimize (Time); - -- Declare the functions that do the conversions between floating-point -- formats. Call the operands IEEE float so they get passed in -- FP registers. diff --git a/gcc/ada/s-vxwext-kernel.adb b/gcc/ada/s-vxwext-kernel.adb index d43edf15429..cd2ac264266 100644 --- a/gcc/ada/s-vxwext-kernel.adb +++ b/gcc/ada/s-vxwext-kernel.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2011, 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- -- @@ -75,6 +75,16 @@ package body System.VxWorks.Ext is return ERROR; end taskCpuAffinitySet; + ------------------------- + -- taskMaskAffinitySet -- + ------------------------- + + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is + pragma Unreferenced (tid, CPU_Set); + begin + return ERROR; + end taskMaskAffinitySet; + -------------- -- taskStop -- -------------- diff --git a/gcc/ada/s-vxwext-kernel.ads b/gcc/ada/s-vxwext-kernel.ads index 59dfee03ac7..ff41666fbed 100644 --- a/gcc/ada/s-vxwext-kernel.ads +++ b/gcc/ada/s-vxwext-kernel.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2011, 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- -- @@ -43,6 +43,7 @@ package System.VxWorks.Ext is type t_id is new Long_Integer; subtype int is Interfaces.C.int; + subtype unsigned is Interfaces.C.unsigned; type Interrupt_Handler is access procedure (parameter : System.Address); pragma Convention (C, Interrupt_Handler); @@ -101,4 +102,9 @@ package System.VxWorks.Ext is -- For SMP run-times set the CPU affinity. -- For uniprocessor systems return ERROR status. + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int; + pragma Convention (C, taskMaskAffinitySet); + -- For SMP run-times set the CPU mask affinity. + -- For uniprocessor systems return ERROR status. + end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext-rtp.adb b/gcc/ada/s-vxwext-rtp.adb index 431f41e7499..e5f74062ca2 100644 --- a/gcc/ada/s-vxwext-rtp.adb +++ b/gcc/ada/s-vxwext-rtp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2011, 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- -- @@ -121,4 +121,14 @@ package body System.VxWorks.Ext is return ERROR; end taskCpuAffinitySet; + ------------------------- + -- taskMaskAffinitySet -- + ------------------------- + + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is + pragma Unreferenced (tid, CPU_Set); + begin + return ERROR; + end taskMaskAffinitySet; + end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext-rtp.ads b/gcc/ada/s-vxwext-rtp.ads index f1783c9c22a..ed734578c0b 100644 --- a/gcc/ada/s-vxwext-rtp.ads +++ b/gcc/ada/s-vxwext-rtp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2011, 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- -- @@ -43,6 +43,7 @@ package System.VxWorks.Ext is type t_id is new Long_Integer; subtype int is Interfaces.C.int; + subtype unsigned is Interfaces.C.unsigned; type Interrupt_Handler is access procedure (parameter : System.Address); pragma Convention (C, Interrupt_Handler); @@ -95,4 +96,9 @@ package System.VxWorks.Ext is -- For SMP run-times set the CPU affinity. -- For uniprocessor systems return ERROR status. + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int; + pragma Convention (C, taskMaskAffinitySet); + -- For SMP run-times set the CPU mask affinity. + -- For uniprocessor systems return ERROR status. + end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext.adb b/gcc/ada/s-vxwext.adb index cfc65da62b6..a386af91d0f 100644 --- a/gcc/ada/s-vxwext.adb +++ b/gcc/ada/s-vxwext.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,4 +42,14 @@ package body System.VxWorks.Ext is return ERROR; end taskCpuAffinitySet; + ------------------------- + -- taskMaskAffinitySet -- + ------------------------- + + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is + pragma Unreferenced (tid, CPU_Set); + begin + return ERROR; + end taskMaskAffinitySet; + end System.VxWorks.Ext; diff --git a/gcc/ada/s-vxwext.ads b/gcc/ada/s-vxwext.ads index f39ccbf3f63..6e7cd16331a 100644 --- a/gcc/ada/s-vxwext.ads +++ b/gcc/ada/s-vxwext.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2011, 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- -- @@ -44,6 +44,7 @@ package System.VxWorks.Ext is type t_id is new Long_Integer; subtype int is Interfaces.C.int; + subtype unsigned is Interfaces.C.unsigned; type Interrupt_Handler is access procedure (parameter : System.Address); pragma Convention (C, Interrupt_Handler); @@ -96,4 +97,9 @@ package System.VxWorks.Ext is -- For SMP run-times set the CPU affinity. -- For uniprocessor systems return ERROR status. + function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int; + pragma Convention (C, taskMaskAffinitySet); + -- For SMP run-times set the CPU mask affinity. + -- For uniprocessor systems return ERROR status. + end System.VxWorks.Ext; diff --git a/gcc/ada/s-winext.ads b/gcc/ada/s-winext.ads index 22a7ab29ba0..803a6483ca4 100644 --- a/gcc/ada/s-winext.ads +++ b/gcc/ada/s-winext.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +53,11 @@ package System.Win32.Ext is dwIdealProcessor : ProcessorId) return DWORD; pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor"); + function SetThreadAffinityMask + (hThread : HANDLE; + dwThreadAffinityMask : DWORD) return DWORD; + pragma Import (Stdcall, SetThreadAffinityMask, "SetThreadAffinityMask"); + -------------- -- Com Port -- -------------- diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 7c0bb820d54..904c6bfe9b8 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -458,8 +458,8 @@ package SCOs is -- This table keeps track of the units and the corresponding starting and -- ending indexes (From, To) in the SCO table. Note that entry zero is - -- unused, it is for convenience in calling the sort routine. Thus the - -- real lower bound for active entries is 1. + -- present but unused, it is for convenience in calling the sort routine. + -- Thus the lower bound for real entries is 1. type SCO_Unit_Index is new Int; -- Used to index values in this table. Values start at 1 and are assigned diff --git a/gcc/ada/seh_init.c b/gcc/ada/seh_init.c index 610df54d6ab..89c9ea48e09 100644 --- a/gcc/ada/seh_init.c +++ b/gcc/ada/seh_init.c @@ -99,7 +99,7 @@ __gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord, { /* otherwise it is a stack overflow */ exception = &storage_error; - msg = "stack overflow (or erroneous memory access)"; + msg = "stack overflow or erroneous memory access"; } break; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index ec108be4e47..4af133c2367 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1053,7 +1053,14 @@ package body Sem_Aggr is -- Ada 2005 (AI-287): Limited aggregates allowed - if Is_Limited_Type (Typ) and then Ada_Version < Ada_2005 then + -- In an instance, ignore aggregate subcomponents tnat may be limited, + -- because they originate in view conflicts. If the original aggregate + -- is legal and the actuals are legal, the aggregate itself is legal. + + if Is_Limited_Type (Typ) + and then Ada_Version < Ada_2005 + and then not In_Instance + then Error_Msg_N ("aggregate type cannot be limited", N); Explain_Limited_Type (Typ, N); @@ -1222,7 +1229,7 @@ package body Sem_Aggr is elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) - and then In_Inlined_Body + and then (In_Inlined_Body or In_Instance_Body) and then Is_Composite_Type (Full_View (Typ)) then Resolve (N, Full_View (Typ)); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 3adbac5cdb0..69963e44501 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -601,30 +601,35 @@ package body Sem_Attr is Build_Access_Subprogram_Type (P); - -- For unrestricted access, kill current values, since this - -- attribute allows a reference to a local subprogram that - -- could modify local variables to be passed out of scope - - if Aname = Name_Unrestricted_Access then - - -- Do not kill values on nodes initializing dispatch tables - -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access) - -- is currently generated by the expander only for this - -- purpose. Done to keep the quality of warnings currently - -- generated by the compiler (otherwise any declaration of - -- a tagged type cleans constant indications from its scope). - - if Nkind (Parent (N)) = N_Unchecked_Type_Conversion - and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr) - or else - Etype (Parent (N)) = RTE (RE_Size_Ptr)) - and then Is_Dispatching_Operation - (Directly_Designated_Type (Etype (N))) - then - null; - else - Kill_Current_Values; - end if; + -- For P'Access or P'Unrestricted_Access, where P is a nested + -- subprogram, we might be passing P to another subprogram (but we + -- don't check that here), which might call P. P could modify + -- local variables, so we need to kill current values. It is + -- important not to do this for library-level subprograms, because + -- Kill_Current_Values is very inefficient in the case of library + -- level packages with lots of tagged types. + + if Is_Library_Level_Entity (Entity (Prefix (N))) then + null; + + -- Do not kill values on nodes initializing dispatch tables + -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access) + -- is currently generated by the expander only for this + -- purpose. Done to keep the quality of warnings currently + -- generated by the compiler (otherwise any declaration of + -- a tagged type cleans constant indications from its scope). + + elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion + and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr) + or else + Etype (Parent (N)) = RTE (RE_Size_Ptr)) + and then Is_Dispatching_Operation + (Directly_Designated_Type (Etype (N))) + then + null; + + else + Kill_Current_Values; end if; return; @@ -1939,7 +1944,7 @@ package body Sem_Attr is -- Analyze prefix and exit if error in analysis. If the prefix is an -- incomplete type, use full view if available. Note that there are -- some attributes for which we do not analyze the prefix, since the - -- prefix is not a normal name. + -- prefix is not a normal name, or else needs special handling. if Aname /= Name_Elab_Body and then @@ -1950,6 +1955,8 @@ package body Sem_Attr is Aname /= Name_UET_Address and then Aname /= Name_Enabled + and then + Aname /= Name_Old then Analyze (P); P_Type := Etype (P); @@ -3772,6 +3779,12 @@ package body Sem_Attr is end if; Check_E0; + + -- Prefix has not been analyzed yet, and its full analysis will take + -- place during expansion (see below). + + Preanalyze_And_Resolve (P); + P_Type := Etype (P); Set_Etype (N, P_Type); if No (Current_Subprogram) then @@ -3852,6 +3865,45 @@ package body Sem_Attr is end if; end Check_Local; + -- The attribute appears within a pre/postcondition, but refers to + -- an entity in the enclosing subprogram. If it is a component of a + -- formal its expansion might generate actual subtypes that may be + -- referenced in an inner context, and which must be elaborated + -- within the subprogram itself. As a result we create a declaration + -- for it and insert it at the start of the enclosing subprogram + -- This is properly an expansion activity but it has to be performed + -- now to prevent out-of-order issues. + + if Nkind (P) = N_Selected_Component + and then Has_Discriminants (Etype (Prefix (P))) + then + P_Type := Base_Type (P_Type); + Set_Etype (N, P_Type); + Set_Etype (P, P_Type); + Expand (N); + end if; + + ---------------------- + -- Overlaps_Storage -- + ---------------------- + + when Attribute_Overlaps_Storage => + if Ada_Version < Ada_2012 then + Error_Msg_N + ("attribute Overlaps_Storage is an Ada 2012 feature", N); + Error_Msg_N + ("\unit must be compiled with -gnat2012 switch", N); + end if; + Check_E1; + + -- Both arguments must be objects of any type + + Analyze_And_Resolve (P); + Analyze_And_Resolve (E1); + Check_Object_Reference (P); + Check_Object_Reference (E1); + Set_Etype (N, Standard_Boolean); + ------------ -- Output -- ------------ @@ -4328,6 +4380,28 @@ package body Sem_Attr is Check_Real_Type; Set_Etype (N, Universal_Real); + ------------------ + -- Same_Storage -- + ------------------ + + when Attribute_Same_Storage => + if Ada_Version < Ada_2012 then + Error_Msg_N + ("attribute Same_Storage is an Ada 2012 feature", N); + Error_Msg_N + ("\unit must be compiled with -gnat2012 switch", N); + end if; + + Check_E1; + + -- The arguments must be objects of any type + + Analyze_And_Resolve (P); + Analyze_And_Resolve (E1); + Check_Object_Reference (P); + Check_Object_Reference (E1); + Set_Etype (N, Standard_Boolean); + ----------- -- Scale -- ----------- @@ -6885,6 +6959,13 @@ package body Sem_Attr is end if; end Object_Size; + ---------------------- + -- Overlaps_Storage -- + ---------------------- + + when Attribute_Overlaps_Storage => + null; + ------------------------- -- Passed_By_Reference -- ------------------------- @@ -7114,6 +7195,13 @@ package body Sem_Attr is Fold_Ureal (N, Model_Small_Value (P_Type), Static); end if; + ------------------ + -- Same_Storage -- + ------------------ + + when Attribute_Same_Storage => + null; + ----------- -- Scale -- ----------- @@ -8312,8 +8400,16 @@ package body Sem_Attr is -- the level is the same of the enclosing composite type. if Ada_Version >= Ada_2005 - and then Is_Local_Anonymous_Access (Btyp) - and then Object_Access_Level (P) > Type_Access_Level (Btyp) + and then (Is_Local_Anonymous_Access (Btyp) + + -- Handle cases where Btyp is the + -- anonymous access type of an Ada 2012 + -- stand-alone object. + + or else Nkind (Associated_Node_For_Itype (Btyp)) = + N_Object_Declaration) + and then Object_Access_Level (P) + > Deepest_Type_Access_Level (Btyp) and then Attr_Id = Attribute_Access then -- In an instance, this is a runtime check, but one we @@ -8775,6 +8871,7 @@ package body Sem_Attr is declare LB : Node_Id; HB : Node_Id; + Dims : List_Id; begin if not Is_Entity_Name (P) @@ -8783,18 +8880,30 @@ package body Sem_Attr is Resolve (P); end if; + Dims := Expressions (N); + HB := Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr (P, Name_Req => True), Attribute_Name => Name_Last, - Expressions => Expressions (N)); + Expressions => Dims); LB := Make_Attribute_Reference (Loc, - Prefix => P, + Prefix => P, Attribute_Name => Name_First, - Expressions => Expressions (N)); + Expressions => (Dims)); + + -- Do not share the dimension indicator, if present. Even + -- though it is a static constant, its source location + -- may be modified when printing expanded code and node + -- sharing will lead to chaos in Sprint. + + if Present (Dims) then + Set_Expressions (LB, + New_List (New_Copy_Tree (First (Dims)))); + end if; -- If the original was marked as Must_Not_Freeze (see code -- in Sem_Ch3.Make_Index), then make sure the rewriting diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 8c54517c236..974ff1d9712 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -445,9 +445,7 @@ package body Sem_Aux is Btype : constant Entity_Id := Base_Type (Ent); begin - if Error_Posted (Ent) - or else Error_Posted (Btype) - then + if Error_Posted (Ent) or else Error_Posted (Btype) then return False; elsif Is_Private_Type (Btype) then diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index ce7c9b360e0..a0f0a798858 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2289,7 +2289,7 @@ package body Sem_Ch10 is -- expansion is active, because the context may be generic and the -- flag not defined yet. - if Expander_Active then + if Full_Expander_Active then Insert_After (N, Make_Assignment_Statement (Loc, Name => @@ -2536,6 +2536,21 @@ package body Sem_Ch10 is -- Child unit in a with clause Change_Selected_Component_To_Expanded_Name (Name (N)); + + -- If this is a child unit without a spec, and it has benn analyzed + -- already, a declaration has been created for it. The with_clause + -- must reflect the actual body, and not the generated declaration, + -- to prevent spurious binding errors involving an out-of-date spec. + -- Note that this can only happen if the unit includes more than one + -- with_clause for the child unit (e.g. in separate subunits). + + if Unit_Kind = N_Subprogram_Declaration + and then Analyzed (Library_Unit (N)) + and then not Comes_From_Source (Library_Unit (N)) + then + Set_Library_Unit (N, + Cunit (Get_Source_Unit (Corresponding_Body (U)))); + end if; end if; -- Restore style checks and restrictions diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index fbc9aa906fe..5ab7783b277 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -516,11 +516,14 @@ package body Sem_Ch12 is -- of packages that are early instantiations are delayed, and their freeze -- node appears after the generic body. - procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id); - -- Insert freeze node at the end of the declarative part that includes the - -- instance node N. If N is in the visible part of an enclosing package - -- declaration, the freeze node has to be inserted at the end of the - -- private declarations, if any. + procedure Insert_Freeze_Node_For_Instance + (N : Node_Id; + F_Node : Node_Id); + -- N denotes a package or a subprogram instantiation and F_Node is the + -- associated freeze node. Insert the freeze node before the first source + -- body which follows immediately after N. If no such body is found, the + -- freeze node is inserted at the end of the declarative region which + -- contains N. procedure Freeze_Subprogram_Body (Inst_Node : Node_Id; @@ -2381,6 +2384,7 @@ package body Sem_Ch12 is Enter_Name (T); Set_Ekind (T, E_Incomplete_Type); Set_Etype (T, T); + Set_Private_Dependents (T, New_Elmt_List); if Tagged_Present (Def) then Set_Is_Tagged_Type (T); @@ -3435,7 +3439,7 @@ package body Sem_Ch12 is or else Might_Inline_Subp) and then not Is_Actual_Pack and then not Inline_Now - and then not ALFA_Mode + and then not Alfa_Mode and then (Operating_Mode = Generate_Code or else (Operating_Mode = Check_Semantics and then ASIS_Mode)); @@ -4049,11 +4053,10 @@ package body Sem_Ch12 is if (Is_In_Main_Unit (N) or else Is_Inlined (Subp) or else Is_Inlined (Alias (Subp))) - and then not ALFA_Mode and then (Operating_Mode = Generate_Code or else (Operating_Mode = Check_Semantics and then ASIS_Mode)) - and then (Expander_Active or else ASIS_Mode) + and then (Full_Expander_Active or else ASIS_Mode) and then not ABE_Is_Certain (N) and then not Is_Eliminated (Subp) then @@ -6698,12 +6701,12 @@ package body Sem_Ch12 is Gen_Body : Node_Id; Pack_Id : Entity_Id) is - F_Node : Node_Id; Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); Par : constant Entity_Id := Scope (Gen_Unit); + E_G_Id : Entity_Id; Enc_G : Entity_Id; Enc_I : Node_Id; - E_G_Id : Entity_Id; + F_Node : Node_Id; function Earlier (N1, N2 : Node_Id) return Boolean; -- Yields True if N1 and N2 appear in the same compilation unit, @@ -6881,15 +6884,37 @@ package body Sem_Ch12 is if Is_Generic_Instance (Par) and then Present (Freeze_Node (Par)) - and then - In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node) + and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node) then - if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then + -- The parent was a premature instantiation. Insert freeze node at + -- the end the current declarative part. - -- The parent was a premature instantiation. Insert freeze node at - -- the end the current declarative part. - - Insert_After_Last_Decl (Inst_Node, F_Node); + if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then + Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); + + -- Handle the following case: + -- + -- package Parent_Inst is new ... + -- Parent_Inst [] + -- + -- procedure P ... -- this body freezes Parent_Inst + -- + -- package Inst is new ... + -- + -- In this particular scenario, the freeze node for Inst must be + -- inserted in the same manner as that of Parent_Inst - before the + -- next source body or at the end of the declarative list (body not + -- available). If body P did not exist and Parent_Inst was frozen + -- after Inst, either by a body following Inst or at the end of the + -- declarative region, the freeze node for Inst must be inserted + -- after that of Parent_Inst. This relation is established by + -- comparing the Slocs of Parent_Inst freeze node and Inst. + + elsif List_Containing (Get_Package_Instantiation_Node (Par)) = + List_Containing (Inst_Node) + and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node) + then + Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); else Insert_After (Freeze_Node (Par), F_Node); @@ -6917,11 +6942,11 @@ package body Sem_Ch12 is -- node, we place it at the end of the declarative part of the -- parent of the generic. - Insert_After_Last_Decl + Insert_Freeze_Node_For_Instance (Freeze_Node (Par), Package_Freeze_Node (Enc_I)); end if; - Insert_After_Last_Decl (Inst_Node, F_Node); + Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); elsif Present (Enc_G) and then Present (Enc_I) @@ -6955,7 +6980,8 @@ package body Sem_Ch12 is end if; if Parent (List_Containing (Enc_G)) /= Enclosing_Body then - Insert_After_Last_Decl (Enc_G, Package_Freeze_Node (Enc_I)); + Insert_Freeze_Node_For_Instance + (Enc_G, Package_Freeze_Node (Enc_I)); end if; end; @@ -6967,13 +6993,13 @@ package body Sem_Ch12 is Insert_After (Enc_G, Freeze_Node (E_G_Id)); end if; - Insert_After_Last_Decl (Inst_Node, F_Node); + Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); else -- If none of the above, insert freeze node at the end of the current -- declarative part. - Insert_After_Last_Decl (Inst_Node, F_Node); + Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); end if; end Freeze_Subprogram_Body; @@ -7197,7 +7223,7 @@ package body Sem_Ch12 is return False; elsif Nkind (Nod) = N_Subunit then - Nod := Corresponding_Stub (Nod); + Nod := Corresponding_Stub (Nod); elsif Nkind (Nod) = N_Compilation_Unit then return False; @@ -7319,27 +7345,69 @@ package body Sem_Ch12 is Hidden_Entities := No_Elist; end Initialize; - ---------------------------- - -- Insert_After_Last_Decl -- - ---------------------------- + ------------------------------------- + -- Insert_Freeze_Node_For_Instance -- + ------------------------------------- - procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is - L : List_Id := List_Containing (N); - P : constant Node_Id := Parent (L); + procedure Insert_Freeze_Node_For_Instance + (N : Node_Id; + F_Node : Node_Id) + is + Inst : constant Entity_Id := Entity (F_Node); + Decl : Node_Id; + Decls : List_Id; + Par_N : Node_Id; begin if not Is_List_Member (F_Node) then - if Nkind (P) = N_Package_Specification - and then L = Visible_Declarations (P) - and then Present (Private_Declarations (P)) - and then not Is_Empty_List (Private_Declarations (P)) + Decls := List_Containing (N); + Par_N := Parent (Decls); + Decl := N; + + -- When the instantiation occurs in a package declaration, append the + -- freeze node to the private declarations (if any). + + if Nkind (Par_N) = N_Package_Specification + and then Decls = Visible_Declarations (Par_N) + and then Present (Private_Declarations (Par_N)) + and then not Is_Empty_List (Private_Declarations (Par_N)) + then + Decls := Private_Declarations (Par_N); + Decl := First (Decls); + end if; + + -- Determine the proper freeze point of a package instantiation. We + -- adhere to the general rule of a package or subprogram body causing + -- freezing of anything before it in the same declarative region. In + -- this case, the proper freeze point of a package instantiation is + -- before the first source body which follows. This ensures that + -- entities coming from the instance are already frozen and usable + -- in source bodies. + + if Nkind (Par_N) /= N_Package_Declaration + and then Ekind (Inst) = E_Package + and then Is_Generic_Instance (Inst) + and then + not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst) then - L := Private_Declarations (P); + while Present (Decl) loop + if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body) + and then Comes_From_Source (Decl) + then + Insert_Before (Decl, F_Node); + return; + end if; + + Next (Decl); + end loop; end if; - Insert_After (Last (L), F_Node); + -- In a package declaration, or if no previous body, insert at end + -- of list. + + Insert_After (Last (Decls), F_Node); end if; - end Insert_After_Last_Decl; + end Insert_Freeze_Node_For_Instance; ------------------ -- Install_Body -- @@ -7475,7 +7543,34 @@ package body Sem_Ch12 is -- generic. if In_Same_Declarative_Part (Freeze_Node (Par), N) then - Insert_After (Freeze_Node (Par), F_Node); + + -- Handle the following case: + -- + -- package Parent_Inst is new ... + -- Parent_Inst [] + -- + -- procedure P ... -- this body freezes Parent_Inst + -- + -- package Inst is new ... + -- + -- In this particular scenario, the freeze node for Inst must + -- be inserted in the same manner as that of Parent_Inst - + -- before the next source body or at the end of the declarative + -- list (body not available). If body P did not exist and + -- Parent_Inst was frozen after Inst, either by a body + -- following Inst or at the end of the declarative region, the + -- freeze node for Inst must be inserted after that of + -- Parent_Inst. This relation is established by comparing the + -- Slocs of Parent_Inst freeze node and Inst. + + if List_Containing (Get_Package_Instantiation_Node (Par)) = + List_Containing (N) + and then Sloc (Freeze_Node (Par)) < Sloc (N) + then + Insert_Freeze_Node_For_Instance (N, F_Node); + else + Insert_After (Freeze_Node (Par), F_Node); + end if; -- Freeze package enclosing instance of inner generic after -- instance of enclosing generic. @@ -7483,26 +7578,48 @@ package body Sem_Ch12 is elsif Nkind (Parent (N)) = N_Package_Body and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N)) then - declare Enclosing : constant Entity_Id := Corresponding_Spec (Parent (N)); begin - Insert_After_Last_Decl (N, F_Node); + Insert_Freeze_Node_For_Instance (N, F_Node); Ensure_Freeze_Node (Enclosing); if not Is_List_Member (Freeze_Node (Enclosing)) then - Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing)); + + -- The enclosing context is a subunit, insert the freeze + -- node after the stub. + + if Nkind (Parent (Parent (N))) = N_Subunit then + Insert_Freeze_Node_For_Instance + (Corresponding_Stub (Parent (Parent (N))), + Freeze_Node (Enclosing)); + + -- The parent instance has been frozen before the body of + -- the enclosing package, insert the freeze node after + -- the body. + + elsif List_Containing (Freeze_Node (Par)) = + List_Containing (Parent (N)) + and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N)) + then + Insert_Freeze_Node_For_Instance + (Parent (N), Freeze_Node (Enclosing)); + + else + Insert_After + (Freeze_Node (Par), Freeze_Node (Enclosing)); + end if; end if; end; else - Insert_After_Last_Decl (N, F_Node); + Insert_Freeze_Node_For_Instance (N, F_Node); end if; else - Insert_After_Last_Decl (N, F_Node); + Insert_Freeze_Node_For_Instance (N, F_Node); end if; end if; @@ -10301,11 +10418,15 @@ package body Sem_Ch12 is and then not Is_Limited_Type (A_Gen_T) and then Ada_Version >= Ada_2012 then - Error_Msg_NE - ("actual for non-limited & cannot be a limited type", Actual, - Gen_T); - Explain_Limited_Type (Act_T, Actual); - Abandon_Instantiation (Actual); + if In_Instance then + null; + else + Error_Msg_NE + ("actual for non-limited & cannot be a limited type", Actual, + Gen_T); + Explain_Limited_Type (Act_T, Actual); + Abandon_Instantiation (Actual); + end if; end if; end Validate_Derived_Type_Instance; @@ -10439,11 +10560,15 @@ package body Sem_Ch12 is if Is_Limited_Type (Act_T) and then not Is_Limited_Type (A_Gen_T) then - Error_Msg_NE - ("actual for non-limited & cannot be a limited type", Actual, - Gen_T); - Explain_Limited_Type (Act_T, Actual); - Abandon_Instantiation (Actual); + if In_Instance then + null; + else + Error_Msg_NE + ("actual for non-limited & cannot be a limited type", Actual, + Gen_T); + Explain_Limited_Type (Act_T, Actual); + Abandon_Instantiation (Actual); + end if; elsif Known_To_Have_Preelab_Init (A_Gen_T) and then not Has_Preelaborable_Initialization (Act_T) @@ -12612,6 +12737,22 @@ package body Sem_Ch12 is end if; end; end if; + + -- If a node has aspects, references within their expressions must + -- be saved separately, given that they are not directly in the + -- tree. + + if Has_Aspects (N) then + declare + Aspect : Node_Id; + begin + Aspect := First (Aspect_Specifications (N)); + while Present (Aspect) loop + Save_Global_References (Expression (Aspect)); + Next (Aspect); + end loop; + end; + end if; end Save_References; -- Start of processing for Save_Global_References diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index a926280b2a0..17f49a8ef3a 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1149,27 +1149,41 @@ package body Sem_Ch13 is pragma Assert (not Delay_Required); - when Aspect_Priority | Aspect_Interrupt_Priority => declare - Pname : Name_Id; + when Aspect_Priority | + Aspect_Interrupt_Priority | + Aspect_Dispatching_Domain | + Aspect_CPU => + declare + Pname : Name_Id; - begin - if A_Id = Aspect_Priority then - Pname := Name_Priority; - else - Pname := Name_Interrupt_Priority; - end if; + begin + if A_Id = Aspect_Priority then + Pname := Name_Priority; - Aitem := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Sloc (Id), Pname), - Pragma_Argument_Associations => - New_List (Relocate_Node (Expr))); + elsif A_Id = Aspect_Interrupt_Priority then + Pname := Name_Interrupt_Priority; - Set_From_Aspect_Specification (Aitem, True); + elsif A_Id = Aspect_CPU then + Pname := Name_CPU; - pragma Assert (not Delay_Required); - end; + else + Pname := Name_Dispatching_Domain; + end if; + + Aitem := + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Sloc (Id), Pname), + Pragma_Argument_Associations => + New_List + (Make_Pragma_Argument_Association + (Sloc => Sloc (Id), + Expression => Relocate_Node (Expr)))); + + Set_From_Aspect_Specification (Aitem, True); + + pragma Assert (not Delay_Required); + end; -- Aspects Pre/Post generate Precondition/Postcondition pragmas -- with a first argument that is the expression, and a second @@ -1486,9 +1500,13 @@ package body Sem_Ch13 is -- For Priority aspects, insert into the task or -- protected definition, which we need to create if it's - -- not there. + -- not there. The same applies to CPU and + -- Dispatching_Domain but only to tasks. - when Aspect_Priority | Aspect_Interrupt_Priority => + when Aspect_Priority | + Aspect_Interrupt_Priority | + Aspect_Dispatching_Domain | + Aspect_CPU => declare T : Node_Id; -- the type declaration L : List_Id; -- list of decls of task/protected @@ -1496,12 +1514,14 @@ package body Sem_Ch13 is begin if Nkind (N) = N_Object_Declaration then T := Parent (Etype (Defining_Identifier (N))); - else T := N; end if; - if Nkind (T) = N_Protected_Type_Declaration then + if Nkind (T) = N_Protected_Type_Declaration + and then A_Id /= Aspect_Dispatching_Domain + and then A_Id /= Aspect_CPU + then pragma Assert (Present (Protected_Definition (T))); @@ -1518,14 +1538,19 @@ package body Sem_Ch13 is End_Label => Empty)); end if; - L := Visible_Declarations - (Task_Definition (T)); + L := Visible_Declarations (Task_Definition (T)); else raise Program_Error; end if; Prepend (Aitem, To => L); + + -- Analyze rewritten pragma. Otherwise, its + -- analysis is done too late, after the task or + -- protected object has been created. + + Analyze (Aitem); end; -- For all other cases, insert in sequence @@ -2009,10 +2034,10 @@ package body Sem_Ch13 is end if; -- Process Ignore_Rep_Clauses option (we also ignore rep clauses in - -- CodePeer mode or ALFA mode, since they are not relevant in these + -- CodePeer mode or Alfa mode, since they are not relevant in these -- contexts). - if Ignore_Rep_Clauses or CodePeer_Mode or ALFA_Mode then + if Ignore_Rep_Clauses or CodePeer_Mode or Alfa_Mode then case Id is -- The following should be ignored. They do not affect legality @@ -2032,7 +2057,7 @@ package body Sem_Ch13 is Rewrite (N, Make_Null_Statement (Sloc (N))); return; - -- We do not want too ignore 'Small in CodePeer_Mode or ALFA_Mode, + -- We do not want too ignore 'Small in CodePeer_Mode or Alfa_Mode, -- since it has an impact on the exact computations performed. -- Perhaps 'Small should also not be ignored by @@ -3904,9 +3929,7 @@ package body Sem_Ch13 is -- This seems dubious, this destroys the source tree in a manner -- not detectable by ASIS ??? - if Operating_Mode = Check_Semantics - and then ASIS_Mode - then + if Operating_Mode = Check_Semantics and then ASIS_Mode then AtM_Nod := Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (Base_Type (Rectype), Loc), @@ -5874,6 +5897,12 @@ package body Sem_Ch13 is when Aspect_Bit_Order => T := RTE (RE_Bit_Order); + when Aspect_CPU => + T := RTE (RE_CPU_Range); + + when Aspect_Dispatching_Domain => + T := RTE (RE_Dispatching_Domain); + when Aspect_External_Tag => T := Standard_String; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d21e8a1a8d5..91e30e65d39 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1609,6 +1609,10 @@ package body Sem_Ch3 is (Tagged_Type => Tagged_Type, Iface_Prim => Iface_Prim); + if No (Prim) and then Serious_Errors_Detected > 0 then + goto Continue; + end if; + pragma Assert (Present (Prim)); -- Ada 2012 (AI05-0197): If the name of the covering primitive @@ -1669,6 +1673,7 @@ package body Sem_Ch3 is Set_Has_Delayed_Freeze (New_Subp); end if; + <<Continue>> Next_Elmt (Elmt); end loop; @@ -2863,8 +2868,8 @@ package body Sem_Ch3 is -- 2. Those generated by the Expression - -- 3. Those used to constrained the Object Definition with the - -- expression constraints when it is unconstrained + -- 3. Those used to constrain the Object Definition with the + -- expression constraints when the definition is unconstrained. -- They must be generated in this order to avoid order of elaboration -- issues. Thus the first step (after entering the name) is to analyze @@ -2875,6 +2880,7 @@ package body Sem_Ch3 is if Present (Prev_Entity) and then + -- If the homograph is an implicit subprogram, it is overridden -- by the current declaration. @@ -7974,28 +7980,6 @@ package body Sem_Ch3 is Set_Last_Entity (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type)); end if; - - -- Update the scope of anonymous access types of discriminants and other - -- components, to prevent scope anomalies in gigi, when the derivation - -- appears in a scope nested within that of the parent. - - declare - D : Entity_Id; - - begin - D := First_Entity (Derived_Type); - while Present (D) loop - if Ekind_In (D, E_Discriminant, E_Component) then - if Is_Itype (Etype (D)) - and then Ekind (Etype (D)) = E_Anonymous_Access_Type - then - Set_Scope (Etype (D), Current_Scope); - end if; - end if; - - Next_Entity (D); - end loop; - end; end Build_Derived_Record_Type; ------------------------ @@ -9157,19 +9141,14 @@ package body Sem_Ch3 is -- The controlling formal of Subp must be of mode "out", -- "in out" or an access-to-variable to be overridden. - -- Error message below needs rewording (remember comma - -- in -gnatj mode) ??? - if Ekind (First_Formal (Subp)) = E_In_Parameter and then Ekind (Subp) /= E_Function then - if not Is_Predefined_Dispatching_Operation (Subp) then - Error_Msg_NE - ("first formal of & must be of mode `OUT`, " & - "`IN OUT` or access-to-variable", T, Subp); - Error_Msg_N - ("\to be overridden by protected procedure or " & - "entry (RM 9.4(11.9/2))", T); + if not Is_Predefined_Dispatching_Operation (Subp) + and then Is_Protected_Type + (Corresponding_Concurrent_Type (T)) + then + Error_Msg_PT (T, Subp); end if; -- Some other kind of overriding failure @@ -10304,6 +10283,7 @@ package body Sem_Ch3 is -- type, so we must be sure not to overwrite these entries. declare + Append : Boolean; Item : Node_Id; Next_Item : Node_Id; @@ -10322,15 +10302,29 @@ package body Sem_Ch3 is -- is not done, as that would create a circularity. elsif Item /= First_Rep_Item (Priv) then + Append := True; + loop Next_Item := Next_Rep_Item (Item); exit when No (Next_Item); Item := Next_Item; + + -- If the private view has aspect specifications, the full view + -- inherits them. Since these aspects may already have been + -- attached to the full view during derivation, do not append + -- them if already present. + + if Item = First_Rep_Item (Priv) then + Append := False; + exit; + end if; end loop; -- And link the private type items at the end of the chain - Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); + if Append then + Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); + end if; end if; end; @@ -11325,7 +11319,10 @@ package body Sem_Ch3 is Related_Id : Entity_Id; Suffix : Character) is - T_Ent : Entity_Id := Entity (Subtype_Mark (SI)); + -- Retrieve Base_Type to ensure getting to the concurrent type in the + -- case of a private subtype (needed when only doing semantic analysis). + + T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI))); T_Val : Entity_Id; begin @@ -15122,7 +15119,12 @@ package body Sem_Ch3 is elsif Def_Kind = N_Access_Definition then T := Access_Definition (Related_Nod, Obj_Def); - Set_Is_Local_Anonymous_Access (T); + + Set_Is_Local_Anonymous_Access + (T, + V => (Ada_Version < Ada_2012) + or else (Nkind (P) /= N_Object_Declaration) + or else Is_Library_Level_Entity (Defining_Identifier (P))); -- Otherwise, the object definition is just a subtype_mark @@ -15678,10 +15680,42 @@ package body Sem_Ch3 is Plain_Discrim : Boolean := False; Stored_Discrim : Boolean := False) is + procedure Set_Anonymous_Type (Id : Entity_Id); + -- Id denotes the entity of an access discriminant or anonymous + -- access component. Set the type of Id to either the same type of + -- Old_C or create a new one depending on whether the parent and + -- the child types are in the same scope. + + ------------------------ + -- Set_Anonymous_Type -- + ------------------------ + + procedure Set_Anonymous_Type (Id : Entity_Id) is + Typ : constant Entity_Id := Etype (Old_C); + + begin + if Scope (Parent_Base) = Scope (Derived_Base) then + Set_Etype (Id, Typ); + + -- The parent and the derived type are in two different scopes. + -- Reuse the type of the original discriminant / component by + -- copying it in order to preserve all attributes and update the + -- scope. + + else + Set_Etype (Id, New_Copy (Typ)); + Set_Scope (Etype (Id), Current_Scope); + end if; + end Set_Anonymous_Type; + + -- Local variables and constants + New_C : constant Entity_Id := New_Copy (Old_C); - Discrim : Entity_Id; Corr_Discrim : Entity_Id; + Discrim : Entity_Id; + + -- Start of processing for Inherit_Component begin pragma Assert (not Is_Tagged or else not Stored_Discrim); @@ -15703,6 +15737,14 @@ package body Sem_Ch3 is Set_Original_Record_Component (New_C, New_C); end if; + -- Set the proper type of an access discriminant + + if Ekind (New_C) = E_Discriminant + and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type + then + Set_Anonymous_Type (New_C); + end if; + -- If we have inherited a component then see if its Etype contains -- references to Parent_Base discriminants. In this case, replace -- these references with the constraints given in Discs. We do not @@ -15712,10 +15754,16 @@ package body Sem_Ch3 is -- transformation in some error situations. if Ekind (New_C) = E_Component then - if (Is_Private_Type (Derived_Base) - and then not Is_Generic_Type (Derived_Base)) + + -- Set the proper type of an anonymous access component + + if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then + Set_Anonymous_Type (New_C); + + elsif (Is_Private_Type (Derived_Base) + and then not Is_Generic_Type (Derived_Base)) or else (Is_Empty_Elmt_List (Discs) - and then not Expander_Active) + and then not Expander_Active) then Set_Etype (New_C, Etype (Old_C)); @@ -15739,7 +15787,7 @@ package body Sem_Ch3 is Set_Etype (New_C, Constrain_Component_Type - (Old_C, Derived_Base, N, Parent_Base, Discs)); + (Old_C, Derived_Base, N, Parent_Base, Discs)); end if; end if; @@ -17376,9 +17424,13 @@ package body Sem_Ch3 is and then (Is_Limited_Type (Full_T) or else Is_Limited_Composite (Full_T)) then - Error_Msg_N - ("completion of nonlimited type cannot be limited", Full_T); - Explain_Limited_Type (Full_T, Full_T); + if In_Instance then + null; + else + Error_Msg_N + ("completion of nonlimited type cannot be limited", Full_T); + Explain_Limited_Type (Full_T, Full_T); + end if; elsif Is_Abstract_Type (Full_T) and then not Is_Abstract_Type (Priv_T) @@ -17432,7 +17484,7 @@ package body Sem_Ch3 is -- Ada 2005 (AI-251): The partial view shall be a descendant of -- an interface type if and only if the full type is descendant - -- of the interface type (AARM 7.3 (7.3/2). + -- of the interface type (AARM 7.3 (7.3/2)). Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); @@ -18550,9 +18602,11 @@ package body Sem_Ch3 is return Process_Subtype (S, Related_Nod, Related_Id, Suffix); end if; - -- Remaining processing depends on type + -- Remaining processing depends on type. Select on Base_Type kind to + -- ensure getting to the concrete type kind in the case of a private + -- subtype (needed when only doing semantic analysis). - case Ekind (Subtype_Mark_Id) is + case Ekind (Base_Type (Subtype_Mark_Id)) is when Access_Kind => Constrain_Access (Def_Id, S, Related_Nod); @@ -19702,7 +19756,7 @@ package body Sem_Ch3 is -- and First_Rep_Item info, which should not be relied upon in formal -- verification. - if ALFA_Mode then + if Alfa_Mode then -- If the range of the type is already symmetric with a possible -- extra negative value, leave it this way. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 62218c46e17..3f049643287 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -30,7 +30,6 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Util; use Exp_Util; -with Expander; use Expander; with Fname; use Fname; with Itypes; use Itypes; with Lib; use Lib; @@ -277,11 +276,17 @@ package body Sem_Ch4 is -- subprogram, and the call F (X) interpreted as F.all (X). In this case -- the call may be overloaded with both interpretations. - function Try_Object_Operation (N : Node_Id) return Boolean; + function Try_Object_Operation + (N : Node_Id; + CW_Test_Only : Boolean := False) return Boolean; -- Ada 2005 (AI-252): Support the object.operation notation. If node N -- is a call in this notation, it is transformed into a normal subprogram -- call where the prefix is a parameter, and True is returned. If node - -- N is not of this form, it is unchanged, and False is returned. + -- N is not of this form, it is unchanged, and False is returned. if + -- CW_Test_Only is true then N is an N_Selected_Component node which + -- is part of a call to an entry or procedure of a tagged concurrent + -- type and this routine is invoked to search for class-wide subprograms + -- conflicting with the target entity. procedure wpo (T : Entity_Id); pragma Warnings (Off, wpo); @@ -485,8 +490,14 @@ package body Sem_Ch4 is Resolve (Expression (E), Type_Id); + -- Allocators generated by the build-in-place expansion mechanism + -- are explicitly marked as coming from source but do not need to be + -- checked for limited initialization. To exclude this case, ensure + -- that the parent of the allocator is a source node. + if Is_Limited_Type (Type_Id) and then Comes_From_Source (N) + and then Comes_From_Source (Parent (N)) and then not In_Instance_Body then if not OK_For_Limited_Init (Type_Id, Expression (E)) then @@ -1759,13 +1770,18 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Explicit_Dereference begin - Check_SPARK_Restriction ("explicit dereference is not allowed", N); + -- If source node, check SPARK restriction. We guard this with the + -- source node check, because ??? + + if Comes_From_Source (N) then + Check_SPARK_Restriction ("explicit dereference is not allowed", N); + end if; -- In formal verification mode, keep track of all reads and writes -- through explicit dereferences. - if ALFA_Mode then - ALFA.Generate_Dereference (N); + if Alfa_Mode then + Alfa.Generate_Dereference (N); end if; Analyze (P); @@ -3352,14 +3368,21 @@ package body Sem_Ch4 is Iterator : Node_Id; begin - -- Analyze construct with expansion disabled, because it will be - -- rewritten as a loop during expansion. + Set_Etype (Ent, Standard_Void_Type); + Set_Scope (Ent, Current_Scope); + Set_Parent (Ent, N); - Expander_Mode_Save_And_Set (False); Check_SPARK_Restriction ("quantified expression is not allowed", N); - Set_Etype (Ent, Standard_Void_Type); - Set_Parent (Ent, N); + -- If expansion is enabled (and not in Alfa mode), the condition is + -- analyzed after rewritten as a loop. So we only need to set the type. + + if Operating_Mode /= Check_Semantics + and then not Alfa_Mode + then + Set_Etype (N, Standard_Boolean); + return; + end if; if Present (Loop_Parameter_Specification (N)) then Iterator := @@ -3390,7 +3413,6 @@ package body Sem_Ch4 is Analyze (Condition (N)); End_Scope; Set_Etype (N, Standard_Boolean); - Expander_Mode_Restore; end Analyze_Quantified_Expression; ------------------- @@ -4160,9 +4182,30 @@ package body Sem_Ch4 is then return; end if; + + -- Ada 2012 (AI05-0090-1): If we found a candidate of a call to an + -- entry or procedure of a tagged concurrent type we must check + -- if there are class-wide subprograms covering the primitive. If + -- true then Try_Object_Operation reports the error. + + if Has_Candidate + and then Is_Concurrent_Type (Prefix_Type) + and then Nkind (Parent (N)) = N_Procedure_Call_Statement + + -- Duplicate the call. This is required to avoid problems with + -- the tree transformations performed by Try_Object_Operation. + + and then + Try_Object_Operation + (N => Sinfo.Name (New_Copy_Tree (Parent (N))), + CW_Test_Only => True) + then + return; + end if; end if; if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then + -- Case of a prefix of a protected type: selector might denote -- an invisible private component. @@ -4388,7 +4431,9 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Slice begin - Check_SPARK_Restriction ("slice is not allowed", N); + if Comes_From_Source (N) then + Check_SPARK_Restriction ("slice is not allowed", N); + end if; Analyze (P); Analyze (D); @@ -6604,7 +6649,9 @@ package body Sem_Ch4 is -- Try_Object_Operation -- -------------------------- - function Try_Object_Operation (N : Node_Id) return Boolean is + function Try_Object_Operation + (N : Node_Id; CW_Test_Only : Boolean := False) return Boolean + is K : constant Node_Kind := Nkind (Parent (N)); Is_Subprg_Call : constant Boolean := Nkind_In (K, N_Procedure_Call_Statement, @@ -6633,7 +6680,7 @@ package body Sem_Ch4 is Call : Node_Id; Subp : Entity_Id) return Entity_Id; -- If the subprogram is a valid interpretation, record it, and add - -- to the list of interpretations of Subprog. + -- to the list of interpretations of Subprog. Otherwise return Empty. procedure Complete_Object_Operation (Call_Node : Node_Id; @@ -6893,14 +6940,17 @@ package body Sem_Ch4 is ---------------------- procedure Report_Ambiguity (Op : Entity_Id) is - Access_Formal : constant Boolean := - Is_Access_Type (Etype (First_Formal (Op))); Access_Actual : constant Boolean := Is_Access_Type (Etype (Prefix (N))); + Access_Formal : Boolean := False; begin Error_Msg_Sloc := Sloc (Op); + if Present (First_Formal (Op)) then + Access_Formal := Is_Access_Type (Etype (First_Formal (Op))); + end if; + if Access_Formal and then not Access_Actual then if Nkind (Parent (Op)) = N_Full_Type_Declaration then Error_Msg_N @@ -7099,6 +7149,14 @@ package body Sem_Ch4 is and then N = Name (Parent (N)) then goto Next_Hom; + + -- If the context is a function call, ignore procedures + -- in the name of the call. + + elsif Ekind (Hom) = E_Procedure + and then Nkind (Parent (N)) /= N_Procedure_Call_Statement + then + goto Next_Hom; end if; Set_Etype (Call_Node, Any_Type); @@ -7192,6 +7250,13 @@ package body Sem_Ch4 is -- Start of processing for Try_Class_Wide_Operation begin + -- If we are searching only for conflicting class-wide subprograms + -- then initialize directly Matching_Op with the target entity. + + if CW_Test_Only then + Matching_Op := Entity (Selector_Name (N)); + end if; + -- Loop through ancestor types (including interfaces), traversing -- the homonym chain of the subprogram, trying out those homonyms -- whose first formal has the class-wide type of the ancestor, or @@ -7266,16 +7331,41 @@ package body Sem_Ch4 is return; end if; - if Try_Primitive_Operation - (Call_Node => New_Call_Node, - Node_To_Replace => Node_To_Replace) - or else - Try_Class_Wide_Operation - (Call_Node => New_Call_Node, - Node_To_Replace => Node_To_Replace) - then - null; - end if; + declare + Dup_Call_Node : constant Node_Id := New_Copy (New_Call_Node); + CW_Result : Boolean; + Prim_Result : Boolean; + pragma Unreferenced (CW_Result); + + begin + if not CW_Test_Only then + Prim_Result := + Try_Primitive_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace); + end if; + + -- Check if there is a class-wide subprogram covering the + -- primitive. This check must be done even if a candidate + -- was found in order to report ambiguous calls. + + if not (Prim_Result) then + CW_Result := + Try_Class_Wide_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace); + + -- If we found a primitive we search for class-wide subprograms + -- using a duplicate of the call node (done to avoid missing its + -- decoration if there is no ambiguity). + + else + CW_Result := + Try_Class_Wide_Operation + (Call_Node => Dup_Call_Node, + Node_To_Replace => Node_To_Replace); + end if; + end; end Try_One_Prefix_Interpretation; ----------------------------- @@ -7627,10 +7717,18 @@ package body Sem_Ch4 is end if; if Etype (New_Call_Node) /= Any_Type then - Complete_Object_Operation - (Call_Node => New_Call_Node, - Node_To_Replace => Node_To_Replace); - return True; + + -- No need to complete the tree transformations if we are only + -- searching for conflicting class-wide subprograms + + if CW_Test_Only then + return False; + else + Complete_Object_Operation + (Call_Node => New_Call_Node, + Node_To_Replace => Node_To_Replace); + return True; + end if; elsif Present (Candidate) then diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 7de014fefe9..e93d00ec6ea 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -601,6 +601,14 @@ package body Sem_Ch5 is then if Is_Local_Anonymous_Access (T1) or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type + + -- Handle assignment to an Ada 2012 stand-alone object + -- of an anonymous access type. + + or else (Ekind (T1) = E_Anonymous_Access_Type + and then Nkind (Associated_Node_For_Itype (T1)) = + N_Object_Declaration) + then Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); Analyze_And_Resolve (Rhs, T1); @@ -2015,7 +2023,7 @@ package body Sem_Ch5 is if Nkind (D_Copy) = N_Function_Call or else - (ALFA_Mode + (Alfa_Mode and then (Nkind (D_Copy) = N_Attribute_Reference and then (Attribute_Name (D_Copy) = Name_Result @@ -2049,6 +2057,11 @@ package body Sem_Ch5 is Analyze (DS); end if; + -- Set kind of loop parameter, which may be used in + -- the subsequent analysis of the condition in a + -- quantified expression. + + Set_Ekind (Id, E_Loop_Parameter); return; end; @@ -2235,26 +2248,26 @@ package body Sem_Ch5 is Typ : Entity_Id; begin - Enter_Name (Def_Id); + -- In semantics mode, introduce loop variable so that loop body can be + -- properly analyzed. Otherwise this is one after expansion. + + if Operating_Mode = Check_Semantics then + Enter_Name (Def_Id); + end if; + Set_Ekind (Def_Id, E_Variable); if Present (Subt) then Analyze (Subt); end if; - -- If it is an expression, the name is pre-analyzed in the caller. - -- If it it of a controlled type we need a block for the finalization - -- actions. As for loop bounds that need finalization, we create a - -- declaration and an assignment to trigger these actions. + -- If domain of iteration is an expression, create a declaration for it, + -- so that finalization actions are introduced outside of the loop. - if Present (Etype (Iter_Name)) - and then Is_Controlled (Etype (Iter_Name)) - and then not Is_Entity_Name (Iter_Name) - then + if not Is_Entity_Name (Iter_Name) then declare - Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); - - Decl : Node_Id; + Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); + Decl : Node_Id; begin Typ := Etype (Iter_Name); @@ -2324,6 +2337,10 @@ package body Sem_Ch5 is else Error_Msg_N ("to iterate over the elements of an array, use OF", N); + + -- Prevent cascaded errors + + Set_Ekind (Def_Id, E_Constant); Set_Etype (Def_Id, Etype (First_Index (Typ))); end if; @@ -2474,12 +2491,26 @@ package body Sem_Ch5 is -- If the expander is not active, then we want to analyze the loop body -- now even in the Ada 2012 iterator case, since the rewriting will not - -- be done. + -- be done. Insert the loop variable in the current scope, if not done + -- when analysing the iteration scheme. if No (Iter) or else No (Iterator_Specification (Iter)) or else not Expander_Active then + if Present (Iter) + and then Present (Iterator_Specification (Iter)) + then + declare + Id : constant Entity_Id := + Defining_Identifier (Iterator_Specification (Iter)); + begin + if Scope (Id) /= Current_Scope then + Enter_Name (Id); + end if; + end; + end if; + Analyze_Statements (Statements (Loop_Statement)); end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 4c196669ccf..7b4bf913ab6 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -564,6 +564,15 @@ package body Sem_Ch6 is Error_Msg_N ("must use anonymous access type", Subtype_Ind); end if; + -- If the return object is of an anonymous access type, then report + -- an error if the function's result type is not also anonymous. + + elsif R_Stm_Type_Is_Anon_Access + and then not R_Type_Is_Anon_Access + then + Error_Msg_N ("anonymous access not allowed for function with " & + "named access result", Subtype_Ind); + -- Subtype indication case: check that the return object's type is -- covered by the result type, and that the subtypes statically match -- when the result subtype is constrained. Also handle record types @@ -969,7 +978,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 Alfa_Mode then Process_PPCs (N, Gen_Id, Body_Id); end if; @@ -1341,12 +1350,13 @@ package body Sem_Ch6 is Result : Entity_Id := Empty; begin - -- Loop outward through the Scope_Stack, skipping blocks and loops + -- Loop outward through the Scope_Stack, skipping blocks, loops, + -- and postconditions. for J in reverse 0 .. Scope_Stack.Last loop Result := Scope_Stack.Table (J).Entity; - exit when Ekind (Result) /= E_Block and then - Ekind (Result) /= E_Loop; + exit when not Ekind_In (Result, E_Block, E_Loop) + and then Chars (Result) /= Name_uPostconditions; end loop; pragma Assert (Present (Result)); @@ -1587,6 +1597,16 @@ package body Sem_Ch6 is Designator, Typ); end if; + -- The type must be completed in the current package. This + -- is checked at the end of the package declaraton, when + -- Taft amemdment types are identified. + + if Ekind (Scope (Current_Scope)) = E_Package + and then In_Private_Part (Scope (Current_Scope)) + then + Append_Elmt (Designator, Private_Dependents (Typ)); + end if; + else Error_Msg_NE ("invalid use of incomplete type&", Designator, Typ); @@ -2545,10 +2565,14 @@ package body Sem_Ch6 is Set_Contract (Body_Id, Make_Contract (Sloc (Body_Id))); Generate_Reference (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True); - Generate_Reference_To_Formals (Body_Id); Install_Formals (Body_Id); Push_Scope (Body_Id); end if; + + -- For stubs and bodies with no previous spec, generate references to + -- formals. + + Generate_Reference_To_Formals (Body_Id); end if; -- If the return type is an anonymous access type whose designated type @@ -2580,7 +2604,7 @@ package body Sem_Ch6 is -- If this is the proper body of a stub, we must verify that the stub -- conforms to the body, and to the previous spec if one was present. - -- we know already that the body conforms to that spec. This test is + -- We know already that the body conforms to that spec. This test is -- only required for subprograms that come from source. if Nkind (Parent (N)) = N_Subunit @@ -2606,8 +2630,8 @@ package body Sem_Ch6 is if not Conformant then - -- The stub was taken to be a new declaration. Indicate - -- that it lacks a body. + -- The stub was taken to be a new declaration. Indicate that + -- it lacks a body. Set_Has_Completion (Old_Id, False); end if; @@ -2631,7 +2655,7 @@ package body Sem_Ch6 is end if; -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis - -- if its specification we have to install the private withed units. + -- of the specification we have to install the private withed units. -- This holds for child units as well. if Is_Compilation_Unit (Body_Id) @@ -2680,7 +2704,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 Alfa_Mode then Process_PPCs (N, Spec_Id, Body_Id); end if; @@ -2690,7 +2714,7 @@ package body Sem_Ch6 is -- when the Expander is active because Install_Private_Data_Declarations -- references entities which were created during regular expansion. - if Expander_Active + if Full_Expander_Active and then Comes_From_Source (N) and then Present (Prot_Typ) and then Present (Spec_Id) @@ -2743,8 +2767,8 @@ package body Sem_Ch6 is if Present (Last_Real_Spec_Entity) then - -- No body entities (happens when the only real spec entities - -- come from precondition and postcondition pragmas) + -- No body entities (happens when the only real spec entities come + -- from precondition and postcondition pragmas). if No (Last_Entity (Body_Id)) then Set_First_Entity @@ -2761,8 +2785,8 @@ package body Sem_Ch6 is Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity); - -- Case where there are no spec entities, in this case there can - -- be no body entities either, so just move everything. + -- Case where there are no spec entities, in this case there can be + -- no body entities either, so just move everything. else pragma Assert (No (Last_Entity (Body_Id))); @@ -2784,7 +2808,7 @@ package body Sem_Ch6 is -- might be the following common idiom for a stubbed function: -- statement of the procedure raises an exception. In particular this -- deals with the common idiom of a stubbed function, which might - -- appear as something like + -- appear as something like: -- function F (A : Integer) return Some_Type; -- X : Some_Type; @@ -4216,7 +4240,26 @@ package body Sem_Ch6 is if Ctype >= Mode_Conformant then if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then - Conformance_Error ("\mode of & does not match!", New_Formal); + if not Ekind_In (New_Id, E_Function, E_Procedure) + or else not Is_Primitive_Wrapper (New_Id) + then + Conformance_Error ("\mode of & does not match!", New_Formal); + + else + declare + T : constant Entity_Id := Find_Dispatching_Type (New_Id); + begin + if Is_Protected_Type + (Corresponding_Concurrent_Type (T)) + then + Error_Msg_PT (T, New_Id); + else + Conformance_Error + ("\mode of & does not match!", New_Formal); + end if; + end; + end if; + return; -- Part of mode conformance for access types is having the same @@ -6077,9 +6120,7 @@ package body Sem_Ch6 is -- dispatching context and such calls must be handled like calls -- to a class-wide function. - if not Is_Constrained (Underlying_Type (Result_Subt)) - or else Is_Tagged_Type (Underlying_Type (Result_Subt)) - then + if Needs_BIP_Alloc_Form (E) then Discard := Add_Extra_Formal (E, Standard_Natural, @@ -7175,6 +7216,7 @@ package body Sem_Ch6 is function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id is G_Typ : Entity_Id; + Defn : Node_Id; Indic : Node_Id; begin @@ -7187,19 +7229,21 @@ package body Sem_Ch6 is -- is needed for cases where a full derived type has been -- rewritten.) - Indic := Subtype_Indication - (Type_Definition (Original_Node (Parent (F_Typ)))); + Defn := Type_Definition (Original_Node (Parent (F_Typ))); + if Nkind (Defn) = N_Derived_Type_Definition then + Indic := Subtype_Indication (Defn); - if Nkind (Indic) = N_Subtype_Indication then - G_Typ := Entity (Subtype_Mark (Indic)); - else - G_Typ := Entity (Indic); - end if; + if Nkind (Indic) = N_Subtype_Indication then + G_Typ := Entity (Subtype_Mark (Indic)); + else + G_Typ := Entity (Indic); + end if; - if Nkind (Parent (G_Typ)) = N_Subtype_Declaration - and then Present (Generic_Parent_Type (Parent (G_Typ))) - then - return Generic_Parent_Type (Parent (G_Typ)); + if Nkind (Parent (G_Typ)) = N_Subtype_Declaration + and then Present (Generic_Parent_Type (Parent (G_Typ))) + then + return Generic_Parent_Type (Parent (G_Typ)); + end if; end if; end if; @@ -7256,9 +7300,10 @@ package body Sem_Ch6 is and then In_Private_Part (Current_Scope) and then Comes_From_Source (New_E) then - -- We examine the formals and result subtype of the inherited - -- operation, to determine whether their type is derived from (the - -- instance of) a generic type. + -- We examine the formals and result type of the inherited operation, + -- to determine whether their type is derived from (the instance of) + -- a generic type. The first such formal or result type is the one + -- tested. Formal := First_Formal (Prev_E); while Present (Formal) loop @@ -7269,6 +7314,7 @@ package body Sem_Ch6 is end if; G_Typ := Get_Generic_Parent_Type (F_Typ); + exit when Present (G_Typ); Next_Formal (Formal); end loop; @@ -7961,6 +8007,7 @@ package body Sem_Ch6 is -- to retrieve the corresponding concurrent type. elsif Is_Concurrent_Record_Type (Typ) + and then not Is_Class_Wide_Type (Typ) and then Present (Corresponding_Concurrent_Type (Typ)) then Typ := Corresponding_Concurrent_Type (Typ); @@ -8088,16 +8135,11 @@ package body Sem_Ch6 is and then Is_Protected_Type (Typ) and then (Is_Limited_Interface (Iface_Typ) - or else Is_Protected_Interface (Iface_Typ) - or else Is_Synchronized_Interface (Iface_Typ) - or else Is_Task_Interface (Iface_Typ)) + or else Is_Protected_Interface (Iface_Typ) + or else Is_Synchronized_Interface (Iface_Typ) + or else Is_Task_Interface (Iface_Typ)) then - Error_Msg_NE - ("first formal of & must be of mode `OUT`, `IN OUT`" - & " or access-to-variable", Typ, Candidate); - Error_Msg_N - ("\in order to be overridden by protected procedure or " - & "entry (RM 9.4(11.9/2))", Typ); + Error_Msg_PT (Parent (Typ), Candidate); end if; end if; @@ -8860,7 +8902,6 @@ package body Sem_Ch6 is elsif not Nkind_In (Parent (T), N_Access_Function_Definition, N_Access_Procedure_Definition) then - -- AI05-0151: Tagged incomplete types are allowed in all -- formal parts. Untagged incomplete types are not allowed -- in bodies. @@ -8895,6 +8936,14 @@ package body Sem_Ch6 is Parameter_Type (Param_Spec), Formal_Type); end if; + -- Ada 2012 (AI-142): Handle aliased parameters + + if Ada_Version >= Ada_2012 + and then Aliased_Present (Param_Spec) + then + Set_Is_Aliased (Formal); + end if; + -- Ada 2005 (AI-231): Create and decorate an internal subtype -- declaration corresponding to the null-excluding type of the -- formal in the enclosing scope. Finally, replace the parameter @@ -8965,6 +9014,8 @@ package body Sem_Ch6 is Set_Etype (Formal, Formal_Type); + -- Deal with default expression if present + Default := Expression (Param_Spec); if Present (Default) then @@ -9078,6 +9129,12 @@ package body Sem_Ch6 is Num_Out_Params := Num_Out_Params + 1; end if; + -- Force call by reference if aliased + + if Is_Aliased (Formal) then + Set_Mechanism (Formal, By_Reference); + end if; + Next (Param_Spec); end loop; @@ -9539,8 +9596,7 @@ package body Sem_Ch6 is if Ekind (Designator) /= E_Procedure then declare Rent : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_uResult); + Make_Defining_Identifier (Loc, Name_uResult); Ftyp : constant Entity_Id := Etype (Designator); begin @@ -9752,10 +9808,9 @@ package body Sem_Ch6 is -- If expansion is active, the formal is replaced by a local -- variable that renames the corresponding entry of the -- parameter block, and it is this local variable that may - -- require an actual subtype. In ALFA mode, expansion of accept - -- statements is skipped. + -- require an actual subtype. - if Expander_Active and not ALFA_Mode then + if Full_Expander_Active then Decl := Build_Actual_Subtype (T, Renamed_Object (Formal)); else Decl := Build_Actual_Subtype (T, Formal); @@ -9794,8 +9849,7 @@ package body Sem_Ch6 is end if; if Nkind (N) = N_Accept_Statement - and then Expander_Active - and then not ALFA_Mode + and then Full_Expander_Active then Set_Actual_Subtype (Renamed_Object (Formal), Defining_Identifier (Decl)); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 77f948f4f6a..796f9b07f71 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -802,8 +802,13 @@ package body Sem_Ch8 is T := Entity (Subtype_Mark (N)); Analyze (Nam); + -- Reject renamings of conversions unless the type is tagged, or + -- the conversion is implicit (which can occur for cases of anonymous + -- access types in Ada 2012). + if Nkind (Nam) = N_Type_Conversion - and then not Is_Tagged_Type (T) + and then Comes_From_Source (Nam) + and then not Is_Tagged_Type (T) then Error_Msg_N ("renaming of conversion only allowed for tagged types", Nam); @@ -834,6 +839,22 @@ package body Sem_Ch8 is return; end if; + -- Ada 2012 (AI05-149): Reject renaming of an anonymous access object + -- when renaming declaration has a named access type. The Ada 2012 + -- coverage rules allow an anonymous access type in the context of + -- an expected named general access type, but the renaming rules + -- require the types to be the same. (An exception is when the type + -- of the renaming is also an anonymous access type, which can only + -- happen due to a renaming created by the expander.) + + if Nkind (Nam) = N_Type_Conversion + and then not Comes_From_Source (Nam) + and then Ekind (Etype (Expression (Nam))) = E_Anonymous_Access_Type + and then Ekind (T) /= E_Anonymous_Access_Type + then + Wrong_Type (Expression (Nam), T); -- Should we give better error??? + end if; + -- Check that a class-wide object is not being renamed as an object -- of a specific type. The test for access types is needed to exclude -- cases where the renamed object is a dynamically tagged access @@ -1116,7 +1137,12 @@ package body Sem_Ch8 is end if; Set_Ekind (Id, E_Variable); - Init_Size_Align (Id); + + -- Initialize the object size and alignment. Note that we used to call + -- Init_Size_Align here, but that's wrong for objects which have only + -- an Esize, not an RM_Size field! + + Init_Object_Size_Align (Id); if T = Any_Type or else Etype (Nam) = Any_Type then return; @@ -1996,7 +2022,7 @@ package body Sem_Ch8 is -- expanded in subsequent instantiations. if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) - and then Expander_Active + and then Full_Expander_Active then declare Stream_Prim : Entity_Id; @@ -3264,10 +3290,15 @@ package body Sem_Ch8 is -- type is still not frozen). We exclude from this processing generic -- formal subprograms found in instantiations and AST_Entry renamings. - -- We must exclude VM targets because entity AST_Handler is defined in - -- package System.Aux_Dec which is not available in those platforms. + -- We must exclude VM targets and restricted run-time libraries because + -- entity AST_Handler is defined in package System.Aux_Dec which is not + -- available in those platforms. Note that we cannot use the function + -- Restricted_Profile (instead of Configurable_Run_Time_Mode) because + -- the ZFP run-time library is not defined as a profile, and we do not + -- want to deal with AST_Handler in ZFP mode. if VM_Target = No_VM + and then not Configurable_Run_Time_Mode and then not Present (Corresponding_Formal_Spec (N)) and then Etype (Nam) /= RTE (RE_AST_Handler) then diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 410c02661b7..cdac2f787d3 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; @@ -727,7 +726,7 @@ package body Sem_Ch9 is -- for the discriminals and privals and finally a declaration for the -- entry family index (if applicable). - if Expander_Active + if Full_Expander_Active and then Is_Protected_Type (P_Type) then Install_Private_Data_Declarations @@ -1274,11 +1273,15 @@ package body Sem_Ch9 is end if; -- Create corresponding record now, because some private dependents - -- may be subtypes of the partial view. Skip if errors are present, - -- to prevent cascaded messages. + -- may be subtypes of the partial view. + + -- Skip if errors are present, to prevent cascaded messages if Serious_Errors_Detected = 0 - and then Expander_Active + + -- Also skip if expander is not active + + and then Full_Expander_Active then Expand_N_Protected_Type_Declaration (N); Process_Full_View (N, T, Def_Id); @@ -1722,7 +1725,6 @@ package body Sem_Ch9 is Defining_Identifier => O_Name, Object_Definition => Make_Identifier (Loc, Chars (T))); - Move_Aspects (N, O_Decl); Rewrite (N, T_Decl); Insert_After (N, O_Decl); Mark_Rewrite_Insertion (O_Decl); @@ -1792,7 +1794,6 @@ package body Sem_Ch9 is Defining_Identifier => O_Name, Object_Definition => Make_Identifier (Loc, Chars (T))); - Move_Aspects (N, O_Decl); Rewrite (N, T_Decl); Insert_After (N, O_Decl); Mark_Rewrite_Insertion (O_Decl); @@ -2077,11 +2078,15 @@ package body Sem_Ch9 is end if; -- Create corresponding record now, because some private dependents - -- may be subtypes of the partial view. Skip if errors are present, - -- to prevent cascaded messages. + -- may be subtypes of the partial view. + + -- Skip if errors are present, to prevent cascaded messages if Serious_Errors_Detected = 0 - and then Expander_Active + + -- Also skip if expander is not active + + and then Full_Expander_Active then Expand_N_Task_Type_Declaration (N); Process_Full_View (N, T, Def_Id); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 66fcb07e0ab..fb20b1a6554 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -850,9 +850,15 @@ package body Sem_Disp is Typ := Etype (Subp); end if; - if not Is_Class_Wide_Type (Typ) + -- The following should be better commented, especially since + -- we just added several new conditions here ??? + + if Comes_From_Source (Subp) and then Is_Interface (Typ) + and then not Is_Class_Wide_Type (Typ) and then not Is_Derived_Type (Typ) + and then not Is_Generic_Type (Typ) + and then not In_Instance then Error_Msg_N ("?declaration of& is too late!", Subp); Error_Msg_NE @@ -1150,11 +1156,14 @@ package body Sem_Disp is -- Ada 2005 (AI-251): In case of late overriding of a primitive -- that covers abstract interface subprograms we must register it -- in all the secondary dispatch tables associated with abstract - -- interfaces. We do this now only if not building static tables. - -- Otherwise the patch code is emitted after those tables are - -- built, to prevent access_before_elaboration in gigi. - - if Body_Is_Last_Primitive then + -- interfaces. We do this now only if not building static tables, + -- nor when the expander is inactive (we avoid trying to register + -- primitives in semantics-only mode, since the type may not have + -- an associated dispatch table). Otherwise the patch code is + -- emitted after those tables are built, to prevent access before + -- elaboration in gigi. + + if Body_Is_Last_Primitive and then Full_Expander_Active then declare Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); Elmt : Elmt_Id; @@ -2256,6 +2265,14 @@ package body Sem_Disp is then return; + -- When expansion is suppressed, an unexpanded call to 'Input can occur, + -- and in that case we can simply return. + + elsif Nkind (Actual) = N_Attribute_Reference then + pragma Assert (Attribute_Name (Actual) = Name_Input); + + return; + -- Only other possibilities are parenthesized or qualified expression, -- or an expander-generated unchecked conversion of a function call to -- a stream Input attribute. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c16a671e0d3..8f5909fdb7f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1877,7 +1877,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 Alfa_Mode then Analyze_PPC_In_Decl_Part (N, Defining_Entity (Unit (Parent (Parent (N))))); end if; @@ -5090,9 +5090,9 @@ package body Sem_Prag is -- Start of processing for Process_Restrictions_Or_Restriction_Warnings begin - -- Ignore all Restrictions pragma in CodePeer and ALFA modes + -- Ignore all Restrictions pragma in CodePeer mode - if CodePeer_Mode or ALFA_Mode then + if CodePeer_Mode then return; end if; @@ -5314,11 +5314,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 Alfa 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) + if (CodePeer_Mode or Alfa_Mode) and then Comes_From_Source (N) then return; @@ -7866,6 +7866,54 @@ package body Sem_Prag is end if; end Discard_Names; + ------------------------ + -- Dispatching_Domain -- + ------------------------ + + -- pragma Dispatching_Domain (EXPRESSION); + + when Pragma_Dispatching_Domain => Dispatching_Domain : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + + begin + Ada_2012_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + + -- This pragma is born obsolete, but not the aspect + + if not From_Aspect_Specification (N) then + Check_Restriction + (No_Obsolescent_Features, Pragma_Identifier (N)); + end if; + + if Nkind (P) = N_Task_Definition then + Arg := Get_Pragma_Arg (Arg1); + + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain)); + + -- Anything else is incorrect + + else + Pragma_Misplaced; + end if; + + if Has_Pragma_Dispatching_Domain (P) then + Error_Pragma ("duplicate pragma% not allowed"); + else + Set_Has_Pragma_Dispatching_Domain (P, True); + + if Nkind (P) = N_Task_Definition then + Record_Rep_Item (Defining_Identifier (Parent (P)), N); + end if; + end if; + end Dispatching_Domain; + --------------- -- Elaborate -- --------------- @@ -9501,11 +9549,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 Alfa 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 Alfa_Mode) then Init_Or_Norm_Scalars := True; Initialize_Scalars := True; @@ -9532,10 +9580,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 Alfa mode, since -- this causes walk order issues. - if not (CodePeer_Mode or ALFA_Mode) then + if not (CodePeer_Mode or Alfa_Mode) then Process_Inline (True); end if; @@ -10975,10 +11023,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 Alfa mode, so ignore this pragma -- in these modes. - if not (CodePeer_Mode or ALFA_Mode) then + if not (CodePeer_Mode or Alfa_Mode) then Normalize_Scalars := True; Init_Or_Norm_Scalars := True; end if; @@ -11347,7 +11395,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 Alfa_Mode then null; -- Don't attempt any packing for VM targets. We possibly @@ -14462,6 +14510,7 @@ package body Sem_Prag is Pragma_Default_Storage_Pool => -1, Pragma_Dimension => -1, Pragma_Discard_Names => 0, + Pragma_Dispatching_Domain => -1, Pragma_Elaborate => -1, Pragma_Elaborate_All => -1, Pragma_Elaborate_Body => -1, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3670221e0bb..3fe07196a45 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -273,15 +273,6 @@ package body Sem_Res is -- is only one requires a search over all visible entities, and happens -- only in very pathological cases (see 6115-006). - function Valid_Conversion - (N : Node_Id; - Target : Entity_Id; - Operand : Node_Id) return Boolean; - -- Verify legality rules given in 4.6 (8-23). Target is the target type - -- of the conversion, which may be an implicit conversion of an actual - -- parameter to an anonymous access type (in which case N denotes the - -- actual parameter and N = Operand). - ------------------------- -- Ambiguous_Character -- ------------------------- @@ -1115,6 +1106,21 @@ package body Sem_Res is if Nkind (Parent (N)) /= N_Function_Call or else N /= Name (Parent (N)) then + + -- This may be a prefixed call that was not fully analyzed, e.g. + -- an actual in an instance. + + if Ada_Version >= Ada_2005 + and then Nkind (N) = N_Selected_Component + and then Is_Dispatching_Operation (Entity (Selector_Name (N))) + then + Analyze_Selected_Component (N); + + if Nkind (N) /= N_Selected_Component then + return; + end if; + end if; + Nam := New_Copy (N); -- If overloaded, overload set belongs to new copy @@ -1719,7 +1725,7 @@ package body Sem_Res is -- Start of processing for Replace_Actual_Discriminants begin - if not Expander_Active then + if not Full_Expander_Active then return; end if; @@ -1964,7 +1970,7 @@ package body Sem_Res is if (Attr = Attribute_Access or else Attr = Attribute_Unchecked_Access or else Attr = Attribute_Unrestricted_Access) - and then Expander_Active + and then Full_Expander_Active and then Get_PCS_Name /= Name_No_DSA then Check_Subtype_Conformant @@ -2745,6 +2751,22 @@ package body Sem_Res is Resolve_Unchecked_Type_Conversion (N, Ctx_Type); end case; + -- Ada 2012 (AI05-0149): Apply an (implicit) conversion to an + -- expression of an anonymous access type that occurs in the context + -- of a named general access type, except when the expression is that + -- of a membership test. This ensures proper legality checking in + -- terms of allowed conversions (expressions that would be illegal to + -- convert implicitly are allowed in membership tests). + + if Ada_Version >= Ada_2012 + and then Ekind (Ctx_Type) = E_General_Access_Type + and then Ekind (Etype (N)) = E_Anonymous_Access_Type + and then Nkind (Parent (N)) not in N_Membership_Test + then + Rewrite (N, Convert_To (Ctx_Type, Relocate_Node (N))); + Analyze_And_Resolve (N, Ctx_Type); + end if; + -- If the subexpression was replaced by a non-subexpression, then -- all we do is to expand it. The only legitimate case we know of -- is converting procedure call statement to entry call statements, @@ -3420,7 +3442,7 @@ package body Sem_Res is elsif Nkind (A) = N_Function_Call and then Is_Limited_Record (Etype (F)) and then not Is_Constrained (Etype (F)) - and then Expander_Active + and then Full_Expander_Active and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) then Establish_Transient_Scope (A, False); @@ -3435,7 +3457,7 @@ package body Sem_Res is elsif Nkind (A) = N_Op_Concat and then Nkind (N) = N_Procedure_Call_Statement - and then Expander_Active + and then Full_Expander_Active and then not (Is_Intrinsic_Subprogram (Nam) and then Chars (Nam) = Name_Asm) @@ -3498,7 +3520,7 @@ package body Sem_Res is -- be removed in the expansion of the wrapped construct. if (Is_Controlled (DDT) or else Has_Task (DDT)) - and then Expander_Active + and then Full_Expander_Active then Establish_Transient_Scope (A, False); end if; @@ -3984,12 +4006,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 Alfa 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 Alfa_Mode then Set_Entity (Selector_Name (Parent (A)), F); Generate_Reference (F, Selector_Name (Parent (A))); @@ -5469,7 +5491,7 @@ package body Sem_Res is then null; - elsif Expander_Active + elsif Full_Expander_Active and then Is_Type (Etype (Nam)) and then Requires_Transient_Scope (Etype (Nam)) and then @@ -6590,7 +6612,7 @@ package body Sem_Res is -- Protected functions can return on the secondary stack, in which -- case we must trigger the transient scope mechanism. - elsif Expander_Active + elsif Full_Expander_Active and then Requires_Transient_Scope (Etype (Nam)) then Establish_Transient_Scope (N, Sec_Stack => True); @@ -6811,7 +6833,7 @@ package body Sem_Res is -- Why the Expander_Active test here ??? - if Expander_Active + if Full_Expander_Active and then (Ekind_In (T, E_Anonymous_Access_Type, E_Anonymous_Access_Subprogram_Type) @@ -7126,7 +7148,7 @@ package body Sem_Res is -- We must preserve the original entity in a generic setting, so that -- the legality of the operation can be verified in an instance. - if not Expander_Active then + if not Full_Expander_Active then return; end if; @@ -8061,9 +8083,14 @@ package body Sem_Res is procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id) is begin - -- Normal mode (not ALFA) + if not Alfa_Mode then + + -- If expansion is enabled, analysis is delayed until the expresssion + -- is rewritten as a loop. - if not ALFA_Mode then + if Operating_Mode /= Check_Semantics then + return; + end if; -- The loop structure is already resolved during its analysis, only -- the resolution of the condition needs to be done. Expansion is @@ -8074,7 +8101,8 @@ package body Sem_Res is Resolve (Condition (N), Typ); Expander_Mode_Restore; - -- In ALFA_Mode, no magic needed, we just resolve the underlying nodes + -- In Alfa mode, we need normal expansion in order to properly introduce + -- the necessary transient scopes. else Resolve (Condition (N), Typ); @@ -8169,7 +8197,7 @@ package body Sem_Res is -- transformation while analyzing generic units, as type information -- would be lost when reanalyzing the constant node in the instance. - if Is_Discrete_Type (Typ) and then Expander_Active then + if Is_Discrete_Type (Typ) and then Full_Expander_Active then if Is_OK_Static_Expression (L) then Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L)); end if; @@ -9317,7 +9345,7 @@ package body Sem_Res is -- expression coincides with the target type. if Ada_Version >= Ada_2005 - and then Expander_Active + and then Full_Expander_Active and then Operand_Typ /= Target_Typ then declare @@ -9816,7 +9844,7 @@ package body Sem_Res is -- premature (e.g. if the slice is within a transient scope). This needs -- to be done only if expansion is enabled. - elsif Expander_Active then + elsif Full_Expander_Active then Ensure_Defined (Typ => Slice_Subtype, N => N); end if; end Set_Slice_Subtype; @@ -10083,18 +10111,32 @@ package body Sem_Res is ---------------------- function Valid_Conversion - (N : Node_Id; - Target : Entity_Id; - Operand : Node_Id) return Boolean + (N : Node_Id; + Target : Entity_Id; + Operand : Node_Id; + Report_Errs : Boolean := True) return Boolean is Target_Type : constant Entity_Id := Base_Type (Target); - Opnd_Type : Entity_Id := Etype (Operand); + Opnd_Type : Entity_Id := Etype (Operand); 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); + -- If Report_Errs, then calls Errout.Error_Msg_N with its arguments + + procedure Error_Msg_NE + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id); + -- If Report_Errs, then calls Errout.Error_Msg_NE with its arguments + function Valid_Tagged_Conversion (Target_Type : Entity_Id; Opnd_Type : Entity_Id) return Boolean; @@ -10113,13 +10155,51 @@ package body Sem_Res is Msg : String) return Boolean is begin - if not Valid then + if not Valid + + -- A generic unit has already been analyzed and we have verified + -- that a particular conversion is OK in that context. Since the + -- instance is reanalyzed without relying on the relationships + -- established during the analysis of the generic, it is possible + -- to end up with inconsistent views of private types. Do not emit + -- the error message in such cases. The rest of the machinery in + -- Valid_Conversion still ensures the proper compatibility of + -- target and operand types. + + and then not In_Instance + then Error_Msg_N (Msg, Operand); end if; return Valid; end Conversion_Check; + ----------------- + -- Error_Msg_N -- + ----------------- + + procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is + begin + if Report_Errs then + Errout.Error_Msg_N (Msg, N); + end if; + end Error_Msg_N; + + ------------------ + -- Error_Msg_NE -- + ------------------ + + procedure Error_Msg_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); + end if; + end Error_Msg_NE; + ---------------------------- -- Valid_Array_Conversion -- ---------------------------- @@ -10473,7 +10553,7 @@ package body Sem_Res is if Ekind (Target_Type) /= E_Anonymous_Access_Type then if Type_Access_Level (Opnd_Type) > - Type_Access_Level (Target_Type) + Deepest_Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise @@ -10485,6 +10565,7 @@ package body Sem_Res is Operand); Error_Msg_N ("\?Program_Error will be raised at run time", Operand); + else Error_Msg_N ("cannot convert local pointer to non-local access type", @@ -10505,7 +10586,7 @@ package body Sem_Res is if Nkind (Operand) = N_Selected_Component and then Object_Access_Level (Operand) > - Type_Access_Level (Target_Type) + Deepest_Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise @@ -10573,9 +10654,83 @@ package body Sem_Res is if Ekind (Target_Type) /= E_Anonymous_Access_Type or else Is_Local_Anonymous_Access (Target_Type) + or else Nkind (Associated_Node_For_Itype (Target_Type)) = + N_Object_Declaration then - if Type_Access_Level (Opnd_Type) - > Type_Access_Level (Target_Type) + -- Ada 2012 (AI05-0149): Perform legality checking on implicit + -- conversions from an anonymous access type to a named general + -- access type. Such conversions are not allowed in the case of + -- access parameters and stand-alone objects of an anonymous + -- access type. The implicit conversion case is recognized by + -- testing that Comes_From_Source is False and that it's been + -- rewritten. The Comes_From_Source test isn't sufficient because + -- nodes in inlined calls to predefined library routines can have + -- Comes_From_Source set to False. (Is there a better way to test + -- for implicit conversions???) + + if Ada_Version >= Ada_2012 + and then not Comes_From_Source (N) + and then N /= Original_Node (N) + and then Ekind (Target_Type) = E_General_Access_Type + and then Ekind (Opnd_Type) = E_Anonymous_Access_Type + then + if Is_Itype (Opnd_Type) then + + -- Implicit conversions aren't allowed for objects of an + -- anonymous access type, since such objects have nonstatic + -- levels in Ada 2012. + + 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); + return False; + + -- Implicit conversions aren't allowed for anonymous access + -- parameters. The "not Is_Local_Anonymous_Access_Type" test + -- is done to exclude anonymous access results. + + elsif not Is_Local_Anonymous_Access (Opnd_Type) + and then Nkind_In (Associated_Node_For_Itype (Opnd_Type), + N_Function_Specification, + N_Procedure_Specification) + then + Error_Msg_N + ("implicit conversion of anonymous access formal " & + "not allowed", Operand); + return False; + + -- This is a case where there's an enclosing object whose + -- to which the "statically deeper than" relationship does + -- not apply (such as an access discriminant selected from + -- a dereference of an access parameter). + + elsif Object_Access_Level (Operand) + = Scope_Depth (Standard_Standard) + then + Error_Msg_N + ("implicit conversion of anonymous access value " & + "not allowed", Operand); + return False; + + -- In other cases, the level of the operand's type must be + -- statically less deep than that of the target type, else + -- implicit conversion is disallowed (by RM12-8.6(27.1/3)). + + 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); + return False; + end if; + end if; + + elsif Type_Access_Level (Opnd_Type) > + Deepest_Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise @@ -10613,7 +10768,7 @@ package body Sem_Res is if Nkind (Operand) = N_Selected_Component and then Object_Access_Level (Operand) > - Type_Access_Level (Target_Type) + Deepest_Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise @@ -10785,7 +10940,7 @@ package body Sem_Res is -- Check the static accessibility rule of 4.6(20) if Type_Access_Level (Opnd_Type) > - Type_Access_Level (Target_Type) + Deepest_Type_Access_Level (Target_Type) then Error_Msg_N ("operand type has deeper accessibility level than target", diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads index 70b534bf50c..361b8651569 100644 --- a/gcc/ada/sem_res.ads +++ b/gcc/ada/sem_res.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -122,6 +122,18 @@ package Sem_Res is procedure Preanalyze_And_Resolve (N : Node_Id); -- Same, but use type of node because context does not impose a single type + function Valid_Conversion + (N : Node_Id; + Target : Entity_Id; + Operand : Node_Id; + Report_Errs : Boolean := True) return Boolean; + -- Verify legality rules given in 4.6 (8-23). Target is the target type + -- of the conversion, which may be an implicit conversion of an actual + -- parameter to an anonymous access type (in which case N denotes the + -- actual parameter and N = Operand). Returns a Boolean result indicating + -- whether the conversion is legal. Reports errors in the case of illegal + -- conversions, unless Report_Errs is False. + private procedure Resolve_Implicit_Type (N : Node_Id) renames Resolve; pragma Inline (Resolve_Implicit_Type); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 70a94234d3e..8c2eeeef65b 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -967,6 +967,19 @@ package body Sem_Type is then return True; + -- Ada 2012 (AI05-0149): Allow an anonymous access type in the context + -- of a named general access type. An implicit conversion will be + -- applied. For the resolution, one designated type must cover the + -- other. + + elsif Ada_Version >= Ada_2012 + and then Ekind (BT1) = E_General_Access_Type + and then Ekind (BT2) = E_Anonymous_Access_Type + and then (Covers (Designated_Type (T1), Designated_Type (T2)) + or else Covers (Designated_Type (T2), Designated_Type (T1))) + then + return True; + -- An Access_To_Subprogram is compatible with itself, or with an -- anonymous type created for an attribute reference Access. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6a5e5f1a1fd..2b9d79df1aa 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2372,6 +2372,29 @@ package body Sem_Util is end if; end Current_Subprogram; + ---------------------------------- + -- Deepest_Type_Access_Level -- + ---------------------------------- + + function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is + begin + if Ekind (Typ) = E_Anonymous_Access_Type + and then not Is_Local_Anonymous_Access (Typ) + and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration + then + -- Typ is the type of an Ada 2012 stand-alone object of an anonymous + -- access type. + + return + Scope_Depth (Enclosing_Dynamic_Scope + (Defining_Identifier + (Associated_Node_For_Itype (Typ)))); + + else + return Type_Access_Level (Typ); + end if; + end Deepest_Type_Access_Level; + --------------------- -- Defining_Entity -- --------------------- @@ -2848,6 +2871,99 @@ package body Sem_Util is end if; end Designate_Same_Unit; + ------------------------------------------ + -- function Dynamic_Accessibility_Level -- + ------------------------------------------ + + function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is + E : Entity_Id; + Loc : constant Source_Ptr := Sloc (Expr); + begin + if Is_Entity_Name (Expr) then + E := Entity (Expr); + + if Present (Renamed_Object (E)) then + return Dynamic_Accessibility_Level (Renamed_Object (E)); + end if; + + if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then + if Present (Extra_Accessibility (E)) then + return New_Occurrence_Of (Extra_Accessibility (E), Loc); + end if; + end if; + end if; + + -- unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? + + case Nkind (Expr) is + -- for access discriminant, the level of the enclosing object + + when N_Selected_Component => + if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant + and then Ekind (Etype (Entity (Selector_Name (Expr)))) = + E_Anonymous_Access_Type then + + return Make_Integer_Literal (Loc, Object_Access_Level (Expr)); + end if; + + when N_Attribute_Reference => + case Get_Attribute_Id (Attribute_Name (Expr)) is + + -- For X'Access, the level of the prefix X + + when Attribute_Access => + return Make_Integer_Literal (Loc, + Object_Access_Level (Prefix (Expr))); + + -- Treat the unchecked attributes as library-level + + when Attribute_Unchecked_Access | + Attribute_Unrestricted_Access => + return Make_Integer_Literal (Loc, + Scope_Depth (Standard_Standard)); + + -- No other access-valued attributes + + when others => + raise Program_Error; + end case; + + when N_Allocator => + -- Unimplemented: depends on context. As an actual + -- parameter where formal type is anonymous, use + -- Scope_Depth (Current_Scope) + 1. + -- For other cases, see 3.10.2(14/3) and following. ??? + null; + + when N_Type_Conversion => + if not Is_Local_Anonymous_Access (Etype (Expr)) then + -- Handle type conversions introduced for a + -- rename of an Ada2012 stand-alone object of an + -- anonymous access type. + return Dynamic_Accessibility_Level (Expression (Expr)); + end if; + + when others => + null; + end case; + + return Make_Integer_Literal (Loc, Type_Access_Level (Etype (Expr))); + end Dynamic_Accessibility_Level; + + ----------------------------------- + -- Effective_Extra_Accessibility -- + ----------------------------------- + + function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is + begin + if Present (Renamed_Object (Id)) + and then Is_Entity_Name (Renamed_Object (Id)) then + return Effective_Extra_Accessibility (Entity (Renamed_Object (Id))); + end if; + + return Extra_Accessibility (Id); + end Effective_Extra_Accessibility; + -------------------------- -- Enclosing_CPP_Parent -- -------------------------- @@ -3585,13 +3701,22 @@ package body Sem_Util is function Find_Body_Discriminal (Spec_Discriminant : Entity_Id) return Entity_Id is - pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); - - Tsk : constant Entity_Id := - Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); + Tsk : Entity_Id; Disc : Entity_Id; begin + -- If expansion is suppressed, then the scope can be the concurrent type + -- itself rather than a corresponding concurrent record type. + + if Is_Concurrent_Type (Scope (Spec_Discriminant)) then + Tsk := Scope (Spec_Discriminant); + + else + pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); + + Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); + end if; + -- Find discriminant of original concurrent type, and use its current -- discriminal, which is the renaming within the task/protected body. @@ -8354,7 +8479,7 @@ package body Sem_Util is or else K = E_In_Out_Parameter or else K = E_Generic_In_Out_Parameter - -- Current instance of type: + -- Current instance of type or else (Is_Type (E) and then In_Open_Scopes (E)) or else (Is_Incomplete_Or_Private_Type (E) @@ -8598,8 +8723,8 @@ package body Sem_Util is Kill_Current_Values_For_Entity_Chain (First_Entity (S)); - -- If scope is a package, also clear current values of all - -- private entities in the scope. + -- If scope is a package, also clear current values of all private + -- entities in the scope. if Is_Package_Or_Generic_Package (S) or else Is_Concurrent_Type (S) @@ -8900,7 +9025,7 @@ package body Sem_Util is -- is an lvalue, but the prefix is never an lvalue, since it is just -- the scope where the name is found. - when N_Expanded_Name => + when N_Expanded_Name => if N = Prefix (P) then return May_Be_Lvalue (P); else @@ -8913,7 +9038,7 @@ package body Sem_Util is -- it is. Note however that A is not an lvalue if it is of an access -- type since this is an implicit dereference. - when N_Selected_Component => + when N_Selected_Component => if N = Prefix (P) and then Present (Etype (N)) and then Is_Access_Type (Etype (N)) @@ -8928,7 +9053,7 @@ package body Sem_Util is -- or slice is an lvalue, except if it is an access type, where we -- have an implicit dereference. - when N_Indexed_Component => + when N_Indexed_Component | N_Slice => if N /= Prefix (P) or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) then @@ -8939,7 +9064,7 @@ package body Sem_Util is -- Prefix of a reference is an lvalue if the reference is an lvalue - when N_Reference => + when N_Reference => return May_Be_Lvalue (P); -- Prefix of explicit dereference is never an lvalue @@ -8956,14 +9081,12 @@ package body Sem_Util is N_Entry_Call_Statement | N_Accept_Statement => - if Nkind (P) = N_Function_Call - and then Ada_Version < Ada_2012 - then + if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then return False; end if; - -- The following mechanism is clumsy and fragile. A single - -- flag set in Resolve_Actuals would be preferable ??? + -- The following mechanism is clumsy and fragile. A single flag + -- set in Resolve_Actuals would be preferable ??? declare Proc : Entity_Id; @@ -8977,8 +9100,8 @@ package body Sem_Util is return True; end if; - -- If we are not a list member, something is strange, so - -- be conservative and return True. + -- If we are not a list member, something is strange, so be + -- conservative and return True. if not Is_List_Member (N) then return True; @@ -8990,8 +9113,8 @@ package body Sem_Util is Form := First_Formal (Proc); Act := N; loop - -- If no formal, something is weird, so be conservative - -- and return True. + -- If no formal, something is weird, so be conservative and + -- return True. if No (Form) then return True; @@ -10509,8 +10632,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 Alfa_Mode then + Alfa.Generate_Dereference (N, 'm'); end if; if Nkind (P) = N_Selected_Component @@ -10588,6 +10711,17 @@ package body Sem_Util is then Exp := Renamed_Object (Ent); goto Continue; + + -- The expression may be the renaming of a subcomponent of an + -- array or container. The assignment to the subcomponent is + -- a modification of the container. + + elsif Comes_From_Source (Original_Node (Exp)) + and then Nkind_In (Original_Node (Exp), N_Selected_Component, + N_Indexed_Component) + then + Exp := Prefix (Original_Node (Exp)); + goto Continue; end if; -- Generate a reference only if the assignment comes from @@ -12533,6 +12667,11 @@ package body Sem_Util is begin case Ekind (E) is + when E_Constant => + if Present (Full_View (E)) then + U := Full_View (E); + end if; + when Type_Kind => if Present (Full_View (E)) then U := Full_View (E); @@ -12980,6 +13119,22 @@ package body Sem_Util is then return; + -- If one of the types is a Taft-Amendment type and the other it its + -- completion, it must be an illegal use of a TAT in the spec, for + -- which an error was already emitted. Avoid cascaded errors. + + elsif Is_Incomplete_Type (Expec_Type) + and then Has_Completion_In_Body (Expec_Type) + and then Full_View (Expec_Type) = Etype (Expr) + then + return; + + elsif Is_Incomplete_Type (Etype (Expr)) + and then Has_Completion_In_Body (Etype (Expr)) + and then Full_View (Etype (Expr)) = Expec_Type + then + return; + -- In an instance, there is an ongoing problem with completion of -- type derived from private types. Their structure is what Gigi -- expects, but the Etype is the parent type rather than the diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b3844d89608..fc408b31a4a 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -292,6 +292,14 @@ package Sem_Util is -- Current_Scope is returned. The returned value is Empty if this is called -- from a library package which is not within any subprogram. + function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint; + -- Same as Type_Access_Level, except that if the type is the type of an Ada + -- 2012 stand-alone object of an anonymous access type, then return the + -- static accesssibility level of the object. In that case, the dynamic + -- accessibility level of the object may take on values in a range. The low + -- bound of of that range is returned by Type_Access_Level; this function + -- yields the high bound of that range. + function Defining_Entity (N : Node_Id) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- declaration has a specification, the entity is obtained from the @@ -332,6 +340,16 @@ package Sem_Util is -- these names is supposed to be a selected component name, an expanded -- name, a defining program unit name or an identifier. + function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id; + -- Expr should be an expression of an access type. Builds an integer + -- literal except in cases involving anonymous access types where + -- accessibility levels are tracked at runtime (access parameters and Ada + -- 2012 stand-alone objects). + + function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id; + -- Same as Einfo.Extra_Accessibility except thtat object renames + -- are looked through. + function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id; -- Returns the closest ancestor of Typ that is a CPP type. @@ -1430,7 +1448,8 @@ package Sem_Util is -- views of the same entity have the same unique defining entity: -- * package spec and body; -- * subprogram declaration, subprogram stub and subprogram body; - -- * private view and full view of a type. + -- * private view and full view of a type; + -- * private view and full view of a deferred constant. -- In other cases, return the defining entity for N. function Unique_Entity (E : Entity_Id) return Entity_Id; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index d1f00676284..67baab977cd 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -206,7 +206,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Component_Definition - or else NT (N).Nkind = N_Object_Declaration); + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); return Flag4 (N); end Aliased_Present; @@ -1471,6 +1472,14 @@ package body Sinfo is return Flag14 (N); end Has_Pragma_CPU; + function Has_Pragma_Dispatching_Domain + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Task_Definition); + return Flag15 (N); + end Has_Pragma_Dispatching_Domain; + function Has_Pragma_Priority (N : Node_Id) return Boolean is begin @@ -3257,7 +3266,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Component_Definition - or else NT (N).Nkind = N_Object_Declaration); + or else NT (N).Nkind = N_Object_Declaration + or else NT (N).Nkind = N_Parameter_Specification); Set_Flag4 (N, Val); end Set_Aliased_Present; @@ -4513,6 +4523,14 @@ package body Sinfo is Set_Flag14 (N, Val); end Set_Has_Pragma_CPU; + procedure Set_Has_Pragma_Dispatching_Domain + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Task_Definition); + Set_Flag15 (N, Val); + end Set_Has_Pragma_Dispatching_Domain; + procedure Set_Has_Pragma_Priority (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 87b018694ea..af6fab23362 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1145,6 +1145,11 @@ package Sinfo is -- flag the presence of a CPU pragma in the declaration sequence (public -- or private in the task case). + -- Has_Pragma_Dispatching_Domain (Flag15-Sem) + -- A flag present in N_Task_Definition nodes to flag the presence of a + -- Dispatching_Domain pragma in the declaration sequence (public or + -- private in the task case). + -- Has_Pragma_Suppress_All (Flag14-Sem) -- This flag is set in an N_Compilation_Unit node if the Suppress_All -- pragma appears anywhere in the unit. This accommodates the rather @@ -2317,7 +2322,7 @@ package Sinfo is -- N_Object_Declaration -- Sloc points to first identifier -- Defining_Identifier (Node1) - -- Aliased_Present (Flag4) set if ALIASED appears + -- Aliased_Present (Flag4) -- Constant_Present (Flag17) set if CONSTANT appears -- Null_Exclusion_Present (Flag11) -- Object_Definition (Node4) subtype indic./array type def./access def. @@ -4509,8 +4514,8 @@ package Sinfo is ---------------------------------- -- PARAMETER_SPECIFICATION ::= - -- DEFINING_IDENTIFIER_LIST : MODE [NULL_EXCLUSION] SUBTYPE_MARK - -- [:= DEFAULT_EXPRESSION] + -- DEFINING_IDENTIFIER_LIST : [ALIASED] MODE [NULL_EXCLUSION] + -- SUBTYPE_MARK [:= DEFAULT_EXPRESSION] -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION -- [:= DEFAULT_EXPRESSION] @@ -4522,9 +4527,12 @@ package Sinfo is -- Prev_Ids flags to preserve the original source form as described -- in the section on "Handling of Defining Identifier Lists". + -- ALIASED can only be present in Ada 2012 mode + -- N_Parameter_Specification -- Sloc points to first identifier -- Defining_Identifier (Node1) + -- Aliased_Present (Flag4) -- In_Present (Flag15) -- Out_Present (Flag17) -- Null_Exclusion_Present (Flag11) @@ -5061,6 +5069,7 @@ package Sinfo is -- Has_Task_Name_Pragma (Flag8-Sem) -- Has_Relative_Deadline_Pragma (Flag9-Sem) -- Has_Pragma_CPU (Flag14-Sem) + -- Has_Pragma_Dispatching_Domain (Flag15-Sem) -------------------- -- 9.1 Task Item -- @@ -8493,6 +8502,9 @@ package Sinfo is function Has_Pragma_CPU (N : Node_Id) return Boolean; -- Flag14 + function Has_Pragma_Dispatching_Domain + (N : Node_Id) return Boolean; -- Flag15 + function Has_Pragma_Priority (N : Node_Id) return Boolean; -- Flag6 @@ -9462,6 +9474,9 @@ package Sinfo is procedure Set_Has_Pragma_CPU (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Has_Pragma_Dispatching_Domain + (N : Node_Id; Val : Boolean := True); -- Flag15 + procedure Set_Has_Pragma_Priority (N : Node_Id; Val : Boolean := True); -- Flag6 @@ -11875,6 +11890,7 @@ package Sinfo is pragma Inline (Has_Self_Reference); pragma Inline (Has_No_Elaboration_Code); pragma Inline (Has_Pragma_CPU); + pragma Inline (Has_Pragma_Dispatching_Domain); pragma Inline (Has_Pragma_Priority); pragma Inline (Has_Pragma_Suppress_All); pragma Inline (Has_Private_View); @@ -12194,6 +12210,7 @@ package Sinfo is pragma Inline (Set_Has_Dynamic_Range_Check); pragma Inline (Set_Has_No_Elaboration_Code); pragma Inline (Set_Has_Pragma_CPU); + pragma Inline (Set_Has_Pragma_Dispatching_Domain); pragma Inline (Set_Has_Pragma_Priority); pragma Inline (Set_Has_Pragma_Suppress_All); pragma Inline (Set_Has_Private_View); diff --git a/gcc/ada/sinput-p.adb b/gcc/ada/sinput-p.adb index cd513d01080..156f036d3cf 100644 --- a/gcc/ada/sinput-p.adb +++ b/gcc/ada/sinput-p.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -97,7 +97,7 @@ package body Sinput.P is ----------------------- function Load_Project_File (Path : String) return Source_File_Index is - X : Source_File_Index; + X : Source_File_Index; begin X := Sinput.C.Load_File (Path); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 3c54e8a05fb..3fa0166b66d 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -156,6 +156,7 @@ package Snames is Name_uChain : constant Name_Id := N + $; Name_uController : constant Name_Id := N + $; Name_uCPU : constant Name_Id := N + $; + Name_uDispatching_Domain : constant Name_Id := N + $; Name_uEntry_Bodies : constant Name_Id := N + $; Name_uExpunge : constant Name_Id := N + $; Name_uFinalizer : constant Name_Id := N + $; @@ -360,6 +361,7 @@ package Snames is Name_Detect_Blocking : constant Name_Id := N + $; -- Ada 05 Name_Default_Storage_Pool : constant Name_Id := N + $; -- Ada 12 Name_Discard_Names : constant Name_Id := N + $; + Name_Dispatching_Domain : constant Name_Id := N + $; -- Ada 12 Name_Elaboration_Checks : constant Name_Id := N + $; -- GNAT Name_Eliminate : constant Name_Id := N + $; -- GNAT Name_Extend_System : constant Name_Id := N + $; -- GNAT @@ -790,6 +792,7 @@ package Snames is Name_Null_Parameter : constant Name_Id := N + $; -- GNAT Name_Object_Size : constant Name_Id := N + $; -- GNAT Name_Old : constant Name_Id := N + $; -- GNAT + Name_Overlaps_Storage : constant Name_Id := N + $; -- GNAT Name_Partition_ID : constant Name_Id := N + $; Name_Passed_By_Reference : constant Name_Id := N + $; -- GNAT Name_Pool_Address : constant Name_Id := N + $; @@ -806,6 +809,7 @@ package Snames is Name_Safe_Large : constant Name_Id := N + $; -- Ada 83 Name_Safe_Last : constant Name_Id := N + $; Name_Safe_Small : constant Name_Id := N + $; -- Ada 83 + Name_Same_Storage : constant Name_Id := N + $; -- Ada 12 Name_Scale : constant Name_Id := N + $; Name_Scaling : constant Name_Id := N + $; Name_Signed_Zeros : constant Name_Id := N + $; @@ -1193,6 +1197,7 @@ package Snames is Name_Shared_Library_Suffix : constant Name_Id := N + $; Name_Separate_Suffix : constant Name_Id := N + $; Name_Source_Dirs : constant Name_Id := N + $; + Name_Source_File_Switches : constant Name_Id := N + $; Name_Source_Files : constant Name_Id := N + $; Name_Source_List_File : constant Name_Id := N + $; Name_Spec : constant Name_Id := N + $; @@ -1341,6 +1346,7 @@ package Snames is Attribute_Null_Parameter, Attribute_Object_Size, Attribute_Old, + Attribute_Overlaps_Storage, Attribute_Partition_ID, Attribute_Passed_By_Reference, Attribute_Pool_Address, @@ -1357,6 +1363,7 @@ package Snames is Attribute_Safe_Large, Attribute_Safe_Last, Attribute_Safe_Small, + Attribute_Same_Storage, Attribute_Scale, Attribute_Scaling, Attribute_Signed_Zeros, @@ -1522,6 +1529,7 @@ package Snames is Pragma_Detect_Blocking, Pragma_Default_Storage_Pool, Pragma_Discard_Names, + Pragma_Dispatching_Domain, Pragma_Elaboration_Checks, Pragma_Eliminate, Pragma_Extend_System, diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index aee200a8db8..af05a91199b 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2010, Free Software Foundation, Inc. * + * Copyright (C) 1992-2011, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -69,6 +69,16 @@ extern struct tm *localtime_r(const time_t *, struct tm *); #include "adaint.h" +/* Don't use macros versions of this functions on VxWorks since they cause + imcompatible changes in some VxWorks versions */ +#ifdef __vxworks +#undef getchar +#undef putchar +#undef feof +#undef ferror +#undef fileno +#endif + /* mode_read_text open text file for reading diff --git a/gcc/ada/system-irix-n64.ads b/gcc/ada/system-irix-n64.ads index 88555673ecb..916fa4d7dff 100644 --- a/gcc/ada/system-irix-n64.ads +++ b/gcc/ada/system-irix-n64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (SGI Irix, n64 ABI) -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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 -- @@ -152,7 +152,6 @@ private Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; -- Note: Denorm is False because denormals are not supported on the -- R10000, and we want the code to be valid for this processor. diff --git a/gcc/ada/system-linux-armeb.ads b/gcc/ada/system-linux-armeb.ads index aa57af87b35..bcc31f3daeb 100644 --- a/gcc/ada/system-linux-armeb.ads +++ b/gcc/ada/system-linux-armeb.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/ARMEB Version) -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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 -- @@ -148,6 +148,5 @@ private Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; - GCC_ZCX_Support : constant Boolean := False; end System; diff --git a/gcc/ada/system-linux-armel.ads b/gcc/ada/system-linux-armel.ads index 64a82f1de6d..104649e75db 100644 --- a/gcc/ada/system-linux-armel.ads +++ b/gcc/ada/system-linux-armel.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/ARMEL Version) -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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 -- @@ -148,6 +148,5 @@ private Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; - GCC_ZCX_Support : constant Boolean := False; end System; diff --git a/gcc/ada/system-linux-mips.ads b/gcc/ada/system-linux-mips.ads index dada13fb94f..885995c076c 100644 --- a/gcc/ada/system-linux-mips.ads +++ b/gcc/ada/system-linux-mips.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/MIPS Version) -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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 -- @@ -139,6 +139,5 @@ private Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; end System; diff --git a/gcc/ada/system-linux-mips64el.ads b/gcc/ada/system-linux-mips64el.ads index c60d1095a30..de3215b3ec4 100644 --- a/gcc/ada/system-linux-mips64el.ads +++ b/gcc/ada/system-linux-mips64el.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/MIPS64EL Version) -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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 -- @@ -139,6 +139,5 @@ private Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; end System; diff --git a/gcc/ada/system-linux-mipsel.ads b/gcc/ada/system-linux-mipsel.ads index 60b8811b85f..a25642a153c 100644 --- a/gcc/ada/system-linux-mipsel.ads +++ b/gcc/ada/system-linux-mipsel.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/MIPSEL Version) -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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 -- @@ -139,6 +139,5 @@ private Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; end System; diff --git a/gcc/ada/system-linux-ppc64.ads b/gcc/ada/system-linux-ppc64.ads index 0ea68dd72f1..52d5d4402b6 100644 --- a/gcc/ada/system-linux-ppc64.ads +++ b/gcc/ada/system-linux-ppc64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/PPC64 Version) -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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 -- @@ -148,6 +148,5 @@ private Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; end System; diff --git a/gcc/ada/system-linux-sparcv9.ads b/gcc/ada/system-linux-sparcv9.ads index 9a42b3d4ae8..14d89f929b2 100644 --- a/gcc/ada/system-linux-sparcv9.ads +++ b/gcc/ada/system-linux-sparcv9.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU/Linux-SPARCV9 Version) -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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 -- @@ -138,6 +138,5 @@ private Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; end System; diff --git a/gcc/ada/system-rtems.ads b/gcc/ada/system-rtems.ads index b4157f333cf..3cab22abfe4 100644 --- a/gcc/ada/system-rtems.ads +++ b/gcc/ada/system-rtems.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Compiler Version) -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011 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,6 +159,5 @@ private Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; - GCC_ZCX_Support : constant Boolean := True; end System; diff --git a/gcc/ada/targext.c b/gcc/ada/targext.c index df4286c0d27..6a9f970c286 100644 --- a/gcc/ada/targext.c +++ b/gcc/ada/targext.c @@ -31,7 +31,9 @@ /* This file contains target-specific parameters describing the file extension for object and executable files. It is used by the compiler, - binder and tools. */ + binder, library and tools. + Note that, in order to have access to the TARGET_* macros used below, + the file must be compiled with IN_GCC defined, even for the library. */ #ifdef __cplusplus extern "C" { diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index eb0a57bbc4a..d92b89c0cc8 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -63,6 +63,7 @@ gcc -c ^ GNAT COMPILE -gnateD ^ /SYMBOL_PREPROCESSING -gnatef ^ /FULL_PATH_IN_BRIEF_MESSAGES -gnateG ^ /GENERATE_PROCESSED_SOURCE +-gnateI ^ /MULTI_UNIT_INDEX= -gnatem ^ /MAPPING_FILE -gnatep ^ /DATA_PREPROCESSING -gnateP ^ /CATEGORIZATION_WARNINGS @@ -229,3 +230,4 @@ stderr ^ SYS$ERROR -O3 ^ /OPTIMIZE=INLINING -H32 ^ /32_MALLOC -H64 ^ /64_MALLOC +-Wall ^ /WARNINGS=ALL_GCC diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb index 3f5421ee4d7..5cde2a2e160 100644 --- a/gcc/ada/vms_conv.adb +++ b/gcc/ada/vms_conv.adb @@ -1799,6 +1799,16 @@ package body VMS_Conv is (Arg (Arg'First .. SwP), Command.Switches, Quiet => False); + + -- Special case for GNAT COMPILE /UNCHECKED... + -- because the corresponding switch --unchecked... is + -- for gnatmake, not for the compiler. + + if Cargs + and then Sw.Name.all = "/UNCHECKED_SHARED_LIB_IMPORTS" + then + Cargs := False; + end if; end if; if Sw /= null then @@ -1815,6 +1825,7 @@ package body VMS_Conv is case Sw.Translation is when T_Direct => Place_Unix_Switches (Sw.Unix_String); + if SwP < Arg'Last and then Arg (SwP + 1) = '=' then @@ -1853,8 +1864,8 @@ package body VMS_Conv is Arg_Idx := Argv'First; Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); - Arg := new String' - (Argv (Arg_Idx .. Next_Arg_Idx)); + Arg := + new String'(Argv (Arg_Idx .. Next_Arg_Idx)); goto Tryagain_After_Coalesce; end if; @@ -1882,9 +1893,8 @@ package body VMS_Conv is while P2 < Endp and then Arg (P2 + 1) /= ',' loop - -- A wildcard directory spec on - -- VMS will contain either * or - -- % or ... + -- A wildcard directory spec on VMS will + -- contain either * or % or ... if Arg (P2) = '*' then Dir_Is_Wild := True; @@ -1918,15 +1928,12 @@ package body VMS_Conv is (Arg (SwP .. P2), True); for J in Dir_List.all'Range loop - Place_Unix_Switches - (Sw.Unix_String); - Place_Lower - (Dir_List.all (J).all); + Place_Unix_Switches (Sw.Unix_String); + Place_Lower (Dir_List.all (J).all); end loop; else - Place_Unix_Switches - (Sw.Unix_String); + Place_Unix_Switches (Sw.Unix_String); Place_Lower (To_Canonical_Dir_Spec (Arg (SwP .. P2), False).all); @@ -1946,37 +1953,33 @@ package body VMS_Conv is else Place_Unix_Switches (Sw.Unix_String); - -- Some switches end in "=". No space - -- here + -- Some switches end in "=", no space here if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' + (Sw.Unix_String'Last) /= '=' then Place (' '); end if; Place_Lower (To_Canonical_Dir_Spec - (Arg (SwP + 2 .. Arg'Last), - False).all); + (Arg (SwP + 2 .. Arg'Last), False).all); end if; when T_File | T_No_Space_File => if SwP + 2 > Arg'Last then - Put (Standard_Error, - "missing file for: "); + Put (Standard_Error, "missing file for: "); Put_Line (Standard_Error, Arg.all); Errors := Errors + 1; else Place_Unix_Switches (Sw.Unix_String); - -- Some switches end in "=". No space - -- here. + -- Some switches end in "=", no space here. if Sw.Translation = T_File and then Sw.Unix_String - (Sw.Unix_String'Last) /= '=' + (Sw.Unix_String'Last) /= '=' then Place (' '); end if; @@ -1994,14 +1997,13 @@ package body VMS_Conv is else Put (Standard_Error, "argument for "); Put (Standard_Error, Sw.Name.all); - Put_Line - (Standard_Error, " must be numeric"); + Put_Line (Standard_Error, " must be numeric"); Errors := Errors + 1; end if; when T_Alphanumplus => if OK_Alphanumerplus - (Arg (SwP + 2 .. Arg'Last)) + (Arg (SwP + 2 .. Arg'Last)) then Place_Unix_Switches (Sw.Unix_String); Place (Arg (SwP + 2 .. Arg'Last)); @@ -2016,28 +2018,28 @@ package body VMS_Conv is when T_String => - -- A String value must be extended to the - -- end of the Argv, otherwise strings like - -- "foo/bar" get split at the slash. + -- A String value must be extended to the end of + -- the Argv, otherwise strings like "foo/bar" get + -- split at the slash. - -- The beginning and ending of the string - -- are flagged with embedded nulls which - -- are removed when building the Spawn - -- call. Nulls are use because they won't - -- show up in a /? output. Quotes aren't - -- used because that would make it + -- The beginning and ending of the string are + -- flagged with embedded nulls which are removed + -- when building the Spawn call. Nulls are use + -- because they won't show up in a /? output. + -- Quotes aren't used because that would make it -- difficult to embed them. Place_Unix_Switches (Sw.Unix_String); if Next_Arg_Idx /= Argv'Last then Next_Arg_Idx := Argv'Last; - Arg := new String' - (Argv (Arg_Idx .. Next_Arg_Idx)); + Arg := + new String'(Argv (Arg_Idx .. Next_Arg_Idx)); SwP := Arg'First; - while SwP < Arg'Last and then - Arg (SwP + 1) /= '=' loop + while SwP < Arg'Last + and then Arg (SwP + 1) /= '=' + loop SwP := SwP + 1; end loop; end if; @@ -2062,10 +2064,9 @@ package body VMS_Conv is Make_Commands_Active := null; else - -- Set source of new commands, also - -- setting this non-null indicates that - -- we are in the special commands mode - -- for processing the -xargs case. + -- Set source of new commands, also setting this + -- non-null indicates that we are in the special + -- commands mode for processing the -xargs case. Make_Commands_Active := Matching_Name @@ -2077,8 +2078,7 @@ package body VMS_Conv is when T_Options => if SwP + 1 > Arg'Last then - Place_Unix_Switches - (Sw.Options.Unix_String); + Place_Unix_Switches (Sw.Options.Unix_String); SwP := Endp + 1; elsif Arg (SwP + 2) /= '(' then @@ -2099,7 +2099,6 @@ package body VMS_Conv is while SwP <= Endp loop P2 := SwP; - while P2 < Endp and then Arg (P2 + 1) /= ',' loop @@ -2112,8 +2111,7 @@ package body VMS_Conv is Sw.Options); if Opt /= null then - Place_Unix_Switches - (Opt.Unix_String); + Place_Unix_Switches (Opt.Unix_String); end if; SwP := P2 + 2; @@ -2121,8 +2119,7 @@ package body VMS_Conv is when T_Other => Place_Unix_Switches - (new String'(Sw.Unix_String.all & - Arg.all)); + (new String'(Sw.Unix_String.all & Arg.all)); end case; end if; diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index b742c69265b..1da9855245a 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -1926,6 +1926,12 @@ package VMS_Data is -- When using a project file, GNAT MAKE creates a temporary mapping file -- and communicates it to the compiler using this switch. + S_GCC_Multi : aliased constant S := "/MULTI_UNIT_INDEX=#" & + "-gnateI#"; + -- /MULTI_UNIT_INDEX=nnn + -- + -- Specify the index of the unit to compile in a multi-unit source file. + S_GCC_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & "DEFAULT " & "-vP0 " & @@ -3391,12 +3397,6 @@ package VMS_Data is -- -- Inhibit all warning messages of the GCC back-end. - S_GCC_All_Back : aliased constant S := "/ALL_BACK_END_WARNINGS " & - "-Wall"; - -- /ALL_BACK_END_WARNINGS - -- - -- Activate all warning messages of the GCC back-end. - S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" & "BRACKETS " & "-gnatWb " & @@ -3585,6 +3585,7 @@ package VMS_Data is S_GCC_Output 'Access, S_GCC_Machine 'Access, S_GCC_Mapping 'Access, + S_GCC_Multi 'Access, S_GCC_Mess 'Access, S_GCC_Nesting 'Access, S_GCC_Noadc 'Access, @@ -3627,7 +3628,6 @@ package VMS_Data is S_GCC_Wide 'Access, S_GCC_WideX 'Access, S_GCC_No_Back 'Access, - S_GCC_All_Back'Access, S_GCC_Xdebug 'Access, S_GCC_Lxdebug 'Access, S_GCC_Xref 'Access); diff --git a/gcc/bb-reorder.c b/gcc/bb-reorder.c index 11423fed29a..d0ed8ea7bd3 100644 --- a/gcc/bb-reorder.c +++ b/gcc/bb-reorder.c @@ -1965,8 +1965,11 @@ insert_section_boundary_note (void) rtx new_note; int first_partition = 0; - if (flag_reorder_blocks_and_partition) - FOR_EACH_BB (bb) + if (!flag_reorder_blocks_and_partition + || !optimize_function_for_speed_p (cfun)) + return; + + FOR_EACH_BB (bb) { if (!first_partition) first_partition = BB_PARTITION (bb); diff --git a/gcc/cgraphunit.c b/gcc/cgraphunit.c index 5e368f87208..f8cbea33292 100644 --- a/gcc/cgraphunit.c +++ b/gcc/cgraphunit.c @@ -2373,9 +2373,7 @@ cgraph_redirect_edge_call_stmt_to_callee (struct cgraph_edge *e) #endif if (e->indirect_unknown_callee - || decl == e->callee->decl - /* Don't update call from same body alias to the real function. */ - || (decl && cgraph_get_node (decl) == cgraph_get_node (e->callee->decl))) + || decl == e->callee->decl) return e->call_stmt; #ifdef ENABLE_CHECKING diff --git a/gcc/config.gcc b/gcc/config.gcc index 67aae86d740..81b542c7e4c 100644 --- a/gcc/config.gcc +++ b/gcc/config.gcc @@ -353,7 +353,7 @@ i[34567]86-*-*) immintrin.h x86intrin.h avxintrin.h xopintrin.h ia32intrin.h cross-stdarg.h lwpintrin.h popcntintrin.h lzcntintrin.h bmiintrin.h bmi2intrin.h tbmintrin.h - avx2intrin.h" + avx2intrin.h fmaintrin.h" ;; x86_64-*-*) cpu_type=i386 @@ -366,7 +366,7 @@ x86_64-*-*) immintrin.h x86intrin.h avxintrin.h xopintrin.h ia32intrin.h cross-stdarg.h lwpintrin.h popcntintrin.h lzcntintrin.h bmiintrin.h tbmintrin.h bmi2intrin.h - avx2intrin.h" + avx2intrin.h fmaintrin.h" need_64bit_hwint=yes ;; ia64-*-*) diff --git a/gcc/config/arm/arm.c b/gcc/config/arm/arm.c index 0490da23b5e..00479692bd2 100644 --- a/gcc/config/arm/arm.c +++ b/gcc/config/arm/arm.c @@ -2624,7 +2624,7 @@ optimal_immediate_sequence_1 (enum rtx_code code, unsigned HOST_WIDE_INT val, do { int end; - int b1, b2, b3, b4; + unsigned int b1, b2, b3, b4; unsigned HOST_WIDE_INT result; int loc; @@ -3367,8 +3367,8 @@ arm_gen_constant (enum rtx_code code, enum machine_mode mode, rtx cond, if (code == SET) { + can_negate = can_invert; can_invert = 0; - can_negate = 1; code = PLUS; } else if (code == MINUS) diff --git a/gcc/config/i386/constraints.md b/gcc/config/i386/constraints.md index e0b28622d17..bef5b30b013 100644 --- a/gcc/config/i386/constraints.md +++ b/gcc/config/i386/constraints.md @@ -124,7 +124,7 @@ (define_constraint "w" "@internal Call memory operand." - (and (match_test "!TARGET_X32") + (and (not (match_test "TARGET_X32")) (match_operand 0 "memory_operand"))) ;; Integer constant constraints. diff --git a/gcc/config/i386/fmaintrin.h b/gcc/config/i386/fmaintrin.h new file mode 100644 index 00000000000..9ec9d17a330 --- /dev/null +++ b/gcc/config/i386/fmaintrin.h @@ -0,0 +1,297 @@ +/* Copyright (C) 2011 Free Software Foundation, Inc. + + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + Under Section 7 of GPL version 3, you are granted additional + permissions described in the GCC Runtime Library Exception, version + 3.1, as published by the Free Software Foundation. + + You should have received a copy of the GNU General Public License and + a copy of the GCC Runtime Library Exception along with this program; + see the files COPYING3 and COPYING.RUNTIME respectively. If not, see + <http://www.gnu.org/licenses/>. */ + +#ifndef _IMMINTRIN_H_INCLUDED +# error "Never use <fmaintrin.h> directly; include <immintrin.h> instead." +#endif + +#ifndef _FMAINTRIN_H_INCLUDED +#define _FMAINTRIN_H_INCLUDED + +#ifndef __FMA__ +# error "FMA instruction set not enabled" +#else + +extern __inline __m128d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmadd_pd (__m128d __A, __m128d __B, __m128d __C) +{ + return (__m128d)__builtin_ia32_vfmaddpd ((__v2df)__A, (__v2df)__B, + (__v2df)__C); +} + +extern __inline __m256d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fmadd_pd (__m256d __A, __m256d __B, __m256d __C) +{ + return (__m256d)__builtin_ia32_vfmaddpd256 ((__v4df)__A, (__v4df)__B, + (__v4df)__C); +} + +extern __inline __m128 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmadd_ps (__m128 __A, __m128 __B, __m128 __C) +{ + return (__m128)__builtin_ia32_vfmaddps ((__v4sf)__A, (__v4sf)__B, + (__v4sf)__C); +} + +extern __inline __m256 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fmadd_ps (__m256 __A, __m256 __B, __m256 __C) +{ + return (__m256)__builtin_ia32_vfmaddps256 ((__v8sf)__A, (__v8sf)__B, + (__v8sf)__C); +} + +extern __inline __m128d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmadd_sd (__m128d __A, __m128d __B, __m128d __C) +{ + return (__m128d) __builtin_ia32_vfmaddsd3 ((__v2df)__A, (__v2df)__B, + (__v2df)__C); +} + +extern __inline __m128 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmadd_ss (__m128 __A, __m128 __B, __m128 __C) +{ + return (__m128) __builtin_ia32_vfmaddss3 ((__v4sf)__A, (__v4sf)__B, + (__v4sf)__C); +} + +extern __inline __m128d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmsub_pd (__m128d __A, __m128d __B, __m128d __C) +{ + return (__m128d)__builtin_ia32_vfmaddpd ((__v2df)__A, (__v2df)__B, + -(__v2df)__C); +} + +extern __inline __m256d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fmsub_pd (__m256d __A, __m256d __B, __m256d __C) +{ + return (__m256d)__builtin_ia32_vfmaddpd256 ((__v4df)__A, (__v4df)__B, + -(__v4df)__C); +} + +extern __inline __m128 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmsub_ps (__m128 __A, __m128 __B, __m128 __C) +{ + return (__m128)__builtin_ia32_vfmaddps ((__v4sf)__A, (__v4sf)__B, + -(__v4sf)__C); +} + +extern __inline __m256 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fmsub_ps (__m256 __A, __m256 __B, __m256 __C) +{ + return (__m256)__builtin_ia32_vfmaddps256 ((__v8sf)__A, (__v8sf)__B, + -(__v8sf)__C); +} + +extern __inline __m128d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmsub_sd (__m128d __A, __m128d __B, __m128d __C) +{ + return (__m128d)__builtin_ia32_vfmaddsd3 ((__v2df)__A, (__v2df)__B, + -(__v2df)__C); +} + +extern __inline __m128 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmsub_ss (__m128 __A, __m128 __B, __m128 __C) +{ + return (__m128)__builtin_ia32_vfmaddss3 ((__v4sf)__A, (__v4sf)__B, + -(__v4sf)__C); +} + +extern __inline __m128d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fnmadd_pd (__m128d __A, __m128d __B, __m128d __C) +{ + return (__m128d)__builtin_ia32_vfmaddpd (-(__v2df)__A, (__v2df)__B, + (__v2df)__C); +} + +extern __inline __m256d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fnmadd_pd (__m256d __A, __m256d __B, __m256d __C) +{ + return (__m256d)__builtin_ia32_vfmaddpd256 (-(__v4df)__A, (__v4df)__B, + (__v4df)__C); +} + +extern __inline __m128 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fnmadd_ps (__m128 __A, __m128 __B, __m128 __C) +{ + return (__m128)__builtin_ia32_vfmaddps (-(__v4sf)__A, (__v4sf)__B, + (__v4sf)__C); +} + +extern __inline __m256 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fnmadd_ps (__m256 __A, __m256 __B, __m256 __C) +{ + return (__m256)__builtin_ia32_vfmaddps256 (-(__v8sf)__A, (__v8sf)__B, + (__v8sf)__C); +} + +extern __inline __m128d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fnmadd_sd (__m128d __A, __m128d __B, __m128d __C) +{ + return (__m128d)__builtin_ia32_vfmaddsd3 (-(__v2df)__A, (__v2df)__B, + (__v2df)__C); +} + +extern __inline __m128 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fnmadd_ss (__m128 __A, __m128 __B, __m128 __C) +{ + return (__m128)__builtin_ia32_vfmaddss3 (-(__v4sf)__A, (__v4sf)__B, + (__v4sf)__C); +} + +extern __inline __m128d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fnmsub_pd (__m128d __A, __m128d __B, __m128d __C) +{ + return (__m128d)__builtin_ia32_vfmaddpd (-(__v2df)__A, (__v2df)__B, + -(__v2df)__C); +} + +extern __inline __m256d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fnmsub_pd (__m256d __A, __m256d __B, __m256d __C) +{ + return (__m256d)__builtin_ia32_vfmaddpd256 (-(__v4df)__A, (__v4df)__B, + -(__v4df)__C); +} + +extern __inline __m128 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fnmsub_ps (__m128 __A, __m128 __B, __m128 __C) +{ + return (__m128)__builtin_ia32_vfmaddps (-(__v4sf)__A, (__v4sf)__B, + -(__v4sf)__C); +} + +extern __inline __m256 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fnmsub_ps (__m256 __A, __m256 __B, __m256 __C) +{ + return (__m256)__builtin_ia32_vfmaddps256 (-(__v8sf)__A, (__v8sf)__B, + -(__v8sf)__C); +} + +extern __inline __m128d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fnmsub_sd (__m128d __A, __m128d __B, __m128d __C) +{ + return (__m128d)__builtin_ia32_vfmaddsd3 (-(__v2df)__A, (__v2df)__B, + -(__v2df)__C); +} + +extern __inline __m128 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fnmsub_ss (__m128 __A, __m128 __B, __m128 __C) +{ + return (__m128)__builtin_ia32_vfmaddss3 (-(__v4sf)__A, (__v4sf)__B, + -(__v4sf)__C); +} + +extern __inline __m128d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmaddsub_pd (__m128d __A, __m128d __B, __m128d __C) +{ + return (__m128d)__builtin_ia32_vfmaddsubpd ((__v2df)__A, (__v2df)__B, + (__v2df)__C); +} + +extern __inline __m256d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fmaddsub_pd (__m256d __A, __m256d __B, __m256d __C) +{ + return (__m256d)__builtin_ia32_vfmaddsubpd256 ((__v4df)__A, + (__v4df)__B, + (__v4df)__C); +} + +extern __inline __m128 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmaddsub_ps (__m128 __A, __m128 __B, __m128 __C) +{ + return (__m128)__builtin_ia32_vfmaddsubps ((__v4sf)__A, (__v4sf)__B, + (__v4sf)__C); +} + +extern __inline __m256 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fmaddsub_ps (__m256 __A, __m256 __B, __m256 __C) +{ + return (__m256)__builtin_ia32_vfmaddsubps256 ((__v8sf)__A, + (__v8sf)__B, + (__v8sf)__C); +} + +extern __inline __m128d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmsubadd_pd (__m128d __A, __m128d __B, __m128d __C) +{ + return (__m128d)__builtin_ia32_vfmaddsubpd ((__v2df)__A, (__v2df)__B, + -(__v2df)__C); +} + +extern __inline __m256d +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fmsubadd_pd (__m256d __A, __m256d __B, __m256d __C) +{ + return (__m256d)__builtin_ia32_vfmaddsubpd256 ((__v4df)__A, + (__v4df)__B, + -(__v4df)__C); +} + +extern __inline __m128 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm_fmsubadd_ps (__m128 __A, __m128 __B, __m128 __C) +{ + return (__m128)__builtin_ia32_vfmaddsubps ((__v4sf)__A, (__v4sf)__B, + -(__v4sf)__C); +} + +extern __inline __m256 +__attribute__((__gnu_inline__, __always_inline__, __artificial__)) +_mm256_fmsubadd_ps (__m256 __A, __m256 __B, __m256 __C) +{ + return (__m256)__builtin_ia32_vfmaddsubps256 ((__v8sf)__A, + (__v8sf)__B, + -(__v8sf)__C); +} + +#endif + +#endif diff --git a/gcc/config/i386/i386.c b/gcc/config/i386/i386.c index 48b9be0b118..d0e1be5df4a 100644 --- a/gcc/config/i386/i386.c +++ b/gcc/config/i386/i386.c @@ -4076,6 +4076,7 @@ ix86_valid_target_attribute_inner_p (tree args, char *p_strings[], IX86_ATTR_ISA ("sse4a", OPT_msse4a), IX86_ATTR_ISA ("ssse3", OPT_mssse3), IX86_ATTR_ISA ("fma4", OPT_mfma4), + IX86_ATTR_ISA ("fma", OPT_mfma), IX86_ATTR_ISA ("xop", OPT_mxop), IX86_ATTR_ISA ("lwp", OPT_mlwp), IX86_ATTR_ISA ("fsgsbase", OPT_mfsgsbase), @@ -8339,7 +8340,7 @@ get_pc_thunk_name (char name[32], unsigned int regno) gcc_assert (!TARGET_64BIT); if (USE_HIDDEN_LINKONCE) - sprintf (name, "__i686.get_pc_thunk.%s", reg_names[regno]); + sprintf (name, "__x86.get_pc_thunk.%s", reg_names[regno]); else ASM_GENERATE_INTERNAL_LABEL (name, "LPR", regno); } @@ -24055,7 +24056,7 @@ enum ix86_builtins IX86_BUILTIN_VEC_PERM_V4DF, IX86_BUILTIN_VEC_PERM_V8SF, - /* FMA4 and XOP instructions. */ + /* FMA4 instructions. */ IX86_BUILTIN_VFMADDSS, IX86_BUILTIN_VFMADDSD, IX86_BUILTIN_VFMADDPS, @@ -24067,6 +24068,11 @@ enum ix86_builtins IX86_BUILTIN_VFMADDSUBPS256, IX86_BUILTIN_VFMADDSUBPD256, + /* FMA3 instructions. */ + IX86_BUILTIN_VFMADDSS3, + IX86_BUILTIN_VFMADDSD3, + + /* XOP instructions. */ IX86_BUILTIN_VPCMOV, IX86_BUILTIN_VPCMOV_V2DI, IX86_BUILTIN_VPCMOV_V4SI, @@ -25450,6 +25456,13 @@ static const struct builtin_description bdesc_multi_arg[] = "__builtin_ia32_vfmaddsd", IX86_BUILTIN_VFMADDSD, UNKNOWN, (int)MULTI_ARG_3_DF }, + { OPTION_MASK_ISA_FMA, CODE_FOR_fmai_vmfmadd_v4sf, + "__builtin_ia32_vfmaddss3", IX86_BUILTIN_VFMADDSS3, + UNKNOWN, (int)MULTI_ARG_3_SF }, + { OPTION_MASK_ISA_FMA, CODE_FOR_fmai_vmfmadd_v2df, + "__builtin_ia32_vfmaddsd3", IX86_BUILTIN_VFMADDSD3, + UNKNOWN, (int)MULTI_ARG_3_DF }, + { OPTION_MASK_ISA_FMA | OPTION_MASK_ISA_FMA4, CODE_FOR_fma4i_fmadd_v4sf, "__builtin_ia32_vfmaddps", IX86_BUILTIN_VFMADDPS, UNKNOWN, (int)MULTI_ARG_3_SF }, diff --git a/gcc/config/i386/i386.md b/gcc/config/i386/i386.md index 3502b8f44d8..37491ae4a7e 100644 --- a/gcc/config/i386/i386.md +++ b/gcc/config/i386/i386.md @@ -490,18 +490,16 @@ ;; Set when REX opcode prefix is used. (define_attr "prefix_rex" "" - (cond [(eq (symbol_ref "TARGET_64BIT") (const_int 0)) + (cond [(not (match_test "TARGET_64BIT")) (const_int 0) (and (eq_attr "mode" "DI") (and (eq_attr "type" "!push,pop,call,callv,leave,ibr") (eq_attr "unit" "!mmx"))) (const_int 1) (and (eq_attr "mode" "QI") - (ne (symbol_ref "x86_extended_QIreg_mentioned_p (insn)") - (const_int 0))) + (match_test "x86_extended_QIreg_mentioned_p (insn)")) (const_int 1) - (ne (symbol_ref "x86_extended_reg_mentioned_p (insn)") - (const_int 0)) + (match_test "x86_extended_reg_mentioned_p (insn)") (const_int 1) (and (eq_attr "type" "imovx") (match_operand:QI 1 "ext_QIreg_operand" "")) @@ -551,7 +549,7 @@ (eq_attr "unit" "i387") (const_int 0) (and (eq_attr "type" "incdec") - (and (eq (symbol_ref "TARGET_64BIT") (const_int 0)) + (and (not (match_test "TARGET_64BIT")) (ior (match_operand:SI 1 "register_operand" "") (match_operand:HI 1 "register_operand" "")))) (const_int 0) @@ -597,7 +595,7 @@ (attr "length_address"))) (ior (eq_attr "prefix" "vex") (and (eq_attr "prefix" "maybe_vex") - (ne (symbol_ref "TARGET_AVX") (const_int 0)))) + (match_test "TARGET_AVX"))) (plus (attr "length_vex") (plus (attr "length_immediate") (plus (attr "modrm") @@ -1927,16 +1925,13 @@ (set (attr "mode") (cond [(eq_attr "alternative" "2,3") (if_then_else - (ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) + (match_test "optimize_function_for_size_p (cfun)") (const_string "V4SF") (const_string "TI")) (eq_attr "alternative" "4") (if_then_else - (ior (ne (symbol_ref "TARGET_SSE_TYPELESS_STORES") - (const_int 0)) - (ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0))) + (ior (match_test "TARGET_SSE_TYPELESS_STORES") + (match_test "optimize_function_for_size_p (cfun)")) (const_string "V4SF") (const_string "TI"))] (const_string "DI")))]) @@ -1985,13 +1980,11 @@ [(set_attr "type" "sselog1,ssemov,ssemov") (set_attr "prefix" "maybe_vex") (set (attr "mode") - (cond [(ior (eq (symbol_ref "TARGET_SSE2") (const_int 0)) - (ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0))) + (cond [(ior (not (match_test "TARGET_SSE2")) + (match_test "optimize_function_for_size_p (cfun)")) (const_string "V4SF") (and (eq_attr "alternative" "2") - (ne (symbol_ref "TARGET_SSE_TYPELESS_STORES") - (const_int 0))) + (match_test "TARGET_SSE_TYPELESS_STORES")) (const_string "V4SF")] (const_string "TI")))]) @@ -2308,11 +2301,11 @@ (const_string "DI") (eq_attr "alternative" "6,7") (if_then_else - (eq (symbol_ref "TARGET_SSE2") (const_int 0)) + (not (match_test "TARGET_SSE2")) (const_string "V4SF") (const_string "TI")) (and (eq_attr "alternative" "8,9,10,11") - (eq (symbol_ref "TARGET_SSE2") (const_int 0))) + (not (match_test "TARGET_SSE2"))) (const_string "SF") ] (const_string "SI")))]) @@ -2336,20 +2329,16 @@ } } [(set (attr "type") - (cond [(ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) + (cond [(match_test "optimize_function_for_size_p (cfun)") (const_string "imov") (and (eq_attr "alternative" "0") - (ior (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") - (const_int 0)) - (eq (symbol_ref "TARGET_HIMODE_MATH") - (const_int 0)))) + (ior (not (match_test "TARGET_PARTIAL_REG_STALL")) + (not (match_test "TARGET_HIMODE_MATH")))) (const_string "imov") (and (eq_attr "alternative" "1,2") (match_operand:HI 1 "aligned_operand" "")) (const_string "imov") - (and (ne (symbol_ref "TARGET_MOVX") - (const_int 0)) + (and (match_test "TARGET_MOVX") (eq_attr "alternative" "0,2")) (const_string "imovx") ] @@ -2361,10 +2350,8 @@ (match_operand:HI 1 "aligned_operand" "")) (const_string "SI") (and (eq_attr "alternative" "0") - (ior (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") - (const_int 0)) - (eq (symbol_ref "TARGET_HIMODE_MATH") - (const_int 0)))) + (ior (not (match_test "TARGET_PARTIAL_REG_STALL")) + (not (match_test "TARGET_HIMODE_MATH")))) (const_string "SI") ] (const_string "HI")))]) @@ -2400,19 +2387,15 @@ (cond [(and (eq_attr "alternative" "5") (not (match_operand:QI 1 "aligned_operand" ""))) (const_string "imovx") - (ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) + (match_test "optimize_function_for_size_p (cfun)") (const_string "imov") (and (eq_attr "alternative" "3") - (ior (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") - (const_int 0)) - (eq (symbol_ref "TARGET_QIMODE_MATH") - (const_int 0)))) + (ior (not (match_test "TARGET_PARTIAL_REG_STALL")) + (not (match_test "TARGET_QIMODE_MATH")))) (const_string "imov") (eq_attr "alternative" "3,5") (const_string "imovx") - (and (ne (symbol_ref "TARGET_MOVX") - (const_int 0)) + (and (match_test "TARGET_MOVX") (eq_attr "alternative" "2")) (const_string "imovx") ] @@ -2426,20 +2409,15 @@ (const_string "SI") (and (eq_attr "type" "imov") (and (eq_attr "alternative" "0,1") - (and (ne (symbol_ref "TARGET_PARTIAL_REG_DEPENDENCY") - (const_int 0)) - (and (eq (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) - (eq (symbol_ref "TARGET_PARTIAL_REG_STALL") - (const_int 0)))))) + (and (match_test "TARGET_PARTIAL_REG_DEPENDENCY") + (and (not (match_test "optimize_function_for_size_p (cfun)")) + (not (match_test "TARGET_PARTIAL_REG_STALL")))))) (const_string "SI") ;; Avoid partial register stalls when not using QImode arithmetic (and (eq_attr "type" "imov") (and (eq_attr "alternative" "0,1") - (and (ne (symbol_ref "TARGET_PARTIAL_REG_STALL") - (const_int 0)) - (eq (symbol_ref "TARGET_QIMODE_MATH") - (const_int 0))))) + (and (match_test "TARGET_PARTIAL_REG_STALL") + (not (match_test "TARGET_QIMODE_MATH"))))) (const_string "SI") ] (const_string "QI")))]) @@ -2579,8 +2557,7 @@ } [(set (attr "type") (if_then_else (ior (not (match_operand:QI 0 "QIreg_operand" "")) - (ne (symbol_ref "TARGET_MOVX") - (const_int 0))) + (match_test "TARGET_MOVX")) (const_string "imovx") (const_string "imov"))) (set (attr "mode") @@ -2606,8 +2583,7 @@ [(set (attr "type") (if_then_else (and (match_operand:QI 0 "register_operand" "") (ior (not (match_operand:QI 0 "QIreg_operand" "")) - (ne (symbol_ref "TARGET_MOVX") - (const_int 0)))) + (match_test "TARGET_MOVX"))) (const_string "imovx") (const_string "imov"))) (set (attr "mode") @@ -2643,8 +2619,7 @@ } [(set (attr "type") (if_then_else (ior (not (match_operand:QI 0 "QIreg_operand" "")) - (ne (symbol_ref "TARGET_MOVX") - (const_int 0))) + (match_test "TARGET_MOVX")) (const_string "imovx") (const_string "imov"))) (set (attr "mode") @@ -2671,8 +2646,7 @@ [(set (attr "type") (if_then_else (and (match_operand:QI 0 "register_operand" "") (ior (not (match_operand:QI 0 "QIreg_operand" "")) - (ne (symbol_ref "TARGET_MOVX") - (const_int 0)))) + (match_test "TARGET_MOVX"))) (const_string "imovx") (const_string "imov"))) (set (attr "mode") @@ -2937,16 +2911,13 @@ (set (attr "mode") (cond [(eq_attr "alternative" "0,2") (if_then_else - (ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) + (match_test "optimize_function_for_size_p (cfun)") (const_string "V4SF") (const_string "TI")) (eq_attr "alternative" "1") (if_then_else - (ior (ne (symbol_ref "TARGET_SSE_TYPELESS_STORES") - (const_int 0)) - (ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0))) + (ior (match_test "TARGET_SSE_TYPELESS_STORES") + (match_test "optimize_function_for_size_p (cfun)")) (const_string "V4SF") (const_string "TI"))] (const_string "DI")))]) @@ -3084,11 +3055,9 @@ /* xorps is one byte shorter. */ (eq_attr "alternative" "7") - (cond [(ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) + (cond [(match_test "optimize_function_for_size_p (cfun)") (const_string "V4SF") - (ne (symbol_ref "TARGET_SSE_LOAD0_BY_PXOR") - (const_int 0)) + (match_test "TARGET_SSE_LOAD0_BY_PXOR") (const_string "TI") ] (const_string "V2DF")) @@ -3100,11 +3069,9 @@ movaps encodes one byte shorter. */ (eq_attr "alternative" "8") (cond - [(ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) + [(match_test "optimize_function_for_size_p (cfun)") (const_string "V4SF") - (ne (symbol_ref "TARGET_SSE_PARTIAL_REG_DEPENDENCY") - (const_int 0)) + (match_test "TARGET_SSE_PARTIAL_REG_DEPENDENCY") (const_string "V2DF") ] (const_string "DF")) @@ -3113,8 +3080,7 @@ of register. */ (eq_attr "alternative" "9") (if_then_else - (ne (symbol_ref "TARGET_SSE_SPLIT_REGS") - (const_int 0)) + (match_test "TARGET_SSE_SPLIT_REGS") (const_string "V1DF") (const_string "DF")) ] @@ -3208,7 +3174,7 @@ (const_string "SI") /* For SSE1, we have many fewer alternatives. */ - (eq (symbol_ref "TARGET_SSE2") (const_int 0)) + (not (match_test "TARGET_SSE2")) (if_then_else (eq_attr "alternative" "5,6,9,10") (const_string "V4SF") @@ -3216,11 +3182,9 @@ /* xorps is one byte shorter. */ (eq_attr "alternative" "5,9") - (cond [(ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) + (cond [(match_test "optimize_function_for_size_p (cfun)") (const_string "V4SF") - (ne (symbol_ref "TARGET_SSE_LOAD0_BY_PXOR") - (const_int 0)) + (match_test "TARGET_SSE_LOAD0_BY_PXOR") (const_string "TI") ] (const_string "V2DF")) @@ -3232,11 +3196,9 @@ movaps encodes one byte shorter. */ (eq_attr "alternative" "6,10") (cond - [(ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) + [(match_test "optimize_function_for_size_p (cfun)") (const_string "V4SF") - (ne (symbol_ref "TARGET_SSE_PARTIAL_REG_DEPENDENCY") - (const_int 0)) + (match_test "TARGET_SSE_PARTIAL_REG_DEPENDENCY") (const_string "V2DF") ] (const_string "DF")) @@ -3245,8 +3207,7 @@ of register. */ (eq_attr "alternative" "7,11") (if_then_else - (ne (symbol_ref "TARGET_SSE_SPLIT_REGS") - (const_int 0)) + (match_test "TARGET_SSE_SPLIT_REGS") (const_string "V1DF") (const_string "DF")) ] @@ -3321,12 +3282,9 @@ (const_string "SI") (eq_attr "alternative" "5") (if_then_else - (and (and (ne (symbol_ref "TARGET_SSE_LOAD0_BY_PXOR") - (const_int 0)) - (ne (symbol_ref "TARGET_SSE2") - (const_int 0))) - (eq (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0))) + (and (and (match_test "TARGET_SSE_LOAD0_BY_PXOR") + (match_test "TARGET_SSE2")) + (not (match_test "optimize_function_for_size_p (cfun)"))) (const_string "TI") (const_string "V4SF")) /* For architectures resolving dependencies on @@ -3341,10 +3299,8 @@ to avoid problems on using packed logical operations. */ (eq_attr "alternative" "6") (if_then_else - (ior (ne (symbol_ref "TARGET_SSE_PARTIAL_REG_DEPENDENCY") - (const_int 0)) - (ne (symbol_ref "TARGET_SSE_SPLIT_REGS") - (const_int 0))) + (ior (match_test "TARGET_SSE_PARTIAL_REG_DEPENDENCY") + (match_test "TARGET_SSE_SPLIT_REGS")) (const_string "V4SF") (const_string "SF")) (eq_attr "alternative" "11") @@ -4962,7 +4918,7 @@ (set (attr "prefix_rex") (if_then_else (and (eq_attr "prefix" "maybe_vex") - (ne (symbol_ref "<SWI48x:MODE>mode == DImode") (const_int 0))) + (match_test "<SWI48x:MODE>mode == DImode")) (const_string "1") (const_string "*"))) (set_attr "unit" "i387,*,*") @@ -4987,7 +4943,7 @@ (set (attr "prefix_rex") (if_then_else (and (eq_attr "prefix" "maybe_vex") - (ne (symbol_ref "<SWI48x:MODE>mode == DImode") (const_int 0))) + (match_test "<SWI48x:MODE>mode == DImode")) (const_string "1") (const_string "*"))) (set_attr "athlon_decode" "*,direct") @@ -5182,7 +5138,7 @@ (set (attr "prefix_rex") (if_then_else (and (eq_attr "prefix" "maybe_vex") - (ne (symbol_ref "<SWI48x:MODE>mode == DImode") (const_int 0))) + (match_test "<SWI48x:MODE>mode == DImode")) (const_string "1") (const_string "*"))) (set_attr "athlon_decode" "double,direct") @@ -5217,7 +5173,7 @@ (set (attr "prefix_rex") (if_then_else (and (eq_attr "prefix" "maybe_vex") - (ne (symbol_ref "<SWI48x:MODE>mode == DImode") (const_int 0))) + (match_test "<SWI48x:MODE>mode == DImode")) (const_string "1") (const_string "*"))) (set_attr "athlon_decode" "direct") @@ -7751,7 +7707,7 @@ (set (attr "prefix_rex") (if_then_else (and (eq_attr "type" "imovx") - (and (ne (symbol_ref "INTVAL (operands[2]) == 0xff") (const_int 0)) + (and (match_test "INTVAL (operands[2]) == 0xff") (match_operand 1 "ext_QIreg_operand" ""))) (const_string "1") (const_string "*"))) @@ -7795,7 +7751,7 @@ (set (attr "prefix_rex") (if_then_else (and (eq_attr "type" "imovx") - (and (ne (symbol_ref "INTVAL (operands[2]) == 0xff") (const_int 0)) + (and (match_test "INTVAL (operands[2]) == 0xff") (match_operand 1 "ext_QIreg_operand" ""))) (const_string "1") (const_string "*"))) @@ -9130,8 +9086,7 @@ (const_string "lea") (eq_attr "alternative" "2") (const_string "ishiftx") - (and (and (ne (symbol_ref "TARGET_DOUBLE_WITH_ADD") - (const_int 0)) + (and (and (match_test "TARGET_DOUBLE_WITH_ADD") (match_operand 0 "register_operand" "")) (match_operand 2 "const1_operand" "")) (const_string "alu") @@ -9142,8 +9097,8 @@ (ior (eq_attr "type" "alu") (and (eq_attr "type" "ishift") (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))))) (const_string "0") (const_string "*"))) (set_attr "mode" "<MODE>")]) @@ -9201,8 +9156,7 @@ (const_string "lea") (eq_attr "alternative" "2") (const_string "ishiftx") - (and (ne (symbol_ref "TARGET_DOUBLE_WITH_ADD") - (const_int 0)) + (and (match_test "TARGET_DOUBLE_WITH_ADD") (match_operand 2 "const1_operand" "")) (const_string "alu") ] @@ -9212,8 +9166,8 @@ (ior (eq_attr "type" "alu") (and (eq_attr "type" "ishift") (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))))) (const_string "0") (const_string "*"))) (set_attr "mode" "SI")]) @@ -9257,8 +9211,7 @@ [(set (attr "type") (cond [(eq_attr "alternative" "1") (const_string "lea") - (and (and (ne (symbol_ref "TARGET_DOUBLE_WITH_ADD") - (const_int 0)) + (and (and (match_test "TARGET_DOUBLE_WITH_ADD") (match_operand 0 "register_operand" "")) (match_operand 2 "const1_operand" "")) (const_string "alu") @@ -9269,8 +9222,8 @@ (ior (eq_attr "type" "alu") (and (eq_attr "type" "ishift") (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))))) (const_string "0") (const_string "*"))) (set_attr "mode" "HI,SI")]) @@ -9316,8 +9269,7 @@ [(set (attr "type") (cond [(eq_attr "alternative" "2") (const_string "lea") - (and (and (ne (symbol_ref "TARGET_DOUBLE_WITH_ADD") - (const_int 0)) + (and (and (match_test "TARGET_DOUBLE_WITH_ADD") (match_operand 0 "register_operand" "")) (match_operand 2 "const1_operand" "")) (const_string "alu") @@ -9328,8 +9280,8 @@ (ior (eq_attr "type" "alu") (and (eq_attr "type" "ishift") (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))))) (const_string "0") (const_string "*"))) (set_attr "mode" "QI,SI,SI")]) @@ -9360,8 +9312,7 @@ } } [(set (attr "type") - (cond [(and (and (ne (symbol_ref "TARGET_DOUBLE_WITH_ADD") - (const_int 0)) + (cond [(and (and (match_test "TARGET_DOUBLE_WITH_ADD") (match_operand 0 "register_operand" "")) (match_operand 1 "const1_operand" "")) (const_string "alu") @@ -9372,8 +9323,8 @@ (ior (eq_attr "type" "alu") (and (eq_attr "type" "ishift1") (and (match_operand 1 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))))) (const_string "0") (const_string "*"))) (set_attr "mode" "QI")]) @@ -9457,8 +9408,7 @@ } } [(set (attr "type") - (cond [(and (and (ne (symbol_ref "TARGET_DOUBLE_WITH_ADD") - (const_int 0)) + (cond [(and (and (match_test "TARGET_DOUBLE_WITH_ADD") (match_operand 0 "register_operand" "")) (match_operand 2 "const1_operand" "")) (const_string "alu") @@ -9469,8 +9419,8 @@ (ior (eq_attr "type" "alu") (and (eq_attr "type" "ishift") (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))))) (const_string "0") (const_string "*"))) (set_attr "mode" "<MODE>")]) @@ -9507,8 +9457,7 @@ } } [(set (attr "type") - (cond [(and (ne (symbol_ref "TARGET_DOUBLE_WITH_ADD") - (const_int 0)) + (cond [(and (match_test "TARGET_DOUBLE_WITH_ADD") (match_operand 2 "const1_operand" "")) (const_string "alu") ] @@ -9518,8 +9467,8 @@ (ior (eq_attr "type" "alu") (and (eq_attr "type" "ishift") (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))))) (const_string "0") (const_string "*"))) (set_attr "mode" "SI")]) @@ -9553,8 +9502,7 @@ } } [(set (attr "type") - (cond [(and (and (ne (symbol_ref "TARGET_DOUBLE_WITH_ADD") - (const_int 0)) + (cond [(and (and (match_test "TARGET_DOUBLE_WITH_ADD") (match_operand 0 "register_operand" "")) (match_operand 2 "const1_operand" "")) (const_string "alu") @@ -9565,8 +9513,8 @@ (ior (eq_attr "type" "alu") (and (eq_attr "type" "ishift") (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))))) (const_string "0") (const_string "*"))) (set_attr "mode" "<MODE>")]) @@ -9784,8 +9732,8 @@ (set (attr "length_immediate") (if_then_else (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))) (const_string "0") (const_string "*"))) (set_attr "mode" "<MODE>")]) @@ -9837,8 +9785,8 @@ (set (attr "length_immediate") (if_then_else (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))) (const_string "0") (const_string "*"))) (set_attr "mode" "SI")]) @@ -9873,8 +9821,8 @@ (set (attr "length_immediate") (if_then_else (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))) (const_string "0") (const_string "*"))) (set_attr "mode" "<MODE>")]) @@ -9899,8 +9847,8 @@ (set (attr "length_immediate") (if_then_else (and (match_operand 1 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))) (const_string "0") (const_string "*"))) (set_attr "mode" "QI")]) @@ -9934,8 +9882,8 @@ (set (attr "length_immediate") (if_then_else (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))) (const_string "0") (const_string "*"))) (set_attr "mode" "<MODE>")]) @@ -9966,8 +9914,8 @@ (set (attr "length_immediate") (if_then_else (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))) (const_string "0") (const_string "*"))) (set_attr "mode" "SI")]) @@ -9996,8 +9944,8 @@ (set (attr "length_immediate") (if_then_else (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))) (const_string "0") (const_string "*"))) (set_attr "mode" "<MODE>")]) @@ -10165,8 +10113,8 @@ (if_then_else (and (eq_attr "type" "rotate") (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0)))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)")))) (const_string "0") (const_string "*"))) (set_attr "mode" "<MODE>")]) @@ -10231,8 +10179,8 @@ (if_then_else (and (eq_attr "type" "rotate") (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0)))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)")))) (const_string "0") (const_string "*"))) (set_attr "mode" "SI")]) @@ -10279,8 +10227,8 @@ (set (attr "length_immediate") (if_then_else (and (match_operand 2 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))) (const_string "0") (const_string "*"))) (set_attr "mode" "<MODE>")]) @@ -10305,8 +10253,8 @@ (set (attr "length_immediate") (if_then_else (and (match_operand 1 "const1_operand" "") - (ne (symbol_ref "TARGET_SHIFT1 || optimize_function_for_size_p (cfun)") - (const_int 0))) + (ior (match_test "TARGET_SHIFT1") + (match_test "optimize_function_for_size_p (cfun)"))) (const_string "0") (const_string "*"))) (set_attr "mode" "QI")]) @@ -15781,7 +15729,7 @@ (set_attr "memory" "both") (set (attr "prefix_rex") (if_then_else - (ne (symbol_ref "<P:MODE>mode == DImode") (const_int 0)) + (match_test "<P:MODE>mode == DImode") (const_string "0") (const_string "*"))) (set_attr "mode" "QI")]) @@ -15957,7 +15905,7 @@ (set_attr "memory" "store") (set (attr "prefix_rex") (if_then_else - (ne (symbol_ref "<P:MODE>mode == DImode") (const_int 0)) + (match_test "<P:MODE>mode == DImode") (const_string "0") (const_string "*"))) (set_attr "mode" "QI")]) @@ -16023,7 +15971,7 @@ (set_attr "memory" "store") (set (attr "prefix_rex") (if_then_else - (ne (symbol_ref "<P:MODE>mode == DImode") (const_int 0)) + (match_test "<P:MODE>mode == DImode") (const_string "0") (const_string "*"))) (set_attr "mode" "QI")]) @@ -16143,7 +16091,7 @@ (set_attr "mode" "QI") (set (attr "prefix_rex") (if_then_else - (ne (symbol_ref "<P:MODE>mode == DImode") (const_int 0)) + (match_test "<P:MODE>mode == DImode") (const_string "0") (const_string "*"))) (set_attr "prefix_rep" "1")]) @@ -16183,7 +16131,7 @@ (set_attr "mode" "QI") (set (attr "prefix_rex") (if_then_else - (ne (symbol_ref "<P:MODE>mode == DImode") (const_int 0)) + (match_test "<P:MODE>mode == DImode") (const_string "0") (const_string "*"))) (set_attr "prefix_rep" "1")]) @@ -16224,7 +16172,7 @@ (set_attr "mode" "QI") (set (attr "prefix_rex") (if_then_else - (ne (symbol_ref "<P:MODE>mode == DImode") (const_int 0)) + (match_test "<P:MODE>mode == DImode") (const_string "0") (const_string "*"))) (set_attr "prefix_rep" "1")]) @@ -16651,7 +16599,7 @@ } [(set (attr "type") (cond [(and (eq_attr "alternative" "0") - (eq (symbol_ref "TARGET_OPT_AGU") (const_int 0))) + (not (match_test "TARGET_OPT_AGU"))) (const_string "alu") (match_operand:<MODE> 2 "const0_operand" "") (const_string "imov") diff --git a/gcc/config/i386/immintrin.h b/gcc/config/i386/immintrin.h index d2e715ff1df..102814e2b90 100644 --- a/gcc/config/i386/immintrin.h +++ b/gcc/config/i386/immintrin.h @@ -72,6 +72,10 @@ #include <bmi2intrin.h> #endif +#ifdef __FMA__ +#include <fmaintrin.h> +#endif + #ifdef __RDRND__ extern __inline int __attribute__((__gnu_inline__, __always_inline__, __artificial__)) diff --git a/gcc/config/i386/mmx.md b/gcc/config/i386/mmx.md index 5e1864b3fda..21f2c94edde 100644 --- a/gcc/config/i386/mmx.md +++ b/gcc/config/i386/mmx.md @@ -159,13 +159,13 @@ (if_then_else (ior (eq_attr "alternative" "4,5") (and (eq_attr "alternative" "7") - (eq (symbol_ref "TARGET_AVX") (const_int 0)))) + (not (match_test "TARGET_AVX")))) (const_string "1") (const_string "*"))) (set (attr "prefix_data16") (if_then_else (and (eq_attr "alternative" "8") - (eq (symbol_ref "TARGET_AVX") (const_int 0))) + (not (match_test "TARGET_AVX"))) (const_string "1") (const_string "*"))) (set (attr "prefix") @@ -224,7 +224,7 @@ (set (attr "length_vex") (if_then_else (and (eq_attr "alternative" "12,13") - (ne (symbol_ref "TARGET_AVX") (const_int 0))) + (match_test "TARGET_AVX")) (const_string "4") (const_string "*"))) (set (attr "prefix") @@ -1563,7 +1563,8 @@ [(set_attr "type" "mmxshft") (set (attr "prefix_extra") (if_then_else - (eq (symbol_ref "(TARGET_SSE || TARGET_3DNOW_A)") (const_int 0)) + (not (ior (match_test "TARGET_SSE") + (match_test "TARGET_3DNOW_A"))) (const_string "1") (const_string "*"))) (set_attr "mode" "DI")]) diff --git a/gcc/config/i386/predicates.md b/gcc/config/i386/predicates.md index b4fa04e2c4d..89cc8a75b55 100644 --- a/gcc/config/i386/predicates.md +++ b/gcc/config/i386/predicates.md @@ -565,7 +565,7 @@ (define_predicate "call_insn_operand" (ior (match_operand 0 "constant_call_address_operand") (match_operand 0 "call_register_no_elim_operand") - (and (match_test "!TARGET_X32") + (and (not (match_test "TARGET_X32")) (match_operand 0 "memory_operand")))) ;; Similarly, but for tail calls, in which we cannot allow memory references. diff --git a/gcc/config/i386/sse.md b/gcc/config/i386/sse.md index fa22e9a11db..3678ea824ec 100644 --- a/gcc/config/i386/sse.md +++ b/gcc/config/i386/sse.md @@ -397,15 +397,12 @@ [(set_attr "type" "sselog1,ssemov,ssemov") (set_attr "prefix" "maybe_vex") (set (attr "mode") - (cond [(ne (symbol_ref "TARGET_AVX") (const_int 0)) + (cond [(match_test "TARGET_AVX") (const_string "<sseinsnmode>") - (ior (ior - (ne (symbol_ref "optimize_function_for_size_p (cfun)") - (const_int 0)) - (eq (symbol_ref "TARGET_SSE2") (const_int 0))) + (ior (ior (match_test "optimize_function_for_size_p (cfun)") + (not (match_test "TARGET_SSE2"))) (and (eq_attr "alternative" "2") - (ne (symbol_ref "TARGET_SSE_TYPELESS_STORES") - (const_int 0)))) + (match_test "TARGET_SSE_TYPELESS_STORES"))) (const_string "V4SF") (eq (const_string "<MODE>mode") (const_string "V4SFmode")) (const_string "V4SF") @@ -548,7 +545,7 @@ (set_attr "movu" "1") (set (attr "prefix_data16") (if_then_else - (ne (symbol_ref "TARGET_AVX") (const_int 0)) + (match_test "TARGET_AVX") (const_string "*") (const_string "1"))) (set_attr "prefix" "maybe_vex") @@ -564,12 +561,12 @@ (set_attr "movu" "1") (set (attr "prefix_data16") (if_then_else - (ne (symbol_ref "TARGET_AVX") (const_int 0)) + (match_test "TARGET_AVX") (const_string "*") (const_string "0"))) (set (attr "prefix_rep") (if_then_else - (ne (symbol_ref "TARGET_AVX") (const_int 0)) + (match_test "TARGET_AVX") (const_string "*") (const_string "1"))) (set_attr "prefix" "maybe_vex") @@ -604,7 +601,7 @@ [(set_attr "type" "ssecvt") (set (attr "prefix_data16") (if_then_else - (ne (symbol_ref "TARGET_AVX") (const_int 0)) + (match_test "TARGET_AVX") (const_string "*") (const_string "1"))) (set_attr "prefix" "maybe_vex") @@ -1719,6 +1716,89 @@ operands[4] = CONST0_RTX (<MODE>mode); }) +(define_expand "fmai_vmfmadd_<mode>" + [(set (match_operand:VF_128 0 "register_operand") + (vec_merge:VF_128 + (fma:VF_128 + (match_operand:VF_128 1 "nonimmediate_operand") + (match_operand:VF_128 2 "nonimmediate_operand") + (match_operand:VF_128 3 "nonimmediate_operand")) + (match_dup 0) + (const_int 1)))] + "TARGET_FMA") + +(define_insn "*fmai_fmadd_<mode>" + [(set (match_operand:VF_128 0 "register_operand" "=x,x,x") + (vec_merge:VF_128 + (fma:VF_128 + (match_operand:VF_128 1 "nonimmediate_operand" "%0, 0,x") + (match_operand:VF_128 2 "nonimmediate_operand" "xm, x,xm") + (match_operand:VF_128 3 "nonimmediate_operand" " x,xm,0")) + (match_dup 0) + (const_int 1)))] + "TARGET_FMA" + "@ + vfmadd132<ssescalarmodesuffix>\t{%2, %3, %0|%0, %3, %2} + vfmadd213<ssescalarmodesuffix>\t{%3, %2, %0|%0, %2, %3} + vfmadd231<ssescalarmodesuffix>\t{%2, %1, %0|%0, %1, %2}" + [(set_attr "type" "ssemuladd") + (set_attr "mode" "<MODE>")]) + +(define_insn "*fmai_fmsub_<mode>" + [(set (match_operand:VF_128 0 "register_operand" "=x,x,x") + (vec_merge:VF_128 + (fma:VF_128 + (match_operand:VF_128 1 "nonimmediate_operand" "%0, 0,x") + (match_operand:VF_128 2 "nonimmediate_operand" "xm, x,xm") + (neg:VF_128 + (match_operand:VF_128 3 "nonimmediate_operand" " x,xm,0"))) + (match_dup 0) + (const_int 1)))] + "TARGET_FMA" + "@ + vfmsub132<ssescalarmodesuffix>\t{%2, %3, %0|%0, %3, %2} + vfmsub213<ssescalarmodesuffix>\t{%3, %2, %0|%0, %2, %3} + vfmsub231<ssescalarmodesuffix>\t{%2, %1, %0|%0, %1, %2}" + [(set_attr "type" "ssemuladd") + (set_attr "mode" "<MODE>")]) + +(define_insn "*fmai_fnmadd_<mode>" + [(set (match_operand:VF_128 0 "register_operand" "=x,x,x") + (vec_merge:VF_128 + (fma:VF_128 + (neg:VF_128 + (match_operand:VF_128 1 "nonimmediate_operand" "%0, 0,x")) + (match_operand:VF_128 2 "nonimmediate_operand" "xm, x,xm") + (match_operand:VF_128 3 "nonimmediate_operand" " x,xm,0")) + (match_dup 0) + (const_int 1)))] + "TARGET_FMA" + "@ + vfnmadd132<ssescalarmodesuffix>\t{%2, %3, %0|%0, %3, %2} + vfnmadd213<ssescalarmodesuffix>\t{%3, %2, %0|%0, %2, %3} + vfnmadd231<ssescalarmodesuffix>\t{%2, %1, %0|%0, %1, %2}" + [(set_attr "type" "ssemuladd") + (set_attr "mode" "<MODE>")]) + +(define_insn "*fmai_fnmsub_<mode>" + [(set (match_operand:VF_128 0 "register_operand" "=x,x,x") + (vec_merge:VF_128 + (fma:VF_128 + (neg:VF_128 + (match_operand:VF_128 1 "nonimmediate_operand" "%0, 0,x")) + (match_operand:VF_128 2 "nonimmediate_operand" "xm, x,xm") + (neg:VF_128 + (match_operand:VF_128 3 "nonimmediate_operand" " x,xm,0"))) + (match_dup 0) + (const_int 1)))] + "TARGET_FMA" + "@ + vfnmsub132<ssescalarmodesuffix>\t{%2, %3, %0|%0, %3, %2} + vfnmsub213<ssescalarmodesuffix>\t{%3, %2, %0|%0, %2, %3} + vfnmsub231<ssescalarmodesuffix>\t{%2, %1, %0|%0, %1, %2}" + [(set_attr "type" "ssemuladd") + (set_attr "mode" "<MODE>")]) + (define_insn "*fma4i_vmfmadd_<mode>" [(set (match_operand:VF_128 0 "register_operand" "=x,x") (vec_merge:VF_128 @@ -2164,7 +2244,7 @@ [(set_attr "type" "ssecvt") (set (attr "prefix_data16") (if_then_else - (ne (symbol_ref "TARGET_AVX") (const_int 0)) + (match_test "TARGET_AVX") (const_string "*") (const_string "1"))) (set_attr "prefix" "maybe_vex") @@ -2187,12 +2267,12 @@ [(set_attr "type" "ssecvt") (set (attr "prefix_rep") (if_then_else - (ne (symbol_ref "TARGET_AVX") (const_int 0)) + (match_test "TARGET_AVX") (const_string "*") (const_string "1"))) (set (attr "prefix_data16") (if_then_else - (ne (symbol_ref "TARGET_AVX") (const_int 0)) + (match_test "TARGET_AVX") (const_string "*") (const_string "0"))) (set_attr "prefix_data16" "0") @@ -4328,7 +4408,7 @@ (set (attr "prefix_data16") (if_then_else (and (eq_attr "alternative" "0") - (eq (symbol_ref "TARGET_AVX") (const_int 0))) + (not (match_test "TARGET_AVX"))) (const_string "1") (const_string "*"))) (set_attr "prefix" "maybe_vex,orig,vex,*,*,*") @@ -4558,7 +4638,7 @@ (set (attr "prefix_data16") (if_then_else (and (eq_attr "alternative" "2,4") - (eq (symbol_ref "TARGET_AVX") (const_int 0))) + (not (match_test "TARGET_AVX"))) (const_string "1") (const_string "*"))) (set_attr "length_immediate" "*,*,*,*,*,1,*,*,*") @@ -6237,11 +6317,11 @@ (const_string "*"))) (set_attr "prefix" "orig,vex") (set (attr "mode") - (cond [(ne (symbol_ref "TARGET_AVX2") (const_int 0)) + (cond [(match_test "TARGET_AVX2") (const_string "OI") - (ne (symbol_ref "GET_MODE_SIZE (<MODE>mode) > 128") (const_int 0)) + (match_test "GET_MODE_SIZE (<MODE>mode) > 128") (const_string "V8SF") - (ne (symbol_ref "TARGET_SSE2") (const_int 0)) + (match_test "TARGET_SSE2") (const_string "TI") ] (const_string "V4SF")))]) @@ -6313,11 +6393,11 @@ (const_string "*"))) (set_attr "prefix" "orig,vex") (set (attr "mode") - (cond [(ne (symbol_ref "TARGET_AVX2") (const_int 0)) + (cond [(match_test "TARGET_AVX2") (const_string "OI") - (ne (symbol_ref "GET_MODE_SIZE (<MODE>mode) > 128") (const_int 0)) + (match_test "GET_MODE_SIZE (<MODE>mode) > 128") (const_string "V8SF") - (ne (symbol_ref "TARGET_SSE2") (const_int 0)) + (match_test "TARGET_SSE2") (const_string "TI") ] (const_string "V4SF")))]) @@ -6730,19 +6810,19 @@ (set_attr "type" "sselog") (set (attr "prefix_rex") (if_then_else - (and (eq (symbol_ref "TARGET_AVX") (const_int 0)) + (and (not (match_test "TARGET_AVX")) (eq (const_string "<MODE>mode") (const_string "V2DImode"))) (const_string "1") (const_string "*"))) (set (attr "prefix_data16") (if_then_else - (and (eq (symbol_ref "TARGET_AVX") (const_int 0)) + (and (not (match_test "TARGET_AVX")) (eq (const_string "<MODE>mode") (const_string "V8HImode"))) (const_string "1") (const_string "*"))) (set (attr "prefix_extra") (if_then_else - (and (eq (symbol_ref "TARGET_AVX") (const_int 0)) + (and (not (match_test "TARGET_AVX")) (eq (const_string "<MODE>mode") (const_string "V8HImode"))) (const_string "*") (const_string "1"))) @@ -7412,7 +7492,7 @@ (set (attr "prefix_rex") (if_then_else (and (eq_attr "alternative" "0,3") - (eq (symbol_ref "TARGET_AVX") (const_int 0))) + (not (match_test "TARGET_AVX"))) (const_string "1") (const_string "*"))) (set_attr "prefix_extra" "1,1,*,*,*,*,*,*,*") @@ -9626,7 +9706,7 @@ [(set_attr "type" "ssecvt") (set (attr "prefix_data16") (if_then_else - (ne (symbol_ref "TARGET_AVX") (const_int 0)) + (match_test "TARGET_AVX") (const_string "*") (const_string "1"))) (set_attr "prefix_extra" "1") diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index 315078aad33..96ac2377be3 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,26 @@ +2011-08-30 Jason Merrill <jason@redhat.com> + + PR c++/50084 + * cp-tree.h (cp_decl_specifier_seq): Rename user_defined_type_p + to type_definition_p. + * parser.c (cp_parser_set_decl_spec_type): Likewise. + * decl.c (grokdeclarator): Check it. + + PR c++/50089 + * semantics.c (finish_id_expression): Use + current_nonlambda_class_type for qualified-ids. + + PR c++/50114 + * decl.c (poplevel): Disable for scope compatibility hack + in C++11 mode. + + PR c++/50220 + * semantics.c (add_capture): Call complete_type for copy. + + PR c++/50234 + * semantics.c (cxx_eval_component_reference): Handle + value-initialization for omitted initializers. + 2011-08-29 Jason Merrill <jason@redhat.com> PR c++/50224 diff --git a/gcc/cp/cp-tree.h b/gcc/cp/cp-tree.h index d1256424def..d18599b0c53 100644 --- a/gcc/cp/cp-tree.h +++ b/gcc/cp/cp-tree.h @@ -4551,8 +4551,8 @@ typedef struct cp_decl_specifier_seq { /* The storage class specified -- or sc_none if no storage class was explicitly specified. */ cp_storage_class storage_class; - /* True iff TYPE_SPEC indicates a user-defined type. */ - BOOL_BITFIELD user_defined_type_p : 1; + /* True iff TYPE_SPEC defines a class or enum. */ + BOOL_BITFIELD type_definition_p : 1; /* True iff multiple types were (erroneously) specified for this decl-specifier-seq. */ BOOL_BITFIELD multiple_types_p : 1; diff --git a/gcc/cp/decl.c b/gcc/cp/decl.c index c375cf7a78d..39a0b0e22fc 100644 --- a/gcc/cp/decl.c +++ b/gcc/cp/decl.c @@ -643,6 +643,9 @@ poplevel (int keep, int reverse, int functionbody) for (link = decls; link; link = TREE_CHAIN (link)) { if (leaving_for_scope && TREE_CODE (link) == VAR_DECL + /* It's hard to make this ARM compatibility hack play nicely with + lambdas, and it really isn't necessary in C++11 mode. */ + && cxx_dialect < cxx0x && DECL_NAME (link)) { tree name = DECL_NAME (link); @@ -9640,6 +9643,7 @@ grokdeclarator (const cp_declarator *declarator, && TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL && TYPE_ANONYMOUS_P (type) + && declspecs->type_definition_p && cp_type_quals (type) == TYPE_UNQUALIFIED) { tree t; diff --git a/gcc/cp/parser.c b/gcc/cp/parser.c index c862a7d0e88..7d766d130ca 100644 --- a/gcc/cp/parser.c +++ b/gcc/cp/parser.c @@ -12577,7 +12577,7 @@ cp_parser_type_specifier (cp_parser* parser, cp_parser_set_decl_spec_type (decl_specs, type_spec, token->location, - /*user_defined_p=*/true); + /*type_definition_p=*/true); return type_spec; } else @@ -12606,7 +12606,7 @@ cp_parser_type_specifier (cp_parser* parser, cp_parser_set_decl_spec_type (decl_specs, type_spec, token->location, - /*user_defined_p=*/true); + /*type_definition_p=*/true); return type_spec; } @@ -12628,7 +12628,7 @@ cp_parser_type_specifier (cp_parser* parser, cp_parser_set_decl_spec_type (decl_specs, type_spec, token->location, - /*user_defined_p=*/true); + /*type_definition_p=*/false); return type_spec; case RID_CONST: @@ -12821,7 +12821,7 @@ cp_parser_simple_type_specifier (cp_parser* parser, if (decl_specs) cp_parser_set_decl_spec_type (decl_specs, type, token->location, - /*user_defined_p=*/true); + /*type_definition_p=*/false); return type; @@ -12831,7 +12831,7 @@ cp_parser_simple_type_specifier (cp_parser* parser, if (decl_specs) cp_parser_set_decl_spec_type (decl_specs, type, token->location, - /*user_defined_p=*/true); + /*type_definition_p=*/false); return type; @@ -12848,7 +12848,7 @@ cp_parser_simple_type_specifier (cp_parser* parser, if (decl_specs) cp_parser_set_decl_spec_type (decl_specs, type, token->location, - /*user_defined_p=*/true); + /*type_definition_p=*/false); cp_lexer_consume_token (parser->lexer); return type; } @@ -12865,7 +12865,7 @@ cp_parser_simple_type_specifier (cp_parser* parser, cp_parser_set_decl_spec_type (decl_specs, type, token->location, - /*user_defined=*/false); + /*type_definition_p=*/false); if (decl_specs) decl_specs->any_specifiers_p = true; @@ -12940,7 +12940,7 @@ cp_parser_simple_type_specifier (cp_parser* parser, if (type && decl_specs) cp_parser_set_decl_spec_type (decl_specs, type, token->location, - /*user_defined=*/true); + /*type_definition_p=*/false); } /* If we didn't get a type-name, issue an error message. */ @@ -21004,15 +21004,14 @@ cp_parser_set_storage_class (cp_parser *parser, decl_specs->conflicting_specifiers_p = true; } -/* Update the DECL_SPECS to reflect the TYPE_SPEC. If USER_DEFINED_P - is true, the type is a user-defined type; otherwise it is a - built-in type specified by a keyword. */ +/* Update the DECL_SPECS to reflect the TYPE_SPEC. If TYPE_DEFINITION_P + is true, the type is a class or enum definition. */ static void cp_parser_set_decl_spec_type (cp_decl_specifier_seq *decl_specs, tree type_spec, location_t location, - bool user_defined_p) + bool type_definition_p) { decl_specs->any_specifiers_p = true; @@ -21022,7 +21021,7 @@ cp_parser_set_decl_spec_type (cp_decl_specifier_seq *decl_specs, declarations so that G++ can work with system headers that are not C++-safe. */ if (decl_specs->specs[(int) ds_typedef] - && !user_defined_p + && !type_definition_p && (type_spec == boolean_type_node || type_spec == char16_type_node || type_spec == char32_type_node @@ -21037,7 +21036,7 @@ cp_parser_set_decl_spec_type (cp_decl_specifier_seq *decl_specs, if (!decl_specs->type) { decl_specs->type = type_spec; - decl_specs->user_defined_type_p = false; + decl_specs->type_definition_p = false; decl_specs->type_location = location; } } @@ -21046,7 +21045,7 @@ cp_parser_set_decl_spec_type (cp_decl_specifier_seq *decl_specs, else { decl_specs->type = type_spec; - decl_specs->user_defined_type_p = user_defined_p; + decl_specs->type_definition_p = type_definition_p; decl_specs->redefined_builtin_type = NULL_TREE; decl_specs->type_location = location; } diff --git a/gcc/cp/semantics.c b/gcc/cp/semantics.c index 07f53b5cd12..ce84062f918 100644 --- a/gcc/cp/semantics.c +++ b/gcc/cp/semantics.c @@ -3251,7 +3251,7 @@ finish_id_expression (tree id_expression, if (scope) { decl = (adjust_result_of_qualified_name_lookup - (decl, scope, current_class_type)); + (decl, scope, current_nonlambda_class_type())); if (TREE_CODE (decl) == FUNCTION_DECL) mark_used (decl); @@ -6518,7 +6518,8 @@ cxx_eval_component_reference (const constexpr_call *call, tree t, if (field == part) return value; } - if (TREE_CODE (TREE_TYPE (whole)) == UNION_TYPE) + if (TREE_CODE (TREE_TYPE (whole)) == UNION_TYPE + && CONSTRUCTOR_NELTS (whole) > 0) { /* DR 1188 says we don't have to deal with this. */ if (!allow_non_constant) @@ -6527,8 +6528,12 @@ cxx_eval_component_reference (const constexpr_call *call, tree t, *non_constant_p = true; return t; } - gcc_unreachable(); - return error_mark_node; + + /* If there's no explicit init for this field, it's value-initialized. */ + value = build_value_init (TREE_TYPE (t), tf_warning_or_error); + return cxx_eval_constant_expression (call, value, + allow_non_constant, addr, + non_constant_p); } /* Subroutine of cxx_eval_constant_expression. @@ -8646,6 +8651,9 @@ add_capture (tree lambda, tree id, tree initializer, bool by_reference_p, if (!real_lvalue_p (initializer)) error ("cannot capture %qE by reference", initializer); } + else + /* Capture by copy requires a complete type. */ + type = complete_type (type); /* Add __ to the beginning of the field name so that user code won't find the field with name lookup. We can't just leave the name diff --git a/gcc/doc/generic.texi b/gcc/doc/generic.texi index dba71e2e0ee..82b26636946 100644 --- a/gcc/doc/generic.texi +++ b/gcc/doc/generic.texi @@ -2504,7 +2504,7 @@ should submit your patches for inclusion in GCC@. @tindex UNKNOWN_TYPE @tindex TYPENAME_TYPE @tindex TYPEOF_TYPE -@findex CP_TYPE_QUALS +@findex cp_type_quals @findex TYPE_UNQUALIFIED @findex TYPE_QUAL_CONST @findex TYPE_QUAL_VOLATILE @@ -2536,8 +2536,8 @@ the type @code{const int ()[7]}, denoting an array of seven @code{int}s. The following functions and macros deal with cv-qualification of types: @ftable @code -@item CP_TYPE_QUALS -This macro returns the set of type qualifiers applied to this type. +@item cp_type_quals +This function returns the set of type qualifiers applied to this type. This value is @code{TYPE_UNQUALIFIED} if no qualifiers have been applied. The @code{TYPE_QUAL_CONST} bit is set if the type is @code{const}-qualified. The @code{TYPE_QUAL_VOLATILE} bit is set if the diff --git a/gcc/doc/md.texi b/gcc/doc/md.texi index ffb8843633e..7fc1a5ee2cc 100644 --- a/gcc/doc/md.texi +++ b/gcc/doc/md.texi @@ -7045,6 +7045,30 @@ string). The @var{constraints} operand is ignored and should be the null string. +@cindex @code{match_test} and attributes +@item (match_test @var{c-expr}) +The test is true if C expression @var{c-expr} is true. In non-constant +attributes, @var{c-expr} has access to the following variables: + +@table @var +@item insn +The rtl instruction under test. +@item which_alternative +The @code{define_insn} alternative that @var{insn} matches. +@xref{Output Statement}. +@item operands +An array of @var{insn}'s rtl operands. +@end table + +@var{c-expr} behaves like the condition in a C @code{if} statement, +so there is no need to explicitly convert the expression into a boolean +0 or 1 value. For example, the following two tests are equivalent: + +@smallexample +(match_test "x & 2") +(match_test "(x & 2) != 0") +@end smallexample + @cindex @code{le} and attributes @cindex @code{leu} and attributes @cindex @code{lt} and attributes @@ -7968,6 +7992,13 @@ verification and debugging. non-critical errors. @item +@dfn{no-comb-vect} prevents the automaton generator from generating +two data structures and comparing them for space efficiency. Using +a comb vector to represent transitions may be better, but it can be +very expensive to construct. This option is useful if the build +process spends an unacceptably long time in genautomata. + +@item @dfn{ndfa} makes nondeterministic finite state automata. This affects the treatment of operator @samp{|} in the regular expressions. The usual treatment of the operator is to try the first alternative and, diff --git a/gcc/expr.c b/gcc/expr.c index e29f3f6f4f9..6e35db2f2e0 100644 --- a/gcc/expr.c +++ b/gcc/expr.c @@ -8636,6 +8636,64 @@ expand_expr_real_2 (sepops ops, rtx target, enum machine_mode tmode, return temp; } + case COND_EXPR: + /* A COND_EXPR with its type being VOID_TYPE represents a + conditional jump and is handled in + expand_gimple_cond_expr. */ + gcc_assert (!VOID_TYPE_P (type)); + + /* Note that COND_EXPRs whose type is a structure or union + are required to be constructed to contain assignments of + a temporary variable, so that we can evaluate them here + for side effect only. If type is void, we must do likewise. */ + + gcc_assert (!TREE_ADDRESSABLE (type) + && !ignore + && TREE_TYPE (treeop1) != void_type_node + && TREE_TYPE (treeop2) != void_type_node); + + /* If we are not to produce a result, we have no target. Otherwise, + if a target was specified use it; it will not be used as an + intermediate target unless it is safe. If no target, use a + temporary. */ + + if (modifier != EXPAND_STACK_PARM + && original_target + && safe_from_p (original_target, treeop0, 1) + && GET_MODE (original_target) == mode +#ifdef HAVE_conditional_move + && (! can_conditionally_move_p (mode) + || REG_P (original_target)) +#endif + && !MEM_P (original_target)) + temp = original_target; + else + temp = assign_temp (type, 0, 0, 1); + + do_pending_stack_adjust (); + NO_DEFER_POP; + op0 = gen_label_rtx (); + op1 = gen_label_rtx (); + jumpifnot (treeop0, op0, -1); + store_expr (treeop1, temp, + modifier == EXPAND_STACK_PARM, + false); + + emit_jump_insn (gen_jump (op1)); + emit_barrier (); + emit_label (op0); + store_expr (treeop2, temp, + modifier == EXPAND_STACK_PARM, + false); + + emit_label (op1); + OK_DEFER_POP; + return temp; + + case VEC_COND_EXPR: + target = expand_vec_cond_expr (type, treeop0, treeop1, treeop2, target); + return target; + default: gcc_unreachable (); } @@ -9878,64 +9936,6 @@ expand_expr_real_1 (tree exp, rtx target, enum machine_mode tmode, return op0; - case COND_EXPR: - /* A COND_EXPR with its type being VOID_TYPE represents a - conditional jump and is handled in - expand_gimple_cond_expr. */ - gcc_assert (!VOID_TYPE_P (type)); - - /* Note that COND_EXPRs whose type is a structure or union - are required to be constructed to contain assignments of - a temporary variable, so that we can evaluate them here - for side effect only. If type is void, we must do likewise. */ - - gcc_assert (!TREE_ADDRESSABLE (type) - && !ignore - && TREE_TYPE (treeop1) != void_type_node - && TREE_TYPE (treeop2) != void_type_node); - - /* If we are not to produce a result, we have no target. Otherwise, - if a target was specified use it; it will not be used as an - intermediate target unless it is safe. If no target, use a - temporary. */ - - if (modifier != EXPAND_STACK_PARM - && original_target - && safe_from_p (original_target, treeop0, 1) - && GET_MODE (original_target) == mode -#ifdef HAVE_conditional_move - && (! can_conditionally_move_p (mode) - || REG_P (original_target)) -#endif - && !MEM_P (original_target)) - temp = original_target; - else - temp = assign_temp (type, 0, 0, 1); - - do_pending_stack_adjust (); - NO_DEFER_POP; - op0 = gen_label_rtx (); - op1 = gen_label_rtx (); - jumpifnot (treeop0, op0, -1); - store_expr (treeop1, temp, - modifier == EXPAND_STACK_PARM, - false); - - emit_jump_insn (gen_jump (op1)); - emit_barrier (); - emit_label (op0); - store_expr (treeop2, temp, - modifier == EXPAND_STACK_PARM, - false); - - emit_label (op1); - OK_DEFER_POP; - return temp; - - case VEC_COND_EXPR: - target = expand_vec_cond_expr (type, treeop0, treeop1, treeop2, target); - return target; - case MODIFY_EXPR: { tree lhs = treeop0; diff --git a/gcc/fold-const.c b/gcc/fold-const.c index 5807a5533ba..0f4ca5e6222 100644 --- a/gcc/fold-const.c +++ b/gcc/fold-const.c @@ -5888,11 +5888,9 @@ extract_muldiv_1 (tree t, tree c, enum tree_code code, tree wide_type, multiple of the other, in which case we replace this with either an operation or CODE or TCODE. - If we have an unsigned type that is not a sizetype, we cannot do - this since it will change the result if the original computation - overflowed. */ - if ((TYPE_OVERFLOW_UNDEFINED (ctype) - || (TREE_CODE (ctype) == INTEGER_TYPE && TYPE_IS_SIZETYPE (ctype))) + If we have an unsigned type, we cannot do this since it will change + the result if the original computation overflowed. */ + if (TYPE_OVERFLOW_UNDEFINED (ctype) && ((code == MULT_EXPR && tcode == EXACT_DIV_EXPR) || (tcode == MULT_EXPR && code != TRUNC_MOD_EXPR && code != CEIL_MOD_EXPR diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d47e4115582..397aa771040 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2011-08-30 Tobias Burnus <burnus@net-b.de> + + PR fortran/45044 + * trans-common.c (build_common_decl): Warn if named common + block's size is not everywhere the same. + +2011-08-30 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/45170 + * trans-stmt.c (gfc_trans_allocate): Evaluate the substring. + 2011-08-29 Janus Weil <janus@gcc.gnu.org> PR fortran/50225 diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index c289bbe3daf..21237c8d8ec 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -390,14 +390,20 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) if (decl != NULL_TREE) { tree size = TYPE_SIZE_UNIT (union_type); + + /* Named common blocks of the same name shall be of the same size + in all scoping units of a program in which they appear, but + blank common blocks may be of different sizes. */ + if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size) + && strcmp (com->name, BLANK_COMMON_NAME)) + gfc_warning ("Named COMMON block '%s' at %L shall be of the " + "same size as elsewhere (%lu vs %lu bytes)", com->name, + &com->where, + (unsigned long) TREE_INT_CST_LOW (size), + (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl))); + if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size)) - { - /* Named common blocks of the same name shall be of the same size - in all scoping units of a program in which they appear, but - blank common blocks may be of different sizes. */ - if (strcmp (com->name, BLANK_COMMON_NAME)) - gfc_warning ("Named COMMON block '%s' at %L shall be of the " - "same size", com->name, &com->where); + { DECL_SIZE (decl) = TYPE_SIZE (union_type); DECL_SIZE_UNIT (decl) = size; DECL_MODE (decl) = TYPE_MODE (union_type); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index a911a5b070e..7d8b4e00827 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4783,6 +4783,10 @@ gfc_trans_allocate (gfc_code * code) || code->expr3->expr_type == EXPR_CONSTANT) { gfc_conv_expr (&se_sz, code->expr3); + gfc_add_block_to_block (&se.pre, &se_sz.pre); + se_sz.string_length + = gfc_evaluate_now (se_sz.string_length, &se.pre); + gfc_add_block_to_block (&se.pre, &se_sz.post); memsz = se_sz.string_length; } else if (code->expr3->mold diff --git a/gcc/genattrtab.c b/gcc/genattrtab.c index a3da97868a9..4a4c2a2c8aa 100644 --- a/gcc/genattrtab.c +++ b/gcc/genattrtab.c @@ -434,8 +434,9 @@ attr_rtx_1 (enum rtx_code code, va_list p) XEXP (rt_val, 1) = arg1; } } - else if (GET_RTX_LENGTH (code) == 1 - && GET_RTX_FORMAT (code)[0] == 's') + else if (code == SYMBOL_REF + || (GET_RTX_LENGTH (code) == 1 + && GET_RTX_FORMAT (code)[0] == 's')) { char *arg0 = va_arg (p, char *); @@ -453,6 +454,11 @@ attr_rtx_1 (enum rtx_code code, va_list p) rtl_obstack = hash_obstack; rt_val = rtx_alloc (code); XSTR (rt_val, 0) = arg0; + if (code == SYMBOL_REF) + { + X0EXP (rt_val, 1) = NULL_RTX; + X0EXP (rt_val, 2) = NULL_RTX; + } } } else if (GET_RTX_LENGTH (code) == 2 @@ -611,6 +617,7 @@ attr_string (const char *str, int len) memcpy (new_str, str, len); new_str[len] = '\0'; attr_hash_add_string (hashcode, new_str); + copy_md_ptr_loc (new_str, str); return new_str; /* Return the new string. */ } @@ -651,6 +658,7 @@ attr_copy_rtx (rtx orig) case CONST_DOUBLE: case CONST_VECTOR: case SYMBOL_REF: + case MATCH_TEST: case CODE_LABEL: case PC: case CC0: @@ -834,6 +842,11 @@ check_attr_test (rtx exp, int is_const, int lineno) XEXP (exp, 0) = check_attr_test (XEXP (exp, 0), is_const, lineno); break; + case MATCH_TEST: + exp = attr_rtx (MATCH_TEST, XSTR (exp, 0)); + ATTR_IND_SIMPLIFIED_P (exp) = 1; + break; + case MATCH_OPERAND: if (is_const) fatal ("RTL operator \"%s\" not valid in constant attribute test", @@ -2900,6 +2913,7 @@ clear_struct_flag (rtx x) case CONST_INT: case CONST_DOUBLE: case CONST_VECTOR: + case MATCH_TEST: case SYMBOL_REF: case CODE_LABEL: case PC: @@ -3564,6 +3578,12 @@ write_test_expr (rtx exp, unsigned int attrs_cached, int flags) printf (HOST_WIDE_INT_PRINT_DEC, XWINT (exp, 0)); break; + case MATCH_TEST: + print_c_condition (XSTR (exp, 0)); + if (flags & FLG_BITWISE) + printf (" != 0"); + break; + /* A random C expression. */ case SYMBOL_REF: print_c_condition (XSTR (exp, 0)); @@ -3758,6 +3778,7 @@ walk_attr_value (rtx exp) must_extract = 1; return; + case MATCH_TEST: case EQ_ATTR_ALT: must_extract = must_constrain = 1; break; diff --git a/gcc/genautomata.c b/gcc/genautomata.c index d614e3a855d..f331f507dae 100644 --- a/gcc/genautomata.c +++ b/gcc/genautomata.c @@ -253,6 +253,7 @@ static arc_t next_out_arc (arc_t); #define W_OPTION "-w" #define NDFA_OPTION "-ndfa" #define COLLAPSE_OPTION "-collapse-ndfa" +#define NO_COMB_OPTION "-no-comb-vect" #define PROGRESS_OPTION "-progress" /* The following flags are set up by function `initiate_automaton_gen'. */ @@ -268,6 +269,9 @@ static int collapse_flag; /* Do not make minimization of DFA (`-no-minimization'). */ static int no_minimization_flag; +/* Do not try to generate a comb vector (`-no-comb-vect'). */ +static int no_comb_flag; + /* Value of this variable is number of automata being generated. The actual number of automata may be less this value if there is not sufficient number of units. This value is defined by argument of @@ -1539,6 +1543,8 @@ gen_automata_option (rtx def) ndfa_flag = 1; else if (strcmp (XSTR (def, 0), COLLAPSE_OPTION + 1) == 0) collapse_flag = 1; + else if (strcmp (XSTR (def, 0), NO_COMB_OPTION + 1) == 0) + no_comb_flag = 1; else if (strcmp (XSTR (def, 0), PROGRESS_OPTION + 1) == 0) progress_flag = 1; else @@ -7251,6 +7257,8 @@ static int undefined_vect_el_value; static int comb_vect_p (state_ainsn_table_t tab) { + if (no_comb_flag) + return false; return (2 * VEC_length (vect_el_t, tab->full_vect) > 5 * VEC_length (vect_el_t, tab->comb_vect)); } @@ -7369,6 +7377,22 @@ add_vect (state_ainsn_table_t tab, int vect_num, vla_hwint_t vect) VEC_replace (vect_el_t, tab->full_vect, full_base + i, VEC_index (vect_el_t, vect, i)); } + + /* The comb_vect min/max values are also used for the full vector, so + compute them now. */ + for (vect_index = 0; vect_index < vect_length; vect_index++) + if (VEC_index (vect_el_t, vect, vect_index) != undefined_vect_el_value) + { + vect_el_t x = VEC_index (vect_el_t, vect, vect_index); + gcc_assert (x >= 0); + if (tab->max_comb_vect_el_value < x) + tab->max_comb_vect_el_value = x; + if (tab->min_comb_vect_el_value > x) + tab->min_comb_vect_el_value = x; + } + if (no_comb_flag) + return; + /* Form comb vector in the table: */ gcc_assert (VEC_length (vect_el_t, tab->comb_vect) == VEC_length (vect_el_t, tab->check_vect)); @@ -7478,10 +7502,6 @@ add_vect (state_ainsn_table_t tab, int vect_num, vla_hwint_t vect) comb_vect_index + vect_index) == undefined_vect_el_value); gcc_assert (x >= 0); - if (tab->max_comb_vect_el_value < x) - tab->max_comb_vect_el_value = x; - if (tab->min_comb_vect_el_value > x) - tab->min_comb_vect_el_value = x; VEC_replace (vect_el_t, tab->comb_vect, comb_vect_index + vect_index, x); VEC_replace (vect_el_t, tab->check_vect, diff --git a/gcc/gimple-fold.c b/gcc/gimple-fold.c index 19f34000654..be5535bf113 100644 --- a/gcc/gimple-fold.c +++ b/gcc/gimple-fold.c @@ -116,14 +116,17 @@ tree canonicalize_constructor_val (tree cval) { STRIP_NOPS (cval); - if (TREE_CODE (cval) == POINTER_PLUS_EXPR) - { - tree t = maybe_fold_offset_to_address (EXPR_LOCATION (cval), - TREE_OPERAND (cval, 0), - TREE_OPERAND (cval, 1), - TREE_TYPE (cval)); - if (t) - cval = t; + if (TREE_CODE (cval) == POINTER_PLUS_EXPR + && TREE_CODE (TREE_OPERAND (cval, 1)) == INTEGER_CST) + { + tree ptr = TREE_OPERAND (cval, 0); + if (is_gimple_min_invariant (ptr)) + cval = build1_loc (EXPR_LOCATION (cval), + ADDR_EXPR, TREE_TYPE (ptr), + fold_build2 (MEM_REF, TREE_TYPE (TREE_TYPE (ptr)), + ptr, + fold_convert (ptr_type_node, + TREE_OPERAND (cval, 1)))); } if (TREE_CODE (cval) == ADDR_EXPR) { @@ -173,384 +176,6 @@ get_symbol_constant_value (tree sym) } -/* Return true if we may propagate the address expression ADDR into the - dereference DEREF and cancel them. */ - -bool -may_propagate_address_into_dereference (tree addr, tree deref) -{ - gcc_assert (TREE_CODE (deref) == MEM_REF - && TREE_CODE (addr) == ADDR_EXPR); - - /* Don't propagate if ADDR's operand has incomplete type. */ - if (!COMPLETE_TYPE_P (TREE_TYPE (TREE_OPERAND (addr, 0)))) - return false; - - /* If the address is invariant then we do not need to preserve restrict - qualifications. But we do need to preserve volatile qualifiers until - we can annotate the folded dereference itself properly. */ - if (is_gimple_min_invariant (addr) - && (!TREE_THIS_VOLATILE (deref) - || TYPE_VOLATILE (TREE_TYPE (addr)))) - return useless_type_conversion_p (TREE_TYPE (deref), - TREE_TYPE (TREE_OPERAND (addr, 0))); - - /* Else both the address substitution and the folding must result in - a valid useless type conversion sequence. */ - return (useless_type_conversion_p (TREE_TYPE (TREE_OPERAND (deref, 0)), - TREE_TYPE (addr)) - && useless_type_conversion_p (TREE_TYPE (deref), - TREE_TYPE (TREE_OPERAND (addr, 0)))); -} - - -/* A subroutine of fold_stmt. Attempts to fold *(A+O) to A[X]. - BASE is an array type. OFFSET is a byte displacement. - - LOC is the location of the original expression. */ - -static tree -maybe_fold_offset_to_array_ref (location_t loc, tree base, tree offset) -{ - tree min_idx, idx, idx_type, elt_offset = integer_zero_node; - tree array_type, elt_type, elt_size; - tree domain_type; - - /* If BASE is an ARRAY_REF, we can pick up another offset (this time - measured in units of the size of elements type) from that ARRAY_REF). - We can't do anything if either is variable. - - The case we handle here is *(&A[N]+O). */ - if (TREE_CODE (base) == ARRAY_REF) - { - tree low_bound = array_ref_low_bound (base); - - elt_offset = TREE_OPERAND (base, 1); - if (TREE_CODE (low_bound) != INTEGER_CST - || TREE_CODE (elt_offset) != INTEGER_CST) - return NULL_TREE; - - elt_offset = int_const_binop (MINUS_EXPR, elt_offset, low_bound); - base = TREE_OPERAND (base, 0); - } - - /* Ignore stupid user tricks of indexing non-array variables. */ - array_type = TREE_TYPE (base); - if (TREE_CODE (array_type) != ARRAY_TYPE) - return NULL_TREE; - elt_type = TREE_TYPE (array_type); - - /* Use signed size type for intermediate computation on the index. */ - idx_type = ssizetype; - - /* If OFFSET and ELT_OFFSET are zero, we don't care about the size of the - element type (so we can use the alignment if it's not constant). - Otherwise, compute the offset as an index by using a division. If the - division isn't exact, then don't do anything. */ - elt_size = TYPE_SIZE_UNIT (elt_type); - if (!elt_size) - return NULL; - if (integer_zerop (offset)) - { - if (TREE_CODE (elt_size) != INTEGER_CST) - elt_size = size_int (TYPE_ALIGN (elt_type)); - - idx = build_int_cst (idx_type, 0); - } - else - { - unsigned HOST_WIDE_INT lquo, lrem; - HOST_WIDE_INT hquo, hrem; - double_int soffset; - - /* The final array offset should be signed, so we need - to sign-extend the (possibly pointer) offset here - and use signed division. */ - soffset = double_int_sext (tree_to_double_int (offset), - TYPE_PRECISION (TREE_TYPE (offset))); - if (TREE_CODE (elt_size) != INTEGER_CST - || div_and_round_double (TRUNC_DIV_EXPR, 0, - soffset.low, soffset.high, - TREE_INT_CST_LOW (elt_size), - TREE_INT_CST_HIGH (elt_size), - &lquo, &hquo, &lrem, &hrem) - || lrem || hrem) - return NULL_TREE; - - idx = build_int_cst_wide (idx_type, lquo, hquo); - } - - /* Assume the low bound is zero. If there is a domain type, get the - low bound, if any, convert the index into that type, and add the - low bound. */ - min_idx = build_int_cst (idx_type, 0); - domain_type = TYPE_DOMAIN (array_type); - if (domain_type) - { - idx_type = domain_type; - if (TYPE_MIN_VALUE (idx_type)) - min_idx = TYPE_MIN_VALUE (idx_type); - else - min_idx = fold_convert (idx_type, min_idx); - - if (TREE_CODE (min_idx) != INTEGER_CST) - return NULL_TREE; - - elt_offset = fold_convert (idx_type, elt_offset); - } - - if (!integer_zerop (min_idx)) - idx = int_const_binop (PLUS_EXPR, idx, min_idx); - if (!integer_zerop (elt_offset)) - idx = int_const_binop (PLUS_EXPR, idx, elt_offset); - - /* Make sure to possibly truncate late after offsetting. */ - idx = fold_convert (idx_type, idx); - - /* We don't want to construct access past array bounds. For example - char *(c[4]); - c[3][2]; - should not be simplified into (*c)[14] or tree-vrp will - give false warnings. - This is only an issue for multi-dimensional arrays. */ - if (TREE_CODE (elt_type) == ARRAY_TYPE - && domain_type) - { - if (TYPE_MAX_VALUE (domain_type) - && TREE_CODE (TYPE_MAX_VALUE (domain_type)) == INTEGER_CST - && tree_int_cst_lt (TYPE_MAX_VALUE (domain_type), idx)) - return NULL_TREE; - else if (TYPE_MIN_VALUE (domain_type) - && TREE_CODE (TYPE_MIN_VALUE (domain_type)) == INTEGER_CST - && tree_int_cst_lt (idx, TYPE_MIN_VALUE (domain_type))) - return NULL_TREE; - else if (compare_tree_int (idx, 0) < 0) - return NULL_TREE; - } - - { - tree t = build4 (ARRAY_REF, elt_type, base, idx, NULL_TREE, NULL_TREE); - SET_EXPR_LOCATION (t, loc); - return t; - } -} - - -/* Attempt to express (ORIG_TYPE)BASE+OFFSET as BASE[index]. - LOC is the location of original expression. - - Before attempting the conversion strip off existing ADDR_EXPRs. */ - -tree -maybe_fold_offset_to_reference (location_t loc, tree base, tree offset, - tree orig_type) -{ - tree ret; - - STRIP_NOPS (base); - if (TREE_CODE (base) != ADDR_EXPR) - return NULL_TREE; - - base = TREE_OPERAND (base, 0); - if (types_compatible_p (orig_type, TREE_TYPE (base)) - && integer_zerop (offset)) - return base; - - ret = maybe_fold_offset_to_array_ref (loc, base, offset); - if (ret && types_compatible_p (orig_type, TREE_TYPE (ret))) - return ret; - return NULL_TREE; -} - -/* Attempt to express (ORIG_TYPE)ADDR+OFFSET as (*ADDR)[index]. - LOC is the location of the original expression. */ - -tree -maybe_fold_offset_to_address (location_t loc, tree addr, tree offset, - tree orig_type) -{ - tree base, ret; - - STRIP_NOPS (addr); - if (TREE_CODE (addr) != ADDR_EXPR) - return NULL_TREE; - base = TREE_OPERAND (addr, 0); - ret = maybe_fold_offset_to_array_ref (loc, base, offset); - if (ret) - { - ret = build_fold_addr_expr (ret); - if (!useless_type_conversion_p (orig_type, TREE_TYPE (ret))) - return NULL_TREE; - SET_EXPR_LOCATION (ret, loc); - } - - return ret; -} - - -/* A quaint feature extant in our address arithmetic is that there - can be hidden type changes here. The type of the result need - not be the same as the type of the input pointer. - - What we're after here is an expression of the form - (T *)(&array + const) - where array is OP0, const is OP1, RES_TYPE is T and - the cast doesn't actually exist, but is implicit in the - type of the POINTER_PLUS_EXPR. We'd like to turn this into - &array[x] - which may be able to propagate further. */ - -tree -maybe_fold_stmt_addition (location_t loc, tree res_type, tree op0, tree op1) -{ - tree ptd_type; - tree t; - - /* The first operand should be an ADDR_EXPR. */ - if (TREE_CODE (op0) != ADDR_EXPR) - return NULL_TREE; - op0 = TREE_OPERAND (op0, 0); - - /* It had better be a constant. */ - if (TREE_CODE (op1) != INTEGER_CST) - { - /* Or op0 should now be A[0] and the non-constant offset defined - via a multiplication by the array element size. */ - if (TREE_CODE (op0) == ARRAY_REF - /* As we will end up creating a variable index array access - in the outermost array dimension make sure there isn't - a more inner array that the index could overflow to. */ - && TREE_CODE (TREE_OPERAND (op0, 0)) != ARRAY_REF - && integer_zerop (TREE_OPERAND (op0, 1)) - && TREE_CODE (op1) == SSA_NAME) - { - gimple offset_def = SSA_NAME_DEF_STMT (op1); - tree elsz = TYPE_SIZE_UNIT (TREE_TYPE (op0)); - if (!host_integerp (elsz, 1) - || !is_gimple_assign (offset_def)) - return NULL_TREE; - - /* Do not build array references of something that we can't - see the true number of array dimensions for. */ - if (!DECL_P (TREE_OPERAND (op0, 0)) - && !handled_component_p (TREE_OPERAND (op0, 0))) - return NULL_TREE; - - if (gimple_assign_rhs_code (offset_def) == MULT_EXPR - && TREE_CODE (gimple_assign_rhs2 (offset_def)) == INTEGER_CST - && tree_int_cst_equal (gimple_assign_rhs2 (offset_def), elsz)) - return build_fold_addr_expr - (build4 (ARRAY_REF, TREE_TYPE (op0), - TREE_OPERAND (op0, 0), - gimple_assign_rhs1 (offset_def), - TREE_OPERAND (op0, 2), - TREE_OPERAND (op0, 3))); - else if (integer_onep (elsz) - && gimple_assign_rhs_code (offset_def) != MULT_EXPR) - return build_fold_addr_expr - (build4 (ARRAY_REF, TREE_TYPE (op0), - TREE_OPERAND (op0, 0), - op1, - TREE_OPERAND (op0, 2), - TREE_OPERAND (op0, 3))); - } - else if (TREE_CODE (TREE_TYPE (op0)) == ARRAY_TYPE - /* Dto. */ - && TREE_CODE (TREE_TYPE (TREE_TYPE (op0))) != ARRAY_TYPE - && TREE_CODE (op1) == SSA_NAME) - { - gimple offset_def = SSA_NAME_DEF_STMT (op1); - tree elsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (op0))); - if (!host_integerp (elsz, 1) - || !is_gimple_assign (offset_def)) - return NULL_TREE; - - /* Do not build array references of something that we can't - see the true number of array dimensions for. */ - if (!DECL_P (op0) - && !handled_component_p (op0)) - return NULL_TREE; - - if (gimple_assign_rhs_code (offset_def) == MULT_EXPR - && TREE_CODE (gimple_assign_rhs2 (offset_def)) == INTEGER_CST - && tree_int_cst_equal (gimple_assign_rhs2 (offset_def), elsz)) - return build_fold_addr_expr - (build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (op0)), - op0, gimple_assign_rhs1 (offset_def), - integer_zero_node, NULL_TREE)); - else if (integer_onep (elsz) - && gimple_assign_rhs_code (offset_def) != MULT_EXPR) - return build_fold_addr_expr - (build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (op0)), - op0, op1, - integer_zero_node, NULL_TREE)); - } - - return NULL_TREE; - } - - /* If the first operand is an ARRAY_REF, expand it so that we can fold - the offset into it. */ - while (TREE_CODE (op0) == ARRAY_REF) - { - tree array_obj = TREE_OPERAND (op0, 0); - tree array_idx = TREE_OPERAND (op0, 1); - tree elt_type = TREE_TYPE (op0); - tree elt_size = TYPE_SIZE_UNIT (elt_type); - tree min_idx; - - if (TREE_CODE (array_idx) != INTEGER_CST) - break; - if (TREE_CODE (elt_size) != INTEGER_CST) - break; - - /* Un-bias the index by the min index of the array type. */ - min_idx = TYPE_DOMAIN (TREE_TYPE (array_obj)); - if (min_idx) - { - min_idx = TYPE_MIN_VALUE (min_idx); - if (min_idx) - { - if (TREE_CODE (min_idx) != INTEGER_CST) - break; - - array_idx = fold_convert (TREE_TYPE (min_idx), array_idx); - if (!integer_zerop (min_idx)) - array_idx = int_const_binop (MINUS_EXPR, array_idx, - min_idx); - } - } - - /* Convert the index to a byte offset. */ - array_idx = fold_convert (sizetype, array_idx); - array_idx = int_const_binop (MULT_EXPR, array_idx, elt_size); - - /* Update the operands for the next round, or for folding. */ - op1 = int_const_binop (PLUS_EXPR, - array_idx, op1); - op0 = array_obj; - } - - ptd_type = TREE_TYPE (res_type); - /* If we want a pointer to void, reconstruct the reference from the - array element type. A pointer to that can be trivially converted - to void *. This happens as we fold (void *)(ptr p+ off). */ - if (VOID_TYPE_P (ptd_type) - && TREE_CODE (TREE_TYPE (op0)) == ARRAY_TYPE) - ptd_type = TREE_TYPE (TREE_TYPE (op0)); - - /* At which point we can try some of the same things as for indirects. */ - t = maybe_fold_offset_to_array_ref (loc, op0, op1); - if (t) - { - t = build_fold_addr_expr (t); - if (!useless_type_conversion_p (res_type, TREE_TYPE (t))) - return NULL_TREE; - SET_EXPR_LOCATION (t, loc); - } - - return t; -} /* Subroutine of fold_stmt. We perform several simplifications of the memory reference tree EXPR and make sure to re-gimplify them properly @@ -669,42 +294,7 @@ fold_gimple_assign (gimple_stmt_iterator *si) { tree rhs = gimple_assign_rhs1 (stmt); - /* Try to fold a conditional expression. */ - if (TREE_CODE (rhs) == COND_EXPR) - { - tree op0 = COND_EXPR_COND (rhs); - tree tem; - bool set = false; - location_t cond_loc = EXPR_LOCATION (rhs); - - if (COMPARISON_CLASS_P (op0)) - { - fold_defer_overflow_warnings (); - tem = fold_binary_loc (cond_loc, - TREE_CODE (op0), TREE_TYPE (op0), - TREE_OPERAND (op0, 0), - TREE_OPERAND (op0, 1)); - /* This is actually a conditional expression, not a GIMPLE - conditional statement, however, the valid_gimple_rhs_p - test still applies. */ - set = (tem && is_gimple_condexpr (tem) - && valid_gimple_rhs_p (tem)); - fold_undefer_overflow_warnings (set, stmt, 0); - } - else if (is_gimple_min_invariant (op0)) - { - tem = op0; - set = true; - } - else - return NULL_TREE; - - if (set) - result = fold_build3_loc (cond_loc, COND_EXPR, TREE_TYPE (rhs), tem, - COND_EXPR_THEN (rhs), COND_EXPR_ELSE (rhs)); - } - - else if (REFERENCE_CLASS_P (rhs)) + if (REFERENCE_CLASS_P (rhs)) return maybe_fold_reference (rhs, false); else if (TREE_CODE (rhs) == ADDR_EXPR) @@ -783,41 +373,14 @@ fold_gimple_assign (gimple_stmt_iterator *si) if (valid_gimple_rhs_p (result)) return result; } - else if (CONVERT_EXPR_CODE_P (subcode) - && POINTER_TYPE_P (gimple_expr_type (stmt)) - && POINTER_TYPE_P (TREE_TYPE (gimple_assign_rhs1 (stmt)))) - { - tree type = gimple_expr_type (stmt); - tree t = maybe_fold_offset_to_address (loc, - gimple_assign_rhs1 (stmt), - integer_zero_node, type); - if (t) - return t; - } } break; case GIMPLE_BINARY_RHS: - /* Try to fold pointer addition. */ - if (gimple_assign_rhs_code (stmt) == POINTER_PLUS_EXPR) - { - tree type = TREE_TYPE (gimple_assign_rhs1 (stmt)); - if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE) - { - type = build_pointer_type (TREE_TYPE (TREE_TYPE (type))); - if (!useless_type_conversion_p - (TREE_TYPE (gimple_assign_lhs (stmt)), type)) - type = TREE_TYPE (gimple_assign_rhs1 (stmt)); - } - result = maybe_fold_stmt_addition (gimple_location (stmt), - type, - gimple_assign_rhs1 (stmt), - gimple_assign_rhs2 (stmt)); - } /* Try to canonicalize for boolean-typed X the comparisons X == 0, X == 1, X != 0, and X != 1. */ - else if (gimple_assign_rhs_code (stmt) == EQ_EXPR - || gimple_assign_rhs_code (stmt) == NE_EXPR) + if (gimple_assign_rhs_code (stmt) == EQ_EXPR + || gimple_assign_rhs_code (stmt) == NE_EXPR) { tree lhs = gimple_assign_lhs (stmt); tree op1 = gimple_assign_rhs1 (stmt); @@ -871,11 +434,49 @@ fold_gimple_assign (gimple_stmt_iterator *si) break; case GIMPLE_TERNARY_RHS: - result = fold_ternary_loc (loc, subcode, - TREE_TYPE (gimple_assign_lhs (stmt)), - gimple_assign_rhs1 (stmt), - gimple_assign_rhs2 (stmt), - gimple_assign_rhs3 (stmt)); + /* Try to fold a conditional expression. */ + if (gimple_assign_rhs_code (stmt) == COND_EXPR) + { + tree op0 = gimple_assign_rhs1 (stmt); + tree tem; + bool set = false; + location_t cond_loc = gimple_location (stmt); + + if (COMPARISON_CLASS_P (op0)) + { + fold_defer_overflow_warnings (); + tem = fold_binary_loc (cond_loc, + TREE_CODE (op0), TREE_TYPE (op0), + TREE_OPERAND (op0, 0), + TREE_OPERAND (op0, 1)); + /* This is actually a conditional expression, not a GIMPLE + conditional statement, however, the valid_gimple_rhs_p + test still applies. */ + set = (tem && is_gimple_condexpr (tem) + && valid_gimple_rhs_p (tem)); + fold_undefer_overflow_warnings (set, stmt, 0); + } + else if (is_gimple_min_invariant (op0)) + { + tem = op0; + set = true; + } + else + return NULL_TREE; + + if (set) + result = fold_build3_loc (cond_loc, COND_EXPR, + TREE_TYPE (gimple_assign_lhs (stmt)), tem, + gimple_assign_rhs2 (stmt), + gimple_assign_rhs3 (stmt)); + } + + if (!result) + result = fold_ternary_loc (loc, subcode, + TREE_TYPE (gimple_assign_lhs (stmt)), + gimple_assign_rhs1 (stmt), + gimple_assign_rhs2 (stmt), + gimple_assign_rhs3 (stmt)); if (result) { @@ -2945,29 +2546,20 @@ gimple_fold_stmt_to_constant_1 (gimple stmt, tree (*valueize) (tree)) /* Handle unary operators that can appear in GIMPLE form. Note that we know the single operand must be a constant, so this should almost always return a simplified RHS. */ - tree lhs = gimple_assign_lhs (stmt); + tree lhs = gimple_assign_lhs (stmt); tree op0 = (*valueize) (gimple_assign_rhs1 (stmt)); /* Conversions are useless for CCP purposes if they are value-preserving. Thus the restrictions that - useless_type_conversion_p places for pointer type conversions - do not apply here. Substitution later will only substitute to - allowed places. */ + useless_type_conversion_p places for restrict qualification + of pointer types should not apply here. + Substitution later will only substitute to allowed places. */ if (CONVERT_EXPR_CODE_P (subcode) && POINTER_TYPE_P (TREE_TYPE (lhs)) - && POINTER_TYPE_P (TREE_TYPE (op0))) - { - tree tem; - /* Try to re-construct array references on-the-fly. */ - if (!useless_type_conversion_p (TREE_TYPE (lhs), - TREE_TYPE (op0)) - && ((tem = maybe_fold_offset_to_address - (loc, - op0, integer_zero_node, TREE_TYPE (lhs))) - != NULL_TREE)) - return tem; - return op0; - } + && POINTER_TYPE_P (TREE_TYPE (op0)) + && (TYPE_ADDR_SPACE (TREE_TYPE (lhs)) + == TYPE_ADDR_SPACE (TREE_TYPE (op0)))) + return op0; return fold_unary_ignore_overflow_loc (loc, subcode, diff --git a/gcc/gimple-pretty-print.c b/gcc/gimple-pretty-print.c index eaf3e5fa995..1f6efc993f2 100644 --- a/gcc/gimple-pretty-print.c +++ b/gcc/gimple-pretty-print.c @@ -428,6 +428,24 @@ dump_ternary_rhs (pretty_printer *buffer, gimple gs, int spc, int flags) pp_string (buffer, ">"); break; + case COND_EXPR: + dump_generic_node (buffer, gimple_assign_rhs1 (gs), spc, flags, false); + pp_string (buffer, " ? "); + dump_generic_node (buffer, gimple_assign_rhs2 (gs), spc, flags, false); + pp_string (buffer, " : "); + dump_generic_node (buffer, gimple_assign_rhs3 (gs), spc, flags, false); + break; + + case VEC_COND_EXPR: + pp_string (buffer, "VEC_COND_EXPR <"); + dump_generic_node (buffer, gimple_assign_rhs1 (gs), spc, flags, false); + pp_string (buffer, ", "); + dump_generic_node (buffer, gimple_assign_rhs2 (gs), spc, flags, false); + pp_string (buffer, ", "); + dump_generic_node (buffer, gimple_assign_rhs3 (gs), spc, flags, false); + pp_string (buffer, ">"); + break; + default: gcc_unreachable (); } diff --git a/gcc/gimple.c b/gcc/gimple.c index 561e41e4582..75885bbb20e 100644 --- a/gcc/gimple.c +++ b/gcc/gimple.c @@ -2611,19 +2611,19 @@ get_gimple_rhs_num_ops (enum tree_code code) || (SYM) == TRUTH_OR_EXPR \ || (SYM) == TRUTH_XOR_EXPR) ? GIMPLE_BINARY_RHS \ : (SYM) == TRUTH_NOT_EXPR ? GIMPLE_UNARY_RHS \ - : ((SYM) == WIDEN_MULT_PLUS_EXPR \ + : ((SYM) == COND_EXPR \ + || (SYM) == WIDEN_MULT_PLUS_EXPR \ || (SYM) == WIDEN_MULT_MINUS_EXPR \ || (SYM) == DOT_PROD_EXPR \ || (SYM) == REALIGN_LOAD_EXPR \ + || (SYM) == VEC_COND_EXPR \ || (SYM) == FMA_EXPR) ? GIMPLE_TERNARY_RHS \ - : ((SYM) == COND_EXPR \ - || (SYM) == CONSTRUCTOR \ + : ((SYM) == CONSTRUCTOR \ || (SYM) == OBJ_TYPE_REF \ || (SYM) == ASSERT_EXPR \ || (SYM) == ADDR_EXPR \ || (SYM) == WITH_SIZE_EXPR \ - || (SYM) == SSA_NAME \ - || (SYM) == VEC_COND_EXPR) ? GIMPLE_SINGLE_RHS \ + || (SYM) == SSA_NAME) ? GIMPLE_SINGLE_RHS \ : GIMPLE_INVALID_RHS), #define END_OF_BASE_TREE_CODES (unsigned char) GIMPLE_INVALID_RHS, diff --git a/gcc/gimple.h b/gcc/gimple.h index 27b20482876..7f831dffcaf 100644 --- a/gcc/gimple.h +++ b/gcc/gimple.h @@ -5069,12 +5069,8 @@ void gimplify_and_update_call_from_tree (gimple_stmt_iterator *, tree); tree gimple_fold_builtin (gimple); bool fold_stmt (gimple_stmt_iterator *); bool fold_stmt_inplace (gimple); -tree maybe_fold_offset_to_address (location_t, tree, tree, tree); -tree maybe_fold_offset_to_reference (location_t, tree, tree, tree); -tree maybe_fold_stmt_addition (location_t, tree, tree, tree); tree get_symbol_constant_value (tree); tree canonicalize_constructor_val (tree); -bool may_propagate_address_into_dereference (tree, tree); extern tree maybe_fold_and_comparisons (enum tree_code, tree, tree, enum tree_code, tree, tree); extern tree maybe_fold_or_comparisons (enum tree_code, tree, tree, diff --git a/gcc/gimplify.c b/gcc/gimplify.c index a22b5d3121f..d7bc818dfb9 100644 --- a/gcc/gimplify.c +++ b/gcc/gimplify.c @@ -1799,7 +1799,6 @@ canonicalize_addr_expr (tree *expr_p) static enum gimplify_status gimplify_conversion (tree *expr_p) { - tree tem; location_t loc = EXPR_LOCATION (*expr_p); gcc_assert (CONVERT_EXPR_P (*expr_p)); @@ -1810,17 +1809,6 @@ gimplify_conversion (tree *expr_p) if (tree_ssa_useless_type_conversion (*expr_p)) *expr_p = TREE_OPERAND (*expr_p, 0); - /* Attempt to avoid NOP_EXPR by producing reference to a subtype. - For example this fold (subclass *)&A into &A->subclass avoiding - a need for statement. */ - if (CONVERT_EXPR_P (*expr_p) - && POINTER_TYPE_P (TREE_TYPE (*expr_p)) - && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (*expr_p, 0))) - && (tem = maybe_fold_offset_to_address - (EXPR_LOCATION (*expr_p), TREE_OPERAND (*expr_p, 0), - integer_zero_node, TREE_TYPE (*expr_p))) != NULL_TREE) - *expr_p = tem; - /* If we still have a conversion at the toplevel, then canonicalize some constructs. */ if (CONVERT_EXPR_P (*expr_p)) @@ -7302,36 +7290,33 @@ gimplify_expr (tree *expr_p, gimple_seq *pre_p, gimple_seq *post_p, goto expr_3; case POINTER_PLUS_EXPR: - /* Convert ((type *)A)+offset into &A->field_of_type_and_offset. - The second is gimple immediate saving a need for extra statement. - */ - if (TREE_CODE (TREE_OPERAND (*expr_p, 1)) == INTEGER_CST - && (tmp = maybe_fold_offset_to_address - (EXPR_LOCATION (*expr_p), - TREE_OPERAND (*expr_p, 0), TREE_OPERAND (*expr_p, 1), - TREE_TYPE (*expr_p)))) - { - *expr_p = tmp; - ret = GS_OK; - break; - } - /* Convert (void *)&a + 4 into (void *)&a[1]. */ - if (TREE_CODE (TREE_OPERAND (*expr_p, 0)) == NOP_EXPR - && TREE_CODE (TREE_OPERAND (*expr_p, 1)) == INTEGER_CST - && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (TREE_OPERAND (*expr_p, - 0),0))) - && (tmp = maybe_fold_offset_to_address - (EXPR_LOCATION (*expr_p), - TREE_OPERAND (TREE_OPERAND (*expr_p, 0), 0), - TREE_OPERAND (*expr_p, 1), - TREE_TYPE (TREE_OPERAND (TREE_OPERAND (*expr_p, 0), - 0))))) - { - *expr_p = fold_convert (TREE_TYPE (*expr_p), tmp); - ret = GS_OK; - break; - } - /* FALLTHRU */ + { + enum gimplify_status r0, r1; + r0 = gimplify_expr (&TREE_OPERAND (*expr_p, 0), pre_p, + post_p, is_gimple_val, fb_rvalue); + r1 = gimplify_expr (&TREE_OPERAND (*expr_p, 1), pre_p, + post_p, is_gimple_val, fb_rvalue); + recalculate_side_effects (*expr_p); + ret = MIN (r0, r1); + /* Convert &X + CST to invariant &MEM[&X, CST]. Do this + after gimplifying operands - this is similar to how + it would be folding all gimplified stmts on creation + to have them canonicalized, which is what we eventually + should do anyway. */ + if (TREE_CODE (TREE_OPERAND (*expr_p, 1)) == INTEGER_CST + && is_gimple_min_invariant (TREE_OPERAND (*expr_p, 0))) + { + *expr_p = build_fold_addr_expr_with_type_loc + (input_location, + fold_build2 (MEM_REF, TREE_TYPE (TREE_TYPE (*expr_p)), + TREE_OPERAND (*expr_p, 0), + fold_convert (ptr_type_node, + TREE_OPERAND (*expr_p, 1))), + TREE_TYPE (*expr_p)); + ret = MIN (ret, GS_OK); + } + break; + } default: switch (TREE_CODE_CLASS (TREE_CODE (*expr_p))) diff --git a/gcc/ipa-inline-analysis.c b/gcc/ipa-inline-analysis.c index c0eacbb62fd..b56c66944e5 100644 --- a/gcc/ipa-inline-analysis.c +++ b/gcc/ipa-inline-analysis.c @@ -1660,18 +1660,28 @@ compute_inline_parameters (struct cgraph_node *node, bool early) /* Can this function be inlined at all? */ info->inlinable = tree_inlinable_function_p (node->decl); - /* Inlinable functions always can change signature. */ - if (info->inlinable) - node->local.can_change_signature = true; + /* Type attributes can use parameter indices to describe them. */ + if (TYPE_ATTRIBUTES (TREE_TYPE (node->decl))) + node->local.can_change_signature = false; else { - /* Functions calling builtin_apply can not change signature. */ - for (e = node->callees; e; e = e->next_callee) - if (DECL_BUILT_IN (e->callee->decl) - && DECL_BUILT_IN_CLASS (e->callee->decl) == BUILT_IN_NORMAL - && DECL_FUNCTION_CODE (e->callee->decl) == BUILT_IN_APPLY_ARGS) - break; - node->local.can_change_signature = !e; + /* Otherwise, inlinable functions always can change signature. */ + if (info->inlinable) + node->local.can_change_signature = true; + else + { + /* Functions calling builtin_apply can not change signature. */ + for (e = node->callees; e; e = e->next_callee) + { + tree cdecl = e->callee->decl; + if (DECL_BUILT_IN (cdecl) + && DECL_BUILT_IN_CLASS (cdecl) == BUILT_IN_NORMAL + && (DECL_FUNCTION_CODE (cdecl) == BUILT_IN_APPLY_ARGS + || DECL_FUNCTION_CODE (cdecl) == BUILT_IN_VA_START)) + break; + } + node->local.can_change_signature = !e; + } } estimate_function_body_sizes (node, early); diff --git a/gcc/ipa-split.c b/gcc/ipa-split.c index 7413d81aeee..4373a1b423e 100644 --- a/gcc/ipa-split.c +++ b/gcc/ipa-split.c @@ -945,10 +945,10 @@ static void split_function (struct split_point *split_point) { VEC (tree, heap) *args_to_pass = NULL; - bitmap args_to_skip = BITMAP_ALLOC (NULL); + bitmap args_to_skip; tree parm; int num = 0; - struct cgraph_node *node; + struct cgraph_node *node, *cur_node = cgraph_get_node (current_function_decl); basic_block return_bb = find_return_bb (); basic_block call_bb; gimple_stmt_iterator gsi; @@ -968,17 +968,30 @@ split_function (struct split_point *split_point) dump_split_point (dump_file, split_point); } + if (cur_node->local.can_change_signature) + args_to_skip = BITMAP_ALLOC (NULL); + else + args_to_skip = NULL; + /* Collect the parameters of new function and args_to_skip bitmap. */ for (parm = DECL_ARGUMENTS (current_function_decl); parm; parm = DECL_CHAIN (parm), num++) - if (!is_gimple_reg (parm) - || !gimple_default_def (cfun, parm) - || !bitmap_bit_p (split_point->ssa_names_to_pass, - SSA_NAME_VERSION (gimple_default_def (cfun, parm)))) + if (args_to_skip + && (!is_gimple_reg (parm) + || !gimple_default_def (cfun, parm) + || !bitmap_bit_p (split_point->ssa_names_to_pass, + SSA_NAME_VERSION (gimple_default_def (cfun, + parm))))) bitmap_set_bit (args_to_skip, num); else { arg = gimple_default_def (cfun, parm); + if (!arg) + { + arg = make_ssa_name (parm, gimple_build_nop ()); + set_default_def (parm, arg); + } + if (TYPE_MAIN_VARIANT (DECL_ARG_TYPE (parm)) != TYPE_MAIN_VARIANT (TREE_TYPE (arg))) { @@ -1081,9 +1094,7 @@ split_function (struct split_point *split_point) /* Now create the actual clone. */ rebuild_cgraph_edges (); - node = cgraph_function_versioning (cgraph_get_node (current_function_decl), - NULL, NULL, - args_to_skip, + node = cgraph_function_versioning (cur_node, NULL, NULL, args_to_skip, split_point->split_bbs, split_point->entry_bb, "part"); /* For usual cloning it is enough to clear builtin only when signature @@ -1094,7 +1105,7 @@ split_function (struct split_point *split_point) DECL_BUILT_IN_CLASS (node->decl) = NOT_BUILT_IN; DECL_FUNCTION_CODE (node->decl) = (enum built_in_function) 0; } - cgraph_node_remove_callees (cgraph_get_node (current_function_decl)); + cgraph_node_remove_callees (cur_node); if (!split_part_return_p) TREE_THIS_VOLATILE (node->decl) = 1; if (dump_file) diff --git a/gcc/rtl.def b/gcc/rtl.def index b098123cc59..dbf320e7a43 100644 --- a/gcc/rtl.def +++ b/gcc/rtl.def @@ -819,9 +819,8 @@ DEF_RTL_EXPR(MATCH_PAR_DUP, "match_par_dup", "iE", RTX_MATCH) the result of the one before it. */ DEF_RTL_EXPR(MATCH_CODE, "match_code", "ss", RTX_MATCH) -/* Appears only in define_predicate/define_special_predicate - expressions. The argument is a C expression to be injected at this - point in the predicate formula. */ +/* Used to inject a C conditional expression into an .md file. It can + appear in a predicate definition or an attribute expression. */ DEF_RTL_EXPR(MATCH_TEST, "match_test", "s", RTX_MATCH) /* Insn (and related) definitions. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 95c78825a1e..3c4932a2374 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,8 +1,105 @@ +2011-09-01 Ira Rosen <ira.rosen@linaro.org> + + PR tree-optimization/50178 + * gfortran.dg/vect/pr50178.f90: New test. + +2011-08-31 Martin Jambor <mjambor@suse.cz> + + PR middle-end/49886 + * gcc.c-torture/execute/pr49886.c: New testcase. + +2011-08-31 Tom de Vries <tom@codesourcery.com> + + PR middle-end/43513 + * gcc.dg/pr43513.c: New test. + +2011-08-30 Tobias Burnus <burnus@net-b.de> + + PR fortran/45044 + * gfortran.dg/common_14.f90: New. + * gfortran.dg/common_resize_1.f: Add two dg-warning. + +2011-08-30 Jason Merrill <jason@redhat.com> + + PR c++/50084 + * g++.dg/cpp0x/decltype33.C: New. + + PR c++/50089 + * g++.dg/cpp0x/lambda/lambda-qualified.C: New. + + PR c++/50114 + * g++.dg/cpp0x/lambda/lambda-for.C: New. + +2011-08-30 Uros Bizjak <ubizjak@gmail.com> + + * gcc.target/i386/fma-compile.c: Escape [ and ] in scan strings. + +2011-08-30 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/specs/aggr3.ads: New test. + * gnat.dg/specs/aggr3_pkg.ads: New helper. + + * gnat.dg/specs/aggr1.ads: Remove superfluous space. + * gnat.dg/specs/aggr2.ads: Likewise. + +2011-08-30 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/45170 + * gfortran.dg/allocate_with_source_2.f90: New test + +2011-08-30 Jason Merrill <jason@redhat.com> + + PR c++/50220 + * g++.dg/cpp0x/lambda/lambda-50220.C: New. + + PR c++/50234 + * g++.dg/cpp0x/constexpr-value3.C: New. + +2011-08-30 Richard Guenther <rguenther@suse.de> + + PR middle-end/48571 + * gcc.c-torture/execute/pr48571-1.c: New testcase. + * gcc.dg/tree-ssa/ssa-ccp-25.c: Remove. + * gcc.dg/tree-ssa/ssa-ccp-26.c: Likewise. + * gcc.dg/pr36902.c: XFAIL. + +2011-08-30 Ilya Tocar <ilya.tocar@intel.com> + + * gcc.target/i386/fma-check.h: New. + * gcc.target/i386/fma-256-fmaddXX.c: New testcase. + * gcc.target/i386/fma-256-fmaddsubXX.c: Likewise. + * gcc.target/i386/fma-256-fmsubXX.c: Likewise. + * gcc.target/i386/fma-256-fmsubaddXX.c: Likewise. + * gcc.target/i386/fma-256-fnmaddXX.c: Likewise. + * gcc.target/i386/fma-256-fnmsubXX.c: Likewise. + * gcc.target/i386/fma-fmaddXX.c: Likewise. + * gcc.target/i386/fma-fmaddsubXX.c: Likewise. + * gcc.target/i386/fma-fmsubXX.c: Likewise. + * gcc.target/i386/fma-fmsubaddXX.c: Likewise. + * gcc.target/i386/fma-fnmaddXX.c: Likewise. + * gcc.target/i386/fma-fnmsubXX.c: Likewise. + * gcc.target/i386/fma-compile.c: Likewise. + * gcc.target/i386/i386.exp (check_effective_target_fma): New. + * gcc.target/i386/sse-12.c: Add -mfma. + * gcc.target/i386/sse-13.c: Likewise. + * gcc.target/i386/sse-14.c: Likewise. + * gcc.target/i386/sse-22.c: Likewise. + * gcc.target/i386/sse-23.c: Likewise. + * g++.dg/other/i386-2.C: Likewise. + * g++.dg/other/i386-3.C: Likewise. + +2011-08-30 Kirill Yukhin <kirill.yukhin@intel.com> + + PR testsuite/50185 + * gcc.target/i386/avx2-vmovmskb-2.c: Rename to ... + * gcc.target/i386/avx2-vpmovmskb-2.c: ... this. Update. + 2011-08-30 Christian Bruel <christian.bruel@st.com> - * g++.dg/bprob/bprob.exp (feedback_options): Set -fbranch-probabilities. + * g++.dg/bprob/bprob.exp (feedback_options): Set + -fbranch-probabilities. * gcc.misc-tests/bprob.exp (feedback_options): Likewise. - + 2011-08-29 Jason Merrill <jason@redhat.com> PR c++/50224 @@ -1037,7 +1134,7 @@ * gcc.dg/pr49860.c: New. 2011-08-06 Nicola Pero <nicola.pero@meta-innovation.com> - + PR libobjc/49882 * objc.dg/gnu-api-2-class.m (main): Test class_getSuperclass() with classes that are in construction. @@ -3690,7 +3787,7 @@ * gcc.dg/pie-link.c: Use target pie. 2011-06-10 Eric Botcazou <ebotcazou@adacore.com> - Laurent Rougé <laurent.rouge@menta.fr> + Laurent Roug� <laurent.rouge@menta.fr> * gcc.dg/20020503-1.c: Add back -mflat option on the SPARC. * gcc.target/sparc/sparc-ret.c: Skip if -mflat is passed. diff --git a/gcc/testsuite/g++.dg/cpp0x/constexpr-value3.C b/gcc/testsuite/g++.dg/cpp0x/constexpr-value3.C new file mode 100644 index 00000000000..38d89936ec4 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/constexpr-value3.C @@ -0,0 +1,10 @@ +// PR c++/50234 +// { dg-options -std=c++0x } + +#define SA(X) static_assert((X),#X) + +struct A { int i; }; + +constexpr int f(A a) { return a.i; } + +SA(f({}) == 0); diff --git a/gcc/testsuite/g++.dg/cpp0x/decltype33.C b/gcc/testsuite/g++.dg/cpp0x/decltype33.C new file mode 100644 index 00000000000..d022d166482 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/decltype33.C @@ -0,0 +1,18 @@ +// PR c++/50084 +// { dg-options "-std=c++0x -fno-inline" } + +template<typename> struct remove_reference; +template<typename T> struct remove_reference<T&> { typedef T type; }; + +template <class T> void f(T) { } + +void g() +{ + struct { } * v = 0; + + typedef remove_reference<decltype(*v)>::type at; + + // The typedef should't assign the name "at" to the struct. + // { dg-final { scan-assembler "_Z1fIZ1gvEUt_EvT_" } } + f(at()); +} diff --git a/gcc/testsuite/g++.dg/cpp0x/lambda/lambda-50220.C b/gcc/testsuite/g++.dg/cpp0x/lambda/lambda-50220.C new file mode 100644 index 00000000000..240143cf65c --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/lambda/lambda-50220.C @@ -0,0 +1,9 @@ +// PR c++/50220 +// { dg-options -std=c++0x } + +template<typename Foo> struct Foobar {}; + +void foobar(const Foobar<void>& obj) +{ + [obj](){}(); +} diff --git a/gcc/testsuite/g++.dg/cpp0x/lambda/lambda-for.C b/gcc/testsuite/g++.dg/cpp0x/lambda/lambda-for.C new file mode 100644 index 00000000000..f161da85774 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/lambda/lambda-for.C @@ -0,0 +1,12 @@ +// PR c++/50114 +// { dg-options "-std=c++0x -w" } + +int open() +{ + int *x2feed_i = 0; + auto insert_feed = [&](unsigned char venue, int* newfeed) + { + for(int x2feed_i = 1; 0; ) ; + x2feed_i = newfeed; + }; +} diff --git a/gcc/testsuite/g++.dg/cpp0x/lambda/lambda-qualified.C b/gcc/testsuite/g++.dg/cpp0x/lambda/lambda-qualified.C new file mode 100644 index 00000000000..ef041c2bb90 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/lambda/lambda-qualified.C @@ -0,0 +1,17 @@ +// PR c++/50089 +// { dg-options -std=c++0x } + +struct TestBase +{ + void foo() {} +}; + +struct Test : TestBase +{ + void foo() + { + [this]{ + /*this->*/TestBase::foo(); // ICE without this-> + }(); + } +}; diff --git a/gcc/testsuite/g++.dg/ext/forscope2.C b/gcc/testsuite/g++.dg/ext/forscope2.C index b883effb255..4c63bab7703 100644 --- a/gcc/testsuite/g++.dg/ext/forscope2.C +++ b/gcc/testsuite/g++.dg/ext/forscope2.C @@ -1,5 +1,5 @@ // { dg-do compile } -// { dg-options -fpermissive } +// { dg-options "-fpermissive -std=c++98" } // Copyright (C) 2001 Free Software Foundation, Inc. // Contributed by Nathan Sidwell 4 Sept 2001 <nathan@codesourcery.com> diff --git a/gcc/testsuite/g++.dg/other/i386-2.C b/gcc/testsuite/g++.dg/other/i386-2.C index 8c9c911a3df..e8237a45b7b 100644 --- a/gcc/testsuite/g++.dg/other/i386-2.C +++ b/gcc/testsuite/g++.dg/other/i386-2.C @@ -1,9 +1,10 @@ /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ -/* { dg-options "-O -pedantic-errors -march=k8 -msse4a -m3dnow -mavx -mavx2 -mfma4 -mxop -maes -mpclmul -mpopcnt -mabm -mlzcnt -mbmi -mbmi2 -mtbm -mlwp -mfsgsbase -mrdrnd -mf16c" } */ +/* { dg-options "-O -pedantic-errors -march=k8 -msse4a -m3dnow -mavx -mavx2 -mfma4 -mxop -maes -mpclmul -mpopcnt -mabm -mlzcnt -mbmi -mbmi2 -mtbm -mlwp -mfsgsbase -mrdrnd -mf16c -mfma" } */ /* Test that {,x,e,p,t,s,w,a,b,i}mmintrin.h, mm3dnow.h, fma4intrin.h, xopintrin.h, abmintrin.h, bmiintrin.h, tbmintrin.h, lwpintrin.h, - popcntintrin.h and mm_malloc.h.h are usable with -O -pedantic-errors. */ + popcntintrin.h, fmaintrin.h and mm_malloc.h.h are usable with + -O -pedantic-errors. */ #include <x86intrin.h> diff --git a/gcc/testsuite/g++.dg/other/i386-3.C b/gcc/testsuite/g++.dg/other/i386-3.C index d8c6f8d3b15..9abbd3278a2 100644 --- a/gcc/testsuite/g++.dg/other/i386-3.C +++ b/gcc/testsuite/g++.dg/other/i386-3.C @@ -1,9 +1,10 @@ /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ -/* { dg-options "-O -fkeep-inline-functions -march=k8 -msse4a -m3dnow -mavx -mavx2 -mfma4 -mxop -maes -mpclmul -mpopcnt -mabm -mlzcnt -mbmi -mbmi2 -mtbm -mlwp -mfsgsbase -mrdrnd -mf16c" } */ +/* { dg-options "-O -fkeep-inline-functions -march=k8 -msse4a -m3dnow -mavx -mfma4 -mxop -maes -mpclmul -mpopcnt -mabm -mlzcnt -mbmi -mtbm -mlwp -mfsgsbase -mrdrnd -mf16c -mfma" } */ +/* { dg-options "-O -fkeep-inline-functions -march=k8 -msse4a -m3dnow -mavx -mavx2 -mfma4 -mxop -maes -mpclmul -mpopcnt -mabm -mlzcnt -mbmi -mbmi2 -mtbm -mlwp -mfsgsbase -mrdrnd -mf16c -mfma" } */ /* Test that {,x,e,p,t,s,w,a,b,i}mmintrin.h, mm3dnow.h, fma4intrin.h, xopintrin.h, abmintrin.h, bmiintrin.h, tbmintrin.h, lwpintrin.h, - popcntintrin.h and mm_malloc.h are usable with + popcntintrin.h, fmaintrin.h and mm_malloc.h are usable with -O -fkeep-inline-functions. */ #include <x86intrin.h> diff --git a/gcc/testsuite/gcc.c-torture/execute/pr48571-1.c b/gcc/testsuite/gcc.c-torture/execute/pr48571-1.c new file mode 100644 index 00000000000..063058e43b3 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/pr48571-1.c @@ -0,0 +1,28 @@ +unsigned int c[624]; +void __attribute__((noinline)) +bar (void) +{ + unsigned int i; + /* Obfuscated c[i] = c[i-1] * 2. */ + for (i = 1; i < 624; ++i) + *(unsigned int *)((void *)c + (__SIZE_TYPE__)i * 4) + = 2 * *(unsigned int *)((void *)c + ((__SIZE_TYPE__)i + + ((__SIZE_TYPE__)-4)/4) * 4); +} +extern void abort (void); +int +main() +{ + unsigned int i, j; + for (i = 0; i < 624; ++i) + c[i] = 1; + bar(); + j = 1; + for (i = 0; i < 624; ++i) + { + if (c[i] != j) + abort (); + j = j * 2; + } + return 0; +} diff --git a/gcc/testsuite/gcc.c-torture/execute/pr49886.c b/gcc/testsuite/gcc.c-torture/execute/pr49886.c new file mode 100644 index 00000000000..9e9ceb26294 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/pr49886.c @@ -0,0 +1,100 @@ +struct PMC { + unsigned flags; +}; + +typedef struct Pcc_cell +{ + struct PMC *p; + long bla; + long type; +} Pcc_cell; + +int gi; +int cond; + +extern void abort (); +extern void never_ever(int interp, struct PMC *pmc) + __attribute__((noinline,noclone)); + +void never_ever (int interp, struct PMC *pmc) +{ + abort (); +} + +static void mark_cell(int * interp, Pcc_cell *c) + __attribute__((__nonnull__(1))); + +static void +mark_cell(int * interp, Pcc_cell *c) +{ + if (!cond) + return; + + if (c && c->type == 4 && c->p + && !(c->p->flags & (1<<18))) + never_ever(gi + 1, c->p); + if (c && c->type == 4 && c->p + && !(c->p->flags & (1<<17))) + never_ever(gi + 2, c->p); + if (c && c->type == 4 && c->p + && !(c->p->flags & (1<<16))) + never_ever(gi + 3, c->p); + if (c && c->type == 4 && c->p + && !(c->p->flags & (1<<15))) + never_ever(gi + 4, c->p); + if (c && c->type == 4 && c->p + && !(c->p->flags & (1<<14))) + never_ever(gi + 5, c->p); + if (c && c->type == 4 && c->p + && !(c->p->flags & (1<<13))) + never_ever(gi + 6, c->p); + if (c && c->type == 4 && c->p + && !(c->p->flags & (1<<12))) + never_ever(gi + 7, c->p); + if (c && c->type == 4 && c->p + && !(c->p->flags & (1<<11))) + never_ever(gi + 8, c->p); + if (c && c->type == 4 && c->p + && !(c->p->flags & (1<<10))) + never_ever(gi + 9, c->p); +} + +static void +foo(int * interp, Pcc_cell *c) +{ + mark_cell(interp, c); +} + +static struct Pcc_cell * +__attribute__((noinline,noclone)) +getnull(void) +{ + return (struct Pcc_cell *) 0; +} + + +int main() +{ + int i; + + cond = 1; + for (i = 0; i < 100; i++) + foo (&gi, getnull ()); + return 0; +} + + +void +bar_1 (int * interp, Pcc_cell *c) +{ + c->bla += 1; + mark_cell(interp, c); +} + +void +bar_2 (int * interp, Pcc_cell *c) +{ + c->bla += 2; + mark_cell(interp, c); +} + diff --git a/gcc/testsuite/gcc.dg/pr36902.c b/gcc/testsuite/gcc.dg/pr36902.c index 43a2d14f981..a065124ae71 100644 --- a/gcc/testsuite/gcc.dg/pr36902.c +++ b/gcc/testsuite/gcc.dg/pr36902.c @@ -44,7 +44,7 @@ foo2(unsigned char * to, const unsigned char * from, int n) *to = *from; break; case 5: - to[4] = from [4]; /* { dg-warning "array subscript is above array bounds" } */ + to[4] = from [4]; /* { dg-warning "array subscript is above array bounds" "" { xfail *-*-* } } */ break; } return to; diff --git a/gcc/testsuite/gcc.dg/pr43513.c b/gcc/testsuite/gcc.dg/pr43513.c new file mode 100644 index 00000000000..78a037b5985 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr43513.c @@ -0,0 +1,19 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-ccp2" } */ + +void bar (int *); +void foo (char *, int); + +void +foo3 () +{ + const int kIterations = 10; + int results[kIterations]; + int i; + bar (results); + for (i = 0; i < kIterations; i++) + foo ("%d ", results[i]); +} + +/* { dg-final { scan-tree-dump-times "alloca" 0 "ccp2"} } */ +/* { dg-final { cleanup-tree-dump "ccp2" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-ccp-25.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-ccp-25.c deleted file mode 100644 index 7912a57f09e..00000000000 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-ccp-25.c +++ /dev/null @@ -1,14 +0,0 @@ -/* { dg-do compile } */ -/* { dg-options "-O -fdump-tree-ccp1 -fdump-tree-forwprop1" } */ - -int a[256]; -int foo(int i) -{ - int *p = &a[0]; - return *(p + i); -} - -/* { dg-final { scan-tree-dump "&a\\\[\[iD\]\\\." "ccp1" } } */ -/* { dg-final { scan-tree-dump "= .*&a\\\]\\\[\[iD\]\\\." "forwprop1" } } */ -/* { dg-final { cleanup-tree-dump "ccp1" } } */ -/* { dg-final { cleanup-tree-dump "forwprop1" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-ccp-26.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-ccp-26.c deleted file mode 100644 index c0a548155cb..00000000000 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-ccp-26.c +++ /dev/null @@ -1,11 +0,0 @@ -/* { dg-do compile } */ -/* { dg-options "-O -fdump-tree-forwprop1" } */ - -int a[256]; -int foo(int i) -{ - return (a + 1)[i]; -} - -/* { dg-final { scan-tree-dump "=.*&a\\\]\\\[D\\\." "forwprop1" } } */ -/* { dg-final { cleanup-tree-dump "forwprop1" } } */ diff --git a/gcc/testsuite/gcc.target/i386/avx2-vmovmskb-2.c b/gcc/testsuite/gcc.target/i386/avx2-vpmovmskb-2.c index 6637d0c8001..e5a9c10e147 100644 --- a/gcc/testsuite/gcc.target/i386/avx2-vmovmskb-2.c +++ b/gcc/testsuite/gcc.target/i386/avx2-vpmovmskb-2.c @@ -1,6 +1,6 @@ /* { dg-do compile } */ /* { dg-options "-mavx2 -O2" } */ -/* { dg-final { scan-assembler "vmovmskb" } } */ +/* { dg-final { scan-assembler "vpmovmskb\[ \\t\]+\[^\n\]*%ymm\[0-9\]" } } */ #include "avx2-check.h" diff --git a/gcc/testsuite/gcc.target/i386/fma-256-fmaddXX.c b/gcc/testsuite/gcc.target/i386/fma-256-fmaddXX.c new file mode 100644 index 00000000000..7e73402fcb1 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-256-fmaddXX.c @@ -0,0 +1,61 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + +void +check_mm256_fmadd_pd (__m256d __A, __m256d __B, __m256d __C) +{ + union256d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[4]; + int i; + e.x = _mm256_fmadd_pd (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = a.a[i] * b.a[i] + c.a[i]; + } + if (check_union256d (e, d)) + abort (); +} + +void +check_mm256_fmadd_ps (__m256 __A, __m256 __B, __m256 __C) +{ + union256 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[8]; + int i; + e.x = _mm256_fmadd_ps (__A, __B, __C); + for (i = 0; i < 8; i++) + { + d[i] = a.a[i] * b.a[i] + c.a[i]; + } + if (check_union256 (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union256 c[3]; + union256d d[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 8; j++) + c[i].a[j] = i * j + 3.5; + for (j = 0; j < 4; j++) + d[i].a[j] = i * j + 3.5; + } + check_mm256_fmadd_pd (d[0].x, d[1].x, d[2].x); + check_mm256_fmadd_ps (c[0].x, c[1].x, c[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-256-fmaddsubXX.c b/gcc/testsuite/gcc.target/i386/fma-256-fmaddsubXX.c new file mode 100644 index 00000000000..4b61ad5f8ac --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-256-fmaddsubXX.c @@ -0,0 +1,61 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + +void +check_mm256_fmaddsub_ps (__m256 __A, __m256 __B, __m256 __C) +{ + union256 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[8]; + int i; + e.x = _mm256_fmaddsub_ps (__A, __B, __C); + for (i = 0; i < 8; i++) + { + d[i] = a.a[i] * b.a[i] + (i % 2 == 1 ? c.a[i] : -c.a[i]); + } + if (check_union256 (e, d)) + abort (); +} + +void +check_mm256_fmaddsub_pd (__m256d __A, __m256d __B, __m256d __C) +{ + union256d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[4]; + int i; + e.x = _mm256_fmaddsub_pd (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = a.a[i] * b.a[i] + (i % 2 == 1 ? c.a[i] : -c.a[i]); + } + if (check_union256d (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union256 c[3]; + union256d d[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 8; j++) + c[i].a[j] = i * j + 3.5; + for (j = 0; j < 4; j++) + d[i].a[j] = i * j + 3.5; + } + check_mm256_fmaddsub_pd (d[0].x, d[1].x, d[2].x); + check_mm256_fmaddsub_ps (c[0].x, c[1].x, c[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-256-fmsubXX.c b/gcc/testsuite/gcc.target/i386/fma-256-fmsubXX.c new file mode 100644 index 00000000000..d92aec0ec53 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-256-fmsubXX.c @@ -0,0 +1,62 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + + +void +check_mm256_fmsub_pd (__m256d __A, __m256d __B, __m256d __C) +{ + union256d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[4]; + int i; + e.x = _mm256_fmsub_pd (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = a.a[i] * b.a[i] - c.a[i]; + } + if (check_union256d (e, d)) + abort (); +} + +void +check_mm256_fmsub_ps (__m256 __A, __m256 __B, __m256 __C) +{ + union256 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[8]; + int i; + e.x = _mm256_fmsub_ps (__A, __B, __C); + for (i = 0; i < 8; i++) + { + d[i] = a.a[i] * b.a[i] - c.a[i]; + } + if (check_union256 (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union256 c[3]; + union256d d[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 8; j++) + c[i].a[j] = i * j + 3.5; + for (j = 0; j < 4; j++) + d[i].a[j] = i * j + 3.5; + } + check_mm256_fmsub_pd (d[0].x, d[1].x, d[2].x); + check_mm256_fmsub_ps (c[0].x, c[1].x, c[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-256-fmsubaddXX.c b/gcc/testsuite/gcc.target/i386/fma-256-fmsubaddXX.c new file mode 100644 index 00000000000..84a41c4c0b5 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-256-fmsubaddXX.c @@ -0,0 +1,61 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + +void +check_mm256_fmsubadd_ps (__m256 __A, __m256 __B, __m256 __C) +{ + union256 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[8]; + int i; + e.x = _mm256_fmsubadd_ps (__A, __B, __C); + for (i = 0; i < 8; i++) + { + d[i] = a.a[i] * b.a[i] + (i % 2 == 1 ? -c.a[i] : c.a[i]); + } + if (check_union256 (e, d)) + abort (); +} + +void +check_mm256_fmsubadd_pd (__m256d __A, __m256d __B, __m256d __C) +{ + union256d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[4]; + int i; + e.x = _mm256_fmsubadd_pd (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = a.a[i] * b.a[i] + (i % 2 == 1 ? -c.a[i] : c.a[i]); + } + if (check_union256d (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union256 c[3]; + union256d d[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 8; j++) + c[i].a[j] = i * j + 3.5; + for (j = 0; j < 4; j++) + d[i].a[j] = i * j + 3.5; + } + check_mm256_fmsubadd_pd (d[0].x, d[1].x, d[2].x); + check_mm256_fmsubadd_ps (c[0].x, c[1].x, c[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-256-fnmaddXX.c b/gcc/testsuite/gcc.target/i386/fma-256-fnmaddXX.c new file mode 100644 index 00000000000..c0dfa6900b3 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-256-fnmaddXX.c @@ -0,0 +1,61 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + +void +check_mm256_fnmadd_pd (__m256d __A, __m256d __B, __m256d __C) +{ + union256d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[4]; + int i; + e.x = _mm256_fnmadd_pd (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = -a.a[i] * b.a[i] + c.a[i]; + } + if (check_union256d (e, d)) + abort (); +} + +void +check_mm256_fnmadd_ps (__m256 __A, __m256 __B, __m256 __C) +{ + union256 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[8]; + int i; + e.x = _mm256_fnmadd_ps (__A, __B, __C); + for (i = 0; i < 8; i++) + { + d[i] = -a.a[i] * b.a[i] + c.a[i]; + } + if (check_union256 (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union256 c[3]; + union256d d[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 8; j++) + c[i].a[j] = i * j + 3.5; + for (j = 0; j < 4; j++) + d[i].a[j] = i * j + 3.5; + } + check_mm256_fnmadd_pd (d[0].x, d[1].x, d[2].x); + check_mm256_fnmadd_ps (c[0].x, c[1].x, c[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-256-fnmsubXX.c b/gcc/testsuite/gcc.target/i386/fma-256-fnmsubXX.c new file mode 100644 index 00000000000..ac4705e5c61 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-256-fnmsubXX.c @@ -0,0 +1,62 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + + +void +check_mm256_fnmsub_pd (__m256d __A, __m256d __B, __m256d __C) +{ + union256d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[4]; + int i; + e.x = _mm256_fnmsub_pd (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = -a.a[i] * b.a[i] - c.a[i]; + } + if (check_union256d (e, d)) + abort (); +} + +void +check_mm256_fnmsub_ps (__m256 __A, __m256 __B, __m256 __C) +{ + union256 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[8]; + int i; + e.x = _mm256_fnmsub_ps (__A, __B, __C); + for (i = 0; i < 8; i++) + { + d[i] = -a.a[i] * b.a[i] - c.a[i]; + } + if (check_union256 (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union256 c[3]; + union256d d[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 8; j++) + c[i].a[j] = i * j + 3.5; + for (j = 0; j < 4; j++) + d[i].a[j] = i * j + 3.5; + } + check_mm256_fnmsub_pd (d[0].x, d[1].x, d[2].x); + check_mm256_fnmsub_ps (c[0].x, c[1].x, c[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-check.h b/gcc/testsuite/gcc.target/i386/fma-check.h new file mode 100644 index 00000000000..696c4a00fb4 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-check.h @@ -0,0 +1,25 @@ +#include <stdlib.h> + +#include "cpuid.h" + +static void fma_test (void); + +static void __attribute__ ((noinline)) do_test (void) +{ + fma_test (); +} + +int +main () +{ + unsigned int eax, ebx, ecx, edx; + + if (!__get_cpuid (1, &eax, &ebx, &ecx, &edx)) + return 0; + + /* Run FMA test only if host has FMA support. */ + if (ecx & bit_FMA) + do_test (); + + exit (0); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-compile.c b/gcc/testsuite/gcc.target/i386/fma-compile.c new file mode 100644 index 00000000000..0445f7bc0ad --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-compile.c @@ -0,0 +1,221 @@ +/* Test that the compiler properly generates floating point multiply + and add instructions FMA systems. */ + +/* { dg-do compile } */ +/* { dg-options "-O2 -mfma" } */ + +#include <x86intrin.h> + +__m128d +check_mm_fmadd_pd (__m128d a, __m128d b, __m128d c) +{ + return _mm_fmadd_pd (a, b, c); +} + +__m256d +check_mm256_fmadd_pd (__m256d a, __m256d b, __m256d c) +{ + return _mm256_fmadd_pd (a, b, c); +} + +__m128 +check_mm_fmadd_ps (__m128 a, __m128 b, __m128 c) +{ + return _mm_fmadd_ps (a, b, c); +} + +__m256 +check_mm256_fmadd_ps (__m256 a, __m256 b, __m256 c) +{ + return _mm256_fmadd_ps (a, b, c); +} + +__m128d +check_mm_fmadd_sd (__m128d a, __m128d b, __m128d c) +{ + return _mm_fmadd_sd (a, b, c); +} + +__m128 +check_mm_fmadd_ss (__m128 a, __m128 b, __m128 c) +{ + return _mm_fmadd_ss (a, b, c); +} + +__m128d +check_mm_fmsub_pd (__m128d a, __m128d b, __m128d c) +{ + return _mm_fmsub_pd (a, b, c); +} + +__m256d +check_mm256_fmsub_pd (__m256d a, __m256d b, __m256d c) +{ + return _mm256_fmsub_pd (a, b, c); +} + +__m128 +check_mm_fmsub_ps (__m128 a, __m128 b, __m128 c) +{ + return _mm_fmsub_ps (a, b, c); +} + +__m256 +check_mm256_fmsub_ps (__m256 a, __m256 b, __m256 c) +{ + return _mm256_fmsub_ps (a, b, c); +} + +__m128d +check_mm_fmsub_sd (__m128d a, __m128d b, __m128d c) +{ + return _mm_fmsub_sd (a, b, c); +} + +__m128 +check_mm_fmsub_ss (__m128 a, __m128 b, __m128 c) +{ + return _mm_fmsub_ss (a, b, c); +} + +__m128d +check_mm_fnmadd_pd (__m128d a, __m128d b, __m128d c) +{ + return _mm_fnmadd_pd (a, b, c); +} + +__m256d +check_mm256_fnmadd_pd (__m256d a, __m256d b, __m256d c) +{ + return _mm256_fnmadd_pd (a, b, c); +} + +__m128 +check_mm_fnmadd_ps (__m128 a, __m128 b, __m128 c) +{ + return _mm_fnmadd_ps (a, b, c); +} + +__m256 +check_mm256_fnmadd_ps (__m256 a, __m256 b, __m256 c) +{ + return _mm256_fnmadd_ps (a, b, c); +} + +__m128d +check_mm_fnmadd_sd (__m128d a, __m128d b, __m128d c) +{ + return _mm_fnmadd_sd (a, b, c); +} + +__m128 +check_mm_fnmadd_ss (__m128 a, __m128 b, __m128 c) +{ + return _mm_fnmadd_ss (a, b, c); +} + +__m128d +check_mm_fnmsub_pd (__m128d a, __m128d b, __m128d c) +{ + return _mm_fnmsub_pd (a, b, c); +} + +__m256d +check_mm256_fnmsub_pd (__m256d a, __m256d b, __m256d c) +{ + return _mm256_fnmsub_pd (a, b, c); +} + +__m128 +check_mm_fnmsub_ps (__m128 a, __m128 b, __m128 c) +{ + return _mm_fnmsub_ps (a, b, c); +} + +__m256 +check_mm256_fnmsub_ps (__m256 a, __m256 b, __m256 c) +{ + return _mm256_fnmsub_ps (a, b, c); +} + +__m128d +check_mm_fnmsub_sd (__m128d a, __m128d b, __m128d c) +{ + return _mm_fnmsub_sd (a, b, c); +} + +__m128 +check_mm_fnmsub_ss (__m128 a, __m128 b, __m128 c) +{ + return _mm_fnmsub_ss (a, b, c); +} + +__m128d +check_mm_fmaddsub_pd (__m128d a, __m128d b, __m128d c) +{ + return _mm_fmaddsub_pd (a, b, c); +} + +__m256d +check_mm256_fmaddsub_pd (__m256d a, __m256d b, __m256d c) +{ + return _mm256_fmaddsub_pd (a, b, c); +} + +__m128 +check_mm_fmaddsub_ps (__m128 a, __m128 b, __m128 c) +{ + return _mm_fmaddsub_ps (a, b, c); +} + +__m256 +check_mm256_fmaddsub_ps (__m256 a, __m256 b, __m256 c) +{ + return _mm256_fmaddsub_ps (a, b, c); +} + +__m128d +check_mm_fmsubadd_pd (__m128d a, __m128d b, __m128d c) +{ + return _mm_fmsubadd_pd (a, b, c); +} + +__m256d +check_mm256_fmsubadd_pd (__m256d a, __m256d b, __m256d c) +{ + return _mm256_fmsubadd_pd (a, b, c); +} + +__m128 +check_mm_fmsubadd_ps (__m128 a, __m128 b, __m128 c) +{ + return _mm_fmsubadd_ps (a, b, c); +} + +__m256 +check_mm256_fmsubadd_ps (__m256 a, __m256 b, __m256 c) +{ + return _mm256_fmsubadd_ps (a, b, c); +} + + +/* { dg-final { scan-assembler-times "vfmadd\[^s\]..ps" 2 } } */ +/* { dg-final { scan-assembler-times "vfmsub\[^s\]..ps" 2 } } */ +/* { dg-final { scan-assembler-times "vfnmadd...ps" 2 } } */ +/* { dg-final { scan-assembler-times "vfnmsub...ps" 2 } } */ +/* { dg-final { scan-assembler-times "vfmaddsub...ps" 2 } } */ +/* { dg-final { scan-assembler-times "vfmsubadd...ps" 2 } } */ +/* { dg-final { scan-assembler-times "vfmadd\[^s\]..pd" 2 } } */ +/* { dg-final { scan-assembler-times "vfmsub\[^s\]..pd" 2 } } */ +/* { dg-final { scan-assembler-times "vfnmadd...pd" 2 } } */ +/* { dg-final { scan-assembler-times "vfnmsub...pd" 2 } } */ +/* { dg-final { scan-assembler-times "vfmaddsub...pd" 2 } } */ +/* { dg-final { scan-assembler-times "vfmsubadd...pd" 2 } } */ +/* { dg-final { scan-assembler-times "vfmadd\[^s\]..ss" 1 } } */ +/* { dg-final { scan-assembler-times "vfmsub\[^s\]..ss" 1 } } */ +/* { dg-final { scan-assembler-times "vfnmadd...ss" 1 } } */ +/* { dg-final { scan-assembler-times "vfnmsub...ss" 1 } } */ +/* { dg-final { scan-assembler-times "vfmadd\[^s\]..sd" 1 } } */ +/* { dg-final { scan-assembler-times "vfmsub\[^s\]..sd" 1 } } */ +/* { dg-final { scan-assembler-times "vfnmadd...sd" 1 } } */ +/* { dg-final { scan-assembler-times "vfnmsub...sd" 1 } } */ diff --git a/gcc/testsuite/gcc.target/i386/fma-fmaddXX.c b/gcc/testsuite/gcc.target/i386/fma-fmaddXX.c new file mode 100644 index 00000000000..43ef9e8071f --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-fmaddXX.c @@ -0,0 +1,102 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + +void +check_mm_fmadd_pd (__m128d __A, __m128d __B, __m128d __C) +{ + union128d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[2]; + int i; + e.x = _mm_fmadd_pd (__A, __B, __C); + for (i = 0; i < 2; i++) + { + d[i] = a.a[i] * b.a[i] + c.a[i]; + } + + if (check_union128d (e, d)) + abort (); +} + +void +check_mm_fmadd_ps (__m128 __A, __m128 __B, __m128 __C) +{ + union128 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[4]; + int i; + e.x = _mm_fmadd_ps (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = a.a[i] * b.a[i] + c.a[i]; + } + if (check_union128 (e, d)) + abort (); +} + +void +check_mm_fmadd_sd (__m128d __A, __m128d __B, __m128d __C) +{ + union128d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[2]; + int i; + e.x = _mm_fmadd_sd (__A, __B, __C); + for (i = 1; i < 2; i++) + { + d[i] = a.a[i]; + } + d[0] = a.a[0] * b.a[0] + c.a[0]; + if (check_union128d (e, d)) + abort (); +} + +void +check_mm_fmadd_ss (__m128 __A, __m128 __B, __m128 __C) +{ + union128 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[4]; + int i; + e.x = _mm_fmadd_ss (__A, __B, __C); + for (i = 1; i < 4; i++) + { + d[i] = a.a[i]; + } + d[0] = a.a[0] * b.a[0] + c.a[0]; + if (check_union128 (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union128 a[3]; + union128d b[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 4; j++) + a[i].a[j] = i * j + 3.5; + for (j = 0; j < 2; j++) + b[i].a[j] = i * j + 3.5; + } + check_mm_fmadd_pd (b[0].x, b[1].x, b[2].x); + check_mm_fmadd_sd (b[0].x, b[1].x, b[2].x); + check_mm_fmadd_ps (a[0].x, a[1].x, a[2].x); + check_mm_fmadd_ss (a[0].x, a[1].x, a[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-fmaddsubXX.c b/gcc/testsuite/gcc.target/i386/fma-fmaddsubXX.c new file mode 100644 index 00000000000..89c816392f3 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-fmaddsubXX.c @@ -0,0 +1,61 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + +void +check_mm_fmaddsub_ps (__m128 __A, __m128 __B, __m128 __C) +{ + union128 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[4]; + int i; + e.x = _mm_fmaddsub_ps (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = a.a[i] * b.a[i] + (i % 2 == 1 ? c.a[i] : -c.a[i]); + } + if (check_union128 (e, d)) + abort (); +} + +void +check_mm_fmaddsub_pd (__m128d __A, __m128d __B, __m128d __C) +{ + union128d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[2]; + int i; + e.x = _mm_fmaddsub_pd (__A, __B, __C); + for (i = 0; i < 2; i++) + { + d[i] = a.a[i] * b.a[i] + (i % 2 == 1 ? c.a[i] : -c.a[i]); + } + if (check_union128d (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union128 a[3]; + union128d b[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 4; j++) + a[i].a[j] = i * j + 3.5; + for (j = 0; j < 2; j++) + b[i].a[j] = i * j + 3.5; + } + check_mm_fmaddsub_pd (b[0].x, b[1].x, b[2].x); + check_mm_fmaddsub_ps (a[0].x, a[1].x, a[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-fmsubXX.c b/gcc/testsuite/gcc.target/i386/fma-fmsubXX.c new file mode 100644 index 00000000000..3d92d4b25a6 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-fmsubXX.c @@ -0,0 +1,101 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + +void +check_mm_fmsub_pd (__m128d __A, __m128d __B, __m128d __C) +{ + union128d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[2]; + int i; + e.x = _mm_fmsub_pd (__A, __B, __C); + for (i = 0; i < 2; i++) + { + d[i] = a.a[i] * b.a[i] - c.a[i]; + } + if (check_union128d (e, d)) + abort (); +} + +void +check_mm_fmsub_ps (__m128 __A, __m128 __B, __m128 __C) +{ + union128 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[4]; + int i; + e.x = _mm_fmsub_ps (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = a.a[i] * b.a[i] - c.a[i]; + } + if (check_union128 (e, d)) + abort (); +} + +void +check_mm_fmsub_sd (__m128d __A, __m128d __B, __m128d __C) +{ + union128d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[2]; + int i; + e.x = _mm_fmsub_sd (__A, __B, __C); + for (i = 1; i < 2; i++) + { + d[i] = a.a[i]; + } + d[0] = a.a[0] * b.a[0] - c.a[0]; + if (check_union128d (e, d)) + abort (); +} + +void +check_mm_fmsub_ss (__m128 __A, __m128 __B, __m128 __C) +{ + union128 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[4]; + int i; + e.x = _mm_fmsub_ss (__A, __B, __C); + for (i = 1; i < 4; i++) + { + d[i] = a.a[i]; + } + d[0] = a.a[0] * b.a[0] - c.a[0]; + if (check_union128 (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union128 a[3]; + union128d b[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 4; j++) + a[i].a[j] = i * j + 3.5; + for (j = 0; j < 2; j++) + b[i].a[j] = i * j + 3.5; + } + check_mm_fmsub_pd (b[0].x, b[1].x, b[2].x); + check_mm_fmsub_sd (b[0].x, b[1].x, b[2].x); + check_mm_fmsub_ps (a[0].x, a[1].x, a[2].x); + check_mm_fmsub_ss (a[0].x, a[1].x, a[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-fmsubaddXX.c b/gcc/testsuite/gcc.target/i386/fma-fmsubaddXX.c new file mode 100644 index 00000000000..b03f875319d --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-fmsubaddXX.c @@ -0,0 +1,61 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + +void +check_mm_fmsubadd_ps (__m128 __A, __m128 __B, __m128 __C) +{ + union128 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[4]; + int i; + e.x = _mm_fmsubadd_ps (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = a.a[i] * b.a[i] + (i % 2 == 1 ? -c.a[i] : c.a[i]); + } + if (check_union128 (e, d)) + abort (); +} + +void +check_mm_fmsubadd_pd (__m128d __A, __m128d __B, __m128d __C) +{ + union128d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[2]; + int i; + e.x = _mm_fmsubadd_pd (__A, __B, __C); + for (i = 0; i < 2; i++) + { + d[i] = a.a[i] * b.a[i] + (i % 2 == 1 ? -c.a[i] : c.a[i]); + } + if (check_union128d (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union128 a[3]; + union128d b[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 4; j++) + a[i].a[j] = i * j + 3.5; + for (j = 0; j < 2; j++) + b[i].a[j] = i * j + 3.5; + } + check_mm_fmsubadd_pd (b[0].x, b[1].x, b[2].x); + check_mm_fmsubadd_ps (a[0].x, a[1].x, a[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-fnmaddXX.c b/gcc/testsuite/gcc.target/i386/fma-fnmaddXX.c new file mode 100644 index 00000000000..f23a6c5e48a --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-fnmaddXX.c @@ -0,0 +1,101 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + +void +check_mm_fnmadd_ps (__m128 __A, __m128 __B, __m128 __C) +{ + union128 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[4]; + int i; + e.x = _mm_fnmadd_ps (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = -a.a[i] * b.a[i] + c.a[i]; + } + if (check_union128 (e, d)) + abort (); +} + +void +check_mm_fnmadd_pd (__m128d __A, __m128d __B, __m128d __C) +{ + union128d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[2]; + int i; + e.x = _mm_fnmadd_pd (__A, __B, __C); + for (i = 0; i < 2; i++) + { + d[i] = -a.a[i] * b.a[i] + c.a[i]; + } + if (check_union128d (e, d)) + abort (); +} + +void +check_mm_fnmadd_sd (__m128d __A, __m128d __B, __m128d __C) +{ + union128d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[2]; + int i; + e.x = _mm_fnmadd_sd (__A, __B, __C); + for (i = 1; i < 2; i++) + { + d[i] = a.a[i]; + } + d[0] = -a.a[0] * b.a[0] + c.a[0]; + if (check_union128d (e, d)) + abort (); +} + +void +check_mm_fnmadd_ss (__m128 __A, __m128 __B, __m128 __C) +{ + union128 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[4]; + int i; + e.x = _mm_fnmadd_ss (__A, __B, __C); + for (i = 1; i < 4; i++) + { + d[i] = a.a[i]; + } + d[0] = -a.a[0] * b.a[0] + c.a[0]; + if (check_union128 (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union128 a[3]; + union128d b[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 4; j++) + a[i].a[j] = i * j + 3.5; + for (j = 0; j < 2; j++) + b[i].a[j] = i * j + 3.5; + } + check_mm_fnmadd_pd (b[0].x, b[1].x, b[2].x); + check_mm_fnmadd_sd (b[0].x, b[1].x, b[2].x); + check_mm_fnmadd_ps (a[0].x, a[1].x, a[2].x); + check_mm_fnmadd_ss (a[0].x, a[1].x, a[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/fma-fnmsubXX.c b/gcc/testsuite/gcc.target/i386/fma-fnmsubXX.c new file mode 100644 index 00000000000..d17c7f2ed1a --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/fma-fnmsubXX.c @@ -0,0 +1,101 @@ +/* { dg-do run } */ +/* { dg-require-effective-target fma } */ +/* { dg-options "-O2 -mfma" } */ + +#include "fma-check.h" + +#include <x86intrin.h> +#include "m256-check.h" + +void +check_mm_fnmsub_sd (__m128d __A, __m128d __B, __m128d __C) +{ + union128d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[2]; + int i; + e.x = _mm_fnmsub_sd (__A, __B, __C); + for (i = 1; i < 2; i++) + { + d[i] = a.a[i]; + } + d[0] = -a.a[0] * b.a[0] - c.a[0]; + if (check_union128d (e, d)) + abort (); +} + +void +check_mm_fnmsub_ss (__m128 __A, __m128 __B, __m128 __C) +{ + union128 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[4]; + int i; + e.x = _mm_fnmsub_ss (__A, __B, __C); + for (i = 1; i < 4; i++) + { + d[i] = a.a[i]; + } + d[0] = -a.a[0] * b.a[0] - c.a[0]; + if (check_union128 (e, d)) + abort (); +} + +void +check_mm_fnmsub_ps (__m128 __A, __m128 __B, __m128 __C) +{ + union128 a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + float d[4]; + int i; + e.x = _mm_fnmsub_ps (__A, __B, __C); + for (i = 0; i < 4; i++) + { + d[i] = -a.a[i] * b.a[i] - c.a[i]; + } + if (check_union128 (e, d)) + abort (); +} + +void +check_mm_fnmsub_pd (__m128d __A, __m128d __B, __m128d __C) +{ + union128d a, b, c, e; + a.x = __A; + b.x = __B; + c.x = __C; + double d[2]; + int i; + e.x = _mm_fnmsub_pd (__A, __B, __C); + for (i = 0; i < 2; i++) + { + d[i] = -a.a[i] * b.a[i] - c.a[i]; + } + if (check_union128d (e, d)) + abort (); +} + +static void +fma_test (void) +{ + union128 a[3]; + union128d b[3]; + int i, j; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 4; j++) + a[i].a[j] = i * j + 3.5; + for (j = 0; j < 2; j++) + b[i].a[j] = i * j + 3.5; + } + check_mm_fnmsub_pd (b[0].x, b[1].x, b[2].x); + check_mm_fnmsub_sd (b[0].x, b[1].x, b[2].x); + check_mm_fnmsub_ps (a[0].x, a[1].x, a[2].x); + check_mm_fnmsub_ss (a[0].x, a[1].x, a[2].x); +} diff --git a/gcc/testsuite/gcc.target/i386/i386.exp b/gcc/testsuite/gcc.target/i386/i386.exp index 6517d45bfdd..75bea9be806 100644 --- a/gcc/testsuite/gcc.target/i386/i386.exp +++ b/gcc/testsuite/gcc.target/i386/i386.exp @@ -172,6 +172,20 @@ proc check_effective_target_fma4 { } { } "-O2 -mfma4" ] } +# Return 1 if fma instructions can be compiled. +proc check_effective_target_fma { } { + return [check_no_compiler_messages fma object { + typedef float __m128 __attribute__ ((__vector_size__ (16))); + typedef float __v4sf __attribute__ ((__vector_size__ (16))); + __m128 _mm_macc_ps(__m128 __A, __m128 __B, __m128 __C) + { + return (__m128) __builtin_ia32_vfmaddps ((__v4sf)__A, + (__v4sf)__B, + (__v4sf)__C); + } + } "-O2 -mfma" ] +} + # Return 1 if xop instructions can be compiled. proc check_effective_target_xop { } { return [check_no_compiler_messages xop object { diff --git a/gcc/testsuite/gcc.target/i386/sse-12.c b/gcc/testsuite/gcc.target/i386/sse-12.c index 9f3713c6808..66a36c68cb6 100644 --- a/gcc/testsuite/gcc.target/i386/sse-12.c +++ b/gcc/testsuite/gcc.target/i386/sse-12.c @@ -3,7 +3,7 @@ popcntintrin.h and mm_malloc.h are usable with -O -std=c89 -pedantic-errors. */ /* { dg-do compile } */ -/* { dg-options "-O -std=c89 -pedantic-errors -march=k8 -msse4a -m3dnow -mavx -mavx2 -mfma4 -mxop -maes -mpclmul -mpopcnt -mabm -mlzcnt -mbmi -mbmi2 -mtbm -mlwp -mfsgsbase -mrdrnd -mf16c" } */ +/* { dg-options "-O -std=c89 -pedantic-errors -march=k8 -msse4a -m3dnow -mavx -mavx2 -mfma4 -mxop -maes -mpclmul -mpopcnt -mabm -mlzcnt -mbmi -mbmi2 -mtbm -mlwp -mfsgsbase -mrdrnd -mf16c -mfma" } */ #include <x86intrin.h> diff --git a/gcc/testsuite/gcc.target/i386/sse-13.c b/gcc/testsuite/gcc.target/i386/sse-13.c index 134905d54fe..4bc0a2ef0eb 100644 --- a/gcc/testsuite/gcc.target/i386/sse-13.c +++ b/gcc/testsuite/gcc.target/i386/sse-13.c @@ -1,13 +1,13 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -Werror-implicit-function-declaration -march=k8 -msse4a -m3dnow -mavx -mavx2 -mfma4 -mxop -maes -mpclmul -mpopcnt -mabm -mlzcnt -mbmi -mbmi2 -mtbm -mlwp -mfsgsbase -mrdrnd -mf16c" } */ +/* { dg-options "-O2 -Werror-implicit-function-declaration -march=k8 -msse4a -m3dnow -mavx -mavx2 -mfma4 -mxop -maes -mpclmul -mpopcnt -mabm -mlzcnt -mbmi -mbmi2 -mtbm -mlwp -mfsgsbase -mrdrnd -mf16c -mfma" } */ #include <mm_malloc.h> /* Test that the intrinsics compile with optimization. All of them are defined as inline functions in {,x,e,p,t,s,w,a,b,i}mmintrin.h, mm3dnow.h, fma4intrin.h, xopintrin.h, abmintrin.h, bmiintrin.h, - tbmintrin.h, lwpintrin.h, popcntintrin.h and mm_malloc.h that - reference the proper builtin functions. + tbmintrin.h, lwpintrin.h, popcntintrin.h, fmaintrin.h and mm_malloc.h + that reference the proper builtin functions. Defining away "extern" and "__inline" results in all of them being compiled as proper functions. */ diff --git a/gcc/testsuite/gcc.target/i386/sse-14.c b/gcc/testsuite/gcc.target/i386/sse-14.c index c1f10f1648e..6451166ca12 100644 --- a/gcc/testsuite/gcc.target/i386/sse-14.c +++ b/gcc/testsuite/gcc.target/i386/sse-14.c @@ -1,12 +1,13 @@ /* { dg-do compile } */ -/* { dg-options "-O0 -Werror-implicit-function-declaration -march=k8 -msse4a -m3dnow -mavx -mavx2 -mfma4 -mxop -maes -mpclmul -mpopcnt -mabm -mlzcnt -mbmi -mbmi2 -mtbm -mlwp -mfsgsbase -mrdrnd -mf16c" } */ +/* { dg-options "-O0 -Werror-implicit-function-declaration -march=k8 -msse4a -m3dnow -mavx -mavx2 -mfma4 -mxop -maes -mpclmul -mpopcnt -mabm -mlzcnt -mbmi -mbmi2 -mtbm -mlwp -mfsgsbase -mrdrnd -mf16c -mfma" } */ #include <mm_malloc.h> /* Test that the intrinsics compile without optimization. All of them are defined as inline functions in {,x,e,p,t,s,w,a,b,i}mmintrin.h, mm3dnow.h, - fma4intrin.h, xopintrin.h, abmintrin.h, bmiintrin.h, tbmintrin.h, - lwpintrin.h and mm_malloc.h that reference the proper builtin functions. + fma4intrin.h, xopintrin.h, abmintrin.h, bmiintrin.h, tbmintrin.h, + lwpintrin.h, fmaintrin.h and mm_malloc.h that reference the proper + builtin functions. Defining away "extern" and "__inline" results in all of them being compiled as proper functions. */ diff --git a/gcc/testsuite/gcc.target/i386/sse-22.c b/gcc/testsuite/gcc.target/i386/sse-22.c index 89ea7b3e0da..9ccb92d1b62 100644 --- a/gcc/testsuite/gcc.target/i386/sse-22.c +++ b/gcc/testsuite/gcc.target/i386/sse-22.c @@ -7,8 +7,8 @@ /* Test that the intrinsics compile with optimization. All of them are defined as inline functions in {,x,e,p,t,s,w,a,b,i}mmintrin.h, mm3dnow.h, fma4intrin.h, xopintrin.h, abmintrin.h, bmiintrin.h, - tbmintrin.h, lwpintrin.h, popcntintrin.h and mm_malloc.h that - reference the proper builtin functions. + tbmintrin.h, lwpintrin.h, popcntintrin.h, fmaintrin.h and mm_malloc.h + that reference the proper builtin functions. Defining away "extern" and "__inline" results in all of them being compiled as proper functions. */ @@ -255,9 +255,9 @@ test_2 (_mm_clmulepi64_si128, __m128i, __m128i, __m128i, 1) #endif #include <popcntintrin.h> -/* x86intrin.h (FMA4/XOP/LWP/BMI/BMI2/TBM/LZCNT). */ +/* x86intrin.h (FMA4/XOP/LWP/BMI/BMI2/TBM/LZCNT/FMA). */ #ifdef DIFFERENT_PRAGMAS -#pragma GCC target ("fma4,xop,lwp,bmi,bmi2,tbm,lzcnt") +#pragma GCC target ("fma4,xop,lwp,bmi,bmi2,tbm,lzcnt,fma") #endif #include <x86intrin.h> /* xopintrin.h */ diff --git a/gcc/testsuite/gcc.target/i386/sse-23.c b/gcc/testsuite/gcc.target/i386/sse-23.c index ef2471c7133..462f8c9acd2 100644 --- a/gcc/testsuite/gcc.target/i386/sse-23.c +++ b/gcc/testsuite/gcc.target/i386/sse-23.c @@ -6,8 +6,8 @@ /* Test that the intrinsics compile with optimization. All of them are defined as inline functions in {,x,e,p,t,s,w,a,b,i}mmintrin.h, mm3dnow.h, fma4intrin.h, xopintrin.h, abmintrin.h, bmiintrin.h, - tbmintrin.h, lwpintrin.h, popcntintrin.h and mm_malloc.h that - reference the proper builtin functions. + tbmintrin.h, lwpintrin.h, popcntintrin.h, fmaintrin.h and mm_malloc.h + that reference the proper builtin functions. Defining away "extern" and "__inline" results in all of them being compiled as proper functions. */ @@ -180,7 +180,7 @@ #define __builtin_ia32_gatherdiv4si(X, Y, Z, K, M) __builtin_ia32_gatherdiv4si(X, Y, Z, K, 1) #define __builtin_ia32_gatherdiv4si256(X, Y, Z, K, M) __builtin_ia32_gatherdiv4si256(X, Y, Z, K, 1) -#pragma GCC target ("sse4a,3dnow,avx,avx2,fma4,xop,aes,pclmul,popcnt,abm,lzcnt,bmi,bmi2,tbm,lwp,fsgsbase,rdrnd,f16c") +#pragma GCC target ("sse4a,3dnow,avx,avx2,fma4,xop,aes,pclmul,popcnt,abm,lzcnt,bmi,bmi2,tbm,lwp,fsgsbase,rdrnd,f16c,fma") #include <wmmintrin.h> #include <smmintrin.h> #include <mm3dnow.h> diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_2.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_2.f90 new file mode 100644 index 00000000000..8e48b226062 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_2.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! PR 45170 +! A variation of a theme for deferred type parameters. The +! substring reference in the source= portion of the allocate +! was not probably resolved. Testcase is a modified version +! of a program due to Hans-Werner Boschmann <boschmann at tp1 +! dot physik dot uni-siegen dot de> +! +program helloworld + character(:),allocatable::string + real::rnd + call hello(5, string) + if (string /= 'hello' .or. len(string) /= 5) call abort +contains + subroutine hello (n,string) + character(:),allocatable,intent(out)::string + integer,intent(in)::n + character(20)::helloworld="hello world" + allocate(string, source=helloworld(:n)) + end subroutine hello +end program helloworld diff --git a/gcc/testsuite/gfortran.dg/common_14.f90 b/gcc/testsuite/gfortran.dg/common_14.f90 new file mode 100644 index 00000000000..aced168c655 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/common_14.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/45044 +! +! Named common blocks need to be all of the same size +! check that the compiler warns for those. + +module m + common /xx/ a +end module m + +subroutine two() +integer :: a, b, c +real(8) :: y +common /xx/ a, b, c, y ! { dg-warning "Named COMMON block 'xx' at \\(1\\) shall be of the same size as elsewhere \\(24 vs 4 bytes" } +end + + +subroutine one() +integer :: a, b +common /xx/ a, b ! { dg-warning "Named COMMON block 'xx' at \\(1\\) shall be of the same size as elsewhere \\(8 vs 24 bytes" } +end + +call two() +end + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/common_resize_1.f b/gcc/testsuite/gfortran.dg/common_resize_1.f index a94c1bc0c6a..ecf692d2d48 100644 --- a/gcc/testsuite/gfortran.dg/common_resize_1.f +++ b/gcc/testsuite/gfortran.dg/common_resize_1.f @@ -13,13 +13,13 @@ c c
c unpack connection data
c
- common/aux32/kka(lnv),kkb(lnv),kkc(lnv),
+ common/aux32/kka(lnv),kkb(lnv),kkc(lnv), ! { dg-warning "shall be of the same size as elsewhere" }
1 kk1(lnv),kk2(lnv),kk3(lnv),dxy(lnv),
2 dyx(lnv),dyz(lnv),dzy(lnv),dzx(lnv),
3 dxz(lnv),vx17(lnv),vx28(lnv),vx35(lnv),
4 vx46(lnv),vy17(lnv),vy28(lnv),
5 vy35(lnv),vy46(lnv),vz17(lnv),vz28(lnv),vz35(lnv),vz46(lnv)
- common/aux33/ix1(lnv),ix2(lnv),ix3(lnv),ix4(lnv),ix5(lnv),
+ common/aux33/ix1(lnv),ix2(lnv),ix3(lnv),ix4(lnv),ix5(lnv), ! { dg-warning "shall be of the same size as elsewhere" }
1 ix6(lnv),ix7(lnv),ix8(lnv),mxt(lnv)
dimension ixp(nwcon,*)
c
diff --git a/gcc/testsuite/gfortran.dg/vect/pr50178.f90 b/gcc/testsuite/gfortran.dg/vect/pr50178.f90 new file mode 100644 index 00000000000..e24ce5b15f6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/vect/pr50178.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } + +module yemdyn + implicit none + integer, parameter :: jpim = selected_int_kind(9) + integer, parameter :: jprb = selected_real_kind(13,300) + real(kind=jprb) :: elx + real(kind=jprb), allocatable :: xkcoef(:) + integer(kind=jpim),allocatable :: ncpln(:), npne(:) +end module yemdyn + +subroutine suedyn + + use yemdyn + + implicit none + + integer(kind=jpim) :: jm, jn + real(kind=jprb) :: zjm, zjn, zxxx + + jn=0 + do jm=0,ncpln(jn) + zjm=real(jm,jprb) / elx + xkcoef(npne(jn)+jm) = - zxxx*(zjm**2)**0.5_jprb + end do + +end subroutine suedyn + +! { dg-final { cleanup-tree-dump "vect" } } diff --git a/gcc/testsuite/gnat.dg/specs/aggr1.ads b/gcc/testsuite/gnat.dg/specs/aggr1.ads index 6c766351374..f26f4999b49 100644 --- a/gcc/testsuite/gnat.dg/specs/aggr1.ads +++ b/gcc/testsuite/gnat.dg/specs/aggr1.ads @@ -1,4 +1,4 @@ --- { dg-do compile } +-- { dg-do compile } package aggr1 is type Buffer_Array is array (1 .. 2 ** 23) of Integer; diff --git a/gcc/testsuite/gnat.dg/specs/aggr2.ads b/gcc/testsuite/gnat.dg/specs/aggr2.ads index 8f7ea871733..00bc44f15d8 100644 --- a/gcc/testsuite/gnat.dg/specs/aggr2.ads +++ b/gcc/testsuite/gnat.dg/specs/aggr2.ads @@ -1,4 +1,4 @@ --- { dg-do compile } +-- { dg-do compile } package Aggr2 is diff --git a/gcc/testsuite/gnat.dg/specs/aggr3.ads b/gcc/testsuite/gnat.dg/specs/aggr3.ads new file mode 100644 index 00000000000..09b4466e0e5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/aggr3.ads @@ -0,0 +1,18 @@ +-- { dg-do compile } + +with Aggr3_Pkg; use Aggr3_Pkg; + +package Aggr3 is + + type Enum is (One); + + type R (D : Enum := One) is + record + case D is + when One => The_T : T; + end case; + end record; + + My_R : R := (D => One, The_T => My_T); + +end Aggr3; diff --git a/gcc/testsuite/gnat.dg/specs/aggr3_pkg.ads b/gcc/testsuite/gnat.dg/specs/aggr3_pkg.ads new file mode 100644 index 00000000000..769426edecf --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/aggr3_pkg.ads @@ -0,0 +1,9 @@ +package Aggr3_Pkg is + + type Root is abstract tagged null record; + + type T is new Root with null record; + + My_T : T; + +end Aggr3_Pkg; diff --git a/gcc/tree-cfg.c b/gcc/tree-cfg.c index bcb8ba9b742..62e2da0c12f 100644 --- a/gcc/tree-cfg.c +++ b/gcc/tree-cfg.c @@ -3668,7 +3668,8 @@ verify_gimple_assign_ternary (gimple stmt) return true; } - if (!is_gimple_val (rhs1) + if (((rhs_code == VEC_COND_EXPR || rhs_code == COND_EXPR) + ? !is_gimple_condexpr (rhs1) : !is_gimple_val (rhs1)) || !is_gimple_val (rhs2) || !is_gimple_val (rhs3)) { @@ -3711,6 +3712,19 @@ verify_gimple_assign_ternary (gimple stmt) } break; + case COND_EXPR: + case VEC_COND_EXPR: + if (!useless_type_conversion_p (lhs_type, rhs2_type) + || !useless_type_conversion_p (lhs_type, rhs3_type)) + { + error ("type mismatch in conditional expression"); + debug_generic_expr (lhs_type); + debug_generic_expr (rhs2_type); + debug_generic_expr (rhs3_type); + return true; + } + break; + case DOT_PROD_EXPR: case REALIGN_LOAD_EXPR: /* FIXME. */ @@ -3827,26 +3841,10 @@ verify_gimple_assign_single (gimple stmt) } return res; - case COND_EXPR: - if (!is_gimple_reg (lhs) - || (!is_gimple_reg (TREE_OPERAND (rhs1, 0)) - && !COMPARISON_CLASS_P (TREE_OPERAND (rhs1, 0))) - || (!is_gimple_reg (TREE_OPERAND (rhs1, 1)) - && !is_gimple_min_invariant (TREE_OPERAND (rhs1, 1))) - || (!is_gimple_reg (TREE_OPERAND (rhs1, 2)) - && !is_gimple_min_invariant (TREE_OPERAND (rhs1, 2)))) - { - error ("invalid COND_EXPR in gimple assignment"); - debug_generic_stmt (rhs1); - return true; - } - return res; - case CONSTRUCTOR: case OBJ_TYPE_REF: case ASSERT_EXPR: case WITH_SIZE_EXPR: - case VEC_COND_EXPR: /* FIXME. */ return res; diff --git a/gcc/tree-inline.c b/gcc/tree-inline.c index e9daff63cc3..741e8e4d005 100644 --- a/gcc/tree-inline.c +++ b/gcc/tree-inline.c @@ -853,43 +853,14 @@ remap_gimple_op_r (tree *tp, int *walk_subtrees, void *data) tree ptr = TREE_OPERAND (*tp, 0); tree type = remap_type (TREE_TYPE (*tp), id); tree old = *tp; - tree tem; /* We need to re-canonicalize MEM_REFs from inline substitutions that can happen when a pointer argument is an ADDR_EXPR. Recurse here manually to allow that. */ walk_tree (&ptr, remap_gimple_op_r, data, NULL); - if ((tem = maybe_fold_offset_to_reference (EXPR_LOCATION (*tp), - ptr, - TREE_OPERAND (*tp, 1), - type)) - && TREE_THIS_VOLATILE (tem) == TREE_THIS_VOLATILE (old)) - { - tree *tem_basep = &tem; - while (handled_component_p (*tem_basep)) - tem_basep = &TREE_OPERAND (*tem_basep, 0); - if (TREE_CODE (*tem_basep) == MEM_REF) - *tem_basep - = build2 (MEM_REF, TREE_TYPE (*tem_basep), - TREE_OPERAND (*tem_basep, 0), - fold_convert (TREE_TYPE (TREE_OPERAND (*tp, 1)), - TREE_OPERAND (*tem_basep, 1))); - else - *tem_basep - = build2 (MEM_REF, TREE_TYPE (*tem_basep), - build_fold_addr_expr (*tem_basep), - build_int_cst - (TREE_TYPE (TREE_OPERAND (*tp, 1)), 0)); - *tp = tem; - TREE_THIS_VOLATILE (*tem_basep) = TREE_THIS_VOLATILE (old); - TREE_THIS_NOTRAP (*tem_basep) = TREE_THIS_NOTRAP (old); - } - else - { - *tp = fold_build2 (MEM_REF, type, - ptr, TREE_OPERAND (*tp, 1)); - TREE_THIS_NOTRAP (*tp) = TREE_THIS_NOTRAP (old); - } + *tp = fold_build2 (MEM_REF, type, + ptr, TREE_OPERAND (*tp, 1)); + TREE_THIS_NOTRAP (*tp) = TREE_THIS_NOTRAP (old); TREE_THIS_VOLATILE (*tp) = TREE_THIS_VOLATILE (old); TREE_NO_WARNING (*tp) = TREE_NO_WARNING (old); *walk_subtrees = 0; diff --git a/gcc/tree-object-size.c b/gcc/tree-object-size.c index b85c9730f1d..b1767584da8 100644 --- a/gcc/tree-object-size.c +++ b/gcc/tree-object-size.c @@ -53,7 +53,7 @@ static void expr_object_size (struct object_size_info *, tree, tree); static bool merge_object_sizes (struct object_size_info *, tree, tree, unsigned HOST_WIDE_INT); static bool plus_stmt_object_size (struct object_size_info *, tree, gimple); -static bool cond_expr_object_size (struct object_size_info *, tree, tree); +static bool cond_expr_object_size (struct object_size_info *, tree, gimple); static unsigned int compute_object_sizes (void); static void init_offset_limit (void); static void check_for_plus_in_loops (struct object_size_info *, tree); @@ -827,25 +827,25 @@ plus_stmt_object_size (struct object_size_info *osi, tree var, gimple stmt) } -/* Compute object_sizes for VAR, defined to VALUE, which is +/* Compute object_sizes for VAR, defined at STMT, which is a COND_EXPR. Return true if the object size might need reexamination later. */ static bool -cond_expr_object_size (struct object_size_info *osi, tree var, tree value) +cond_expr_object_size (struct object_size_info *osi, tree var, gimple stmt) { tree then_, else_; int object_size_type = osi->object_size_type; unsigned int varno = SSA_NAME_VERSION (var); bool reexamine = false; - gcc_assert (TREE_CODE (value) == COND_EXPR); + gcc_assert (gimple_assign_rhs_code (stmt) == COND_EXPR); if (object_sizes[object_size_type][varno] == unknown[object_size_type]) return false; - then_ = COND_EXPR_THEN (value); - else_ = COND_EXPR_ELSE (value); + then_ = gimple_assign_rhs2 (stmt); + else_ = gimple_assign_rhs3 (stmt); if (TREE_CODE (then_) == SSA_NAME) reexamine |= merge_object_sizes (osi, var, then_, 0); @@ -932,14 +932,14 @@ collect_object_sizes_for (struct object_size_info *osi, tree var) || (gimple_assign_rhs_code (stmt) == ADDR_EXPR && TREE_CODE (TREE_OPERAND (rhs, 0)) == MEM_REF)) reexamine = plus_stmt_object_size (osi, var, stmt); + else if (gimple_assign_rhs_code (stmt) == COND_EXPR) + reexamine = cond_expr_object_size (osi, var, stmt); else if (gimple_assign_single_p (stmt) || gimple_assign_unary_nop_p (stmt)) { if (TREE_CODE (rhs) == SSA_NAME && POINTER_TYPE_P (TREE_TYPE (rhs))) reexamine = merge_object_sizes (osi, var, rhs, 0); - else if (TREE_CODE (rhs) == COND_EXPR) - reexamine = cond_expr_object_size (osi, var, rhs); else expr_object_size (osi, var, rhs); } @@ -956,8 +956,6 @@ collect_object_sizes_for (struct object_size_info *osi, tree var) if (TREE_CODE (arg) == SSA_NAME && POINTER_TYPE_P (TREE_TYPE (arg))) reexamine = merge_object_sizes (osi, var, arg, 0); - else if (TREE_CODE (arg) == COND_EXPR) - reexamine = cond_expr_object_size (osi, var, arg); else expr_object_size (osi, var, arg); } diff --git a/gcc/tree-scalar-evolution.c b/gcc/tree-scalar-evolution.c index 646b4f1c568..6c32923852e 100644 --- a/gcc/tree-scalar-evolution.c +++ b/gcc/tree-scalar-evolution.c @@ -1796,7 +1796,8 @@ interpret_expr (struct loop *loop, gimple at_stmt, tree expr) if (automatically_generated_chrec_p (expr)) return expr; - if (TREE_CODE (expr) == POLYNOMIAL_CHREC) + if (TREE_CODE (expr) == POLYNOMIAL_CHREC + || get_gimple_rhs_class (TREE_CODE (expr)) == GIMPLE_TERNARY_RHS) return chrec_dont_know; extract_ops_from_tree (expr, &code, &op0, &op1); diff --git a/gcc/tree-ssa-ccp.c b/gcc/tree-ssa-ccp.c index 55a504ee52d..007e17dd8b6 100644 --- a/gcc/tree-ssa-ccp.c +++ b/gcc/tree-ssa-ccp.c @@ -133,6 +133,7 @@ along with GCC; see the file COPYING3. If not see #include "diagnostic-core.h" #include "dbgcnt.h" #include "gimple-fold.h" +#include "params.h" /* Possible lattice values. */ @@ -1684,6 +1685,51 @@ evaluate_stmt (gimple stmt) return val; } +/* Detects a vla-related alloca with a constant argument. Declares fixed-size + array and return the address, if found, otherwise returns NULL_TREE. */ + +static tree +fold_builtin_alloca_for_var (gimple stmt) +{ + unsigned HOST_WIDE_INT size, threshold, n_elem; + tree lhs, arg, block, var, elem_type, array_type; + unsigned int align; + + /* Get lhs. */ + lhs = gimple_call_lhs (stmt); + if (lhs == NULL_TREE) + return NULL_TREE; + + /* Detect constant argument. */ + arg = get_constant_value (gimple_call_arg (stmt, 0)); + if (arg == NULL_TREE || TREE_CODE (arg) != INTEGER_CST + || !host_integerp (arg, 1)) + return NULL_TREE; + size = TREE_INT_CST_LOW (arg); + + /* Heuristic: don't fold large vlas. */ + threshold = (unsigned HOST_WIDE_INT)PARAM_VALUE (PARAM_LARGE_STACK_FRAME); + /* In case a vla is declared at function scope, it has the same lifetime as a + declared array, so we allow a larger size. */ + block = gimple_block (stmt); + if (!(cfun->after_inlining + && TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)) + threshold /= 10; + if (size > threshold) + return NULL_TREE; + + /* Declare array. */ + elem_type = build_nonstandard_integer_type (BITS_PER_UNIT, 1); + n_elem = size * 8 / BITS_PER_UNIT; + align = MIN (size * 8, BIGGEST_ALIGNMENT); + array_type = build_array_type_nelts (elem_type, n_elem); + var = create_tmp_var (array_type, NULL); + DECL_ALIGN (var) = align; + + /* Fold alloca to the address of the array. */ + return fold_convert (TREE_TYPE (lhs), build_fold_addr_expr (var)); +} + /* Fold the stmt at *GSI with CCP specific information that propagating and regular folding does not catch. */ @@ -1752,6 +1798,20 @@ ccp_fold_stmt (gimple_stmt_iterator *gsi) if (gimple_call_internal_p (stmt)) return false; + /* The heuristic of fold_builtin_alloca_for_var differs before and after + inlining, so we don't require the arg to be changed into a constant + for folding, but just to be constant. */ + if (gimple_call_alloca_for_var_p (stmt)) + { + tree new_rhs = fold_builtin_alloca_for_var (stmt); + bool res; + if (new_rhs == NULL_TREE) + return false; + res = update_call_from_tree (gsi, new_rhs); + gcc_assert (res); + return true; + } + /* Propagate into the call arguments. Compared to replace_uses_in this can use the argument slot types for type verification instead of the current argument type. We also can safely diff --git a/gcc/tree-ssa-forwprop.c b/gcc/tree-ssa-forwprop.c index 00121796613..89d6239836b 100644 --- a/gcc/tree-ssa-forwprop.c +++ b/gcc/tree-ssa-forwprop.c @@ -540,12 +540,9 @@ forward_propagate_into_gimple_cond (gimple stmt) /* Propagate from the ssa name definition statements of COND_EXPR in the rhs of statement STMT into the conditional if that simplifies it. - Returns zero if no statement was changed, one if there were - changes and two if cfg_cleanup needs to run. - - This must be kept in sync with forward_propagate_into_gimple_cond. */ + Returns true zero if the stmt was changed. */ -static int +static bool forward_propagate_into_cond (gimple_stmt_iterator *gsi_p) { gimple stmt = gsi_stmt (*gsi_p); @@ -560,15 +557,17 @@ forward_propagate_into_cond (gimple_stmt_iterator *gsi_p) TREE_OPERAND (cond, 1)); else if (TREE_CODE (cond) == SSA_NAME) { - tree name = cond, rhs0; + tree name = cond; gimple def_stmt = get_prop_source_stmt (name, true, NULL); if (!def_stmt || !can_propagate_from (def_stmt)) return 0; - rhs0 = gimple_assign_rhs1 (def_stmt); - tmp = combine_cond_expr_cond (stmt, NE_EXPR, boolean_type_node, rhs0, - build_int_cst (TREE_TYPE (rhs0), 0), - false); + if (TREE_CODE_CLASS (gimple_assign_rhs_code (def_stmt)) == tcc_comparison) + tmp = fold_build2_loc (gimple_location (def_stmt), + gimple_assign_rhs_code (def_stmt), + boolean_type_node, + gimple_assign_rhs1 (def_stmt), + gimple_assign_rhs2 (def_stmt)); } if (tmp) @@ -582,11 +581,16 @@ forward_propagate_into_cond (gimple_stmt_iterator *gsi_p) fprintf (dump_file, "'\n"); } - gimple_assign_set_rhs_from_tree (gsi_p, unshare_expr (tmp)); + if (integer_onep (tmp)) + gimple_assign_set_rhs_from_tree (gsi_p, gimple_assign_rhs2 (stmt)); + else if (integer_zerop (tmp)) + gimple_assign_set_rhs_from_tree (gsi_p, gimple_assign_rhs3 (stmt)); + else + gimple_assign_set_rhs1 (stmt, unshare_expr (tmp)); stmt = gsi_stmt (*gsi_p); update_stmt (stmt); - return is_gimple_min_invariant (tmp) ? 2 : 1; + return true; } return 0; @@ -1002,31 +1006,21 @@ forward_propagate_addr_expr_1 (tree name, tree def_rhs, return false; rhs2 = gimple_assign_rhs2 (use_stmt); - /* Try to optimize &x[C1] p+ C2 where C2 is a multiple of the size - of the elements in X into &x[C1 + C2/element size]. */ + /* Optimize &x[C1] p+ C2 to &x p+ C3 with C3 = C1 * element_size + C2. */ if (TREE_CODE (rhs2) == INTEGER_CST) { - tree new_rhs = maybe_fold_stmt_addition (gimple_location (use_stmt), - TREE_TYPE (def_rhs), - def_rhs, rhs2); - if (new_rhs) - { - tree type = TREE_TYPE (gimple_assign_lhs (use_stmt)); - new_rhs = unshare_expr (new_rhs); - if (!useless_type_conversion_p (type, TREE_TYPE (new_rhs))) - { - if (!is_gimple_min_invariant (new_rhs)) - new_rhs = force_gimple_operand_gsi (use_stmt_gsi, new_rhs, - true, NULL_TREE, - true, GSI_SAME_STMT); - new_rhs = fold_convert (type, new_rhs); - } - gimple_assign_set_rhs_from_tree (use_stmt_gsi, new_rhs); - use_stmt = gsi_stmt (*use_stmt_gsi); - update_stmt (use_stmt); - tidy_after_forward_propagate_addr (use_stmt); - return true; - } + tree new_rhs = build1_loc (gimple_location (use_stmt), + ADDR_EXPR, TREE_TYPE (def_rhs), + fold_build2 (MEM_REF, + TREE_TYPE (TREE_TYPE (def_rhs)), + unshare_expr (def_rhs), + fold_convert (ptr_type_node, + rhs2))); + gimple_assign_set_rhs_from_tree (use_stmt_gsi, new_rhs); + use_stmt = gsi_stmt (*use_stmt_gsi); + update_stmt (use_stmt); + tidy_after_forward_propagate_addr (use_stmt); + return true; } /* Try to optimize &x[0] p+ OFFSET where OFFSET is defined by @@ -2446,12 +2440,8 @@ ssa_forward_propagate_and_combine (void) else if (code == COND_EXPR) { /* In this case the entire COND_EXPR is in rhs1. */ - int did_something; - did_something = forward_propagate_into_cond (&gsi); + changed |= forward_propagate_into_cond (&gsi); stmt = gsi_stmt (gsi); - if (did_something == 2) - cfg_changed = true; - changed = did_something != 0; } else if (TREE_CODE_CLASS (code) == tcc_comparison) { diff --git a/gcc/tree-ssa-loop-im.c b/gcc/tree-ssa-loop-im.c index 7828c5b343b..cb527913d4f 100644 --- a/gcc/tree-ssa-loop-im.c +++ b/gcc/tree-ssa-loop-im.c @@ -1251,11 +1251,9 @@ move_computations_stmt (struct dom_walk_data *dw_data, gcc_assert (arg0 && arg1); t = build2 (gimple_cond_code (cond), boolean_type_node, gimple_cond_lhs (cond), gimple_cond_rhs (cond)); - t = build3 (COND_EXPR, TREE_TYPE (gimple_phi_result (stmt)), - t, arg0, arg1); - new_stmt = gimple_build_assign_with_ops (COND_EXPR, - gimple_phi_result (stmt), - t, NULL_TREE); + new_stmt = gimple_build_assign_with_ops3 (COND_EXPR, + gimple_phi_result (stmt), + t, arg0, arg1); SSA_NAME_DEF_STMT (gimple_phi_result (stmt)) = new_stmt; *((unsigned int *)(dw_data->global_data)) |= TODO_cleanup_cfg; } diff --git a/gcc/tree-ssa-threadedge.c b/gcc/tree-ssa-threadedge.c index a485b211e59..707c8df3ec5 100644 --- a/gcc/tree-ssa-threadedge.c +++ b/gcc/tree-ssa-threadedge.c @@ -225,24 +225,7 @@ fold_assignment_stmt (gimple stmt) switch (get_gimple_rhs_class (subcode)) { case GIMPLE_SINGLE_RHS: - { - tree rhs = gimple_assign_rhs1 (stmt); - - if (TREE_CODE (rhs) == COND_EXPR) - { - /* Sadly, we have to handle conditional assignments specially - here, because fold expects all the operands of an expression - to be folded before the expression itself is folded, but we - can't just substitute the folded condition here. */ - tree cond = fold (COND_EXPR_COND (rhs)); - if (cond == boolean_true_node) - rhs = COND_EXPR_THEN (rhs); - else if (cond == boolean_false_node) - rhs = COND_EXPR_ELSE (rhs); - } - - return fold (rhs); - } + return fold (gimple_assign_rhs1 (stmt)); case GIMPLE_UNARY_RHS: { @@ -265,6 +248,14 @@ fold_assignment_stmt (gimple stmt) tree op0 = gimple_assign_rhs1 (stmt); tree op1 = gimple_assign_rhs2 (stmt); tree op2 = gimple_assign_rhs3 (stmt); + + /* Sadly, we have to handle conditional assignments specially + here, because fold expects all the operands of an expression + to be folded before the expression itself is folded, but we + can't just substitute the folded condition here. */ + if (gimple_assign_rhs_code (stmt) == COND_EXPR) + op0 = fold (op0); + return fold_ternary (subcode, TREE_TYPE (lhs), op0, op1, op2); } diff --git a/gcc/tree-vect-loop.c b/gcc/tree-vect-loop.c index 539bcaabd97..5c0b0a1c753 100644 --- a/gcc/tree-vect-loop.c +++ b/gcc/tree-vect-loop.c @@ -2126,15 +2126,15 @@ vect_is_simple_reduction_1 (loop_vec_info loop_info, gimple phi, return NULL; } - op3 = TREE_OPERAND (gimple_assign_rhs1 (def_stmt), 0); + op3 = gimple_assign_rhs1 (def_stmt); if (COMPARISON_CLASS_P (op3)) { op4 = TREE_OPERAND (op3, 1); op3 = TREE_OPERAND (op3, 0); } - op1 = TREE_OPERAND (gimple_assign_rhs1 (def_stmt), 1); - op2 = TREE_OPERAND (gimple_assign_rhs1 (def_stmt), 2); + op1 = gimple_assign_rhs2 (def_stmt); + op2 = gimple_assign_rhs3 (def_stmt); if (TREE_CODE (op1) != SSA_NAME && TREE_CODE (op2) != SSA_NAME) { diff --git a/gcc/tree-vect-stmts.c b/gcc/tree-vect-stmts.c index 3b5fa01f8fb..2a1318195e5 100644 --- a/gcc/tree-vect-stmts.c +++ b/gcc/tree-vect-stmts.c @@ -4740,7 +4740,6 @@ vectorizable_condition (gimple stmt, gimple_stmt_iterator *gsi, { tree scalar_dest = NULL_TREE; tree vec_dest = NULL_TREE; - tree op = NULL_TREE; tree cond_expr, then_clause, else_clause; stmt_vec_info stmt_info = vinfo_for_stmt (stmt); tree vectype = STMT_VINFO_VECTYPE (stmt_info); @@ -4794,11 +4793,9 @@ vectorizable_condition (gimple stmt, gimple_stmt_iterator *gsi, if (code != COND_EXPR) return false; - gcc_assert (gimple_assign_single_p (stmt)); - op = gimple_assign_rhs1 (stmt); - cond_expr = TREE_OPERAND (op, 0); - then_clause = TREE_OPERAND (op, 1); - else_clause = TREE_OPERAND (op, 2); + cond_expr = gimple_assign_rhs1 (stmt); + then_clause = gimple_assign_rhs2 (stmt); + else_clause = gimple_assign_rhs3 (stmt); if (!vect_is_simple_cond (cond_expr, loop_vinfo)) return false; @@ -4839,7 +4836,8 @@ vectorizable_condition (gimple stmt, gimple_stmt_iterator *gsi, if (!vec_stmt) { STMT_VINFO_TYPE (stmt_info) = condition_vec_info_type; - return expand_vec_cond_expr_p (TREE_TYPE (op), vec_mode); + return expand_vec_cond_expr_p (TREE_TYPE (gimple_assign_lhs (stmt)), + vec_mode); } /* Transform */ diff --git a/gcc/tree-vrp.c b/gcc/tree-vrp.c index df19cbbfdd1..56fc5a20b2b 100644 --- a/gcc/tree-vrp.c +++ b/gcc/tree-vrp.c @@ -3190,11 +3190,11 @@ extract_range_from_unary_expr (value_range_t *vr, enum tree_code code, } -/* Extract range information from a conditional expression EXPR based on +/* Extract range information from a conditional expression STMT based on the ranges of each of its operands and the expression code. */ static void -extract_range_from_cond_expr (value_range_t *vr, tree expr) +extract_range_from_cond_expr (value_range_t *vr, gimple stmt) { tree op0, op1; value_range_t vr0 = { VR_UNDEFINED, NULL_TREE, NULL_TREE, NULL }; @@ -3202,7 +3202,7 @@ extract_range_from_cond_expr (value_range_t *vr, tree expr) /* Get value ranges for each operand. For constant operands, create a new value range with the operand to simplify processing. */ - op0 = COND_EXPR_THEN (expr); + op0 = gimple_assign_rhs2 (stmt); if (TREE_CODE (op0) == SSA_NAME) vr0 = *(get_value_range (op0)); else if (is_gimple_min_invariant (op0)) @@ -3210,7 +3210,7 @@ extract_range_from_cond_expr (value_range_t *vr, tree expr) else set_value_range_to_varying (&vr0); - op1 = COND_EXPR_ELSE (expr); + op1 = gimple_assign_rhs3 (stmt); if (TREE_CODE (op1) == SSA_NAME) vr1 = *(get_value_range (op1)); else if (is_gimple_min_invariant (op1)) @@ -3302,7 +3302,7 @@ extract_range_from_assignment (value_range_t *vr, gimple stmt) gimple_expr_type (stmt), gimple_assign_rhs1 (stmt)); else if (code == COND_EXPR) - extract_range_from_cond_expr (vr, gimple_assign_rhs1 (stmt)); + extract_range_from_cond_expr (vr, stmt); else if (TREE_CODE_CLASS (code) == tcc_comparison) extract_range_from_comparison (vr, gimple_assign_rhs_code (stmt), gimple_expr_type (stmt), |