diff options
Diffstat (limited to 'gcc')
375 files changed, 9548 insertions, 3603 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index ffd2855a31b..4fccde3b980 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,509 @@ +2011-09-07 Eric Botcazou <ebotcazou@adacore.com> + Iain Sandoe <iains@gcc.gnu.org> + + * config/rs6000/rs6000.c (compute_save_world_info): Test + cfun->has_nonlocal_label to determine if the out-of-line save + world call may be used. + +2011-09-07 Nick Clifton <nickc@redhat.com> + + * config/mn10300/mn10300.c (mn10300_insert_setlb_lcc): Set the jump + label on the parallel part of the insn. + +2011-09-07 Jakub Jelinek <jakub@redhat.com> + + PR debug/50191 + * dwarf2out.c (mem_loc_descriptor) <case MEM>: Try + avoid_constant_pool_reference first instead of last. + +2011-09-06 Michael Meissner <meissner@linux.vnet.ibm.com> + + * doc/configfiles.texi (Configuration Files): Update documentation + about tm_p.h and remove FIXME comment. + +2011-09-06 Uros Bizjak <ubizjak@gmail.com> + + * config/i386/i386.c (ix86_function_value_regno_p): Use AX_REG. + (function_value_32): Do not check TARGET_MMX, TARGET_SSE or TARGET_AVX. + +2011-09-06 Iain Sandoe <iains@gcc.gnu.org> + + * config/darwin10.h Remove duplicate LIB_SPEC. + +2011-09-06 Enkovich Ilya <ilya.enkovich@intel.com> + + PR middle-end/44382 + * target.def (reassociation_width): New hook. + + * doc/tm.texi.in (reassociation_width): Likewise. + + * doc/tm.texi (reassociation_width): Likewise. + + * doc/invoke.texi (tree-reassoc-width): New param documented. + + * hooks.h (hook_int_uint_mode_1): New default hook. + + * hooks.c (hook_int_uint_mode_1): Likewise. + + * config/i386/i386.h (ix86_tune_indices): Add + X86_TUNE_REASSOC_INT_TO_PARALLEL and + X86_TUNE_REASSOC_FP_TO_PARALLEL. + + (TARGET_REASSOC_INT_TO_PARALLEL): New. + (TARGET_REASSOC_FP_TO_PARALLEL): Likewise. + + * config/i386/i386.c (initial_ix86_tune_features): Add + X86_TUNE_REASSOC_INT_TO_PARALLEL and + X86_TUNE_REASSOC_FP_TO_PARALLEL. + + (ix86_reassociation_width) implementation of + new hook for i386 target. + + * params.def (PARAM_TREE_REASSOC_WIDTH): New param added. + + * tree-ssa-reassoc.c (get_required_cycles): New function. + (get_reassociation_width): Likewise. + (swap_ops_for_binary_stmt): Likewise. + (rewrite_expr_tree_parallel): Likewise. + + (rewrite_expr_tree): Refactored. Part of code moved into + swap_ops_for_binary_stmt. + + (reassociate_bb): Now checks reassociation width to be used + and call rewrite_expr_tree_parallel instead of rewrite_expr_tree + if needed. + +2011-09-06 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/47025 + * tree-ssa-alias.c (ref_maybe_used_by_call_p_1): BUILT_IN_VA_END + uses nothing. + (call_may_clobber_ref_p_1): BUILT_IN_VA_END is a barrier like + BUILT_IN_FREE. + (stmt_kills_ref_p_1): BUILT_IN_VA_END kills what its argument + definitely points to. + * tree-ssa-structalias.c (find_func_aliases_for_builtin_call): + BUILT_IN_VA_START doesn't let its va_list argument escape. + * tree-ssa-dce.c (propagate_necessity): BUILT_IN_VA_END does + not make any previous stores necessary. + +2011-09-06 Martin Jambor <mjambor@suse.cz> + + * ipa-inline.h (struct inline_summary): Move versionable flag... + * cgraph.h (struct cgraph_local_info): ...here + * ipa-cp.c (determine_versionability): Use the new versionable flag. + (determine_versionability): Likewise. + (ipcp_versionable_function_p): Likewise. + (ipcp_generate_summary): Likewise. + * ipa-inline-analysis.c (dump_inline_summary): Do not dump the + versionable flag. + (compute_inline_parameters): Do not clear the versionable flag. + (inline_read_section): Do not stream the versionable flag. + (inline_write_summary): Likewise. + * lto-cgraph.c (lto_output_node): Stream the versionable flag. + (input_overwrite_node): Likewise. + +2011-09-06 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/48149 + * tree-ssa-sccvn.c (vn_get_expr_for): Simplify. Fix tuplification bug. + (vn_valueize): Move earlier. + (valueize_expr): Use vn_valueize. + (simplify_binary_expression): Simplify, also combine COMPLEX_EXPR + operands. + (simplify_unary_expression): Simplify. + +2011-09-06 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/48317 + * tree-ssa-sccvn.h (struct vn_nary_op_s): Make op a true + trailing array. + (sizeof_vn_nary_op): New inline function. + (vn_nary_op_lookup_pieces): Adjust. + (vn_nary_op_insert_pieces): Likewise. + * tree-ssa-sccvn.c (vn_nary_op_eq): Also compare the length. + (init_vn_nary_op_from_pieces): Adjust signature. Deal with + any number of operands. + (vn_nary_length_from_stmt): New function. + (init_vn_nary_op_from_stmt): Adjust for CONSTRUCTOR handling. + (vn_nary_op_lookup_pieces): Adjust signature and allocate properly + sized temporary. + (vn_nary_op_lookup): Likewise. + (vn_nary_op_lookup_stmt): Likewise. + (vn_nary_op_insert_into): Likewise. + (vn_nary_op_insert_stmt): Likewise. + (visit_use): Handle CONSTRUCTOR as nary. + * tree-ssa-pre.c (phi_translate_1): Adjust. + (create_expression_by_pieces): Likewise. + (compute_avail): Likewise. + +2011-09-06 Ira Rosen <ira.rosen@linaro.org> + + * config/arm/arm.c (arm_preferred_simd_mode): Check + TARGET_NEON_VECTORIZE_DOUBLE instead of + TARGET_NEON_VECTORIZE_QUAD. + (arm_autovectorize_vector_sizes): Likewise. + * config/arm/arm.opt (mvectorize-with-neon-quad): Make inverse + mask of mvectorize-with-neon-double. Add RejectNegative. + (mvectorize-with-neon-double): New. + +2011-09-06 Richard Guenther <rguenther@suse.de> + + * tree-ssa-sccvn.c (visit_use): CSE stmt pieces and simplify + matching. + +2011-09-06 Tom de Vries <tom@codesourcery.com> + + * recog.c (asm_labels_ok): New function. + (check_asm_operands): Use asm_labels_ok. + +2011-09-05 Richard Sandiford <rdsandiford@googlemail.com> + + PR target/49606 + * config/mips/mips.h (ABI_HAS_64BIT_SYMBOLS): Check Pmode. + (PMODE_INSN): New macro. + * config/mips/mips.c (gen_load_const_gp): Use PMODE_INSN. + (mips_got_load, mips_expand_synci_loop): Likewise. + (mips_save_gp_to_cprestore_slot): Handle SImode and DImode + cprestore patterns. + (mips_emit_loadgp): Use PMODE_INSN. Handle SImode and DImode + copygp_mips16 patterns. + (mips_expand_prologue): Handle SImode and DImode potential_cprestore + and use_cprestore patterns. + (mips_override_options): Check for incompatible -mabi and -mlong + combinations. + * config/mips/mips.md (unspec_got<mode>): Rename to... + (unspec_got_<mode>): ...this. + (copygp_mips16): Use the Pmode iterator. + (potential_cprestore, cprestore, use_cprestore): Likewise. + (clear_cache, indirect_jump): Use PMODE_INSN. + (indirect_jump<mode>): Rename to... + (indirect_jump_<mode>): ...this. + (tablejump): Use PMODE_INSN. + (tablejump<mode>): Rename to... + (tablejump_<mode>): ...this. + (exception_receiver): Handle restore_gp_si and restore_gp_di. + (restore_gp): Use the Pmode iterator. + * config/mips/mips-dsp.md (mips_lbux, mips_lhx, mips_lwx): Use + PMODE_INSN. + +2011-09-05 Richard Sandiford <rdsandiford@googlemail.com> + + * config/mips/mips.c (mips_gimplify_va_arg_expr): Unshare off. + Fix the type of the BIT_AND_EXPR. + +2011-09-05 David S. Miller <davem@davemloft.net> + + * config.host: Add driver-sparc.o and sparc/x-sparc on + native sparc*-*-linux* builds. + * config/sparc/driver-sparc.c: Correct Linux strings. + * config/sparc/linux.h: Add DRIVER_SELF_SPECS. + * config/sparc/linux64.h: Likewise. + * doc/invoke.texi: Document that Linux also supports + -mcpu=native and -mtune=native on sparc. + + * config/sparc/sparc-opts.h (PROCESSOR_NIAGARA3, + PROCESSOR_NIAGARA4): New. + * config/sparc/sparc.opt: Handle new processor types. + * config/sparc/sparc.md: Add to "cpu" attribute. + * config/sparc/sparc.h (TARGET_CPU_niagara3, + TARGET_CPU_niagara4): New, treat as niagara2. + * config/sparc/linux64.h: Handle niagara3 and niagara4 + like niagara2. + * config/sparc/sol2.h: Likewise. + * config/sparc/niagara2.md: Schedule niagara3 like + niagara2. + * config/sparc/sparc.c (sparc_option_override): Add + niagara3 and niagara4 handling. + (sparc32_initialize_trampoline): Likewise. + (sparc64_initialize_trampoline): Likewise. + (sparc_use_sched_lookahead): Likewise. + (sparc_issue_rate): Likewise. + (sparc_register_move_cost): Likewise. + * config/sparc/driver-sparc.c (cpu_names): Use niagara3 + and niagara4 as appropriate. + * doc/invoke.texi: Document new processor types. + * config.gcc: Recognize niagara3 and niagara4 in --with-cpu + and --with-tune options. + + * config/sparc/sol2-64.h: Move ... + * config/sparc/default-64.h: ... to here. Update comment. + * config.gcc: Update Solaris sparc to use default-64.h, also + prefix this header into the list on sparc64-*-linux. + * config/sparc/linux64.h (TARGET_DEFAULT): Only override if + TARGET_64BIT_DEFAULT is defined. Remove commented out reference + to MASK_HARD_QUAD. + +2011-09-05 Georg-Johann Lay <avr@gjlay.de> + + PR target/50289 + * config/avr/avr.c (sequent_regs_live): Don't recognize sequences + that contain global register variable. + +2011-09-05 Richard Guenther <rguenther@suse.de> + + * tree-cfg.c (replace_uses_by): Use fold_stmt, not fold_stmt_inplace. + +2011-09-05 Richard Guenther <rguenther@suse.de> + + * stor-layout.c (layout_type): Use size_binop for array size + calculations. + +2011-09-05 Georg-Johann Lay <avr@gjlay.de> + + * config/avr/avr.h (progmem_section): Remove Declaration. + * config/avr/avr.c (progmem_section): Make static and rename to + progmem_swtable_section. + (avr_output_addr_vec_elt): No need to switch sections. + (avr_asm_init_sections): Use output_section_asm_op as section + callback for progmem_swtable_section. + (avr_output_progmem_section_asm_op): Remove Function. + (TARGET_ASM_FUNCTION_RODATA_SECTION): New Define. + (avr_asm_function_rodata_section): New static Function. + * config/avr/elf.h (ASM_OUTPUT_BEFORE_CASE_LABEL): Output + alignment 2**1 for jump tables. + +2011-09-04 Jan Hubicka <jh@suse.cz> + + * ipa-inline-analysis.c (set_cond_stmt_execution_predicate): Check that + parameter is SSA name. + +2011-09-04 Richard Guenther <rguenther@suse.de> + + Revert + 2011-08-31 Richard Guenther <rguenther@suse.de> + + * fold-const.c (extract_muldiv_1): Remove bogus TYPE_IS_SIZETYPE + special-casing. + +2011-09-04 Iain Sandoe <iains@gcc.gnu.org> + + PR debug/49901 + * config/darwin.h (DEBUG_MACRO_SECTION): New macro. + +2011-09-04 Jakub Jelinek <jakub@redhat.com> + Ira Rosen <ira.rosen@linaro.org> + + PR tree-optimization/50208 + * tree-vect-patterns.c (vect_handle_widen_mult_by_const): Add an + argument. Check that def_stmt is inside the loop. + (vect_recog_widen_mult_pattern): Update calls to + vect_handle_widen_mult_by_cons. + (vect_operation_fits_smaller_type): Check that def_stmt is + inside the loop. + +2011-09-04 Ira Rosen <ira.rosen@linaro.org> + + * tree-vectorizer.c (vect_print_dump_info): Print line + number when dumping to a file. + (vectorize_loops): Add new messages to dump file. + +2011-09-03 Martin Jambor <mjambor@suse.cz> + + * ipa-prop.h (ipa_jump_func_t): New typedef. + (struct ipa_edge_args): Removed field argument_count, field + jump_functions turned into a vector. + (ipa_set_cs_argument_count): Removed. + (ipa_get_cs_argument_count): Updated to work on vectors. + (ipa_get_ith_jump_func): Likewise. + * ipa-prop.c (ipa_count_arguments): Removed. + (compute_scalar_jump_functions): Use ipa_get_ith_jump_func to access + jump functions. Update caller. + (compute_pass_through_member_ptrs): Likewise. + (compute_cst_member_ptr_arguments): Likewise. + (ipa_compute_jump_functions_for_edge): Get number of arguments from + the statement, allocate vector. + (ipa_compute_jump_functions): Do not call ipa_count_arguments. + (duplicate_ipa_jump_func_array): Removed. + (ipa_edge_duplication_hook): Use VEC_copy, do not copy argument count. + (ipa_read_node_info): Allocate vector. + +2011-09-03 John David Anglin <dave.anglin@nrc-cnrc.gc.ca> + + PR middle-end/50232 + * config/pa/pa.md (return): Define "return" insn pattern. + (epilogue): Use it when no epilogue is needed. + * config/pa/pa.c (pa_can_use_return_insn): New function. + * config/pa/pa-protos.h (pa_can_use_return_insn): Declare. + +2011-09-03 Eric Botcazou <ebotcazou@adacore.com> + + * cfgexpand.c (add_stack_var): Assert that the alignment is not zero. + * tree-ssa-ccp.c (fold_builtin_alloca_for_var): Revert latest change. + Force at least BITS_PER_UNIT alignment on the new variable. + +2011-09-02 Gary Funck <gary@intrepid.com> + + * opts.c (print_specific_help): Fix off-by-one compare in + assertion check. + * opts.h (CL_PARAMS, CL_WARNING, CL_OPTIMIZATION, CL_DRIVER, + CL_TARGET, CL_COMMON, CL_JOINED, CL_SEPARATE, CL_UNDOCUMENTED): + Increase by +5 to allow for more languages. + * optc-gen.awk: Generate #if that ensures that the number of + languages is within the implementation-defined limit. + +2011-09-02 Michael Matz <matz@suse.de> + + PR middle-end/50260 + * ipa-split.c (split_function): Call add_referenced_var. + + * tree-ssa-phiopt.c (cond_store_replacement): Don't call get_var_ann. + (cond_if_else_store_replacement_1): Ditto. + * tree-ssa-pre.c (get_representative_for): Ditto. + (create_expression_by_pieces): Ditto. + (insert_into_preds_of_block): Ditto. + * tree-sra.c (create_access_replacement): Ditto. + (get_replaced_param_substitute): Ditto. + +2011-09-02 Bernd Schmidt <bernds@codesourcery.com> + + * config/c6x/c6x.md (collapse-ndfa, no-comb-vect): New + automata_options. + (d1, l1, s1, m1, d2, l2, s2, m2): Changed to define_query_cpu_unit. + (l1w, s1w, l2w, s2w): Define in the main automaton. + (fps1, fpl1, adddps1, adddpl1, fps2, fpl2, adddps2, adddpl2): New + units. + * config/c6x/c6x.c (c6x_sched_insn_info): Add unit_mask member. + (c6x_unit_names): Add the new units. + (c6x_unit_codes): New static array. + (UNIT_QID_D1, UNIT_QID_L1, UNIT_QID_S1, UNIT_QID_M1, UNIT_QID_FPS1, + UNIT_QID_FPL1, UNIT_QID_ADDDPS1, UNIT_QID_ADDDPL1, + UNIT_QID_SIDE_OFFSET): New macros. + (RESERVATION_S2): Adjust value. + (c6x_option_override): Compute c6x_unit_codes. + (assign_reservations): Take the unit_mask of the last instruction + into account. Detect floating point reservations by looking for + the new units. Don't assign reservations if the field is already + nonzero. + (struct c6x_sched_context): Add member prev_cycle_state_ctx. + (init_sched_state): Initialize it. + (c6x_clear_sched_context): Free it. + (insn_set_clock): Clear reservation. + (prev_cycle_state): New static variable. + (c6x_init_sched_context): Save it. + (c6x_sched_init): Allocate space for it and clear it. + (c6x_sched_dfa_pre_cycle_insn): New static function. + (c6x_dfa_new_cycle): Save state at the start of a new cycle. + (c6x_variable_issue): Only record units in the unit_mask that + were not set at the start of the cycle. + (c6x_variable_issue): Compute and store the unit_mask from the + current state. + (reorg_split_calls): Ensure the new information remains correct. + (TARGET_SCHED_DFA_NEW_CYCLE, TARGET_SCHED_CLEAR_SCHED_CONTEXT, + TARGET_SCHED_DFA_PRE_CYCLE_INSN): Define. + * config/c6x/c6x.h (CPU_UNITS_QUERY): Define. + * config/c6x/c6x-sched.md.in (fp4_ls_N__CROSS_, adddp_ls_N__CROSS_): + Add special reservations. + * config/c6x/c6x-sched.md: Regenerate. + +2011-09-02 Martin Jambor <mjambor@suse.cz> + + * ipa-prop.h (ipa_node_params): Removed fields + called_with_var_arguments and node_versionable. + (ipa_set_called_with_variable_arg): Removed. + (ipa_is_called_with_var_arguments): Likewise. + * ipa-cp.c (ipa_get_lattice): Fixed index check in an assert. + (determine_versionability): Do not check for type attributes and va + builtins. Record versionability into inline summary. + (initialize_node_lattices): Do not check + ipa_is_called_with_var_arguments. + (propagate_constants_accross_call): Likewise, ignore arguments we do + not have PARM_DECLs for, set variable flag for parameters that were + not passed a value. + (create_specialized_node): Dump info that we cannot change signature. + * ipa-prop.c (ipa_compute_jump_functions): Do not care about variable + number of arguments. + (ipa_make_edge_direct_to_target): Likewise. + (ipa_update_after_lto_read): Likewise. + (ipa_node_duplication_hook): Do not copy called_with_var_arguments flag. + * tree-inline.c (copy_arguments_for_versioning): Copy PARM_DECLs if + they were remapped. + +2011-09-02 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/27460 + PR middle-end/29269 + * doc/md.texi (vcond): Document. + * genopinit.c (optabs): Turn vcond{,u}_optab into a conversion + optab with two modes. + * optabs.h (enum convert_optab_index): Add COI_vcond, COI_vcondu. + (enum direct_optab_index): Remove DOI_vcond, DOI_vcondu. + (vcond_optab): Adjust. + (vcondu_optab): Likewise. + (expand_vec_cond_expr_p): Adjust prototype. + * optabs.c (get_vcond_icode): Adjust. + (expand_vec_cond_expr_p): Likewise. + (expand_vec_cond_expr): Likewise. + * tree-vect-stmts.c (vect_is_simple_cond): Return the comparison + vector type. + (vectorizable_condition): Allow differing types for comparison + and result. + * config/i386/i386.c (ix86_expand_sse_cmp): Use proper mode + for the comparison. + * config/i386/sse.md (vcond<mode>): Split to + vcond<V_256:mode><VF_256:mode>, vcond<V_128:mode><VF_128:mode>, + vcond<V_128:mode><VI124_128:mode> and + vcondu<V_128:mode><VI124_128:mode>. + (vcondv2di): Change to vcond<VI8F_128:mode>v2di. + (vconduv2di): Likewise. + * config/arm/neon.md (vcond<mode>): Change to vcond*<mode><mode>. + (vcondu<mode>): Likewise. + * config/ia64/vect.md (vcond<mode>): Likewise. + (vcondu<mode>): Likewise. + (vcondv2sf): Likewise. + * config/mips/mips-ps-3d.md (vcondv2sf): Likewise. + * config/rs6000/paired.md (vcondv2sf): Likewise. + * config/rs6000/vector.md (vcond<mode>): Likewise. + (vcondu<mode>): Likewise. + * config/spu/spu.md (vcond<mode>): Likewise. + (vcondu<mode>): Likewise. + +2011-09-02 Richard Guenther <rguenther@suse.de> + + * pretty-print.h (pp_unsigned_wide_integer): New. + * tree-pretty-print.c (dump_generic_node): Print unsigned + host-wide-int fitting INTEGER_CSTs with pp_unsigned_wide_integer. + +2011-09-02 Richard Sandiford <richard.sandiford@linaro.org> + + PR target/49987 + * config/rs6000/rs6000.c (paired_expand_vector_init): Check for + valid CONST_VECTOR operands. + (rs6000_expand_vector_init): Likewise. + +2011-09-02 Martin Jambor <mjambor@suse.cz> + + * cgraph.h (cgraph_indirect_call_info): Removed field thunk_delta. + * gimple-fold.c (gimple_get_virt_method_for_binfo): Rewritten to use + BINFO_VTABLE. Parameter delta removed, all callers updated. + * tree.c (free_lang_data_in_binfo): Clear BINFO_VIRTUALs instead + BINFO_VTABLE. + * cgraph.c (cgraph_make_edge_direct): Removed parameter delta, updated + all calls. + * cgraphunit.c (cgraph_redirect_edge_call_stmt_to_callee): Removed + handling of thunk_delta. + * ipa-cp.c (get_indirect_edge_target): Removed parameter delta. + (devirtualization_time_bonus): Do not handle thunk deltas. + (ipcp_discover_new_direct_edges): Likewise. + * ipa-prop.c (ipa_make_edge_direct_to_target): Likewise. + (try_make_edge_direct_simple_call): Likewise. + (try_make_edge_direct_virtual_call): Likewise. + * lto-cgraph.c (output_cgraph_opt_summary_p): Likewise. Mark + parameter set as unused. + (output_edge_opt_summary): Likewise. Mark both parameters as unused. + * lto-cgraph.c (output_cgraph_opt_summary_p): Likewise. Mark + parameter set as unused. + (output_edge_opt_summary): Likewise. Mark both parameters as unused. + (input_edge_opt_summary): Likewise. + * lto-streamer-out.c (lto_output_ts_binfo_tree_pointers): Do not stream + BINFO_VIRTUALS at all. + * lto-streamer-in.c (lto_input_ts_binfo_tree_pointers): Likewise. + +2011-09-02 Richard Guenther <rguenther@suse.de> + + * tree-ssa-ccp.c (fold_builtin_alloca_for_var): Do not fold alloca (0). + (ccp_fold_stmt): Continue replacing args when folding alloca fails. + 2011-08-31 Richard Guenther <rguenther@suse.de> * expr.c (expand_expr_real_2): Move COND_EXPR and VEC_COND_EXPR @@ -15,8 +521,7 @@ (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. + * 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. @@ -163,8 +668,8 @@ * gthr-posix.h (__gthread_active_p): Do not use preprocessor conditionals and comments inside macro arguments. -20011-08-29 Artjoms Sinkarovs <artyom.shinkaroff@gmail.com> - Richard Guenther <rguenther@suse.de> +2011-08-29 Artjoms Sinkarovs <artyom.shinkaroff@gmail.com> + Richard Guenther <rguenther@suse.de> * tree.h (constant_boolean_node): Adjust prototype. * fold-const.c (fold_convert_loc): Move aggregate conversion diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 9ac8da10af7..dab65aca3e3 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20110902 +20110907 diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 885cbad07ce..da25c724917 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,1130 @@ +2011-09-07 Iain Sandoe <iains@gcc.gnu.org> + + * gcc-interface/Makefile.in (darwin): Provide powerpc64 system + implementation. + * system-darwin-ppc64.ads: New file. + +2011-09-06 Iain Sandoe <iains@gcc.gnu.org> + + * gcc-interface/Makefile.in (gnatlib-shared-darwin): Remove + reference to "-lm". + +2011-09-06 Iain Sandoe <iains@gcc.gnu.org> + + * gcc-interface/Makefile.in (darwin, SO_OPTS): Provide architecture + size switches to the link phase for shared libs. + +2011-09-06 Iain Sandoe <iains@gcc.gnu.org> + + * gcc-interface/Makefile.in (x86_64 darwin arch): Adjust + LIBGNAT_TARGET_PAIRS for x86 and x86_64 variants. + +2011-09-06 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in + (gnattools, regnattools, cross-gnattools, canadian-gnattools, + gnatlib, gnatlib-sjlj, gnatlib-zcx, gnatlib-shared, gnatlib_and_tools): + New targets. + (TOOLS_FLAGS_TO_PASS): New. + (../stamp-tools): Reintroduce, to avoid merge conflicts. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * sem_ch10.adb, impunit.ads, impunit.adb (Not_Impl_Defined_Unit): New + name for Is_RM_Defined_Unit. Also several fixes to this unit. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * impunit.ads, impunit.adb (Is_RM_Defined_Unit): New function. + * s-rident.ads: New restriction No_Implementation_Units + (this restriction is also part of the profile + No_Implementation_Extensions) + * sem_ch10.adb (Analyze_With_Clause): Add check for + No_Implementation_Units restriction. + +2011-09-06 Jerome Guitton <guitton@adacore.com> + + * sysdep.c (__gnat_get_task_options): Disable VX_SPE_TASK + on vThreads. + +2011-09-06 Thomas Quinot <quinot@adacore.com> + + * s-solita.adb: Minor reformatting. + +2011-09-06 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): The body that + is a rewriting of an expression function does not freeze previous + entities. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * impunit.adb (Is_Known_Unit): Fix bad handling of Ada 2012 case + +2011-09-06 Tristan Gingold <gingold@adacore.com> + + * gcc-interface/Makefile.in: Handle e500v2-wrs-vxworksae like + powerpc-wrs-vxworksae. + +2011-09-06 Thomas Quinot <quinot@adacore.com> + + * s-os_lib.ads (Spawn): Minor documentation clarification, + Success is True for a zero exit status. + +2011-09-06 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb: Add message for common iterator error. + +2011-09-06 Ed Schonberg <schonberg@adacore.com> + + * exp_ch3.adb (Build_Initialization_Call): If the target is a + selected component discriminated by a current instance, replace + the constraint with a reference to the target object, regardless + of whether the context is an init_proc. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * exp_attr.adb: Descriptor_Size is never static. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: Add documentation for LSLOC metric in gnatmetric + +2011-09-06 Hristian Kirtchev <kirtchev@adacore.com> + + * gnat_rm.texi: Clarify that attribute Descriptor_Size is + non-static. + +2011-09-06 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve): An expression that is the body of an + expression function does not freeze. + +2011-09-06 Matthew Heaney <heaney@adacore.com> + + * a-csquin.ads, a-cusyqu.adb, a-cbprqu.adb, a-cbsyqu.adb, + a-cuprqu.adb: Changed copyright notice to indicate current + year only. + +2011-09-06 Vincent Celier <celier@adacore.com> + + * prj.adb: Minor spelling error fix in comment + * sem_res.adb: Minor reformatting + +2011-09-06 Pascal Obry <obry@adacore.com> + + * sysdep.c (winflush_nt): Removed as not needed anymore. + (winflush_95): Likewise. + (winflush_init): Likewise. + (winflush_function): Likewise. + (getc_immediate_common): Remove call to winflush_function. + +2011-09-06 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Rewrite the + processing for Descriptor_Size. + * gnat_rm.texi: Rephrase the wording for attribute Descriptor_Size + to account for its broader usage. + * sem_attr.adb (Analyze_Attribute): Change the error detection + circuitry for Descriptor_Size as the attribute is now applicable + to all types. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * sem_attr.adb, prj-nmsc.adb, exp_aggr.adb: Minor reformatting. + +2011-09-06 Ed Schonberg <schonberg@adacore.com> + + * lib-xref.adb (OK_To_Set_Referenced): A reference to a formal + in a parameter association must not set the Referenced flag on + the formal. + * prj-nmsc.adb (Check_File_Naming_Schemes): Remove useless formal + +2011-09-06 Hristian Kirtchev <kirtchev@adacore.com> + + * gnat_rm.texi: Add a section on attribute Descriptor_Size + +2011-09-06 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Makefile.in (common-tools, gnatmake-re, + gnatlink-re): Speed up by using -j0. + +2011-09-06 Yannick Moy <moy@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Call + Set_Corresponding_Aspect when creating pragma from aspect. + (Add_Predicates): Use new field Corresponding_Aspect. + * sem_prag.adb (Analyze_Pragma): Make Pname hold source aspect + name when present, for the purpose of issuing error messages; + remove local procedure Error_Pragma_Arg_Alternate_Name. + * sinfo.adb, sinfo.ads (Corresponding_Aspect): New field in + N_Pragma node. + (From_Dynamic_Predicate, From_Static_Predicate): Remove fields from + N_Pragma node. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * checks.adb, s-except.ads, g-socket.adb: Minor reformatting. + +2011-09-06 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb (Build_Heap_Allocator): Add new + local variable Desig_Typ. Code and comment reformatting. Add + machinery to ensure that the allocation uses a fat pointer when + the type of the return object is a constrained array and the + function return type is an unconstrained array. + +2011-09-06 Vincent Celier <celier@adacore.com> + + * make.adb, prj-part.adb, prj-nmsc.adb: Remove unused formal + parameters in subprograms. + +2011-09-06 Arnaud Charlet <charlet@adacore.com> + + * s-taprop-mingw.adb (Finalize_TCB): Fix typo. + +2011-09-06 Thomas Quinot <quinot@adacore.com> + + * s-taprop-vxworks.adb, s-tpoaal.adb, s-tpopsp-vxworks.adb + (System.Tasking.Primitive_Operations.Specific.Delete): Remove + subprogram. + (System.Tasking.Primitive_Operations.Specific.Set): If argument + is null, destroy task specific data, to make API consistent with + other platforms, and thus compatible with the shared version + of s-tpoaal.adb. + (System.Tasking.Primitive_Operations.ATCB_Allocation.Free_ATCB): + Document the above assumption. + +2011-09-06 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Expand_Inlined_Call): Fix use of uninitialized + variable for type of return value when return type is + unconstrained and context is an assignment. + +2011-09-06 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Check_Class_Wide_Actual): Do not generate body of + class-wide operation if expansion is not enabled. + +2011-09-06 Eric Botcazou <ebotcazou@adacore.com> + + * checks.adb (Apply_Scalar_Range_Check): Deal with access + type prefix. + +2011-09-06 Yannick Moy <moy@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications, case + Aspect_Invariant): Do not issue error at this point on illegal + pragma placement, as this is checked later on when analyzing + the corresponding pragma. + * sem_prag.adb (Error_Pragma_Arg_Alternate_Name): New procedure + similar to Error_Pragma_Arg, except the source name of the + aspect/pragma to use in warnings may be equal to parameter + Alt_Name (Analyze_Pragma, case Pragma_Invariant): refine error + message to distinguish source name of pragma/aspect, and whether + the illegality resides in the type being public, or being private + without a public declaration + +2011-09-06 Thomas Quinot <quinot@adacore.com> + + * g-socket.adb (Check_For_Fd_Set): On Windows, no need for bitmap + size check (fd_set is implemented differently on that platform). + +2011-09-06 Thomas Quinot <quinot@adacore.com> + + * s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-vms.adb, + s-tpoaal.adb, s-taprop-mingw.adb, s-taprop-linux.adb, + s-taprop-solaris.adb, s-taprop-irix.adb, s-taprop.ads, + s-taprop-hpux-dce.adb, s-taprop-dummy.adb, s-taprop-posix.adb + (ATCB_Allocation): New subpackage of + System.Tasking.Primitive_Operations, shared across all targets + with full tasking runtime. + (ATCB_Allocation.New_ATCB): Moved there (from target specific + s-taprop bodies). + (ATCB_Allocation.Free_ATCB): New subprogram. Deallocate an ATCB, + taking care of establishing a local temporary ATCB if the one + being deallocated is Self, to avoid a reference to the freed + ATCB in Abort_Undefer. + +2011-09-06 Thomas Quinot <quinot@adacore.com> + + * s-tassta.adb, s-taskin.ads (Free_Task): If the task is not + terminated, mark it for deallocation upon termination. + (Terminate_Task): Call Free_Task again if the task is marked + for automatic deallocation upon termination. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * a-cbprqu.ads, a-cbsyqu.ads, a-cuprqu.ads, a-cusyqu.ads, + a-intnam-aix.ads, a-intnam-darwin.ads, a-intnam-dummy.ads, + a-intnam-freebsd.ads, a-intnam-hpux.ads, a-intnam-irix.ads, + a-intnam-linux.ads, a-intnam-lynxos.ads, a-intnam-mingw.ads, + a-intnam-solaris.ads, a-intnam-tru64.ads, + a-intnam-vms.ads, a-intnam-vxworks.ads, a-intnam.ads, interfac.ads, + cstand.adb, s-maccod.ads: Mark all entities as Implementation_Defined + * einfo.ads, einfo.adb (Is_Implementation_Defined): New flag + * par-prag.adb: Add dummy entry for pragma Implementation_Defined + * s-rident.ads: Add new restriction No_Implementation_Identifiers + Add new profile No_Implementation_Extensions + * sem_prag.adb: Implement pragma Implementation_Defined Implement + profile No_Implementation_Extensions + * sem_util.adb: Minor reformatting (Set_Entity_With_Style_Check): + Check violation of restriction No_Implementation_Identifiers + * snames.ads-tmpl: Add entries for pragma Implementation_Defined + Add entry for Name_No_Implementation_Extensions + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * impunit.ads: Minor reformatting. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * ali.adb, sem_ch13.adb, lib-xref.adb: Minor reformatting. + +2011-09-06 Pascal Obry <obry@adacore.com> + + * s-osinte-linux.ads, s-oscons-tmplt.c: Use oscons to define sigset_t + types. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * g-socket.adb: Minor reformatting + +2011-09-06 Javier Miranda <miranda@adacore.com> + + * ali.adb (Scan_ALI): Add missing support to load references of + entities imported from other languages. + * ali.ads (Xref_Record): Adding new fields to store the language and + name of an imported entity. + * lib-xref.adb (Output_Import_Export_Info): Fix typo + in comment. + +2011-09-06 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Analyze_Pragma, case Type_Invariant): A type invariant + is allowed on a full type declaration if it is the completion of + a private declarations. + * sem_ch13.adb (Analyze_Aspect_Specifications): An invariant + aspect is allowed on a full type declaration in the private part + of a package. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * sem_ch8.ads: Minor reformatting + +2011-09-06 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c, g-socket.adb (GNAT.Sockets.Clear,Set,Is_Set): + Guard against socket values that are not in [0;FD_SETSIZE[ + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * s-osinte-linux.ads, a-iteint.ads, exp_ch6.adb, s-solita.adb: Minor + reformatting. + +2011-09-06 Arnaud Charlet <charlet@adacore.com> + + * s-linux-alpha.ads: Minor reformatting + * s-oscons-tmplt.c: Fix generated comments in s-oscons template. + Use sizeof instead of corresponding C defines in s-oscons template. + +2011-09-06 Vadim Godunko <godunko@adacore.com> + + * a-convec.ads, a-iteint.ads: Minor reformatting. + +2011-09-06 Vincent Celier <celier@adacore.com> + + * projects.texi: Add menus and @node lines. + +2011-09-06 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Expand_Inlined_Call): Handle properly the case + where the return type is an unconstrained array and the context + is an assignment. Optimize the case when the target of the + assignment is a selected component. + +2011-09-06 Arnaud Charlet <charlet@adacore.com> + + * s-solita.adb: Update comments. + +2011-09-06 Pascal Obry <obry@adacore.com> + + * s-linux.ads, s-linux-alpha.ads, s-linux-hppa.ads, s-linux-mipsel.ads, + s-linux-sparc.ads: Remove hard coded and now wrong definitions. + * s-oscons-tmplt.c: Add support for generating pthread related + types size on GNU/Linux as done for Darwin. + * s-osinte-linux.ads: Use s-oscons to define the pthread types. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * exp_ch6.adb: Fix minor typo. + +2011-09-06 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb: Remove with and use clauses for Get_Targ. + (Alignment_Of): Moved to the body of Nearest_Multiple_Rounded_Up. + (Double_Size_Of): Alphabetized. Update the comment on usage. + (Make_Finalize_Address_Stmts): Update comments and reformat code. + (Nearest_Multiple_Rounded_Up): New routine. + (Size_Of): Update comment on usage. The generated expression now + accounts for alignment gaps by rounding the size of the type to the + nearest multiple rounded up of the type's alignment. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * exp_ch7.adb, g-comlin.adb: Minor reformatting. + +2011-09-06 Steve Baird <baird@adacore.com> + + * exp_ch4.adb (Expand_Allocator_Expression): Look through + derived subprograms in checking for presence of an + Extra_Accessibility_Of_Result formal parameter. + * exp_ch6.adb (Expand_Call): Look through derived subprograms in + checking for presence of an Extra_Accessibility_Of_Result formal + parameter. + (Expand_Call.Add_Actual_Parameter): Fix a bug in the + case where the Parameter_Associatiations attribute is already set, + but set to an empty list. + (Needs_Result_Accessibility_Level): + Unconditionally return False. This is a temporary + change, disabling the Extra_Accessibility_Of_Result + mechanism. + (Expand_Simple_Function_Return): Check for + Extra_Accessibility_Of_Result parameter's presence instead of + testing Ada_Version when generating a runtime accessibility + check which makes use of the parameter. + +2011-09-06 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Expand_N_Case_Expression): Actions created for the + expression in a given case alternative must be attached to the + statement list of the ccrresponding case statement alternative + They cannot be propagated ahead of the case statement, because + the validity of the expression that generated the action may + hold only for that alternative. + +2011-09-06 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb: Remove with and use clauses for Get_Targ. + (Alignment_Of): Remove the code for strict alignment targets. + (Double_Alignment_Of): Removed. + (Double_Size_Of): New routine. + (Make_Finalize_Address_Stmts): Change the + calculation of the dope's size. Update relevant comments. + (Size_Of): New routine. + +2011-09-06 Steve Baird <baird@adacore.com> + + * einfo.ads (Extra_Accessibility): Update associated comment to use + the term "present" correctly ("present" just means that it is not + an error to query the value of the attribute - it does not imply + that the value must be non-null). + (Extra_Constrained): Ditto. + (Is_Visible_Formal): Ditto. + (Extra_Accessibility_Of_Result) Ditto; also add Inline pragma. + (Set_Extra_Accessibility_Of_Result): Add Inline pragma. + * exp_ch4.adb (Expand_Allocator_Expression): Improve a comment. + * exp_ch6.adb (Expand_Call): The callee may require an + Extra_Accessibility_Of_Result actual parameter even if Ada_Version + < Ada_2012. This can occur if the callee is exported from a Gnat + runtimes unit. Also improve a comment. + +2011-09-06 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb: Add with and use clauses for Get_Targ. + (Alignment_Of): Rename formal parameter Some_Typ + to Typ, update related comment. Use the allocator alignment on + strict alignment targets such as SPARC. + (Double_Alignment_Of): Rename formal parameter Some_Typ to Typ, update + related comment. + +2011-09-06 Gary Dismukes <dismukes@adacore.com> + + * sem_ch9.adb (Check_Interfaces): Test + Is_Limited_Type rather than Is_Limited_Record when checking that + the partial view of a synchronized full view must be limited. + +2011-09-06 Emmanuel Briot <briot@adacore.com> + + * g-comlin.adb (Free): Fix memory leak. + +2011-09-06 Robert Dewar <dewar@adacore.com> + + * sem_util.adb, exp_ch6.adb: Minor reformatting and code reorganization. + +2011-09-06 Steve Baird <baird@adacore.com> + + * einfo.ads (Extra_Accessibility_Of_Result): New function; in the + (Ada2012) cases described in AI05-0234 where the accessibility + level of a function result is "determined by the point of + call", an implicit parameter representing that accessibility + level is passed in. Extra_Accessibilty_Of_Result yields this + additional formal parameter. Extra_Accessibility_Of_Result + is analogous to the existing Extra_Accessibility + function used in the implementation of access parameters. + (Set_Extra_Accessibility_Of_Result): New procedure; sets + Extra_Accessibility_Of_Result attribute. + * einfo.adb (Extra_Accessibility_Of_Result): New function. + (Set_Extra_Accessibility_Of_Result): New procedure. + (Write_Field19_Name): Display Extra_Accessibilty_Of_Result attribute. + * sem_util.adb (Dynamic_Accessibility_Level): Set Etype of + an accessibility level literal to Natural; introduce a nested + function, Make_Level_Literal, to do this. + * exp_ch6.ads (Needs_Result_Accessibility_Level): New function; + determines whether a given function (or access-to-function + type) needs to have an implicitly-declared accessibility-level + parameter added to its profile. + (Add_Extra_Actual_To_Call): Export an existing procedure which was + previously declared in the body of Exp_Ch6. + * exp_ch6.adb (Add_Extra_Actual_To_Call): Export declaration by moving + it to exp_ch6.ads. + (Has_Unconstrained_Access_Discriminants): New Function; a + predicate on subtype entities which returns True if the given + subtype is unconstrained and has one or more access discriminants. + (Expand_Call): When expanding a call to a function which takes an + Extra_Accessibility_Of_Result parameter, pass in the appropriate + actual parameter value. In the case of a function call which is + used to initialize an allocator, this may not be possible because + the Etype of the allocator may not have been set yet. In this + case, we defer passing in the parameter and handle it later in + Expand_Allocator_Expression. + (Expand_Simple_Function_Return): When returning from a function which + returns an unconstrained subtype having at least one access + discriminant, generate the accessibility check needed to ensure that + the function result will not outlive any objects designated by its + discriminants. + (Needs_Result_Accessibility_Level): New function; see exp_ch6.ads + description. + * exp_ch4.adb (Expand_Allocator_Expression): When a function call + is used to initialize an allocator, we may need to pass in "the + accessibility level determined by the point of call" (AI05-0234) + to the function. Expand_Call, where such actual parameters are + usually generated, is too early in this case because the Etype of + the allocator (which is used in determining the level to be passed + in) may not have been set yet when Expand_Call executes. Instead, + we generate code to pass in the appropriate actual parameter + in Expand_Allocator_Expression. + * sem_ch6.adb (Create_Extra_Formals): Create + the new Extra_Accessibility_Of_Result formal if + Needs_Result_Accessibility_Level returns True. This includes the + introduction of a nested procedure, Check_Against_Result_Level. + +2011-09-06 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Makefile.in (X86_TARGET_PAIRS): Remove duplicate + declaration. + +2011-09-05 Hristian Kirtchev <kirtchev@adacore.com> + + * s-finmas.adb (Set_Finalize_Address): Explain the reason + for the synchronization. Move the test for null from + s-stposu.Allocate_Any_Controlled to this routine since the check + needs to be protected too. + (Set_Heterogeneous_Finalize_Address): Explain the reason for the + synchronization code. + * s-finmas.ads (Set_Heterogeneous_Finalize_Address): Add comment + explaining the context in which this routine is used. + * s-stposu.adb (Allocate_Any_Controlled): Move the test for null + to s-finmas.Set_Finalize_Address. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * einfo.ads: Document that itypes have no parent field. + +2011-09-05 Robert Dewar <dewar@adacore.com> + + * rtsfind.adb (Check_CRT): Check for overloaded entity + * rtsfind.ads: Document that entities to be found by rtsfind + cannot be overloaded + * s-taenca.adb, s-tasren.adb, s-tpobop.adb, s-tpoben.ads, s-tpoben.adb + (Lock_Entries_With_Status): New name for Lock_Entries with two + arguments (changed to meet rtsfind no overloading rule). + +2011-09-05 Hristian Kirtchev <kirtchev@adacore.com> + + * s-finmas.adb (Set_Finalize_Address (Address, + Finalize_Address_Ptr)): Renamed to Set_Heterogeneous_Finalize_Address. + (Set_Finalize_Address (in out Finalization_Master, + Finalize_Address_Ptr): Add synchronization code. + * s-finmas.ads (Set_Finalize_Address (Address, + Finalize_Address_Ptr)): Renamed to Set_Heterogeneous_Finalize_Address. + * s-stposu.adb (Allocate_Any_Controlled): Update the call to + Set_Finalize_Address for the heterogeneous case. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb: Undo previous change, not suitable after all. + +2011-09-05 Robert Dewar <dewar@adacore.com> + + * einfo.ads: Minor comment clarification. + +2011-09-05 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch6.adb (Move_Activation_Chain): Rewritten. The routine + no longer needs to search through the entities of the return + statement scope to find the _chain. + * sem_ch5.adb: Add with and use clauses for Exp_Ch6 and Sem_Ch6. + (Analyze_Block_Statement): Add local variable + Is_BIP_Return_Statement. Add machinery to install all entities + produced by the expansion of the return object declaration. + (Install_Return_Entities): New routine. + * sem_ch6.ads, sem_ch6.adb (Install_Entity): Moved from body to spec. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch10.adb (Analyze_Context): Apply simple fixup if context + of subunit is incomplete. + (Analyze_Proper_Body): If parent spec is not available, do not + attempt analysis. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * sem_disp.adb (Find_Controlling_Arg): Add checks for + interface type conversions, that are expanded into dereferences. + +2011-09-05 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): + Examine the parameter and return profile of a subprogram and swap + any incomplete types coming from a limited context with their + corresponding non-limited views. + (Exchange_Limited_Views): New routine. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Prepare_Private_Subtype_Completion): Set parent + of internal entity to the subtype declaration, so that when + entities are subsequently exchanged in a package body, the tree + remains properly formatted for ASIS. + +2011-09-05 Johannes Kanig <kanig@adacore.com> + + * g-comlin.adb (Set_Usage): Additional optional argument to set help + message. + (Display_Help): display the user given help message, if available. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (OK_For_Limited_Init_In_05): The expression + is legal if the original node is an identifier that is a + parameterless function call. + +2011-09-05 Pascal Obry <obry@adacore.com> + + * prj-nmsc.adb: Minor reformatting. + Add support for standalone aggregate library. + (Check_Stand_Alone_Library): Handle standalone aggregate library. + * projects.texi: Fix documentation for aggregate library projects. + +2011-09-05 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb: Minor reformatting. + +2011-09-05 Matthew Gingell <gingell@adacore.com> + + * s-tassta.adb (Task_Wrapper): Ensure that we don't try to write the + stack guard page on PPC Linux. This patch ensures the 64K guard page at + the bottom of the stack is not overwritten. + +2011-09-05 Thomas Quinot <quinot@adacore.com> + + * exp_intr.adb, s-tasini.adb: Minor reformatting. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Access_Definition): If an access type declaration + appears in a child unit, the scope of whatever anonymous type + may be generated is the child unit itself. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Expression_Function): Do not set + Comes_From_Source on rewritten body. + (Analyze_Subprogram_Body_Helper): Check that the original node for + the body comes from source, when determining whether expansion + of a protected operation is needed. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Replace_Type): If the target of the assignment is + a selected component and the right-hand side is a self-referential + access, the proper prefix of the rewritten attribute is a copy + of the left-hand side, not of its prefix. + +2011-09-05 Robert Dewar <dewar@adacore.com> + + * sem_ch5.adb: Minor reformatting. + * sem_ch3.adb: Minor code clean up. + +2011-09-05 Jose Ruiz <ruiz@adacore.com> + + * exp_ch9.adb (Make_Initialize_Protection): The fact that + restriction No_Dynamic_Attachment is in effect or not should + not influence the default priority associated to a protected + object. With this change, when the restriction is in effect (as + is the case for the Ravenscar profile) the default priority of + a protected object with an interrupt handler is in the range of + interrupt priorities (Default_Interrupt_Priority) as required + by D.3(10). + +2011-09-05 Arnaud Charlet <charlet@adacore.com> + + * a-iteint.ads: Fix header. + +2011-09-05 Vincent Celier <celier@adacore.com> + + * prj-conf.adb (Do_Autoconf): Make sure Obj_Dir always ends + with a directory separator to avoid output such as: + "/path/to/objauto.cgpr" has been deleted. + +2011-09-05 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb: Minor reformatting. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb: Better error message. + +2011-09-05 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_aggr.adb: Add with and use clause for Exp_Ch6. + (Expand_Array_Aggregate): Detect a special case of an aggregate + which contains tasks in the context of an unexpanded return + statement of a build-in-place function. + * exp_ch6.adb: Add with and use clause for Exp_Aggr. + (Expand_N_Extended_Return_Statement): Detect a delayed aggregate + which contains tasks and expand it now that the original simple + return statement has been rewritten. + * exp_ch9.adb (Build_Activation_Chain_Entity): Code + reformatting. Do not create a chain for an extended return + statement if one is already available. + (Has_Activation_Chain): New routine. + +2011-09-05 Marc Sango <sango@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Remove + the wrong test and add the correct test to detect the violation + of illegal use of unconstrained string type in SPARK mode. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Iteration_Specification): Improve error + message on an iterator over an array. + +2011-09-05 Robert Dewar <dewar@adacore.com> + + * lib-xref-alfa.adb: Minor reformatting. + +2011-09-05 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb, sem_res.adb, par.adb, par-ch6.adb, g-comlin.adb, + exp_ch6.adb, lib-xref-alfa.adb: Minor reformatting. + +2011-09-05 Gary Dismukes <dismukes@adacore.com> + + * exp_ch7.adb, exp_ch6.adb: Minor reformatting. + +2011-09-05 Johannes Kanig <kanig@adacore.com> + + * lib-xref-alfa.adb: Update comments. + +2011-09-05 Thomas Quinot <quinot@adacore.com> + + * sem_res.adb: Minor reformatting + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Build_In_Place_Formal): If extra formals are not + present, create them now. Needed in case the return type was + a limited view in the function declaration. + (Make_Build_In_Place_Call_In_Allocator): If return type contains + tasks, build the activation chain for it. Pass a reference to + the Master_Id in call to Add_Task_Actuals_To_Build_In_Place call. + * exp_ch7.adb (Make_Set_Finalize_Address_Call): Clean up interface + with build_in_place calls. + * sem_ch9.adb (Analyze_Task_Type_Declaration): If partial view was + incomplete, inatialize its Corresponding_Record_Type component. + * sem_ch10.adb (Build_Chain): Initialize Private_Dependents field + of limited views. + +2011-09-05 Johannes Kanig <kanig@adacore.com> + + * lib-xref-alfa.adb (Is_Alfa_Reference): Filter constants from effect + information. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * par-ch6.adb (P_Subprogram): In Ada2012 mode, if the subprogram + appears within a package specification and the token after "IS" + is not a parenthesis, assume that this is an unparenthesized + expression function, even if the token appears in a line by + itself. + * par.adb: Clarify use of Labl field of scope stack in error + recovery. + +2011-09-05 Bob Duff <duff@adacore.com> + + * sem_res.adb (Resolve_Intrinsic_Operator): Use unchecked + conversions instead of normal type conversions in all cases where a + type conversion would be illegal. In particular, use unchecked + conversions when the operand types are private. + +2011-09-05 Johannes Kanig <kanig@adacore.com> + + * lib-xref-alfa.adb (Is_Alfa_Reference): Never declare effects on + objects of task type or protected type. + +2011-09-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Expression_Function): If the expression + function comes from source, indicate that so does its rewriting, + so it is compatible with any subsequent expansion of the + subprogram body (e.g. when it is a protected operation). + * sem_ch4.adb: minor reformatting + +2011-09-05 Hristian Kirtchev <kirtchev@adacore.com> + + * lib.adb (Check_Same_Extended_Unit): Comment rewriting. Use + Get_Source_Unit rather than Get_Code_Unit as instantiation unfolding + may lead to wrong ancestor package in the case of instantiated subunit + bodies. If a subunit is instantiated, follow the chain of instantiations + rather than the stub structure. + +2011-09-02 Robert Dewar <dewar@adacore.com> + + * sem_ch4.adb, sem_ch6.adb: Minor reformatting. + * gcc-interface/Make-lang.in: Update dependencies. + +2011-09-02 Marc Sango <sango@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Change + comment and add additional check to differentiate constant of + type string from others unconstrained type. + +2011-09-02 Ed Schonberg <schonberg@adacore.com> + + * sinfo.ads, sinfo.adb: New semantic attribute Premature_Use, + present in incomplete type declarations to refine the error + message the full declaration is in the same unit. + * sem_ch4.adb (Analyze_Selected_Component): If the prefix is of + an incomplete type, set the Premature_Use for additional message. + * sem_ch3.adb (Find_Type_Name): If partial view is incomplete + and Premature_Use is set, place additional information at the + point of premature use. + +2011-09-02 Bob Duff <duff@adacore.com> + + * sem_ch6.adb: (Check_Post_State): Suppress warning + "postcondition refers only to pre-state" when the expression has not + yet been analyzed, because it causes false alarms. This can happen when + the postcondition contains a quantified expression, because those are + analyzed later. This is a temporary/partial fix. + (Process_Post_Conditions): Minor: change wording of warning. + +2011-09-02 Marc Sango <sango@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Detect the violation of + illegal use of unconstrained string type in SPARK mode. + * sem_res.adb (Analyze_Operator_Symbol): Set the + right place where the string operand of concatenation should be + violate in SPARK mode. + +2011-09-02 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb, sem_util.adb, sem_ch6.adb, prj-nmsc.adb, + exp_ch3.adb: Minor reformatting. + +2011-09-02 Vincent Celier <celier@adacore.com> + + * prj-conf.adb (Add_Default_GNAT_Naming_Scheme): Declare "gcc" + as the compiler driver so Is_Compilable returns True for sources. + * prj-nmsc.adb (Override_Kind): When Kind is Sep, set the source + for the body. + +2011-09-02 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Analyze_PPC_In_Decl_Part): for a class-wide + condition, a reference to a controlling formal must be interpreted + as having the class-wide type (or an access to such) so that the + inherited condition can be properly applied to any overriding + operation (see ARM12 6.6.1 (7)). + +2011-09-02 Tristan Gingold <gingold@adacore.com> + + * init.c (__gnat_is_vms_v7): Fix case and add prototype + for LIB$GETSYI. + +2011-09-02 Javier Miranda <miranda@adacore.com> + + * exp_ch3.adb (Expand_N_Object_Declaration): Do not copy the + initializing expression of a class-wide interface object declaration + if its type is limited. + +2011-09-02 Johannes Kanig <kanig@adacore.com> + + * sem_util.adb (Unique_Name): To obtain a unique name for enumeration + literals, take into account the type name; the type is *not* + the scope for an enumeration literal. + +2011-09-02 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Check_Overriding_Indicator): add special check + to reject an overriding indicator on a user-defined Adjust + subprogram for a limited controlled type. + +2011-09-02 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Actuals): add missing call to Resolve + for an actual that is a function call returning an unconstrained + limited controlled type. + +2011-09-02 Tristan Gingold <gingold@adacore.com> + + * g-socthi-vms.adb (c_sendmsg, c_recvmsg): Use unpacked msg if on vms 7 + +2011-09-02 Johannes Kanig <kanig@adacore.com> + + * alfa.ads (Name_Of_Heap_Variable): Change value of the HEAP variable + from "HEAP" to __HEAP Change comment that refers to that variable + * put_alfa.adb: Change comment that refers to that variable + +2011-09-02 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb, exp_ch6.adb, prj-nmsc.adb: Minor reformatting. + +2011-09-02 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_util.adb (Extract_Renamed_Object): Renamed to + Find_Renamed_Object. This routine has been reimplemented and now uses + tree traversal to locate a renamed object. + (Is_Aliased): Replace call to Extract_Renamed_Object with + Find_Renamed_Object. + +2011-09-02 Tristan Gingold <gingold@adacore.com> + + * init.c: (__gnat_is_vms_v7): New function. + +2011-09-02 Olivier Hainque <hainque@adacore.com> + + * tracebak.c (STOP_FRAME, ppc elf/vxworks case): Stop on frames + that have a misaligned backchain, necessarily bogus. + +2011-09-02 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch3.adb (Expand_Freeze_Class_Wide_Type): Do not create + TSS routine Finalize_Address when compiling in Alfa mode. + (Expand_Freeze_Record_Type): Do not create TSS routine + Finalize_Address when compiling in Alfa mode. + * exp_ch4.adb (Expand_Allocator_Expression): Do not produce a + call to Set_Finalize_Address in Alfa mode because Finalize_Address is + not built. + (Expand_N_Allocator): Do not produce a call to + Set_Finalize_Address in Alfa mode because Finalize_Address is not built. + * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Do not + produce a call to primitive Set_Finalize_Address in Alfa mode because + Finalize_Address is not built. + * exp_ch7.adb (Build_Finalization_Master): Do not create + finalization masters in Afa mode since they are not needed. + (Build_Finalizer): Do not create scope and library-level + finalizers in Alfa mode since they are not needed. + * exp_util.adb (Build_Allocate_Deallocate_Proc): Do not expand + "new" and "free" when applied to controlled objects in Alfa mode since + this is not needed. + +2011-09-02 Vincent Celier <celier@adacore.com> + + * prj-nmsc.db: (Check_Stand_Alone_Library): For SALs, allow + only library names with the syntax of Ada identifiers, to avoid errors + when compiling the binder generated files. + * projects.texi: Document restriction on SAL library names + +2011-09-02 Thomas Quinot <quinot@adacore.com> + + * a-chtgbo.adb: Minor comment fix. + +2011-09-02 Robert Dewar <dewar@adacore.com> + + * lib-xref.adb: Minor reformatting + +2011-09-02 Vincent Celier <celier@adacore.com> + + * bindusg.adb, clean.adb, gnatchop.adb, gnatfind.adb, gnatlink.adb, + gnatls.adb, gnatname.adb, gnatxref.adb, gprep.adb, makeusg.adb: Add + --version and --help in usage. + * switch.ads, switch.adb (Display_Usage_Version_And_Help): New procedure + +2011-09-02 Bob Duff <duff@adacore.com> + + * lib-xref.adb: (Hash): Avoid use of 'Mod attribute, because old + compilers don't understand it. + +2011-09-02 Gary Dismukes <dismukes@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Pass the + underlying subtype rather than its base type on the call to + Build_Record_Or_Elementary_Input_Function, so that any + constraints on a discriminated subtype will be available for + doing the check required by AI05-0192. + * exp_strm.adb (Build_Record_Or_Elementary_Input_Function): + If the prefix subtype of the 'Input attribute is a constrained + discriminated subtype, then check each constrained discriminant value + against the corresponding value read from the stream. + +2011-09-02 Yannick Moy <moy@adacore.com> + + * usage.adb, warnsw.adb, sem_ch6.adb, opt.ads: Disable by default + warnings on suspicious contracts, and enable them with -gnatwa. + +2011-09-02 Robert Dewar <dewar@adacore.com> + + * exp_util.adb, exp_ch9.adb, sem_attr.adb, sem_ch6.adb: Minor + reformatting. + +2011-09-02 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch9.adb (Install_Private_Data_Declarations): Add guards + which ensure that restriction No_Dynamic_Attachment has not been + violated. + (Make_Initialize_Protection): Protected types with attach or + interrupt handlers must not violate restriction No_Dynamic_Attachment. + * exp_util.adb (Corresponding_Runtime_Package): Add a guard + which ensures that restriction No_Dynamic_Attachment has not been + violated. + * sem_attr.adb: (Eval_Attribute): Transform + VAX_Float_Type'First and 'Last into references to + the temporaries which store the corresponding bounds. The + transformation is needed since the back end cannot evaluate + 'First and 'Last on VAX. + (Is_VAX_Float): New routine. + +2011-09-02 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Analyze_Subprogram_Instantiation): If the + generic unit is not intrinsic and has an explicit convention, + the instance inherits it. + +2011-09-02 Robert Dewar <dewar@adacore.com> + + * prj-dect.adb, prj-env.adb, prj-nmsc.adb, prj-proc.adb, prj-tree.adb, + prj.adb, prj.ads, sem_ch5.adb: Minor reformatting. + +2011-09-02 Thomas Quinot <quinot@adacore.com> + + * sem_attr.adb (Analyze_Attribute, case Unrestriced_Access): + Guard against a prefix that is an N_Has_Entity but has no + associated entity. + +2011-09-02 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb (Is_Alfa_Reference): Ignore IN parameters in Alfa + references. + +2011-09-02 Yannick Moy <moy@adacore.com> + + * opt.ads (Warn_On_Suspicious_Contract): New warning flag. + * sem_ch3.adb (Analyze_Declarations): Call checker for suspicious + contracts. + * sem_ch6.adb, sem_ch6.ads (Check_Subprogram_Contract): New + procedure looking for suspicious postconditions. + * usage.adb (Usage): New options -gnatw.t and -gnatw.T. + * warnsw.adb (Set_Dot_Warning_Switch): Take into account new + options -gnatw.t and -gnatw.T. + +2011-09-02 Pascal Obry <obry@adacore.com> + + * prj.adb: Minor code refactoring. Move check for null project in + Project_Changed. + * projects.texi: Fix minor typos. + +2011-09-02 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Iterator_Specification): If the domain + of iteration is an expression, its value must be captured in a + renaming declaration, so that modification of the elements is + propagated to the original container. + +2011-09-02 Pascal Obry <obry@adacore.com> + + * prj-proc.adb, prj.adb, makeutl.adb, makeutl.ads, prj-dect.adb, + prj-nmsc.adb, prj-util.adb, prj-conf.adb, prj-env.adb, + prj-tree.adb: Minor reformatting and style fixes. + +2011-09-02 Robert Dewar <dewar@adacore.com> + + * s-rident.ads: Add new restriction No_Implicit_Aliasing + * sem_attr.adb: (Analyze_Access_Attribute): Deal with + No_Implicit_Aliasing + (Analyze_Attribute, case Address): ditto + (Analyze_Attribute, case Unrestricted_Access): ditto + * sem_util.ads, sem_util.adb: (Is_Aliased_View): Handle + No_Implicit_Aliasing restriction. + * gnat_rm.texi: Add documentation for No_Implicit_Aliasing + +2011-09-02 Ed Schonberg <schonberg@adacore.com> + + * exp_util.adb: (Possible_Bit_Aligned_Object): If the object + is an unchecked conversion, apply test to its expression. + +2011-09-02 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Check_Abstract_Overriding): When + traversing the chain of aliased subprograms avoid reporting a + redundant error on the current entity. + +2011-09-02 Sergey Rybin <rybin@adacore.com> + + * gnat_ugn.texi: Minor clean up. + +2011-09-02 Bob Duff <duff@adacore.com> + + * s-htable.adb (Set_If_Not_Present): Use renaming + instead of ":=", because the type Key is limited in the generic (even + if not in the instances). + +2011-09-02 Robert Dewar <dewar@adacore.com> + + * exp_util.adb, sem_ch10.adb, sem_attr.adb, s-htable.adb, + g-comlin.adb, g-comlin.ads, lib-xref-alfa.adb, lib-xref.adb: Minor + reformatting. + +2011-09-02 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch3.adb: (Set_Anonymous_Type): Associate the itype of an + inherited component with the enclosing derived type. Code reformatting. + +2011-09-02 Gary Dismukes <dismukes@adacore.com> + + * checks.adb: (Determine_Range): Add test of OK1 to prevent the early + return done when overflow checks are enabled, since comparisons against + Lor and Hir should not be done when OK1 is False. + +2011-09-02 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call): + Add new formal Master_Exp. When present, add that expression to the + call as an extra actual. + (Make_Build_In_Place_Call_In_Object_Declaration): Add variable + Fmaster_Actual and in the case of a BIP call initializing a return + object of an enclosing BIP function set it to a + new reference to the implicit finalization master + formal of the enclosing function. Fmaster_Actual is + then passed to the new formal Master_Exp on the call to + Add_Finalization_Master_Actual_To_Build_ In_Place_Call. Move + initializations of Enclosing_Func to its declaration. + +2011-09-02 Thomas Quinot <quinot@adacore.com> + + * csets.ads: Minor reformatting + +2011-09-02 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_aggr.adb: (Get_Constraint_Association): Add code to retrieve + the full view of a private type coming from an instantiation. + * exp_ch4.adb: (Current_Anonymous_Master): Reimplement the search + loop to iterate over the declarations rather than use the + First_Entity / Next_Entity scheme. + 2011-09-02 Ed Schonberg <schonberg@adacore.com> * sem_attr.adb: (Analyze_Attribute, case 'Range): when expanding diff --git a/gcc/ada/a-cbprqu.adb b/gcc/ada/a-cbprqu.adb index ca049128005..09a06b277ad 100644 --- a/gcc/ada/a-cbprqu.adb +++ b/gcc/ada/a-cbprqu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- 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- -- diff --git a/gcc/ada/a-cbprqu.ads b/gcc/ada/a-cbprqu.ads index 9caef3482c2..589ee313894 100644 --- a/gcc/ada/a-cbprqu.ads +++ b/gcc/ada/a-cbprqu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 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 -- @@ -54,6 +54,10 @@ generic package Ada.Containers.Bounded_Priority_Queues is pragma Preelaborate; + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + package Implementation is type List_Type (Capacity : Count_Type) is tagged limited private; @@ -111,7 +115,6 @@ package Ada.Containers.Bounded_Priority_Queues is function Peak_Use return Count_Type; private - List : Implementation.List_Type (Capacity); end Queue; diff --git a/gcc/ada/a-cbsyqu.adb b/gcc/ada/a-cbsyqu.adb index cb2cbc5d4f7..462d6f4c95c 100644 --- a/gcc/ada/a-cbsyqu.adb +++ b/gcc/ada/a-cbsyqu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- 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- -- diff --git a/gcc/ada/a-cbsyqu.ads b/gcc/ada/a-cbsyqu.ads index 26e86bc1801..8d25359469d 100644 --- a/gcc/ada/a-cbsyqu.ads +++ b/gcc/ada/a-cbsyqu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 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 -- @@ -44,6 +44,10 @@ generic package Ada.Containers.Bounded_Synchronized_Queues is pragma Preelaborate; + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + package Implementation is type List_Type (Capacity : Count_Type) is tagged limited private; diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb index 9e7da11e7e6..1a395d3b34e 100644 --- a/gcc/ada/a-chtgbo.adb +++ b/gcc/ada/a-chtgbo.adb @@ -144,7 +144,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is -- 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 + -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add -- special-case checks at the point of call. if X = 0 then diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index e2532f85803..c6815d31ebb 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -358,7 +358,7 @@ package Ada.Containers.Vectors is return Vector_Iterator_Interfaces.Reversible_Iterator'Class; function Iterate (Container : Vector; Start : Cursor) - return Vector_Iterator_Interfaces.Reversible_Iterator'class; + return Vector_Iterator_Interfaces.Reversible_Iterator'Class; generic with function "<" (Left, Right : Element_Type) return Boolean is <>; diff --git a/gcc/ada/a-csquin.ads b/gcc/ada/a-csquin.ads index 4a544d43188..2a4d0b36eec 100644 --- a/gcc/ada/a-csquin.ads +++ b/gcc/ada/a-csquin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 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 -- diff --git a/gcc/ada/a-cuprqu.adb b/gcc/ada/a-cuprqu.adb index c1da3ee49cf..2d11a2621b3 100644 --- a/gcc/ada/a-cuprqu.adb +++ b/gcc/ada/a-cuprqu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- 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- -- diff --git a/gcc/ada/a-cuprqu.ads b/gcc/ada/a-cuprqu.ads index ac5b19e5373..d31c8824458 100644 --- a/gcc/ada/a-cuprqu.ads +++ b/gcc/ada/a-cuprqu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 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 -- @@ -52,6 +52,10 @@ generic package Ada.Containers.Unbounded_Priority_Queues is pragma Preelaborate; + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + package Implementation is type List_Type is tagged limited private; diff --git a/gcc/ada/a-cusyqu.adb b/gcc/ada/a-cusyqu.adb index 6a8e0d8506e..7fc01cc5fc9 100644 --- a/gcc/ada/a-cusyqu.adb +++ b/gcc/ada/a-cusyqu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- 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- -- diff --git a/gcc/ada/a-cusyqu.ads b/gcc/ada/a-cusyqu.ads index a8a2dda160c..98337a03587 100644 --- a/gcc/ada/a-cusyqu.ads +++ b/gcc/ada/a-cusyqu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 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 -- @@ -44,6 +44,10 @@ generic package Ada.Containers.Unbounded_Synchronized_Queues is pragma Preelaborate; + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + package Implementation is type List_Type is tagged limited private; diff --git a/gcc/ada/a-intnam-aix.ads b/gcc/ada/a-intnam-aix.ads index 8597c3b8fb5..308f55f82b5 100644 --- a/gcc/ada/a-intnam-aix.ads +++ b/gcc/ada/a-intnam-aix.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -52,6 +52,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + -- Beware that the mapping of names to signals may be many-to-one. There -- may be aliases. Also, for all signal names that are not supported on -- the current system the value of the corresponding constant will be zero. diff --git a/gcc/ada/a-intnam-darwin.ads b/gcc/ada/a-intnam-darwin.ads index c2b6b100834..4610876490f 100644 --- a/gcc/ada/a-intnam-darwin.ads +++ b/gcc/ada/a-intnam-darwin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -46,6 +46,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + -- Beware that the mapping of names to signals may be many-to-one. There -- may be aliases. Also, for all signal names that are not supported on the -- current system the value of the corresponding constant will be zero. diff --git a/gcc/ada/a-intnam-dummy.ads b/gcc/ada/a-intnam-dummy.ads index 02602b3c618..6e71411de2e 100644 --- a/gcc/ada/a-intnam-dummy.ads +++ b/gcc/ada/a-intnam-dummy.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (No Tasking Version) -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -40,6 +40,10 @@ package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1; DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2; diff --git a/gcc/ada/a-intnam-freebsd.ads b/gcc/ada/a-intnam-freebsd.ads index dd432acf710..7362f9f156a 100644 --- a/gcc/ada/a-intnam-freebsd.ads +++ b/gcc/ada/a-intnam-freebsd.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -35,6 +35,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + -- Beware that the mapping of names to signals may be many-to-one. There -- may be aliases. Also, for all signal names that are not supported on -- the current system the value of the corresponding constant will be zero. diff --git a/gcc/ada/a-intnam-hpux.ads b/gcc/ada/a-intnam-hpux.ads index 366a2404c30..db061a96b5c 100644 --- a/gcc/ada/a-intnam-hpux.ads +++ b/gcc/ada/a-intnam-hpux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + -- Beware that the mapping of names to signals may be many-to-one. There -- may be aliases. Also, for all signal names that are not supported on -- the current system the value of the corresponding constant will be zero. diff --git a/gcc/ada/a-intnam-irix.ads b/gcc/ada/a-intnam-irix.ads index 9c1cd028022..65859c091cd 100644 --- a/gcc/ada/a-intnam-irix.ads +++ b/gcc/ada/a-intnam-irix.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -53,6 +53,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + -- Beware that the mapping of names to signals may be many-to-one. There -- may be aliases. Also, for all signal names that are not supported on -- the current system the value of the corresponding constant will be zero. diff --git a/gcc/ada/a-intnam-linux.ads b/gcc/ada/a-intnam-linux.ads index 0b33efe813d..5003c20461a 100644 --- a/gcc/ada/a-intnam-linux.ads +++ b/gcc/ada/a-intnam-linux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -52,6 +52,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + -- Beware that the mapping of names to signals may be many-to-one. There -- may be aliases. Also, for all signal names that are not supported on the -- current system the value of the corresponding constant will be zero. diff --git a/gcc/ada/a-intnam-lynxos.ads b/gcc/ada/a-intnam-lynxos.ads index 13509e53fa0..c4e714c8696 100644 --- a/gcc/ada/a-intnam-lynxos.ads +++ b/gcc/ada/a-intnam-lynxos.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + -- Beware that the mapping of names to signals may be many-to-one. There -- may be aliases. diff --git a/gcc/ada/a-intnam-mingw.ads b/gcc/ada/a-intnam-mingw.ads index 7b790a6b191..3a2bcdc179f 100644 --- a/gcc/ada/a-intnam-mingw.ads +++ b/gcc/ada/a-intnam-mingw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -38,6 +38,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + -- Beware that the mapping of names to signals may be many-to-one. There -- may be aliases. Also, for all signal names that are not supported on the -- current system the value of the corresponding constant will be zero. diff --git a/gcc/ada/a-intnam-solaris.ads b/gcc/ada/a-intnam-solaris.ads index 88d4e2721ea..3ed974e7d4c 100644 --- a/gcc/ada/a-intnam-solaris.ads +++ b/gcc/ada/a-intnam-solaris.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -49,6 +49,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + -- Beware that the mapping of names to signals may be many-to-one. There -- may be aliases. Also, for all signal names that are not supported on the -- current system the value of the corresponding constant will be zero. diff --git a/gcc/ada/a-intnam-tru64.ads b/gcc/ada/a-intnam-tru64.ads index 281260b5de5..3ea1a4afd7c 100644 --- a/gcc/ada/a-intnam-tru64.ads +++ b/gcc/ada/a-intnam-tru64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + -- Beware that the mapping of names to signals may be many-to-one. There -- may be aliases. Also, for all signal names that are not supported on the -- current system the value of the corresponding constant will be zero. diff --git a/gcc/ada/a-intnam-vms.ads b/gcc/ada/a-intnam-vms.ads index f9086cce826..30f98d33466 100644 --- a/gcc/ada/a-intnam-vms.ads +++ b/gcc/ada/a-intnam-vms.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -38,6 +38,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + package OS renames System.OS_Interface; Interrupt_ID_0 : constant Interrupt_ID := OS.Interrupt_ID_0; diff --git a/gcc/ada/a-intnam-vxworks.ads b/gcc/ada/a-intnam-vxworks.ads index 7a6e364a7ad..0c043f45a07 100644 --- a/gcc/ada/a-intnam-vxworks.ads +++ b/gcc/ada/a-intnam-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -35,6 +35,10 @@ with System.OS_Interface; package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + subtype Hardware_Interrupts is Interrupt_ID range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt; -- Range of values that can be used for hardware interrupts diff --git a/gcc/ada/a-intnam.ads b/gcc/ada/a-intnam.ads index e055d6aa17e..f50c46a0df0 100644 --- a/gcc/ada/a-intnam.ads +++ b/gcc/ada/a-intnam.ads @@ -23,6 +23,10 @@ package Ada.Interrupts.Names is + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1; DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2; diff --git a/gcc/ada/a-iteint.ads b/gcc/ada/a-iteint.ads index 192bdcb430b..8ac9e1a12e2 100644 --- a/gcc/ada/a-iteint.ads +++ b/gcc/ada/a-iteint.ads @@ -6,27 +6,10 @@ -- -- -- 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/>. -- +-- 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. -- -- -- ------------------------------------------------------------------------------ @@ -34,17 +17,22 @@ generic type Cursor; with function Has_Element (Position : Cursor) return Boolean; pragma Unreferenced (Has_Element); + package Ada.Iterator_Interfaces is pragma Pure; type Forward_Iterator is limited interface; - function First (Object : Forward_Iterator) return Cursor is abstract; + + function First + (Object : Forward_Iterator) return Cursor is abstract; function Next (Object : Forward_Iterator; Position : Cursor) return Cursor is abstract; + type Reversible_Iterator is limited interface and Forward_Iterator; - function Last (Object : Reversible_Iterator) return Cursor is abstract; + function Last + (Object : Reversible_Iterator) return Cursor is abstract; function Previous (Object : Reversible_Iterator; Position : Cursor) return Cursor is abstract; diff --git a/gcc/ada/alfa.ads b/gcc/ada/alfa.ads index 95c4be3d902..7531f9e4b34 100644 --- a/gcc/ada/alfa.ads +++ b/gcc/ada/alfa.ads @@ -91,8 +91,7 @@ package Alfa is -- FS . scope line type col entity (-> spec-file . spec-scope)? - -- What is the ? marke here, is it part of the actual syntax, or is - -- it a query about a problem, in which case it should be ??? + -- (The ? mark stands for an optional entry in the syntax) -- scope is the ones-origin scope number for the current file (e.g. 2 = -- reference to the second FS line in this FD block). @@ -176,9 +175,9 @@ package Alfa is -- s = subprogram reference in a static call -- Special entries for reads and writes to memory reference a special - -- variable called "HEAP". These special entries are present in every scope - -- where reads and writes to memory are present. Line and column for this - -- special variable are always 0. + -- variable called "__HEAP". These special entries are present in every + -- scope where reads and writes to memory are present. Line and column for + -- this special variable are always 0. -- Examples: ??? add examples here @@ -336,7 +335,7 @@ package Alfa is -- Constants -- --------------- - Name_Of_Heap_Variable : constant String := "HEAP"; + Name_Of_Heap_Variable : constant String := "__HEAP"; -- Name of special variable used in effects to denote reads and writes -- through explicit dereference. diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 2b90ed7e6c1..93dd10956cc 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -504,6 +504,10 @@ package body ALI is or else Nextc = '<' or else Nextc = '>' or else Nextc = '='; + -- Terminate on comma + + exit when Nextc = ','; + -- Terminate if left bracket not part of wide char sequence -- Note that we only recognize brackets notation so far ??? @@ -2389,12 +2393,22 @@ package body ALI is -- Imported entities reference as in: -- 494b<c,__gnat_copy_attribs>25 - -- ??? Simply skipped for now if Nextc = '<' then - while Getc /= '>' loop - null; - end loop; + Skipc; + XR.Imported_Lang := Get_Name; + + pragma Assert (Nextc = ','); + Skipc; + + XR.Imported_Name := Get_Name; + + pragma Assert (Nextc = '>'); + Skipc; + + else + XR.Imported_Lang := No_Name; + XR.Imported_Name := No_Name; end if; XR.Col := Get_Nat; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 0a808179fde..b2b9b3d7ffc 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -975,6 +975,10 @@ package ALI is -- ref1 is a reference to an entity that was instantied at ref2. -- ref2 itself is also the result of an instantiation, that took -- place at ref3 + + Imported_Lang : Name_Id := No_Name; + Imported_Name : Name_Id := No_Name; + -- Language and name of imported entity reference end record; package Xref is new Table.Table ( diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index e762c872fcb..23840d3048c 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -25,6 +25,7 @@ with Osint; use Osint; with Output; use Output; +with Switch; use Switch; with System.WCh_Con; use System.WCh_Con; @@ -55,6 +56,8 @@ package body Bindusg is Write_Eol; Write_Eol; + Display_Usage_Version_And_Help; + -- Line for @response_file Write_Line (" @<resp_file> Get arguments from response file"); diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 3eb0c4ec141..0d2322afa6f 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1877,6 +1877,10 @@ package body Checks is if Is_Subscr_Ref then Arr := Prefix (Parnt); Arr_Typ := Get_Actual_Subtype_If_Available (Arr); + + if Is_Access_Type (Arr_Typ) then + Arr_Typ := Directly_Designated_Type (Arr_Typ); + end if; end if; if not Do_Range_Check (Expr) then @@ -3479,10 +3483,11 @@ package body Checks is -- to restrict the possible range of results. -- If one of the computed bounds is outside the range of the base type, - -- the expression may raise an exception and we better indicate that + -- the expression may raise an exception and we had better indicate that -- the evaluation has failed, at least if checks are enabled. - if Enable_Overflow_Checks + if OK1 + and then Enable_Overflow_Checks and then not Is_Entity_Name (N) and then (Lor < Lo or else Hir > Hi) then diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index d6dc8ba140e..f20253391cd 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -1893,6 +1893,8 @@ package body Clean is Put_Line ("Usage: gnatclean [switches] {[-innn] name}"); New_Line; + Display_Usage_Version_And_Help; + Put_Line (" names is one or more file names from which " & "the .adb or .ads suffix may be omitted"); Put_Line (" names may be omitted if -P<project> is specified"); diff --git a/gcc/ada/csets.ads b/gcc/ada/csets.ads index ebf167096e1..2f40e36aa8c 100644 --- a/gcc/ada/csets.ads +++ b/gcc/ada/csets.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- -- @@ -90,7 +90,7 @@ package Csets is -- This table has True entries for all characters that can legally appear -- in identifiers, including digits, the underline character, all letters -- including upper and lower case and extended letters (as controlled by - -- the setting of Opt.Identifier_Character_Set, left bracket for brackets + -- the setting of Opt.Identifier_Character_Set), left bracket for brackets -- notation wide characters and also ESC if wide characters are permitted -- in identifiers using escape sequences starting with ESC. diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 650b86e5dee..ce46e0f2809 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -442,8 +442,10 @@ package body CStand is begin -- Create type definition nodes for predefined float types - Copy_Float_Type (Standard_Short_Float, - Find_Back_End_Float_Type ("float")); + Copy_Float_Type + (Standard_Short_Float, + Find_Back_End_Float_Type ("float")); + Set_Is_Implementation_Defined (Standard_Short_Float); Copy_Float_Type (Standard_Float, Standard_Short_Float); @@ -476,6 +478,7 @@ package body CStand is LLF := Standard_Long_Float; end if; + Set_Is_Implementation_Defined (Standard_Long_Long_Float); Copy_Float_Type (Standard_Long_Long_Float, LLF); Append_Elmt (Standard_Long_Long_Float, Predefined_Float_Types); @@ -670,9 +673,11 @@ package body CStand is Build_Signed_Integer_Type (Standard_Long_Long_Integer, Standard_Long_Long_Integer_Size); + Set_Is_Implementation_Defined (Standard_Long_Long_Integer); Create_Unconstrained_Base_Type (Standard_Short_Short_Integer, E_Signed_Integer_Subtype); + Set_Is_Implementation_Defined (Standard_Short_Short_Integer); Create_Unconstrained_Base_Type (Standard_Short_Integer, E_Signed_Integer_Subtype); @@ -685,6 +690,7 @@ package body CStand is Create_Unconstrained_Base_Type (Standard_Long_Long_Integer, E_Signed_Integer_Subtype); + Set_Is_Implementation_Defined (Standard_Short_Short_Integer); Create_Float_Types; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 494f31b9f1c..4cbd4c5cb44 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -161,6 +161,7 @@ package body Einfo is -- Body_Entity Node19 -- Corresponding_Discriminant Node19 + -- Extra_Accessibility_Of_Result Node19 -- Parent_Subtype Node19 -- Related_Array_Object Node19 -- Size_Check_Code Node19 @@ -522,8 +523,7 @@ package body Einfo is -- Has_Implicit_Dereference Flag251 -- Is_Processed_Transient Flag252 -- Has_Anonymous_Master Flag253 - - -- (unused) Flag254 + -- Is_Implementation_Defined Flag254 ----------------------- -- Local subprograms -- @@ -1043,6 +1043,12 @@ package body Einfo is return Node13 (Id); end Extra_Accessibility; + function Extra_Accessibility_Of_Result (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type)); + return Node19 (Id); + end Extra_Accessibility_Of_Result; + function Extra_Constrained (Id : E) return E is begin pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); @@ -1873,6 +1879,11 @@ package body Einfo is return Flag7 (Id); end Is_Immediately_Visible; + function Is_Implementation_Defined (Id : E) return B is + begin + return Flag254 (Id); + end Is_Implementation_Defined; + function Is_Imported (Id : E) return B is begin return Flag24 (Id); @@ -3519,6 +3530,12 @@ package body Einfo is Set_Node13 (Id, V); end Set_Extra_Accessibility; + procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type)); + Set_Node19 (Id, V); + end Set_Extra_Accessibility_Of_Result; + procedure Set_Extra_Constrained (Id : E; V : E) is begin pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); @@ -4395,6 +4412,11 @@ package body Einfo is Set_Flag7 (Id, V); end Set_Is_Immediately_Visible; + procedure Set_Is_Implementation_Defined (Id : E; V : B := True) is + begin + Set_Flag254 (Id, V); + end Set_Is_Implementation_Defined; + procedure Set_Is_Imported (Id : E; V : B := True) is begin Set_Flag24 (Id, V); @@ -7551,6 +7573,7 @@ package body Einfo is W ("Is_Hidden", Flag57 (Id)); W ("Is_Hidden_Open_Scope", Flag171 (Id)); W ("Is_Immediately_Visible", Flag7 (Id)); + W ("Is_Implementation_Defined", Flag254 (Id)); W ("Is_Imported", Flag24 (Id)); W ("Is_Inlined", Flag11 (Id)); W ("Is_Instantiated", Flag126 (Id)); @@ -8312,6 +8335,9 @@ package body Einfo is when Private_Kind => Write_Str ("Underlying_Full_View"); + when E_Function | E_Operator | E_Subprogram_Type => + Write_Str ("Extra_Accessibility_Of_Result"); + when others => Write_Str ("Field19??"); end case; @@ -8686,9 +8712,12 @@ package body Einfo is procedure Write_Field28_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Procedure | + when E_Entry | + E_Entry_Family | E_Function | - E_Entry => + E_Procedure | + E_Subprogram_Body | + E_Subprogram_Type => Write_Str ("Extra_Formals"); when E_Record_Type => diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index c0dda86ca66..c366e0274b3 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -391,7 +391,7 @@ package Einfo is -- that holds value of the Aft attribute for the type. -- Alias (Node18) --- Present in overloaded entities (literals, subprograms, entries) and +-- Present in overloadable entities (literals, subprograms, entries) and -- subprograms that cover a primitive operation of an abstract interface -- (that is, subprograms with the Interface_Alias attribute). In case of -- overloaded entities it points to the parent subprogram of a derived @@ -442,6 +442,11 @@ package Einfo is -- declaration, the associated_node_for_itype is the discriminant -- specification. For an access parameter it is the enclosing subprogram -- declaration. +-- +-- Itypes have no explicit declaration, and therefore are not attached to +-- the tree: their Parent field is always empty. The Associated_Node_For_ +-- Itype is the only way to determine the construct that leads to the +-- creation of a given itype entity. -- Associated_Storage_Pool (Node22) [root type only] -- Present in simple and general access type entities. References the @@ -1115,9 +1120,9 @@ package Einfo is -- or entry. Returns Empty if there are no extra formals. -- Extra_Accessibility (Node13) --- Present in formal parameters in the non-generic case if expansion is --- active. Normally Empty, but if a parameter is one for which a dynamic --- accessibility check is required, then an extra formal of type +-- Present in formal parameters in the non-generic case. Normally Empty, +-- but if expansion is active, and a parameter is one for which a +-- dynamic accessibility check is required, then an extra formal of type -- Natural is created (see description of field Extra_Formal), and the -- Extra_Accessibility field of the formal parameter points to the entity -- for this extra formal. Also present in variables when compiling @@ -1126,9 +1131,18 @@ package Einfo is -- must be retrieved through the entity designed by this field instead of -- being computed. +-- Extra_Accessibility_Of_Result (Node19) +-- Present in (non-generic) Function, Operator, and Subprogram_Type +-- entities. Normally Empty, but if expansion is active, and a function +-- is one for which "the accessibility level of the result ... determined +-- by the point of call" (AI05-0234) is needed, then an extra formal of +-- subtype Natural is created (see description of field Extra_Formal), +-- and the Extra_Accessibility_Of_Result field of the function points to +-- the entity for this extra formal. + -- Extra_Constrained (Node23) --- Present in formal parameters in the non-generic case if expansion is --- active. Normally Empty, but if a parameter is one for which a dynamic +-- Present in formal parameters in the non-generic case. Normally Empty, +-- but if expansion is active and a parameter is one for which a dynamic -- indication of its constrained status is required, then an extra formal -- of type Boolean is created (see description of field Extra_Formal), -- and the Extra_Constrained field of the formal parameter points to the @@ -2278,6 +2292,12 @@ package Einfo is -- Present in all entities. Set if entity is immediately visible, i.e. -- is defined in some currently open scope (RM 8.3(4)). +-- Is_Implementation_Defined (Flag254) +-- Present in all entities. Set if a pragma Implementation_Defined is +-- applied to the pragma. Used to mark all implementation defined +-- identifiers in standard library packages, and to implement the +-- restriction No_Implementation_Identifiers. + -- Is_Imported (Flag24) -- Present in all entities. Set if the entity is imported. For now we -- only allow the import of exceptions, functions, procedures, packages. @@ -2839,11 +2859,10 @@ package Einfo is -- visible by selected notation, or not. -- Is_Visible_Formal (Flag206) --- Present in all entities. Set for instances of the formals of a formal --- package. Indicates that the entity must be made visible in the body --- of the instance, to reproduce the visibility of the generic. This --- simplifies visibility settings in instance bodies. --- ??? confusion in above comments between being present and being set +-- Present in all entities. Set True for instances of the formals of a +-- formal package. Indicates that the entity must be made visible in the +-- body of the instance, to reproduce the visibility of the generic. +-- This simplifies visibility settings in instance bodies. -- Is_VMS_Exception (Flag133) -- Present in all entities. Set only for exception entities where the @@ -4791,6 +4810,7 @@ package Einfo is -- Is_Hidden (Flag57) -- Is_Hidden_Open_Scope (Flag171) -- Is_Immediately_Visible (Flag7) + -- Is_Implementation_Defined (Flag254) -- Is_Imported (Flag24) -- Is_Inlined (Flag11) -- Is_Internal (Flag17) @@ -5137,6 +5157,7 @@ package Einfo is -- Protection_Object (Node23) (protected kind) -- Contract (Node24) (for entry only) -- PPC_Wrapper (Node25) + -- Extra_Formals (Node28) -- Default_Expressions_Processed (Flag108) -- Entry_Accepted (Flag152) -- Is_AST_Entry (Flag132) (for entry only) @@ -5229,6 +5250,7 @@ package Einfo is -- First_Entity (Node17) -- Alias (Node18) (non-generic case only) -- Renamed_Entity (Node18) (generic case only) + -- Extra_Accessibility_Of_Result (Node19) (non-generic case only) -- Last_Entity (Node20) -- Interface_Name (Node21) -- Scope_Depth_Value (Uint22) @@ -5383,6 +5405,7 @@ package Einfo is -- E_Operator -- First_Entity (Node17) -- Alias (Node18) + -- Extra_Accessibility_Of_Result (Node19) -- Last_Entity (Node20) -- Overridden_Operation (Node26) -- Subprograms_For_Type (Node29) @@ -5670,10 +5693,13 @@ package Einfo is -- Corresponding_Protected_Entry (Node18) -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) + -- Extra_Formals (Node28) -- Scope_Depth (synth) -- E_Subprogram_Type + -- Extra_Accessibility_Of_Result (Node19) -- Directly_Designated_Type (Node20) + -- Extra_Formals (Node28) -- First_Formal (synth) -- First_Formal_With_Extras (synth) -- Last_Formal (synth) @@ -6060,6 +6086,7 @@ package Einfo is function Esize (Id : E) return U; function Exception_Code (Id : E) return U; function Extra_Accessibility (Id : E) return E; + function Extra_Accessibility_Of_Result (Id : E) return E; function Extra_Constrained (Id : E) return E; function Extra_Formal (Id : E) return E; function Extra_Formals (Id : E) return E; @@ -6206,6 +6233,7 @@ package Einfo is function Is_Hidden (Id : E) return B; function Is_Hidden_Open_Scope (Id : E) return B; function Is_Immediately_Visible (Id : E) return B; + function Is_Implementation_Defined (Id : E) return B; function Is_Imported (Id : E) return B; function Is_Inlined (Id : E) return B; function Is_Interface (Id : E) return B; @@ -6648,6 +6676,7 @@ package Einfo is procedure Set_Esize (Id : E; V : U); procedure Set_Exception_Code (Id : E; V : U); procedure Set_Extra_Accessibility (Id : E; V : E); + procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E); procedure Set_Extra_Constrained (Id : E; V : E); procedure Set_Extra_Formal (Id : E; V : E); procedure Set_Extra_Formals (Id : E; V : E); @@ -6799,6 +6828,7 @@ package Einfo is procedure Set_Is_Hidden (Id : E; V : B := True); procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True); procedure Set_Is_Immediately_Visible (Id : E; V : B := True); + procedure Set_Is_Implementation_Defined (Id : E; V : B := True); procedure Set_Is_Imported (Id : E; V : B := True); procedure Set_Is_Inlined (Id : E; V : B := True); procedure Set_Is_Interface (Id : E; V : B := True); @@ -7351,6 +7381,7 @@ package Einfo is pragma Inline (Esize); pragma Inline (Exception_Code); pragma Inline (Extra_Accessibility); + pragma Inline (Extra_Accessibility_Of_Result); pragma Inline (Extra_Constrained); pragma Inline (Extra_Formal); pragma Inline (Extra_Formals); @@ -7523,6 +7554,7 @@ package Einfo is pragma Inline (Is_Hidden); pragma Inline (Is_Hidden_Open_Scope); pragma Inline (Is_Immediately_Visible); + pragma Inline (Is_Implementation_Defined); pragma Inline (Is_Imported); pragma Inline (Is_Incomplete_Or_Private_Type); pragma Inline (Is_Incomplete_Type); @@ -7795,6 +7827,7 @@ package Einfo is pragma Inline (Set_Esize); pragma Inline (Set_Exception_Code); pragma Inline (Set_Extra_Accessibility); + pragma Inline (Set_Extra_Accessibility_Of_Result); pragma Inline (Set_Extra_Constrained); pragma Inline (Set_Extra_Formal); pragma Inline (Set_Extra_Formals); @@ -7944,6 +7977,7 @@ package Einfo is pragma Inline (Set_Is_Hidden); pragma Inline (Set_Is_Hidden_Open_Scope); pragma Inline (Set_Is_Immediately_Visible); + pragma Inline (Set_Is_Implementation_Defined); pragma Inline (Set_Is_Imported); pragma Inline (Set_Is_Inlined); pragma Inline (Set_Is_Interface); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index a54ebe8b297..2dd052eb8f5 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -32,6 +32,7 @@ with Errout; use Errout; with Expander; use Expander; with Exp_Util; use Exp_Util; with Exp_Ch3; use Exp_Ch3; +with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; with Exp_Disp; use Exp_Disp; @@ -106,17 +107,14 @@ package body Exp_Aggr is ------------------------------------------------------ function Build_Record_Aggr_Code - (N : Node_Id; - Typ : Entity_Id; - Lhs : Node_Id; - Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id; + (N : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id) return List_Id; -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the -- aggregate. Target is an expression containing the location on which the -- component by component assignments will take place. Returns the list of -- assignments plus all other adjustments needed for tagged and controlled - -- types. Is_Limited_Ancestor_Expansion indicates that the function has - -- been called recursively to expand the limited ancestor to avoid copying - -- it. + -- types. procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the @@ -1731,10 +1729,9 @@ package body Exp_Aggr is ---------------------------- function Build_Record_Aggr_Code - (N : Node_Id; - Typ : Entity_Id; - Lhs : Node_Id; - Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id + (N : Node_Id; + Typ : Entity_Id; + Lhs : Node_Id) return List_Id is Loc : constant Source_Ptr := Sloc (N); L : constant List_Id := New_List; @@ -1984,10 +1981,23 @@ package body Exp_Aggr is -------------------------------- function Get_Constraint_Association (T : Entity_Id) return Node_Id is - Typ_Def : constant Node_Id := Type_Definition (Parent (T)); - Indic : constant Node_Id := Subtype_Indication (Typ_Def); + Indic : Node_Id; + Typ : Entity_Id; begin + Typ := T; + + -- Handle private types in instances + + if In_Instance + and then Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + Indic := Subtype_Indication (Type_Definition (Parent (Typ))); + -- ??? Also need to cover case of a type mark denoting a subtype -- with constraint. @@ -2154,7 +2164,7 @@ package body Exp_Aggr is Rewrite (Expr, Make_Attribute_Reference (Loc, Attribute_Name => Name_Unrestricted_Access, - Prefix => New_Copy_Tree (Prefix (Lhs)))); + Prefix => New_Copy_Tree (Lhs))); Set_Analyzed (Parent (Expr), False); else @@ -2321,11 +2331,10 @@ package body Exp_Aggr is Generate_Finalization_Actions; Append_List_To (L, - Build_Record_Aggr_Code ( - N => Unqualify (Ancestor), - Typ => Etype (Unqualify (Ancestor)), - Lhs => Target, - Is_Limited_Ancestor_Expansion => True)); + Build_Record_Aggr_Code + (N => Unqualify (Ancestor), + Typ => Etype (Unqualify (Ancestor)), + Lhs => Target)); -- If the ancestor part is an expression "E", we generate @@ -4591,6 +4600,21 @@ package body Exp_Aggr is or else Is_RTE (Ctyp, RE_Asm_Output_Operand) then return; + + -- Do not expand an aggregate for an array type which contains tasks if + -- the aggregate is associated with an unexpanded return statement of a + -- build-in-place function. The aggregate is expanded when the related + -- return statement (rewritten into an extended return) is processed. + -- This delay ensures that any temporaries and initialization code + -- generated for the aggregate appear in the proper return block and + -- use the correct _chain and _master. + + elsif Has_Task (Base_Type (Etype (N))) + and then Nkind (Parent (N)) = N_Simple_Return_Statement + and then Is_Build_In_Place_Function + (Return_Applies_To (Return_Statement_Entity (Parent (N)))) + then + return; end if; -- If the semantic analyzer has determined that aggregate N will raise diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index c38a3844a78..897844bb8e4 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1799,6 +1799,29 @@ package body Exp_Attr is Analyze_And_Resolve (N, Typ); end Count; + --------------------- + -- Descriptor_Size -- + --------------------- + + when Attribute_Descriptor_Size => + + -- Attribute Descriptor_Size is handled by the back end when applied + -- to an unconstrained array type. + + if Is_Array_Type (Ptyp) + and then not Is_Constrained (Ptyp) + then + Apply_Universal_Integer_Attribute_Checks (N); + + -- For any other type, the descriptor size is 0 because there is no + -- actual descriptor, but the result is not formally static. + + else + Rewrite (N, Make_Integer_Literal (Loc, 0)); + Analyze (N); + Set_Is_Static_Expression (N, False); + end if; + --------------- -- Elab_Body -- --------------- @@ -2531,8 +2554,12 @@ package body Exp_Attr is return; end if; + -- Build the type's Input function, passing the subtype rather + -- than its base type, because checks are needed in the case of + -- constrained discriminants (see Ada 2012 AI05-0192). + Build_Record_Or_Elementary_Input_Function - (Loc, Base_Type (U_Type), Decl, Fname); + (Loc, U_Type, Decl, Fname); Insert_Action (N, Decl); if Nkind (Parent (N)) = N_Object_Declaration diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 464fdef4024..fecbf5ce26b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1563,7 +1563,21 @@ package body Exp_Ch3 is Discriminant_Constraint (Full_Type)); end; - if In_Init_Proc then + -- If the target has access discriminants, and is constrained by + -- an access to the enclosing construct, i.e. a current instance, + -- replace the reference to the type by a reference to the object. + + if Nkind (Arg) = N_Attribute_Reference + and then Is_Access_Type (Etype (Arg)) + and then Is_Entity_Name (Prefix (Arg)) + and then Is_Type (Entity (Prefix (Arg))) + then + Arg := + Make_Attribute_Reference (Loc, + Prefix => New_Copy (Prefix (Id_Ref)), + Attribute_Name => Name_Unrestricted_Access); + + elsif In_Init_Proc then -- Replace any possible references to the discriminant in the -- call to the record initialization procedure with references @@ -1574,19 +1588,6 @@ package body Exp_Ch3 is then Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc); - -- Case of access discriminants. We replace the reference - -- to the type by a reference to the actual object - - elsif Nkind (Arg) = N_Attribute_Reference - and then Is_Access_Type (Etype (Arg)) - and then Is_Entity_Name (Prefix (Arg)) - and then Is_Type (Entity (Prefix (Arg))) - then - Arg := - Make_Attribute_Reference (Loc, - Prefix => New_Copy (Prefix (Id_Ref)), - Attribute_Name => Name_Unrestricted_Access); - -- Otherwise make a copy of the default expression. Note that -- we use the current Sloc for this, because we do not want the -- call to appear to be at the declaration point. Within the @@ -4841,11 +4842,11 @@ package body Exp_Ch3 is return; -- Ada 2005 (AI-251): Rewrite the expression that initializes a - -- class-wide object to ensure that we copy the full object, - -- unless we are targetting a VM where interfaces are handled by - -- VM itself. Note that if the root type of Typ is an ancestor - -- of Expr's type, both types share the same dispatch table and - -- there is no need to displace the pointer. + -- class-wide interface object to ensure that we copy the full + -- object, unless we are targetting a VM where interfaces are handled + -- by VM itself. Note that if the root type of Typ is an ancestor of + -- Expr's type, both types share the same dispatch table and there is + -- no need to displace the pointer. elsif Comes_From_Source (N) and then Is_Interface (Typ) @@ -4978,13 +4979,30 @@ package body Exp_Ch3 is -- Copy the object - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Obj_Id, - Object_Definition => - New_Occurrence_Of - (Etype (Object_Definition (N)), Loc), - Expression => New_Expr)); + if not Is_Limited_Record (Expr_Typ) then + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => + New_Occurrence_Of + (Etype (Object_Definition (N)), Loc), + Expression => New_Expr)); + + -- Rename limited type object since they cannot be copied + -- This case occurs when the initialization expression + -- has been previously expanded into a temporary object. + + else pragma Assert (not Comes_From_Source (Expr_Q)); + Insert_Action (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Obj_Id, + Subtype_Mark => + New_Occurrence_Of + (Etype (Object_Definition (N)), Loc), + Name => + Unchecked_Convert_To + (Etype (Object_Definition (N)), New_Expr))); + end if; -- Dynamically reference the tag associated with the -- interface. @@ -5634,6 +5652,12 @@ package body Exp_Ch3 is elsif CodePeer_Mode then return; + + -- Do not create TSS routine Finalize_Address when compiling in Alfa + -- mode because it is not necessary and results in useless expansion. + + elsif Alfa_Mode then + return; end if; -- Create the body of TSS primitive Finalize_Address. This automatically @@ -6379,11 +6403,14 @@ package body Exp_Ch3 is -- Create the body of TSS primitive Finalize_Address. This must -- be done before the bodies of all predefined primitives are - -- created. If Def_Id is limited, Stream_Input and Streap_Read - -- may produce build-in-place allocations and for that the - -- expander needs Finalize_Address. + -- created. If Def_Id is limited, Stream_Input and Stream_Read + -- may produce build-in-place allocations and for those the + -- expander needs Finalize_Address. Do not create the body of + -- Finalize_Address in Alfa mode since it is not needed. - Make_Finalize_Address_Body (Def_Id); + if not Alfa_Mode then + Make_Finalize_Address_Body (Def_Id); + end if; Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); Append_Freeze_Actions (Def_Id, Predef_List); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 3c6754b26bb..aef54a60ec2 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -380,12 +380,11 @@ package body Exp_Ch4 is ------------------------------ 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; + Decls : List_Id; + Loc : Source_Ptr; + Subp_Body : Node_Id; + Unit_Decl : Node_Id; + Unit_Id : Entity_Id; begin Unit_Id := Cunit_Entity (Current_Sem_Unit); @@ -440,21 +439,35 @@ package body Exp_Ch4 is -- declarations and locate the entity. if Has_Anonymous_Master (Unit_Id) then - Fin_Mas_Id := First_Entity (Unit_Id); - while Present (Fin_Mas_Id) loop + declare + Decl : Node_Id; + Fin_Mas_Id : Entity_Id; - -- Look for the first variable whose type is Finalization_Master + begin + Decl := First (Decls); + while Present (Decl) loop - if Ekind (Fin_Mas_Id) = E_Variable - and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master) - then - return Fin_Mas_Id; - end if; + -- Look for the first variable in the declarations whole type + -- is Finalization_Master. - Next_Entity (Fin_Mas_Id); - end loop; + if Nkind (Decl) = N_Object_Declaration then + Fin_Mas_Id := Defining_Identifier (Decl); - raise Program_Error; + if Ekind (Fin_Mas_Id) = E_Variable + and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master) + then + return Fin_Mas_Id; + end if; + end if; + + Next (Decl); + end loop; + + -- The master was not found even though the unit was labeled as + -- having one. + + raise Program_Error; + end; -- Create a new anonymous master @@ -462,6 +475,7 @@ package body Exp_Ch4 is declare First_Decl : constant Node_Id := First (Decls); Action : Node_Id; + Fin_Mas_Id : Entity_Id; begin -- Since the master and its associated initialization is inserted @@ -751,11 +765,38 @@ package body Exp_Ch4 is -- Start of processing for Expand_Allocator_Expression begin - -- WOuld be nice to comment the branches of this very long if ??? + -- In the case of an Ada2012 allocator whose initial value comes from a + -- function call, pass "the accessibility level determined by the point + -- of call" (AI05-0234) to the function. Conceptually, this belongs in + -- Expand_Call but it couldn't be done there (because the Etype of the + -- allocator wasn't set then) so we generate the parameter here. See + -- the Boolean variable Defer in (a block within) Expand_Call. + + if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then + declare + Subp : Entity_Id; - if Is_Tagged_Type (T) - or else Needs_Finalization (T) - then + begin + if Nkind (Name (Exp)) = N_Explicit_Dereference then + Subp := Designated_Type (Etype (Prefix (Name (Exp)))); + else + Subp := Entity (Name (Exp)); + end if; + + Subp := Ultimate_Alias (Subp); + + if Present (Extra_Accessibility_Of_Result (Subp)) then + Add_Extra_Actual_To_Call + (Subprogram_Call => Exp, + Extra_Formal => Extra_Accessibility_Of_Result (Subp), + Extra_Actual => Dynamic_Accessibility_Level (PtrT)); + end if; + end; + end if; + + -- Would be nice to comment the branches of this very long if ??? + + if Is_Tagged_Type (T) or else Needs_Finalization (T) then if Is_CPP_Constructor_Call (Exp) then -- Generate: @@ -797,10 +838,10 @@ package body Exp_Ch4 is Insert_List_After_And_Analyze (P, Build_Initialization_Call (Loc, - Id_Ref => + Id_Ref => Make_Explicit_Dereference (Loc, Prefix => New_Reference_To (Temp, Loc)), - Typ => Etype (Exp), + Typ => Etype (Exp), Constructor_Ref => Exp)); end; @@ -1135,12 +1176,19 @@ package body Exp_Ch4 is -- Generate: -- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access); - -- 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. Do not create - -- this call if there is no allocator available any more. + -- Do not generate this call in the following cases: + + -- * .NET/JVM - these targets do not support address arithmetic + -- and unchecked conversion, key elements of Finalize_Address. + + -- * Alfa mode - the call is useless and results in unwanted + -- expansion. + + -- * CodePeer mode - TSS primitive Finalize_Address is not + -- created in this mode. if VM_Target = No_VM + and then not Alfa_Mode and then not CodePeer_Mode and then Present (Finalization_Master (PtrT)) and then Present (Temp_Decl) @@ -3467,9 +3515,12 @@ package body Exp_Ch4 is end if; -- The finalization master must be inserted and analyzed as part of - -- the current semantic unit. + -- the current semantic unit. This form of expansion is not carried + -- out in Alfa mode because it is useless. - if No (Finalization_Master (PtrT)) then + if No (Finalization_Master (PtrT)) + and then not Alfa_Mode + then Set_Finalization_Master (PtrT, Current_Anonymous_Master); end if; end if; @@ -3965,10 +4016,17 @@ package body Exp_Ch4 is -- Set_Finalize_Address -- (<PtrT>FM, <T>FD'Unrestricted_Access); - -- Do not generate the above for CodePeer compilations - -- because primitive Finalize_Address is never built. + -- Do not generate this call in the following cases: + -- + -- * Alfa mode - the call is useless and results in + -- unwanted expansion. + -- + -- * CodePeer mode - TSS primitive Finalize_Address is + -- not created in this mode. - elsif not CodePeer_Mode then + elsif not Alfa_Mode + and then not CodePeer_Mode + then Insert_Action (N, Make_Set_Finalize_Address_Call (Loc => Loc, @@ -4093,14 +4151,13 @@ package body Exp_Ch4 is Alt := First (Alternatives (N)); while Present (Alt) loop declare - Aexp : Node_Id := Expression (Alt); - Aloc : constant Source_Ptr := Sloc (Aexp); + Aexp : Node_Id := Expression (Alt); + Aloc : constant Source_Ptr := Sloc (Aexp); + Stats : List_Id; begin - -- Propagate declarations inserted in the node by Insert_Actions - -- (for example, temporaries generated to remove side effects). - - Append_List_To (Actions, Sinfo.Actions (Alt)); + -- As described above, take Unrestricted_Access for case of non- + -- scalar types, to avoid big copies, and special cases. if not Is_Scalar_Type (Typ) then Aexp := @@ -4109,14 +4166,25 @@ package body Exp_Ch4 is Attribute_Name => Name_Unrestricted_Access); end if; + Stats := New_List ( + Make_Assignment_Statement (Aloc, + Name => New_Occurrence_Of (Tnn, Loc), + Expression => Aexp)); + + -- Propagate declarations inserted in the node by Insert_Actions + -- (for example, temporaries generated to remove side effects). + -- These actions must remain attached to the alternative, given + -- that they are generated by the corresponding expression. + + if Present (Sinfo.Actions (Alt)) then + Prepend_List (Sinfo.Actions (Alt), Stats); + end if; + Append_To (Alternatives (Cstmt), Make_Case_Statement_Alternative (Sloc (Alt), Discrete_Choices => Discrete_Choices (Alt), - Statements => New_List ( - Make_Assignment_Statement (Aloc, - Name => New_Occurrence_Of (Tnn, Loc), - Expression => Aexp)))); + Statements => Stats)); end; Next (Alt); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 75746422125..8955e5d9174 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -29,6 +29,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Elists; use Elists; +with Exp_Aggr; use Exp_Aggr; with Exp_Atag; use Exp_Atag; with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; @@ -103,21 +104,16 @@ package body Exp_Ch6 is -- present, then use it, otherwise pass a literal corresponding to the -- Alloc_Form parameter (which must not be Unspecified in that case). - procedure Add_Extra_Actual_To_Call - (Subprogram_Call : Node_Id; - Extra_Formal : Entity_Id; - Extra_Actual : Node_Id); - -- Adds Extra_Actual as a named parameter association for the formal - -- Extra_Formal in Subprogram_Call. - procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call - (Func_Call : Node_Id; - Func_Id : Entity_Id; - Ptr_Typ : Entity_Id := Empty); + (Func_Call : Node_Id; + Func_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty; + Master_Exp : Node_Id := Empty); -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs -- finalization actions, add an actual parameter which is a pointer to the - -- finalization master of the caller. If Ptr_Typ is left Empty, this will - -- result in an automatic "null" value for the actual. + -- finalization master of the caller. If Master_Exp is not Empty, then that + -- will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this + -- will result in an automatic "null" value for the actual. procedure Add_Task_Actuals_To_Build_In_Place_Call (Function_Call : Node_Id; @@ -177,7 +173,7 @@ package body Exp_Ch6 is procedure Expand_Non_Function_Return (N : Node_Id); -- Called by Expand_N_Simple_Return_Statement in case we're returning from -- a procedure body, entry body, accept statement, or extended return - -- statement. Note that all non-function returns are simple return + -- statement. Note that all non-function returns are simple return -- statements. function Expand_Protected_Object_Reference @@ -193,6 +189,11 @@ package body Exp_Ch6 is -- reference to the object itself, and the call becomes a call to the -- corresponding protected subprogram. + function Has_Unconstrained_Access_Discriminants + (Subtyp : Entity_Id) return Boolean; + -- Returns True if the given subtype is unconstrained and has one + -- or more access discriminants. + procedure Expand_Simple_Function_Return (N : Node_Id); -- Expand simple return from function. In the case where we are returning -- from a function body this is called by Expand_N_Simple_Return_Statement. @@ -311,9 +312,10 @@ package body Exp_Ch6 is ----------------------------------------------------------- procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call - (Func_Call : Node_Id; - Func_Id : Entity_Id; - Ptr_Typ : Entity_Id := Empty) + (Func_Call : Node_Id; + Func_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty; + Master_Exp : Node_Id := Empty) is begin if not Needs_BIP_Finalization_Master (Func_Id) then @@ -329,9 +331,16 @@ package body Exp_Ch6 is Desig_Typ : Entity_Id; begin + -- If there is a finalization master actual, such as the implicit + -- finalization master of an enclosing build-in-place function, + -- then this must be added as an extra actual of the call. + + if Present (Master_Exp) then + Actual := Master_Exp; + -- Case where the context does not require an actual master - if No (Ptr_Typ) then + elsif No (Ptr_Typ) then Actual := Make_Null (Loc); else @@ -459,7 +468,7 @@ package body Exp_Ch6 is begin -- No such extra parameters are needed if there are no tasks - if not Has_Task (Etype (Function_Id)) then + if not Has_Task (Available_View (Etype (Function_Id))) then return; end if; @@ -467,6 +476,12 @@ package body Exp_Ch6 is if Restriction_Active (No_Task_Hierarchy) then Actual := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc); + + -- In the case where we use the master associated with an access type, + -- the actual is an entity and requires an explicit reference. + + elsif Nkind (Actual) = N_Defining_Identifier then + Actual := New_Reference_To (Actual, Loc); end if; -- The master @@ -483,8 +498,7 @@ package body Exp_Ch6 is -- Build the parameter association for the new actual and add it to -- the end of the function's actuals. - Add_Extra_Actual_To_Call - (Function_Call, Master_Formal, Actual); + Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual); end; -- The activation chain @@ -496,8 +510,8 @@ package body Exp_Ch6 is begin -- Locate implicit activation chain parameter in the called function - Activation_Chain_Formal := Build_In_Place_Formal - (Function_Id, BIP_Activation_Chain); + Activation_Chain_Formal := + Build_In_Place_Formal (Function_Id, BIP_Activation_Chain); -- Create the actual which is a pointer to the current activation -- chain @@ -552,6 +566,16 @@ package body Exp_Ch6 is -- Maybe it would be better for each implicit formal of a build-in-place -- function to have a flag or a Uint attribute to identify it. ??? + -- The return type in the function declaration may have been a limited + -- view, and the extra formals for the function were not generated at + -- that point. At the point of call the full view must be available and + -- the extra formals can be created. + + if No (Extra_Formal) then + Create_Extra_Formals (Func); + Extra_Formal := Extra_Formals (Func); + end if; + loop pragma Assert (Present (Extra_Formal)); exit when @@ -1823,8 +1847,10 @@ package body Exp_Ch6 is if No (Prev) then if No (Parameter_Associations (Call_Node)) then Set_Parameter_Associations (Call_Node, New_List); - Append (Insert_Param, Parameter_Associations (Call_Node)); end if; + + Append (Insert_Param, Parameter_Associations (Call_Node)); + else Insert_After (Prev, Insert_Param); end if; @@ -2725,6 +2751,120 @@ package body Exp_Ch6 is Next_Formal (Formal); end loop; + -- If we are calling an Ada2012 function which needs to have the + -- "accessibility level determined by the point of call" (AI05-0234) + -- passed in to it, then pass it in. + + if Ekind_In (Subp, E_Function, E_Operator, E_Subprogram_Type) + and then + Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))) + then + declare + Ancestor : Node_Id := Parent (Call_Node); + Level : Node_Id := Empty; + Defer : Boolean := False; + + begin + -- Unimplemented: if Subp returns an anonymous access type, then + + -- a) if the call is the operand of an explict conversion, then + -- the target type of the conversion (a named access type) + -- determines the accessibility level pass in; + + -- b) if the call defines an access discriminant of an object + -- (e.g., the discriminant of an object being created by an + -- allocator, or the discriminant of a function result), + -- then the accessibility level to pass in is that of the + -- discriminated object being initialized). + + -- ??? + + while Nkind (Ancestor) = N_Qualified_Expression + loop + Ancestor := Parent (Ancestor); + end loop; + + case Nkind (Ancestor) is + when N_Allocator => + + -- At this point, we'd like to assign + + -- Level := Dynamic_Accessibility_Level (Ancestor); + + -- but Etype of Ancestor may not have been set yet, + -- so that doesn't work. + + -- Handle this later in Expand_Allocator_Expression. + + Defer := True; + + when N_Object_Declaration | N_Object_Renaming_Declaration => + declare + Def_Id : constant Entity_Id := + Defining_Identifier (Ancestor); + + begin + if Is_Return_Object (Def_Id) then + if Present (Extra_Accessibility_Of_Result + (Return_Applies_To (Scope (Def_Id)))) + then + -- Pass along value that was passed in if the + -- routine we are returning from also has an + -- Accessibility_Of_Result formal. + + Level := + New_Occurrence_Of + (Extra_Accessibility_Of_Result + (Return_Applies_To (Scope (Def_Id))), Loc); + end if; + else + Level := + Make_Integer_Literal (Loc, + Intval => Object_Access_Level (Def_Id)); + end if; + end; + + when N_Simple_Return_Statement => + if Present (Extra_Accessibility_Of_Result + (Return_Applies_To + (Return_Statement_Entity (Ancestor)))) + then + -- Pass along value that was passed in if the routine + -- we are returning from also has an + -- Accessibility_Of_Result formal. + + Level := + New_Occurrence_Of + (Extra_Accessibility_Of_Result + (Return_Applies_To + (Return_Statement_Entity (Ancestor))), Loc); + end if; + + when others => + null; + end case; + + if not Defer then + if not Present (Level) then + + -- The "innermost master that evaluates the function call". + + -- ??? - Should we use Integer'Last here instead in order + -- to deal with (some of) the problems associated with + -- calls to subps whose enclosing scope is unknown (e.g., + -- Anon_Access_To_Subp_Param.all)? + + Level := Make_Integer_Literal (Loc, + Scope_Depth (Current_Scope) + 1); + end if; + + Add_Extra_Actual + (Level, + Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))); + end if; + end; + end if; + -- If we are expanding a rhs of an assignment we need to check if tag -- propagation is needed. You might expect this processing to be in -- Analyze_Assignment but has to be done earlier (bottom-up) because the @@ -3600,8 +3740,15 @@ package body Exp_Ch6 is New_A : Node_Id; Num_Ret : Int := 0; Ret_Type : Entity_Id; - Targ : Node_Id; - Targ1 : Node_Id; + + Targ : Node_Id; + -- The target of the call. If context is an assignment statement then + -- this is the left-hand side of the assignment. else it is a temporary + -- to which the return value is assigned prior to rewriting the call. + + Targ1 : Node_Id; + -- A separate target used when the return type is unconstrained + Temp : Entity_Id; Temp_Typ : Entity_Id; @@ -3609,8 +3756,8 @@ package body Exp_Ch6 is -- Entity in declaration in an extended_return_statement Is_Unc : constant Boolean := - Is_Array_Type (Etype (Subp)) - and then not Is_Constrained (Etype (Subp)); + Is_Array_Type (Etype (Subp)) + and then not Is_Constrained (Etype (Subp)); -- If the type returned by the function is unconstrained and the call -- can be inlined, special processing is required. @@ -3701,6 +3848,7 @@ package body Exp_Ch6 is Rewrite (N, New_Copy (A)); end if; end if; + return Skip; elsif Is_Entity_Name (N) @@ -3751,8 +3899,8 @@ package body Exp_Ch6 is if Nkind_In (Expression (N), N_Aggregate, N_Null) then Ret := Make_Qualified_Expression (Sloc (N), - Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), - Expression => Relocate_Node (Expression (N))); + Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), + Expression => Relocate_Node (Expression (N))); else Ret := Unchecked_Convert_To @@ -3762,12 +3910,12 @@ package body Exp_Ch6 is if Nkind (Targ) = N_Defining_Identifier then Rewrite (N, Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Targ, Loc), + Name => New_Occurrence_Of (Targ, Loc), Expression => Ret)); else Rewrite (N, Make_Assignment_Statement (Loc, - Name => New_Copy (Targ), + Name => New_Copy (Targ), Expression => Ret)); end if; @@ -3775,19 +3923,17 @@ package body Exp_Ch6 is if Present (Exit_Lab) then Insert_After (N, - Make_Goto_Statement (Loc, - Name => New_Copy (Lab_Id))); + Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); end if; end if; return OK; - elsif Nkind (N) = N_Extended_Return_Statement then - - -- An extended return becomes a block whose first statement is - -- the assignment of the initial expression of the return object - -- to the target of the call itself. + -- An extended return becomes a block whose first statement is the + -- assignment of the initial expression of the return object to the + -- target of the call itself. + elsif Nkind (N) = N_Extended_Return_Statement then declare Return_Decl : constant Entity_Id := First (Return_Object_Declarations (N)); @@ -3800,12 +3946,12 @@ package body Exp_Ch6 is if Nkind (Targ) = N_Defining_Identifier then Assign := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Targ, Loc), + Name => New_Occurrence_Of (Targ, Loc), Expression => Expression (Return_Decl)); else Assign := Make_Assignment_Statement (Loc, - Name => New_Copy (Targ), + Name => New_Copy (Targ), Expression => Expression (Return_Decl)); end if; @@ -3871,7 +4017,6 @@ package body Exp_Ch6 is and then Nkind (Fst) = N_Assignment_Statement and then No (Next (Fst)) then - -- The function call may have been rewritten as the temporary -- that holds the result of the call, in which case remove the -- now useless declaration. @@ -3891,12 +4036,20 @@ package body Exp_Ch6 is Insert_After (Parent (Entity (N)), Blk); + -- If the context is an assignment, and the left-hand side is free of + -- side-effects, the replacement is also safe. + -- Can this be generalized further??? + elsif Nkind (Parent (N)) = N_Assignment_Statement and then (Is_Entity_Name (Name (Parent (N))) - or else - (Nkind (Name (Parent (N))) = N_Explicit_Dereference - and then Is_Entity_Name (Prefix (Name (Parent (N)))))) + or else + (Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N))))) + + or else + (Nkind (Name (Parent (N))) = N_Selected_Component + and then Is_Entity_Name (Prefix (Name (Parent (N)))))) then -- Replace assignment with the block @@ -3932,6 +4085,7 @@ package body Exp_Ch6 is procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is HSS : constant Node_Id := Handled_Statement_Sequence (Blk); + begin -- If there is a transient scope for N, this will be the scope of the -- actions for N, and the statements in Blk need to be within this @@ -4013,7 +4167,6 @@ package body Exp_Ch6 is -- Start of processing for Expand_Inlined_Call begin - -- Check for an illegal attempt to inline a recursive procedure. If the -- subprogram has parameters this is detected when trying to supply a -- binding for parameters that already have one. For parameterless @@ -4061,22 +4214,27 @@ package body Exp_Ch6 is Set_Declarations (Blk, New_List); end if; - -- For the unconstrained case, capture the name of the local - -- variable that holds the result. This must be the first declaration - -- in the block, because its bounds cannot depend on local variables. - -- Otherwise there is no way to declare the result outside of the - -- block. Needless to say, in general the bounds will depend on the - -- actuals in the call. + -- For the unconstrained case, capture the name of the local variable + -- that holds the result. This must be the first declaration in the + -- block, because its bounds cannot depend on local variables. Otherwise + -- there is no way to declare the result outside of the block. Needless + -- to say, in general the bounds will depend on the actuals in the call. + + -- If the context is an assignment statement, as is the case for the + -- expansion of an extended return, the left-hand side provides bounds + -- even if the return type is unconstrained. if Is_Unc then - Targ1 := Defining_Identifier (First (Declarations (Blk))); + if Nkind (Parent (N)) /= N_Assignment_Statement then + Targ1 := Defining_Identifier (First (Declarations (Blk))); + else + Targ1 := Name (Parent (N)); + end if; end if; -- If this is a derived function, establish the proper return type - if Present (Orig_Subp) - and then Orig_Subp /= Subp - then + if Present (Orig_Subp) and then Orig_Subp /= Subp then Ret_Type := Etype (Orig_Subp); else Ret_Type := Etype (Subp); @@ -4101,8 +4259,7 @@ package body Exp_Ch6 is if Is_Class_Wide_Type (Etype (F)) or else (Is_Access_Type (Etype (F)) - and then - Is_Class_Wide_Type (Designated_Type (Etype (F)))) + and then Is_Class_Wide_Type (Designated_Type (Etype (F)))) then Temp_Typ := Etype (F); @@ -4110,7 +4267,6 @@ package body Exp_Ch6 is and then Etype (F) /= Base_Type (Etype (F)) then Temp_Typ := Etype (F); - else Temp_Typ := Etype (A); end if; @@ -4136,13 +4292,13 @@ package body Exp_Ch6 is or else (Nkind_In (A, N_Real_Literal, - N_Integer_Literal, - N_Character_Literal) - and then not Address_Taken (F)) + N_Integer_Literal, + N_Character_Literal) + and then not Address_Taken (F)) then if Etype (F) /= Etype (A) then Set_Renamed_Object - (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); + (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); else Set_Renamed_Object (F, A); end if; @@ -4188,9 +4344,9 @@ package body Exp_Ch6 is if Ekind (F) = E_In_Parameter and then not Is_By_Reference_Type (Etype (A)) and then - (not Is_Array_Type (Etype (A)) - or else not Is_Object_Reference (A) - or else Is_Bit_Packed_Array (Etype (A))) + (not Is_Array_Type (Etype (A)) + or else not Is_Object_Reference (A) + or else Is_Bit_Packed_Array (Etype (A))) then Decl := Make_Object_Declaration (Loc, @@ -4232,6 +4388,12 @@ package body Exp_Ch6 is then Targ := Name (Parent (N)); + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then Nkind (Name (Parent (N))) = N_Selected_Component + and then Is_Entity_Name (Prefix (Name (Parent (N)))) + then + Targ := New_Copy_Tree (Name (Parent (N))); + elsif Nkind (Parent (N)) = N_Object_Declaration and then Is_Limited_Type (Etype (Subp)) then @@ -4248,11 +4410,13 @@ package body Exp_Ch6 is -- eventually be possible to remove that temporary and use the -- result variable directly. - if Is_Unc then + if Is_Unc + and then Nkind (Parent (N)) /= N_Assignment_Statement + then Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, - Object_Definition => + Object_Definition => New_Copy_Tree (Object_Definition (Parent (Targ1)))); Replace_Formals (Decl); @@ -4261,8 +4425,7 @@ package body Exp_Ch6 is Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (Ret_Type, Loc)); + Object_Definition => New_Occurrence_Of (Ret_Type, Loc)); Set_Etype (Temp, Ret_Type); end if; @@ -4282,9 +4445,7 @@ package body Exp_Ch6 is Replace_Formals (Blk); Set_Parent (Blk, N); - if not Comes_From_Source (Subp) - or else Is_Predef - then + if not Comes_From_Source (Subp) or else Is_Predef then Reset_Slocs (Blk); end if; @@ -4296,7 +4457,7 @@ package body Exp_Ch6 is if Num_Ret = 1 and then Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = - N_Goto_Statement + N_Goto_Statement then Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); else @@ -4334,6 +4495,7 @@ package body Exp_Ch6 is if Ekind (Subp) = E_Procedure then Rewrite_Procedure_Call (N, Blk); + else Rewrite_Function_Call (N, Blk); @@ -4489,10 +4651,10 @@ package body Exp_Ch6 is Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); Stmts : constant List_Id := New_List; - - Local_Id : Entity_Id; - Pool_Id : Entity_Id; - Ptr_Typ : Entity_Id; + Desig_Typ : Entity_Id; + Local_Id : Entity_Id; + Pool_Id : Entity_Id; + Ptr_Typ : Entity_Id; begin -- Generate: @@ -4522,8 +4684,19 @@ package body Exp_Ch6 is -- of the temporary. Otherwise the secondary stack allocation -- will fail. + Desig_Typ := Ret_Typ; + + -- Ensure that the build-in-place machinery uses a fat pointer + -- when allocating an unconstrained array on the heap. In this + -- case the result object type is a constrained array type even + -- though the function type is unconstrained. + + if Ekind (Desig_Typ) = E_Array_Subtype then + Desig_Typ := Base_Type (Desig_Typ); + end if; + -- Generate: - -- type Ptr_Typ is access Ret_Typ; + -- type Ptr_Typ is access Desig_Typ; Ptr_Typ := Make_Temporary (Loc, 'P'); @@ -4533,7 +4706,7 @@ package body Exp_Ch6 is Type_Definition => Make_Access_To_Object_Definition (Loc, Subtype_Indication => - New_Reference_To (Ret_Typ, Loc)))); + New_Reference_To (Desig_Typ, Loc)))); -- Perform minor decoration in order to set the master and the -- storage pool attributes. @@ -4543,7 +4716,6 @@ package body Exp_Ch6 is Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); -- Create the temporary, generate: - -- -- Local_Id : Ptr_Typ; Local_Id := Make_Temporary (Loc, 'T'); @@ -4555,7 +4727,6 @@ package body Exp_Ch6 is New_Reference_To (Ptr_Typ, Loc))); -- Allocate the object, generate: - -- -- Local_Id := <Alloc_Expr>; Append_To (Stmts, @@ -4603,7 +4774,6 @@ package body Exp_Ch6 is end; -- For all other cases, generate: - -- -- Temp_Id := <Alloc_Expr>; else @@ -4619,38 +4789,29 @@ package body Exp_Ch6 is --------------------------- function Move_Activation_Chain return Node_Id is - Chain_Formal : constant Entity_Id := - Build_In_Place_Formal - (Par_Func, BIP_Activation_Chain); - To : constant Node_Id := - New_Reference_To (Chain_Formal, Loc); - Master_Formal : constant Entity_Id := - Build_In_Place_Formal (Par_Func, BIP_Master); - New_Master : constant Node_Id := - New_Reference_To (Master_Formal, Loc); - - Chain_Id : Entity_Id; - From : Node_Id; - begin - Chain_Id := First_Entity (Return_Statement_Entity (N)); - while Chars (Chain_Id) /= Name_uChain loop - Chain_Id := Next_Entity (Chain_Id); - end loop; - - From := - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To (Chain_Id, Loc), - Attribute_Name => Name_Unrestricted_Access); - -- ??? Not clear why "Make_Identifier (Loc, Name_uChain)" doesn't - -- work, instead of "New_Reference_To (Chain_Id, Loc)" above. - return Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), - Parameter_Associations => New_List (From, To, New_Master)); + + Parameter_Associations => New_List ( + + -- Source chain + + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uChain), + Attribute_Name => Name_Unrestricted_Access), + + -- Destination chain + + New_Reference_To + (Build_In_Place_Formal (Par_Func, BIP_Activation_Chain), Loc), + + -- New master + + New_Reference_To + (Build_In_Place_Formal (Par_Func, BIP_Master), Loc))); end Move_Activation_Chain; -- Start of processing for Expand_N_Extended_Return_Statement @@ -4682,6 +4843,7 @@ package body Exp_Ch6 is -- Recover the function body Func_Bod := Unit_Declaration_Node (Par_Func); + if Nkind (Func_Bod) = N_Subprogram_Declaration then Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); end if; @@ -4743,6 +4905,15 @@ package body Exp_Ch6 is if Is_Build_In_Place and then Has_Task (Etype (Par_Func)) then + -- The return expression is an aggregate for a complex type which + -- contains tasks. This particular case is left unexpanded since + -- the regular expansion would insert all temporaries and + -- initialization code in the wrong block. + + if Nkind (Exp) = N_Aggregate then + Expand_N_Aggregate (Exp); + end if; + Append_To (Stmts, Move_Activation_Chain); end if; @@ -4794,12 +4965,12 @@ package body Exp_Ch6 is Set_Identifier (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); - -- If the object decl was already rewritten as a renaming, then - -- we don't want to do the object allocation and transformation of - -- of the return object declaration to a renaming. This case occurs + -- If the object decl was already rewritten as a renaming, then we + -- don't want to do the object allocation and transformation of of + -- the return object declaration to a renaming. This case occurs -- when the return object is initialized by a call to another - -- build-in-place function, and that function is responsible for the - -- allocation of the return object. + -- build-in-place function, and that function is responsible for + -- the allocation of the return object. if Is_Build_In_Place and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration @@ -5083,9 +5254,9 @@ package body Exp_Ch6 is -- The allocator is returned on the secondary stack, -- so indicate that the function return, as well as -- the block that encloses the allocator, must not - -- release it. The flags must be set now because the - -- decision to use the secondary stack is done very - -- late in the course of expanding the return + -- release it. The flags must be set now because + -- the decision to use the secondary stack is done + -- very late in the course of expanding the return -- statement, past the point where these flags are -- normally set. @@ -5162,10 +5333,10 @@ package body Exp_Ch6 is -- If a separate initialization assignment was created -- earlier, append that following the assignment of the -- implicit access formal to the access object, to ensure - -- that the return object is initialized in that case. - -- In this situation, the target of the assignment must - -- be rewritten to denote a dereference of the access to - -- the return object passed in by the caller. + -- that the return object is initialized in that case. In + -- this situation, the target of the assignment must be + -- rewritten to denote a dereference of the access to the + -- return object passed in by the caller. if Present (Init_Assignment) then Rewrite (Name (Init_Assignment), @@ -5813,10 +5984,10 @@ package body Exp_Ch6 is Pop_Scope; end if; - -- Ada 2005 (AI-348): Generate body for a null procedure. - -- In most cases this is superfluous because calls to it - -- will be automatically inlined, but we definitely need - -- the body if preconditions for the procedure are present. + -- Ada 2005 (AI-348): Generate body for a null procedure. In most + -- cases this is superfluous because calls to it will be automatically + -- inlined, but we definitely need the body if preconditions for the + -- procedure are present. elsif Nkind (Specification (N)) = N_Procedure_Specification and then Null_Present (Specification (N)) @@ -5854,11 +6025,11 @@ package body Exp_Ch6 is begin -- Call _Postconditions procedure if procedure with active - -- postconditions. Here, we use the Postcondition_Proc attribute, which - -- is needed for implicitly-generated returns. Functions never - -- have implicitly-generated returns, and there's no room for - -- Postcondition_Proc in E_Function, so we look up the identifier - -- Name_uPostconditions for function returns (see + -- postconditions. Here, we use the Postcondition_Proc attribute, + -- which is needed for implicitly-generated returns. Functions + -- never have implicitly-generated returns, and there's no + -- room for Postcondition_Proc in E_Function, so we look up the + -- identifier Name_uPostconditions for function returns (see -- Expand_Simple_Function_Return). if Ekind (Scope_Id) = E_Procedure @@ -6063,13 +6234,13 @@ package body Exp_Ch6 is Rec : Node_Id; begin - -- If the protected object is not an enclosing scope, this is an - -- inter-object function call. Inter-object procedure calls are expanded - -- by Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if - -- the subprogram being called is in the protected body being compiled, - -- and if the protected object in the call is statically the enclosing - -- type. The object may be an component of some other data structure, in - -- which case this must be handled as an inter-object call. + -- If the protected object is not an enclosing scope, this is an inter- + -- object function call. Inter-object procedure calls are expanded by + -- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the + -- subprogram being called is in the protected body being compiled, and + -- if the protected object in the call is statically the enclosing type. + -- The object may be an component of some other data structure, in which + -- case this must be handled as an inter-object call. if not In_Open_Scopes (Scop) or else not Is_Entity_Name (Name (N)) @@ -6119,12 +6290,38 @@ package body Exp_Ch6 is end if; end Expand_Protected_Subprogram_Call; + -------------------------------------------- + -- Has_Unconstrained_Access_Discriminants -- + -------------------------------------------- + + function Has_Unconstrained_Access_Discriminants + (Subtyp : Entity_Id) return Boolean + is + Discr : Entity_Id; + + begin + if Has_Discriminants (Subtyp) + and then not Is_Constrained (Subtyp) + then + Discr := First_Discriminant (Subtyp); + while Present (Discr) loop + if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then + return True; + end if; + + Next_Discriminant (Discr); + end loop; + end if; + + return False; + end Has_Unconstrained_Access_Discriminants; + ----------------------------------- -- Expand_Simple_Function_Return -- ----------------------------------- - -- The "simple" comes from the syntax rule simple_return_statement. - -- The semantics are not at all simple! + -- The "simple" comes from the syntax rule simple_return_statement. The + -- semantics are not at all simple! procedure Expand_Simple_Function_Return (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -6145,12 +6342,12 @@ package body Exp_Ch6 is -- The type of the expression (not necessarily the same as R_Type) Subtype_Ind : Node_Id; - -- If the result type of the function is class-wide and the - -- expression has a specific type, then we use the expression's - -- type as the type of the return object. In cases where the - -- expression is an aggregate that is built in place, this avoids - -- the need for an expensive conversion of the return object to - -- the specific type on assignments to the individual components. + -- If the result type of the function is class-wide and the expression + -- has a specific type, then we use the expression's type as the type of + -- the return object. In cases where the expression is an aggregate that + -- is built in place, this avoids the need for an expensive conversion + -- of the return object to the specific type on assignments to the + -- individual components. begin if Is_Class_Wide_Type (R_Type) @@ -6314,13 +6511,13 @@ package body Exp_Ch6 is -- Optimize the case where the result is a function call. In this -- case either the result is already on the secondary stack, or is -- already being returned with the stack pointer depressed and no - -- further processing is required except to set the By_Ref flag to - -- ensure that gigi does not attempt an extra unnecessary copy. + -- further processing is required except to set the By_Ref flag + -- to ensure that gigi does not attempt an extra unnecessary copy. -- (actually not just unnecessary but harmfully wrong in the case -- of a controlled type, where gigi does not know how to do a copy). - -- To make up for a gcc 2.8.1 deficiency (???), we perform - -- the copy for array types if the constrained status of the - -- target type is different from that of the expression. + -- To make up for a gcc 2.8.1 deficiency (???), we perform the copy + -- for array types if the constrained status of the target type is + -- different from that of the expression. if Requires_Transient_Scope (Exptyp) and then @@ -6414,12 +6611,12 @@ package body Exp_Ch6 is end if; end if; - -- Implement the rules of 6.5(8-10), which require a tag check in the - -- case of a limited tagged return type, and tag reassignment for + -- Implement the rules of 6.5(8-10), which require a tag check in + -- the case of a limited tagged return type, and tag reassignment for -- nonlimited tagged results. These actions are needed when the return -- type is a specific tagged type and the result expression is a - -- conversion or a formal parameter, because in that case the tag of the - -- expression might differ from the tag of the specific result type. + -- conversion or a formal parameter, because in that case the tag of + -- the expression might differ from the tag of the specific result type. if Is_Tagged_Type (Utyp) and then not Is_Class_Wide_Type (Utyp) @@ -6428,8 +6625,8 @@ package body Exp_Ch6 is or else (Is_Entity_Name (Exp) and then Ekind (Entity (Exp)) in Formal_Kind)) then - -- When the return type is limited, perform a check that the - -- tag of the result is the same as the tag of the return type. + -- When the return type is limited, perform a check that the tag of + -- the result is the same as the tag of the return type. if Is_Limited_Type (R_Type) then Insert_Action (Exp, @@ -6449,8 +6646,8 @@ package body Exp_Ch6 is -- If the result type is a specific nonlimited tagged type, then we -- have to ensure that the tag of the result is that of the result - -- type. This is handled by making a copy of the expression in the - -- case where it might have a different tag, namely when the + -- type. This is handled by making a copy of the expression in + -- the case where it might have a different tag, namely when the -- expression is a conversion or a formal parameter. We create a new -- object of the result type and initialize it from the expression, -- which will implicitly force the tag to be set appropriately. @@ -6509,8 +6706,8 @@ package body Exp_Ch6 is begin -- Ada 2005 (AI-251): In class-wide interface objects we displace - -- "this" to reference the base of the object --- required to get - -- access to the TSD of the object. + -- "this" to reference the base of the object. This is required to + -- get access to the TSD of the object. if Is_Class_Wide_Type (Etype (Exp)) and then Is_Interface (Etype (Exp)) @@ -6563,20 +6760,237 @@ package body Exp_Ch6 is Make_Op_Ne (Loc, Left_Opnd => Duplicate_Subexpr (Exp), Right_Opnd => Make_Null (Loc)), + Right_Opnd => Make_Op_Ne (Loc, Left_Opnd => Make_Selected_Component (Loc, Prefix => Duplicate_Subexpr (Exp), Selector_Name => Make_Identifier (Loc, Name_uTag)), + Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Designated_Type (R_Type), Loc), Attribute_Name => Name_Tag))), + Reason => CE_Tag_Check_Failed), Suppress => All_Checks); end if; + -- AI05-0234: RM 6.5(21/3). Check access discriminants to + -- ensure that the function result does not outlive an + -- object designated by one of it discriminants. + + if Present (Extra_Accessibility_Of_Result (Scope_Id)) + and then Has_Unconstrained_Access_Discriminants (R_Type) + then + declare + Discrim_Source : Node_Id; + + procedure Check_Against_Result_Level (Level : Node_Id); + -- Check the given accessibility level against the level + -- determined by the point of call. (AI05-0234). + + -------------------------------- + -- Check_Against_Result_Level -- + -------------------------------- + + procedure Check_Against_Result_Level (Level : Node_Id) is + begin + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Level, + Right_Opnd => + New_Occurrence_Of + (Extra_Accessibility_Of_Result (Scope_Id), Loc)), + Reason => PE_Accessibility_Check_Failed)); + end Check_Against_Result_Level; + + begin + Discrim_Source := Exp; + while Nkind (Discrim_Source) = N_Qualified_Expression loop + Discrim_Source := Expression (Discrim_Source); + end loop; + + if Nkind (Discrim_Source) = N_Identifier + and then Is_Return_Object (Entity (Discrim_Source)) + then + Discrim_Source := Entity (Discrim_Source); + + if Is_Constrained (Etype (Discrim_Source)) then + Discrim_Source := Etype (Discrim_Source); + else + Discrim_Source := Expression (Parent (Discrim_Source)); + end if; + + elsif Nkind (Discrim_Source) = N_Identifier + and then Nkind_In (Original_Node (Discrim_Source), + N_Aggregate, N_Extension_Aggregate) + then + Discrim_Source := Original_Node (Discrim_Source); + + elsif Nkind (Discrim_Source) = N_Explicit_Dereference and then + Nkind (Original_Node (Discrim_Source)) = N_Function_Call + then + Discrim_Source := Original_Node (Discrim_Source); + end if; + + while Nkind_In (Discrim_Source, N_Qualified_Expression, + N_Type_Conversion, + N_Unchecked_Type_Conversion) + loop + Discrim_Source := Expression (Discrim_Source); + end loop; + + case Nkind (Discrim_Source) is + when N_Defining_Identifier => + + pragma Assert (Is_Composite_Type (Discrim_Source) + and then Has_Discriminants (Discrim_Source) + and then Is_Constrained (Discrim_Source)); + + declare + Discrim : Entity_Id := + First_Discriminant (Base_Type (R_Type)); + Disc_Elmt : Elmt_Id := + First_Elmt (Discriminant_Constraint + (Discrim_Source)); + begin + loop + if Ekind (Etype (Discrim)) = + E_Anonymous_Access_Type + then + Check_Against_Result_Level + (Dynamic_Accessibility_Level (Node (Disc_Elmt))); + end if; + + Next_Elmt (Disc_Elmt); + Next_Discriminant (Discrim); + exit when not Present (Discrim); + end loop; + end; + + when N_Aggregate | N_Extension_Aggregate => + + -- Unimplemented: extension aggregate case where discrims + -- come from ancestor part, not extension part. + + declare + Discrim : Entity_Id := + First_Discriminant (Base_Type (R_Type)); + + Disc_Exp : Node_Id := Empty; + + Positionals_Exhausted + : Boolean := not Present (Expressions + (Discrim_Source)); + + function Associated_Expr + (Comp_Id : Entity_Id; + Associations : List_Id) return Node_Id; + + -- Given a component and a component associations list, + -- locate the expression for that component; returns + -- Empty if no such expression is found. + + --------------------- + -- Associated_Expr -- + --------------------- + + function Associated_Expr + (Comp_Id : Entity_Id; + Associations : List_Id) return Node_Id + is + Assoc : Node_Id; + Choice : Node_Id; + + begin + -- Simple linear search seems ok here + + Assoc := First (Associations); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + while Present (Choice) loop + if (Nkind (Choice) = N_Identifier + and then Chars (Choice) = Chars (Comp_Id)) + or else (Nkind (Choice) = N_Others_Choice) + then + return Expression (Assoc); + end if; + + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + return Empty; + end Associated_Expr; + + -- Start of processing for Expand_Simple_Function_Return + + begin + if not Positionals_Exhausted then + Disc_Exp := First (Expressions (Discrim_Source)); + end if; + + loop + if Positionals_Exhausted then + Disc_Exp := + Associated_Expr + (Discrim, + Component_Associations (Discrim_Source)); + end if; + + if Ekind (Etype (Discrim)) = + E_Anonymous_Access_Type + then + Check_Against_Result_Level + (Dynamic_Accessibility_Level (Disc_Exp)); + end if; + + Next_Discriminant (Discrim); + exit when not Present (Discrim); + + if not Positionals_Exhausted then + Next (Disc_Exp); + Positionals_Exhausted := not Present (Disc_Exp); + end if; + end loop; + end; + + when N_Function_Call => + + -- No check needed (check performed by callee) + + null; + + when others => + + declare + Level : constant Node_Id := + Make_Integer_Literal (Loc, + Object_Access_Level (Discrim_Source)); + + begin + -- Unimplemented: check for name prefix that includes + -- a dereference of an access value with a dynamic + -- accessibility level (e.g., an access param or a + -- saooaaat) and use dynamic level in that case. For + -- example: + -- return Access_Param.all(Some_Index).Some_Component; + -- ??? + + Set_Etype (Level, Standard_Natural); + Check_Against_Result_Level (Level); + end; + + end case; + end; + end if; + -- If we are returning an object that may not be bit-aligned, then copy -- the value into a temporary first. This copy may need to expand to a -- loop of component operations. @@ -6794,8 +7208,8 @@ package body Exp_Ch6 is -- Step past qualification or unchecked conversion (the latter can occur -- in cases of calls to 'Input). - if Nkind_In - (Exp_Node, N_Qualified_Expression, N_Unchecked_Type_Conversion) + if Nkind_In (Exp_Node, N_Qualified_Expression, + N_Unchecked_Type_Conversion) then Exp_Node := Expression (N); end if; @@ -6804,19 +7218,22 @@ package body Exp_Ch6 is return False; else - if Is_Entity_Name (Name (Exp_Node)) then + -- In Alfa mode, build-in-place calls are not expanded, so that we + -- may end up with a call that is neither resolved to an entity, nor + -- an indirect call. + + if Alfa_Mode then + return False; + + elsif Is_Entity_Name (Name (Exp_Node)) then Function_Id := Entity (Name (Exp_Node)); + -- In the case of an explicitly dereferenced call, use the subprogram + -- type generated for the dereference. + 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; @@ -6877,9 +7294,9 @@ package body Exp_Ch6 is Thunk_Code, Build_Set_Predefined_Prim_Op_Address (Loc, - Tag_Node => + Tag_Node => New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc), - Position => DT_Position (Prim), + Position => DT_Position (Prim), Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, @@ -6887,11 +7304,11 @@ package body Exp_Ch6 is Attribute_Name => Name_Unrestricted_Access))), Build_Set_Predefined_Prim_Op_Address (Loc, - Tag_Node => + Tag_Node => New_Reference_To (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), Loc), - Position => DT_Position (Prim), + Position => DT_Position (Prim), Address_Node => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, @@ -6904,13 +7321,12 @@ package body Exp_Ch6 is Next_Elmt (Iface_DT_Ptr); pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); - -- Skip the tag of the no-thunks dispatch table + -- Skip tag of the no-thunks dispatch table Next_Elmt (Iface_DT_Ptr); pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); - -- Skip the tag of the predefined primitives no-thunks dispatch - -- table. + -- Skip tag of predefined primitives no-thunks dispatch table Next_Elmt (Iface_DT_Ptr); pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); @@ -6962,8 +7378,8 @@ package body Exp_Ch6 is -- slots. elsif Is_Imported (Subp) - and then (Convention (Subp) = Convention_CPP - or else Convention (Subp) = Convention_C) + and then (Convention (Subp) = Convention_CPP + or else Convention (Subp) = Convention_C) then null; @@ -7072,11 +7488,11 @@ package body Exp_Ch6 is (Allocator : Node_Id; Function_Call : Node_Id) is + Acc_Type : constant Entity_Id := Etype (Allocator); Loc : Source_Ptr; Func_Call : Node_Id := Function_Call; Function_Id : Entity_Id; Result_Subt : Entity_Id; - Acc_Type : constant Entity_Id := Etype (Allocator); New_Allocator : Node_Id; Return_Obj_Access : Entity_Id; @@ -7115,7 +7531,14 @@ package body Exp_Ch6 is raise Program_Error; end if; - Result_Subt := Etype (Function_Id); + Result_Subt := Available_View (Etype (Function_Id)); + + -- Check whether return type includes tasks. This may not have been done + -- previously, if the type was a limited view. + + if Has_Task (Result_Subt) then + Build_Activation_Chain_Entity (Allocator); + end if; -- When the result subtype is constrained, the return object must be -- allocated on the caller side, and access to it is passed to the @@ -7235,10 +7658,14 @@ package body Exp_Ch6 is then null; - -- Do not generate the call to Make_Set_Finalize_Address for - -- CodePeer compilations because Finalize_Address is never built. + -- Do not generate the call to Set_Finalize_Address in Alfa mode + -- because it is not necessary and results in unwanted expansion. + -- This expansion is also not carried out in CodePeer mode because + -- Finalize_Address is never built. - elsif not CodePeer_Mode then + elsif not Alfa_Mode + and then not CodePeer_Mode + then Insert_Action (Allocator, Make_Set_Finalize_Address_Call (Loc, Typ => Etype (Function_Id), @@ -7561,7 +7988,9 @@ package body Exp_Ch6 is Ptr_Typ_Decl : Node_Id; Def_Id : Entity_Id; New_Expr : Node_Id; - Enclosing_Func : Entity_Id; + Enclosing_Func : constant Entity_Id := + Enclosing_Subprogram (Obj_Def_Id); + Fmaster_Actual : Node_Id := Empty; Pass_Caller_Acc : Boolean := False; begin @@ -7613,8 +8042,6 @@ package body Exp_Ch6 is if Is_Return_Object (Defining_Identifier (Object_Decl)) then Pass_Caller_Acc := True; - Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); - -- 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). @@ -7636,6 +8063,13 @@ package body Exp_Ch6 is (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); end if; + if Needs_BIP_Finalization_Master (Enclosing_Func) then + Fmaster_Actual := + New_Reference_To + (Build_In_Place_Formal + (Enclosing_Func, BIP_Finalization_Master), Loc); + end if; + -- Retrieve the BIPacc formal from the enclosing function and convert -- it to the access type of the callee's BIP_Object_Access formal. @@ -7686,14 +8120,18 @@ package body Exp_Ch6 is Establish_Transient_Scope (Object_Decl, Sec_Stack => True); end if; + -- Pass along any finalization master actual, which is needed in the + -- case where the called function initializes a return object of an + -- enclosing build-in-place function. + Add_Finalization_Master_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id); + (Func_Call => Func_Call, + Func_Id => Function_Id, + Master_Exp => Fmaster_Actual); if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement and then Has_Task (Result_Subt) then - Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); - -- Here we're passing along the master that was passed in to this -- function. @@ -7853,7 +8291,6 @@ package body Exp_Ch6 is is pragma Assert (Is_Build_In_Place_Function (Func_Id)); Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); - begin return not Restriction_Active (No_Finalization) @@ -7871,4 +8308,130 @@ package body Exp_Ch6 is return not Is_Constrained (Func_Typ) or else Is_Tagged_Type (Func_Typ); end Needs_BIP_Alloc_Form; + -------------------------------------- + -- Needs_Result_Accessibility_Level -- + -------------------------------------- + + function Needs_Result_Accessibility_Level + (Func_Id : Entity_Id) return Boolean + is + Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); + + function Has_Unconstrained_Access_Discriminant_Component + (Comp_Typ : Entity_Id) return Boolean; + -- Returns True if any component of the type has an unconstrained access + -- discriminant. + + ----------------------------------------------------- + -- Has_Unconstrained_Access_Discriminant_Component -- + ----------------------------------------------------- + + function Has_Unconstrained_Access_Discriminant_Component + (Comp_Typ : Entity_Id) return Boolean + is + begin + if not Is_Limited_Type (Comp_Typ) then + return False; + + -- Only limited types can have access discriminants with + -- defaults. + + elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then + return True; + + elsif Is_Array_Type (Comp_Typ) then + return Has_Unconstrained_Access_Discriminant_Component + (Underlying_Type (Component_Type (Comp_Typ))); + + elsif Is_Record_Type (Comp_Typ) then + declare + Comp : Entity_Id; + + begin + Comp := First_Component (Comp_Typ); + while Present (Comp) loop + if Has_Unconstrained_Access_Discriminant_Component + (Underlying_Type (Etype (Comp))) + then + return True; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + + return False; + end Has_Unconstrained_Access_Discriminant_Component; + + Feature_Disabled : constant Boolean := True; + -- Temporary + + -- Start of processing for Needs_Result_Accessibility_Level + + begin + -- False if completion unavailable (how does this happen???) + + if not Present (Func_Typ) then + return False; + + elsif Feature_Disabled then + return False; + + -- False if not a function, also handle enum-lit renames case + + elsif Func_Typ = Standard_Void_Type + or else Is_Scalar_Type (Func_Typ) + then + return False; + + -- Handle a corner case, a cross-dialect subp renaming. For example, + -- an Ada2012 renaming of an Ada05 subprogram. This can occur when a + -- non-Ada2012 unit references predefined runtime units. + + elsif Present (Alias (Func_Id)) then + + -- Unimplemented: a cross-dialect subp renaming which does not set + -- the Alias attribute (e.g., a rename of a dereference of an access + -- to subprogram value). ??? + + return Present (Extra_Accessibility_Of_Result (Alias (Func_Id))); + + -- Remaining cases require Ada 2012 mode + + elsif Ada_Version < Ada_2012 then + return False; + + elsif Ekind (Func_Typ) = E_Anonymous_Access_Type + or else Is_Tagged_Type (Func_Typ) + then + -- In the case of, say, a null tagged record result type, the need + -- for this extra parameter might not be obvious. This function + -- returns True for all tagged types for compatibility reasons. + -- A function with, say, a tagged null controlling result type might + -- be overridden by a primitive of an extension having an access + -- discriminant and the overrider and overridden must have compatible + -- calling conventions (including implicitly declared parameters). + -- Similarly, values of one access-to-subprogram type might designate + -- both a primitive subprogram of a given type and a function + -- which is, for example, not a primitive subprogram of any type. + -- Again, this requires calling convention compatibility. + -- It might be possible to solve these issues by introducing + -- wrappers, but that is not the approach that was chosen. + + return True; + + elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then + return True; + + elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then + return True; + + -- False for all other cases + + else + return False; + end if; + end Needs_Result_Accessibility_Level; + end Exp_Ch6; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 29dc27322d9..06145f525e0 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -205,4 +205,17 @@ package Exp_Ch6 is -- Ada 2005 (AI-318-02): Return True if the function needs an implicit -- BIP_Alloc_Form parameter (see type BIP_Formal_Kind). + function Needs_Result_Accessibility_Level + (Func_Id : Entity_Id) return Boolean; + -- Ada 2012 (AI05-0234): Return True if the function needs an implicit + -- parameter to identify the accessibility level of the function result + -- "determined by the point of call". + + procedure Add_Extra_Actual_To_Call + (Subprogram_Call : Node_Id; + Extra_Formal : Entity_Id; + Extra_Actual : Node_Id); + -- Adds Extra_Actual as a named parameter association for the formal + -- Extra_Formal in Subprogram_Call. + end Exp_Ch6; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 73ae23da94c..c7ea703d272 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -80,18 +80,18 @@ package body Exp_Ch7 is -- unconstrained or tagged values) may appear in 3 different contexts which -- lead to 3 different kinds of transient scope expansion: - -- 1. In a simple statement (procedure call, assignment, ...). In - -- this case the instruction is wrapped into a transient block. - -- (See Wrap_Transient_Statement for details) + -- 1. In a simple statement (procedure call, assignment, ...). In this + -- case the instruction is wrapped into a transient block. See + -- Wrap_Transient_Statement for details. -- 2. In an expression of a control structure (test in a IF statement, - -- expression in a CASE statement, ...). - -- (See Wrap_Transient_Expression for details) + -- expression in a CASE statement, ...). See Wrap_Transient_Expression + -- for details. -- 3. In a expression of an object_declaration. No wrapping is possible -- here, so the finalization actions, if any, are done right after the -- declaration and the secondary stack deallocation is done in the - -- proper enclosing scope (see Wrap_Transient_Declaration for details) + -- proper enclosing scope. See Wrap_Transient_Declaration for details. -- Note about functions returning tagged types: it has been decided to -- always allocate their result in the secondary stack, even though is not @@ -185,11 +185,10 @@ package body Exp_Ch7 is -- access type definition otherwise, this is the chain of the current -- scope. - -- Adjust Calls: They are generated on 2 occasions: (1) for - -- declarations or dynamic allocations of Controlled objects with an - -- initial value. (2) after an assignment. In the first case they are - -- followed by an attachment to the final chain, in the second case - -- they are not. + -- Adjust Calls: They are generated on 2 occasions: (1) for declarations + -- or dynamic allocations of Controlled objects with an initial value. + -- (2) after an assignment. In the first case they are followed by an + -- attachment to the final chain, in the second case they are not. -- Finalization Calls: They are generated on (1) scope exit, (2) -- assignments, (3) unchecked deallocations. In case (3) they have to @@ -226,6 +225,7 @@ package body Exp_Ch7 is -- end record; -- W : R; -- Z : R := (C => X); + -- begin -- X := Y; -- W := Z; @@ -499,7 +499,7 @@ package body Exp_Ch7 is -- has entries, call the entry service routine. -- NOTE: The generated code references _object, a parameter to the - -- procedure. + -- procedure. elsif Is_Protected_Body then declare @@ -888,6 +888,12 @@ package body Exp_Ch7 is and then not Is_Controlled (Desig_Typ) then return; + + -- Do not create finalization masters in Alfa mode because they result + -- in unwanted expansion. + + elsif Alfa_Mode then + return; end if; declare @@ -1054,7 +1060,6 @@ package body Exp_Ch7 is 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: - -- -- Counter_Id -- Finalizer_Decls -- Finalizer_Stmts @@ -1074,8 +1079,7 @@ package body Exp_Ch7 is Finalizer_Decls : List_Id := No_List; -- Local variable declarations. This list holds the label declarations -- of all jump block alternatives as well as the declaration of the - -- local exception occurence and the raised flag. - -- + -- local exception occurence and the raised flag: -- E : Exception_Occurrence; -- Raised : Boolean := False; -- L<counter value> : label; @@ -1531,12 +1535,10 @@ package body Exp_Ch7 is Fin_Body := Make_Subprogram_Body (Loc, - Specification => + Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => Body_Id), - - Declarations => Finalizer_Decls, - + Declarations => Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts)); @@ -1769,15 +1771,15 @@ package body Exp_Ch7 is null; -- Transient variables are treated separately in order to - -- minimize the size of the generated code. See Process_ - -- Transient_Objects. + -- minimize the size of the generated code. For details, see + -- Process_Transient_Objects. elsif Is_Processed_Transient (Obj_Id) then null; -- The object is of the form: -- Obj : Typ [:= Expr]; - -- + -- Do not process the incomplete view of a deferred constant. -- Do not consider tag-to-class-wide conversions. @@ -1791,7 +1793,7 @@ package body Exp_Ch7 is -- The object is of the form: -- Obj : Access_Typ := Non_BIP_Function_Call'reference; - -- + -- Obj : Access_Typ := -- BIP_Function_Call -- (..., BIPaccess => null, ...)'reference; @@ -1802,9 +1804,9 @@ package body Exp_Ch7 is and then Present (Expr) and then (Is_Null_Access_BIP_Func_Call (Expr) - or else (Is_Non_BIP_Func_Call (Expr) - and then not - Is_Related_To_Func_Return (Obj_Id))) + or else + (Is_Non_BIP_Func_Call (Expr) + and then not Is_Related_To_Func_Return (Obj_Id))) then Processing_Actions (Has_No_Init => True); @@ -1835,11 +1837,11 @@ package body Exp_Ch7 is -- protected Prot is -- procedure Do_Something (Obj : in out Ctrl); -- end Prot; - -- + -- protected body Prot is -- procedure Do_Something (Obj : in out Ctrl) is ... -- end Prot; - -- + -- procedure Finalize (Obj : in out Ctrl) is -- begin -- Prot.Do_Something (Obj); @@ -2050,7 +2052,6 @@ package body Exp_Ch7 is -- type Ptr_Typ is access Obj_Typ; -- for Ptr_Typ'Storage_Pool -- use Base_Pool (BIPfinalizationmaster); - -- -- begin -- Free (Ptr_Typ (Temp)); -- end; @@ -2267,11 +2268,9 @@ package body Exp_Ch7 is end if; return - (Present (Deep_Init) - and then Call_Ent = Deep_Init) - or else - (Present (Init) - and then Call_Ent = Init); + (Present (Deep_Init) and then Call_Ent = Deep_Init) + or else + (Present (Init) and then Call_Ent = Init); end; end if; @@ -2440,8 +2439,8 @@ package body Exp_Ch7 is Label_Id := Make_Identifier (Loc, New_External_Name ('L', Counter_Val)); - Set_Entity (Label_Id, - Make_Defining_Identifier (Loc, Chars (Label_Id))); + Set_Entity + (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id))); Label := Make_Label (Loc, Label_Id); Prepend_To (Finalizer_Decls, @@ -2476,6 +2475,7 @@ package body Exp_Ch7 is if Is_Simple_Protected_Type (Obj_Typ) then Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref); + if Present (Fin_Call) then Fin_Stmts := New_List (Fin_Call); end if; @@ -2483,7 +2483,6 @@ package body Exp_Ch7 is elsif Has_Simple_Protected_Object (Obj_Typ) then if Is_Record_Type (Obj_Typ) then Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ); - elsif Is_Array_Type (Obj_Typ) then Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ); end if; @@ -2493,7 +2492,7 @@ package body Exp_Ch7 is -- begin -- System.Tasking.Protected_Objects.Finalize_Protection -- (Obj._object); - -- + -- exception -- when others => -- null; @@ -2523,7 +2522,7 @@ package body Exp_Ch7 is -- begin -- Exception handlers allowed -- [Deep_]Finalize (Obj); - -- + -- exception -- when Id : others => -- if not Raised then @@ -2559,7 +2558,7 @@ package body Exp_Ch7 is -- If we are dealing with a return object of a build-in-place -- function, generate the following cleanup statements: - -- + -- if BIPallocfrom > Secondary_Stack'Pos -- and then BIPfinalizationmaster /= null -- then @@ -2567,7 +2566,6 @@ package body Exp_Ch7 is -- type Ptr_Typ is access Obj_Typ; -- for Ptr_Typ'Storage_Pool use -- Base_Pool (BIPfinalizationmaster.all).all; - -- -- begin -- Free (Ptr_Typ (Temp)); -- end; @@ -2595,7 +2593,7 @@ package body Exp_Ch7 is -- Return objects use a flag to aid their potential -- finalization when the enclosing function fails to return -- properly. Generate: - -- + -- if not Flag then -- <object finalization statements> -- end if; @@ -2678,7 +2676,7 @@ package body Exp_Ch7 is Append_To (Tagged_Type_Stmts, Make_Procedure_Call_Statement (Loc, - Name => + Name => New_Reference_To (RTE (RE_Unregister_Tag), Loc), Parameter_Associations => New_List ( New_Reference_To (DT_Ptr, Loc)))); @@ -2689,6 +2687,13 @@ package body Exp_Ch7 is begin Fin_Id := Empty; + -- Do not perform this expansion in Alfa mode because it is not + -- necessary. + + if Alfa_Mode then + return; + end if; + -- Step 1: Extract all lists which may contain controlled objects or -- library-level tagged types. @@ -2844,6 +2849,13 @@ package body Exp_Ch7 is -- which belongs to a protected type. begin + -- Do not perform this expansion in Alfa mode because we do not create + -- finalizers in the first place. + + if Alfa_Mode then + return; + end if; + -- The At_End handler should have been assimilated by the finalizer pragma Assert (No (At_End_Proc (HSS))); @@ -2852,14 +2864,14 @@ package body Exp_Ch7 is -- finalizer call needs to be associated with the block which wraps the -- unprotected version of the subprogram. The following illustrates this -- scenario: - -- + -- procedure Prot_SubpP is -- procedure finalizer is -- begin -- Service_Entries (Prot_Obj); -- Abort_Undefer; -- end finalizer; - -- + -- begin -- . . . -- begin @@ -3022,7 +3034,7 @@ package body Exp_Ch7 is Parameter_Associations => New_List (New_Reference_To (Data.E_Id, Data.Loc))); - -- Restricted runtime: exception messages are not supported and hence + -- Restricted run-time: exception messages are not supported and hence -- Raise_From_Controlled_Operation is not supported. Raise Program_Error -- instead. @@ -3870,6 +3882,14 @@ package body Exp_Ch7 is No_Body := True; end if; + -- For a nested instance, delay processing until freeze point + + if Has_Delayed_Freeze (Id) + and then Nkind (Parent (N)) /= N_Compilation_Unit + then + return; + end if; + -- For a package declaration that implies no associated body, generate -- task activation call and RACW supporting bodies now (since we won't -- have a specific separate compilation unit for that). @@ -3960,10 +3980,9 @@ package body Exp_Ch7 is when N_Pragma => return The_Parent; - -- Usually assignments are good candidate for wrapping - -- except when they have been generated as part of a - -- controlled aggregate where the wrapping should take - -- place more globally. + -- Usually assignments are good candidate for wrapping except + -- when they have been generated as part of a controlled aggregate + -- where the wrapping should take place more globally. when N_Assignment_Statement => if No_Ctrl_Actions (The_Parent) then @@ -3972,9 +3991,9 @@ package body Exp_Ch7 is return The_Parent; end if; - -- An entry call statement is a special case if it occurs in - -- the context of a Timed_Entry_Call. In this case we wrap - -- the entire timed entry call. + -- An entry call statement is a special case if it occurs in the + -- context of a Timed_Entry_Call. In this case we wrap the entire + -- timed entry call. when N_Entry_Call_Statement | N_Procedure_Call_Statement => @@ -3989,8 +4008,8 @@ package body Exp_Ch7 is end if; -- Object declarations are also a boundary for the transient scope - -- even if they are not really wrapped - -- (see Wrap_Transient_Declaration) + -- even if they are not really wrapped. For further details, see + -- Wrap_Transient_Declaration. when N_Object_Declaration | N_Object_Renaming_Declaration | @@ -4039,8 +4058,8 @@ package body Exp_Ch7 is when N_Loop_Parameter_Specification => return Parent (The_Parent); - -- The following nodes contains "dummy calls" which don't - -- need to be wrapped. + -- The following nodes contains "dummy calls" which don't need to + -- be wrapped. when N_Parameter_Specification | N_Discriminant_Specification | @@ -4075,7 +4094,7 @@ package body Exp_Ch7 is N_Block_Statement => return Empty; - -- otherwise continue the search + -- Otherwise continue the search when others => null; @@ -4089,11 +4108,11 @@ package body Exp_Ch7 is function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id is begin - -- Access types whose size is smaller than System.Address size can - -- exist only on VMS. We can't use the usual global pool which returns - -- an object of type Address as truncation will make it invalid. - -- To handle this case, VMS has a dedicated global pool that returns - -- addresses that fit into 32 bit accesses. + -- Access types whose size is smaller than System.Address size can exist + -- only on VMS. We can't use the usual global pool which returns an + -- object of type Address as truncation will make it invalid. To handle + -- this case, VMS has a dedicated global pool that returns addresses + -- that fit into 32 bit accesses. if Opt.True_VMS_Target and then Esize (T) = 32 then return RTE (RE_Global_Pool_32_Object); @@ -4358,9 +4377,7 @@ package body Exp_Ch7 is end if; Append_To (Stmts, - Make_Final_Call - (Obj_Ref => Obj_Ref, - Typ => Desig_Typ)); + Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ)); -- Generate: -- [Temp := null;] @@ -4398,8 +4415,9 @@ package body Exp_Ch7 is -- the loop. elsif Nkind (Related_Node) = N_Object_Declaration - and then Is_Array_Type (Base_Type - (Etype (Defining_Identifier (Related_Node)))) + and then Is_Array_Type + (Base_Type + (Etype (Defining_Identifier (Related_Node)))) and then Nkind (Stmt) = N_Loop_Statement then declare @@ -4813,11 +4831,11 @@ package body Exp_Ch7 is -- ... -- end loop; -- end; - + -- -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); -- end if; - + -- -- raise; -- end; -- end loop; @@ -5883,27 +5901,27 @@ package body Exp_Ch7 is -- A derived record type must adjust all inherited components. This -- action poses the following problem: - -- + -- procedure Deep_Adjust (Obj : in out Parent_Typ) is -- begin -- Adjust (Obj); -- ... - -- + -- procedure Deep_Adjust (Obj : in out Derived_Typ) is -- begin -- Deep_Adjust (Obj._parent); -- ... -- Adjust (Obj); -- ... - -- + -- Adjusting the derived type will invoke Adjust of the parent and -- then that of the derived type. This is undesirable because both -- routines may modify shared components. Only the Adjust of the -- derived type should be invoked. - -- + -- To prevent this double adjustment of shared components, -- Deep_Adjust uses a flag to control the invocation of Adjust: - -- + -- procedure Deep_Adjust -- (Obj : in out Some_Type; -- Flag : Boolean := True) @@ -5913,10 +5931,10 @@ package body Exp_Ch7 is -- Adjust (Obj); -- end if; -- ... - -- + -- When Deep_Adjust is invokes for field _parent, a value of False is -- provided for the flag: - -- + -- Deep_Adjust (Obj._parent, False); if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then @@ -5961,8 +5979,7 @@ package body Exp_Ch7 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( - Build_Exception_Handler - (Finalizer_Data)))); + Build_Exception_Handler (Finalizer_Data)))); end if; Prepend_To (Bod_Stmts, Adj_Stmt); @@ -6461,27 +6478,27 @@ package body Exp_Ch7 is -- A derived record type must finalize all inherited components. This -- action poses the following problem: - -- + -- procedure Deep_Finalize (Obj : in out Parent_Typ) is -- begin -- Finalize (Obj); -- ... - -- + -- procedure Deep_Finalize (Obj : in out Derived_Typ) is -- begin -- Deep_Finalize (Obj._parent); -- ... -- Finalize (Obj); -- ... - -- + -- Finalizing the derived type will invoke Finalize of the parent and -- then that of the derived type. This is undesirable because both -- routines may modify shared components. Only the Finalize of the -- derived type should be invoked. - -- + -- To prevent this double adjustment of shared components, -- Deep_Finalize uses a flag to control the invocation of Finalize: - -- + -- procedure Deep_Finalize -- (Obj : in out Some_Type; -- Flag : Boolean := True) @@ -6491,10 +6508,10 @@ package body Exp_Ch7 is -- Finalize (Obj); -- end if; -- ... - -- + -- When Deep_Finalize is invokes for field _parent, a value of False -- is provided for the flag: - -- + -- Deep_Finalize (Obj._parent, False); if Is_Tagged_Type (Typ) @@ -6509,7 +6526,7 @@ package body Exp_Ch7 is if Needs_Finalization (Par_Typ) then Call := Make_Final_Call - (Obj_Ref => + (Obj_Ref => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Selector_Name => @@ -6830,7 +6847,7 @@ package body Exp_Ch7 is Set_Assignment_OK (Ref); end if; - -- Select the appropriate version of finalize + -- Select the appropriate version of Finalize if For_Parent then if Has_Controlled_Component (Utyp) then @@ -6943,8 +6960,8 @@ package body Exp_Ch7 is or else Present (TSS (Typ, TSS_Finalize_Address)) or else (Is_Class_Wide_Type (Typ) - and then Ekind (Root_Type (Typ)) = E_Record_Subtype - and then not Comes_From_Source (Root_Type (Typ))) + and then Ekind (Root_Type (Typ)) = E_Record_Subtype + and then not Comes_From_Source (Root_Type (Typ))) then return; end if; @@ -6954,10 +6971,11 @@ package body Exp_Ch7 is Make_TSS_Name (Typ, TSS_Finalize_Address)); -- Generate: + -- procedure <Typ>FD (V : System.Address) is -- begin -- null; -- for tasks - -- + -- declare -- for all other types -- type Pnn is access all Typ; -- for Pnn'Storage_Size use 0; @@ -7005,42 +7023,6 @@ package body Exp_Ch7 is Desg_Typ : Entity_Id; Obj_Expr : Node_Id; - function Alignment_Of (Some_Typ : Entity_Id) return Node_Id; - -- Subsidiary routine, generate the following attribute reference: - -- - -- Some_Typ'Alignment - - function Double_Alignment_Of (Some_Typ : Entity_Id) return Node_Id; - -- Subsidiary routine, generate the following expression: - -- - -- 2 * Some_Typ'Alignment - - ------------------ - -- Alignment_Of -- - ------------------ - - function Alignment_Of (Some_Typ : Entity_Id) return Node_Id is - begin - return - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Some_Typ, Loc), - Attribute_Name => Name_Alignment); - end Alignment_Of; - - ------------------------- - -- Double_Alignment_Of -- - ------------------------- - - function Double_Alignment_Of (Some_Typ : Entity_Id) return Node_Id is - begin - return - Make_Op_Multiply (Loc, - Left_Opnd => Make_Integer_Literal (Loc, 2), - Right_Opnd => Alignment_Of (Some_Typ)); - end Double_Alignment_Of; - - -- Start of processing for Make_Finalize_Address_Stmts - begin if Is_Array_Type (Typ) then if Is_Constrained (First_Subtype (Typ)) then @@ -7057,11 +7039,12 @@ package body Exp_Ch7 is Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ))) then declare - Parent_Typ : Entity_Id := Root_Type (Typ); + Parent_Typ : Entity_Id; begin -- Climb the parent type chain looking for a non-constrained type + Parent_Typ := Root_Type (Typ); while Parent_Typ /= Etype (Parent_Typ) and then Has_Discriminants (Parent_Typ) and then not @@ -7114,15 +7097,10 @@ package body Exp_Ch7 is and then not Is_Constrained (First_Subtype (Typ)) then declare - Dope_Expr : Node_Id; - Dope_Id : Entity_Id; - For_First : Boolean := True; - Index : Node_Id; - Index_Typ : Entity_Id; + Dope_Id : Entity_Id; begin -- Ensure that Ptr_Typ a thin pointer, generate: - -- -- for Ptr_Typ'Size use System.Address'Size; Append_To (Decls, @@ -7132,59 +7110,9 @@ package body Exp_Ch7 is Expression => Make_Integer_Literal (Loc, System_Address_Size))); - -- For unconstrained arrays, create the expression which computes - -- the size of the dope vector. - - Index := First_Index (Typ); - while Present (Index) loop - Index_Typ := Etype (Index); - - -- Each bound has two values and a potential hole added to - -- compensate for alignment differences. - - if For_First then - For_First := False; - - -- Generate: - -- 2 * Index_Typ'Alignment - - Dope_Expr := Double_Alignment_Of (Index_Typ); - - else - -- Generate: - -- Dope_Expr + 2 * Index_Typ'Alignment - - Dope_Expr := - Make_Op_Add (Loc, - Left_Opnd => Dope_Expr, - Right_Opnd => Double_Alignment_Of (Index_Typ)); - end if; - - Next_Index (Index); - end loop; - - -- Round the cumulative alignment to the next higher multiple of - -- the array alignment. Generate: - - -- ((Dope_Expr + Typ'Alignment - 1) / Typ'Alignment) - -- * Typ'Alignment - - Dope_Expr := - Make_Op_Multiply (Loc, - Left_Opnd => - Make_Op_Divide (Loc, - Left_Opnd => - Make_Op_Add (Loc, - Left_Opnd => Dope_Expr, - Right_Opnd => - Make_Op_Subtract (Loc, - Left_Opnd => Alignment_Of (Typ), - Right_Opnd => Make_Integer_Literal (Loc, 1))), - Right_Opnd => Alignment_Of (Typ)), - Right_Opnd => Alignment_Of (Typ)); - -- Generate: - -- Dnn : Storage_Offset := Dope_Expr; + -- Dnn : constant Storage_Offset := + -- Desg_Typ'Descriptor_Size / Storage_Unit; Dope_Id := Make_Temporary (Loc, 'D'); @@ -7194,7 +7122,14 @@ package body Exp_Ch7 is Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Storage_Offset), Loc), - Expression => Dope_Expr)); + Expression => + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Desg_Typ, Loc), + Attribute_Name => Name_Descriptor_Size), + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit)))); -- Shift the address from the start of the dope vector to the -- start of the elements: @@ -7256,7 +7191,7 @@ package body Exp_Ch7 is -- Procedure call or raise statement begin - -- Standard runtime, .NET/JVM targets: add choice parameter E and pass + -- Standard run-time, .NET/JVM targets: add choice parameter E and pass -- it to Raise_From_Controlled_Operation so that the original exception -- name and message can be recorded in the exception message for -- Program_Error. @@ -7271,7 +7206,7 @@ package body Exp_Ch7 is Parameter_Associations => New_List ( New_Reference_To (E_Occ, Loc))); - -- Restricted runtime: exception messages are not supported + -- Restricted run-time: exception messages are not supported else E_Occ := Empty; @@ -7430,9 +7365,11 @@ package body Exp_Ch7 is Typ : Entity_Id; Ptr_Typ : Entity_Id) return Node_Id is - Desig_Typ : constant Entity_Id := - Available_View (Designated_Type (Ptr_Typ)); - Utyp : Entity_Id; + Desig_Typ : constant Entity_Id := + Available_View (Designated_Type (Ptr_Typ)); + Fin_Mas_Id : constant Entity_Id := Finalization_Master (Ptr_Typ); + Fin_Mas_Ref : Node_Id; + Utyp : Entity_Id; begin -- If the context is a class-wide allocator, we use the class-wide type @@ -7483,6 +7420,15 @@ package body Exp_Ch7 is Utyp := Base_Type (Utyp); end if; + Fin_Mas_Ref := New_Occurrence_Of (Fin_Mas_Id, Loc); + + -- If the call is from a build-in-place function, the Master parameter + -- is actually a pointer. Dereference it for the call. + + if Is_Access_Type (Etype (Fin_Mas_Id)) then + Fin_Mas_Ref := Make_Explicit_Dereference (Loc, Fin_Mas_Ref); + end if; + -- Generate: -- Set_Finalize_Address (<Ptr_Typ>FM, <Utyp>FD'Unrestricted_Access); @@ -7491,7 +7437,7 @@ package body Exp_Ch7 is Name => New_Reference_To (RTE (RE_Set_Finalize_Address), Loc), Parameter_Associations => New_List ( - New_Reference_To (Finalization_Master (Ptr_Typ), Loc), + Fin_Mas_Ref, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc), @@ -7532,10 +7478,9 @@ package body Exp_Ch7 is Set_Uses_Sec_Stack (Current_Scope, False); exit; - -- In a function, only release the sec stack if the - -- function does not return on the sec stack otherwise - -- the result may be lost. The caller is responsible for - -- releasing. + -- In a function, only release the sec stack if the function + -- does not return on the sec stack otherwise the result may + -- be lost. The caller is responsible for releasing. elsif Ekind (S) = E_Function then Set_Uses_Sec_Stack (Current_Scope, False); @@ -7592,10 +7537,10 @@ package body Exp_Ch7 is Freeze_All (First_Entity (Current_Scope), Insert); end if; - -- When the transient scope was established, we pushed the entry for - -- the transient scope onto the scope stack, so that the scope was - -- active for the installation of finalizable entities etc. Now we - -- must remove this entry, since we have constructed a proper block. + -- When the transient scope was established, we pushed the entry for the + -- transient scope onto the scope stack, so that the scope was active + -- for the installation of finalizable entities etc. Now we must remove + -- this entry, since we have constructed a proper block. Pop_Scope; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 3d0652232cb..bbdb56be338 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -843,72 +843,121 @@ package body Exp_Ch9 is ----------------------------------- procedure Build_Activation_Chain_Entity (N : Node_Id) is - P : Node_Id; + function Has_Activation_Chain (Stmt : Node_Id) return Boolean; + -- Determine whether an extended return statement has an activation + -- chain. + + -------------------------- + -- Has_Activation_Chain -- + -------------------------- + + function Has_Activation_Chain (Stmt : Node_Id) return Boolean is + Decl : Node_Id; + + begin + Decl := First (Return_Object_Declarations (Stmt)); + while Present (Decl) loop + if Nkind (Decl) = N_Object_Declaration + and then Chars (Defining_Identifier (Decl)) = Name_uChain + then + return True; + end if; + + Next (Decl); + end loop; + + return False; + end Has_Activation_Chain; + + -- Local variables + Decls : List_Id; - Chain : Entity_Id; + Par : Node_Id; + + -- Start of processing for Build_Activation_Chain_Entity begin - -- Loop to find enclosing construct containing activation chain variable - -- The construct is a body, a block, or an extended return. - - P := Parent (N); - - while not Nkind_In (P, N_Subprogram_Body, - N_Entry_Body, - N_Package_Declaration, - N_Package_Body, - N_Block_Statement, - N_Task_Body, - N_Extended_Return_Statement) + -- Traverse the parent chain looking for an enclosing construct which + -- contains an activation chain variable. The construct is either a + -- body, a block, or an extended return. + + Par := Parent (N); + + while not Nkind_In (Par, N_Block_Statement, + N_Entry_Body, + N_Extended_Return_Statement, + N_Package_Body, + N_Package_Declaration, + N_Subprogram_Body, + N_Task_Body) loop - P := Parent (P); + Par := Parent (Par); end loop; - -- If we are in a package body, the activation chain variable is - -- declared in the body, but the Activation_Chain_Entity is attached - -- to the spec. + -- When the enclosing construct is a package body, the activation chain + -- variable is declared in the body, but the Activation_Chain_Entity is + -- attached to the spec. - if Nkind (P) = N_Package_Body then - Decls := Declarations (P); - P := Unit_Declaration_Node (Corresponding_Spec (P)); + if Nkind (Par) = N_Package_Body then + Decls := Declarations (Par); + Par := Unit_Declaration_Node (Corresponding_Spec (Par)); - elsif Nkind (P) = N_Package_Declaration then - Decls := Visible_Declarations (Specification (P)); + elsif Nkind (Par) = N_Package_Declaration then + Decls := Visible_Declarations (Specification (Par)); - elsif Nkind (P) = N_Extended_Return_Statement then - Decls := Return_Object_Declarations (P); + elsif Nkind (Par) = N_Extended_Return_Statement then + Decls := Return_Object_Declarations (Par); else - Decls := Declarations (P); + Decls := Declarations (Par); end if; - -- If activation chain entity not already declared, declare it + -- If an activation chain entity has not been declared already, create + -- one. - if Nkind (P) = N_Extended_Return_Statement - or else No (Activation_Chain_Entity (P)) + if Nkind (Par) = N_Extended_Return_Statement + or else No (Activation_Chain_Entity (Par)) then - Chain := Make_Defining_Identifier (Sloc (N), Name_uChain); - - -- Note: An extended return statement is not really a task activator, - -- but it does have an activation chain on which to store the tasks - -- temporarily. On successful return, the tasks on this chain are - -- moved to the chain passed in by the caller. We do not build an - -- Activation_Chain_Entity for an N_Extended_Return_Statement, - -- because we do not want to build a call to Activate_Tasks. Task - -- activation is the responsibility of the caller. - - if Nkind (P) /= N_Extended_Return_Statement then - Set_Activation_Chain_Entity (P, Chain); + -- Since extended return statements do not store the entity of the + -- chain, examine the return object declarations to avoid creating + -- a duplicate. + + if Nkind (Par) = N_Extended_Return_Statement + and then Has_Activation_Chain (Par) + then + return; end if; - Prepend_To (Decls, - Make_Object_Declaration (Sloc (P), - Defining_Identifier => Chain, - Aliased_Present => True, - Object_Definition => - New_Reference_To (RTE (RE_Activation_Chain), Sloc (P)))); + declare + Chain : Entity_Id; + Decl : Node_Id; + + begin + Chain := Make_Defining_Identifier (Sloc (N), Name_uChain); + + -- Note: An extended return statement is not really a task + -- activator, but it does have an activation chain on which to + -- store the tasks temporarily. On successful return, the tasks + -- on this chain are moved to the chain passed in by the caller. + -- We do not build an Activation_Chain_Entity for an extended + -- return statement, because we do not want to build a call to + -- Activate_Tasks. Task activation is the responsibility of the + -- caller. + + if Nkind (Par) /= N_Extended_Return_Statement then + Set_Activation_Chain_Entity (Par, Chain); + end if; + + Decl := + Make_Object_Declaration (Sloc (Par), + Defining_Identifier => Chain, + Aliased_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Activation_Chain), Sloc (Par))); - Analyze (First (Decls)); + Prepend_To (Decls, Decl); + Analyze (Decl); + end; end if; end Build_Activation_Chain_Entity; @@ -7991,7 +8040,9 @@ package body Exp_Ch9 is Make_Integer_Literal (Loc, Num_Attach_Handler)))); end if; - elsif Has_Interrupt_Handler (Prot_Typ) then + elsif Has_Interrupt_Handler (Prot_Typ) + and then not Restriction_Active (No_Dynamic_Attachment) + then Protection_Subtype := Make_Subtype_Indication ( Sloc => Loc, @@ -12029,10 +12080,13 @@ package body Exp_Ch9 is if Has_Attach_Handler (Conc_Typ) and then not Restricted_Profile + and then not Restriction_Active (No_Dynamic_Attachment) then Prot_Typ := RE_Static_Interrupt_Protection; - elsif Has_Interrupt_Handler (Conc_Typ) then + elsif Has_Interrupt_Handler (Conc_Typ) + and then not Restriction_Active (No_Dynamic_Attachment) + then Prot_Typ := RE_Dynamic_Interrupt_Protection; -- The type has explicit entries or generated primitive entry @@ -12449,8 +12503,8 @@ package body Exp_Ch9 is -- When no priority is specified but an xx_Handler pragma is, we default -- to System.Interrupts.Default_Interrupt_Priority, see D.3(10). - elsif Has_Interrupt_Handler (Ptyp) - or else Has_Attach_Handler (Ptyp) + elsif Has_Attach_Handler (Ptyp) + or else Has_Interrupt_Handler (Ptyp) then Append_To (Args, New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc)); @@ -12473,13 +12527,14 @@ package body Exp_Ch9 is -- context of dispatching select statements. if Has_Entry - or else Has_Interrupt_Handler (Ptyp) - or else Has_Attach_Handler (Ptyp) or else Has_Interfaces (Protect_Rec) + or else + ((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp)) + and then not Restriction_Active (No_Dynamic_Attachment)) then declare - Pkg_Id : constant RTU_Id := - Corresponding_Runtime_Package (Ptyp); + Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); + Called_Subp : RE_Id; begin @@ -12530,8 +12585,7 @@ package body Exp_Ch9 is Append_To (Args, Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To (P_Arr, Loc), + Prefix => New_Reference_To (P_Arr, Loc), Attribute_Name => Name_Unrestricted_Access)); -- Build_Entry_Names generation flag. When set to true, the diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 2d478467474..ce7c0dcc979 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -1006,9 +1006,8 @@ package body Exp_Intr is Nam2 : Node_Id; begin - -- An Abort followed by a Free will not do what the user - -- expects, because the abort is not immediate. This is - -- worth a friendly warning. + -- An Abort followed by a Free will not do what the user expects, + -- because the abort is not immediate. This is worth a warning. while Present (Stat) and then not Comes_From_Source (Original_Node (Stat)) @@ -1101,9 +1100,9 @@ package body Exp_Intr is if Present (Procedure_To_Call (Free_Node)) then - -- For all cases of a Deallocate call, the back-end needs to be - -- able to compute the size of the object being freed. This may - -- require some adjustments for objects of dynamic size. + -- For all cases of a Deallocate call, the back-end needs to be able + -- to compute the size of the object being freed. This may require + -- some adjustments for objects of dynamic size. -- -- If the type is class wide, we generate an implicit type with the -- right dynamic size, so that the deallocate call gets the right @@ -1175,8 +1174,8 @@ package body Exp_Intr is Set_Expression (Free_Node, Free_Arg); end if; - -- Only remaining step is to set result to null, or generate a - -- raise of constraint error if the target object is "not null". + -- Only remaining step is to set result to null, or generate a raise of + -- Constraint_Error if the target object is "not null". if Can_Never_Be_Null (Etype (Arg)) then Append_To (Stmts, diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index d7aba2447a7..c88c789432e 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -25,6 +25,7 @@ with Atree; use Atree; with Einfo; use Einfo; +with Elists; use Elists; with Exp_Util; use Exp_Util; with Namet; use Namet; with Nlists; use Nlists; @@ -1106,14 +1107,16 @@ package body Exp_Strm is Decl : out Node_Id; Fnam : out Entity_Id) is - Cn : Name_Id; - Constr : List_Id; - Decls : List_Id; - Discr : Entity_Id; - J : Pos; - Obj_Decl : Node_Id; - Odef : Node_Id; - Stms : List_Id; + B_Typ : constant Entity_Id := Base_Type (Typ); + Cn : Name_Id; + Constr : List_Id; + Decls : List_Id; + Discr : Entity_Id; + Discr_Elmt : Elmt_Id := No_Elmt; + J : Pos; + Obj_Decl : Node_Id; + Odef : Node_Id; + Stms : List_Id; begin Decls := New_List; @@ -1121,8 +1124,15 @@ package body Exp_Strm is J := 1; - if Has_Discriminants (Typ) then - Discr := First_Discriminant (Typ); + if Has_Discriminants (B_Typ) then + Discr := First_Discriminant (B_Typ); + + -- If the prefix subtype is constrained, then retrieve the first + -- element of its constraint. + + if Is_Constrained (Typ) then + Discr_Elmt := First_Elmt (Discriminant_Constraint (Typ)); + end if; while Present (Discr) loop Cn := New_External_Name ('C', J); @@ -1153,13 +1163,30 @@ package body Exp_Strm is Append_To (Constr, Make_Identifier (Loc, Cn)); + -- If the prefix subtype imposes a discriminant constraint, then + -- check that each discriminant value equals the value read. + + if Present (Discr_Elmt) then + Append_To (Decls, + Make_Raise_Constraint_Error (Loc, + Condition => Make_Op_Ne (Loc, + Left_Opnd => + New_Reference_To + (Defining_Identifier (Decl), Loc), + Right_Opnd => + New_Copy_Tree (Node (Discr_Elmt))), + Reason => CE_Discriminant_Check_Failed)); + + Next_Elmt (Discr_Elmt); + end if; + Next_Discriminant (Discr); J := J + 1; end loop; Odef := Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Subtype_Mark => New_Occurrence_Of (B_Typ, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constr)); @@ -1167,7 +1194,7 @@ package body Exp_Strm is -- If no discriminants, then just use the type with no constraint else - Odef := New_Occurrence_Of (Typ, Loc); + Odef := New_Occurrence_Of (B_Typ, Loc); end if; -- Create an extended return statement encapsulating the result object @@ -1184,7 +1211,7 @@ package body Exp_Strm is -- The object is about to get its value from Read, and if the type is -- null excluding we do not want spurious warnings on an initial null. - if Is_Access_Type (Typ) then + if Is_Access_Type (B_Typ) then Set_No_Initialization (Obj_Decl); end if; @@ -1195,15 +1222,15 @@ package body Exp_Strm is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), + Prefix => New_Occurrence_Of (B_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); + Fnam := Make_Stream_Subprogram_Name (Loc, B_Typ, TSS_Stream_Input); - Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms); + Build_Stream_Function (Loc, B_Typ, Decl, Fnam, Decls, Stms); end Build_Record_Or_Elementary_Input_Function; ------------------------------------------------- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 65311f8eec3..34901abafd4 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -480,6 +480,13 @@ package body Exp_Util is -- Start of processing for Build_Allocate_Deallocate_Proc begin + -- Do not perform this expansion in Alfa mode because it is not + -- necessary. + + if Alfa_Mode then + return; + end if; + -- Obtain the attributes of the allocation / deallocation if Nkind (N) = N_Free_Statement then @@ -1515,9 +1522,6 @@ package body Exp_Util is if Ekind (Typ) in Protected_Kind then if Has_Entries (Typ) - or else Has_Interrupt_Handler (Typ) - or else (Has_Attach_Handler (Typ) - and then not Restricted_Profile) -- A protected type without entries that covers an interface and -- overrides the abstract routines with protected procedures is @@ -1527,12 +1531,16 @@ package body Exp_Util is -- node to recognize this case. or else Present (Interface_List (Parent (Typ))) + or else + (((Has_Attach_Handler (Typ) and then not Restricted_Profile) + or else Has_Interrupt_Handler (Typ)) + and then not Restriction_Active (No_Dynamic_Attachment)) then if Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False or else Number_Entries (Typ) > 1 or else (Has_Attach_Handler (Typ) - and then not Restricted_Profile) + and then not Restricted_Profile) then Pkg_Id := System_Tasking_Protected_Objects_Entries; else @@ -1559,10 +1567,8 @@ package body Exp_Util is if Act_ST = Etype (Exp) then return; - else - Rewrite (Exp, - Convert_To (Act_ST, Relocate_Node (Exp))); + Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp))); Analyze_And_Resolve (Exp, Act_ST); end if; end Convert_To_Actual_Subtype; @@ -1643,7 +1649,6 @@ package body Exp_Util is Name_Req : Boolean := False) return Node_Id is New_Exp : Node_Id; - begin Remove_Side_Effects (Exp, Name_Req); New_Exp := New_Copy_Tree (Exp); @@ -3882,50 +3887,61 @@ package body Exp_Util is (Trans_Id : Entity_Id; First_Stmt : Node_Id) return Boolean is - function Extract_Renamed_Object - (Ren_Decl : Node_Id) return Entity_Id; + function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id; -- Given an object renaming declaration, retrieve the entity of the -- renamed name. Return Empty if the renamed name is anything other -- than a variable or a constant. - ---------------------------- - -- Extract_Renamed_Object -- - ---------------------------- + ------------------------- + -- Find_Renamed_Object -- + ------------------------- - function Extract_Renamed_Object - (Ren_Decl : Node_Id) return Entity_Id - is - Change : Boolean; - Ren_Obj : Node_Id; + function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is + Ren_Obj : Node_Id := Empty; - begin - Change := True; - Ren_Obj := Renamed_Object (Defining_Identifier (Ren_Decl)); + function Find_Object (N : Node_Id) return Traverse_Result; + -- Try to detect an object which is either a constant or a + -- variable. - while Change loop - Change := False; + ----------------- + -- Find_Object -- + ----------------- - if Nkind_In (Ren_Obj, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component) - then - Ren_Obj := Prefix (Ren_Obj); - Change := True; + function Find_Object (N : Node_Id) return Traverse_Result is + begin + -- Stop the search once a constant or a variable has been + -- detected. - elsif Nkind_In (Ren_Obj, N_Type_Conversion, - N_Unchecked_Type_Conversion) + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + and then Ekind_In (Entity (N), E_Constant, E_Variable) then - Ren_Obj := Expression (Ren_Obj); - Change := True; + Ren_Obj := Entity (N); + return Abandon; end if; - end loop; - if Nkind (Ren_Obj) in N_Has_Entity then - return Entity (Ren_Obj); + return OK; + end Find_Object; + + procedure Search is new Traverse_Proc (Find_Object); + + -- Local variables + + Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl)); + + -- Start of processing for Find_Renamed_Object + + begin + -- Actions related to dispatching calls may appear as renamings of + -- tags. Do not process this type of renaming because it does not + -- use the actual value of the object. + + if not Is_RTE (Typ, RE_Tag_Ptr) then + Search (Name (Ren_Decl)); end if; - return Empty; - end Extract_Renamed_Object; + return Ren_Obj; + end Find_Renamed_Object; -- Local variables @@ -3950,7 +3966,7 @@ package body Exp_Util is end if; elsif Nkind (Stmt) = N_Object_Renaming_Declaration then - Ren_Obj := Extract_Renamed_Object (Stmt); + Ren_Obj := Find_Renamed_Object (Stmt); if Present (Ren_Obj) and then Ren_Obj = Trans_Id @@ -3971,7 +3987,6 @@ package body Exp_Util is 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)) @@ -3994,30 +4009,30 @@ 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. + -- 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. + -- Do not consider transient objects allocated on the heap since + -- they are attached to a finalization master. and then not Is_Allocated (Obj_Id) - -- If the transient object is a pointer, check that it is not - -- initialized by a function which returns a pointer or acts as a - -- renaming of another pointer. + -- If the transient object is a pointer, check that it is not + -- initialized by a function which returns a pointer or acts as a + -- renaming of another pointer. and then (not Is_Access_Type (Obj_Typ) or else not Initialized_By_Access (Obj_Id)) - -- Do not consider transient objects which act as indirect aliases of - -- build-in-place function results. + -- Do not consider transient objects which act as indirect aliases + -- of build-in-place function results. and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id) - -- Do not consider conversions of tags to class-wide types + -- Do not consider conversions of tags to class-wide types and then not Is_Tag_To_CW_Conversion (Obj_Id); end Is_Finalizable_Transient; @@ -4200,8 +4215,7 @@ package body Exp_Util is begin -- If component reference is for an array with non-static bounds, -- then it is always aligned: we can only process unaligned arrays - -- with static bounds (more accurately bounds known at compile - -- time). + -- with static bounds (more precisely compile time known bounds). if Is_Array_Type (T) and then not Compile_Time_Known_Bounds (T) @@ -4262,6 +4276,8 @@ package body Exp_Util is -- alignment, and we either know it is too small, or cannot tell, -- then the component may be unaligned. + -- What is the following commented out code ??? + -- if Known_Alignment (Etype (P)) -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment -- and then M > Alignment (Etype (P)) @@ -5688,6 +5704,12 @@ package body Exp_Util is when N_Slice => return Possible_Bit_Aligned_Component (Prefix (N)); + -- For an unchecked conversion, check whether the expression may + -- be bit-aligned. + + when N_Unchecked_Type_Conversion => + return Possible_Bit_Aligned_Component (Expression (N)); + -- If we have none of the above, it means that we have fallen off the -- top testing prefixes recursively, and we now have a stand alone -- object, where we don't have a problem. diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index cce88b9daed..07b01632f99 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -119,9 +119,9 @@ package body GNAT.Command_Line is (Config : in out Command_Line_Configuration; Switch : Switch_Definition); procedure Add - (Def : in out Alias_Definitions_List; - Alias : Alias_Definition); - -- Add a new element to Def. + (Def : in out Alias_Definitions_List; + Alias : Alias_Definition); + -- Add a new element to Def procedure Initialize_Switch_Def (Def : out Switch_Definition; @@ -226,9 +226,8 @@ package body GNAT.Command_Line is for J in S'Range loop if S (J) in 'A' .. 'Z' then S (J) := Character'Val - (Character'Pos (S (J)) + - Character'Pos ('a') - - Character'Pos ('A')); + (Character'Pos (S (J)) + + (Character'Pos ('a') - Character'Pos ('A'))); end if; end loop; end if; @@ -277,7 +276,8 @@ package body GNAT.Command_Line is -- go to the next level. elsif Is_Directory - (It.Dir_Name (1 .. It.Levels (Current).Name_Last) & S (1 .. Last)) + (It.Dir_Name (1 .. It.Levels (Current).Name_Last) & + S (1 .. Last)) and then S (1 .. Last) /= "." and then S (1 .. Last) /= ".." then @@ -402,6 +402,7 @@ package body GNAT.Command_Line is loop Parser.Current_Argument := Parser.Current_Argument + 1; end loop; + else return String'(1 .. 0 => ' '); end if; @@ -533,8 +534,8 @@ package body GNAT.Command_Line is Length := Length + 1; end loop; - -- Length now marks the separator after the current switch - -- Last will mark the last character of the name of the switch + -- Length now marks the separator after the current switch. Last will + -- mark the last character of the name of the switch. if Length = Index + 1 then P := Parameter_None; @@ -584,7 +585,7 @@ package body GNAT.Command_Line is -- If we have finished parsing the current command line item (there -- might be multiple switches in a single item), then go to the next - -- element + -- element. if Parser.Current_Argument > Parser.Arg_Count or else (Parser.Current_Index > @@ -615,7 +616,7 @@ package body GNAT.Command_Line is -- If it isn't a switch, return it immediately. We also know it -- isn't the parameter to a previous switch, since that has - -- already been handled + -- already been handled. if Switches (Switches'First) = '*' then Set_Parameter @@ -754,6 +755,7 @@ package body GNAT.Command_Line is First => End_Index + 2, Last => Arg'Last); Dummy := Goto_Next_Argument_In_Section (Parser); + else Parser.Current_Index := End_Index + 1; raise Invalid_Parameter; @@ -902,7 +904,7 @@ package body GNAT.Command_Line is Parser.Section (Parser.Current_Argument); end if; - -- Until we have the start of another section + -- Exit from loop if we have the start of another section if Index = Parser.Section'Last or else Parser.Section (Index + 1) /= 0 @@ -993,9 +995,9 @@ package body GNAT.Command_Line is Parser.Stop_At_First := Stop_At_First_Non_Switch; Parser.Section := (others => 1); - -- If we are using sections, we have to preprocess the command line - -- to delimit them. A section can be repeated, so we just give each - -- item on the command line a section number + -- If we are using sections, we have to preprocess the command line to + -- delimit them. A section can be repeated, so we just give each item + -- on the command line a section number Section_Num := 1; Section_Index := Section_Delimiters'First; @@ -1014,8 +1016,8 @@ package body GNAT.Command_Line is if Argument (Parser, Index)(1) = Parser.Switch_Character and then Argument (Parser, Index) = Parser.Switch_Character & - Section_Delimiters - (Section_Index .. Last - 1) + Section_Delimiters + (Section_Index .. Last - 1) then Parser.Section (Index) := 0; Delimiter_Found := True; @@ -1164,8 +1166,8 @@ package body GNAT.Command_Line is ---------- procedure Free (Parser : in out Opt_Parser) is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Opt_Parser_Data, Opt_Parser); + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Opt_Parser_Data, Opt_Parser); begin if Parser /= null and then Parser /= Command_Line_Parser @@ -1217,11 +1219,13 @@ package body GNAT.Command_Line is -- Add -- --------- - procedure Add (Config : in out Command_Line_Configuration; - Switch : Switch_Definition) + procedure Add + (Config : in out Command_Line_Configuration; + Switch : Switch_Definition) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Switch_Definitions, Switch_Definitions_List); + Tmp : Switch_Definitions_List; begin @@ -1253,8 +1257,10 @@ package body GNAT.Command_Line is procedure Add (Def : in out Alias_Definitions_List; Alias : Alias_Definition) is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Alias_Definitions, Alias_Definitions_List); + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation + (Alias_Definitions, Alias_Definitions_List); + Tmp : Alias_Definitions_List := Def; begin @@ -1433,7 +1439,7 @@ package body GNAT.Command_Line is if (Section = "" and then Config.Switches (J).Section = null) or else (Config.Switches (J).Section /= null - and then Config.Switches (J).Section.all = Section) + and then Config.Switches (J).Section.all = Section) then exit when Config.Switches (J).Switch /= null and then not Callback (Config.Switches (J).Switch.all, J); @@ -1475,6 +1481,7 @@ package body GNAT.Command_Line is else Append (Ret, " " & S); end if; + return True; end Add_Switch; @@ -1768,12 +1775,12 @@ package body GNAT.Command_Line is function Is_In_Config (Config_Switch : String; Index : Integer) return Boolean; -- If Switch is the same as Config_Switch, run the callback and sets - -- Found_In_Config to True + -- Found_In_Config to True. function Starts_With (Config_Switch : String; Index : Integer) return Boolean; -- if Switch starts with Config_Switch, sets Found_In_Config to True. - -- The return value is for the Foreach_Switch iterator + -- The return value is for the Foreach_Switch iterator. -------------------- -- Group_Analysis -- @@ -1832,9 +1839,7 @@ package body GNAT.Command_Line is end loop; end if; - if not Require_Parameter (Switch) - or else Last >= Param - then + if not Require_Parameter (Switch) or else Last >= Param then if Idx = Group'First and then Last = Group'Last and then Last < Param @@ -1860,6 +1865,7 @@ package body GNAT.Command_Line is Section, Prefix & Group (Idx .. Param - 1), Group (Param .. Last)); + else For_Each_Simple_Switch (Config, Section, Prefix & Group (Idx .. Last), ""); @@ -1881,7 +1887,6 @@ package body GNAT.Command_Line is Idx := Group'First; while Idx <= Group'Last loop Found := False; - Foreach (Config, Section); if not Found then @@ -1960,7 +1965,8 @@ package body GNAT.Command_Line is Decompose_Switch (Config_Switch, P, Last); if Looking_At - (Switch, Switch'First, Config_Switch (Config_Switch'First .. Last)) + (Switch, Switch'First, + Config_Switch (Config_Switch'First .. Last)) then -- Set first char of Param, and last char of Switch @@ -2546,7 +2552,9 @@ package body GNAT.Command_Line is if Result (C) /= null and then Compatible_Parameter (Params (C)) and then Looking_At - (Result (C).all, Result (C)'First, Cmd.Config.Prefixes (P).all) + (Result (C).all, + Result (C)'First, + Cmd.Config.Prefixes (P).all) then -- If we are still in the same section, group the switches @@ -2589,8 +2597,8 @@ package body GNAT.Command_Line is Group := Ada.Strings.Unbounded.To_Unbounded_String (Result (C) - (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. - Result (C)'Last)); + (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. + Result (C)'Last)); First := C; end if; end if; @@ -2642,8 +2650,8 @@ package body GNAT.Command_Line is if Result (E) /= null and then (Params (E) = null - or else Params (E) (Params (E)'First + 1 - .. Params (E)'Last) = Param) + or else Params (E) (Params (E)'First + 1 .. + Params (E)'Last) = Param) and then Result (E).all = Switch then return; @@ -2866,16 +2874,19 @@ package body GNAT.Command_Line is function Is_New_Section (Iter : Command_Line_Iterator) return Boolean is Section : constant String := Current_Section (Iter); + begin if Iter.Sections = null then return False; + elsif Iter.Current = Iter.Sections'First or else Iter.Sections (Iter.Current - 1) = null then return Section /= ""; - end if; - return Section /= Iter.Sections (Iter.Current - 1).all; + else + return Section /= Iter.Sections (Iter.Current - 1).all; + end if; end Is_New_Section; --------------------- @@ -2933,12 +2944,11 @@ package body GNAT.Command_Line is return ""; else + -- Return result, skipping separator + declare P : constant String := Iter.Params (Iter.Current).all; - begin - -- Skip separator - return P (P'First + 1 .. P'Last); end; end if; @@ -2972,16 +2982,21 @@ package body GNAT.Command_Line is ---------- procedure Free (Config : in out Command_Line_Configuration) is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Switch_Definitions, Switch_Definitions_List); - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Alias_Definitions, Alias_Definitions_List); + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation + (Switch_Definitions, Switch_Definitions_List); + + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation + (Alias_Definitions, Alias_Definitions_List); + begin if Config /= null then Free (Config.Prefixes); Free (Config.Sections); Free (Config.Usage); Free (Config.Help); + Free (Config.Help_Msg); if Config.Aliases /= null then for A in Config.Aliases'Range loop @@ -2989,6 +3004,7 @@ package body GNAT.Command_Line is Free (Config.Aliases (A).Expansion); Free (Config.Aliases (A).Section); end loop; + Unchecked_Free (Config.Aliases); end if; @@ -3026,9 +3042,10 @@ package body GNAT.Command_Line is --------------- procedure Set_Usage - (Config : in out Command_Line_Configuration; - Usage : String := "[switches] [arguments]"; - Help : String := "") + (Config : in out Command_Line_Configuration; + Usage : String := "[switches] [arguments]"; + Help : String := ""; + Help_Msg : String := "") is begin if Config = null then @@ -3036,8 +3053,12 @@ package body GNAT.Command_Line is end if; Free (Config.Usage); - Config.Usage := new String'(Usage); - Config.Help := new String'(Help); + Free (Config.Help); + Free (Config.Help_Msg); + + Config.Usage := new String'(Usage); + Config.Help := new String'(Help); + Config.Help_Msg := new String'(Help_Msg); end Set_Usage; ------------------ @@ -3065,6 +3086,7 @@ package body GNAT.Command_Line is procedure Display_Section_Help (Section : String) is Max_Len : Natural := 0; + begin -- ??? Special display for "*" @@ -3095,7 +3117,8 @@ package body GNAT.Command_Line is for S in Config.Switches'Range loop declare N : constant String := - Switch_Name (Config.Switches (S), Section); + Switch_Name (Config.Switches (S), Section); + begin if N /= "" then Put (" "); @@ -3171,9 +3194,7 @@ package body GNAT.Command_Line is if (Section = "" and then Def.Section = null) or else (Def.Section /= null and then Def.Section.all = Section) then - if Def.Switch /= null - and then Def.Switch.all = "*" - then + if Def.Switch /= null and then Def.Switch.all = "*" then return "[any switch]"; end if; @@ -3222,12 +3243,17 @@ package body GNAT.Command_Line is & " [switches] [arguments]"); end if; - Display_Section_Help (""); + if Config.Help_Msg /= null and then Config.Help_Msg.all /= "" then + Put_Line (Config.Help_Msg.all); - if Config.Sections /= null and then Config.Switches /= null then - for S in Config.Sections'Range loop - Display_Section_Help (Config.Sections (S).all); - end loop; + else + Display_Section_Help (""); + + if Config.Sections /= null and then Config.Switches /= null then + for S in Config.Sections'Range loop + Display_Section_Help (Config.Sections (S).all); + end loop; + end if; end if; end Display_Help; @@ -3291,6 +3317,7 @@ package body GNAT.Command_Line is with "Expected integer parameter for '" & Switch & "'"; end; + return; when Switch_String => @@ -3386,13 +3413,15 @@ package body GNAT.Command_Line is elsif C /= ASCII.NUL then if Full_Switch (Parser) = "h" - or else Full_Switch (Parser) = "-help" + or else + Full_Switch (Parser) = "-help" then Display_Help (Config); raise Exit_From_Command_Line; end if; -- Do switch expansion if needed + For_Each_Simple (Config, Section => Section_Name.all, @@ -3473,8 +3502,7 @@ package body GNAT.Command_Line is Start (Line, Iter, Expanded => Expanded); while Has_More (Iter) loop if Is_New_Section (Iter) then - Args (Count) := new String' - (Switch_Char & Current_Section (Iter)); + Args (Count) := new String'(Switch_Char & Current_Section (Iter)); Count := Count + 1; end if; diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index f19d7baea5b..9b2b0059788 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -664,11 +664,14 @@ package GNAT.Command_Line is -- Output is always initialized to the empty string. procedure Set_Usage - (Config : in out Command_Line_Configuration; - Usage : String := "[switches] [arguments]"; - Help : String := ""); + (Config : in out Command_Line_Configuration; + Usage : String := "[switches] [arguments]"; + Help : String := ""; + Help_Msg : String := ""); -- Defines the general format of the call to the application, and a short - -- help text. These are both displayed by Display_Help + -- help text. These are both displayed by Display_Help. When a non-empty + -- Help_Msg is given, it is used by Display_Help instead of the + -- automatically generated list of supported switches. procedure Display_Help (Config : Command_Line_Configuration); -- Display the help for the tool (ie its usage, and its supported switches) @@ -707,9 +710,9 @@ package GNAT.Command_Line is 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, if the - -- switch is not handled automatically. + -- Similar to the standard Getopt function. 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 @@ -726,12 +729,15 @@ package GNAT.Command_Line is -- will display an error message and raises Invalid_Switch again. -- -- This function automatically expands switches: - -- * If Define_Prefix was called (for instance "-gnaty") and the user - -- specifies "-gnatycb" on the command line, then Getopt returns - -- "-gnatyc" and "-gnatyb" separately. - -- * If Define_Alias was called (for instance "-gnatya = -gnatycb") then - -- the latter is returned (in this case it also expands -gnaty as per - -- the above. + -- + -- If Define_Prefix was called (for instance "-gnaty") and the user + -- specifies "-gnatycb" on the command line, then Getopt returns + -- "-gnatyc" and "-gnatyb" separately. + -- + -- If Define_Alias was called (for instance "-gnatya = -gnatycb") then + -- the latter is returned (in this case it also expands -gnaty as per + -- the above. + -- -- The goal is to make handling as easy as possible by leaving as much -- work as possible to this package. -- @@ -753,15 +759,17 @@ package GNAT.Command_Line is -- way to remove a switch from an existing command line. -- For instance: + -- declare -- Config : Command_Line_Configuration; -- Line : Command_Line; -- Args : Argument_List_Access; + -- begin -- Define_Switch (Config, "-gnatyc"); -- Define_Switch (Config, ...); -- for all valid switches -- Define_Prefix (Config, "-gnaty"); - -- + -- Set_Configuration (Line, Config); -- Add_Switch (Line, "-O2"); -- Add_Switch (Line, "-gnatyc"); @@ -1129,6 +1137,7 @@ private Aliases : Alias_Definitions_List; Usage : GNAT.OS_Lib.String_Access; Help : GNAT.OS_Lib.String_Access; + Help_Msg : GNAT.OS_Lib.String_Access; Switches : Switch_Definitions_List; -- List of expected switches (Used when expanding switch groups) end record; diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index c562a84944c..bf1fe9fdde0 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.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- -- @@ -195,6 +195,11 @@ package body GNAT.Sockets is procedure Narrow (Item : in out Socket_Set_Type); -- Update Last as it may be greater than the real last socket + procedure Check_For_Fd_Set (Fd : Socket_Type); + pragma Inline (Check_For_Fd_Set); + -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to + -- FD_SETSIZE, on platforms where fd_set is a bitmap. + -- Types needed for Datagram_Socket_Stream_Type type Datagram_Socket_Stream_Type is new Root_Stream_Type with record @@ -463,6 +468,33 @@ package body GNAT.Sockets is end if; end Bind_Socket; + ---------------------- + -- Check_For_Fd_Set -- + ---------------------- + + procedure Check_For_Fd_Set (Fd : Socket_Type) is + use SOSC; + + begin + -- On Windows, fd_set is a FD_SETSIZE array of socket ids: + -- no check required. Warnings suppressed because condition + -- is known at compile time. + + pragma Warnings (Off); + if Target_OS = Windows then + pragma Warnings (On); + + return; + + -- On other platforms, fd_set is an FD_SETSIZE bitmap: check + -- that Fd is within range (otherwise behaviour is undefined). + + elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then + raise Constraint_Error with "invalid value for socket set: " + & Image (Fd); + end if; + end Check_For_Fd_Set; + -------------------- -- Check_Selector -- -------------------- @@ -577,7 +609,10 @@ package body GNAT.Sockets is Socket : Socket_Type) is Last : aliased C.int := C.int (Item.Last); + begin + Check_For_Fd_Set (Socket); + if Item.Last /= No_Socket then Remove_Socket_From_Set (Item.Set'Access, C.int (Socket)); Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access); @@ -1454,6 +1489,8 @@ package body GNAT.Sockets is Socket : Socket_Type) return Boolean is begin + Check_For_Fd_Set (Socket); + return Item.Last /= No_Socket and then Socket <= Item.Last and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0; @@ -2100,6 +2137,8 @@ package body GNAT.Sockets is procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is begin + Check_For_Fd_Set (Socket); + if Item.Last = No_Socket then -- Uninitialized socket set, make sure it is properly zeroed out diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index c075ae542e2..51c28fb601a 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -42,7 +42,15 @@ package body GNAT.Sockets.Thin is pragma Pack (VMS_Msghdr); -- 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. + -- VMS 7.3. + + function Is_VMS_V7 return Integer; + pragma Import (C, Is_VMS_V7, "__gnat_is_vms_v7"); + -- Helper (defined in init.c) that returns a non-zero value if the VMS + -- version is 7.x. + + VMS_V7 : constant Boolean := Is_VMS_V7 /= 0; + -- True if VMS version is 7.x. Non_Blocking_Sockets : aliased Fd_Set; -- When this package is initialized with Process_Blocking_IO set to True, @@ -295,15 +303,24 @@ package body GNAT.Sockets.Thin is is Res : C.int; + Msg_Addr : System.Address; + GNAT_Msg : Msghdr; for GNAT_Msg'Address use Msg; pragma Import (Ada, GNAT_Msg); - VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg); + VMS_Msg : aliased VMS_Msghdr; begin + if VMS_V7 then + Msg_Addr := Msg; + else + VMS_Msg := VMS_Msghdr (GNAT_Msg); + Msg_Addr := VMS_Msg'Address; + end if; + loop - Res := Syscall_Recvmsg (S, VMS_Msg'Address, Flags); + Res := Syscall_Recvmsg (S, Msg_Addr, Flags); exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) @@ -311,7 +328,9 @@ package body GNAT.Sockets.Thin is delay Quantum; end loop; - GNAT_Msg := Msghdr (VMS_Msg); + if not VMS_V7 then + GNAT_Msg := Msghdr (VMS_Msg); + end if; return System.CRTL.ssize_t (Res); end C_Recvmsg; @@ -327,15 +346,24 @@ package body GNAT.Sockets.Thin is is Res : C.int; + Msg_Addr : System.Address; + GNAT_Msg : Msghdr; for GNAT_Msg'Address use Msg; pragma Import (Ada, GNAT_Msg); - VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg); + VMS_Msg : aliased VMS_Msghdr; begin + if VMS_V7 then + Msg_Addr := Msg; + else + VMS_Msg := VMS_Msghdr (GNAT_Msg); + Msg_Addr := VMS_Msg'Address; + end if; + loop - Res := Syscall_Sendmsg (S, VMS_Msg'Address, Flags); + Res := Syscall_Sendmsg (S, Msg_Addr, Flags); exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) @@ -343,7 +371,9 @@ package body GNAT.Sockets.Thin is delay Quantum; end loop; - GNAT_Msg := Msghdr (VMS_Msg); + if not VMS_V7 then + GNAT_Msg := Msghdr (VMS_Msg); + end if; return System.CRTL.ssize_t (Res); end C_Sendmsg; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 2d97a4417e8..f199a69dac2 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -545,6 +545,39 @@ gnat1$(exeext): $(TARGET_ADA_SRCS) $(GNAT1_OBJS) $(ADA_BACKEND) libcommon-target gnatbind$(exeext): ada/b_gnatb.o $(CONFIG_H) $(GNATBIND_OBJS) ggc-none.o libcommon-target.a $(LIBDEPS) +$(GCC_LINK) -o $@ ada/b_gnatb.o $(GNATBIND_OBJS) ggc-none.o libcommon-target.a $(LIBS) $(SYSLIBS) $(CFLAGS) +# use target-gcc target-gnatmake target-gnatbind target-gnatlink +gnattools: $(GCC_PARTS) $(CONFIG_H) prefix.o force + $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \ + ADA_INCLUDES="-I- -I../rts"\ + CC="../../xgcc -B../../" GNATBIND="../../gnatbind" gnattools1 + $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools2 + +regnattools: + $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools1-re + $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools2 + +cross-gnattools: force + $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools1-re + $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools2 + $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools4 + +canadian-gnattools: force + $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools1-re + $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools2 + +gnatlib gnatlib-sjlj gnatlib-zcx gnatlib-shared: ada/s-oscons.ads force + $(MAKE) -C ada $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \ + THREAD_KIND="$(THREAD_KIND)" \ + TRACE="$(TRACE)" \ + FORCE_DEBUG_ADAFLAGS="$(FORCE_DEBUG_ADAFLAGS)" \ + $@ + +# use only for native compiler +gnatlib_and_tools: gnatlib gnattools + # use cross-gcc gnat-cross: force make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" \ @@ -1506,13 +1539,14 @@ ada/bindgen.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/bindusg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/bindusg.ads ada/bindusg.adb \ - ada/debug.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ - ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/system.ads \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + ada/debug.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \ + ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads \ + ada/switch.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/widechar.ads ada/butil.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/butil.ads ada/butil.adb \ @@ -2562,21 +2596,21 @@ ada/exp_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_strm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/exp_strm.ads ada/exp_strm.adb ada/exp_tss.ads \ - ada/exp_util.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_util.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/elists.ads ada/elists.adb ada/exp_strm.ads ada/exp_strm.adb \ + ada/exp_tss.ads ada/exp_util.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/exp_tss.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -2624,18 +2658,19 @@ ada/exp_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_disp.ads ada/sem_eval.ads \ ada/sem_eval.adb ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \ ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/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/urealp.adb ada/validsw.ads ada/widechar.ads + ada/sinfo.adb ada/sinput.ads ada/sinput.adb 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/urealp.adb ada/validsw.ads \ + ada/widechar.ads ada/exp_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 1afe6c00562..6f8cf3b4beb 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -434,14 +434,6 @@ X86_TARGET_PAIRS = \ g-bytswa.adb<g-bytswa-x86.adb \ s-atocou.adb<s-atocou-x86.adb -# 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 - X86_64_TARGET_PAIRS = \ a-numaux.ads<a-numaux-x86.ads \ a-numaux.adb<a-numaux-x86.adb \ @@ -598,7 +590,7 @@ ifeq ($(strip $(filter-out e500% powerpc% wrs vxworks,$(targ))),) endif # vxworks 653 -ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),) +ifeq ($(strip $(filter-out powerpc% e500v2 wrs vxworksae,$(targ))),) # target pairs for vthreads runtime LIBGNAT_TARGET_PAIRS = \ a-elchha.adb<a-elchha-vxworks-ppc-full.adb \ @@ -2172,6 +2164,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) endif ifeq ($(strip $(filter-out darwin%,$(osys))),) + SO_OPTS = -Wl,-flat_namespace -shared-libgcc ifeq ($(strip $(filter-out %86,$(arch))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-darwin.ads \ @@ -2192,6 +2185,7 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) LIBGNAT_TARGET_PAIRS += \ $(X86_64_TARGET_PAIRS) \ system.ads<system-darwin-x86_64.ads + SO_OPTS += -m64 else LIBGNAT_TARGET_PAIRS += \ $(X86_TARGET_PAIRS) \ @@ -2213,15 +2207,17 @@ 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 \ - $(ATOMICS_TARGET_PAIRS) \ - $(X86_64_TARGET_PAIRS) \ - system.ads<system-darwin-x86_64.ads + $(ATOMICS_TARGET_PAIRS) + ifeq ($(strip $(MULTISUBDIR)),/i386) LIBGNAT_TARGET_PAIRS += \ - system.ads<system-darwin-x86.ads + $(X86_TARGET_PAIRS) \ + system.ads<system-darwin-x86.ads + SO_OPTS += -m32 else LIBGNAT_TARGET_PAIRS += \ - system.ads<system-darwin-x86_64.ads + $(X86_64_TARGET_PAIRS) \ + system.ads<system-darwin-x86_64.ads endif endif @@ -2240,8 +2236,16 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) a-numaux.ads<a-numaux-darwin.ads \ a-numaux.adb<a-numaux-darwin.adb \ g-trasym.ads<g-trasym-unimplemented.ads \ - g-trasym.adb<g-trasym-unimplemented.adb \ - system.ads<system-darwin-ppc.ads + g-trasym.adb<g-trasym-unimplemented.adb + + ifeq ($(strip $(MULTISUBDIR)),/ppc64) + LIBGNAT_TARGET_PAIRS += \ + system.ads<system-darwin-ppc64.ads + SO_OPTS += -m64 + else + LIBGNAT_TARGET_PAIRS += \ + system.ads<system-darwin-ppc.ads + endif endif TOOLS_TARGET_PAIRS = \ @@ -2250,7 +2254,6 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) EH_MECHANISM=-gcc GNATLIB_SHARED = gnatlib-shared-darwin - SO_OPTS = -Wl,-flat_namespace -shared-libgcc RANLIB = ranlib -c GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) @@ -2323,8 +2326,32 @@ ADA_INCLUDE_SRCS =\ LIBGNAT=../$(RTSDIR)/libgnat.a +TOOLS_FLAGS_TO_PASS= \ + "CC=$(CC)" \ + "CFLAGS=$(CFLAGS)" \ + "LDFLAGS=$(LDFLAGS)" \ + "ADAFLAGS=$(ADAFLAGS)" \ + "INCLUDES=$(INCLUDES_FOR_SUBDIR)"\ + "ADA_INCLUDES=$(ADA_INCLUDES) $(ADA_INCLUDES_FOR_SUBDIR)"\ + "libsubdir=$(libsubdir)" \ + "exeext=$(exeext)" \ + "fsrcdir=$(fsrcdir)" \ + "srcdir=$(fsrcdir)" \ + "TOOLS_LIBS=$(TOOLS_LIBS) $(TGT_LIB)" \ + "GNATMAKE=$(GNATMAKE)" \ + "GNATLINK=$(GNATLINK)" \ + "GNATBIND=$(GNATBIND)" + GCC_LINK=$(CC) $(GCC_LINK_FLAGS) $(ADA_INCLUDES) +# Build directory for the tools. Let's copy the target-dependent +# sources using the same mechanism as for gnatlib. The other sources are +# accessed using the vpath directive below +# Note: dummy target, stamp-tools is mainly handled by gnattools. + +../stamp-tools: + touch ../stamp-tools + # when compiling the tools, the runtime has to be first on the path so that # it hides the runtime files lying with the rest of the sources ifeq ($(TOOLSCASE),native) @@ -2343,8 +2370,39 @@ ifeq ($(TOOLSCASE),cross) vpath %.h ../ endif -common-tools: - $(GNATMAKE) -c -b $(ADA_INCLUDES) \ +# gnatmake/link tools cannot always be built with gnatmake/link for bootstrap +# reasons: gnatmake should be built with a recent compiler, a recent compiler +# may not generate ALI files compatible with an old gnatmake so it is important +# to be able to build gnatmake without a version of gnatmake around. Once +# everything has been compiled once, gnatmake can be recompiled with itself +# (see target gnattools1-re) +gnattools1: ../stamp-tools ../stamp-gnatlib-$(RTSDIR) + $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \ + TOOLSCASE=native \ + ../../gnatmake$(exeext) ../../gnatlink$(exeext) + +# gnatmake/link can be built with recent gnatmake/link if they are available. +# This is especially convenient for building cross tools or for rebuilding +# the tools when the original bootstrap has already be done. +gnattools1-re: ../stamp-tools + $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \ + TOOLSCASE=cross INCLUDES="" gnatmake-re gnatlink-re + +# these tools are built with gnatmake & are common to native and cross +gnattools2: ../stamp-tools + $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \ + TOOLSCASE=native common-tools $(EXTRA_GNATTOOLS) + +# those tools are only built for the cross version +gnattools4: ../stamp-tools +ifeq ($(ENABLE_VXADDR2LINE),true) + $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \ + TOOLSCASE=cross top_buildir=../../.. \ + ../../vxaddr2line$(exeext) +endif + +common-tools: ../stamp-tools + $(GNATMAKE) -j0 -c -b $(ADA_INCLUDES) \ --GNATBIND="$(GNATBIND)" --GCC="$(CC) $(ALL_ADAFLAGS)" \ gnatchop gnatcmd gnatkr gnatls gnatprep gnatxref gnatfind gnatname \ gnatclean -bargs $(ADA_INCLUDES) $(GNATBIND_FLAGS) @@ -2367,32 +2425,34 @@ common-tools: $(GNATLINK) -v gnatclean -o ../../gnatclean$(exeext) \ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) -../../gnatsym$(exeext): +../../gnatsym$(exeext): ../stamp-tools $(GNATMAKE) -c $(ADA_INCLUDES) gnatsym --GCC="$(CC) $(ALL_ADAFLAGS)" $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatsym $(GNATLINK) -v gnatsym -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) -../../gnatdll$(exeext): +../../gnatdll$(exeext): ../stamp-tools $(GNATMAKE) -c $(ADA_INCLUDES) gnatdll --GCC="$(CC) $(ALL_ADAFLAGS)" $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatdll $(GNATLINK) -v gnatdll -o $@ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) -../../vxaddr2line$(exeext): targext.o +../../vxaddr2line$(exeext): ../stamp-tools targext.o $(GNATMAKE) -c $(ADA_INCLUDES) vxaddr2line --GCC="$(CC) $(ALL_ADAFLAGS)" $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vxaddr2line $(GNATLINK) -v vxaddr2line -o $@ --GCC="$(GCC_LINK)" targext.o $(CLIB) -gnatmake-re: link.o targext.o - $(GNATMAKE) $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)" - $(GNATMAKE) -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)" +gnatmake-re: ../stamp-tools link.o targext.o + $(GNATMAKE) -j0 $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)" + $(GNATMAKE) -j0 -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)" $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatmake $(GNATLINK) -v gnatmake -o ../../gnatmake$(exeext) \ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) # Note the use of the "mv" command in order to allow gnatlink to be linked with # with the former version of gnatlink itself which cannot override itself. -gnatlink-re: link.o targext.o - $(GNATMAKE) -c $(ADA_INCLUDES) gnatlink --GCC="$(CC) $(ALL_ADAFLAGS)" +# gnatlink-re cannot be run at the same time as gnatmake-re, hence the +# dependency +gnatlink-re: ../stamp-tools link.o targext.o gnatmake-re + $(GNATMAKE) -j0 -c $(ADA_INCLUDES) gnatlink --GCC="$(CC) $(ALL_ADAFLAGS)" $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatlink $(GNATLINK) -v gnatlink -o ../../gnatlinknew$(exeext) \ --GCC="$(GCC_LINK)" $(TOOLS_LIBS) @@ -2671,7 +2731,7 @@ gnatlib-shared-darwin: $(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) \ $(SO_OPTS) \ -Wl,-install_name,@rpath/libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \ - $(MISCLIB) -lm + $(MISCLIB) cd $(RTSDIR); `echo "$(GCC_FOR_TARGET)" \ | sed -e 's,\./xgcc,../../xgcc,' -e 's,-B\./,-B../../,'` -dynamiclib $(PICFLAG_FOR_TARGET) \ -o libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 8e0ccd41701..13df71f129c 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -1878,6 +1878,20 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) prefix_unused = true; break; + case Attr_Descriptor_Size: + gnu_type = TREE_TYPE (gnu_prefix); + gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE); + + /* What we want is the offset of the ARRAY field in the record that the + thin pointer designates, but the components have been shifted so this + is actually the opposite of the offset of the BOUNDS field. */ + gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type); + gnu_result = size_binop (MINUS_EXPR, bitsize_zero_node, + bit_position (TYPE_FIELDS (gnu_type))); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + prefix_unused = true; + break; + case Attr_Null_Parameter: /* This is just a zero cast to the pointer type for our prefix and dereferenced. */ diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 5cc0cb6db2b..666d251273d 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -236,6 +236,7 @@ Implementation Defined Attributes * Compiler_Version:: * Code_Address:: * Default_Bit_Order:: +* Descriptor_Size:: * Elaborated:: * Elab_Body:: * Elab_Spec:: @@ -5718,6 +5719,7 @@ consideration, you should minimize the use of these attributes. * Compiler_Version:: * Code_Address:: * Default_Bit_Order:: +* Descriptor_Size:: * Elaborated:: * Elab_Body:: * Elab_Spec:: @@ -5879,7 +5881,7 @@ the containing record @var{R}. @code{Standard'Compiler_Version} (@code{Standard} is the only allowed prefix) yields a static string identifying the version of the compiler being used to compile the unit containing the attribute reference. A -typical result would be something like "@value{EDITION} @value{gnat_version} (20090221)". +typical result would be something like "@value{EDITION} @i{version} (20090221)". @node Code_Address @unnumberedsec Code_Address @@ -5932,6 +5934,30 @@ as a @code{Pos} value (0 for @code{High_Order_First}, 1 for @code{Low_Order_First}). This is used to construct the definition of @code{Default_Bit_Order} in package @code{System}. +@node Descriptor_Size +@unnumberedsec Descriptor_Size +@cindex Descriptor +@cindex Dope vector +@findex Descriptor_Size +@noindent +Non-static attribute @code{Descriptor_Size} returns the size in bits of the +descriptor allocated for a type. The result is non-zero only for unconstrained +array types and the returned value is of type universal integer. In GNAT, an +array descriptor contains bounds information and is located immediately before +the first element of the array. + +@smallexample @c ada +type Unconstr_Array is array (Positive range <>) of Boolean; +Put_Line ("Descriptor size = " & Unconstr_Array'Descriptor_Size'Img); +@end smallexample + +@noindent +The attribute takes into account any additional padding due to type alignment. +In the example above, the descriptor contains two values of type +@code{Positive} representing the low and high bound. Since @code{Positive} has +a size of 31 bits and an alignment of 4, the descriptor size is @code{2 * +Positive'Size + 2} or 64 bits. + @node Elaborated @unnumberedsec Elaborated @findex Elaborated @@ -8988,6 +9014,17 @@ in a distributed environment. If this exception is active, then the generated code is simplified by omitting the otherwise-required global registration of exceptions when they are declared. +@item No_Implicit_Aliasing +@findex No_Implicit_Aliasing + +This restriction, which is not required to be partition-wide consistent, +requires an explicit aliased keyword for an object to which 'Access, +'Unchecked_Access, or 'Address is applied, and forbids entirely the use of +the 'Unrestricted_Access attribute for objects. Note: the reason that +Unrestricted_Access is forbidden is that it would require the prefix +to be aliased, and in such cases, it can always be replaced by +the standard attribute Unchecked_Access which is preferable. + @item No_Implicit_Conditionals @findex No_Implicit_Conditionals This restriction ensures that the generated code does not contain any diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 145c66ea8e0..e17716709d4 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -13071,8 +13071,6 @@ Reformat comment blocks @item ^-c5^/COMMENTS_LAYOUT=KEEP_SPECIAL^ Keep unchanged special form comments -Reformat comment blocks - @cindex @option{^-l@var{n}^/CONSTRUCT_LAYOUT^} (@command{gnatpp}) @item ^-l1^/CONSTRUCT_LAYOUT=GNAT^ GNAT-style layout (this is the default) @@ -14237,7 +14235,23 @@ outermost unit and for each eligible local unit: @table @emph @item LSLOC (``Logical Source Lines Of Code'') -The total number of declarations and the total number of statements +The total number of declarations and the total number of statements. Note +that the definition of declarations is the one given in the reference +manual: + +@noindent +``Each of the following is defined to be a declaration: any basic_declaration; +an enumeration_literal_specification; a discriminant_specification; +a component_declaration; a loop_parameter_specification; a +parameter_specification; a subprogram_body; an entry_declaration; +an entry_index_specification; a choice_parameter_specification; +a generic_formal_parameter_declaration.'' + +This means for example that each enumeration literal adds one to the count, +as well as each subprogram parameter. + +Thus the results from this metric will be significantly greater than might +be expected from a naive view of counting semicolons. @item Maximal static nesting level of inner program units According to diff --git a/gcc/ada/gnatchop.adb b/gcc/ada/gnatchop.adb index c72ac75b1f0..4cec050321c 100644 --- a/gcc/ada/gnatchop.adb +++ b/gcc/ada/gnatchop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -1361,6 +1361,9 @@ procedure Gnatchop is "[-r] [-p] [-q] [-v] [-w] [-x] [--GCC=xx] file [file ...] [dir]"); New_Line; + + Display_Usage_Version_And_Help; + Put_Line (" -c compilation mode, configuration pragmas " & "follow RM rules"); diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb index 8af7b9e4f8b..a98e013f2f8 100644 --- a/gcc/ada/gnatfind.adb +++ b/gcc/ada/gnatfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -299,6 +299,7 @@ procedure Gnatfind is & "references. This parameters are optional"); New_Line; Put_Line ("gnatfind switches:"); + Display_Usage_Version_And_Help; Put_Line (" -a Consider all files, even when the ali file is " & "readonly"); Put_Line (" -aIdir Specify source files search path"); diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 5afe2be6306..61d3db3861f 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -1422,6 +1422,8 @@ procedure Gnatlink is Write_Eol; Write_Line (" mainprog.ali the ALI file of the main program"); Write_Eol; + Write_Eol; + Display_Usage_Version_And_Help; Write_Line (" -f Force object file list to be generated"); Write_Line (" -g Compile binder source file with debug information"); Write_Line (" -n Do not compile the binder source file"); diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 5f9f2368993..7c7b41f89e8 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -1386,6 +1386,8 @@ procedure Gnatls is Write_Str ("switches:"); Write_Eol; + Display_Usage_Version_And_Help; + -- Line for -a Write_Str (" -a also output relevant predefined units"); diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index 00ebebe413e..c741834ec29 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -512,6 +512,8 @@ procedure Gnatname is Write_Eol; Write_Line ("switches:"); + Display_Usage_Version_And_Help; + Write_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs"); Write_Eol; diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb index c20ef175564..cbdf54a6d94 100644 --- a/gcc/ada/gnatxref.adb +++ b/gcc/ada/gnatxref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -257,6 +257,7 @@ procedure Gnatxref is "including with'ed units"); New_Line; Put_Line ("gnatxref switches:"); + Display_Usage_Version_And_Help; Put_Line (" -a Consider all files, even when the ali file is" & " readonly"); Put_Line (" -aIdir Specify source files search path"); diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb index 88710d6206c..f6ce3acf02e 100644 --- a/gcc/ada/gprep.adb +++ b/gcc/ada/gprep.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. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -808,6 +808,7 @@ package body GPrep is Write_Line (" deffile Name of the definition file"); Write_Eol; Write_Line ("gnatprep switches:"); + Display_Usage_Version_And_Help; Write_Line (" -b Replace preprocessor lines by blank lines"); Write_Line (" -c Keep preprocessor lines as comments"); Write_Line (" -C Do symbol replacements within comments"); diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index c3d250032fe..be1d05744f9 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -29,6 +29,7 @@ with Sinfo; use Sinfo; with Fname.UF; use Fname.UF; with Lib; use Lib; with Namet; use Namet; +with Opt; use Opt; with Uname; use Uname; -- Note: this package body is used by GPS and GNATBench to supply a list of @@ -37,7 +38,21 @@ with Uname; use Uname; package body Impunit is subtype File_Name_8 is String (1 .. 8); - type File_List is array (Nat range <>) of File_Name_8; + + type File_Name_Record is record + Fname : File_Name_8; + -- 8 character name of unit + + RMdef : Boolean; + -- True if unit is RM defined. False for any unit that is implementation + -- defined (and thus not with'able in No_Implementation_Units mode). + end record; + + type File_List is array (Nat range <>) of File_Name_Record; + + T : constant Boolean := True; + F : constant Boolean := False; + -- Short hand for RM_Defined values in lists below ------------------ -- Ada 95 Units -- @@ -58,130 +73,133 @@ package body Impunit is -- Ada Hierarchy Units from Ada-95 Reference Manual -- ------------------------------------------------------ - "a-astaco", -- Ada.Asynchronous_Task_Control - "a-calend", -- Ada.Calendar - "a-chahan", -- Ada.Characters.Handling - "a-charac", -- Ada.Characters - "a-chlat1", -- Ada.Characters.Latin_1 - "a-comlin", -- Ada.Command_Line - "a-decima", -- Ada.Decimal - "a-direio", -- Ada.Direct_IO - "a-dynpri", -- Ada.Dynamic_Priorities - "a-except", -- Ada.Exceptions - "a-finali", -- Ada.Finalization - "a-flteio", -- Ada.Float_Text_IO - "a-fwteio", -- Ada.Float_Wide_Text_IO - "a-inteio", -- Ada.Integer_Text_IO - "a-interr", -- Ada.Interrupts - "a-intnam", -- Ada.Interrupts.Names - "a-ioexce", -- Ada.IO_Exceptions - "a-iwteio", -- Ada.Integer_Wide_Text_IO - "a-ncelfu", -- Ada.Numerics.Complex_Elementary_Functions - "a-ngcefu", -- Ada.Numerics.Generic_Complex_Elementary_Functions - "a-ngcoty", -- Ada.Numerics.Generic_Complex_Types - "a-ngelfu", -- Ada.Numerics.Generic_Elementary_Functions - "a-nucoty", -- Ada.Numerics.Complex_Types - "a-nudira", -- Ada.Numerics.Discrete_Random - "a-nuelfu", -- Ada.Numerics.Elementary_Functions - "a-nuflra", -- Ada.Numerics.Float_Random - "a-numeri", -- Ada.Numerics - "a-reatim", -- Ada.Real_Time - "a-sequio", -- Ada.Sequential_IO - "a-stmaco", -- Ada.Strings.Maps.Constants - "a-storio", -- Ada.Storage_IO - "a-strbou", -- Ada.Strings.Bounded - "a-stream", -- Ada.Streams - "a-strfix", -- Ada.Strings.Fixed - "a-string", -- Ada.Strings - "a-strmap", -- Ada.Strings.Maps - "a-strunb", -- Ada.Strings.Unbounded - "a-ststio", -- Ada.Streams.Stream_IO - "a-stwibo", -- Ada.Strings.Wide_Bounded - "a-stwifi", -- Ada.Strings.Wide_Fixed - "a-stwima", -- Ada.Strings.Wide_Maps - "a-stwiun", -- Ada.Strings.Wide_Unbounded - "a-swmwco", -- Ada.Strings.Wide_Maps.Wide_Constants - "a-sytaco", -- Ada.Synchronous_Task_Control - "a-tags ", -- Ada.Tags - "a-tasatt", -- Ada.Task_Attributes - "a-taside", -- Ada.Task_Identification - "a-teioed", -- Ada.Text_IO.Editing - "a-textio", -- Ada.Text_IO - "a-ticoio", -- Ada.Text_IO.Complex_IO - "a-titest", -- Ada.Text_IO.Text_Streams - "a-unccon", -- Ada.Unchecked_Conversion - "a-uncdea", -- Ada.Unchecked_Deallocation - "a-witeio", -- Ada.Wide_Text_IO - "a-wtcoio", -- Ada.Wide_Text_IO.Complex_IO - "a-wtedit", -- Ada.Wide_Text_IO.Editing - "a-wttest", -- Ada.Wide_Text_IO.Text_Streams + ("a-astaco", T), -- Ada.Asynchronous_Task_Control + ("a-calend", T), -- Ada.Calendar + ("a-chahan", T), -- Ada.Characters.Handling + ("a-charac", T), -- Ada.Characters + ("a-chlat1", T), -- Ada.Characters.Latin_1 + ("a-comlin", T), -- Ada.Command_Line + ("a-decima", T), -- Ada.Decimal + ("a-direio", T), -- Ada.Direct_IO + ("a-dynpri", T), -- Ada.Dynamic_Priorities + ("a-except", T), -- Ada.Exceptions + ("a-finali", T), -- Ada.Finalization + ("a-flteio", T), -- Ada.Float_Text_IO + ("a-fwteio", T), -- Ada.Float_Wide_Text_IO + ("a-inteio", T), -- Ada.Integer_Text_IO + ("a-interr", T), -- Ada.Interrupts + ("a-intnam", T), -- Ada.Interrupts.Names + ("a-ioexce", T), -- Ada.IO_Exceptions + ("a-iwteio", T), -- Ada.Integer_Wide_Text_IO + ("a-ncelfu", T), -- Ada.Numerics.Complex_Elementary_Functions + ("a-ngcefu", T), -- Ada.Numerics.Generic_Complex_Elementary_Functions + ("a-ngcoty", T), -- Ada.Numerics.Generic_Complex_Types + ("a-ngelfu", T), -- Ada.Numerics.Generic_Elementary_Functions + ("a-nucoty", T), -- Ada.Numerics.Complex_Types + ("a-nudira", T), -- Ada.Numerics.Discrete_Random + ("a-nuelfu", T), -- Ada.Numerics.Elementary_Functions + ("a-nuflra", T), -- Ada.Numerics.Float_Random + ("a-numeri", T), -- Ada.Numerics + ("a-reatim", T), -- Ada.Real_Time + ("a-sequio", T), -- Ada.Sequential_IO + ("a-stmaco", T), -- Ada.Strings.Maps.Constants + ("a-storio", T), -- Ada.Storage_IO + ("a-strbou", T), -- Ada.Strings.Bounded + ("a-stream", T), -- Ada.Streams + ("a-strfix", T), -- Ada.Strings.Fixed + ("a-string", T), -- Ada.Strings + ("a-strmap", T), -- Ada.Strings.Maps + ("a-strunb", T), -- Ada.Strings.Unbounded + ("a-ststio", T), -- Ada.Streams.Stream_IO + ("a-stwibo", T), -- Ada.Strings.Wide_Bounded + ("a-stwifi", T), -- Ada.Strings.Wide_Fixed + ("a-stwima", T), -- Ada.Strings.Wide_Maps + ("a-stwiun", T), -- Ada.Strings.Wide_Unbounded + ("a-swmwco", T), -- Ada.Strings.Wide_Maps.Wide_Constants + ("a-sytaco", T), -- Ada.Synchronous_Task_Control + ("a-tags ", T), -- Ada.Tags + ("a-tasatt", T), -- Ada.Task_Attributes + ("a-taside", T), -- Ada.Task_Identification + ("a-teioed", T), -- Ada.Text_IO.Editing + ("a-textio", T), -- Ada.Text_IO + ("a-ticoio", T), -- Ada.Text_IO.Complex_IO + ("a-titest", T), -- Ada.Text_IO.Text_Streams + ("a-unccon", T), -- Ada.Unchecked_Conversion + ("a-uncdea", T), -- Ada.Unchecked_Deallocation + ("a-witeio", T), -- Ada.Wide_Text_IO + ("a-wtcoio", T), -- Ada.Wide_Text_IO.Complex_IO + ("a-wtedit", T), -- Ada.Wide_Text_IO.Editing + ("a-wttest", T), -- Ada.Wide_Text_IO.Text_Streams ------------------------------------------------- -- RM Required Additions to Ada for GNAT Types -- ------------------------------------------------- - "a-lfteio", -- Ada.Long_Float_Text_IO - "a-lfwtio", -- Ada.Long_Float_Wide_Text_IO - "a-liteio", -- Ada.Long_Integer_Text_IO - "a-liwtio", -- Ada.Long_Integer_Wide_Text_IO - "a-llftio", -- Ada.Long_Long_Float_Text_IO - "a-llfwti", -- Ada.Long_Long_Float_Wide_Text_IO - "a-llitio", -- Ada.Long_Long_Integer_Text_IO - "a-lliwti", -- Ada.Long_Long_Integer_Wide_Text_IO - "a-nlcefu", -- Ada.Long_Complex_Elementary_Functions - "a-nlcoty", -- Ada.Numerics.Long_Complex_Types - "a-nlelfu", -- Ada.Numerics.Long_Elementary_Functions - "a-nllcef", -- Ada.Long_Long_Complex_Elementary_Functions - "a-nllefu", -- Ada.Numerics.Long_Long_Elementary_Functions - "a-nllcty", -- Ada.Numerics.Long_Long_Complex_Types - "a-nscefu", -- Ada.Short_Complex_Elementary_Functions - "a-nscoty", -- Ada.Numerics.Short_Complex_Types - "a-nselfu", -- Ada.Numerics.Short_Elementary_Functions - "a-sfteio", -- Ada.Short_Float_Text_IO - "a-sfwtio", -- Ada.Short_Float_Wide_Text_IO - "a-siteio", -- Ada.Short_Integer_Text_IO - "a-siwtio", -- Ada.Short_Integer_Wide_Text_IO - "a-ssitio", -- Ada.Short_Short_Integer_Text_IO - "a-ssiwti", -- Ada.Short_Short_Integer_Wide_Text_IO + -- Note: Long versions are considered RM defined, but not the Long Long, + -- Short, or Short_Short versions. + + ("a-lfteio", T), -- Ada.Long_Float_Text_IO + ("a-lfwtio", T), -- Ada.Long_Float_Wide_Text_IO + ("a-liteio", T), -- Ada.Long_Integer_Text_IO + ("a-liwtio", T), -- Ada.Long_Integer_Wide_Text_IO + ("a-llftio", T), -- Ada.Long_Long_Float_Text_IO + ("a-llfwti", T), -- Ada.Long_Long_Float_Wide_Text_IO + ("a-llitio", T), -- Ada.Long_Long_Integer_Text_IO + ("a-lliwti", F), -- Ada.Long_Long_Integer_Wide_Text_IO + ("a-nlcefu", F), -- Ada.Long_Complex_Elementary_Functions + ("a-nlcoty", T), -- Ada.Numerics.Long_Complex_Types + ("a-nlelfu", T), -- Ada.Numerics.Long_Elementary_Functions + ("a-nllcef", F), -- Ada.Long_Long_Complex_Elementary_Functions + ("a-nllefu", F), -- Ada.Numerics.Long_Long_Elementary_Functions + ("a-nllcty", F), -- Ada.Numerics.Long_Long_Complex_Types + ("a-nscefu", F), -- Ada.Short_Complex_Elementary_Functions + ("a-nscoty", F), -- Ada.Numerics.Short_Complex_Types + ("a-nselfu", F), -- Ada.Numerics.Short_Elementary_Functions + ("a-sfteio", F), -- Ada.Short_Float_Text_IO + ("a-sfwtio", F), -- Ada.Short_Float_Wide_Text_IO + ("a-siteio", F), -- Ada.Short_Integer_Text_IO + ("a-siwtio", F), -- Ada.Short_Integer_Wide_Text_IO + ("a-ssitio", F), -- Ada.Short_Short_Integer_Text_IO + ("a-ssiwti", F), -- Ada.Short_Short_Integer_Wide_Text_IO ----------------------------------- -- GNAT Defined Additions to Ada -- ----------------------------------- - "a-calcon", -- Ada.Calendar.Conversions - "a-chlat9", -- Ada.Characters.Latin_9 - "a-clrefi", -- Ada.Command_Line.Response_File - "a-colien", -- Ada.Command_Line.Environment - "a-colire", -- Ada.Command_Line.Remove - "a-cwila1", -- Ada.Characters.Wide_Latin_1 - "a-cwila9", -- Ada.Characters.Wide_Latin_9 - "a-diocst", -- Ada.Direct_IO.C_Streams - "a-einuoc", -- Ada.Exceptions.Is_Null_Occurrence - "a-elchha", -- Ada.Exceptions.Last_Chance_Handler - "a-exctra", -- Ada.Exceptions.Traceback - "a-siocst", -- Ada.Sequential_IO.C_Streams - "a-ssicst", -- Ada.Streams.Stream_IO.C_Streams - "a-suteio", -- Ada.Strings.Unbounded.Text_IO - "a-swuwti", -- Ada.Strings.Wide_Unbounded.Wide_Text_IO - "a-tiocst", -- Ada.Text_IO.C_Streams - "a-wtcstr", -- Ada.Wide_Text_IO.C_Streams + ("a-calcon", F), -- Ada.Calendar.Conversions + ("a-chlat9", F), -- Ada.Characters.Latin_9 + ("a-clrefi", F), -- Ada.Command_Line.Response_File + ("a-colien", F), -- Ada.Command_Line.Environment + ("a-colire", F), -- Ada.Command_Line.Remove + ("a-cwila1", F), -- Ada.Characters.Wide_Latin_1 + ("a-cwila9", F), -- Ada.Characters.Wide_Latin_9 + ("a-diocst", F), -- Ada.Direct_IO.C_Streams + ("a-einuoc", F), -- Ada.Exceptions.Is_Null_Occurrence + ("a-elchha", F), -- Ada.Exceptions.Last_Chance_Handler + ("a-exctra", F), -- Ada.Exceptions.Traceback + ("a-siocst", F), -- Ada.Sequential_IO.C_Streams + ("a-ssicst", F), -- Ada.Streams.Stream_IO.C_Streams + ("a-suteio", F), -- Ada.Strings.Unbounded.Text_IO + ("a-swuwti", F), -- Ada.Strings.Wide_Unbounded.Wide_Text_IO + ("a-tiocst", F), -- Ada.Text_IO.C_Streams + ("a-wtcstr", F), -- Ada.Wide_Text_IO.C_Streams -- Note: strictly the next two should be Ada 2005 units, but it seems -- harmless (and useful) to make then available in Ada 95 mode, since -- they only deal with Wide_Character, not Wide_Wide_Character. - "a-wichun", -- Ada.Wide_Characters.Unicode - "a-widcha", -- Ada.Wide_Characters + ("a-wichun", F), -- Ada.Wide_Characters.Unicode + ("a-widcha", F), -- Ada.Wide_Characters -- Note: strictly the following should be Ada 2012 units, but it seems -- harmless (and useful) to make then available in Ada 95 mode, since -- they do not deal with Wide_Wide_Character. - "a-wichha", -- Ada.Wide_Characters.Handling - "a-stuten", -- Ada.Strings.UTF_Encoding - "a-suenco", -- Ada.Strings.UTF_Encoding.Conversions - "a-suenst", -- Ada.Strings.UTF_Encoding.Strings - "a-suewst", -- Ada.Strings.UTF_Encoding.Wide_Strings + ("a-wichha", F), -- Ada.Wide_Characters.Handling + ("a-stuten", F), -- Ada.Strings.UTF_Encoding + ("a-suenco", F), -- Ada.Strings.UTF_Encoding.Conversions + ("a-suenst", F), -- Ada.Strings.UTF_Encoding.Strings + ("a-suewst", F), -- Ada.Strings.UTF_Encoding.Wide_Strings --------------------------- -- GNAT Special IO Units -- @@ -195,167 +213,167 @@ package body Impunit is -- (if we did, then we would get a junk warning which would be confusing -- and unnecessary, given that we generate a clear error message). - "a-tideio", -- Ada.Text_IO.Decimal_IO - "a-tienio", -- Ada.Text_IO.Enumeration_IO - "a-tifiio", -- Ada.Text_IO.Fixed_IO - "a-tiflio", -- Ada.Text_IO.Float_IO - "a-tiinio", -- Ada.Text_IO.Integer_IO - "a-tiinio", -- Ada.Text_IO.Integer_IO - "a-timoio", -- Ada.Text_IO.Modular_IO - "a-wtdeio", -- Ada.Wide_Text_IO.Decimal_IO - "a-wtenio", -- Ada.Wide_Text_IO.Enumeration_IO - "a-wtfiio", -- Ada.Wide_Text_IO.Fixed_IO - "a-wtflio", -- Ada.Wide_Text_IO.Float_IO - "a-wtinio", -- Ada.Wide_Text_IO.Integer_IO - "a-wtmoio", -- Ada.Wide_Text_IO.Modular_IO + ("a-tideio", F), -- Ada.Text_IO.Decimal_IO + ("a-tienio", F), -- Ada.Text_IO.Enumeration_IO + ("a-tifiio", F), -- Ada.Text_IO.Fixed_IO + ("a-tiflio", F), -- Ada.Text_IO.Float_IO + ("a-tiinio", F), -- Ada.Text_IO.Integer_IO + ("a-tiinio", F), -- Ada.Text_IO.Integer_IO + ("a-timoio", F), -- Ada.Text_IO.Modular_IO + ("a-wtdeio", F), -- Ada.Wide_Text_IO.Decimal_IO + ("a-wtenio", F), -- Ada.Wide_Text_IO.Enumeration_IO + ("a-wtfiio", F), -- Ada.Wide_Text_IO.Fixed_IO + ("a-wtflio", F), -- Ada.Wide_Text_IO.Float_IO + ("a-wtinio", F), -- Ada.Wide_Text_IO.Integer_IO + ("a-wtmoio", F), -- Ada.Wide_Text_IO.Modular_IO ------------------------ -- GNAT Library Units -- ------------------------ - "g-altive", -- GNAT.Altivec - "g-altcon", -- GNAT.Altivec.Conversions - "g-alveop", -- GNAT.Altivec.Vector_Operations - "g-alvety", -- GNAT.Altivec.Vector_Types - "g-alvevi", -- GNAT.Altivec.Vector_Views - "g-arrspl", -- GNAT.Array_Split - "g-awk ", -- GNAT.AWK - "g-boubuf", -- GNAT.Bounded_Buffers - "g-boumai", -- GNAT.Bounded_Mailboxes - "g-bubsor", -- GNAT.Bubble_Sort - "g-busora", -- GNAT.Bubble_Sort_A - "g-busorg", -- GNAT.Bubble_Sort_G - "g-byorma", -- GNAT.Byte_Order_Mark - "g-bytswa", -- GNAT.Byte_Swapping - "g-calend", -- GNAT.Calendar - "g-catiio", -- GNAT.Calendar.Time_IO - "g-casuti", -- GNAT.Case_Util - "g-cgi ", -- GNAT.CGI - "g-cgicoo", -- GNAT.CGI.Cookie - "g-cgideb", -- GNAT.CGI.Debug - "g-comlin", -- GNAT.Command_Line - "g-comver", -- GNAT.Compiler_Version - "g-crc32 ", -- GNAT.CRC32 - "g-ctrl_c", -- GNAT.Ctrl_C - "g-curexc", -- GNAT.Current_Exception - "g-debpoo", -- GNAT.Debug_Pools - "g-debuti", -- GNAT.Debug_Utilities - "g-decstr", -- GNAT.Decode_String - "g-deutst", -- GNAT.Decode_UTF8_String - "g-dirope", -- GNAT.Directory_Operations - "g-diopit", -- GNAT.Directory_Operations.Iteration - "g-dynhta", -- GNAT.Dynamic_HTables - "g-dyntab", -- GNAT.Dynamic_Tables - "g-encstr", -- GNAT.Encode_String - "g-enutst", -- GNAT.Encode_UTF8_String - "g-excact", -- GNAT.Exception_Actions - "g-except", -- GNAT.Exceptions - "g-exctra", -- GNAT.Exception_Traces - "g-expect", -- GNAT.Expect - "g-flocon", -- GNAT.Float_Control - "g-heasor", -- GNAT.Heap_Sort - "g-hesora", -- GNAT.Heap_Sort_A - "g-hesorg", -- GNAT.Heap_Sort_G - "g-htable", -- GNAT.Htable - "g-io ", -- GNAT.IO - "g-io_aux", -- GNAT.IO_Aux - "g-locfil", -- GNAT.Lock_Files - "g-mbdira", -- GNAT.MBBS_Discrete_Random - "g-mbflra", -- GNAT.MBBS_Float_Random - "g-md5 ", -- GNAT.MD5 - "g-memdum", -- GNAT.Memory_Dump - "g-moreex", -- GNAT.Most_Recent_Exception - "g-os_lib", -- GNAT.Os_Lib - "g-pehage", -- GNAT.Perfect_Hash_Generators - "g-rannum", -- GNAT.Random_Numbers - "g-regexp", -- GNAT.Regexp - "g-regist", -- GNAT.Registry - "g-regpat", -- GNAT.Regpat - "g-semaph", -- GNAT.Semaphores - "g-sercom", -- GNAT.Serial_Communications - "g-sestin", -- GNAT.Secondary_Stack_Info - "g-sha1 ", -- GNAT.SHA1 - "g-sha224", -- GNAT.SHA224 - "g-sha256", -- GNAT.SHA256 - "g-sha384", -- GNAT.SHA384 - "g-sha512", -- GNAT.SHA512 - "g-signal", -- GNAT.Signals - "g-socket", -- GNAT.Sockets - "g-souinf", -- GNAT.Source_Info - "g-speche", -- GNAT.Spell_Checker - "g-spchge", -- GNAT.Spell_Checker_Generic - "g-spitbo", -- GNAT.Spitbol - "g-spipat", -- GNAT.Spitbol.Patterns - "g-sptabo", -- GNAT.Spitbol.Table_Boolean - "g-sptain", -- GNAT.Spitbol.Table_Integer - "g-sptavs", -- GNAT.Spitbol.Table_Vstring - "g-string", -- GNAT.Strings - "g-strspl", -- GNAT.String_Split - "g-sse ", -- GNAT.SSE - "g-ssvety", -- GNAT.SSE.Vector_Types - "g-table ", -- GNAT.Table - "g-tasloc", -- GNAT.Task_Lock - "g-tastus", -- GNAT.Task_Stack_Usage - "g-thread", -- GNAT.Threads - "g-timsta", -- GNAT.Time_Stamp - "g-traceb", -- GNAT.Traceback - "g-trasym", -- GNAT.Traceback.Symbolic - "g-utf_32", -- GNAT.UTF_32 - "g-u3spch", -- GNAT.UTF_32_Spelling_Checker - "g-wispch", -- GNAT.Wide_Spelling_Checker - "g-wistsp", -- GNAT.Wide_String_Split + ("g-altive", F), -- GNAT.Altivec + ("g-altcon", F), -- GNAT.Altivec.Conversions + ("g-alveop", F), -- GNAT.Altivec.Vector_Operations + ("g-alvety", F), -- GNAT.Altivec.Vector_Types + ("g-alvevi", F), -- GNAT.Altivec.Vector_Views + ("g-arrspl", F), -- GNAT.Array_Split + ("g-awk ", F), -- GNAT.AWK + ("g-boubuf", F), -- GNAT.Bounded_Buffers + ("g-boumai", F), -- GNAT.Bounded_Mailboxes + ("g-bubsor", F), -- GNAT.Bubble_Sort + ("g-busora", F), -- GNAT.Bubble_Sort_A + ("g-busorg", F), -- GNAT.Bubble_Sort_G + ("g-byorma", F), -- GNAT.Byte_Order_Mark + ("g-bytswa", F), -- GNAT.Byte_Swapping + ("g-calend", F), -- GNAT.Calendar + ("g-catiio", F), -- GNAT.Calendar.Time_IO + ("g-casuti", F), -- GNAT.Case_Util + ("g-cgi ", F), -- GNAT.CGI + ("g-cgicoo", F), -- GNAT.CGI.Cookie + ("g-cgideb", F), -- GNAT.CGI.Debug + ("g-comlin", F), -- GNAT.Command_Line + ("g-comver", F), -- GNAT.Compiler_Version + ("g-crc32 ", F), -- GNAT.CRC32 + ("g-ctrl_c", F), -- GNAT.Ctrl_C + ("g-curexc", F), -- GNAT.Current_Exception + ("g-debpoo", F), -- GNAT.Debug_Pools + ("g-debuti", F), -- GNAT.Debug_Utilities + ("g-decstr", F), -- GNAT.Decode_String + ("g-deutst", F), -- GNAT.Decode_UTF8_String + ("g-dirope", F), -- GNAT.Directory_Operations + ("g-diopit", F), -- GNAT.Directory_Operations.Iteration + ("g-dynhta", F), -- GNAT.Dynamic_HTables + ("g-dyntab", F), -- GNAT.Dynamic_Tables + ("g-encstr", F), -- GNAT.Encode_String + ("g-enutst", F), -- GNAT.Encode_UTF8_String + ("g-excact", F), -- GNAT.Exception_Actions + ("g-except", F), -- GNAT.Exceptions + ("g-exctra", F), -- GNAT.Exception_Traces + ("g-expect", F), -- GNAT.Expect + ("g-flocon", F), -- GNAT.Float_Control + ("g-heasor", F), -- GNAT.Heap_Sort + ("g-hesora", F), -- GNAT.Heap_Sort_A + ("g-hesorg", F), -- GNAT.Heap_Sort_G + ("g-htable", F), -- GNAT.Htable + ("g-io ", F), -- GNAT.IO + ("g-io_aux", F), -- GNAT.IO_Aux + ("g-locfil", F), -- GNAT.Lock_Files + ("g-mbdira", F), -- GNAT.MBBS_Discrete_Random + ("g-mbflra", F), -- GNAT.MBBS_Float_Random + ("g-md5 ", F), -- GNAT.MD5 + ("g-memdum", F), -- GNAT.Memory_Dump + ("g-moreex", F), -- GNAT.Most_Recent_Exception + ("g-os_lib", F), -- GNAT.Os_Lib + ("g-pehage", F), -- GNAT.Perfect_Hash_Generators + ("g-rannum", F), -- GNAT.Random_Numbers + ("g-regexp", F), -- GNAT.Regexp + ("g-regist", F), -- GNAT.Registry + ("g-regpat", F), -- GNAT.Regpat + ("g-semaph", F), -- GNAT.Semaphores + ("g-sercom", F), -- GNAT.Serial_Communications + ("g-sestin", F), -- GNAT.Secondary_Stack_Info + ("g-sha1 ", F), -- GNAT.SHA1 + ("g-sha224", F), -- GNAT.SHA224 + ("g-sha256", F), -- GNAT.SHA256 + ("g-sha384", F), -- GNAT.SHA384 + ("g-sha512", F), -- GNAT.SHA512 + ("g-signal", F), -- GNAT.Signals + ("g-socket", F), -- GNAT.Sockets + ("g-souinf", F), -- GNAT.Source_Info + ("g-speche", F), -- GNAT.Spell_Checker + ("g-spchge", F), -- GNAT.Spell_Checker_Generic + ("g-spitbo", F), -- GNAT.Spitbol + ("g-spipat", F), -- GNAT.Spitbol.Patterns + ("g-sptabo", F), -- GNAT.Spitbol.Table_Boolean + ("g-sptain", F), -- GNAT.Spitbol.Table_Integer + ("g-sptavs", F), -- GNAT.Spitbol.Table_Vstring + ("g-string", F), -- GNAT.Strings + ("g-strspl", F), -- GNAT.String_Split + ("g-sse ", F), -- GNAT.SSE + ("g-ssvety", F), -- GNAT.SSE.Vector_Types + ("g-table ", F), -- GNAT.Table + ("g-tasloc", F), -- GNAT.Task_Lock + ("g-tastus", F), -- GNAT.Task_Stack_Usage + ("g-thread", F), -- GNAT.Threads + ("g-timsta", F), -- GNAT.Time_Stamp + ("g-traceb", F), -- GNAT.Traceback + ("g-trasym", F), -- GNAT.Traceback.Symbolic + ("g-utf_32", F), -- GNAT.UTF_32 + ("g-u3spch", F), -- GNAT.UTF_32_Spelling_Checker + ("g-wispch", F), -- GNAT.Wide_Spelling_Checker + ("g-wistsp", F), -- GNAT.Wide_String_Split ----------------------------------------------------- -- Interface Hierarchy Units from Reference Manual -- ----------------------------------------------------- - "i-c ", -- Interfaces.C - "i-cobol ", -- Interfaces.Cobol - "i-cpoint", -- Interfaces.C.Pointers - "i-cstrin", -- Interfaces.C.Strings - "i-fortra", -- Interfaces.Fortran + ("i-c ", T), -- Interfaces.C + ("i-cobol ", T), -- Interfaces.Cobol + ("i-cpoint", T), -- Interfaces.C.Pointers + ("i-cstrin", T), -- Interfaces.C.Strings + ("i-fortra", T), -- Interfaces.Fortran ------------------------------------------ -- GNAT Defined Additions to Interfaces -- ------------------------------------------ - "i-cexten", -- Interfaces.C.Extensions - "i-cil ", -- Interfaces.CIL - "i-cilobj", -- Interfaces.CIL.Object - "i-cpp ", -- Interfaces.CPP - "i-cstrea", -- Interfaces.C.Streams - "i-java ", -- Interfaces.Java - "i-javjni", -- Interfaces.Java.JNI - "i-pacdec", -- Interfaces.Packed_Decimal - "i-vxwoio", -- Interfaces.VxWorks.IO - "i-vxwork", -- Interfaces.VxWorks + ("i-cexten", F), -- Interfaces.C.Extensions + ("i-cil ", F), -- Interfaces.CIL + ("i-cilobj", F), -- Interfaces.CIL.Object + ("i-cpp ", F), -- Interfaces.CPP + ("i-cstrea", F), -- Interfaces.C.Streams + ("i-java ", F), -- Interfaces.Java + ("i-javjni", F), -- Interfaces.Java.JNI + ("i-pacdec", F), -- Interfaces.Packed_Decimal + ("i-vxwoio", F), -- Interfaces.VxWorks.IO + ("i-vxwork", F), -- Interfaces.VxWorks -------------------------------------------------- -- System Hierarchy Units from Reference Manual -- -------------------------------------------------- - "s-atacco", -- System.Address_To_Access_Conversions - "s-maccod", -- System.Machine_Code - "s-rpc ", -- System.Rpc - "s-stoele", -- System.Storage_Elements - "s-stopoo", -- System.Storage_Pools + ("s-atacco", T), -- System.Address_To_Access_Conversions + ("s-maccod", T), -- System.Machine_Code + ("s-rpc ", T), -- System.Rpc + ("s-stoele", T), -- System.Storage_Elements + ("s-stopoo", T), -- System.Storage_Pools -------------------------------------- -- GNAT Defined Additions to System -- -------------------------------------- - "s-addima", -- System.Address_Image - "s-assert", -- System.Assertions - "s-memory", -- System.Memory - "s-parint", -- System.Partition_Interface - "s-pooglo", -- System.Pool_Global - "s-pooloc", -- System.Pool_Local - "s-restri", -- System.Restrictions - "s-rident", -- System.Rident - "s-ststop", -- System.Strings.Stream_Ops - "s-tasinf", -- System.Task_Info - "s-wchcnv", -- System.Wch_Cnv - "s-wchcon"); -- System.Wch_Con + ("s-addima", F), -- System.Address_Image + ("s-assert", F), -- System.Assertions + ("s-memory", F), -- System.Memory + ("s-parint", F), -- System.Partition_Interface + ("s-pooglo", F), -- System.Pool_Global + ("s-pooloc", F), -- System.Pool_Local + ("s-restri", F), -- System.Restrictions + ("s-rident", F), -- System.Rident + ("s-ststop", F), -- System.Strings.Stream_Ops + ("s-tasinf", F), -- System.Task_Info + ("s-wchcnv", F), -- System.Wch_Cnv + ("s-wchcon", F)); -- System.Wch_Con -------------------- -- Ada 2005 Units -- @@ -369,114 +387,117 @@ package body Impunit is -- Ada Hierarchy Units from Ada 2005 Reference Manual -- -------------------------------------------------------- - "a-assert", -- Ada.Assertions - "a-calari", -- Ada.Calendar.Arithmetic - "a-calfor", -- Ada.Calendar.Formatting - "a-catizo", -- Ada.Calendar.Time_Zones - "a-cdlili", -- Ada.Containers.Doubly_Linked_Lists - "a-cgarso", -- Ada.Containers.Generic_Array_Sort - "a-cgcaso", -- Ada.Containers.Generic_Constrained_Array_Sort - "a-chacon", -- Ada.Characters.Conversions - "a-cidlli", -- Ada.Containers.Indefinite_Doubly_Linked_Lists - "a-cihama", -- Ada.Containers.Indefinite_Hashed_Maps - "a-cihase", -- Ada.Containers.Indefinite_Hashed_Sets - "a-ciorma", -- Ada.Containers.Indefinite_Ordered_Maps - "a-ciorse", -- Ada.Containers.Indefinite_Ordered_Sets - "a-cohama", -- Ada.Containers.Hashed_Maps - "a-cohase", -- Ada.Containers.Hashed_Sets - "a-coinve", -- Ada.Containers.Indefinite_Vectors - "a-contai", -- Ada.Containers - "a-convec", -- Ada.Containers.Vectors - "a-coorma", -- Ada.Containers.Ordered_Maps - "a-coorse", -- Ada.Containers.Ordered_Sets - "a-coteio", -- Ada.Complex_Text_IO - "a-direct", -- Ada.Directories - "a-diroro", -- Ada.Dispatching.Round_Robin - "a-disedf", -- Ada.Dispatching.EDF - "a-dispat", -- Ada.Dispatching - "a-envvar", -- Ada.Environment_Variables - "a-etgrbu", -- Ada.Execution_Time.Group_Budgets - "a-exetim", -- Ada.Execution_Time - "a-extiti", -- Ada.Execution_Time.Timers - "a-izteio", -- Ada.Integer_Wide_Wide_Text_IO - "a-rttiev", -- Ada.Real_Time.Timing_Events - "a-ngcoar", -- Ada.Numerics.Generic_Complex_Arrays - "a-ngrear", -- Ada.Numerics.Generic_Real_Arrays - "a-nucoar", -- Ada.Numerics.Complex_Arrays - "a-nurear", -- Ada.Numerics.Real_Arrays - "a-stboha", -- Ada.Strings.Bounded.Hash - "a-stfiha", -- Ada.Strings.Fixed.Hash - "a-strhas", -- Ada.Strings.Hash - "a-stunha", -- Ada.Strings.Unbounded.Hash - "a-stwiha", -- Ada.Strings.Wide_Hash - "a-stzbou", -- Ada.Strings.Wide_Wide_Bounded - "a-stzfix", -- Ada.Strings.Wide_Wide_Fixed - "a-stzhas", -- Ada.Strings.Wide_Wide_Hash - "a-stzmap", -- Ada.Strings.Wide_Wide_Maps - "a-stzunb", -- Ada.Strings.Wide_Wide_Unbounded - "a-swbwha", -- Ada.Strings.Wide_Bounded.Wide_Hash - "a-swfwha", -- Ada.Strings.Wide_Fixed.Wide_Hash - "a-swuwha", -- Ada.Strings.Wide_Unbounded.Wide_Hash - "a-szbzha", -- Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash - "a-szfzha", -- Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash - "a-szmzco", -- Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants - "a-szuzha", -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash - "a-taster", -- Ada.Task_Termination - "a-tgdico", -- Ada.Tags.Generic_Dispatching_Constructor - "a-tiboio", -- Ada.Text_IO.Bounded_IO - "a-tiunio", -- Ada.Text_IO.Unbounded_IO - "a-wichun", -- Ada.Wide_Characters.Unicode - "a-wwboio", -- Ada.Wide_Text_IO.Wide_Bounded_IO - "a-wwunio", -- Ada.Wide_Text_IO.Wide_Unbounded_IO - "a-zchara", -- Ada.Wide_Wide_Characters - "a-zchhan", -- Ada.Wide_Wide_Characters.Handling - "a-ztcoio", -- Ada.Wide_Wide_Text_IO.Complex_IO - "a-ztedit", -- Ada.Wide_Wide_Text_IO.Editing - "a-zttest", -- Ada.Wide_Wide_Text_IO.Text_Streams - "a-ztexio", -- Ada.Wide_Wide_Text_IO - "a-zzboio", -- Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO - "a-zzunio", -- Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO + ("a-assert", T), -- Ada.Assertions + ("a-calari", T), -- Ada.Calendar.Arithmetic + ("a-calfor", T), -- Ada.Calendar.Formatting + ("a-catizo", T), -- Ada.Calendar.Time_Zones + ("a-cdlili", T), -- Ada.Containers.Doubly_Linked_Lists + ("a-cgarso", T), -- Ada.Containers.Generic_Array_Sort + ("a-cgcaso", T), -- Ada.Containers.Generic_Constrained_Array_Sort + ("a-chacon", T), -- Ada.Characters.Conversions + ("a-cidlli", T), -- Ada.Containers.Indefinite_Doubly_Linked_Lists + ("a-cihama", T), -- Ada.Containers.Indefinite_Hashed_Maps + ("a-cihase", T), -- Ada.Containers.Indefinite_Hashed_Sets + ("a-ciorma", T), -- Ada.Containers.Indefinite_Ordered_Maps + ("a-ciorse", T), -- Ada.Containers.Indefinite_Ordered_Sets + ("a-cohama", T), -- Ada.Containers.Hashed_Maps + ("a-cohase", T), -- Ada.Containers.Hashed_Sets + ("a-coinve", T), -- Ada.Containers.Indefinite_Vectors + ("a-contai", T), -- Ada.Containers + ("a-convec", T), -- Ada.Containers.Vectors + ("a-coorma", T), -- Ada.Containers.Ordered_Maps + ("a-coorse", T), -- Ada.Containers.Ordered_Sets + ("a-coteio", T), -- Ada.Complex_Text_IO + ("a-direct", T), -- Ada.Directories + ("a-diroro", T), -- Ada.Dispatching.Round_Robin + ("a-disedf", T), -- Ada.Dispatching.EDF + ("a-dispat", T), -- Ada.Dispatching + ("a-envvar", T), -- Ada.Environment_Variables + ("a-etgrbu", T), -- Ada.Execution_Time.Group_Budgets + ("a-exetim", T), -- Ada.Execution_Time + ("a-extiti", T), -- Ada.Execution_Time.Timers + ("a-izteio", T), -- Ada.Integer_Wide_Wide_Text_IO + ("a-rttiev", T), -- Ada.Real_Time.Timing_Events + ("a-ngcoar", T), -- Ada.Numerics.Generic_Complex_Arrays + ("a-ngrear", T), -- Ada.Numerics.Generic_Real_Arrays + ("a-nucoar", T), -- Ada.Numerics.Complex_Arrays + ("a-nurear", T), -- Ada.Numerics.Real_Arrays + ("a-stboha", T), -- Ada.Strings.Bounded.Hash + ("a-stfiha", T), -- Ada.Strings.Fixed.Hash + ("a-strhas", T), -- Ada.Strings.Hash + ("a-stunha", T), -- Ada.Strings.Unbounded.Hash + ("a-stwiha", T), -- Ada.Strings.Wide_Hash + ("a-stzbou", T), -- Ada.Strings.Wide_Wide_Bounded + ("a-stzfix", T), -- Ada.Strings.Wide_Wide_Fixed + ("a-stzhas", T), -- Ada.Strings.Wide_Wide_Hash + ("a-stzmap", T), -- Ada.Strings.Wide_Wide_Maps + ("a-stzunb", T), -- Ada.Strings.Wide_Wide_Unbounded + ("a-swbwha", T), -- Ada.Strings.Wide_Bounded.Wide_Hash + ("a-swfwha", T), -- Ada.Strings.Wide_Fixed.Wide_Hash + ("a-swuwha", T), -- Ada.Strings.Wide_Unbounded.Wide_Hash + ("a-szbzha", T), -- Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash + ("a-szfzha", T), -- Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash + ("a-szmzco", T), -- Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants + ("a-szuzha", T), -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash + ("a-taster", T), -- Ada.Task_Termination + ("a-tgdico", T), -- Ada.Tags.Generic_Dispatching_Constructor + ("a-tiboio", T), -- Ada.Text_IO.Bounded_IO + ("a-tiunio", T), -- Ada.Text_IO.Unbounded_IO + ("a-wichun", T), -- Ada.Wide_Characters.Unicode + ("a-wwboio", T), -- Ada.Wide_Text_IO.Wide_Bounded_IO + ("a-wwunio", T), -- Ada.Wide_Text_IO.Wide_Unbounded_IO + ("a-zchara", T), -- Ada.Wide_Wide_Characters + ("a-zchhan", T), -- Ada.Wide_Wide_Characters.Handling + ("a-ztcoio", T), -- Ada.Wide_Wide_Text_IO.Complex_IO + ("a-ztedit", T), -- Ada.Wide_Wide_Text_IO.Editing + ("a-zttest", T), -- Ada.Wide_Wide_Text_IO.Text_Streams + ("a-ztexio", T), -- Ada.Wide_Wide_Text_IO + ("a-zzboio", T), -- Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO + ("a-zzunio", T), -- Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO ------------------------------------------------------ -- RM Required Additions to Ada 2005 for GNAT Types -- ------------------------------------------------------ - "a-lcteio", -- Ada.Long_Complex_Text_IO - "a-lfztio", -- Ada.Long_Float_Wide_Wide_Text_IO - "a-liztio", -- Ada.Long_Integer_Wide_Wide_Text_IO - "a-llctio", -- Ada.Long_Long_Complex_Text_IO - "a-llfzti", -- Ada.Long_Long_Float_Wide_Wide_Text_IO - "a-llizti", -- Ada.Long_Long_Integer_Wide_Wide_Text_IO - "a-nlcoar", -- Ada.Numerics.Long_Complex_Arrays - "a-nllcar", -- Ada.Numerics.Long_Long_Complex_Arrays - "a-nllrar", -- Ada.Numerics.Long_Long_Real_Arrays - "a-nlrear", -- Ada.Numerics.Long_Real_Arrays - "a-scteio", -- Ada.Short_Complex_Text_IO - "a-sfztio", -- Ada.Short_Float_Wide_Wide_Text_IO - "a-siztio", -- Ada.Short_Integer_Wide_Wide_Text_IO - "a-ssizti", -- Ada.Short_Short_Integer_Wide_Wide_Text_IO - "a-ztcstr", -- Ada.Wide_Wide_Text_IO.C_Streams + -- Note: Long versions are considered RM defined, but not the Long Long, + -- Short, or Short_Short versions. + + ("a-lcteio", T), -- Ada.Long_Complex_Text_IO + ("a-lfztio", T), -- Ada.Long_Float_Wide_Wide_Text_IO + ("a-liztio", T), -- Ada.Long_Integer_Wide_Wide_Text_IO + ("a-llctio", T), -- Ada.Long_Long_Complex_Text_IO + ("a-llfzti", T), -- Ada.Long_Long_Float_Wide_Wide_Text_IO + ("a-llizti", T), -- Ada.Long_Long_Integer_Wide_Wide_Text_IO + ("a-nlcoar", T), -- Ada.Numerics.Long_Complex_Arrays + ("a-nllcar", T), -- Ada.Numerics.Long_Long_Complex_Arrays + ("a-nllrar", T), -- Ada.Numerics.Long_Long_Real_Arrays + ("a-nlrear", T), -- Ada.Numerics.Long_Real_Arrays + ("a-scteio", F), -- Ada.Short_Complex_Text_IO + ("a-sfztio", F), -- Ada.Short_Float_Wide_Wide_Text_IO + ("a-siztio", F), -- Ada.Short_Integer_Wide_Wide_Text_IO + ("a-ssizti", F), -- Ada.Short_Short_Integer_Wide_Wide_Text_IO ---------------------------------------- -- GNAT Defined Additions to Ada 2005 -- ---------------------------------------- - "a-cgaaso", -- Ada.Containers.Generic_Anonymous_Array_Sort - "a-chzla1", -- Ada.Characters.Wide_Wide_Latin_1 - "a-chzla9", -- Ada.Characters.Wide_Wide_Latin_9 - "a-ciormu", -- Ada.Containers.Indefinite_Ordered_Multisets - "a-coormu", -- Ada.Containers.Ordered_Multisets - "a-crdlli", -- Ada.Containers.Restricted_Doubly_Linked_Lists - "a-secain", -- Ada.Strings.Equal_Case_Insensitive - "a-shcain", -- Ada.Strings.Hash_Case_Insensitive - "a-slcain", -- Ada.Strings.Less_Case_Insensitive - "a-szuzti", -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO - "a-zchuni", -- Ada.Wide_Wide_Characters.Unicode + ("a-cgaaso", F), -- Ada.Containers.Generic_Anonymous_Array_Sort + ("a-chzla1", F), -- Ada.Characters.Wide_Wide_Latin_1 + ("a-chzla9", F), -- Ada.Characters.Wide_Wide_Latin_9 + ("a-ciormu", F), -- Ada.Containers.Indefinite_Ordered_Multisets + ("a-coormu", F), -- Ada.Containers.Ordered_Multisets + ("a-crdlli", F), -- Ada.Containers.Restricted_Doubly_Linked_Lists + ("a-secain", F), -- Ada.Strings.Equal_Case_Insensitive + ("a-shcain", F), -- Ada.Strings.Hash_Case_Insensitive + ("a-slcain", F), -- Ada.Strings.Less_Case_Insensitive + ("a-szuzti", F), -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO + ("a-zchuni", F), -- Ada.Wide_Wide_Characters.Unicode + ("a-ztcstr", F), -- Ada.Wide_Wide_Text_IO.C_Streams -- Note: strictly the following should be Ada 2012 units, but it seems -- harmless (and useful) to make then available in Ada 2005 mode. - "a-suezst", -- Ada.Strings.UTF_Encoding.Wide_Wide_Strings + ("a-suezst", T), -- Ada.Strings.UTF_Encoding.Wide_Wide_Strings --------------------------- -- GNAT Special IO Units -- @@ -485,19 +506,19 @@ package body Impunit is -- See Ada 95 section for further information. These packages are for the -- implementation of the Wide_Wide_Text_IO generic packages. - "a-ztdeio", -- Ada.Wide_Wide_Text_IO.Decimal_IO - "a-ztenio", -- Ada.Wide_Wide_Text_IO.Enumeration_IO - "a-ztfiio", -- Ada.Wide_Wide_Text_IO.Fixed_IO - "a-ztflio", -- Ada.Wide_Wide_Text_IO.Float_IO - "a-ztinio", -- Ada.Wide_Wide_Text_IO.Integer_IO - "a-ztmoio", -- Ada.Wide_Wide_Text_IO.Modular_IO + ("a-ztdeio", F), -- Ada.Wide_Wide_Text_IO.Decimal_IO + ("a-ztenio", F), -- Ada.Wide_Wide_Text_IO.Enumeration_IO + ("a-ztfiio", F), -- Ada.Wide_Wide_Text_IO.Fixed_IO + ("a-ztflio", F), -- Ada.Wide_Wide_Text_IO.Float_IO + ("a-ztinio", F), -- Ada.Wide_Wide_Text_IO.Integer_IO + ("a-ztmoio", F), -- Ada.Wide_Wide_Text_IO.Modular_IO ------------------------ -- GNAT Library Units -- ------------------------ - "g-zspche", -- GNAT.Wide_Wide_Spelling_Checker - "g-zstspl"); -- GNAT.Wide_Wide_String_Split + ("g-zspche", F), -- GNAT.Wide_Wide_Spelling_Checker + ("g-zstspl", F)); -- GNAT.Wide_Wide_String_Split -------------------- -- Ada 2012 Units -- @@ -506,39 +527,39 @@ package body Impunit is -- The following units should be used only in Ada 2012 mode Non_Imp_File_Names_12 : constant File_List := ( - "s-multip", -- System.Multiprocessors - "s-mudido", -- System.Multiprocessors.Dispatching_Domains - "s-stposu", -- System.Storage_Pools.Subpools - "a-cobove", -- Ada.Containers.Bounded_Vectors - "a-cbdlli", -- Ada.Containers.Bounded_Doubly_Linked_Lists - "a-cborse", -- Ada.Containers.Bounded_Ordered_Sets - "a-cborma", -- Ada.Containers.Bounded_Ordered_Maps - "a-cbhase", -- Ada.Containers.Bounded_Hashed_Sets - "a-cbhama", -- Ada.Containers.Bounded_Hashed_Maps - "a-coinho", -- Ada.Containers.Indefinite_Holders - "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 - "a-undesu", -- Ada.Unchecked_Deallocate_Subpool + ("s-multip", T), -- System.Multiprocessors + ("s-mudido", T), -- System.Multiprocessors.Dispatching_Domains + ("s-stposu", T), -- System.Storage_Pools.Subpools + ("a-cobove", T), -- Ada.Containers.Bounded_Vectors + ("a-cbdlli", T), -- Ada.Containers.Bounded_Doubly_Linked_Lists + ("a-cborse", T), -- Ada.Containers.Bounded_Ordered_Sets + ("a-cborma", T), -- Ada.Containers.Bounded_Ordered_Maps + ("a-cbhase", T), -- Ada.Containers.Bounded_Hashed_Sets + ("a-cbhama", T), -- Ada.Containers.Bounded_Hashed_Maps + ("a-coinho", T), -- Ada.Containers.Indefinite_Holders + ("a-comutr", T), -- Ada.Containers.Multiway_Trees + ("a-cimutr", T), -- Ada.Containers.Indefinite_Multiway_Trees + ("a-cbmutr", T), -- Ada.Containers.Bounded_Multiway_Trees + ("a-csquin", T), -- Ada.Containers.Synchronized_Queue_Interfaces + ("a-cusyqu", T), -- Ada.Containers.Unbounded_Synchronized_Queues + ("a-cuprqu", T), -- Ada.Containers.Unbounded_Priority_Queues + ("a-cbsyqu", T), -- Ada.Containers.Bounded_Synchronized_Queues + ("a-cbprqu", T), -- Ada.Containers.Bounded_Priority_Queues + ("a-extiin", T), -- Ada.Execution_Time.Interrupts + ("a-iteint", T), -- Ada.Iterator_Interfaces + ("a-synbar", T), -- Ada.Synchronous_Barriers + ("a-undesu", T), -- Ada.Unchecked_Deallocate_Subpool ---------------------------------------- -- GNAT Defined Additions to Ada 2012 -- ---------------------------------------- - "a-cofove", -- Ada.Containers.Formal_Vectors - "a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists - "a-cforse", -- Ada.Containers.Formal_Ordered_Sets - "a-cforma", -- Ada.Containers.Formal_Ordered_Maps - "a-cfhase", -- Ada.Containers.Formal_Hashed_Sets - "a-cfhama"); -- Ada.Containers.Formal_Hashed_Maps + ("a-cofove", F), -- Ada.Containers.Formal_Vectors + ("a-cfdlli", F), -- Ada.Containers.Formal_Doubly_Linked_Lists + ("a-cforse", F), -- Ada.Containers.Formal_Ordered_Sets + ("a-cforma", F), -- Ada.Containers.Formal_Ordered_Maps + ("a-cfhase", F), -- Ada.Containers.Formal_Hashed_Sets + ("a-cfhama", F)); -- Ada.Containers.Formal_Hashed_Maps ----------------------- -- Alternative Units -- @@ -589,17 +610,25 @@ package body Impunit is begin Error_Msg_Strlen := 0; + Get_Name_String (Fname); - -- If length of file name is greater than 12, not predefined. - -- The value 12 here is an 8 char name with extension .ads. + -- Ada/System/Interfaces are all Ada 95 units - if Length_Of_Name (Fname) > 12 then - return Not_Predefined_Unit; + if (Name_Len = 7 and then Name_Buffer (1 .. 7) = "ada.ads") + or else + (Name_Len = 10 and then Name_Buffer (1 .. 10) = "system.ads") + or else + (Name_Len = 12 and then Name_Buffer (1 .. 12) = "interfac.ads") + then + return Ada_95_Unit; end if; - -- Otherwise test file name + -- If length of file name is greater than 12, not predefined. The value + -- 12 here is an 8 char name with extension .ads. - Get_Name_String (Fname); + if Name_Len > 12 then + return Not_Predefined_Unit; + end if; -- Not predefined if file name does not start with a- g- s- i- @@ -634,7 +663,7 @@ package body Impunit is -- See if name is in 95 list for J in Non_Imp_File_Names_95'Range loop - if Name_Buffer (1 .. 8) = Non_Imp_File_Names_95 (J) then + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_95 (J).Fname then return Ada_95_Unit; end if; end loop; @@ -642,7 +671,7 @@ package body Impunit is -- See if name is in 2005 list for J in Non_Imp_File_Names_05'Range loop - if Name_Buffer (1 .. 8) = Non_Imp_File_Names_05 (J) then + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_05 (J).Fname then return Ada_2005_Unit; end if; end loop; @@ -650,7 +679,7 @@ package body Impunit is -- See if name is in 2012 list for J in Non_Imp_File_Names_12'Range loop - if Name_Buffer (1 .. 8) = Non_Imp_File_Names_12 (J) then + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_12 (J).Fname then return Ada_2012_Unit; end if; end loop; @@ -726,9 +755,25 @@ package body Impunit is Fnam := Get_File_Name (Unam, Subunit => False); Get_Name_String (Fnam); + Error_Msg_Strlen := 0; + + -- Ada/System/Interfaces are all Ada 95 units + + if (Name_Len = 7 and then Name_Buffer (1 .. 7) = "ada.ads") + or else + (Name_Len = 10 and then Name_Buffer (1 .. 10) = "system.ads") + or else + (Name_Len = 12 and then Name_Buffer (1 .. 12) = "interfac.ads") + then + return True; + end if; + -- Remove extension from file name - if Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then + if Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" + or else + Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" + then Name_Len := Name_Len - 4; else return False; @@ -750,13 +795,19 @@ package body Impunit is -- If length is 8, search our tables for J in Non_Imp_File_Names_95'Range loop - if Name_Buffer (1 .. 8) = Non_Imp_File_Names_95 (J) then + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_95 (J).Fname then return True; end if; end loop; for J in Non_Imp_File_Names_05'Range loop - if Name_Buffer (1 .. 8) = Non_Imp_File_Names_05 (J) then + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_05 (J).Fname then + return True; + end if; + end loop; + + for J in Non_Imp_File_Names_12'Range loop + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_12 (J).Fname then return True; end if; end loop; @@ -775,4 +826,100 @@ package body Impunit is return False; end Is_Known_Unit; + --------------------------- + -- Not_Impl_Defined_Unit -- + --------------------------- + + function Not_Impl_Defined_Unit (U : Unit_Number_Type) return Boolean is + Fname : constant File_Name_Type := Unit_File_Name (U); + + begin + Error_Msg_Strlen := 0; + Get_Name_String (Fname); + + -- Ada/System/Interfaces are all RM-defined Ada 95 units + + if (Name_Len = 7 and then Name_Buffer (1 .. 7) = "ada.ads") + or else + (Name_Len = 10 and then Name_Buffer (1 .. 10) = "system.ads") + or else + (Name_Len = 12 and then Name_Buffer (1 .. 12) = "interfac.ads") + then + return True; + end if; + + -- If length of file name is greater than 12, then it's a user unit + -- and not a GNAT implementation defined unit. + + if Name_Len > 12 then + return True; + end if; + + -- Implementation defined if unit in the gnat hierarchy + + if (Name_Len = 8 and then Name_Buffer (1 .. 8) = "gnat.ads") + or else (Name_Len > 2 and then Name_Buffer (1 .. 2) = "g-") + then + return False; + end if; + + -- Not implementation defined if file name does not start with a- s- i- + + if Name_Len < 3 + or else Name_Buffer (2) /= '-' + or else (Name_Buffer (1) /= 'a' + and then + Name_Buffer (1) /= 'i' + and then + Name_Buffer (1) /= 's') + then + return True; + end if; + + -- Not impl-defined if file name does not end in .ads. This can happen + -- when non-standard file names are being used. + + if Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads" then + return True; + end if; + + -- Otherwise normalize file name to 8 characters + + Name_Len := Name_Len - 4; + while Name_Len < 8 loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end loop; + + -- Check our lists of names, if we find a match, return corresponding + -- indication of whether the file is RM defined, respecting the RM + -- version in which it is defined. + + for J in Non_Imp_File_Names_95'Range loop + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_95 (J).Fname then + return Non_Imp_File_Names_95 (J).RMdef; + end if; + end loop; + + for J in Non_Imp_File_Names_05'Range loop + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_05 (J).Fname then + return Non_Imp_File_Names_05 (J).RMdef + and then Ada_Version >= Ada_2005; + end if; + end loop; + + for J in Non_Imp_File_Names_12'Range loop + if Name_Buffer (1 .. 8) = Non_Imp_File_Names_12 (J).Fname then + return Non_Imp_File_Names_95 (J).RMdef + and then Ada_Version >= Ada_2012; + end if; + end loop; + + -- If unit is in System, Ada or Interfaces hierarchies and did not match + -- any entry in the list, means it is an internal implementation defined + -- unit which the restriction should definition forbid. + + return True; + end Not_Impl_Defined_Unit; + end Impunit; diff --git a/gcc/ada/impunit.ads b/gcc/ada/impunit.ads index 621a034011f..e5244938ef9 100644 --- a/gcc/ada/impunit.ads +++ b/gcc/ada/impunit.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2010, 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- -- @@ -23,10 +23,10 @@ -- -- ------------------------------------------------------------------------------ --- This package contains data and functions used to determine if a given --- unit is an internal unit intended only for use by the implementation --- and which should not be directly WITH'ed by user code. It also checks --- for Ada 05 units that should only be WITH'ed in Ada 05 mode. +-- This package contains data and functions used to determine if a given unit +-- is an internal unit intended only for use by the implementation and which +-- should not be directly WITH'ed by user code. It also checks for Ada 05 +-- units that should only be WITH'ed in Ada 05 mode. with Types; use Types; @@ -34,42 +34,52 @@ package Impunit is type Kind_Of_Unit is (Implementation_Unit, - -- Unit from predefined library intended to be used only by the - -- compiler generated code, or from the implementation of the run time. - -- Use of such a unit generates a warning unless the client is compiled - -- with the -gnatg switch. If we are being super strict, this should be - -- an error for the case of Ada units, but that seems over strenuous. + -- Unit from predefined library intended to be used only by the compiler + -- generated code, or from the implementation of the run time. Use of + -- such a unit generates a warning unless the client is compiled with + -- the -gnatg switch. If we are being super strict, this should be an + -- error for the case of Ada units, but that seems over strenuous. Not_Predefined_Unit, -- This is not a predefined unit, so no checks are needed Ada_95_Unit, - -- This unit is defined in the Ada 95 RM, and can be freely with'ed - -- in both Ada 95 mode and Ada 05 mode. Note that in Ada 83 mode, no - -- child units are allowed, so you can't even name such a unit. + -- This unit is defined in the Ada 95 RM, and can be freely with'ed in + -- both Ada 95 mode and Ada 05 mode. Note that in Ada 83 mode, no child + -- units are allowed, so you can't even name such a unit. Ada_2005_Unit, - -- This unit is defined in the Ada 2005 RM. Withing this unit from a + -- This unit is defined in the Ada 2005 RM. Withing this unit from an -- Ada 95 mode program will generate a warning (again, strictly speaking -- this should be an error, but that seems over-strenuous). Ada_2012_Unit); - -- This unit is defined in the Ada 2012 RM. Withing this unit from a Ada - -- 95 mode or Ada 2005 program will generate a warning (again, strictly + -- This unit is defined in the Ada 2012 RM. Withing this unit from an + -- Ada 95 or 2005 mode program will generate a warning (again, strictly -- speaking this should be an error, but that seems over-strenuous). function Get_Kind_Of_Unit (U : Unit_Number_Type) return Kind_Of_Unit; -- Given the unit number of a unit, this function determines the type -- of the unit, as defined above. If the result is Implementation_Unit, -- then the name of a possible atlernative equivalent unit is placed in - -- Error_Msg_String/Slen on return. If there is no alternative name, or - -- if the result is not Implementation_Unit, then Error_Msg_Slen is zero - -- on return, indicating that no alternative name was found. + -- Error_Msg_String/Slen on return. If there is no alternative name, or if + -- the result is not Implementation_Unit, then Error_Msg_Slen is zero on + -- return, indicating that no alternative name was found. function Is_Known_Unit (Nam : Node_Id) return Boolean; -- Nam is the possible name of a child unit, represented as a selected - -- component node. This function determines whether the name matches - -- one of the known library units, and if so, returns True. If the name - -- does not match any known library unit, False is returned. + -- component node. This function determines whether the name matches one of + -- the known library units, and if so, returns True. If the name does not + -- match any known library unit, False is returned. + + function Not_Impl_Defined_Unit (U : Unit_Number_Type) return Boolean; + -- This function returns True if U represents a unit that is permitted by + -- the restriction No_Implementation_Units (i.e. a unit in the Ada, System, + -- and Interfaces hierarchies that is defined in the RM, or a user defined + -- unit. It returns False if U represents a unit that is not permitted by + -- this restriction, which includes units in these three hierarchies that + -- are GNAT implementation defined. It also returns False for any units in + -- the GNAT hierarchy, which is not strictly conforming, but so obviously + -- useful that it is a reasonable deviation from the standard. end Impunit; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 0e6fb11745c..0cf32e8166f 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1747,6 +1747,31 @@ __gnat_set_features (void) __gnat_features_set = 1; } +/* Return true if the VMS version is 7.x. */ + +extern unsigned int LIB$GETSYI (int *, ...); + +#define SYI$_VERSION 0x1000 + +int +__gnat_is_vms_v7 (void) +{ + struct descriptor_s desc; + char version[8]; + int status; + int code = SYI$_VERSION; + + desc.len = sizeof (version); + desc.mbz = 0; + desc.adr = version; + + status = LIB$GETSYI (&code, 0, &desc); + if ((status & 1) == 1 && version[1] == '7' && version[2] == '.') + return 1; + else + return 0; +} + /*******************/ /* FreeBSD Section */ /*******************/ diff --git a/gcc/ada/interfac.ads b/gcc/ada/interfac.ads index d36b48f742c..810366d5763 100644 --- a/gcc/ada/interfac.ads +++ b/gcc/ada/interfac.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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 -- @@ -36,6 +36,10 @@ package Interfaces is pragma Pure; + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + type Integer_8 is range -2 ** 7 .. 2 ** 7 - 1; for Integer_8'Size use 8; diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 8a29818f37c..cc0aa3ac84d 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -457,7 +457,7 @@ package body Alfa is -- the entity definition. elsif Get_Scope_Num (T1.Key.Ent_Scope) /= - Get_Scope_Num (T2.Key.Ent_Scope) + Get_Scope_Num (T2.Key.Ent_Scope) then return Get_Scope_Num (T1.Key.Ent_Scope) < Get_Scope_Num (T2.Key.Ent_Scope); @@ -503,7 +503,7 @@ package body Alfa is -- Seventh test: for same entity, sort by reference location scope elsif Get_Scope_Num (T1.Key.Ref_Scope) /= - Get_Scope_Num (T2.Key.Ref_Scope) + Get_Scope_Num (T2.Key.Ref_Scope) then return Get_Scope_Num (T1.Key.Ref_Scope) < Get_Scope_Num (T2.Key.Ref_Scope); @@ -586,10 +586,12 @@ package body Alfa is function Is_Alfa_Reference (E : Entity_Id; Typ : Character) return Boolean; - -- Return whether the reference is adequate for this entity + -- Return whether entity reference E meets Alfa requirements. Typ + -- is the reference type. function Is_Alfa_Scope (E : Entity_Id) return Boolean; - -- Return whether the entity or reference scope is adequate + -- Return whether the entity or reference scope meets requirements + -- for being an Alfa scope. function Is_Global_Constant (E : Entity_Id) return Boolean; -- Return True if E is a global constant for which we should ignore @@ -610,6 +612,25 @@ package body Alfa is if Ekind (E) in Overloadable_Kind then return Typ = 's'; + + -- References to constant objects are not considered in Alfa + -- section, as these will be translated as constants in the + -- intermediate language for formal verification, and should + -- therefore never appear in frame conditions. + + elsif Is_Constant_Object (E) then + return False; + + -- Objects of Task type or protected type are not Alfa references + + elsif Present (Etype (E)) + and then Ekind (Etype (E)) in Concurrent_Kind + then + return False; + + -- In all other cases, result is true for reference/modify cases, + -- and false for all other cases. + else return Typ = 'r' or else Typ = 'm'; end if; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 2dbf5ff23d2..f16e8abbdc4 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -205,7 +205,7 @@ package body Lib.Xref is function Equal (F1, F2 : Xref_Entry_Number) return Boolean is Result : constant Boolean := - Xrefs.Table (F1).Key = Xrefs.Table (F2).Key; + Xrefs.Table (F1).Key = Xrefs.Table (F2).Key; begin return Result; end Equal; @@ -373,12 +373,12 @@ package body Lib.Xref is Set_Ref : Boolean := True; Force : Boolean := False) is - Nod : Node_Id; - Ref : Source_Ptr; - Def : Source_Ptr; - Ent : Entity_Id; + Nod : Node_Id; + Ref : Source_Ptr; + Def : Source_Ptr; + Ent : Entity_Id; - Actual_Typ : Character := Typ; + Actual_Typ : Character := Typ; Ref_Scope : Entity_Id; Ent_Scope : Entity_Id; @@ -512,6 +512,16 @@ package body Lib.Xref is return False; end if; end if; + + -- A reference to a formal in a named parameter association does + -- not make the formal referenced. Formals that are unused in the + -- subprogram body are properly flagged as such, even if calls + -- elsewhere use named notation. + + elsif Nkind (P) = N_Parameter_Association + and then N = Selector_Name (P) + then + return False; end if; end if; @@ -1057,7 +1067,16 @@ package body Lib.Xref is 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); + + H : constant M := M (XE.Key.Ent) + 2 ** 7 * M (abs XE.Key.Loc); + -- It would be more natural to write: + -- + -- H : constant M := M'Mod (XE.Key.Ent) + 2**7 * M'Mod (XE.Key.Loc); + -- + -- But we can't use M'Mod, because it prevents bootstrapping with older + -- compilers. Loc can be negative, so we do "abs" before converting. + -- One day this can be cleaned up ??? + begin return Header_Num (H mod Num_Buckets); end Hash; @@ -1154,7 +1173,7 @@ package body Lib.Xref is procedure Output_Import_Export_Info (Ent : Entity_Id); -- Output language and external name information for an interfaced - -- entity, using the format <language, external_name>, + -- entity, using the format <language, external_name>. ------------------------ -- Get_Type_Reference -- @@ -1882,10 +1901,10 @@ package body Lib.Xref is if XE.Key.Typ = 'e' and then Ent /= Curent - and then (Refno = Nrefs or else - Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent) - and then - not In_Extended_Main_Source_Unit (Ent) + and then (Refno = Nrefs + or else + Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent) + and then not In_Extended_Main_Source_Unit (Ent) then goto Continue; end if; diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index c5149bee3b0..2c5aa4c507f 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -293,10 +293,14 @@ package body Lib is Sloc1 := S1; Sloc2 := S2; - Unum1 := Get_Code_Unit (Sloc1); - Unum2 := Get_Code_Unit (Sloc2); + + Unum1 := Get_Source_Unit (Sloc1); + Unum2 := Get_Source_Unit (Sloc2); loop + -- Step 1: Check whether the two locations are in the same source + -- file. + Sind1 := Get_Source_File_Index (Sloc1); Sind2 := Get_Source_File_Index (Sloc2); @@ -310,28 +314,27 @@ package body Lib is end if; end if; - -- OK, the two nodes are in separate source elements, but this is not - -- decisive, because of the issue of subunits and instantiations. - - -- First we deal with subunits, since if the subunit is in an - -- instantiation, we know that the parent is in the corresponding - -- instantiation, since that is the only way we can have a subunit - -- that is part of an instantiation. + -- Step 2: Check subunits. If a subunit is instantiated, follow the + -- instantiation chain rather than the stub chain. Unit1 := Unit (Cunit (Unum1)); Unit2 := Unit (Cunit (Unum2)); + Inst1 := Instantiation (Sind1); + Inst2 := Instantiation (Sind2); if Nkind (Unit1) = N_Subunit and then Present (Corresponding_Stub (Unit1)) + and then Inst1 = No_Location then - -- Both in subunits. They could have a common ancestor. If they - -- do, then the deeper one must have a longer unit name. Replace - -- the deeper one with its corresponding stub, in order to find - -- nearest common ancestor, if any. - if Nkind (Unit2) = N_Subunit and then Present (Corresponding_Stub (Unit2)) + and then Inst2 = No_Location then + -- Both locations refer to subunits which may have a common + -- ancestor. If they do, the deeper subunit must have a longer + -- unit name. Replace the deeper one with its corresponding + -- stub in order to find the nearest ancestor. + if Length_Of_Name (Unit_Name (Unum1)) < Length_Of_Name (Unit_Name (Unum2)) then @@ -345,7 +348,7 @@ package body Lib is goto Continue; end if; - -- Nod1 in subunit, Nod2 not + -- Sloc1 in subunit, Sloc2 not else Sloc1 := Sloc (Corresponding_Stub (Unit1)); @@ -353,28 +356,25 @@ package body Lib is goto Continue; end if; - -- Nod2 in subunit, Nod1 not + -- Sloc2 in subunit, Sloc1 not elsif Nkind (Unit2) = N_Subunit and then Present (Corresponding_Stub (Unit2)) + and then Inst2 = No_Location then Sloc2 := Sloc (Corresponding_Stub (Unit2)); Unum2 := Get_Source_Unit (Sloc2); goto Continue; end if; - -- At this stage we know that neither is a subunit, so we deal - -- with instantiations, since we could have a common ancestor - - Inst1 := Instantiation (Sind1); - Inst2 := Instantiation (Sind2); + -- Step 3: Check instances. The two locations may yield a common + -- ancestor. if Inst1 /= No_Location then - - -- Both are instantiations - if Inst2 /= No_Location then + -- Both locations denote instantiations + Depth1 := Instantiation_Depth (Sloc1); Depth2 := Instantiation_Depth (Sloc2); @@ -396,7 +396,7 @@ package body Lib is goto Continue; end if; - -- Only first node is in instantiation + -- Sloc1 is an instantiation else Sloc1 := Inst1; @@ -404,7 +404,7 @@ package body Lib is goto Continue; end if; - -- Only second node is instantiation + -- Sloc2 is an instantiation elsif Inst2 /= No_Location then Sloc2 := Inst2; @@ -412,10 +412,9 @@ package body Lib is goto Continue; end if; - -- No instantiations involved, so we are not in the same unit - -- However, there is one case still to check, namely the case - -- where one location is in the spec, and the other in the - -- corresponding body (the spec location is earlier). + -- Step 4: One location in the spec, the other in the corresponding + -- body of the same unit. The location in the spec is considered + -- earlier. if Nkind (Unit1) = N_Subprogram_Body or else @@ -434,8 +433,8 @@ package body Lib is end if; end if; - -- If that special case does not occur, then we are certain that - -- the two locations are really in separate units. + -- At this point it is certain that the two locations denote two + -- entirely separate units. return No; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 13777bbf0c5..bf6a21a0dad 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -608,8 +608,6 @@ package body Make is procedure Compute_Switches_For_Main (Main_Source_File : in out File_Name_Type; - Main_Index : Int; - Project_Node_Tree : Project_Node_Tree_Ref; Root_Environment : in out Prj.Tree.Environment; Compute_Builder : Boolean; Current_Work_Dir : String); @@ -744,10 +742,8 @@ package body Make is procedure Add_Switches (The_Package : Package_Id; File_Name : String; - Index : Int; Program : Make_Program_Type; Unknown_Switches_To_The_Compiler : Boolean := True; - Project_Node_Tree : Project_Node_Tree_Ref; Env : in out Prj.Tree.Environment); procedure Add_Switch (S : String_Access; @@ -769,7 +765,6 @@ package body Make is procedure Check (Source_File : File_Name_Type; - Source_Index : Int; Is_Main_Source : Boolean; The_Args : Argument_List; Lib_File : File_Name_Type; @@ -1276,10 +1271,8 @@ package body Make is procedure Add_Switches (The_Package : Package_Id; File_Name : String; - Index : Int; Program : Make_Program_Type; Unknown_Switches_To_The_Compiler : Boolean := True; - Project_Node_Tree : Project_Node_Tree_Ref; Env : in out Prj.Tree.Environment) is Switches : Variable_Value; @@ -1445,7 +1438,6 @@ package body Make is procedure Check (Source_File : File_Name_Type; - Source_Index : Int; Is_Main_Source : Boolean; The_Args : Argument_List; Lib_File : File_Name_Type; @@ -3445,7 +3437,6 @@ package body Make is if not Force_Compilations then Check (Source_File => Source.File, - Source_Index => Source.Index, Is_Main_Source => Source.File = Main_Source, The_Args => Args, Lib_File => Lib_File, @@ -5206,8 +5197,6 @@ package body Make is procedure Compute_Switches_For_Main (Main_Source_File : in out File_Name_Type; - Main_Index : Int; - Project_Node_Tree : Project_Node_Tree_Ref; Root_Environment : in out Prj.Tree.Environment; Compute_Builder : Boolean; Current_Work_Dir : String) @@ -5349,10 +5338,8 @@ package body Make is end if; Add_Switches - (Project_Node_Tree => Project_Node_Tree, - Env => Root_Environment, + (Env => Root_Environment, File_Name => Main_Unit_File_Name, - Index => Main_Index, The_Package => Binder_Package, Program => Binder); end if; @@ -5367,10 +5354,8 @@ package body Make is end if; Add_Switches - (Project_Node_Tree => Project_Node_Tree, - Env => Root_Environment, + (Env => Root_Environment, File_Name => Main_Unit_File_Name, - Index => Main_Index, The_Package => Linker_Package, Program => Linker); end if; @@ -6029,8 +6014,6 @@ package body Make is Compute_Switches_For_Main (Main_Source_File, - Main_Index, - Project_Node_Tree, Root_Environment, Compute_Builder => Is_First_Main, Current_Work_Dir => Current_Work_Dir.all); diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb index f2889a26c01..62cc703094b 100644 --- a/gcc/ada/makeusg.adb +++ b/gcc/ada/makeusg.adb @@ -26,6 +26,7 @@ with Makeutl; with Osint; use Osint; with Output; use Output; +with Switch; use Switch; with Usage; procedure Makeusg is @@ -51,6 +52,8 @@ begin Write_Str ("gnatmake switches:"); Write_Eol; + Display_Usage_Version_And_Help; + -- Line for -a Write_Str (" -a Consider all files, even readonly ali files"); diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 848db592a1a..cfca418595e 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -850,9 +850,7 @@ package body Makeutl is Allow_Wildcards => True); end if; - if Value = Nil_Variable_Value - and then Test_Without_Suffix - then + if Value = Nil_Variable_Value and then Test_Without_Suffix then Lang := Get_Language_From_Name (Project, Get_Name_String (Source_Lang)); @@ -872,8 +870,8 @@ package body Makeutl is Name (1 .. Last) := SF_Name; if Last > Body_Suffix'Length - and then Name (Last - Body_Suffix'Length + 1 .. Last) = - Body_Suffix + and then + Name (Last - Body_Suffix'Length + 1 .. Last) = Body_Suffix then Truncated := True; Last := Last - Body_Suffix'Length; @@ -881,8 +879,8 @@ package body Makeutl is if not Truncated and then Last > Spec_Suffix'Length - and then Name (Last - Spec_Suffix'Length + 1 .. Last) = - Spec_Suffix + and then + Name (Last - Spec_Suffix'Length + 1 .. Last) = Spec_Suffix then Truncated := True; Last := Last - Spec_Suffix'Length; @@ -900,9 +898,7 @@ package body Makeutl is Allow_Wildcards => True); end if; - if Value = Nil_Variable_Value - and then Check_ALI_Suffix - then + if Value = Nil_Variable_Value and then Check_ALI_Suffix then Last := SF_Name'Length; while Name (Last) /= '.' loop Last := Last - 1; @@ -994,9 +990,12 @@ package body Makeutl is ------------------------------ procedure Initialize_Source_Record (Source : Prj.Source_Id) is + procedure Set_Object_Project - (Obj_Dir : String; Obj_Proj : Project_Id; Obj_Path : Path_Name_Type; - Stamp : Time_Stamp_Type); + (Obj_Dir : String; + Obj_Proj : Project_Id; + Obj_Path : Path_Name_Type; + Stamp : Time_Stamp_Type); -- Update information about object file, switches file,... ------------------------ @@ -1004,8 +1003,10 @@ package body Makeutl is ------------------------ procedure Set_Object_Project - (Obj_Dir : String; Obj_Proj : Project_Id; Obj_Path : Path_Name_Type; - Stamp : Time_Stamp_Type) is + (Obj_Dir : String; + Obj_Proj : Project_Id; + Obj_Path : Path_Name_Type; + Stamp : Time_Stamp_Type) is begin Source.Object_Project := Obj_Proj; Source.Object_Path := Obj_Path; @@ -1031,10 +1032,11 @@ package body Makeutl is declare Switches_Path : constant String := - Normalize_Pathname - (Name => Get_Name_String (Source.Switches), - Resolve_Links => Opt.Follow_Links_For_Files, - Directory => Obj_Dir); + Normalize_Pathname + (Name => + Get_Name_String (Source.Switches), + Resolve_Links => Opt.Follow_Links_For_Files, + Directory => Obj_Dir); begin Source.Switches_Path := Create_Name (Switches_Path); @@ -1093,21 +1095,22 @@ package body Makeutl is -- elsewhere that's where we'll expect to find it). Obj_Proj := Source.Project; + while Obj_Proj /= No_Project loop declare - Dir : constant String := Get_Name_String - (Obj_Proj.Object_Directory.Display_Name); + Dir : constant String := + Get_Name_String + (Obj_Proj.Object_Directory.Display_Name); - Object_Path : constant String := - Normalize_Pathname - (Name => - Get_Name_String (Source.Object), - Resolve_Links => - Opt.Follow_Links_For_Files, - Directory => Dir); + Object_Path : constant String := + Normalize_Pathname + (Name => + Get_Name_String (Source.Object), + Resolve_Links => Opt.Follow_Links_For_Files, + Directory => Dir); Obj_Path : constant Path_Name_Type := Create_Name (Object_Path); - Stamp : Time_Stamp_Type := Empty_Time_Stamp; + Stamp : Time_Stamp_Type := Empty_Time_Stamp; begin -- For specs, we do not check object files if there is a body. @@ -1286,10 +1289,10 @@ package body Makeutl is for Index in reverse 1 .. Linker_Opts.Last loop declare - Options : String_List_Id; - Proj : constant Project_Id := - Linker_Opts.Table (Index).Project; - Option : Name_Id; + Options : String_List_Id; + Proj : constant Project_Id := + Linker_Opts.Table (Index).Project; + Option : Name_Id; Dir_Path : constant String := Get_Name_String (Proj.Directory.Name); @@ -1397,12 +1400,12 @@ package body Makeutl is procedure Add_Multi_Unit_Sources (Tree : Project_Tree_Ref; Source : Prj.Source_Id); - -- Add all units from the same file as the multi-unit Source. + -- Add all units from the same file as the multi-unit Source function Find_File_Add_Extension - (Tree : Project_Tree_Ref; - Base_Main : String) return Prj.Source_Id; - -- Search for Main in the project, adding body or spec extensions. + (Tree : Project_Tree_Ref; + Base_Main : String) return Prj.Source_Id; + -- Search for Main in the project, adding body or spec extensions ---------------------------- -- Add_Multi_Unit_Sources -- @@ -1455,8 +1458,8 @@ package body Makeutl is ----------------------------- function Find_File_Add_Extension - (Tree : Project_Tree_Ref; - Base_Main : String) return Prj.Source_Id + (Tree : Project_Tree_Ref; + Base_Main : String) return Prj.Source_Id is Spec_Source : Prj.Source_Id := No_Source; Source : Prj.Source_Id; @@ -1464,7 +1467,7 @@ package body Makeutl is Suffix : File_Name_Type; begin - Source := No_Source; + Source := No_Source; Iter := For_Each_Source (Tree); -- In all projects loop Source := Prj.Element (Iter); @@ -1611,10 +1614,10 @@ package body Makeutl is -- check later that we found the correct file. Source := Find_Source - (In_Tree => File.Tree, - Project => File.Project, - Base_Name => Main_Id, - Index => File.Index, + (In_Tree => File.Tree, + Project => File.Project, + Base_Name => Main_Id, + Index => File.Index, In_Imported_Only => True); if Source = No_Source then @@ -1624,8 +1627,8 @@ package body Makeutl is if Is_Absolute and then Source /= No_Source - and then File_Name_Type (Source.Path.Name) /= - File.File + and then + File_Name_Type (Source.Path.Name) /= File.File then Debug_Output ("Found a non-matching file", @@ -2192,7 +2195,7 @@ package body Makeutl is -- processed, if it hasn't already been processed. function Insert_No_Roots (Source : Source_Info) return Boolean; - -- Insert Source, but do not look for its roots (see doc for Insert). + -- Insert Source, but do not look for its roots (see doc for Insert) ------------------- -- Was_Processed -- @@ -2506,6 +2509,7 @@ package body Makeutl is if Roots = Nil_Variable_Value then Debug_Output (" -> no roots declared"); + else List := Roots.Values; @@ -2596,7 +2600,7 @@ package body Makeutl is Initialize_Source_Record (Other_Part (Root_Source)); end if; - -- Save the root for the binder. + -- Save the root for the binder Source.Id.Roots := new Source_Roots' (Root => Root_Source, @@ -2745,6 +2749,11 @@ package body Makeutl is Unique_Compile : Boolean) is procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref); + + --------------- + -- Do_Insert -- + --------------- + procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref) is Unit_Based : constant Boolean := Unique_Compile @@ -2775,7 +2784,7 @@ package body Makeutl is if Is_Compilable (Source) and then (All_Projects - or else Is_Extending (Project, Source.Project)) + or else Is_Extending (Project, Source.Project)) and then not Source.Locally_Removed and then Source.Replaced_By = No_Source and then @@ -2855,25 +2864,25 @@ package body Makeutl is and then Src_Id.Dep_Name = Afile then case Src_Id.Kind is - when Spec => - declare - Bdy : constant Prj.Source_Id := - Other_Part (Src_Id); - begin - if Bdy /= No_Source - and then not Bdy.Locally_Removed - then - Src_Id := Other_Part (Src_Id); + when Spec => + declare + Bdy : constant Prj.Source_Id := + Other_Part (Src_Id); + begin + if Bdy /= No_Source + and then not Bdy.Locally_Removed + then + Src_Id := Other_Part (Src_Id); + end if; + end; + + when Impl => + if Is_Subunit (Src_Id) then + Src_Id := No_Source; end if; - end; - when Impl => - if Is_Subunit (Src_Id) then + when Sep => Src_Id := No_Source; - end if; - - when Sep => - Src_Id := No_Source; end case; exit; @@ -2899,6 +2908,7 @@ package body Makeutl is end loop; end loop; end Insert_Withed_Sources_For; + end Queue; ---------- @@ -2948,6 +2958,10 @@ package body Makeutl is is procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref); + ---------------- + -- Do_Compute -- + ---------------- + procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref) is Data : constant Builder_Data_Access := Builder_Data (Tree); All_Phases : constant Boolean := @@ -3008,8 +3022,8 @@ package body Makeutl is Only_For_Lang : Name_Id := No_Name) is Builder_Package : constant Package_Id := - Value_Of (Name_Builder, Main_Project.Decl.Packages, - Project_Tree.Shared); + Value_Of (Name_Builder, Main_Project.Decl.Packages, + Project_Tree.Shared); Global_Compilation_Array : Array_Element_Id; Global_Compilation_Elem : Array_Element; @@ -3029,7 +3043,7 @@ package body Makeutl is Switches_For_Lang : Variable_Value := Nil_Variable_Value; -- Value of Builder'Default_Switches(lang) - Name : Name_Id := No_Name; -- main file index for Switches + Name : Name_Id := No_Name; -- main file index for Switches Switches_For_Main : Variable_Value := Nil_Variable_Value; -- Switches for a specific main. When there are several mains, Name is -- set to No_Name, and Switches_For_Main might be left with an actual @@ -3052,7 +3066,6 @@ package body Makeutl is -- use this language as the switches index. if Mains.Number_Of_Mains (Project_Tree) = 0 then - if Only_For_Lang = No_Name then declare Language : Language_Ptr := Main_Project.Languages; @@ -3079,8 +3092,8 @@ package body Makeutl is else for Index in 1 .. Mains.Number_Of_Mains (Project_Tree) loop Source := Mains.Next_Main.Source; - if Source /= No_Source then + if Source /= No_Source then if Switches_For_Main = Nil_Variable_Value then Switches_For_Main := Value_Of (Name => Name_Id (Source.File), @@ -3130,9 +3143,10 @@ package body Makeutl is Default_Switches_Array := Project_Tree.Shared.Packages.Table (Builder_Package).Decl.Arrays; - while Default_Switches_Array /= No_Array and then - Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Name /= - Name_Default_Switches + while Default_Switches_Array /= No_Array + and then + Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Name /= + Name_Default_Switches loop Default_Switches_Array := Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Next; @@ -3243,8 +3257,7 @@ package body Makeutl is declare -- Add_Switch might itself be using the name_buffer, so -- we make a temporary here. - Switch : constant String := - Name_Buffer (1 .. Name_Len); + Switch : constant String := Name_Buffer (1 .. Name_Len); begin Success := Add_Switch (Switch => Switch, diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index ceb38bdf39f..402c92dde49 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -336,7 +336,7 @@ package Makeutl is Need_Compilation : Boolean := True; Need_Binding : Boolean := True; Need_Linking : Boolean := True; - -- Which of the compilation phases are needed for this project tree. + -- Which of the compilation phases are needed for this project tree end record; type Builder_Data_Access is access all Builder_Project_Tree_Data; @@ -459,10 +459,10 @@ package Makeutl is Id : Source_Id := null; when Format_Gnatmake => - File : File_Name_Type := No_File; - Unit : Unit_Name_Type := No_Unit_Name; - Index : Int := 0; - Project : Project_Id := No_Project; + File : File_Name_Type := No_File; + Unit : Unit_Name_Type := No_Unit_Name; + Index : Int := 0; + Project : Project_Id := No_Project; end case; end record; -- Information about files stored in the queue. The exact information @@ -473,8 +473,9 @@ package Makeutl is procedure Initialize (Queue_Per_Obj_Dir : Boolean; - Force : Boolean := False); - -- Initialize the queue. + Force : Boolean := False); + -- Initialize the queue + -- -- Queue_Per_Obj_Dir matches the --single-compile-per-obj-dir switch: -- when True, there cannot be simultaneous compilations with the object -- files in the same object directory when project files are used. @@ -483,11 +484,10 @@ package Makeutl is -- initialized. procedure Remove_Marks; - -- Remove all marks set for the files. - -- This means that the files will be handed to the compiler if they are - -- added to the queue, and is mostly useful when recompiling several - -- executables in non-project mode, as the switches may be different - -- and -s may be in use. + -- Remove all marks set for the files. This means that the files will be + -- handed to the compiler if they are added to the queue, and is mostly + -- useful when recompiling several executables in non-project mode, as + -- the switches may be different and -s may be in use. function Is_Empty return Boolean; -- Returns True if the queue is empty diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index d2874d4ad49..b84e4ec1adb 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1550,6 +1550,12 @@ package Opt is -- clauses that are affected by non-standard bit-order. The default is -- that this warning is enabled. + Warn_On_Suspicious_Contract : Boolean := False; + -- GNAT + -- Set to True to generate warnings for suspicious contracts expressed as + -- pragmas or aspects precondition and postcondition. The default is that + -- this warning is disabled. + Warn_On_Suspicious_Modulus_Value : Boolean := True; -- GNAT -- Set to True to generate warnings for suspicious modulus values. The diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 167f43e195b..7b200e761b2 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -675,10 +675,40 @@ package body Ch6 is else -- If the identifier is the first token on its line, then -- let's assume that we have a missing begin and this is - -- intended as a subprogram body. + -- intended as a subprogram body. However, if the context + -- is a function and the unit is a package declaration, a + -- body would be illegal, so try for an unparenthesized + -- expression function. if Token_Is_At_Start_Of_Line then - return False; + declare + -- The enclosing scope entry is a subprogram spec + + Spec_Node : constant Node_Id := + Parent + (Scope.Table (Scope.Last).Labl); + Lib_Node : Node_Id := Spec_Node; + + begin + -- Check whether there is an enclosing scope that + -- is a package declaration. + + if Scope.Last > 1 then + Lib_Node := + Parent (Scope.Table (Scope.Last - 1).Labl); + end if; + + if Ada_Version >= Ada_2012 + and then + Nkind (Lib_Node) = N_Package_Specification + and then + Nkind (Spec_Node) = N_Function_Specification + then + null; + else + return False; + end if; + end; -- Otherwise we have to scan ahead. If the identifier is -- followed by a colon or a comma, it is a declaration diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 5ab9f94a4a8..5ed6553546f 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1149,6 +1149,7 @@ begin Pragma_Finalize_Storage_Only | Pragma_Float_Representation | Pragma_Ident | + Pragma_Implementation_Defined | Pragma_Implemented | Pragma_Implicit_Packing | Pragma_Import | diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 0dbb7d988a7..e054c198143 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -466,14 +466,23 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- control heuristic error recovery actions. Labl : Node_Id; - -- This field is used only for the LOOP and BEGIN cases, and is the - -- Node_Id value of the label name. For all cases except child units, - -- this value is an entity whose Chars field contains the name pointer - -- that identifies the label uniquely. For the child unit case the Labl - -- field references an N_Defining_Program_Unit_Name node for the name. - -- For cases other than LOOP or BEGIN, the Label field is set to Error, - -- indicating that it is an error to have a label on the end line. - -- (this is really a misuse of Error since there is no Error ???) + -- This field is used to provide the name of the construct being parsed + -- and indirectly its kind. For loops and blocks, the field contains the + -- source name or the generated one. For package specifications, bodies, + -- subprogram specifications and bodies the field holds the correponding + -- program unit name. For task declarations and bodies, protected types + -- and bodies, and accept statements the field hold the name of the type + -- or operation. For if-statements, case-statements, and selects, the + -- field is initialized to Error. + + -- Note: this is a bit of an odd (mis)use of Error, since there is no + -- Error, but we use this value as a place holder to indicate that it + -- is an error to have a label on the end line. + + -- Whenever the field is a name, it is attached to the parent node of + -- the construct being parsed. Thus the parent node indicates the kind + -- of construct whose parse tree is being built. This is used in error + -- recovery. Decl : List_Id; -- Points to the list of declarations (i.e. the declarative part) diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index ae1d0c6ed7a..1514107effb 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -436,6 +436,8 @@ package body Prj.Conf is Compiler := Create_Package (Project_Tree, Config_File, "compiler"); Create_Attribute + (Name_Driver, "gcc", "ada", Pkg => Compiler); + Create_Attribute (Name_Language_Kind, "unit_based", "ada", Pkg => Compiler); Create_Attribute (Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler); @@ -508,10 +510,10 @@ package body Prj.Conf is else Add_Attributes - (Project_Tree => Project_Tree, - Conf_Decl => Conf_Pack.Decl, - User_Decl => - Shared.Packages.Table (User_Pack_Id).Decl); + (Project_Tree => Project_Tree, + Conf_Decl => Conf_Pack.Decl, + User_Decl => Shared.Packages.Table + (User_Pack_Id).Decl); end if; Conf_Pack_Id := Conf_Pack.Next; @@ -522,18 +524,17 @@ package body Prj.Conf is -- For aggregate projects, we need to apply the config to all -- their aggregated trees as well. - if Proj.Project.Qualifier = Aggregate then + if Proj.Project.Qualifier in Aggregate_Project then declare - List : Aggregated_Project_List := - Proj.Project.Aggregated_Projects; + List : Aggregated_Project_List; begin + List := Proj.Project.Aggregated_Projects; while List /= null loop Debug_Output ("Recursively apply config to aggregated tree", List.Project.Name); Apply_Config_File - (Config_File, - Project_Tree => List.Tree); + (Config_File, Project_Tree => List.Tree); List := List.Next; end loop; end; @@ -958,6 +959,13 @@ package body Prj.Conf is end if; end loop; + -- Make sure that Obj_Dir ends with a directory separator + + if Name_Buffer (Name_Len) /= Directory_Separator then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Directory_Separator; + end if; + declare Obj_Dir : constant String := Name_Buffer (1 .. Name_Len); Config_Switches : Argument_List_Access; @@ -1132,8 +1140,7 @@ package body Prj.Conf is if Config_File_Name = "" then if Obj_Dir_Exists then - Args (3) := - new String'(Obj_Dir & Directory_Separator & Auto_Cgpr); + Args (3) := new String'(Obj_Dir & Auto_Cgpr); else declare @@ -1154,9 +1161,7 @@ package body Prj.Conf is else -- We'll have an error message later on - Args (3) := - new String' - (Obj_Dir & Directory_Separator & Auto_Cgpr); + Args (3) := new String'(Obj_Dir & Auto_Cgpr); end if; end; end if; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 8f0ca61af86..b1a1738412c 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -23,11 +23,7 @@ -- -- ------------------------------------------------------------------------------ -with Err_Vars; use Err_Vars; - -with GNAT.Case_Util; use GNAT.Case_Util; -with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; - +with Err_Vars; use Err_Vars; with Opt; use Opt; with Prj.Attr; use Prj.Attr; with Prj.Attr.PM; use Prj.Attr.PM; @@ -37,34 +33,34 @@ with Prj.Tree; use Prj.Tree; with Snames; with Uintp; use Uintp; +with GNAT; use GNAT; +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; with GNAT.Strings; package body Prj.Dect is - use GNAT; - type Zone is (In_Project, In_Package, In_Case_Construction); - -- Used to indicate if we are parsing a package (In_Package), - -- a case construction (In_Case_Construction) or none of those two - -- (In_Project). + -- Used to indicate if we are parsing a package (In_Package), a case + -- construction (In_Case_Construction) or none of those two (In_Project). procedure Rename_Obsolescent_Attributes (In_Tree : Project_Node_Tree_Ref; Attribute : Project_Node_Id; Current_Package : Project_Node_Id); - -- Rename obsolescent attributes in the tree. - -- When the attribute has been renamed since its initial introduction in - -- the design of projects, we replace the old name in the tree with the - -- new name, so that the code does not have to check both names forever. + -- Rename obsolescent attributes in the tree. When the attribute has been + -- renamed since its initial introduction in the design of projects, we + -- replace the old name in the tree with the new name, so that the code + -- does not have to check both names forever. procedure Check_Attribute_Allowed - (In_Tree : Project_Node_Tree_Ref; - Project : Project_Node_Id; - Attribute : Project_Node_Id; - Flags : Processing_Flags); - -- Check whether the attribute is valid in this project. - -- In particular, depending on the type of project (qualifier), some - -- attributes might be disabled. + (In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Attribute : Project_Node_Id; + Flags : Processing_Flags); + -- Check whether the attribute is valid in this project. In particular, + -- depending on the type of project (qualifier), some attributes might + -- be disabled. procedure Check_Package_Allowed (In_Tree : Project_Node_Tree_Ref; @@ -186,20 +182,20 @@ package body Prj.Dect is and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored then case Name_Of (Attribute, In_Tree) is - when Snames.Name_Specification => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec); + when Snames.Name_Specification => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec); - when Snames.Name_Specification_Suffix => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix); + when Snames.Name_Specification_Suffix => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix); - when Snames.Name_Implementation => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body); + when Snames.Name_Implementation => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body); - when Snames.Name_Implementation_Suffix => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix); + when Snames.Name_Implementation_Suffix => + Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix); - when others => - null; + when others => + null; end case; end if; end Rename_Obsolescent_Attributes; @@ -218,7 +214,7 @@ package body Prj.Dect is Project_Qualifier_Of (Project, In_Tree); Name : constant Name_Id := Name_Of (Current_Package, In_Tree); begin - if Qualif = Aggregate + if Qualif in Aggregate_Project and then Name /= Snames.Name_Builder then Error_Msg_Name_1 := Name; @@ -234,10 +230,10 @@ package body Prj.Dect is ----------------------------- procedure Check_Attribute_Allowed - (In_Tree : Project_Node_Tree_Ref; - Project : Project_Node_Id; - Attribute : Project_Node_Id; - Flags : Processing_Flags) + (In_Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Attribute : Project_Node_Id; + Flags : Processing_Flags) is Qualif : constant Project_Qualifier := Project_Qualifier_Of (Project, In_Tree); @@ -245,8 +241,8 @@ package body Prj.Dect is begin case Qualif is - when Aggregate => - if Name = Snames.Name_Languages + when Aggregate | Aggregate_Library => + if Name = Snames.Name_Languages or else Name = Snames.Name_Source_Files or else Name = Snames.Name_Source_List_File or else Name = Snames.Name_Locally_Removed_Files diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 6cca2e22cc5..9f29313a0b6 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -272,15 +272,15 @@ package body Prj.Env is begin -- Check if the directory is already in the table - for Index in Object_Path_Table.First .. - Object_Path_Table.Last (Object_Paths) + for Index in + Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths) loop -- If it is, remove it, and add it as the last one if Object_Paths.Table (Index) = Object_Dir then - for Index2 in Index + 1 .. - Object_Path_Table.Last (Object_Paths) + for Index2 in + Index + 1 .. Object_Path_Table.Last (Object_Paths) loop Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2); end loop; @@ -422,8 +422,8 @@ package body Prj.Env is -- Check if the source directory is already in the table - for Index in Source_Path_Table.First .. - Source_Path_Table.Last (Source_Paths) + for Index in + Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths) loop -- If it is already, no need to add it @@ -458,6 +458,7 @@ package body Prj.Env is Table_Low_Bound => 1, Table_Initial => 5, Table_Increment => 100); + Default_Naming : constant Naming_Id := Naming_Table.First; Namings : Naming_Table.Instance; -- Table storing the naming data for gnatmake/gprmake @@ -777,10 +778,9 @@ package body Prj.Env is In_Tree : Project_Tree_Ref; Name : out Path_Name_Type) is - File : File_Descriptor := Invalid_FD; - - Buffer : String_Access := new String (1 .. Buffer_Initial); - Buffer_Last : Natural := 0; + File : File_Descriptor := Invalid_FD; + Buffer : String_Access := new String (1 .. Buffer_Initial); + Buffer_Last : Natural := 0; procedure Put_Name_Buffer; -- Put the line contained in the Name_Buffer in the global buffer @@ -831,9 +831,8 @@ package body Prj.Env is if Source.Replaced_By = No_Source and then Source.Path.Name /= No_Path - and then - (Source.Language.Config.Kind = File_Based - or else Source.Unit /= No_Unit_Index) + and then (Source.Language.Config.Kind = File_Based + or else Source.Unit /= No_Unit_Index) then if Source.Unit /= No_Unit_Index then @@ -999,12 +998,12 @@ package body Prj.Env is Main_Project_Only : Boolean := True; Full_Path : Boolean := False) return String is + + Lang : constant Language_Ptr := + Get_Language_From_Name (Project, "ada"); The_Project : Project_Id := Project; Original_Name : String := Name; - Lang : constant Language_Ptr := - Get_Language_From_Name (Project, "ada"); - Unit : Unit_Index; The_Original_Name : Name_Id; The_Spec_Name : Name_Id; @@ -1140,10 +1139,8 @@ package body Prj.Env is -- Check for spec if not Main_Project_Only - or else - (Unit.File_Names (Spec) /= null - and then Unit.File_Names (Spec).Project = - The_Project) + or else (Unit.File_Names (Spec) /= null + and then Unit.File_Names (Spec).Project = The_Project) then declare Current_Name : File_Name_Type; @@ -1701,8 +1698,8 @@ package body Prj.Env is if Source_FD /= Invalid_FD then Buffer_Last := 0; - for Index in Source_Path_Table.First .. - Source_Path_Table.Last (Source_Paths) + for Index in + Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths) loop Get_Name_String (Source_Paths.Table (Index)); Name_Len := Name_Len + 1; @@ -1727,8 +1724,8 @@ package body Prj.Env is if Object_FD /= Invalid_FD then Buffer_Last := 0; - for Index in Object_Path_Table.First .. - Object_Path_Table.Last (Object_Paths) + for Index in + Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths) loop Get_Name_String (Object_Paths.Table (Index)); Name_Len := Name_Len + 1; @@ -1752,9 +1749,10 @@ package body Prj.Env is -- Set the env vars, if they need to be changed, and set the -- corresponding flags. - if Include_Path and then - Shared.Private_Part.Current_Source_Path_File /= - Project.Include_Path_File + if Include_Path + and then + Shared.Private_Part.Current_Source_Path_File /= + Project.Include_Path_File then Shared.Private_Part.Current_Source_Path_File := Project.Include_Path_File; @@ -2268,7 +2266,6 @@ package body Prj.Env is end if; -- No need to copy the Cache, it will be recomputed as needed - end Copy; end Prj.Env; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 1a8c2114c47..0ff3eda1732 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -36,6 +36,7 @@ with Sinput.P; with Snames; use Snames; with Targparm; use Targparm; +with Ada; use Ada; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Directories; use Ada.Directories; with Ada.Strings; use Ada.Strings; @@ -81,8 +82,7 @@ package body Prj.Nmsc is Hash => Hash, Equal => "="); -- File name information found in string list attribute (Source_Files or - -- Source_List_File). Except is set to True if source is a naming exception - -- in the project. Used to check that all referenced files were indeed + -- Source_List_File). Used to check that all referenced files were indeed -- found on the disk. type Unit_Exception is record @@ -217,8 +217,8 @@ package body Prj.Nmsc is generic with procedure Callback - (Path : Path_Information; - Pattern_Index : Natural); + (Path : Path_Information; + Pattern_Index : Natural); procedure Expand_Subdirectory_Pattern (Project : Project_Id; Data : in out Tree_Processing_Data; @@ -376,8 +376,7 @@ package body Prj.Nmsc is -- otherwise only those currently set in the Source_Names hash table. procedure Check_File_Naming_Schemes - (In_Tree : Project_Tree_Ref; - Project : Project_Processing_Data; + (Project : Project_Processing_Data; File_Name : File_Name_Type; Alternate_Languages : out Language_List; Language : out Language_Ptr; @@ -392,8 +391,8 @@ package body Prj.Nmsc is -- the same value. procedure Get_Directories - (Project : Project_Id; - Data : in out Tree_Processing_Data); + (Project : Project_Id; + Data : in out Tree_Processing_Data); -- Get the object directory, the exec directory and the source directories -- of a project. @@ -426,8 +425,7 @@ package body Prj.Nmsc is Naming : Lang_Naming_Data; Kind : out Source_Kind; Unit : out Name_Id; - Project : Project_Processing_Data; - In_Tree : Project_Tree_Ref); + Project : Project_Processing_Data); -- Check whether the file matches the naming scheme. If it does, -- compute its unit name. If Unit is set to No_Name on exit, none of the -- other out parameters are relevant. @@ -636,11 +634,11 @@ package body Prj.Nmsc is Locally_Removed : Boolean := False; Location : Source_Ptr := No_Location) is - Config : constant Language_Config := Lang_Id.Config; - UData : Unit_Index; - Add_Src : Boolean; - Source : Source_Id; - Prev_Unit : Unit_Index := No_Unit_Index; + Config : constant Language_Config := Lang_Id.Config; + UData : Unit_Index; + Add_Src : Boolean; + Source : Source_Id; + Prev_Unit : Unit_Index := No_Unit_Index; Source_To_Replace : Source_Id := No_Source; begin @@ -665,9 +663,7 @@ package body Prj.Nmsc is Source := Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name); - if Source /= No_Source - and then Source.Index = Index - then + if Source /= No_Source and then Source.Index = Index then Add_Src := False; end if; end if; @@ -891,9 +887,10 @@ package body Prj.Nmsc is Remove_Source (Data.Tree, Source_To_Replace, Id); end if; - if Data.Tree.Replaced_Source_Number > 0 and then - Replaced_Source_HTable.Get (Data.Tree.Replaced_Sources, Id.File) /= - No_File + if Data.Tree.Replaced_Source_Number > 0 + and then + Replaced_Source_HTable.Get + (Data.Tree.Replaced_Sources, Id.File) /= No_File then Replaced_Source_HTable.Remove (Data.Tree.Replaced_Sources, Id.File); Data.Tree.Replaced_Source_Number := @@ -981,7 +978,7 @@ package body Prj.Nmsc is -- Start of processing for Check_Aggregate_Project begin - pragma Assert (Project.Qualifier = Aggregate); + pragma Assert (Project.Qualifier in Aggregate_Project); if Project_Files.Default then Error_Msg_Name_1 := Snames.Name_Project_Files; @@ -1023,7 +1020,7 @@ package body Prj.Nmsc is (Project : Project_Id; Data : in out Tree_Processing_Data) is - Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; + Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Prj_Data : Project_Processing_Data; begin @@ -1031,20 +1028,28 @@ package body Prj.Nmsc is Initialize (Prj_Data, Project); - Check_If_Externally_Built (Project, Data); + Check_If_Externally_Built (Project, Data); - if Project.Qualifier /= Aggregate then - Get_Directories (Project, Data); - Check_Programming_Languages (Project, Data); + case Project.Qualifier is + when Aggregate => + null; - if Current_Verbosity = High then - Show_Source_Dirs (Project, Shared); - end if; - end if; + when Aggregate_Library => + if Project.Object_Directory = No_Path_Information then + Project.Object_Directory := Project.Directory; + end if; - case Project.Qualifier is - when Dry => Check_Abstract_Project (Project, Data); - when others => null; + when others => + Get_Directories (Project, Data); + Check_Programming_Languages (Project, Data); + + if Current_Verbosity = High then + Show_Source_Dirs (Project, Shared); + end if; + + if Project.Qualifier = Dry then + Check_Abstract_Project (Project, Data); + end if; end case; -- Check configuration. This must be done even for gnatmake (even though @@ -1056,7 +1061,13 @@ package body Prj.Nmsc is if Project.Qualifier /= Aggregate then Check_Library_Attributes (Project, Data); Check_Package_Naming (Project, Data); - Look_For_Sources (Prj_Data, Data); + + -- An aggregate library has no source, no need to look for them + + if Project.Qualifier /= Aggregate_Library then + Look_For_Sources (Prj_Data, Data); + end if; + Check_Interfaces (Project, Data); if Project.Library then @@ -1125,8 +1136,8 @@ package body Prj.Nmsc is (Project : Project_Id; Data : in out Tree_Processing_Data) is - Shared : constant Shared_Project_Tree_Data_Access := - Data.Tree.Shared; + Shared : constant Shared_Project_Tree_Data_Access := + Data.Tree.Shared; Dot_Replacement : File_Name_Type := No_File; Casing : Casing_Type := All_Lower_Case; @@ -1418,8 +1429,9 @@ package body Prj.Nmsc is Lang_Index.Config.Compiler_Driver := File_Name_Type (Element.Value.Value); - when Name_Required_Switches | - Name_Leading_Required_Switches => + when Name_Required_Switches + | Name_Leading_Required_Switches + => Put (Into_List => Lang_Index.Config. Compiler_Leading_Required_Switches, @@ -2703,8 +2715,8 @@ package body Prj.Nmsc is Source := Prj.Element (Iter); exit when Source = No_Source; - if Source.Unit /= No_Unit_Index and then - Source.Unit.Name = Name_Id (Name) + if Source.Unit /= No_Unit_Index + and then Source.Unit.Name = Name_Id (Name) then if not Source.Locally_Removed then Source.In_Interfaces := True; @@ -2856,8 +2868,8 @@ package body Prj.Nmsc is end if; end if; - elsif Project.Library_Kind /= Static and then - Proj.Library_Kind = Static + elsif Project.Library_Kind /= Static + and then Proj.Library_Kind = Static then Error_Msg_Name_1 := Project.Name; Error_Msg_Name_2 := Proj.Name; @@ -2951,8 +2963,8 @@ package body Prj.Nmsc is if Project.Library_Name /= No_Name then if Current_Verbosity = High then - Write_Attr ("Library name: ", - Get_Name_String (Project.Library_Name)); + Write_Attr + ("Library name: ", Get_Name_String (Project.Library_Name)); end if; pragma Assert (Lib_Dir.Kind = Single); @@ -3096,7 +3108,7 @@ package body Prj.Nmsc is Project.Library := Project.Library_Dir /= No_Path_Information - and then Project.Library_Name /= No_Name; + and then Project.Library_Name /= No_Name; if Project.Extends = No_Project then case Project.Qualifier is @@ -3179,8 +3191,8 @@ package body Prj.Nmsc is Lib_ALI_Dir.Location, Project); end if; - if (not Project.Externally_Built) and then - Project.Library_ALI_Dir /= Project.Library_Dir + if not Project.Externally_Built + and then Project.Library_ALI_Dir /= Project.Library_Dir then -- The library ALI directory cannot be the same as the -- Object directory. @@ -3378,7 +3390,9 @@ package body Prj.Nmsc is end; end if; - if Project.Library then + if Project.Library + and then Project.Qualifier /= Aggregate_Library + then Debug_Output ("this is a library project file"); Check_Library (Project.Extends, Extends => True); @@ -4285,6 +4299,12 @@ package body Prj.Nmsc is is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; + Lib_Name : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Name, + Project.Decl.Attributes, + Shared); + Lib_Interfaces : constant Prj.Variable_Value := Prj.Util.Value_Of (Snames.Name_Library_Interface, @@ -4336,6 +4356,46 @@ package body Prj.Nmsc is -- Library_Interface is defined. if not Lib_Interfaces.Default then + + -- The name of a stand-alone library needs to have the syntax of an + -- Ada identifier. + + declare + Name : constant String := Get_Name_String (Project.Library_Name); + OK : Boolean := Is_Letter (Name (Name'First)); + + Underline : Boolean := False; + + begin + for J in Name'First + 1 .. Name'Last loop + exit when not OK; + + if Is_Alphanumeric (Name (J)) then + Underline := False; + + elsif Name (J) = '_' then + if Underline then + OK := False; + else + Underline := True; + end if; + + else + OK := False; + end if; + end loop; + + OK := OK and not Underline; + + if not OK then + Error_Msg + (Data.Flags, + "Incorrect library name for a Stand-Alone Library", + Lib_Name.Location, Project); + return; + end if; + end; + declare Interfaces : String_List_Id := Lib_Interfaces.Values; Interface_ALIs : String_List_Id := Nil_String; @@ -4373,7 +4433,18 @@ package body Prj.Nmsc is Error_Msg_Name_1 := Unit; Next_Proj := Project.Extends; - Iter := For_Each_Source (Data.Tree, Project); + + if Project.Qualifier = Aggregate_Library then + + -- For an aggregate library we want to consider sources + -- of all aggregated projects. + + Iter := For_Each_Source (Data.Tree); + + else + Iter := For_Each_Source (Data.Tree, Project); + end if; + loop while Prj.Element (Iter) /= No_Source and then @@ -4405,6 +4476,7 @@ package body Prj.Nmsc is if Source /= No_Source then if Source.Project /= Project and then not Is_Extending (Project, Source.Project) + and then Project.Qualifier /= Aggregate_Library then Source := No_Source; end if; @@ -4429,13 +4501,13 @@ package body Prj.Nmsc is Shared.String_Elements.Table (String_Element_Table.Last (Shared.String_Elements)) := - (Value => Name_Id (Source.Dep_Name), - Index => 0, - Display_Value => Name_Id (Source.Dep_Name), - Location => - Shared.String_Elements.Table (Interfaces).Location, - Flag => False, - Next => Interface_ALIs); + (Value => Name_Id (Source.Dep_Name), + Index => 0, + Display_Value => Name_Id (Source.Dep_Name), + Location => + Shared.String_Elements.Table (Interfaces).Location, + Flag => False, + Next => Interface_ALIs); Interface_ALIs := String_Element_Table.Last (Shared.String_Elements); @@ -4890,10 +4962,10 @@ package body Prj.Nmsc is and then Name_Len > 3 and then Name_Buffer (2 .. 3) = "__" and then - ((Name_Buffer (1) = 'a') or else - (Name_Buffer (1) = 'g') or else - (Name_Buffer (1) = 'i') or else - (Name_Buffer (1) = 's')) + (Name_Buffer (1) = 'a' or else + Name_Buffer (1) = 'g' or else + Name_Buffer (1) = 'i' or else + Name_Buffer (1) = 's') then Name_Buffer (2) := '.'; Name_Buffer (3 .. Name_Len - 1) := Name_Buffer (4 .. Name_Len); @@ -4992,8 +5064,8 @@ package body Prj.Nmsc is OK := OK and then not Need_Letter and then not Last_Underscore; if OK then - if First /= Name'First and then - Is_Reserved (The_Name (First .. The_Name'Last)) + if First /= Name'First + and then Is_Reserved (The_Name (First .. The_Name'Last)) then return; end if; @@ -5179,12 +5251,12 @@ package body Prj.Nmsc is No_Sources : constant Boolean := ((not Source_Files.Default and then Source_Files.Values = Nil_String) - or else - (not Source_Dirs.Default - and then Source_Dirs.Values = Nil_String) - or else - (not Languages.Default - and then Languages.Values = Nil_String)) + or else + (not Source_Dirs.Default + and then Source_Dirs.Values = Nil_String) + or else + (not Languages.Default + and then Languages.Values = Nil_String)) and then Project.Extends = No_Project; -- Start of processing for Get_Directories @@ -5231,9 +5303,8 @@ package body Prj.Nmsc is Must_Exist => False, Externally_Built => Project.Externally_Built); - if not Dir_Exists - and then not Project.Externally_Built - then + if not Dir_Exists and then not Project.Externally_Built then + -- The object directory does not exist, report an error if the -- project is not externally built. @@ -5273,7 +5344,7 @@ package body Prj.Nmsc is -- We set the object directory to its default - Project.Exec_Directory := Project.Object_Directory; + Project.Exec_Directory := Project.Object_Directory; if Exec_Dir.Value /= Empty_String then Get_Name_String (Exec_Dir.Value); @@ -5342,19 +5413,19 @@ package body Prj.Nmsc is Remove_Source_Dirs := False; Add_To_Or_Remove_From_Source_Dirs - (Path => (Name => Project.Directory.Name, - Display_Name => Project.Directory.Display_Name), - Rank => 1); + (Path => (Name => Project.Directory.Name, + Display_Name => Project.Directory.Display_Name), + Rank => 1); else Remove_Source_Dirs := False; Find_Source_Dirs - (Project => Project, - Data => Data, - Patterns => Source_Dirs.Values, - Ignore => Ignore_Source_Sub_Dirs.Values, - Search_For => Search_Directories, - Resolve_Links => Opt.Follow_Links_For_Dirs); + (Project => Project, + Data => Data, + Patterns => Source_Dirs.Values, + Ignore => Ignore_Source_Sub_Dirs.Values, + Search_For => Search_Directories, + Resolve_Links => Opt.Follow_Links_For_Dirs); if Project.Source_Dirs = Nil_String and then Project.Qualifier = Standard @@ -5371,12 +5442,12 @@ package body Prj.Nmsc is then Remove_Source_Dirs := True; Find_Source_Dirs - (Project => Project, - Data => Data, - Patterns => Excluded_Source_Dirs.Values, - Ignore => Nil_String, - Search_For => Search_Directories, - Resolve_Links => Opt.Follow_Links_For_Dirs); + (Project => Project, + Data => Data, + Patterns => Excluded_Source_Dirs.Values, + Ignore => Nil_String, + Search_For => Search_Directories, + Resolve_Links => Opt.Follow_Links_For_Dirs); end if; Debug_Output ("putting source directories in canonical cases"); @@ -5554,8 +5625,7 @@ package body Prj.Nmsc is Naming : Lang_Naming_Data; Kind : out Source_Kind; Unit : out Name_Id; - Project : Project_Processing_Data; - In_Tree : Project_Tree_Ref) + Project : Project_Processing_Data) is Filename : constant String := Get_Name_String (File_Name); Last : Integer := Filename'Last; @@ -6216,8 +6286,10 @@ package body Prj.Nmsc is -- need for an object directory, if not specified. if Project.Project.Extends = No_Project - and then Project.Project.Object_Directory = - Project.Project.Directory + and then + Project.Project.Object_Directory = Project.Project.Directory + and then + not (Project.Project.Qualifier = Aggregate_Library) then Project.Project.Object_Directory := No_Path_Information; end if; @@ -6291,9 +6363,11 @@ package body Prj.Nmsc is declare Source_File_Path_Name : constant String := - Path_Name_Of - (File_Name_Type (Source_List_File.Value), - Project.Project.Directory.Display_Name); + Path_Name_Of + (File_Name_Type + (Source_List_File.Value), + Project.Project. + Directory.Display_Name); begin Has_Explicit_Sources := True; @@ -6544,8 +6618,7 @@ package body Prj.Nmsc is ------------------------------- procedure Check_File_Naming_Schemes - (In_Tree : Project_Tree_Ref; - Project : Project_Processing_Data; + (Project : Project_Processing_Data; File_Name : File_Name_Type; Alternate_Languages : out Language_List; Language : out Language_Ptr; @@ -6643,12 +6716,11 @@ package body Prj.Nmsc is if not Header_File then Compute_Unit_Name - (File_Name => File_Name, - Naming => Config.Naming_Data, - Kind => Kind, - Unit => Unit, - Project => Project, - In_Tree => In_Tree); + (File_Name => File_Name, + Naming => Config.Naming_Data, + Kind => Kind, + Unit => Unit, + Project => Project); if Unit /= No_Name then Language := Tmp_Lang; @@ -6701,8 +6773,12 @@ package body Prj.Nmsc is & " kind=" & Source.Kind'Img); end if; - if Source.Kind in Spec_Or_Body and then Source.Unit /= null then - Source.Unit.File_Names (Source.Kind) := Source; + if Source.Unit /= null then + if Source.Kind = Spec then + Source.Unit.File_Names (Spec) := Source; + else + Source.Unit.File_Names (Impl) := Source; + end if; end if; end Override_Kind; @@ -6837,7 +6913,6 @@ package body Prj.Nmsc is Name_Loc.Source.Unit.Name, Name_Loc.Source.Unit); end if; - end if; end if; end if; @@ -6845,8 +6920,7 @@ package body Prj.Nmsc is if Check_Name then Check_File_Naming_Schemes - (In_Tree => Data.Tree, - Project => Project, + (Project => Project, File_Name => File_Name, Alternate_Languages => Alternate_Languages, Language => Language, @@ -7028,7 +7102,8 @@ package body Prj.Nmsc is exit when Last = 0; if Name (1 .. Last) /= "." - and then Name (1 .. Last) /= ".." + and then + Name (1 .. Last) /= ".." then declare Path_Name : constant String := @@ -7181,6 +7256,7 @@ package body Prj.Nmsc is end if; if not Has_Error then + -- Links have been resolved if necessary, and Path_Name -- always ends with a directory separator. @@ -7252,8 +7328,9 @@ package body Prj.Nmsc is -- Loop through subdirectories - Source_Dir := Project.Project.Source_Dirs; Src_Dir_Rank := Project.Project.Source_Dir_Ranks; + + Source_Dir := Project.Project.Source_Dirs; while Source_Dir /= Nil_String loop begin Num_Nod := Shared.Number_Lists.Table (Src_Dir_Rank); @@ -7292,7 +7369,6 @@ package body Prj.Nmsc is loop Read (Dir, Name, Last); - exit when Last = 0; -- In fast project loading mode (without -eL), the user @@ -7459,8 +7535,8 @@ package body Prj.Nmsc is if Source.Unit /= No_Unit_Index then declare Unit_Except : Unit_Exception := - Unit_Exceptions_Htable.Get - (Project.Unit_Exceptions, Source.Unit.Name); + Unit_Exceptions_Htable.Get + (Project.Unit_Exceptions, Source.Unit.Name); begin Unit_Except.Name := Source.Unit.Name; @@ -7516,7 +7592,7 @@ package body Prj.Nmsc is procedure Check_Missing_Sources is Extending : constant Boolean := - Project.Project.Extends /= No_Project; + Project.Project.Extends /= No_Project; Language : Language_Ptr; Source : Source_Id; Alt_Lang : Language_List; @@ -7787,8 +7863,8 @@ package body Prj.Nmsc is Id.Project := Project.Project; Lang_Id := Project.Project.Languages; - while Lang_Id /= No_Language_Index and then - Lang_Id.Name /= Src.Language + while Lang_Id /= No_Language_Index + and then Lang_Id.Name /= Src.Language loop Lang_Id := Lang_Id.Next; end loop; @@ -7802,9 +7878,9 @@ package body Prj.Nmsc is " in source info file"); end if; - Id.Language := Lang_Id; - Id.Kind := Src.Kind; - Id.Index := Src.Index; + Id.Language := Lang_Id; + Id.Kind := Src.Kind; + Id.Index := Src.Index; Id.Path := (Path_Name_Type (Src.Display_Path_Name), @@ -7812,8 +7888,7 @@ package body Prj.Nmsc is Name_Len := 0; Add_Str_To_Name_Buffer - (Ada.Directories.Simple_Name - (Get_Name_String (Src.Path_Name))); + (Directories.Simple_Name (Get_Name_String (Src.Path_Name))); Id.File := Name_Find; Id.Next_With_File_Name := @@ -7822,16 +7897,16 @@ package body Prj.Nmsc is Name_Len := 0; Add_Str_To_Name_Buffer - (Ada.Directories.Simple_Name + (Directories.Simple_Name (Get_Name_String (Src.Display_Path_Name))); Id.Display_File := Name_Find; - Id.Dep_Name := Dependency_Name - (Id.File, Id.Language.Config.Dependency_Kind); - Id.Naming_Exception := Src.Naming_Exception; - Id.Object := Object_Name - (Id.File, Id.Language.Config.Object_File_Suffix); - Id.Switches := Switches_Name (Id.File); + Id.Dep_Name := + Dependency_Name (Id.File, Id.Language.Config.Dependency_Kind); + Id.Naming_Exception := Src.Naming_Exception; + Id.Object := + Object_Name (Id.File, Id.Language.Config.Object_File_Suffix); + Id.Switches := Switches_Name (Id.File); -- Add the source id to the Unit_Sources_HT hash table, if the -- unit name is not null. @@ -7840,7 +7915,8 @@ package body Prj.Nmsc is declare UData : Unit_Index := - Units_Htable.Get (Data.Tree.Units_HT, Src.Unit_Name); + Units_Htable.Get + (Data.Tree.Units_HT, Src.Unit_Name); begin if UData = No_Unit_Index then UData := new Unit_Data; @@ -8014,9 +8090,8 @@ package body Prj.Nmsc is when Warning | Error => declare Msg : constant String := - "<there are no " & - Lang_Name & - " sources in this project"; + "<there are no " + & Lang_Name & " sources in this project"; begin Error_Msg_Warn := Data.Flags.When_No_Sources = Warning; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 3b07a804648..1c18680fbe8 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -215,7 +215,6 @@ package body Prj.Part is Imported_Projects : in out Project_Node_Id; Project_Directory : Path_Name_Type; From_Extended : Extension_Origin; - In_Limited : Boolean; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; @@ -752,7 +751,6 @@ package body Prj.Part is Imported_Projects : in out Project_Node_Id; Project_Directory : Path_Name_Type; From_Extended : Extension_Origin; - In_Limited : Boolean; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; @@ -1503,7 +1501,6 @@ package body Prj.Part is Imported_Projects => Imported_Projects, Project_Directory => Project_Directory, From_Extended => From_Ext, - In_Limited => In_Limited, Packages_To_Check => Packages_To_Check, Depth => Depth + 1, Current_Dir => Current_Dir, @@ -1863,7 +1860,6 @@ package body Prj.Part is Imported_Projects => Imported_Projects, Project_Directory => Project_Directory, From_Extended => From_Ext, - In_Limited => In_Limited, Packages_To_Check => Packages_To_Check, Depth => Depth + 1, Current_Dir => Current_Dir, diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index b6049cc8936..269bc4552db 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -462,9 +462,9 @@ package body Prj.Proc is ------------------------- function Get_Attribute_Index - (Tree : Project_Node_Tree_Ref; - Attr : Project_Node_Id; - Index : Name_Id) return Name_Id + (Tree : Project_Node_Tree_Ref; + Attr : Project_Node_Id; + Index : Name_Id) return Name_Id is begin if Index = All_Other_Names @@ -685,8 +685,8 @@ package body Prj.Proc is Index : Name_Id := No_Name; begin - if Present (Term_Project) and then - Term_Project /= From_Project_Node + if Present (Term_Project) + and then Term_Project /= From_Project_Node then -- This variable or attribute comes from another project @@ -1331,8 +1331,8 @@ package body Prj.Proc is -- Should never happen - Write_Line ("package """ & Get_Name_String (With_Name) & - """ not found"); + Write_Line + ("package """ & Get_Name_String (With_Name) & """ not found"); raise Program_Error; else @@ -1363,8 +1363,8 @@ package body Prj.Proc is Env => Env, Reset_Tree => Reset_Tree); - if Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree) /= - Configuration + if Project_Qualifier_Of + (From_Project_Node, From_Project_Node_Tree) /= Configuration then Process_Project_Tree_Phase_2 (In_Tree => In_Tree, @@ -1381,17 +1381,16 @@ package body Prj.Proc is ------------------------------- procedure Process_Declarative_Items - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - From_Project_Node : Project_Node_Id; - Node_Tree : Project_Node_Tree_Ref; - Env : Prj.Tree.Environment; - Pkg : Package_Id; - Item : Project_Node_Id; - Child_Env : in out Prj.Tree.Environment) + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + From_Project_Node : Project_Node_Id; + Node_Tree : Project_Node_Tree_Ref; + Env : Prj.Tree.Environment; + Pkg : Package_Id; + Item : Project_Node_Id; + Child_Env : in out Prj.Tree.Environment) is - Shared : constant Shared_Project_Tree_Data_Access := - In_Tree.Shared; + Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; procedure Check_Or_Set_Typed_Variable (Value : in out Variable_Value; @@ -1459,8 +1458,8 @@ package body Prj.Proc is (String_Type_Of (Declaration, Node_Tree), Node_Tree); while Present (Current_String) - and then String_Value_Of (Current_String, Node_Tree) /= - Value.Value + and then + String_Value_Of (Current_String, Node_Tree) /= Value.Value loop Current_String := Next_Literal_String (Current_String, Node_Tree); @@ -1548,16 +1547,17 @@ package body Prj.Proc is declare Project_Name : constant Name_Id := - Name_Of (Project_Of_Renamed_Package, Node_Tree); + Name_Of (Project_Of_Renamed_Package, + Node_Tree); Renamed_Project : constant Project_Id := - Imported_Or_Extended_Project_From - (Project, Project_Name); + Imported_Or_Extended_Project_From + (Project, Project_Name); Renamed_Package : constant Package_Id := - Package_From - (Renamed_Project, Shared, - Name_Of (Current_Item, Node_Tree)); + Package_From + (Renamed_Project, Shared, + Name_Of (Current_Item, Node_Tree)); begin -- For a renamed package, copy the declarations of the @@ -1566,8 +1566,9 @@ package body Prj.Proc is -- declaration. Copy_Package_Declarations - (From => Shared.Packages.Table (Renamed_Package).Decl, - To => Shared.Packages.Table (New_Pkg).Decl, + (From => Shared.Packages.Table + (Renamed_Package).Decl, + To => Shared.Packages.Table (New_Pkg).Decl, New_Loc => Location_Of (Current_Item, Node_Tree), Restricted => False, Shared => Shared); @@ -2359,8 +2360,8 @@ package body Prj.Proc is (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); if Current_Verbosity = High then - Debug_Decrease_Indent ("Done Process tree, phase 1, Success=" - & Success'Img); + Debug_Decrease_Indent + ("Done Process tree, phase 1, Success=" & Success'Img); end if; end Process_Project_Tree_Phase_1; @@ -2396,12 +2397,10 @@ package body Prj.Proc is -- all virtual extending projects to object directory of main project. if Project /= No_Project - and then - Is_Extending_All (From_Project_Node, From_Project_Node_Tree) + and then Is_Extending_All (From_Project_Node, From_Project_Node_Tree) then declare - Object_Dir : constant Path_Information := - Project.Object_Directory; + Object_Dir : constant Path_Information := Project.Object_Directory; begin Prj := In_Tree.Projects; @@ -2471,10 +2470,9 @@ package body Prj.Proc is Debug_Decrease_Indent ("Done Process tree, phase 2"); - Success := - Total_Errors_Detected = 0 - and then - (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); + Success := Total_Errors_Detected = 0 + and then + (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); end Process_Project_Tree_Phase_2; ----------------------- @@ -2489,8 +2487,7 @@ package body Prj.Proc is Env : in out Prj.Tree.Environment; Extended_By : Project_Id) is - Shared : constant Shared_Project_Tree_Data_Access := - In_Tree.Shared; + Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; Child_Env : Prj.Tree.Environment; -- Only used for the root aggregate project (if any). This is left @@ -2576,21 +2573,23 @@ package body Prj.Proc is --------------------------------- procedure Process_Aggregated_Projects is - List : Aggregated_Project_List; + List : Aggregated_Project_List; Loaded_Project : Prj.Tree.Project_Node_Id; - Success : Boolean := True; + Success : Boolean := True; + Tree : Project_Tree_Ref; + begin - if Project.Qualifier /= Aggregate then + if Project.Qualifier not in Aggregate_Project then return; end if; Debug_Increase_Indent ("Process_Aggregated_Projects", Project.Name); Prj.Nmsc.Process_Aggregated_Projects - (Tree => In_Tree, - Project => Project, - Node_Tree => From_Project_Node_Tree, - Flags => Env.Flags); + (Tree => In_Tree, + Project => Project, + Node_Tree => From_Project_Node_Tree, + Flags => Env.Flags); List := Project.Aggregated_Projects; while Success and then List /= null loop @@ -2610,6 +2609,15 @@ package body Prj.Proc is Prj.Initialize (List.Tree); List.Tree.Shared := In_Tree.Shared; + -- In aggregate library, aggregated projects are parsed using + -- the aggregate library tree. + + if Project.Qualifier = Aggregate_Library then + Tree := In_Tree; + else + Tree := List.Tree; + end if; + -- We can only do the phase 1 of the processing, since we do -- not have access to the configuration file yet (this is -- called when doing phase 1 of the processing for the root @@ -2617,7 +2625,7 @@ package body Prj.Proc is if In_Tree.Is_Root_Tree then Process_Project_Tree_Phase_1 - (In_Tree => List.Tree, + (In_Tree => Tree, Project => List.Project, Success => Success, From_Project_Node => Loaded_Project, @@ -2628,7 +2636,7 @@ package body Prj.Proc is -- use the same environment as the rest of the aggregated -- projects, ie the one that was setup by the root aggregate Process_Project_Tree_Phase_1 - (In_Tree => List.Tree, + (In_Tree => Tree, Project => List.Project, Success => Success, From_Project_Node => Loaded_Project, @@ -2636,6 +2644,7 @@ package body Prj.Proc is Env => Env, Reset_Tree => False); end if; + else Debug_Output ("Failed to parse", Name_Id (List.Path)); end if; @@ -2667,8 +2676,8 @@ package body Prj.Proc is Current_Pkg := First; while Current_Pkg /= No_Package - and then Shared.Packages.Table (Current_Pkg).Name /= - Element.Name + and then + Shared.Packages.Table (Current_Pkg).Name /= Element.Name loop Current_Pkg := Shared.Packages.Table (Current_Pkg).Next; end loop; @@ -2702,9 +2711,8 @@ package body Prj.Proc is Attribute1 := Attr_Value1.Next; end loop; - if Attribute1 = No_Variable - or else Attr_Value1.Value.Default - then + if Attribute1 = No_Variable or else Attr_Value1.Value.Default then + -- Attribute Languages is not declared in the extending project. -- Check if it is declared in the project being extended. @@ -2715,8 +2723,8 @@ package body Prj.Proc is Attribute2 := Attr_Value2.Next; end loop; - if Attribute2 /= No_Variable and then - not Attr_Value2.Value.Default + if Attribute2 /= No_Variable + and then not Attr_Value2.Value.Default then -- As attribute Languages is declared in the project being -- extended, copy its value for the extending project. @@ -2793,8 +2801,8 @@ package body Prj.Proc is -- being a virtual extending project. if Name_Len > Virtual_Prefix'Length - and then Name_Buffer (1 .. Virtual_Prefix'Length) = - Virtual_Prefix + and then + Name_Buffer (1 .. Virtual_Prefix'Length) = Virtual_Prefix then Project.Virtual := True; end if; @@ -2827,11 +2835,15 @@ package body Prj.Proc is Process_Imported_Projects (Imported, Limited_With => False); - if Project.Qualifier = Aggregate - and then In_Tree.Is_Root_Tree - then + if Project.Qualifier = Aggregate and then In_Tree.Is_Root_Tree then Initialize_And_Copy (Child_Env, Copy_From => Env); + elsif Project.Qualifier = Aggregate_Library then + + -- The child environment is the same as the current one + + Child_Env := Env; + else -- No need to initialize Child_Env, since it will not be -- used anyway by Process_Declarative_Items (only the root @@ -2872,11 +2884,29 @@ package body Prj.Proc is if Err_Vars.Total_Errors_Detected = 0 then Process_Aggregated_Projects; + + -- For an aggregate library we add the aggregated projects as + -- imported ones. This is necessary to give visibility to all + -- sources from the aggregates from the aggregated library + -- projects. + + if Project.Qualifier = Aggregate_Library then + declare + L : Aggregated_Project_List; + begin + L := Project.Aggregated_Projects; + while L /= null loop + Project.Imported_Projects := + new Project_List_Element' + (Project => L.Project, + Next => Project.Imported_Projects); + L := L.Next; + end loop; + end; + end if; end if; - if Project.Qualifier = Aggregate - and then In_Tree.Is_Root_Tree - then + if Project.Qualifier = Aggregate and then In_Tree.Is_Root_Tree then Free (Child_Env); end if; end; diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index aee8da5c48c..8072c9daae4 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -144,9 +144,9 @@ package body Prj.Tree is -- Create new N_Comment node - if (Where = After or else Where = After_End) and then - Token /= Tok_EOF and then - Comments.Table (J).Follows_Empty_Line + if (Where = After or else Where = After_End) + and then Token /= Tok_EOF + and then Comments.Table (J).Follows_Empty_Line then Comments.Table (1 .. Comments.Last - J + 1) := Comments.Table (J .. Comments.Last); diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index c1f9409de15..9454f9ff418 100644 --- a/gcc/ada/prj-util.adb +++ b/gcc/ada/prj-util.adb @@ -128,8 +128,8 @@ package body Prj.Util is --------------- procedure Duplicate - (This : in out Name_List_Index; - Shared : Shared_Project_Tree_Data_Access) + (This : in out Name_List_Index; + Shared : Shared_Project_Tree_Data_Access) is Old_Current : Name_List_Index; New_Current : Name_List_Index; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 796e601cada..7795cc9c505 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -358,7 +358,6 @@ package body Prj is Name_Len := Name_Len - 1; return Name_Find; - end Extend_Name; --------------------- @@ -367,8 +366,10 @@ package body Prj is procedure Project_Changed (Iter : in out Source_Iterator) is begin - Iter.Language := Iter.Project.Project.Languages; - Language_Changed (Iter); + if Iter.Project /= null then + Iter.Language := Iter.Project.Project.Languages; + Language_Changed (Iter); + end if; end Project_Changed; ---------------------- @@ -377,7 +378,7 @@ package body Prj is procedure Language_Changed (Iter : in out Source_Iterator) is begin - Iter.Current := No_Source; + Iter.Current := No_Source; if Iter.Language_Name /= No_Name then while Iter.Language /= null @@ -392,11 +393,7 @@ package body Prj is if Iter.Language = No_Language_Index then if Iter.All_Projects then Iter.Project := Iter.Project.Next; - - if Iter.Project /= null then - Project_Changed (Iter); - end if; - + Project_Changed (Iter); else Iter.Project := null; end if; @@ -494,7 +491,6 @@ package body Prj is Tree : Project_Tree_Ref) is List : Project_List; - Agg : Aggregated_Project_List; begin if not Get (Seen, Project) then @@ -524,14 +520,18 @@ package body Prj is -- Visit all aggregated projects if Include_Aggregated - and then Project.Qualifier = Aggregate + and then Project.Qualifier in Aggregate_Project then - Agg := Project.Aggregated_Projects; - while Agg /= null loop - pragma Assert (Agg.Project /= No_Project); - Recursive_Check (Agg.Project, Agg.Tree); - Agg := Agg.Next; - end loop; + declare + Agg : Aggregated_Project_List; + begin + Agg := Project.Aggregated_Projects; + while Agg /= null loop + pragma Assert (Agg.Project /= No_Project); + Recursive_Check (Agg.Project, Agg.Tree); + Agg := Agg.Next; + end loop; + end; end if; if Imported_First then @@ -626,6 +626,7 @@ package body Prj is Include_Aggregated => False, With_State => Result); end if; + else Look_For_Sources (No_Project, In_Tree, Result); end if; @@ -853,7 +854,7 @@ package body Prj is Free_List (Project.Languages); case Project.Qualifier is - when Aggregate => + when Aggregate | Aggregate_Library => Free (Project.Aggregated_Projects); when others => @@ -1363,8 +1364,8 @@ package body Prj is procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Recursive_Add); - Dummy : Boolean := False; - List : Project_List; + Dummy : Boolean := False; + List : Project_List; begin List := Local_Tree.Projects; @@ -1658,10 +1659,11 @@ package body Prj is Root_Tree : Project_Tree_Ref) is Agg : Aggregated_Project_List; + begin Action (Root_Project, Root_Tree); - if Root_Project.Qualifier = Aggregate then + if Root_Project.Qualifier in Aggregate_Project then Agg := Root_Project.Aggregated_Projects; while Agg /= null loop For_Project_And_Aggregated (Agg.Project, Agg.Tree); @@ -1670,6 +1672,8 @@ package body Prj is end if; end For_Project_And_Aggregated; +-- Package initialization for Prj + begin -- Make sure that the standard config and user project file extensions are -- compatible with canonical case file naming. diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index a9943ca773a..e88455dec3c 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -77,6 +77,9 @@ package Prj is -- Aggregate_Library: aggregate library project is ... -- Configuration: configuration project is ... + subtype Aggregate_Project is + Project_Qualifier range Aggregate .. Aggregate_Library; + All_Packages : constant String_List_Access; -- Default value of parameter Packages of procedures Parse, in Prj.Pars and -- Prj.Part, indicating that all packages should be checked. @@ -1343,7 +1346,7 @@ package Prj is -- The following fields are only valid for specific types of projects case Qualifier is - when Aggregate => + when Aggregate | Aggregate_Library => Aggregated_Projects : Aggregated_Project_List := null; -- List of aggregated projects (which could themselves be -- aggregate projects). diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index 6f87ba5a011..d6130411409 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -1,6 +1,7 @@ @set gprconfig GPRconfig @c ------ projects.texi +@c Copyright (C) 2002-2011, Free Software Foundation, Inc. @c This file is shared between the GNAT user's guide and gprbuild. It is not @c compilable on its own, you should instead compile the other two manuals. @c For that reason, there is no toplevel @menu @@ -19,6 +20,7 @@ * Library Projects:: * Project Extension:: * Aggregate Projects:: +* Aggregate Library Projects:: * Project File Reference:: @end menu @@ -1524,10 +1526,11 @@ front of the @code{project} keyword. @item @b{Library_Name}: @cindex @code{Library_Name} This attribute is the name of the library to be built. There is no - restriction on the name of a library imposed by the project manager; - however, there may be system specific restrictions on the name. - In general, it is recommended to stick to alphanumeric characters - (and possibly underscores) to help portability. + restriction on the name of a library imposed by the project manager, except + for stand-alone libraries whose names must follow the syntax of Ada + identifiers; however, there may be system specific restrictions on the name. + In general, it is recommended to stick to alphanumeric characters (and + possibly single underscores) to help portability. @item @b{Library_Dir}: @cindex @code{Library_Dir} @@ -1748,6 +1751,9 @@ transparent. However, stand-alone libraries are also useful when the main is in Ada: they provide a means for minimizing relinking & redeployment of complex systems when localized changes are made. +The name of a stand-alone library, specified with attribute +@code{Library_Name}, must have the syntax of an Ada identifier. + The most prominent characteristic of a stand-alone library is that it offers a distinction between interface units and implementation units. Only the former are visible to units outside the library. A stand-alone library project is thus @@ -2125,7 +2131,19 @@ meant to solve a few specific use cases that cannot be solved directly using standard projects. This section will go over a few of these use cases to try and explain what you can use aggregate projects for. +@menu +* Building all main units from a single project tree:: +* Building a set of projects with a single command:: +* Define a build environment:: +* Performance improvements in builder:: +* Syntax of aggregate projects:: +* package Builder in aggregate projects:: +@end menu + +@c ----------------------------------------------------------- +@node Building all main units from a single project tree @subsection Building all main units from a single project tree +@c ----------------------------------------------------------- Most often, an application is organized into modules and submodules, which are very conveniently represented as a project tree or graph @@ -2178,7 +2196,10 @@ aggregate project, you will need to add "p.gpr" in the list of project files for the aggregate project, or the main unit will not be built when building the aggregate project. +@c --------------------------------------------------------- +@node Building a set of projects with a single command @subsection Building a set of projects with a single command +@c --------------------------------------------------------- One other case is when you have multiple applications and libraries that are build independently from each other (but they can be build in @@ -2217,7 +2238,10 @@ with Annex E. Aggregate projects can be used to build multiple partitions @end smallexample +@c --------------------------------------------- +@node Define a build environment @subsection Define a build environment +@c --------------------------------------------- The environment variables at the time you launch gprbuild or gprbuild will influence the view these tools have of the project (PATH to find @@ -2272,7 +2296,10 @@ project MyProject is end MyProject; @end smallexample +@c -------------------------------------------- +@node Performance improvements in builder @subsection Performance improvements in builder +@c -------------------------------------------- The loading of aggregate projects is optimized in gprbuild and gnatmake, so that all files are searched for only once on the disk @@ -2288,7 +2315,10 @@ can be compiled in parallel (through the usual -j switch) and this can be done while maximizing the use of CPUs (compared to launching multiple gprbuild and gnatmake commands in parallel). +@c ------------------------------------- +@node Syntax of aggregate projects @subsection Syntax of aggregate projects +@c ------------------------------------- An aggregate project follows the general syntax of project files. The recommended extension is still @file{.gpr}. However, a special @@ -2307,7 +2337,7 @@ attributes and packages are forbidden in an aggregate project. Here is the @itemize @bullet @item Languages -@item Source_files, Source_List_File and other attributes dealing with +@item Source_Files, Source_List_File and other attributes dealing with list of sources. @item Source_Dirs, Exec_Dir and Object_Dir @item Library_Dir, Library_Name and other library-related attributes @@ -2317,7 +2347,7 @@ attributes and packages are forbidden in an aggregate project. Here is the @item Inherit_Source_Path @item Excluded_Source_Dirs @item Locally_Removed_Files -@item Excluded_Source_Fies +@item Excluded_Source_Files @item Excluded_Source_List_File @item Interfaces @end itemize @@ -2486,7 +2516,10 @@ P, which in particular might impact the list of source files in P. @end table +@c ---------------------------------------------- +@node package Builder in aggregate projects @subsection package Builder in aggregate projects +@c ---------------------------------------------- As we mentioned before, only the package Builder can be specified in an aggregate project. In this package, only the following attributes @@ -2608,6 +2641,116 @@ name of the executables resulting from the link of the main units, and for the Executable_Suffix. @c --------------------------------------------- +@node Aggregate Library Projects +@section Aggregate Library Projects +@c --------------------------------------------- + +@noindent + +Aggregate library projects make it possible to build a single library +using object files built using other standard or library +projects. This gives the flexibility to describe an application as +having multiple modules (a GUI, database access, ...) using different +project files (so possibly built with different compiler options) and +yet create a single library (static or relocatable) out of the +corresponding object files. + +@menu +* Building aggregate library projects:: +* Syntax of aggregate library projects:: +@end menu + +@c --------------------------------------------- +@node Building aggregate library projects +@subsection Building aggregate library projects +@c --------------------------------------------- + +For example, we can define an aggregate project Agg that groups A, B +and C: + +@smallexample @c projectfile + aggregate library project Agg is + for Project_Files use ("a.gpr", "b.gpr", "c.gpr"); + for Library_Name use ("agg"); + for Library_Dir use ("lagg"); + end Agg; +@end smallexample + +Then, when you build with: + +@smallexample + gprbuild agg.gpr +@end smallexample + +This will build all units from projects A, B and C and will create a +static library named @file{libagg.a} into the @file{lagg} +directory. An aggregate library project has the same set of +restriction as a standard library project. + +Note that a shared aggregate library project cannot aggregates a +static library project. In platforms where a compiler option is +required to create relocatable object files, a Builder package in the +aggregate library project may be used: + +@smallexample @c projectfile + aggregate library project Agg is + for Project_Files use ("a.gpr", "b.gpr", "c.gpr"); + for Library_Name use ("agg"); + for Library_Dir use ("lagg"); + for Library_Kind use "relocatable"; + + package Builder is + for Global_Compilation_Switches ("Ada") use ("-fPIC"); + end Builder; + end Agg; +@end smallexample + +With the above aggregate library Builder package, the @code{-fPIC} +option will be passed to the compiler when building any source code +from projects @file{a.gpr}, @file{b.gpr} and @file{c.gpr}. + +@c --------------------------------------------- +@node Syntax of aggregate library projects +@subsection Syntax of aggregate library projects +@c --------------------------------------------- + +An aggregate library project follows the general syntax of project +files. The recommended extension is still @file{.gpr}. However, a special +@code{aggregate library} qualifier must be put before the keyword +@code{project}. + +An aggregate library project cannot @code{with} any other project +(standard or aggregate), except an abstract project which can be used +to share attribute values. + +An aggregate library project does not have any source files directly (only +through other standard projects). Therefore a number of the standard +attributes and packages are forbidden in an aggregate library +project. Here is the (non exhaustive) list: + +@itemize @bullet +@item Languages +@item Source_Files, Source_List_File and other attributes dealing with + list of sources. +@item Source_Dirs, Exec_Dir and Object_Dir +@item Main +@item Roots +@item Externally_Built +@item Inherit_Source_Path +@item Excluded_Source_Dirs +@item Locally_Removed_Files +@item Excluded_Source_Files +@item Excluded_Source_List_File +@item Interfaces +@end itemize + +The only package that is authorized (albeit optional) is Builder. + +The Project_Files attribute (See @pxref{Aggregate Projects}) is used to +described the aggregated projects whose object files have to be +included into the aggregate library. + +@c --------------------------------------------- @node Project File Reference @section Project File Reference @c --------------------------------------------- diff --git a/gcc/ada/put_alfa.adb b/gcc/ada/put_alfa.adb index adb41a8397f..49dfac87df1 100644 --- a/gcc/ada/put_alfa.adb +++ b/gcc/ada/put_alfa.adb @@ -151,8 +151,8 @@ begin Write_Info_Char (S.Scope_Name (N)); end loop; - -- Default value of (0,0) is used for the special HEAP variable - -- so use another default value. + -- Default value of (0,0) is used for the special __HEAP + -- variable so use another default value. Entity_Line := 0; Entity_Col := 1; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index bb963d097e8..459f886dcc9 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -135,7 +135,7 @@ package body Rtsfind is -- Check entity Eid to ensure that configurable run-time restrictions are -- met. May generate an error message (if RTE_Available_Call is false) and -- raise RE_Not_Available if entity E does not exist (e.g. Eid is Empty). - -- Above documentation not clear ??? + -- Also check that entity is not overloaded. procedure Entity_Not_Defined (Id : RE_Id); -- Outputs error messages for an entity that is not defined in the run-time @@ -233,6 +233,22 @@ package body Rtsfind is raise RE_Not_Available; end if; + -- Check entity is not overloaded, checking for special exceptions + + if Has_Homonym (Eid) + and then E /= RE_Save_Occurrence + then + Set_Standard_Error; + Write_Str ("Run-time configuration error ("); + Write_Str ("rtsfind entity """); + Get_Decoded_Name_String (Chars (Eid)); + Set_Casing (Mixed_Case); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Str (""" is overloaded)"); + Write_Eol; + raise Unrecoverable_Error; + end if; + -- Otherwise entity is accessible return Eid; @@ -414,8 +430,8 @@ package body Rtsfind is return E1 = E2; end if; - -- If the unit containing E is not loaded, we already know that - -- the entity we have cannot have come from this unit. + -- If the unit containing E is not loaded, we already know that the + -- entity we have cannot have come from this unit. E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E)); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index bc5556904fc..7b772d021c4 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -498,6 +498,14 @@ package Rtsfind is -- value is required syntactically, but no real entry is required or -- needed. Use of this value will cause a fatal error in an RTE call. + -- Note that under no circumstances can any of these entities be defined + -- more than once in a given package, i.e. no overloading is allowed for + -- any entity that is found using rtsfind. A fatal error is given if this + -- rule is violated. The one exception is for Save_Occurrence, where the + -- RM mandates the overloading. In this case, the compiler only uses the + -- procedure, not the function, and the procedure must come first so that + -- the compiler finds it and not the function. + type RE_Id is ( RE_Null, diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb index a08bb08a494..c663988f43a 100644 --- a/gcc/ada/s-finmas.adb +++ b/gcc/ada/s-finmas.adb @@ -463,22 +463,36 @@ package body System.Finalization_Masters is Fin_Addr_Ptr : Finalize_Address_Ptr) is begin - Master.Finalize_Address := Fin_Addr_Ptr; + -- TSS primitive Finalize_Address is set at the point of allocation, + -- either through Allocate_Any_Controlled or through this routine. + -- Since multiple tasks can allocate on the same finalization master, + -- access to this attribute must be protected. + + Lock_Task.all; + + if Master.Finalize_Address = null then + Master.Finalize_Address := Fin_Addr_Ptr; + end if; + + Unlock_Task.all; end Set_Finalize_Address; - -------------------------- - -- Set_Finalize_Address -- - -------------------------- + ---------------------------------------- + -- Set_Heterogeneous_Finalize_Address -- + ---------------------------------------- - procedure Set_Finalize_Address + procedure Set_Heterogeneous_Finalize_Address (Obj : System.Address; Fin_Addr_Ptr : Finalize_Address_Ptr) is begin + -- Protected access is required in this case because + -- Finalize_Address_Table is a global data structure. + Lock_Task.all; Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr); Unlock_Task.all; - end Set_Finalize_Address; + end Set_Heterogeneous_Finalize_Address; -------------------------- -- Set_Is_Heterogeneous -- diff --git a/gcc/ada/s-finmas.ads b/gcc/ada/s-finmas.ads index 0ffc78af2d0..bb9ff5bdc3c 100644 --- a/gcc/ada/s-finmas.ads +++ b/gcc/ada/s-finmas.ads @@ -119,13 +119,15 @@ package System.Finalization_Masters is procedure Set_Finalize_Address (Master : in out Finalization_Master; Fin_Addr_Ptr : Finalize_Address_Ptr); - -- Set the clean up routine of a finalization master. Note: this routine - -- must precede the one below since RTSfind needs to match this one. + -- Set the clean up routine of a finalization master - procedure Set_Finalize_Address + procedure Set_Heterogeneous_Finalize_Address (Obj : System.Address; Fin_Addr_Ptr : Finalize_Address_Ptr); - -- Add a relation pair object - Finalize_Address to the internal hash table + -- Add a relation pair object - Finalize_Address to the internal hash + -- table. This is done in the context of allocation on a heterogeneous + -- finalization master where a single master services multiple anonymous + -- access-to-controlled types. procedure Set_Is_Heterogeneous (Master : in out Finalization_Master); -- Mark the master as being a heterogeneous collection of objects diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb index 68a4ac30d04..e2b5235f054 100644 --- a/gcc/ada/s-htable.adb +++ b/gcc/ada/s-htable.adb @@ -195,16 +195,21 @@ package body System.HTable is ------------------------ function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is - K : constant Key := Get_Key (E); + K : Key renames Get_Key (E); + -- Note that it is important to use a renaming here rather than + -- define a constant initialized by the call, because the latter + -- construct runs into bootstrap problems with earlier versions + -- of the GNAT compiler. + Index : constant Header_Num := Hash (K); - Elmt : Elmt_Ptr := Table (Index); + Elmt : Elmt_Ptr; begin + Elmt := Table (Index); loop if Elmt = Null_Ptr then Set_Next (E, Table (Index)); Table (Index) := E; - return True; elsif Equal (Get_Key (Elmt), K) then diff --git a/gcc/ada/s-linux-alpha.ads b/gcc/ada/s-linux-alpha.ads index cdc716c727d..ba72719f8db 100644 --- a/gcc/ada/s-linux-alpha.ads +++ b/gcc/ada/s-linux-alpha.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-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- -- @@ -111,9 +111,4 @@ package System.Linux is SA_SIGINFO : constant := 16#40#; SA_ONSTACK : constant := 16#01#; - type pthread_mutex_t is record - dum0, dum1, dum2, dum3, dum4 : Interfaces.C.unsigned_long; - end record; - pragma Convention (C, pthread_mutex_t); - end System.Linux; diff --git a/gcc/ada/s-linux-hppa.ads b/gcc/ada/s-linux-hppa.ads index 6176376cbeb..d25dcebdb33 100644 --- a/gcc/ada/s-linux-hppa.ads +++ b/gcc/ada/s-linux-hppa.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -103,26 +103,4 @@ package System.Linux is SA_SIGINFO : constant := 16#10#; SA_ONSTACK : constant := 16#01#; - type lock_array is array (1 .. 4) of Integer; - type atomic_lock_t is record - lock : lock_array; - end record; - pragma Convention (C, atomic_lock_t); - for atomic_lock_t'Alignment use 16; - - type struct_pthread_fast_lock is record - spinlock : atomic_lock_t; - status : Long_Integer; - end record; - pragma Convention (C, struct_pthread_fast_lock); - - type pthread_mutex_t is record - m_reserved : Integer; - m_count : Integer; - m_owner : System.Address; - m_kind : Integer; - m_lock : struct_pthread_fast_lock; - end record; - pragma Convention (C, pthread_mutex_t); - end System.Linux; diff --git a/gcc/ada/s-linux-mipsel.ads b/gcc/ada/s-linux-mipsel.ads index c0911d8d16a..f1b119d0f11 100644 --- a/gcc/ada/s-linux-mipsel.ads +++ b/gcc/ada/s-linux-mipsel.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-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- -- @@ -100,19 +100,4 @@ package System.Linux is SA_SIGINFO : constant := 16#04#; SA_ONSTACK : constant := 16#08000000#; - type struct_pthread_fast_lock is record - status : Long_Integer; - spinlock : Integer; - end record; - pragma Convention (C, struct_pthread_fast_lock); - - type pthread_mutex_t is record - m_reserved : Integer; - m_count : Integer; - m_owner : System.Address; - m_kind : Integer; - m_lock : struct_pthread_fast_lock; - end record; - pragma Convention (C, pthread_mutex_t); - end System.Linux; diff --git a/gcc/ada/s-linux-sparc.ads b/gcc/ada/s-linux-sparc.ads index 206eb86a072..756d69d8f30 100644 --- a/gcc/ada/s-linux-sparc.ads +++ b/gcc/ada/s-linux-sparc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-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- -- @@ -109,11 +109,4 @@ package System.Linux is SA_SIGINFO : constant := 16#200#; SA_ONSTACK : constant := 16#001#; - type pthread_mutex_t is record - L1, L2, L3, L4 : Interfaces.C.long; - I1, I2 : Interfaces.C.int; - end record; - pragma Convention (C, pthread_mutex_t); - -- 24 bytes for 32-bit and 40 bytes for 64-bit, aligned like 'long' - end System.Linux; diff --git a/gcc/ada/s-linux.ads b/gcc/ada/s-linux.ads index 29918d7d4ca..c8a7ad1744e 100644 --- a/gcc/ada/s-linux.ads +++ b/gcc/ada/s-linux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -101,19 +101,4 @@ package System.Linux is SA_SIGINFO : constant := 16#04#; SA_ONSTACK : constant := 16#08000000#; - type struct_pthread_fast_lock is record - status : Long_Integer; - spinlock : Integer; - end record; - pragma Convention (C, struct_pthread_fast_lock); - - type pthread_mutex_t is record - m_reserved : Integer; - m_count : Integer; - m_owner : System.Address; - m_kind : Integer; - m_lock : struct_pthread_fast_lock; - end record; - pragma Convention (C, pthread_mutex_t); - end System.Linux; diff --git a/gcc/ada/s-maccod.ads b/gcc/ada/s-maccod.ads index c1bfbf1b81f..a95e319cb98 100644 --- a/gcc/ada/s-maccod.ads +++ b/gcc/ada/s-maccod.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- -- @@ -36,6 +36,10 @@ package System.Machine_Code is pragma Pure; + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + type Asm_Input_Operand is private; type Asm_Output_Operand is private; -- These types are never used directly, they are declared only so that diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index 85e77ebbc74..1c63e386ea9 100755 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -707,7 +707,8 @@ package System.OS_Lib is -- -- This function will always set Success to False under VxWorks and other -- similar operating systems which have no notion of the concept of - -- dynamically executable file. + -- dynamically executable file. Otherwise Success is set True if the exit + -- status of the spawned process is zero. function Spawn (Program_Name : String; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index fe3b90d1854..ad3d06520d8 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -163,6 +163,11 @@ pragma Style_Checks ("M32766"); # include <_types.h> #endif +#ifdef __linux__ +# include <pthread.h> +# include <signal.h> +#endif + #ifdef NATIVE #include <stdio.h> @@ -1256,12 +1261,18 @@ CND(SIZEOF_sockaddr_in6, "struct sockaddr_in6") #define SIZEOF_fd_set (sizeof (fd_set)) CND(SIZEOF_fd_set, "fd_set"); +CND(FD_SETSIZE, "Max fd value"); #define SIZEOF_struct_hostent (sizeof (struct hostent)) CND(SIZEOF_struct_hostent, "struct hostent"); #define SIZEOF_struct_servent (sizeof (struct servent)) CND(SIZEOF_struct_servent, "struct servent"); + +#if defined (__linux__) +#define SIZEOF_sigset (sizeof (sigset_t)) +CND(SIZEOF_sigset, "sigset"); +#endif /* -- Fields of struct msghdr @@ -1351,43 +1362,51 @@ CND(WSAEDISCON, "Disconnected") putchar ('\n'); #endif -#if defined (__APPLE__) || defined (DUMMY) +#if defined (__APPLE__) || defined (__linux__) || defined (DUMMY) /* - ------------------------------- - -- Darwin-specific constants -- - ------------------------------- - - -- These constants may be used only within the Darwin version of the GNAT - -- runtime library. + -- Sizes of pthread data types (on Darwin these are padding) */ -#define PTHREAD_SIZE __PTHREAD_SIZE__ -CND(PTHREAD_SIZE, "Pad in pthread_t") +#if defined (__APPLE__) || defined (DUMMY) +#define PTHREAD_SIZE __PTHREAD_SIZE__ +#define PTHREAD_ATTR_SIZE __PTHREAD_ATTR_SIZE__ +#define PTHREAD_MUTEXATTR_SIZE __PTHREAD_MUTEXATTR_SIZE__ +#define PTHREAD_MUTEX_SIZE __PTHREAD_MUTEX_SIZE__ +#define PTHREAD_CONDATTR_SIZE __PTHREAD_CONDATTR_SIZE__ +#define PTHREAD_COND_SIZE __PTHREAD_COND_SIZE__ +#define PTHREAD_RWLOCKATTR_SIZE __PTHREAD_RWLOCKATTR_SIZE__ +#define PTHREAD_RWLOCK_SIZE __PTHREAD_RWLOCK_SIZE__ +#define PTHREAD_ONCE_SIZE __PTHREAD_ONCE_SIZE__ +#else +#define PTHREAD_SIZE (sizeof (pthread_t)) +#define PTHREAD_ATTR_SIZE (sizeof (pthread_attr_t)) +#define PTHREAD_MUTEXATTR_SIZE (sizeof (pthread_mutexattr_t)) +#define PTHREAD_MUTEX_SIZE (sizeof (pthread_mutex_t)) +#define PTHREAD_CONDATTR_SIZE (sizeof (pthread_condattr_t)) +#define PTHREAD_COND_SIZE (sizeof (pthread_cond_t)) +#define PTHREAD_RWLOCKATTR_SIZE (sizeof (pthread_rwlockattr_t)) +#define PTHREAD_RWLOCK_SIZE (sizeof (pthread_rwlock_t)) +#define PTHREAD_ONCE_SIZE (sizeof (pthread_once_t)) +#endif -#define PTHREAD_ATTR_SIZE __PTHREAD_ATTR_SIZE__ -CND(PTHREAD_ATTR_SIZE, "Pad in pthread_attr_t") +CND(PTHREAD_SIZE, "pthread_t") -#define PTHREAD_MUTEXATTR_SIZE __PTHREAD_MUTEXATTR_SIZE__ -CND(PTHREAD_MUTEXATTR_SIZE, "Pad in pthread_mutexattr_t") +CND(PTHREAD_ATTR_SIZE, "pthread_attr_t") -#define PTHREAD_MUTEX_SIZE __PTHREAD_MUTEX_SIZE__ -CND(PTHREAD_MUTEX_SIZE, "Pad in pthread_mutex_t") +CND(PTHREAD_MUTEXATTR_SIZE, "pthread_mutexattr_t") -#define PTHREAD_CONDATTR_SIZE __PTHREAD_CONDATTR_SIZE__ -CND(PTHREAD_CONDATTR_SIZE, "Pad in pthread_condattr_t") +CND(PTHREAD_MUTEX_SIZE, "pthread_mutex_t") -#define PTHREAD_COND_SIZE __PTHREAD_COND_SIZE__ -CND(PTHREAD_COND_SIZE, "Pad in pthread_cond_t") +CND(PTHREAD_CONDATTR_SIZE, "pthread_condattr_t") -#define PTHREAD_RWLOCKATTR_SIZE __PTHREAD_RWLOCKATTR_SIZE__ -CND(PTHREAD_RWLOCKATTR_SIZE, "Pad in pthread_rwlockattr_t") +CND(PTHREAD_COND_SIZE, "pthread_cond_t") + +CND(PTHREAD_RWLOCKATTR_SIZE, "pthread_rwlockattr_t") -#define PTHREAD_RWLOCK_SIZE __PTHREAD_RWLOCK_SIZE__ -CND(PTHREAD_RWLOCK_SIZE, "Pad in pthread_rwlock_t") +CND(PTHREAD_RWLOCK_SIZE, "pthread_rwlock_t") -#define PTHREAD_ONCE_SIZE __PTHREAD_ONCE_SIZE__ -CND(PTHREAD_ONCE_SIZE, "Pad in pthread_once_t") +CND(PTHREAD_ONCE_SIZE, "pthread_once_t") #endif diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads index 18a314bbc97..bd37c119fd1 100644 --- a/gcc/ada/s-osinte-linux.ads +++ b/gcc/ada/s-osinte-linux.ads @@ -41,6 +41,7 @@ with Ada.Unchecked_Conversion; with Interfaces.C; with System.Linux; +with System.OS_Constants; package System.OS_Interface is pragma Preelaborate; @@ -533,7 +534,8 @@ package System.OS_Interface is private - type sigset_t is array (0 .. 127) of unsigned_char; + type sigset_t is + array (0 .. OS_Constants.SIZEOF_sigset - 1) of unsigned_char; pragma Convention (C, sigset_t); for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment; @@ -557,35 +559,38 @@ private end record; pragma Convention (C, timespec); + type unsigned_long_long_t is mod 2 ** 64; + -- Local type only used to get the alignment of this type below + + subtype char_array is Interfaces.C.char_array; + type pthread_attr_t is record - detachstate : int; - schedpolicy : int; - schedparam : struct_sched_param; - inheritsched : int; - scope : int; - guardsize : size_t; - stackaddr_set : int; - stackaddr : System.Address; - stacksize : size_t; + Data : char_array (1 .. OS_Constants.PTHREAD_ATTR_SIZE); end record; pragma Convention (C, pthread_attr_t); + for pthread_attr_t'Alignment use Interfaces.C.unsigned_long'Alignment; type pthread_condattr_t is record - dummy : int; + Data : char_array (1 .. OS_Constants.PTHREAD_CONDATTR_SIZE); end record; pragma Convention (C, pthread_condattr_t); + for pthread_condattr_t'Alignment use Interfaces.C.int'Alignment; type pthread_mutexattr_t is record - mutexkind : int; - end record; + Data : char_array (1 .. OS_Constants.PTHREAD_MUTEXATTR_SIZE); + end record; pragma Convention (C, pthread_mutexattr_t); + for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment; - type pthread_mutex_t is new System.Linux.pthread_mutex_t; - - type unsigned_long_long_t is mod 2 ** 64; - -- Local type only used to get it's 'Alignment below + type pthread_mutex_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE); + end record; + pragma Convention (C, pthread_mutex_t); + for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment; - type pthread_cond_t is array (0 .. 47) of unsigned_char; + type pthread_cond_t is record + Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE); + end record; pragma Convention (C, pthread_cond_t); for pthread_cond_t'Alignment use unsigned_long_long_t'Alignment; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index 2f0a2f30ff1..dca27fe9c61 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.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- -- @@ -126,8 +126,11 @@ package System.Rident is Immediate_Reclamation, -- (RM H.4(10)) No_Implementation_Attributes, -- Ada 2005 AI-257 + No_Implementation_Identifiers, -- Ada 2012 AI-246 No_Implementation_Pragmas, -- Ada 2005 AI-257 No_Implementation_Restrictions, -- GNAT + No_Implementation_Units, -- Ada 2012 AI-242 + No_Implicit_Aliasing, -- GNAT No_Elaboration_Code, -- GNAT No_Obsolescent_Features, -- Ada 2005 AI-368 No_Wide_Characters, -- GNAT @@ -309,12 +312,21 @@ package System.Rident is -- Profile Definitions and Data -- ---------------------------------- - type Profile_Name is (No_Profile, Ravenscar, Restricted); + -- Note: to add a profile, modify the following declarations appropriately, + -- add Name_xxx to Snames, and add a branch to the conditions for pragmas + -- Profile and Profile_Warnings in the body of Sem_Prag. + + type Profile_Name is + (No_Profile, + No_Implementation_Extensions, + Ravenscar, + Restricted); -- Names of recognized profiles. No_Profile is used to indicate that a -- restriction came from pragma Restrictions[_Warning], as opposed to -- pragma Profile[_Warning]. - subtype Profile_Name_Actual is Profile_Name range Ravenscar .. Restricted; + subtype Profile_Name_Actual is Profile_Name + range No_Implementation_Extensions .. Restricted; -- Actual used profile names type Profile_Data is record @@ -333,9 +345,24 @@ package System.Rident is Profile_Info : constant array (Profile_Name_Actual) of Profile_Data := + (No_Implementation_Extensions => + -- Restrictions for Restricted profile + + (Set => + (No_Implementation_Attributes => True, + No_Implementation_Identifiers => True, + No_Implementation_Pragmas => True, + No_Implementation_Units => True, + others => False), + + -- Value settings for Restricted profile (none + + Value => + (others => 0)), + -- Restricted Profile - (Restricted => + Restricted => -- Restrictions for Restricted profile diff --git a/gcc/ada/s-solita.adb b/gcc/ada/s-solita.adb index aa3c5a8e25e..a222c87f470 100644 --- a/gcc/ada/s-solita.adb +++ b/gcc/ada/s-solita.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, 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- -- @@ -151,8 +151,12 @@ package body System.Soft_Links.Tasking is begin -- We can only be here because we are terminating the environment task. - -- Task termination for the rest of the tasks is handled in the - -- Task_Wrapper. + -- Task termination for all other tasks is handled in the Task_Wrapper. + + -- We do not want to enable this check and e.g. call System.OS_Lib.Abort + -- here because some restricted run-times may not have System.OS_Lib + -- (e.g. JVM), and calling abort may do more harm than good to the + -- main application. pragma Assert (Self_Id = STPO.Environment_Task); @@ -175,9 +179,9 @@ package body System.Soft_Links.Tasking is Ada.Exceptions.Save_Occurrence (EO, Excep); end if; - -- There is no need for explicit protection against race conditions - -- for this part because it can only be executed by the environment - -- task after all the other tasks have been finalized. + -- There is no need for explicit protection against race conditions for + -- this part because it can only be executed by the environment task + -- after all the other tasks have been finalized. if Self_Id.Common.Specific_Handler /= null then Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); @@ -211,8 +215,8 @@ package body System.Soft_Links.Tasking is SSL.Timed_Delay := Timed_Delay_T'Access; SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access; - -- No need to create a new Secondary Stack, since we will use the - -- default one created in s-secsta.adb + -- No need to create a new secondary stack, since we will use the + -- default one created in s-secsta.adb. SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT); SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT); diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index 828c47e6f4e..b8ad53d613b 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -276,9 +276,7 @@ package body System.Storage_Pools.Subpools is -- 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; + Set_Finalize_Address (Master.all, Fin_Address); -- Heterogeneous masters service the following: @@ -286,7 +284,7 @@ package body System.Storage_Pools.Subpools is -- 2) Certain cases of anonymous access types usage else - Set_Finalize_Address (Addr, Fin_Address); + Set_Heterogeneous_Finalize_Address (Addr, Fin_Address); Finalize_Address_Table_In_Use := True; end if; diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb index 14812a4464d..b1e9b640ba8 100644 --- a/gcc/ada/s-taenca.adb +++ b/gcc/ada/s-taenca.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- -- @@ -216,7 +216,7 @@ package body System.Tasking.Entry_Calls is STPO.Unlock_RTS; end if; - Lock_Entries (Test_PO, Ceiling_Violation); + Lock_Entries_With_Status (Test_PO, Ceiling_Violation); -- ??? diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb index 88f4571f61e..f6e9a64cdc7 100644 --- a/gcc/ada/s-taprop-dummy.adb +++ b/gcc/ada/s-taprop-dummy.adb @@ -46,6 +46,13 @@ package body System.Task_Primitives.Operations is pragma Warnings (Off); -- Turn off warnings since so many unreferenced parameters + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + ---------------- -- Abort_Task -- ---------------- @@ -252,15 +259,6 @@ package body System.Task_Primitives.Operations is return 0.0; end Monotonic_Clock; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - --------------- -- Read_Lock -- --------------- diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 6bc89fc087a..346de43ba05 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -39,7 +39,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -130,6 +129,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -696,15 +702,6 @@ package body System.Task_Primitives.Operations is Specific.Set (Self_ID); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -839,12 +836,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -859,11 +851,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index bfa425e9b45..26469049920 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -39,7 +39,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -127,6 +126,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -699,15 +705,6 @@ package body System.Task_Primitives.Operations is end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -901,12 +898,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -921,11 +913,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index 8d381ab9564..84c663a282a 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -38,8 +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_Deallocation; - with Interfaces.C; with System.Task_Info; @@ -137,6 +135,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -731,15 +736,6 @@ package body System.Task_Primitives.Operations is end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -978,12 +974,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -999,11 +990,8 @@ package body System.Task_Primitives.Operations is end if; SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access); - Free (Tmp); - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index ab66a889741..7fc505e30bc 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -38,8 +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_Deallocation; - with Interfaces.C; with Interfaces.C.Strings; @@ -176,6 +174,13 @@ package body System.Task_Primitives.Operations is end Specific; + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -820,15 +825,6 @@ package body System.Task_Primitives.Operations is Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -987,13 +983,8 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Self_ID : Task_Id := T; Result : DWORD; Succeeded : BOOL; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin if not Single_Lock then @@ -1006,7 +997,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - if Self_ID.Common.LL.Thread /= 0 then + if T.Common.LL.Thread /= 0 then -- This task has been activated. Wait for the thread to terminate -- then close it. This is needed to release system resources. @@ -1017,11 +1008,7 @@ package body System.Task_Primitives.Operations is pragma Assert (Succeeded = Win32.TRUE); end if; - Free (Self_ID); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 440d94149b9..eb1b77147ec 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -45,7 +45,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -144,6 +143,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -782,15 +788,6 @@ package body System.Task_Primitives.Operations is end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -1000,12 +997,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -1020,11 +1012,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 421c60e219e..b5fe1ee9d42 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -38,8 +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_Deallocation; - with Interfaces.C; with System.Multiprocessors; @@ -226,6 +224,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -868,26 +873,15 @@ package body System.Task_Primitives.Operations is procedure Enter_Task (Self_ID : Task_Id) is begin Self_ID.Common.LL.Thread := thr_self; - - Self_ID.Common.LL.LWP := lwp_self; + Self_ID.Common.LL.LWP := lwp_self; Set_Task_Affinity (Self_ID); - Specific.Set (Self_ID); -- We need the above code even if we do direct fetch of Task_Id in Self -- for the main task on Sun, x86 Solaris and for gcc 2.7.2. end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -1032,12 +1026,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin T.Common.LL.Thread := Null_Thread_Id; @@ -1054,11 +1043,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index 2fe24419f3d..b0b727d9bb1 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -38,8 +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_Deallocation; - with Interfaces; with Interfaces.C; @@ -127,6 +125,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -695,15 +700,6 @@ package body System.Task_Primitives.Operations is Specific.Set (Self_ID); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -930,12 +926,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -950,11 +941,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index 1cfafbbb55a..92b6023bdff 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -39,7 +39,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -114,6 +113,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -680,15 +686,6 @@ package body System.Task_Primitives.Operations is Specific.Set (Self_ID); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -839,12 +836,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -859,11 +851,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index ae286498d5c..be76162b284 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -39,7 +39,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -125,11 +124,8 @@ package body System.Task_Primitives.Operations is procedure Set (Self_Id : Task_Id); pragma Inline (Set); - -- Set the self id for the current task - - procedure Delete; - pragma Inline (Delete); - -- Delete the task specific data associated with the current task + -- Set the self id for the current task, unless Self_Id is null, in + -- which case the task specific data is deleted. function Self return Task_Id; pragma Inline (Self); @@ -140,6 +136,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -828,15 +831,6 @@ package body System.Task_Primitives.Operations is end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -986,12 +980,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := (T = Self); - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : int; begin if not Single_Lock then @@ -1008,11 +997,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Delete; - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads index feb6f558c1f..12fbd71386e 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -87,9 +87,24 @@ package System.Task_Primitives.Operations is -- The effects of further calls to operations defined below on the task -- are undefined thereafter. - function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id; - pragma Inline (New_ATCB); - -- Allocate a new ATCB with the specified number of entries + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package ATCB_Allocation is + + function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id; + pragma Inline (New_ATCB); + -- Allocate a new ATCB with the specified number of entries + + procedure Free_ATCB (T : ST.Task_Id); + pragma Inline (Free_ATCB); + -- Deallocate an ATCB previously allocated by New_ATCB + + end ATCB_Allocation; + + function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id + renames ATCB_Allocation.New_ATCB; procedure Initialize_TCB (Self_ID : ST.Task_Id; Succeeded : out Boolean); pragma Inline (Initialize_TCB); diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index cacd86c4c22..7203c1ccec2 100644 --- a/gcc/ada/s-tasini.adb +++ b/gcc/ada/s-tasini.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- -- @@ -682,9 +682,7 @@ package body System.Tasking.Initialization is -- between the expander and the run time, we may end up with -- Self_ID.Deferral_Level being equal to zero, when called from -- the procedure created by the expander that corresponds to a - -- task body. - - -- In this case, there's nothing to be done + -- task body. In this case, there's nothing to be done. -- See related code in System.Tasking.Stages.Create_Task resetting -- Deferral_Level when System.Restrictions.Abort_Allowed is False. diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 8b4e61a89c1..d31313708f7 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -1150,6 +1150,12 @@ package System.Tasking is -- -- Protection: Self.L. Once a task has set Self.Stage to Completing, it -- has exclusive access to this field. + + Free_On_Termination : Boolean := False; + -- Deallocate the ATCB when the task terminates. This flag is normally + -- False, and is set True when Unchecked_Deallocation is called on a + -- non-terminated task so that the associated storage is automatically + -- reclaimed when the task terminates. end record; -------------------- diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 0958a8dbf32..4034e61af17 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -628,7 +628,7 @@ package body System.Tasking.Rendezvous is -- Requeue to a protected entry Called_PO := POE.To_Protection (Entry_Call.Called_PO); - STPE.Lock_Entries (Called_PO, Ceiling_Violation); + STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation); if Ceiling_Violation then pragma Assert (Ex = Ada.Exceptions.Null_Id); diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 224b197eaf8..6449bf6b017 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -529,12 +529,15 @@ package body System.Tasking.Stages is if CPU /= Unspecified_CPU and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) - or else CPU > Integer (System.Multiprocessors.CPU_Range'Last) - or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) + or else + CPU > Integer (System.Multiprocessors.CPU_Range'Last) + or else + CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) then raise Tasking_Error with "CPU not in range"; -- Normal CPU affinity + else Base_CPU := (if CPU = Unspecified_CPU @@ -966,12 +969,11 @@ package body System.Tasking.Stages is Free_Entry_Names (T); System.Task_Primitives.Operations.Finalize_TCB (T); - -- If the task is not terminated, then we simply ignore the call. This - -- happens when a user program attempts an unchecked deallocation on - -- a non-terminated task. - else - null; + -- If the task is not terminated, then mark the task as to be freed + -- upon termination. + + T.Free_On_Termination := True; end if; end Free_Task; @@ -1001,8 +1003,8 @@ package body System.Tasking.Stages is Initialization.Defer_Abort (Self_ID); - -- Loop through the From chain, changing their Master_of_Task - -- fields, and to find the end of the chain. + -- Loop through the From chain, changing their Master_of_Task fields, + -- and to find the end of the chain. loop C.Master_of_Task := New_Master; @@ -1088,10 +1090,10 @@ package body System.Tasking.Stages is -- Indicates the reason why this task terminates. Normal corresponds to -- a task terminating due to completing the last statement of its body, -- or as a result of waiting on a terminate alternative. If the task - -- terminates because it is being aborted then Cause will be set to - -- Abnormal. If the task terminates because of an exception raised by - -- the execution of its task body, then Cause is set to - -- Unhandled_Exception. + -- terminates because it is being aborted then Cause will be set + -- to Abnormal. If the task terminates because of an exception + -- raised by the execution of its task body, then Cause is set + -- to Unhandled_Exception. EO : Exception_Occurrence; -- If the task terminates because of an exception raised by the @@ -1172,14 +1174,16 @@ package body System.Tasking.Stages is -- smaller values resulted in segmentation faults from dynamic -- stack analysis. - Big_Overflow_Guard : constant := 16 * 1024; + Big_Overflow_Guard : constant := 64 * 1024 + 8 * 1024; Small_Stack_Limit : constant := 64 * 1024; -- ??? These three values are experimental, and seem to work on -- most platforms. They still need to be analyzed further. They - -- also need documentation, what are they??? + -- also need documentation, what are they and why does the logic + -- differ depending on whether the stack is large or small??? Pattern_Size : Natural := - Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size); + Natural (Self_ID.Common. + Compiler_Data.Pri_Stack_Info.Size); -- Size of the pattern Stack_Base : Address; @@ -1187,6 +1191,7 @@ package body System.Tasking.Stages is begin Stack_Base := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base; + if Stack_Base = Null_Address then -- On many platforms, we don't know the real stack base @@ -1211,6 +1216,7 @@ package body System.Tasking.Stages is else Big_Overflow_Guard); else -- Reduce by the size of the final guard page + Pattern_Size := Pattern_Size - Guard_Page_Size; end if; @@ -1256,8 +1262,7 @@ package body System.Tasking.Stages is end if; if Global_Task_Debug_Event_Set then - Debug.Signal_Debug_Event - (Debug.Debug_Event_Run, Self_ID); + Debug.Signal_Debug_Event (Debug.Debug_Event_Run, Self_ID); end if; begin @@ -1311,6 +1316,7 @@ package body System.Tasking.Stages is (Debug.Debug_Event_Abort_Terminated, Self_ID); end if; end if; + when others => -- ??? Using an E : others here causes CD2C11A to fail on Tru64 @@ -1395,10 +1401,9 @@ package body System.Tasking.Stages is -- Terminate_Task -- -------------------- - -- Before we allow the thread to exit, we must clean up. This is a - -- delicate job. We must wake up the task's master, who may immediately try - -- to deallocate the ATCB out from under the current task WHILE IT IS STILL - -- EXECUTING. + -- Before we allow the thread to exit, we must clean up. This is a delicate + -- job. We must wake up the task's master, who may immediately try to + -- deallocate the ATCB from the current task WHILE IT IS STILL EXECUTING. -- To avoid this, the parent task must be blocked up to the latest -- statement executed. The trouble is that we have another step that we @@ -1423,6 +1428,7 @@ package body System.Tasking.Stages is procedure Terminate_Task (Self_ID : Task_Id) is Environment_Task : constant Task_Id := STPO.Environment_Task; Master_of_Task : Integer; + Deallocate : Boolean; begin Debug.Task_Termination_Hook; @@ -1433,8 +1439,7 @@ package body System.Tasking.Stages is -- Since GCC cannot allocate stack chunks efficiently without reordering -- some of the allocations, we have to handle this unexpected situation - -- here. We should normally never have to call Vulnerable_Complete_Task - -- here. + -- here. Normally we never have to call Vulnerable_Complete_Task here. if Self_ID.Common.Activator /= null then Vulnerable_Complete_Task (Self_ID); @@ -1455,6 +1460,7 @@ package body System.Tasking.Stages is if Single_Lock then Utilities.Independent_Task_Count := Utilities.Independent_Task_Count - 1; + else Write_Lock (Environment_Task); Utilities.Independent_Task_Count := @@ -1468,6 +1474,7 @@ package body System.Tasking.Stages is Stack_Guard (Self_ID, False); Utilities.Make_Passive (Self_ID, Task_Completed => True); + Deallocate := Self_ID.Free_On_Termination; if Single_Lock then Unlock_RTS; @@ -1479,7 +1486,12 @@ package body System.Tasking.Stages is Initialization.Final_Task_Unlock (Self_ID); -- WARNING: past this point, this thread must assume that the ATCB has - -- been deallocated. It should not be accessed again. + -- been deallocated, and can't access it anymore (which is why we have + -- saved the Free_On_Termination flag in a temporary variable). + + if Deallocate then + Free_Task (Self_ID); + end if; if Master_of_Task > 0 then STPO.Exit_Task; @@ -1581,8 +1593,8 @@ package body System.Tasking.Stages is pragma Assert (Self_ID.Common.Activator /= null); - -- Remove dangling reference to Activator, since a task may - -- outlive its activator. + -- Remove dangling reference to Activator, since a task may outlive its + -- activator. Self_ID.Common.Activator := null; @@ -1713,12 +1725,13 @@ package body System.Tasking.Stages is if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then - pragma Assert (C.Common.State = Unactivated); -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task -- = CM. The only case where C is pending activation by this -- task, but the master of C is not CM is in Ada 2005, when C is -- part of a return object of a build-in-place function. + pragma Assert (C.Common.State = Unactivated); + Write_Lock (C); C.Common.Activator := null; C.Common.State := Terminated; @@ -1933,9 +1946,8 @@ package body System.Tasking.Stages is declare Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1; -- Corresponds to the entry index of System.Interrupts. - -- Interrupt_Manager.Detach_Interrupt_Entries. - -- Be sure to update this value when changing - -- Interrupt_Manager specs. + -- Interrupt_Manager.Detach_Interrupt_Entries. Be sure + -- to update this value when changing Interrupt_Manager specs. type Param_Type is access all Task_Id; diff --git a/gcc/ada/s-tpoaal.adb b/gcc/ada/s-tpoaal.adb new file mode 100644 index 00000000000..1d25fb84b62 --- /dev/null +++ b/gcc/ada/s-tpoaal.adb @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.ATCB_ALLOCATION -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +separate (System.Task_Primitives.Operations) +package body ATCB_Allocation is + + --------------- + -- Free_ATCB -- + --------------- + + procedure Free_ATCB (T : Task_Id) is + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if Is_Self then + declare + Local_ATCB : aliased Ada_Task_Control_Block (0); + -- Create a dummy ATCB and initialize it minimally so that "Free" + -- can still call Self and Defer/Undefer_Abort after Tmp is freed + -- by the underlying memory management library. + + begin + Local_ATCB.Common.LL.Thread := T.Common.LL.Thread; + Local_ATCB.Common.Current_Priority := T.Common.Current_Priority; + + Specific.Set (Local_ATCB'Unchecked_Access); + Free (Tmp); + + -- Note: it is assumed here that for all platforms, Specific.Set + -- deletes the task specific information if passed a null value. + + Specific.Set (null); + end; + + else + Free (Tmp); + end if; + end Free_ATCB; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + +end ATCB_Allocation; diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index ba2bf6c267a..88527315e42 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -261,7 +261,22 @@ package body System.Tasking.Protected_Objects.Entries is -- Lock_Entries -- ------------------ - procedure Lock_Entries + procedure Lock_Entries (Object : Protection_Entries_Access) is + Ceiling_Violation : Boolean; + + begin + Lock_Entries_With_Status (Object, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error with "Ceiling Violation"; + end if; + end Lock_Entries; + + ------------------------------ + -- Lock_Entries_With_Status -- + ------------------------------ + + procedure Lock_Entries_With_Status (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is @@ -316,19 +331,7 @@ package body System.Tasking.Protected_Objects.Entries is Self_Id.Common.Protected_Action_Nesting + 1; end; end if; - - end Lock_Entries; - - procedure Lock_Entries (Object : Protection_Entries_Access) is - Ceiling_Violation : Boolean; - - begin - Lock_Entries (Object, Ceiling_Violation); - - if Ceiling_Violation then - raise Program_Error with "Ceiling Violation"; - end if; - end Lock_Entries; + end Lock_Entries_With_Status; ---------------------------- -- Lock_Read_Only_Entries -- diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads index b0be2526c45..ce7045cf56e 100644 --- a/gcc/ada/s-tpoben.ads +++ b/gcc/ada/s-tpoben.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- -- @@ -183,7 +183,7 @@ package System.Tasking.Protected_Objects.Entries is -- Unlock has been made by the caller. Program_Error is raised in case of -- ceiling violation. - procedure Lock_Entries + procedure Lock_Entries_With_Status (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean); -- Same as above, but return the ceiling violation status instead of diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 8aeabc2efbb..171c771ed61 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -568,7 +568,7 @@ package body System.Tasking.Protected_Objects.Operations is -- where abort is already deferred. Initialization.Defer_Abort_Nestable (Self_ID); - Lock_Entries (Object, Ceiling_Violation); + Lock_Entries_With_Status (Object, Ceiling_Violation); if Ceiling_Violation then @@ -722,7 +722,7 @@ package body System.Tasking.Protected_Objects.Operations is -- Requeue is to different PO - Lock_Entries (New_Object, Ceiling_Violation); + Lock_Entries_With_Status (New_Object, Ceiling_Violation); if Ceiling_Violation then Object.Call_In_Progress := null; @@ -966,7 +966,7 @@ package body System.Tasking.Protected_Objects.Operations is end if; Initialization.Defer_Abort_Nestable (Self_Id); - Lock_Entries (Object, Ceiling_Violation); + Lock_Entries_With_Status (Object, Ceiling_Violation); if Ceiling_Violation then Initialization.Undefer_Abort (Self_Id); diff --git a/gcc/ada/s-tpopsp-vxworks.adb b/gcc/ada/s-tpopsp-vxworks.adb index 64bf10c4d94..a926ca445ec 100644 --- a/gcc/ada/s-tpopsp-vxworks.adb +++ b/gcc/ada/s-tpopsp-vxworks.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- -- @@ -44,17 +44,6 @@ package body Specific is -- implementation. This mechanism is used to minimize impact on other -- targets. - ------------ - -- Delete -- - ------------ - - procedure Delete is - Result : STATUS; - begin - Result := taskVarDelete (taskIdSelf, ATCB_Key'Access); - pragma Assert (Result /= ERROR); - end Delete; - ---------------- -- Initialize -- ---------------- @@ -81,6 +70,16 @@ package body Specific is Result : STATUS; begin + -- If argument is null, destroy task specific data, to make API + -- consistent with other platforms, and thus compatible with the + -- shared version of s-tpoaal.adb. + + if Self_Id = null then + Result := taskVarDelete (taskIdSelf, ATCB_Key'Access); + pragma Assert (Result /= ERROR); + return; + end if; + if taskVarGet (0, ATCB_Key'Access) = ERROR then Result := taskVarAdd (0, ATCB_Key'Access); pragma Assert (Result = OK); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 69963e44501..738edda77fd 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -837,7 +837,13 @@ package body Sem_Attr is and then not In_Instance and then not In_Inlined_Body then - Error_Attr_P ("prefix of % attribute must be aliased"); + if Restriction_Check_Required (No_Implicit_Aliasing) then + Error_Attr_P + ("prefix of % attribute must be explicitly aliased"); + else + Error_Attr_P + ("prefix of % attribute must be aliased"); + end if; end if; end Analyze_Access_Attribute; @@ -1900,7 +1906,7 @@ package body Sem_Attr is end if; end Validate_Non_Static_Attribute_Function_Call; - -- Start of processing for Analyze_Attribute + -- Start of processing for Analyze_Attribute begin -- Immediate return if unrecognized attribute (already diagnosed @@ -2221,11 +2227,19 @@ package body Sem_Attr is then Set_Address_Taken (Ent); - -- If we have an address of an object, and the attribute - -- comes from source, then set the object as potentially - -- source modified. We do this because the resulting address - -- can potentially be used to modify the variable and we - -- might not detect this, leading to some junk warnings. + -- Deal with No_Implicit_Aliasing restriction + + if Restriction_Check_Required (No_Implicit_Aliasing) then + if not Is_Aliased_View (P) then + Check_Restriction (No_Implicit_Aliasing, P); + end if; + end if; + + -- If we have an address of an object, and the attribute + -- comes from source, then set the object as potentially + -- source modified. We do this because the resulting address + -- can potentially be used to modify the variable and we + -- might not detect this, leading to some junk warnings. Set_Never_Set_In_Source (Ent, False); @@ -3000,6 +3014,21 @@ package body Sem_Attr is Check_Floating_Point_Type_0; Set_Etype (N, Standard_Boolean); + --------------------- + -- Descriptor_Size -- + --------------------- + + when Attribute_Descriptor_Size => + Check_E0; + + if not Is_Entity_Name (P) + or else not Is_Type (Entity (P)) + then + Error_Attr_P ("prefix of attribute % must denote a type"); + end if; + + Set_Etype (N, Universal_Integer); + ------------ -- Digits -- ------------ @@ -4925,8 +4954,18 @@ package body Sem_Attr is -- all scope checks and checks for aliased views are omitted. when Attribute_Unrestricted_Access => + + -- If from source, deal with relevant restrictions + if Comes_From_Source (N) then Check_Restriction (No_Unchecked_Access, N); + + if Nkind (P) in N_Has_Entity + and then Present (Entity (P)) + and then Is_Object (Entity (P)) + then + Check_Restriction (No_Implicit_Aliasing, N); + end if; end if; if Is_Entity_Name (P) then @@ -5239,6 +5278,9 @@ package body Sem_Attr is -- Computes the Fore value for the current attribute prefix, which is -- known to be a static fixed-point type. Used by Fore and Width. + function Is_VAX_Float (Typ : Entity_Id) return Boolean; + -- Determine whether Typ denotes a VAX floating point type + function Mantissa return Uint; -- Returns the Mantissa value for the prefix type @@ -5369,6 +5411,19 @@ package body Sem_Attr is return R; end Fore_Value; + ------------------ + -- Is_VAX_Float -- + ------------------ + + function Is_VAX_Float (Typ : Entity_Id) return Boolean is + begin + return + Is_Floating_Point_Type (Typ) + and then + (Float_Format = 'V' + or else Float_Rep (Typ) = VAX_Native); + end Is_VAX_Float; + -------------- -- Mantissa -- -------------- @@ -6206,6 +6261,13 @@ package body Sem_Attr is Fold_Uint (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True); + --------------------- + -- Descriptor_Size -- + --------------------- + + when Attribute_Descriptor_Size => + null; + ------------ -- Digits -- ------------ @@ -6316,6 +6378,16 @@ package body Sem_Attr is Fold_Uint (N, Expr_Value (Lo_Bound), Static); end if; + -- Replace VAX Float_Type'First with a reference to the temporary + -- which represents the low bound of the type. This transformation + -- is needed since the back end cannot evaluate 'First on VAX. + + elsif Is_VAX_Float (P_Type) + and then Nkind (Lo_Bound) = N_Identifier + then + Rewrite (N, New_Reference_To (Entity (Lo_Bound), Sloc (N))); + Analyze (N); + else Check_Concurrent_Discriminant (Lo_Bound); end if; @@ -6507,6 +6579,16 @@ package body Sem_Attr is Fold_Uint (N, Expr_Value (Hi_Bound), Static); end if; + -- Replace VAX Float_Type'Last with a reference to the temporary + -- which represents the high bound of the type. This transformation + -- is needed since the back end cannot evaluate 'Last on VAX. + + elsif Is_VAX_Float (P_Type) + and then Nkind (Hi_Bound) = N_Identifier + then + Rewrite (N, New_Reference_To (Entity (Hi_Bound), Sloc (N))); + Analyze (N); + else Check_Concurrent_Discriminant (Hi_Bound); end if; @@ -8892,8 +8974,8 @@ package body Sem_Attr is LB := Make_Attribute_Reference (Loc, Prefix => P, - Attribute_Name => Name_First, - Expressions => (Dims)); + Attribute_Name => Name_First, + Expressions => (Dims)); -- Do not share the dimension indicator, if present. Even -- though it is a static constant, its source location diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 974ff1d9712..3b3453ff11e 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -597,7 +597,7 @@ package body Sem_Aux is ------------------------------- function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is - Btype : constant Entity_Id := Base_Type (Ent); + Btype : constant Entity_Id := Available_View (Base_Type (Ent)); begin if Is_Limited_Record (Btype) then @@ -607,9 +607,8 @@ package body Sem_Aux is and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration then return not In_Package_Body (Scope ((Btype))); - end if; - if Is_Private_Type (Btype) then + elsif Is_Private_Type (Btype) then -- AI05-0063: A type derived from a limited private formal type is -- not immutably limited in a generic body. diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index a0f0a798858..c6f18da4e54 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1650,6 +1650,16 @@ package body Sem_Ch10 is if Present (Library_Unit (N)) then Set_Corresponding_Stub (Unit (Library_Unit (N)), N); + + -- If the subunit has severe errors, the spec of the enclosing + -- body may not be available, in which case do not try analysis. + + if Serious_Errors_Detected > 0 + and then No (Library_Unit (Library_Unit (N))) + then + return; + end if; + Analyze_Subunit (Library_Unit (N)); -- Otherwise we must load the subunit and link to it @@ -1990,6 +2000,16 @@ package body Sem_Ch10 is null; else + -- If a subunits has serious syntax errors, the context + -- may not have been loaded. Add a harmless unit name to + -- attempt processing. + + if Serious_Errors_Detected > 0 + and then No (Entity (Name (Item))) + then + Set_Entity (Name (Item), Standard_Standard); + end if; + Unit_Name := Entity (Name (Item)); while Is_Child_Unit (Unit_Name) loop Set_Is_Visible_Child_Unit (Unit_Name); @@ -2326,6 +2346,10 @@ package body Sem_Ch10 is Intunit : Boolean; -- Set True if the unit currently being compiled is an internal unit + Restriction_Violation : Boolean := False; + -- Set True if a with violates a restriction, no point in giving any + -- warnings if we have this definite error. + Save_Style_Check : constant Boolean := Opt.Style_Check; Save_C_Restrict : Save_Cunit_Boolean_Restrictions; @@ -2348,13 +2372,25 @@ package body Sem_Ch10 is Is_Predefined_File_Name (F, Renamings_Included => False) then Check_Restriction (No_Obsolescent_Features, N); + Restriction_Violation := True; end if; end; end if; + -- Check No_Implementation_Units violation + + if Restriction_Check_Required (No_Implementation_Units) then + if Not_Impl_Defined_Unit (Get_Source_Unit (U)) then + null; + else + Check_Restriction (No_Implementation_Units, Nam); + Restriction_Violation := True; + end if; + end if; + -- Save current restriction set, does not apply to with'ed unit - Save_C_Restrict := Cunit_Boolean_Restrictions_Save; + Save_C_Restrict := Cunit_Boolean_Restrictions_Save; -- Several actions are skipped for dummy packages (those supplied for -- with's where no matching file could be found). Such packages are @@ -2425,12 +2461,14 @@ package body Sem_Ch10 is end if; -- Check for inappropriate with of internal implementation unit if we - -- are not compiling an internal unit. We do not issue this message - -- for implicit with's generated by the compiler itself. + -- are not compiling an internal unit and also check for withing unit + -- in wrong version of Ada. Do not issue these messages for implicit + -- with's generated by the compiler itself. if Implementation_Unit_Warnings and then not Intunit and then not Implicit_With (N) + and then not Restriction_Violation then declare U_Kind : constant Kind_Of_Unit := @@ -2537,7 +2575,7 @@ package body Sem_Ch10 is Change_Selected_Component_To_Expanded_Name (Name (N)); - -- If this is a child unit without a spec, and it has benn analyzed + -- If this is a child unit without a spec, and it has been 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. @@ -5393,6 +5431,7 @@ package body Sem_Ch10 is end if; Set_Non_Limited_View (Lim_Typ, Comp_Typ); + Set_Private_Dependents (Lim_Typ, New_Elmt_List); elsif Nkind_In (Decl, N_Private_Type_Declaration, N_Incomplete_Type_Declaration, @@ -5432,6 +5471,11 @@ package body Sem_Ch10 is Set_Non_Limited_View (Lim_Typ, Comp_Typ); + -- Initialize Private_Depedents, so the field has the proper + -- type, even though the list will remain empty. + + Set_Private_Dependents (Lim_Typ, New_Elmt_List); + elsif Nkind (Decl) = N_Private_Extension_Declaration then Comp_Typ := Defining_Identifier (Decl); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 5ab7783b277..1419b76f41c 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -4430,8 +4430,6 @@ package body Sem_Ch12 is -- for the compilation, we generate the instance body even if it is -- not within the main unit. - -- Any other pragmas might also be inherited ??? - if Is_Intrinsic_Subprogram (Gen_Unit) then Set_Is_Intrinsic_Subprogram (Anon_Id); Set_Is_Intrinsic_Subprogram (Act_Decl_Id); @@ -4441,6 +4439,17 @@ package body Sem_Ch12 is end if; end if; + -- Inherit convention from generic unit. Intrinsic convention, as for + -- an instance of unchecked conversion, is not inherited because an + -- explicit Ada instance has been created. + + if Has_Convention_Pragma (Gen_Unit) + and then Convention (Gen_Unit) /= Convention_Intrinsic + then + Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); + Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit)); + end if; + Generate_Definition (Act_Decl_Id); Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id))); -- ??? needed? Set_Contract (Act_Decl_Id, Make_Contract (Sloc (Act_Decl_Id))); @@ -4479,8 +4488,6 @@ package body Sem_Ch12 is Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); - -- Subject to change, pending on if other pragmas are inherited ??? - Validate_Categorization_Dependency (N, Act_Decl_Id); if not Is_Intrinsic_Subprogram (Act_Decl_Id) then diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 17f49a8ef3a..f5b52d04e0d 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1146,6 +1146,7 @@ package body Sem_Ch13 is New_List (Ent, Relocate_Node (Expr))); Set_From_Aspect_Specification (Aitem, True); + Set_Corresponding_Aspect (Aitem, Aspect); pragma Assert (not Delay_Required); @@ -1181,6 +1182,7 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr)))); Set_From_Aspect_Specification (Aitem, True); + Set_Corresponding_Aspect (Aitem, Aspect); pragma Assert (not Delay_Required); end; @@ -1259,6 +1261,7 @@ package body Sem_Ch13 is end if; Set_From_Aspect_Specification (Aitem, True); + Set_Corresponding_Aspect (Aitem, Aspect); Set_Is_Delayed_Aspect (Aspect); -- For Pre/Post cases, insert immediately after the entity @@ -1289,14 +1292,9 @@ package body Sem_Ch13 is when Aspect_Invariant | Aspect_Type_Invariant => - -- Check placement legality - - if not Nkind_In (N, N_Private_Type_Declaration, - N_Private_Extension_Declaration) - then - Error_Msg_N - ("invariant aspect must apply to a private type", N); - end if; + -- Analysis of the pragma will verify placement legality: + -- an invariant must apply to a private type, or appear in + -- the private part of a spec and apply to a completion. -- Construct the pragma @@ -1321,6 +1319,7 @@ package body Sem_Ch13 is end if; Set_From_Aspect_Specification (Aitem, True); + Set_Corresponding_Aspect (Aitem, Aspect); Set_Is_Delayed_Aspect (Aspect); -- For Invariant case, insert immediately after the entity @@ -1350,14 +1349,7 @@ package body Sem_Ch13 is Make_Identifier (Sloc (Id), Name_Predicate)); Set_From_Aspect_Specification (Aitem, True); - - -- Set special flags for dynamic/static cases - - if A_Id = Aspect_Dynamic_Predicate then - Set_From_Dynamic_Predicate (Aitem); - elsif A_Id = Aspect_Static_Predicate then - Set_From_Static_Predicate (Aitem); - end if; + Set_Corresponding_Aspect (Aitem, Aspect); -- Make sure we have a freeze node (it might otherwise be -- missing in cases like subtype X is Y, and we would not @@ -1431,6 +1423,7 @@ package body Sem_Ch13 is Args); Set_From_Aspect_Specification (Aitem, True); + Set_Corresponding_Aspect (Aitem, Aspect); Set_Is_Delayed_Aspect (Aspect); -- Insert immediately after the entity declaration @@ -1449,6 +1442,11 @@ package body Sem_Ch13 is if Delay_Required then if Present (Aitem) then Set_From_Aspect_Specification (Aitem, True); + + if Nkind (Aitem) = N_Pragma then + Set_Corresponding_Aspect (Aitem, Aspect); + end if; + Set_Is_Delayed_Aspect (Aitem); Set_Aspect_Rep_Item (Aspect, Aitem); end if; @@ -1462,6 +1460,10 @@ package body Sem_Ch13 is else Set_From_Aspect_Specification (Aitem, True); + if Nkind (Aitem) = N_Pragma then + Set_Corresponding_Aspect (Aitem, Aspect); + end if; + -- If this is a compilation unit, we will put the pragma in -- the Pragmas_After list of the N_Compilation_Unit_Aux node. @@ -4739,10 +4741,15 @@ package body Sem_Ch13 is if Nkind (Ritem) = N_Pragma and then Pragma_Name (Ritem) = Name_Predicate then - if From_Dynamic_Predicate (Ritem) then - Dynamic_Predicate_Present := True; - elsif From_Static_Predicate (Ritem) then - Static_Predicate_Present := Ritem; + if Present (Corresponding_Aspect (Ritem)) then + case Chars (Identifier (Corresponding_Aspect (Ritem))) is + when Name_Dynamic_Predicate => + Dynamic_Predicate_Present := True; + when Name_Static_Predicate => + Static_Predicate_Present := Ritem; + when others => + null; + end case; end if; -- Acquire arguments diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 91e30e65d39..8802ae52077 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -772,10 +772,16 @@ package body Sem_Ch3 is Anon_Scope := Scope (Defining_Entity (Related_Nod)); end if; - else - -- For access formals, access components, and access discriminants, - -- the scope is that of the enclosing declaration, + -- For an access type definition, if the current scope is a child + -- unit it is the scope of the type. + + elsif Is_Compilation_Unit (Current_Scope) then + Anon_Scope := Current_Scope; + + -- For access formals, access components, and access discriminants, the + -- scope is that of the enclosing declaration, + else Anon_Scope := Scope (Current_Scope); end if; @@ -815,7 +821,7 @@ package body Sem_Ch3 is Set_Can_Use_Internal_Rep (Anon_Type, not Always_Compatible_Rep_On_Target); - -- If the anonymous access is associated with a protected operation + -- If the anonymous access is associated with a protected operation, -- create a reference to it after the enclosing protected definition -- because the itype will be used in the subsequent bodies. @@ -902,10 +908,10 @@ package body Sem_Ch3 is Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uMaster), - Constant_Present => True, - Object_Definition => + Constant_Present => True, + Object_Definition => New_Reference_To (RTE (RE_Master_Id), Loc), - Expression => + Expression => Make_Explicit_Dereference (Loc, New_Reference_To (RTE (RE_Current_Master), Loc))); @@ -2192,6 +2198,8 @@ package body Sem_Ch3 is Prag := Next_Pragma (Prag); end loop; + Check_Subprogram_Contract (Sent); + Prag := Spec_TC_List (Contract (Sent)); while Present (Prag) loop Analyze_TC_In_Decl_Part (Prag, Sent); @@ -3265,6 +3273,15 @@ package body Sem_Ch3 is if Is_Indefinite_Subtype (T) then + -- In SPARK, a declaration of unconstrained type is allowed + -- only for constants of type string. + + if Is_String_Type (T) and then not Constant_Present (N) then + Check_SPARK_Restriction + ("declaration of object of unconstrained type not allowed", + N); + end if; + -- Nothing to do in deferred constant case if Constant_Present (N) and then No (E) then @@ -3311,9 +3328,12 @@ package body Sem_Ch3 is -- Case of initialization present else - -- Not allowed in Ada 83 + -- Check restrictions in Ada 83 if not Constant_Present (N) then + + -- Unconstrained variables not allowed in Ada 83 mode + if Ada_Version = Ada_83 and then Comes_From_Source (Object_Definition (N)) then @@ -9105,9 +9125,16 @@ package body Sem_Ch3 is begin E := Subp; while Present (Alias (E)) loop - Error_Msg_Sloc := Sloc (E); - Error_Msg_NE - ("\& has been inherited #", T, Subp); + + -- Avoid reporting redundant errors on entities + -- inherited from interfaces + + if Sloc (E) /= Sloc (T) then + Error_Msg_Sloc := Sloc (E); + Error_Msg_NE + ("\& has been inherited #", T, Subp); + end if; + E := Alias (E); end loop; @@ -15039,6 +15066,15 @@ package body Sem_Ch3 is end if; end if; + if Present (Prev) + and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration + and then Present (Premature_Use (Parent (Prev))) + then + Error_Msg_Sloc := Sloc (N); + Error_Msg_N + ("\full declaration #", Premature_Use (Parent (Prev))); + end if; + return New_Id; end if; end Find_Type_Name; @@ -15691,20 +15727,30 @@ package body Sem_Ch3 is ------------------------ procedure Set_Anonymous_Type (Id : Entity_Id) is - Typ : constant Entity_Id := Etype (Old_C); + Old_Typ : constant Entity_Id := Etype (Old_C); begin if Scope (Parent_Base) = Scope (Derived_Base) then - Set_Etype (Id, Typ); + Set_Etype (Id, Old_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. + -- copying it in order to preserve all attributes. else - Set_Etype (Id, New_Copy (Typ)); - Set_Scope (Etype (Id), Current_Scope); + declare + Typ : constant Entity_Id := New_Copy (Old_Typ); + + begin + Set_Etype (Id, Typ); + + -- Since we do not generate component declarations for + -- inherited components, associate the itype with the + -- derived type. + + Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base)); + Set_Scope (Typ, Derived_Base); + end; end if; end Set_Anonymous_Type; @@ -16820,12 +16866,17 @@ package body Sem_Ch3 is -- function calls. The function call may have been given in prefixed -- notation, in which case the original node is an indexed component. -- If the function is parameterless, the original node was an explicit - -- dereference. + -- dereference. The function may also be parameterless, in which case + -- the source node is just an identifier. case Nkind (Original_Node (Exp)) is when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => return True; + when N_Identifier => + return Present (Entity (Original_Node (Exp))) + and then Ekind (Entity (Original_Node (Exp))) = E_Function; + when N_Qualified_Expression => return OK_For_Limited_Init_In_05 diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 3f049643287..8bdc569d1e7 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4322,6 +4322,34 @@ package body Sem_Ch4 is Error_Msg_Node_2 := First_Subtype (Prefix_Type); Error_Msg_NE ("no selector& for}", N, Sel); + -- Add information in the case of an incomplete prefix + + if Is_Incomplete_Type (Type_To_Use) then + declare + Inc : constant Entity_Id := First_Subtype (Type_To_Use); + + begin + if From_With_Type (Scope (Type_To_Use)) then + Error_Msg_NE + ("\limited view of& has no components", N, Inc); + + else + Error_Msg_NE + ("\premature usage of incomplete type&", N, Inc); + + if Nkind (Parent (Inc)) = + N_Incomplete_Type_Declaration + then + -- Record location of premature use in entity so that + -- a continuation message is generated when the + -- completion is seen. + + Set_Premature_Use (Parent (Inc), N); + end if; + end if; + end; + end if; + Check_Misspelled_Selector (Type_To_Use, Sel); end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index e93d00ec6ea..be2237715c6 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -29,6 +29,7 @@ with Checks; use Checks; with Einfo; use Einfo; with Errout; use Errout; with Expander; use Expander; +with Exp_Ch6; use Exp_Ch6; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Lib; use Lib; @@ -44,6 +45,7 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Case; use Sem_Case; with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; with Sem_Elab; use Sem_Elab; @@ -836,10 +838,44 @@ package body Sem_Ch5 is ----------------------------- procedure Analyze_Block_Statement (N : Node_Id) is + procedure Install_Return_Entities (Scop : Entity_Id); + -- Install all entities of return statement scope Scop in the visibility + -- chain except for the return object since its entity is reused in a + -- renaming. + + ----------------------------- + -- Install_Return_Entities -- + ----------------------------- + + procedure Install_Return_Entities (Scop : Entity_Id) is + Id : Entity_Id; + + begin + Id := First_Entity (Scop); + while Present (Id) loop + + -- Do not install the return object + + if not Ekind_In (Id, E_Constant, E_Variable) + or else not Is_Return_Object (Id) + then + Install_Entity (Id); + end if; + + Next_Entity (Id); + end loop; + end Install_Return_Entities; + + -- Local constants and variables + Decls : constant List_Id := Declarations (N); Id : constant Node_Id := Identifier (N); HSS : constant Node_Id := Handled_Statement_Sequence (N); + Is_BIP_Return_Statement : Boolean; + + -- Start of processing for Analyze_Block_Statement + begin -- In SPARK mode, we reject block statements. Note that the case of -- block statements generated by the expander is fine. @@ -855,6 +891,16 @@ package body Sem_Ch5 is return; end if; + -- Detect whether the block is actually a rewritten return statement of + -- a build-in-place function. + + Is_BIP_Return_Statement := + Present (Id) + and then Present (Entity (Id)) + and then Ekind (Entity (Id)) = E_Return_Statement + and then Is_Build_In_Place_Function + (Return_Applies_To (Entity (Id))); + -- Normal processing with HSS present declare @@ -915,6 +961,14 @@ package body Sem_Ch5 is Set_Block_Node (Ent, Identifier (N)); Push_Scope (Ent); + -- The block served as an extended return statement. Ensure that any + -- entities created during the analysis and expansion of the return + -- object declaration are once again visible. + + if Is_BIP_Return_Statement then + Install_Return_Entities (Ent); + end if; + if Present (Decls) then Analyze_Declarations (Decls); Check_Completion; @@ -2261,8 +2315,10 @@ package body Sem_Ch5 is Analyze (Subt); end if; - -- If domain of iteration is an expression, create a declaration for it, - -- so that finalization actions are introduced outside of the loop. + -- If domain of iteration is an expression, create a declaration for + -- it, so that finalization actions are introduced outside of the loop. + -- The declaration must be a renaming because the body of the loop may + -- assign to elements. if not Is_Entity_Name (Iter_Name) then declare @@ -2273,10 +2329,10 @@ package body Sem_Ch5 is Typ := Etype (Iter_Name); Decl := - Make_Object_Declaration (Loc, + Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Id, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Relocate_Node (Iter_Name)); + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => Relocate_Node (Iter_Name)); Insert_Actions (Parent (Parent (N)), New_List (Decl)); Rewrite (Name (N), New_Occurrence_Of (Id, Loc)); @@ -2334,13 +2390,24 @@ package body Sem_Ch5 is if Is_Array_Type (Typ) then if Of_Present (N) then Set_Etype (Def_Id, Component_Type (Typ)); + + -- Here we have a missing Range attribute + else Error_Msg_N - ("to iterate over the elements of an array, use OF", N); + ("missing Range attribute in iteration over an array", N); + + -- In Ada 2012 mode, this may be an attempt at an iterator + + if Ada_Version >= Ada_2012 then + Error_Msg_NE + ("\if& is meant to designate an element of the array, use OF", + N, Def_Id); + end if; -- Prevent cascaded errors - Set_Ekind (Def_Id, E_Constant); + Set_Ekind (Def_Id, E_Loop_Parameter); Set_Etype (Def_Id, Etype (First_Index (Typ))); end if; @@ -2363,6 +2430,21 @@ package body Sem_Ch5 is Entity (Find_Aspect (Typ, Aspect_Iterator_Element))); else + -- For an iteration of the form IN, the name must denote an + -- iterator, typically the result of a call to Iterate. Give a + -- useful error message when the name is a container by itself. + + if Is_Entity_Name (Original_Node (Name (N))) + and then not Is_Iterator (Typ) + then + Error_Msg_N + ("name must be an iterator, not a container", Name (N)); + + Error_Msg_NE + ("\to iterate directly over a container, write `of &`", + Name (N), Original_Node (Name (N))); + end if; + -- The result type of Iterate function is the classwide type of -- the interface parent. We need the specific Cursor type defined -- in the container package. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 7b4bf913ab6..10de0990799 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -181,9 +181,6 @@ package body Sem_Ch6 is -- This procedure makes S, a new overloaded entity, into the first visible -- entity with that name. - procedure Install_Entity (E : Entity_Id); - -- Make single entity visible (used for generic formals as well) - function Is_Non_Overriding_Operation (Prev_E : Entity_Id; New_E : Entity_Id) return Boolean; @@ -1727,6 +1724,11 @@ package body Sem_Ch6 is -- mechanism is used to find the corresponding spec of the primitive -- body. + procedure Exchange_Limited_Views (Subp_Id : Entity_Id); + -- Ada 2012 (AI05-0151): Detect whether the profile of Subp_Id contains + -- incomplete types coming from a limited context and swap their limited + -- views with the non-limited ones. + function Is_Private_Concurrent_Primitive (Subp_Id : Entity_Id) return Boolean; -- Determine whether subprogram Subp_Id is a primitive of a concurrent @@ -2092,6 +2094,65 @@ package body Sem_Ch6 is return Spec_N; end Disambiguate_Spec; + ---------------------------- + -- Exchange_Limited_Views -- + ---------------------------- + + procedure Exchange_Limited_Views (Subp_Id : Entity_Id) is + procedure Detect_And_Exchange (Id : Entity_Id); + -- Determine whether Id's type denotes an incomplete type associated + -- with a limited with clause and exchange the limited view with the + -- non-limited one. + + ------------------------- + -- Detect_And_Exchange -- + ------------------------- + + procedure Detect_And_Exchange (Id : Entity_Id) is + Typ : constant Entity_Id := Etype (Id); + + begin + if Ekind (Typ) = E_Incomplete_Type + and then From_With_Type (Typ) + and then Present (Non_Limited_View (Typ)) + then + Set_Etype (Id, Non_Limited_View (Typ)); + end if; + end Detect_And_Exchange; + + -- Local variables + + Formal : Entity_Id; + + -- Start of processing for Exchange_Limited_Views + + begin + if No (Subp_Id) then + return; + + -- Do not process subprogram bodies as they already use the non- + -- limited view of types. + + elsif not Ekind_In (Subp_Id, E_Function, E_Procedure) then + return; + end if; + + -- Examine all formals and swap views when applicable + + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + Detect_And_Exchange (Formal); + + Next_Formal (Formal); + end loop; + + -- Process the return type of a function + + if Ekind (Subp_Id) = E_Function then + Detect_And_Exchange (Subp_Id); + end if; + end Exchange_Limited_Views; + ------------------------------------- -- Is_Private_Concurrent_Primitive -- ------------------------------------- @@ -2285,7 +2346,12 @@ package body Sem_Ch6 is -- expansion has generated an equivalent type that is used when -- elaborating the body. - if No (Spec_Id) then + -- An exception in the case of Ada2012, AI05-177: The bodies + -- created for expression functions do not freeze. + + if No (Spec_Id) + and then Nkind (Original_Node (N)) /= N_Expression_Function + then Freeze_Before (N, Body_Id); elsif Nkind (Parent (N)) = N_Compilation_Unit then @@ -2712,10 +2778,12 @@ package body Sem_Ch6 is -- for discriminals and privals and finally a declaration for the entry -- family index (if applicable). This form of early expansion is done -- when the Expander is active because Install_Private_Data_Declarations - -- references entities which were created during regular expansion. + -- references entities which were created during regular expansion. The + -- body may be the rewritting of an expression function, and we need to + -- verify that the original node is in the source. if Full_Expander_Active - and then Comes_From_Source (N) + and then Comes_From_Source (Original_Node (N)) and then Present (Prot_Typ) and then Present (Spec_Id) and then not Is_Eliminated (Spec_Id) @@ -2724,6 +2792,15 @@ package body Sem_Ch6 is (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N)); end if; + -- Ada 2012 (AI05-0151): Incomplete types coming from a limited context + -- may now appear in parameter and result profiles. Since the analysis + -- of a subprogram body may use the parameter and result profile of the + -- spec, swap any limited views with their non-limited counterpart. + + if Ada_Version >= Ada_2012 then + Exchange_Limited_Views (Spec_Id); + end if; + -- Analyze the declarations (this call will analyze the precondition -- Check pragmas we prepended to the list, as well as the declaration -- of the _Postconditions procedure). @@ -4956,6 +5033,21 @@ package body Sem_Ch6 is ("subprogram & overrides inherited operation #", Spec, Subp); end if; + -- Special-case to fix a GNAT oddity: Limited_Controlled is declared + -- as an extension of Root_Controlled, and thus has a useless Adjust + -- operation. This operation should not be inherited by other limited + -- controlled types. An explicit Adjust for them is not overriding. + + elsif Must_Override (Spec) + and then Chars (Overridden_Subp) = Name_Adjust + and then Is_Limited_Type (Etype (First_Formal (Subp))) + and then Present (Alias (Overridden_Subp)) + and then + Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Alias (Overridden_Subp)))) + then + Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); + elsif Is_Subprogram (Subp) then if Is_Init_Proc (Subp) then null; @@ -5454,6 +5546,219 @@ package body Sem_Ch6 is end if; end Check_Returns; + ------------------------------- + -- Check_Subprogram_Contract -- + ------------------------------- + + procedure Check_Subprogram_Contract (Spec_Id : Entity_Id) is + + -- Code is currently commented out as, in some cases, it causes crashes + -- because Direct_Primitive_Operations is not available for a private + -- type. This may cause more warnings to be issued than necessary. See + -- below for the intended use of this variable. ??? + +-- Inherited : constant Subprogram_List := +-- Inherited_Subprograms (Spec_Id); +-- -- List of subprograms inherited by this subprogram + + Last_Postcondition : Node_Id := Empty; + -- Last postcondition on the subprogram, or else Empty if either no + -- postcondition or only inherited postconditions. + + Attribute_Result_Mentioned : Boolean := False; + -- Whether attribute 'Result is mentioned in a postcondition + + Post_State_Mentioned : Boolean := False; + -- Whether some expression mentioned in a postcondition can have a + -- different value in the post-state than in the pre-state. + + function Check_Attr_Result (N : Node_Id) return Traverse_Result; + -- Check if N is a reference to the attribute 'Result, and if so set + -- Attribute_Result_Mentioned and return Abandon. Otherwise return OK. + + function Check_Post_State (N : Node_Id) return Traverse_Result; + -- Check whether the value of evaluating N can be different in the + -- post-state, compared to the same evaluation in the pre-state, and + -- if so set Post_State_Mentioned and return Abandon. Return Skip on + -- reference to attribute 'Old, in order to ignore its prefix, which + -- is precisely evaluated in the pre-state. Otherwise return OK. + + procedure Process_Post_Conditions (Spec : Node_Id; Class : Boolean); + -- This processes the Spec_PPC_List from Spec, processing any + -- postconditions from the list. If Class is True, then only + -- postconditions marked with Class_Present are considered. The + -- caller has checked that Spec_PPC_List is non-Empty. + + function Find_Attribute_Result is new Traverse_Func (Check_Attr_Result); + + function Find_Post_State is new Traverse_Func (Check_Post_State); + + ----------------------- + -- Check_Attr_Result -- + ----------------------- + + function Check_Attr_Result (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Attribute_Reference + and then Get_Attribute_Id (Attribute_Name (N)) = Attribute_Result + then + Attribute_Result_Mentioned := True; + return Abandon; + else + return OK; + end if; + end Check_Attr_Result; + + ---------------------- + -- Check_Post_State -- + ---------------------- + + function Check_Post_State (N : Node_Id) return Traverse_Result is + Found : Boolean := False; + + begin + case Nkind (N) is + when N_Function_Call | + N_Explicit_Dereference => + Found := True; + + when N_Identifier | + N_Expanded_Name => + + declare + E : constant Entity_Id := Entity (N); + + begin + -- ???Quantified expressions get analyzed later, so E can + -- be empty at this point. In this case, we suppress the + -- warning, just in case E is assignable. It seems better to + -- have false negatives than false positives. At some point, + -- we should make the warning more accurate, either by + -- analyzing quantified expressions earlier, or moving + -- this processing later. + + if No (E) + or else + (Is_Entity_Name (N) + and then Ekind (E) in Assignable_Kind) + then + Found := True; + end if; + end; + + when N_Attribute_Reference => + case Get_Attribute_Id (Attribute_Name (N)) is + when Attribute_Old => + return Skip; + when Attribute_Result => + Found := True; + when others => + null; + end case; + + when others => + null; + end case; + + if Found then + Post_State_Mentioned := True; + return Abandon; + else + return OK; + end if; + end Check_Post_State; + + ----------------------------- + -- Process_Post_Conditions -- + ----------------------------- + + procedure Process_Post_Conditions + (Spec : Node_Id; + Class : Boolean) + is + Prag : Node_Id; + Arg : Node_Id; + Ignored : Traverse_Final_Result; + pragma Unreferenced (Ignored); + + begin + Prag := Spec_PPC_List (Contract (Spec)); + + loop + Arg := First (Pragma_Argument_Associations (Prag)); + + -- Since pre- and post-conditions are listed in reverse order, the + -- first postcondition in the list is the last in the source. + + if Pragma_Name (Prag) = Name_Postcondition + and then not Class + and then No (Last_Postcondition) + then + Last_Postcondition := Prag; + end if; + + -- For functions, look for presence of 'Result in postcondition + + if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then + Ignored := Find_Attribute_Result (Arg); + end if; + + -- For each individual non-inherited postcondition, look for + -- presence of an expression that could be evaluated differently + -- in post-state. + + if Pragma_Name (Prag) = Name_Postcondition + and then not Class + then + Post_State_Mentioned := False; + Ignored := Find_Post_State (Arg); + + if not Post_State_Mentioned then + Error_Msg_N ("?postcondition refers only to pre-state", + Prag); + end if; + end if; + + Prag := Next_Pragma (Prag); + exit when No (Prag); + end loop; + end Process_Post_Conditions; + + -- Start of processing for Check_Subprogram_Contract + + begin + if not Warn_On_Suspicious_Contract then + return; + end if; + + if Present (Spec_PPC_List (Contract (Spec_Id))) then + Process_Post_Conditions (Spec_Id, Class => False); + end if; + + -- Process inherited postconditions + + -- Code is currently commented out as, in some cases, it causes crashes + -- because Direct_Primitive_Operations is not available for a private + -- type. This may cause more warnings to be issued than necessary. ??? + +-- for J in Inherited'Range loop +-- if Present (Spec_PPC_List (Contract (Inherited (J)))) then +-- Process_Post_Conditions (Inherited (J), Class => True); +-- end if; +-- end loop; + + -- Issue warning for functions whose postcondition does not mention + -- 'Result after all postconditions have been processed. + + if Ekind_In (Spec_Id, E_Function, E_Generic_Function) + and then Present (Last_Postcondition) + and then not Attribute_Result_Mentioned + then + Error_Msg_N ("?function postcondition does not mention result", + Last_Postcondition); + end if; + end Check_Subprogram_Contract; + ---------------------------- -- Check_Subprogram_Order -- ---------------------------- @@ -5461,8 +5766,8 @@ package body Sem_Ch6 is procedure Check_Subprogram_Order (N : Node_Id) is function Subprogram_Name_Greater (S1, S2 : String) return Boolean; - -- This is used to check if S1 > S2 in the sense required by this - -- test, for example nameab < namec, but name2 < name10. + -- This is used to check if S1 > S2 in the sense required by this test, + -- for example nameab < namec, but name2 < name10. ----------------------------- -- Subprogram_Name_Greater -- @@ -5996,7 +6301,7 @@ package body Sem_Ch6 is -- build-in-place formals are needed in some cases (limited 'Input). if Is_Predefined_Internal_Operation (E) then - goto Test_For_BIP_Extras; + goto Test_For_Func_Result_Extras; end if; Formal := First_Formal (E); @@ -6095,7 +6400,15 @@ package body Sem_Ch6 is Next_Formal (Formal); end loop; - <<Test_For_BIP_Extras>> + <<Test_For_Func_Result_Extras>> + + -- Ada 2012 (AI05-234): "the accessibility level of the result of a + -- function call is ... determined by the point of call ...". + + if Needs_Result_Accessibility_Level (E) then + Set_Extra_Accessibility_Of_Result + (E, Add_Extra_Formal (E, Standard_Natural, E, "L")); + end if; -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind. @@ -6137,11 +6450,11 @@ package body Sem_Ch6 is E, BIP_Formal_Suffix (BIP_Finalization_Master)); end if; - -- If the result type contains tasks, we have two extra formals: - -- the master of the tasks to be created, and the caller's - -- activation chain. + -- When the result type contains tasks, add two extra formals: the + -- master of the tasks to be created, and the caller's activation + -- chain. - if Has_Task (Result_Subt) then + if Has_Task (Available_View (Result_Subt)) then Discard := Add_Extra_Formal (E, RTE (RE_Master_Id), diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index 96d967b128d..6d5496c6ae6 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.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- -- @@ -113,6 +113,10 @@ package Sem_Ch6 is -- type-conformant subprogram that becomes hidden by the new subprogram. -- Is_Primitive indicates whether the subprogram is primitive. + procedure Check_Subprogram_Contract (Spec_Id : Entity_Id); + -- Spec_Id is the spec entity for a subprogram. This routine issues + -- warnings on suspicious contracts if Warn_On_Suspicious_Contract is set. + procedure Check_Subtype_Conformant (New_Id : Entity_Id; Old_Id : Entity_Id; @@ -175,6 +179,9 @@ package Sem_Ch6 is -- Determines if two subtype definitions are fully conformant. Used -- for entry family conformance checks (RM 6.3.1 (24)). + procedure Install_Entity (E : Entity_Id); + -- Place a single entity on the visibility chain + procedure Install_Formals (Id : Entity_Id); -- On entry to a subprogram body, make the formals visible. Note that -- simply placing the subprogram on the scope stack is not sufficient: diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 796f9b07f71..6c561dafc71 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1859,9 +1859,12 @@ package body Sem_Ch8 is Statements (Handled_Statement_Sequence (New_Body))); -- The generated body does not freeze. It is analyzed when the - -- generated operation is frozen. + -- generated operation is frozen. This body is only needed if + -- expansion is enabled. - Append_Freeze_Action (Defining_Entity (New_Decl), New_Body); + if Expander_Active then + Append_Freeze_Action (Defining_Entity (New_Decl), New_Body); + end if; Result := Defining_Entity (New_Decl); end if; diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads index 6d02a41b76a..922b282cdfa 100644 --- a/gcc/ada/sem_ch8.ads +++ b/gcc/ada/sem_ch8.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- -- @@ -44,16 +44,16 @@ package Sem_Ch8 is -- Subprograms -- ----------------- - procedure Analyze_Exception_Renaming (N : Node_Id); - procedure Analyze_Expanded_Name (N : Node_Id); - procedure Analyze_Generic_Function_Renaming (N : Node_Id); - procedure Analyze_Generic_Package_Renaming (N : Node_Id); - procedure Analyze_Generic_Procedure_Renaming (N : Node_Id); - procedure Analyze_Object_Renaming (N : Node_Id); - procedure Analyze_Package_Renaming (N : Node_Id); - procedure Analyze_Subprogram_Renaming (N : Node_Id); - procedure Analyze_Use_Package (N : Node_Id); - procedure Analyze_Use_Type (N : Node_Id); + procedure Analyze_Exception_Renaming (N : Node_Id); + procedure Analyze_Expanded_Name (N : Node_Id); + procedure Analyze_Generic_Function_Renaming (N : Node_Id); + procedure Analyze_Generic_Package_Renaming (N : Node_Id); + procedure Analyze_Generic_Procedure_Renaming (N : Node_Id); + procedure Analyze_Object_Renaming (N : Node_Id); + procedure Analyze_Package_Renaming (N : Node_Id); + procedure Analyze_Subprogram_Renaming (N : Node_Id); + procedure Analyze_Use_Package (N : Node_Id); + procedure Analyze_Use_Type (N : Node_Id); procedure End_Scope; -- Called at end of scope. On exit from blocks and bodies (subprogram, @@ -71,19 +71,26 @@ package Sem_Ch8 is procedure End_Use_Package (N : Node_Id); procedure End_Use_Type (N : Node_Id); - -- Subsidiaries of End_Use_Clauses. Also called directly for use clauses + -- Subsidiaries of End_Use_Clauses. Also called directly for use clauses -- appearing in context clauses. procedure Find_Direct_Name (N : Node_Id); -- Given a direct name (Identifier or Operator_Symbol), this routine scans - -- the homonym chain for the name searching for corresponding visible + -- the homonym chain for the name, searching for corresponding visible -- entities to find the referenced entity (or in the case of overloading, - -- entities). On return, the Entity and Etype fields are set. In the - -- non-overloaded case, these are the correct final entries. In the - -- overloaded case, Is_Overloaded is set, Etype and Entity refer to an - -- arbitrary element of the overloads set, and an appropriate list of - -- entries has been made in the overload interpretation table (to be - -- disambiguated in the resolve phase). + -- one candidate interpretation). On return, the Entity and Etype fields + -- are set. In the non-overloaded case, these are the correct entries. + -- In the overloaded case, the flag Is_Overloaded is set, Etype and Entity + -- refer to an arbitrary element of the overloads set, and the appropriate + -- entries have been added to the overloads table entry for the node. The + -- overloading will be disambiguated during type resolution. + -- + -- Note, when this is called during semantic analysis in the overloaded + -- case, the entity set will be the most recently declared homonym. In + -- particular, the caller may follow the homonym chain checking for all + -- entries in the current scope, and that will give all homonyms that are + -- declared before the point of call in the current scope. This is useful + -- for example in the processing for pragma Inline. procedure Find_Selected_Component (N : Node_Id); -- Resolve various cases of selected components, recognize expanded names diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index cdac2f787d3..b4a4c456dc5 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2001,10 +2001,18 @@ package body Sem_Ch9 is -- In the case of an incomplete type, use the full view, unless it's not -- present (as can occur for an incomplete view from a limited with). + -- Initialize the Corresponding_Record_Type (which overlays the Private + -- Dependents field of the incomplete view). - if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then - T := Full_View (T); - Set_Completion_Referenced (T); + if Ekind (T) = E_Incomplete_Type then + if Present (Full_View (T)) then + T := Full_View (T); + Set_Completion_Referenced (T); + + else + Set_Ekind (T, E_Task_Type); + Set_Corresponding_Record_Type (T, Empty); + end if; end if; Set_Ekind (T, E_Task_Type); @@ -2373,7 +2381,7 @@ package body Sem_Ch9 is -- declaration must be limited. if Present (Interface_List (N)) - and then not Is_Limited_Record (Priv_T) + and then not Is_Limited_Type (Priv_T) then Error_Msg_Sloc := Sloc (Priv_T); Error_Msg_N ("(Ada 2005) limited type declaration expected for " & diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index fb20b1a6554..2d80676791c 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -1616,6 +1616,32 @@ package body Sem_Disp is then return Controlling_Argument (Orig_Node); + -- Type conversions are dynamically tagged if the target type, or its + -- designated type, are classwide. An interface conversion expands into + -- a dereference, so test must be performed on the original node. + + elsif Nkind (Orig_Node) = N_Type_Conversion + and then Nkind (N) = N_Explicit_Dereference + and then Is_Controlling_Actual (N) + then + declare + Target_Type : constant Entity_Id := + Entity (Subtype_Mark (Orig_Node)); + + begin + if Is_Class_Wide_Type (Target_Type) then + return N; + + elsif Is_Access_Type (Target_Type) + and then Is_Class_Wide_Type (Designated_Type (Target_Type)) + then + return N; + + else + return Empty; + end if; + end; + -- Normal case elsif Is_Controlling_Actual (N) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 8f5909fdb7f..e3db8077f68 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -39,6 +39,7 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Dist; use Exp_Dist; with Exp_Util; use Exp_Util; +with Freeze; use Freeze; with Lib; use Lib; with Lib.Writ; use Lib.Writ; with Lib.Xref; use Lib.Xref; @@ -261,6 +262,104 @@ package body Sem_Prag is Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); + -- For a class-wide condition, a reference to a controlling formal must + -- be interpreted as having the class-wide type (or an access to such) + -- so that the inherited condition can be properly applied to any + -- overriding operation (see ARM12 6.6.1 (7)). + + if Class_Present (N) then + declare + T : constant Entity_Id := Find_Dispatching_Type (S); + + ACW : Entity_Id := Empty; + -- Access to T'class, created if there is a controlling formal + -- that is an access parameter. + + function Get_ACW return Entity_Id; + -- If the expression has a reference to an controlling access + -- parameter, create an access to T'class for the necessary + -- conversions if one does not exist. + + function Process (N : Node_Id) return Traverse_Result; + -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class + -- aspect for a primitive subprogram of a tagged type T, a name + -- that denotes a formal parameter of type T is interpreted as + -- having type T'Class. Similarly, a name that denotes a formal + -- accessparameter of type access-to-T is interpreted as having + -- type access-to-T'Class. This ensures the expression is well- + -- defined for a primitive subprogram of a type descended from T. + + ------------- + -- Get_ACW -- + ------------- + + function Get_ACW return Entity_Id is + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + + begin + if No (ACW) then + Decl := Make_Full_Type_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'T'), + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Class_Wide_Type (T), Loc), + All_Present => True)); + + Insert_Before (Unit_Declaration_Node (S), Decl); + Analyze (Decl); + ACW := Defining_Identifier (Decl); + Freeze_Before (Unit_Declaration_Node (S), ACW); + end if; + + return ACW; + end Get_ACW; + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + Loc : constant Source_Ptr := Sloc (N); + Typ : Entity_Id; + + begin + if Is_Entity_Name (N) + and then Is_Formal (Entity (N)) + and then Nkind (Parent (N)) /= N_Type_Conversion + then + if Etype (Entity (N)) = T then + Typ := Class_Wide_Type (T); + + elsif Is_Access_Type (Etype (Entity (N))) + and then Designated_Type (Etype (Entity (N))) = T + then + Typ := Get_ACW; + else + Typ := Empty; + end if; + + if Present (Typ) then + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Expression => New_Occurrence_Of (Entity (N), Loc))); + Set_Etype (N, Typ); + end if; + end if; + + return OK; + end Process; + + procedure Replace_Type is new Traverse_Proc (Process); + + begin + Replace_Type (Get_Pragma_Arg (Arg1)); + end; + end if; + -- Remove the subprogram from the scope stack now that the pre-analysis -- of the precondition/postcondition is done. @@ -273,9 +372,13 @@ package body Sem_Prag is procedure Analyze_Pragma (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Pname : constant Name_Id := Pragma_Name (N); Prag_Id : Pragma_Id; + Pname : Name_Id; + -- Name of the source pragma, or name of the corresponding aspect for + -- pragmas which originate in a source aspect. In the latter case, the + -- name may be different from the pragma name. + Pragma_Exit : exception; -- This exception is used to exit pragma processing completely. It is -- used when an error is detected, and no further processing is @@ -953,6 +1056,7 @@ package body Sem_Prag is if Is_Compilation_Unit (Ent) then declare Decl : constant Node_Id := Unit_Declaration_Node (Ent); + begin -- Case of pragma placed immediately after spec @@ -1838,6 +1942,12 @@ package body Sem_Prag is Chain_PPC (PO); return; + elsif Nkind (PO) = N_Subprogram_Declaration + and then In_Instance + then + Chain_PPC (PO); + return; + -- For all other cases of non source code, do nothing else @@ -4780,7 +4890,8 @@ package body Sem_Prag is -- For the pragma case, climb homonym chain. This is -- what implements allowing the pragma in the renaming - -- case, with the result applying to the ancestors. + -- case, with the result applying to the ancestors, and + -- also allows Inline to apply to all previous homonyms. if not From_Aspect_Specification (N) then while Present (Homonym (Subp)) @@ -6064,6 +6175,8 @@ package body Sem_Prag is -- Deal with unrecognized pragma + Pname := Pragma_Name (N); + if not Is_Pragma_Name (Pname) then if Warn_On_Unrecognized_Pragma then Error_Msg_Name_1 := Pname; @@ -6086,6 +6199,10 @@ package body Sem_Prag is Prag_Id := Get_Pragma_Id (Pname); + if Present (Corresponding_Aspect (N)) then + Pname := Chars (Identifier (Corresponding_Aspect (N))); + end if; + -- Preset arguments Arg_Count := 0; @@ -9015,6 +9132,42 @@ package body Sem_Prag is end; end Ident; + ---------------------------- + -- Implementation_Defined -- + ---------------------------- + + -- pragma Implementation_Defined (local_NAME); + + -- Marks previously declared entity as implementation defined. For + -- an overloaded entity, applies to the most recent homonym. + + -- pragma Implementation_Defined; + + -- The form with no arguments appears anywhere within a scope, most + -- typically a package spec, and indicates that all entities that are + -- defined within the package spec are Implementation_Defined. + + when Pragma_Implementation_Defined => Implementation_Defined : declare + Ent : Entity_Id; + + begin + Check_No_Identifiers; + + -- Form with no arguments + + if Arg_Count = 0 then + Set_Is_Implementation_Defined (Current_Scope); + + -- Form with one argument + + else + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + Ent := Entity (Get_Pragma_Arg (Arg1)); + Set_Is_Implementation_Defined (Ent); + end if; + end Implementation_Defined; + ----------------- -- Implemented -- ----------------- @@ -9983,10 +10136,26 @@ package body Sem_Prag is if Typ = Any_Type then return; - elsif not Ekind_In (Typ, E_Private_Type, - E_Record_Type_With_Private, - E_Limited_Private_Type) + -- An invariant must apply to a private type, or appear in the + -- private part of a package spec and apply to a completion. + + elsif Ekind_In (Typ, E_Private_Type, + E_Record_Type_With_Private, + E_Limited_Private_Type) then + null; + + elsif In_Private_Part (Current_Scope) + and then Has_Private_Declaration (Typ) + then + null; + + elsif In_Private_Part (Current_Scope) then + Error_Pragma_Arg + ("pragma% only allowed for private type " & + "declared in visible part", Arg1); + + else Error_Pragma_Arg ("pragma% only allowed for private type", Arg1); end if; @@ -12044,12 +12213,21 @@ package body Sem_Prag is declare Argx : constant Node_Id := Get_Pragma_Arg (Arg1); + begin if Chars (Argx) = Name_Ravenscar then Set_Ravenscar_Profile (N); + elsif Chars (Argx) = Name_Restricted then Set_Profile_Restrictions - (Restricted, N, Warn => Treat_Restrictions_As_Warnings); + (Restricted, + N, Warn => Treat_Restrictions_As_Warnings); + + elsif Chars (Argx) = Name_No_Implementation_Extensions then + Set_Profile_Restrictions + (No_Implementation_Extensions, + N, Warn => Treat_Restrictions_As_Warnings); + else Error_Pragma_Arg ("& is not a valid profile", Argx); end if; @@ -12071,11 +12249,18 @@ package body Sem_Prag is declare Argx : constant Node_Id := Get_Pragma_Arg (Arg1); + begin if Chars (Argx) = Name_Ravenscar then Set_Profile_Restrictions (Ravenscar, N, Warn => True); + elsif Chars (Argx) = Name_Restricted then Set_Profile_Restrictions (Restricted, N, Warn => True); + + elsif Chars (Argx) = Name_No_Implementation_Extensions then + Set_Profile_Restrictions + (No_Implementation_Extensions, N, Warn => True); + else Error_Pragma_Arg ("& is not a valid profile", Argx); end if; @@ -14532,6 +14717,7 @@ package body Sem_Prag is Pragma_Finalize_Storage_Only => 0, Pragma_Float_Representation => 0, Pragma_Ident => -1, + Pragma_Implementation_Defined => -1, Pragma_Implemented => -1, Pragma_Implicit_Packing => 0, Pragma_Import => +2, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3fe07196a45..9ce5282d5b8 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2810,7 +2810,16 @@ package body Sem_Res is -- default expression mode (the Freeze_Expression routine tests this -- flag and only freezes static types if it is set). - Freeze_Expression (N); + -- AI05-177 (Ada2012): Expression functions do not freeze. Only + -- their use (in an expanded call) freezes. + + if Ekind (Current_Scope) /= E_Function + or else + Nkind (Original_Node (Unit_Declaration_Node (Current_Scope))) /= + N_Expression_Function + then + Freeze_Expression (N); + end if; -- Now we can do the expansion @@ -3446,6 +3455,7 @@ package body Sem_Res is and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) then Establish_Transient_Scope (A, False); + Resolve (A, Etype (F)); -- A small optimization: if one of the actuals is a concatenation -- create a block around a procedure call to recover stack space. @@ -7144,6 +7154,8 @@ package body Sem_Res is return Res; end Convert_Operand; + -- Start of processing for Resolve_Intrinsic_Operator + begin -- We must preserve the original entity in a generic setting, so that -- the legality of the operation can be verified in an instance. @@ -7161,13 +7173,17 @@ package body Sem_Res is Set_Entity (N, Op); Set_Is_Overloaded (N, False); - -- If the operand type is private, rewrite with suitable conversions on - -- the operands and the result, to expose the proper underlying numeric - -- type. + -- If the result or operand types are private, rewrite with unchecked + -- conversions on the operands and the result, to expose the proper + -- underlying numeric type. - if Is_Private_Type (Typ) then + if Is_Private_Type (Typ) + or else Is_Private_Type (Etype (Left_Opnd (N))) + or else Is_Private_Type (Etype (Right_Opnd (N))) + then Arg1 := Convert_Operand (Left_Opnd (N)); -- Unchecked_Convert_To (Btyp, Left_Opnd (N)); + -- What on earth is this commented out fragment of code??? if Nkind (N) = N_Op_Expon then Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N)); @@ -7740,7 +7756,7 @@ package body Sem_Res is if Is_Character_Type (Etype (Arg)) then if not Is_Static_Expression (Arg) then Check_SPARK_Restriction - ("character operand for concatenation should be static", N); + ("character operand for concatenation should be static", Arg); end if; elsif Is_String_Type (Etype (Arg)) then @@ -7749,7 +7765,7 @@ package body Sem_Res is and then not Is_Static_Expression (Arg) then Check_SPARK_Restriction - ("string operand for concatenation should be static", N); + ("string operand for concatenation should be static", Arg); end if; -- Do not issue error on an operand that is neither a character nor a diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 2b9d79df1aa..8bbffd93997 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2878,6 +2878,24 @@ package body Sem_Util is function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is E : Entity_Id; Loc : constant Source_Ptr := Sloc (Expr); + + function Make_Level_Literal (Level : Uint) return Node_Id; + -- Construct an integer literal representing an accessibility level + -- with its type set to Natural. + + ------------------------ + -- Make_Level_Literal -- + ------------------------ + + function Make_Level_Literal (Level : Uint) return Node_Id is + Result : constant Node_Id := Make_Integer_Literal (Loc, Level); + begin + Set_Etype (Result, Standard_Natural); + return Result; + end Make_Level_Literal; + + -- Start of processing for Dynamic_Accessibility_Level + begin if Is_Entity_Name (Expr) then E := Entity (Expr); @@ -2893,17 +2911,18 @@ package body Sem_Util is end if; end if; - -- unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? + -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? case Nkind (Expr) is - -- for access discriminant, the level of the enclosing object + + -- 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)); + E_Anonymous_Access_Type + then + return Make_Level_Literal (Object_Access_Level (Expr)); end if; when N_Attribute_Reference => @@ -2912,15 +2931,14 @@ package body Sem_Util is -- For X'Access, the level of the prefix X when Attribute_Access => - return Make_Integer_Literal (Loc, - Object_Access_Level (Prefix (Expr))); + return Make_Level_Literal + (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)); + when Attribute_Unchecked_Access | + Attribute_Unrestricted_Access => + return Make_Level_Literal (Scope_Depth (Standard_Standard)); -- No other access-valued attributes @@ -2929,17 +2947,20 @@ package body Sem_Util is end case; when N_Allocator => - -- Unimplemented: depends on context. As an actual - -- parameter where formal type is anonymous, use + + -- 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. + + -- 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; @@ -2947,7 +2968,7 @@ package body Sem_Util is null; end case; - return Make_Integer_Literal (Loc, Type_Access_Level (Etype (Expr))); + return Make_Level_Literal (Type_Access_Level (Etype (Expr))); end Dynamic_Accessibility_Level; ----------------------------------- @@ -6489,9 +6510,12 @@ package body Sem_Util is begin if Is_Entity_Name (Obj) then - E := Entity (Obj); + if Is_Object (E) and then not Is_Aliased (E) then + Check_Restriction (No_Implicit_Aliasing, Obj); + end if; + return (Is_Object (E) and then @@ -6526,13 +6550,10 @@ package body Sem_Util is return Has_Aliased_Components (Etype (Prefix (Obj))) or else (Is_Access_Type (Etype (Prefix (Obj))) - and then - Has_Aliased_Components - (Designated_Type (Etype (Prefix (Obj))))); + and then Has_Aliased_Components + (Designated_Type (Etype (Prefix (Obj))))); - elsif Nkind (Obj) = N_Unchecked_Type_Conversion - or else Nkind (Obj) = N_Type_Conversion - then + elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then return Is_Tagged_Type (Etype (Obj)) and then Is_Aliased_View (Expression (Obj)); @@ -12118,8 +12139,31 @@ package body Sem_Util is Nod : Node_Id; begin + -- Unconditionally set the entity + Set_Entity (N, Val); + -- Check for No_Implementation_Identifiers + + if Restriction_Check_Required (No_Implementation_Identifiers) then + + -- We have an implementation defined entity if it is marked as + -- implementation defined, or is defined in a package marked as + -- implementation defined. However, library packages themselves + -- are excluded (we don't want to flag Interfaces itself, just + -- the entities within it). + + if (Is_Implementation_Defined (Val) + and then not (Ekind_In (Val, E_Package, E_Generic_Package) + and then Is_Library_Level_Entity (Val))) + or else Is_Implementation_Defined (Scope (Val)) + then + Check_Restriction (No_Implementation_Identifiers, N); + end if; + end if; + + -- Do the style check + if Style_Check and then not Suppress_Style_Checks (Val) and then not In_Instance @@ -12748,6 +12792,9 @@ package body Sem_Util is return Get_Name_String (Name_Standard) & "__" & Get_Name_String (Chars (E)); + elsif Ekind (E) = E_Enumeration_Literal then + return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E)); + else return Get_Scoped_Name (E); end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index fc408b31a4a..55a23109828 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -753,7 +753,8 @@ package Sem_Util is function Is_Aliased_View (Obj : Node_Id) return Boolean; -- Determine if Obj is an aliased view, i.e. the name of an object to which - -- 'Access or 'Unchecked_Access can apply. + -- 'Access or 'Unchecked_Access can apply. Note that the implementation + -- takes the No_Implicit_Aiasing restriction into account. function Is_Ancestor_Package (E1 : Entity_Id; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 67baab977cd..75433470b71 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -590,6 +590,14 @@ package body Sinfo is return Flag14 (N); end Conversion_OK; + function Corresponding_Aspect + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Node3 (N); + end Corresponding_Aspect; + function Corresponding_Body (N : Node_Id) return Node_Id is begin @@ -1337,22 +1345,6 @@ package body Sinfo is return Flag6 (N); end From_Default; - function From_Dynamic_Predicate - (N : Node_Id) return Boolean is - begin - pragma Assert (False - or else NT (N).Nkind = N_Pragma); - return Flag7 (N); - end From_Dynamic_Predicate; - - function From_Static_Predicate - (N : Node_Id) return Boolean is - begin - pragma Assert (False - or else NT (N).Nkind = N_Pragma); - return Flag8 (N); - end From_Static_Predicate; - function Generic_Associations (N : Node_Id) return List_Id is begin @@ -2459,6 +2451,14 @@ package body Sinfo is return Node3 (N); end Prefix; + function Premature_Use + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Incomplete_Type_Declaration); + return Node5 (N); + end Premature_Use; + function Present_Expr (N : Node_Id) return Uint is begin @@ -3650,6 +3650,14 @@ package body Sinfo is Set_Flag14 (N, Val); end Set_Conversion_OK; + procedure Set_Corresponding_Aspect + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Node3 (N, Val); + end Set_Corresponding_Aspect; + procedure Set_Corresponding_Body (N : Node_Id; Val : Node_Id) is begin @@ -4388,22 +4396,6 @@ package body Sinfo is Set_Flag6 (N, Val); end Set_From_Default; - procedure Set_From_Dynamic_Predicate - (N : Node_Id; Val : Boolean := True) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Pragma); - Set_Flag7 (N, Val); - end Set_From_Dynamic_Predicate; - - procedure Set_From_Static_Predicate - (N : Node_Id; Val : Boolean := True) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Pragma); - Set_Flag8 (N, Val); - end Set_From_Static_Predicate; - procedure Set_Generic_Associations (N : Node_Id; Val : List_Id) is begin @@ -5510,6 +5502,14 @@ package body Sinfo is Set_Node3_With_Parent (N, Val); end Set_Prefix; + procedure Set_Premature_Use + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Incomplete_Type_Declaration); + Set_Node5 (N, Val); + end Set_Premature_Use; + procedure Set_Present_Expr (N : Node_Id; Val : Uint) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index af6fab23362..4e239b8203b 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -717,6 +717,10 @@ package Sinfo is -- direct conversion of the underlying integer result, with no regard to -- the small operand. + -- Corresponding_Aspect (Node3-Sem) + -- Present in N_Pragma node. Used to point back to the source aspect from + -- the corresponding pragma. This field is Empty for source pragmas. + -- Corresponding_Body (Node5-Sem) -- This field is set in subprogram declarations, package declarations, -- entry declarations of protected types, and in generic units. It points @@ -1076,14 +1080,6 @@ package Sinfo is -- declaration is treated as an implicit reference to the formal in the -- ali file. - -- From_Dynamic_Predicate (Flag7-Sem) - -- Set for generated pragma Predicate node if this is generated by a - -- Dynamic_Predicate aspect. - - -- From_Static_Predicate (Flag8-Sem) - -- Set for generated pragma Predicate node if this is generated by a - -- Static_Predicate aspect. - -- Generic_Parent (Node5-Sem) -- Generic_Parent is defined on declaration nodes that are instances. The -- value of Generic_Parent is the generic entity from which the instance @@ -1598,6 +1594,12 @@ package Sinfo is -- package specification. This field is Empty for library bodies (the -- parent spec in this case can be found from the corresponding spec). + -- Premature_Use (Node5-Sem) + -- Present in N_Incomplete_Type_Declaration node. Used for improved + -- error diagnostics: if there is a premature usage of an incomplete + -- type, a subsequently generated error message indicates the position + -- of its full declaration. + -- Present_Expr (Uint3-Sem) -- Present in an N_Variant node. This has a meaningful value only after -- Gigi has back annotated the tree with representation information. At @@ -2057,6 +2059,7 @@ package Sinfo is -- Sloc points to PRAGMA -- Next_Pragma (Node1-Sem) -- Pragma_Argument_Associations (List2) (set to No_List if none) + -- Corresponding_Aspect (Node3-Sem) (set to Empty if not present) -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) -- From_Aspect_Specification (Flag13-Sem) @@ -2064,8 +2067,6 @@ package Sinfo is -- Import_Interface_Present (Flag16-Sem) -- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set -- Class_Present (Flag6) set if from Aspect with 'Class - -- From_Dynamic_Predicate (Flag7-Sem) Set if Dynamic_Predicate aspect - -- From_Static_Predicate (Flag8-Sem) Set if Static_Predicate aspect -- Note: we should have a section on what pragmas are passed on to -- the back end to be processed. This section should note that pragma @@ -3091,6 +3092,7 @@ package Sinfo is -- Discriminant_Specifications (List4) (set to No_List if no -- discriminant part, or if the discriminant part is an -- unknown discriminant part) + -- Premature_Use (Node5-Sem) used for improved diagnostics. -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant -- Tagged_Present (Flag15) @@ -8235,6 +8237,9 @@ package Sinfo is function Conversion_OK (N : Node_Id) return Boolean; -- Flag14 + function Corresponding_Aspect + (N : Node_Id) return Node_Id; -- Node3 + function Corresponding_Body (N : Node_Id) return Node_Id; -- Node5 @@ -8457,12 +8462,6 @@ package Sinfo is function From_Default (N : Node_Id) return Boolean; -- Flag6 - function From_Dynamic_Predicate - (N : Node_Id) return Boolean; -- Flag7 - - function From_Static_Predicate - (N : Node_Id) return Boolean; -- Flag8 - function Generic_Associations (N : Node_Id) return List_Id; -- List3 @@ -8814,6 +8813,9 @@ package Sinfo is function Prefix (N : Node_Id) return Node_Id; -- Node3 + function Premature_Use + (N : Node_Id) return Node_Id; -- Node5 + function Present_Expr (N : Node_Id) return Uint; -- Uint3 @@ -9210,6 +9212,9 @@ package Sinfo is procedure Set_Conversion_OK (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Corresponding_Aspect + (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Corresponding_Body (N : Node_Id; Val : Node_Id); -- Node5 @@ -9429,12 +9434,6 @@ package Sinfo is procedure Set_From_Default (N : Node_Id; Val : Boolean := True); -- Flag6 - procedure Set_From_Dynamic_Predicate - (N : Node_Id; Val : Boolean := True); -- Flag7 - - procedure Set_From_Static_Predicate - (N : Node_Id; Val : Boolean := True); -- Flag8 - procedure Set_Generic_Associations (N : Node_Id; Val : List_Id); -- List3 @@ -9786,6 +9785,9 @@ package Sinfo is procedure Set_Prefix (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Premature_Use + (N : Node_Id; Val : Node_Id); -- Node5 + procedure Set_Present_Expr (N : Node_Id; Val : Uint); -- Uint3 @@ -10420,7 +10422,7 @@ package Sinfo is 2 => False, -- unused 3 => False, -- unused 4 => True, -- Discriminant_Specifications (List4) - 5 => False), -- unused + 5 => False), -- Premature_Use N_Explicit_Dereference => (1 => False, -- unused @@ -11800,6 +11802,7 @@ package Sinfo is pragma Inline (Context_Pending); pragma Inline (Controlling_Argument); pragma Inline (Conversion_OK); + pragma Inline (Corresponding_Aspect); pragma Inline (Corresponding_Body); pragma Inline (Corresponding_Formal_Spec); pragma Inline (Corresponding_Generic_Association); @@ -11874,8 +11877,6 @@ package Sinfo is pragma Inline (From_At_End); pragma Inline (From_At_Mod); pragma Inline (From_Default); - pragma Inline (From_Dynamic_Predicate); - pragma Inline (From_Static_Predicate); pragma Inline (Generic_Associations); pragma Inline (Generic_Formal_Declarations); pragma Inline (Generic_Parent); @@ -11993,6 +11994,7 @@ package Sinfo is pragma Inline (Pragmas_After); pragma Inline (Pragmas_Before); pragma Inline (Prefix); + pragma Inline (Premature_Use); pragma Inline (Present_Expr); pragma Inline (Prev_Ids); pragma Inline (Print_In_Hex); @@ -12122,6 +12124,7 @@ package Sinfo is pragma Inline (Set_Context_Pending); pragma Inline (Set_Controlling_Argument); pragma Inline (Set_Conversion_OK); + pragma Inline (Set_Corresponding_Aspect); pragma Inline (Set_Corresponding_Body); pragma Inline (Set_Corresponding_Formal_Spec); pragma Inline (Set_Corresponding_Generic_Association); @@ -12195,8 +12198,6 @@ package Sinfo is pragma Inline (Set_From_At_End); pragma Inline (Set_From_At_Mod); pragma Inline (Set_From_Default); - pragma Inline (Set_From_Dynamic_Predicate); - pragma Inline (Set_From_Static_Predicate); pragma Inline (Set_Generic_Associations); pragma Inline (Set_Generic_Formal_Declarations); pragma Inline (Set_Generic_Parent); @@ -12314,6 +12315,7 @@ package Sinfo is pragma Inline (Set_Pragmas_After); pragma Inline (Set_Pragmas_Before); pragma Inline (Set_Prefix); + pragma Inline (Set_Premature_Use); pragma Inline (Set_Present_Expr); pragma Inline (Set_Prev_Ids); pragma Inline (Set_Print_In_Hex); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 3fa0166b66d..332a7902ff2 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -459,6 +459,7 @@ package Snames is Name_External : constant Name_Id := N + $; -- GNAT Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT Name_Ident : constant Name_Id := N + $; -- VMS + Name_Implementation_Defined : constant Name_Id := N + $; -- GNAT Name_Implemented : constant Name_Id := N + $; -- Ada 12 Name_Import : constant Name_Id := N + $; Name_Import_Exception : constant Name_Id := N + $; -- VMS @@ -659,6 +660,7 @@ package Snames is Name_No_Dependence : constant Name_Id := N + $; Name_No_Dynamic_Attachment : constant Name_Id := N + $; Name_No_Dynamic_Interrupts : constant Name_Id := N + $; + Name_No_Implementation_Extensions : constant Name_Id := N + $; Name_No_Requeue : constant Name_Id := N + $; Name_No_Requeue_Statements : constant Name_Id := N + $; Name_No_Task_Attributes : constant Name_Id := N + $; @@ -742,6 +744,7 @@ package Snames is Name_Definite : constant Name_Id := N + $; Name_Delta : constant Name_Id := N + $; Name_Denorm : constant Name_Id := N + $; + Name_Descriptor_Size : constant Name_Id := N + $; Name_Digits : constant Name_Id := N + $; Name_Elaborated : constant Name_Id := N + $; -- GNAT Name_Emax : constant Name_Id := N + $; -- Ada 83 @@ -1296,6 +1299,7 @@ package Snames is Attribute_Definite, Attribute_Delta, Attribute_Denorm, + Attribute_Descriptor_Size, Attribute_Digits, Attribute_Elaborated, Attribute_Emax, @@ -1612,6 +1616,7 @@ package Snames is Pragma_External, Pragma_Finalize_Storage_Only, Pragma_Ident, + Pragma_Implementation_Defined, Pragma_Implemented, Pragma_Import, Pragma_Import_Exception, diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb index 000f95136c5..f871b19fa1a 100644 --- a/gcc/ada/switch.adb +++ b/gcc/ada/switch.adb @@ -98,6 +98,20 @@ package body Switch is end if; end Check_Version_And_Help_G; + ------------------------------------ + -- Display_Usage_Version_And_Help -- + ------------------------------------ + + procedure Display_Usage_Version_And_Help is + begin + Write_Str (" --version Display version and exit"); + Write_Eol; + + Write_Str (" --help Display usage and exit"); + Write_Eol; + Write_Eol; + end Display_Usage_Version_And_Help; + --------------------- -- Display_Version -- --------------------- diff --git a/gcc/ada/switch.ads b/gcc/ada/switch.ads index ce3b37166eb..b55e2fcf0de 100644 --- a/gcc/ada/switch.ads +++ b/gcc/ada/switch.ads @@ -64,6 +64,9 @@ package Switch is Version_String : String := Gnatvsn.Gnat_Version_String); -- Display version of a tool when switch --version is used + procedure Display_Usage_Version_And_Help; + -- Output the two lines of usage for switches --version and --help + function Is_Switch (Switch_Chars : String) return Boolean; -- Returns True iff Switch_Chars is at least two characters long, and the -- first character is an hyphen ('-'). diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index af05a91199b..696630ec298 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -211,84 +211,10 @@ __gnat_ttyname (int filedes) return NULL; } -/* This function is needed to fix a bug under Win95/98. Under these platforms - doing : - ch1 = getch(); - ch2 = fgetc (stdin); - - will put the same character into ch1 and ch2. It seem that the character - read by getch() is not correctly removed from the buffer. Even a - fflush(stdin) does not fix the bug. This bug does not appear under Window - NT. So we have two version of this routine below one for 95/98 and one for - NT/2000 version of Windows. There is also a special routine (winflushinit) - that will be called only the first time to check which version of Windows - we are running running on to set the right routine to use. - - This problem occurs when using Text_IO.Get_Line after Text_IO.Get_Immediate - for example. - - Calling FlushConsoleInputBuffer just after getch() fix the bug under - 95/98. */ - -#ifdef RTX - -static void winflush_nt (void); - -/* winflush_function will do nothing since we only have problems with Windows - 95/98 which are not supported by RTX. */ - -static void (*winflush_function) (void) = winflush_nt; - -static void -winflush_nt (void) -{ - /* Does nothing as there is no problem under NT. */ -} - -#else /* !RTX */ - -static void winflush_init (void); - -static void winflush_95 (void); - -static void winflush_nt (void); +#ifndef RTX int __gnat_is_windows_xp (void); -/* winflusfunction is set first to the winflushinit function which will check - the OS version 95/98 or NT/2000 */ - -static void (*winflush_function) (void) = winflush_init; - -/* This function does the runtime check of the OS version and then sets - winflush_function to the appropriate function and then call it. */ - -static void -winflush_init (void) -{ - DWORD dwVersion = GetVersion(); - - if (dwVersion < 0x80000000) /* Windows NT/2000 */ - winflush_function = winflush_nt; - else /* Windows 95/98 */ - winflush_function = winflush_95; - - (*winflush_function)(); /* Perform the 'flush' */ - -} - -static void -winflush_95 (void) -{ - FlushConsoleInputBuffer (GetStdHandle (STD_INPUT_HANDLE)); -} - -static void -winflush_nt (void) -{ - /* Does nothing as there is no problem under NT. */ -} - int __gnat_is_windows_xp (void) { @@ -311,7 +237,7 @@ __gnat_is_windows_xp (void) return is_win_xp; } -#endif /* !RTX */ +#endif /* Get the bounds of the stack. The stack pointer is supposed to be initialized to BASE when a thread is created and the stack can be extended @@ -542,7 +468,6 @@ getc_immediate_common (FILE *stream, if (waiting) { *ch = getch (); - (*winflush_function) (); if (*ch == eot_ch) *end_of_file = 1; @@ -559,7 +484,6 @@ getc_immediate_common (FILE *stream, { *avail = 1; *ch = getch (); - (*winflush_function) (); if (*ch == eot_ch) *end_of_file = 1; @@ -987,7 +911,8 @@ __gnat_get_task_options (void) /* Force VX_FP_TASK because it is almost always required */ options |= VX_FP_TASK; -#if defined (__SPE__) && (! defined (__VXWORKSMILS__)) +#if defined (__SPE__) && (! defined (__VXWORKSMILS__)) \ + && (! defined (VTHREADS)) options |= VX_SPE_TASK; #endif diff --git a/gcc/ada/system-darwin-ppc64.ads b/gcc/ada/system-darwin-ppc64.ads new file mode 100644 index 00000000000..6d4c61651d8 --- /dev/null +++ b/gcc/ada/system-darwin-ppc64.ads @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Darwin/PPC64 Version) -- +-- -- +-- Copyright (C) 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/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + type Name is (SYSTEM_NAME_GNAT); + System_Name : constant Name := SYSTEM_NAME_GNAT; + + -- System-Dependent Named Numbers + + Min_Int : constant := Long_Long_Integer'First; + Max_Int : constant := Long_Long_Integer'Last; + + Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; + + Max_Base_Digits : constant := Long_Long_Float'Digits; + Max_Digits : constant := Long_Long_Float'Digits; + + Max_Mantissa : constant := 63; + Fine_Delta : constant := 2.0 ** (-Max_Mantissa); + + Tick : constant := 0.01; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- The values defined here are copied from the ppc version. + + Max_Interrupt_Priority : constant Positive := 63; + Max_Priority : constant Positive := Max_Interrupt_Priority - 1; + + subtype Any_Priority is Integer range 0 .. Max_Interrupt_Priority; + subtype Priority is Any_Priority range 0 .. Max_Priority; + subtype Interrupt_Priority is Any_Priority + range Priority'Last + 1 .. Max_Interrupt_Priority; + + Default_Priority : constant Priority := + (Priority'Last - Priority'First) / 2; + +private + + type Address is mod Memory_Size; + Null_Address : constant Address := 0; + + -------------------------------------- + -- System Implementation Parameters -- + -------------------------------------- + + -- These parameters provide information about the target that is used + -- by the compiler. They are in the private part of System, where they + -- can be accessed using the special circuitry in the Targparm unit + -- whose source should be consulted for more detailed descriptions + -- of the individual switch values. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index eedc715a2e5..a8a200d4486 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -259,7 +259,13 @@ struct layout #define FRAME_OFFSET(FP) 0 #define PC_ADJUST -4 -#define STOP_FRAME(CURRENT, TOP_STACK) ((CURRENT)->next == 0) + +/* According to the base PPC ABI, a toplevel frame entry should feature + a null backchain. What happens at signal handler frontiers isn't so + well specified, so we add a safety guard on top. */ + +#define STOP_FRAME(CURRENT, TOP_STACK) \ + ((CURRENT)->next == 0 || ((long)(CURRENT)->next % __alignof__(void*)) != 0) #define BASE_SKIP 1 diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index a4f0948369a..146b0c043f3 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -484,6 +484,8 @@ begin Write_Line (" .S* turn off warnings for overridden size clause"); Write_Line (" t turn on warnings for tracking deleted code"); Write_Line (" T* turn off warnings for tracking deleted code"); + Write_Line (" .t+ turn on warnings for suspicious contract"); + Write_Line (" .T* turn off warnings for suspicious contract"); Write_Line (" u+ turn on warnings for unused entity"); Write_Line (" U* turn off warnings for unused entity"); Write_Line (" .u turn on warnings for unordered enumeration"); diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index c226f3bf48c..711b9438dbd 100644 --- a/gcc/ada/warnsw.adb +++ b/gcc/ada/warnsw.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. -- -- -- -- GNAT is 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,6 +86,7 @@ package body Warnsw is Warn_On_Record_Holes := True; Warn_On_Redundant_Constructs := True; Warn_On_Reverse_Bit_Order := True; + Warn_On_Suspicious_Contract := True; Warn_On_Unchecked_Conversion := True; Warn_On_Unordered_Enumeration_Type := True; Warn_On_Unrecognized_Pragma := True; @@ -143,6 +144,12 @@ package body Warnsw is when 'S' => Warn_On_Overridden_Size := False; + when 't' => + Warn_On_Suspicious_Contract := True; + + when 'T' => + Warn_On_Suspicious_Contract := False; + when 'u' => Warn_On_Unordered_Enumeration_Type := True; @@ -250,6 +257,7 @@ package body Warnsw is Warn_On_Questionable_Missing_Parens := True; Warn_On_Redundant_Constructs := True; Warn_On_Reverse_Bit_Order := True; + Warn_On_Suspicious_Contract := True; Warn_On_Unchecked_Conversion := True; Warn_On_Unrecognized_Pragma := True; Warn_On_Unrepped_Components := True; @@ -288,6 +296,7 @@ package body Warnsw is Warn_On_Questionable_Missing_Parens := False; Warn_On_Redundant_Constructs := False; Warn_On_Reverse_Bit_Order := False; + Warn_On_Suspicious_Contract := False; Warn_On_Unchecked_Conversion := False; Warn_On_Unordered_Enumeration_Type := False; Warn_On_Unrecognized_Pragma := False; diff --git a/gcc/c-family/ChangeLog b/gcc/c-family/ChangeLog index 44eae081011..347d904205f 100644 --- a/gcc/c-family/ChangeLog +++ b/gcc/c-family/ChangeLog @@ -1,3 +1,14 @@ +2011-09-06 Eric Botcazou <ebotcazou@adacore.com> + + PR middle-end/50266 + * c-common.c (c_fully_fold_internal) <ADDR_EXPR>: Fold offsetof-like + computations. + +2011-09-05 Richard Guenther <rguenther@suse.de> + + * c-common.c (complete_array_type): Use ssize_int (-1) instead + of integer_minus_one_node for empty array upper bounds. + 2011-08-28 Dodji Seketeli <dodji@redhat.com> * c-pch.c (c_common_read_pch): Call linemap_add with LC_ENTER as diff --git a/gcc/c-family/c-common.c b/gcc/c-family/c-common.c index 4cace8d3b14..d8028d34878 100644 --- a/gcc/c-family/c-common.c +++ b/gcc/c-family/c-common.c @@ -1264,7 +1264,20 @@ c_fully_fold_internal (tree expr, bool in_init, bool *maybe_const_operands, STRIP_TYPE_NOPS (op0); if (code != ADDR_EXPR && code != REALPART_EXPR && code != IMAGPART_EXPR) op0 = decl_constant_value_for_optimization (op0); - if (op0 != orig_op0 || in_init) + /* ??? Cope with user tricks that amount to offsetof. The middle-end is + not prepared to deal with them if they occur in initializers. */ + if (op0 != orig_op0 + && code == ADDR_EXPR + && (op1 = get_base_address (op0)) != NULL_TREE + && TREE_CODE (op1) == INDIRECT_REF + && TREE_CONSTANT (TREE_OPERAND (op1, 0))) + { + tree offset = fold_offsetof (op0, op1); + op1 + = fold_convert_loc (loc, TREE_TYPE (expr), TREE_OPERAND (op1, 0)); + ret = fold_build_pointer_plus_loc (loc, op1, offset); + } + else if (op0 != orig_op0 || in_init) ret = in_init ? fold_build1_initializer_loc (loc, code, TREE_TYPE (expr), op0) : fold_build1_loc (loc, code, TREE_TYPE (expr), op0); @@ -8844,7 +8857,7 @@ complete_array_type (tree *ptype, tree initial_value, bool do_default) { if (pedantic) failure = 3; - maxindex = integer_minus_one_node; + maxindex = ssize_int (-1); } else { diff --git a/gcc/cfgexpand.c b/gcc/cfgexpand.c index 03a4409eeda..1495633840b 100644 --- a/gcc/cfgexpand.c +++ b/gcc/cfgexpand.c @@ -271,6 +271,8 @@ add_stack_var (tree decl) if (v->size == 0) v->size = 1; v->alignb = align_local_variable (SSAVAR (decl)); + /* An alignment of zero can mightily confuse us later. */ + gcc_assert (v->alignb != 0); /* All variables are initially in their own partition. */ v->representative = stack_vars_num; diff --git a/gcc/cgraph.c b/gcc/cgraph.c index c37158d20c7..14e7a3b0f08 100644 --- a/gcc/cgraph.c +++ b/gcc/cgraph.c @@ -835,7 +835,7 @@ cgraph_set_call_stmt (struct cgraph_edge *e, gimple new_stmt) struct cgraph_node *new_callee = cgraph_get_node (decl); gcc_checking_assert (new_callee); - cgraph_make_edge_direct (e, new_callee, 0); + cgraph_make_edge_direct (e, new_callee); } push_cfun (DECL_STRUCT_FUNCTION (e->caller->decl)); @@ -1161,11 +1161,9 @@ cgraph_redirect_edge_callee (struct cgraph_edge *e, struct cgraph_node *n) pointer (first parameter) to compensate for skipping a thunk adjustment. */ void -cgraph_make_edge_direct (struct cgraph_edge *edge, struct cgraph_node *callee, - HOST_WIDE_INT delta) +cgraph_make_edge_direct (struct cgraph_edge *edge, struct cgraph_node *callee) { edge->indirect_unknown_callee = 0; - edge->indirect_info->thunk_delta = delta; /* Get the edge out of the indirect edge list. */ if (edge->prev_callee) diff --git a/gcc/cgraph.h b/gcc/cgraph.h index cfc24795917..294fb772a5b 100644 --- a/gcc/cgraph.h +++ b/gcc/cgraph.h @@ -84,10 +84,13 @@ struct GTY(()) cgraph_local_info { /* Set when function is visible by other units. */ unsigned externally_visible : 1; - + /* Set once it has been finalized so we consider it to be output. */ unsigned finalized : 1; + /* False when there is something makes versioning impossible. */ + unsigned versionable : 1; + /* False when function calling convention and signature can not be changed. This is the case when __builtin_apply_args is used. */ unsigned can_change_signature : 1; @@ -314,9 +317,6 @@ struct GTY(()) cgraph_indirect_call_info HOST_WIDE_INT anc_offset; /* OBJ_TYPE_REF_TOKEN of a polymorphic call (if polymorphic is set). */ HOST_WIDE_INT otr_token; - /* Delta by which must be added to this parameter to compensate for a skipped - this adjusting thunk. */ - HOST_WIDE_INT thunk_delta; /* Type of the object from OBJ_TYPE_REF_OBJECT. */ tree otr_type; /* Index of the parameter that is called. */ @@ -507,8 +507,7 @@ struct cgraph_node * cgraph_clone_node (struct cgraph_node *, tree, gcov_type, struct cgraph_node *cgraph_create_function_alias (tree, tree); void cgraph_redirect_edge_callee (struct cgraph_edge *, struct cgraph_node *); -void cgraph_make_edge_direct (struct cgraph_edge *, struct cgraph_node *, - HOST_WIDE_INT); +void cgraph_make_edge_direct (struct cgraph_edge *, struct cgraph_node *); bool cgraph_only_called_directly_p (struct cgraph_node *); struct cgraph_asm_node *cgraph_add_asm_node (tree); diff --git a/gcc/cgraphunit.c b/gcc/cgraphunit.c index f8cbea33292..829bcc72bc0 100644 --- a/gcc/cgraphunit.c +++ b/gcc/cgraphunit.c @@ -2367,7 +2367,6 @@ cgraph_redirect_edge_call_stmt_to_callee (struct cgraph_edge *e) tree decl = gimple_call_fndecl (e->call_stmt); gimple new_stmt; gimple_stmt_iterator gsi; - bool gsi_computed = false; #ifdef ENABLE_CHECKING struct cgraph_node *node; #endif @@ -2398,21 +2397,6 @@ cgraph_redirect_edge_call_stmt_to_callee (struct cgraph_edge *e) } } - if (e->indirect_info && - e->indirect_info->thunk_delta != 0 - && (!e->callee->clone.combined_args_to_skip - || !bitmap_bit_p (e->callee->clone.combined_args_to_skip, 0))) - { - if (cgraph_dump_file) - fprintf (cgraph_dump_file, " Thunk delta is " - HOST_WIDE_INT_PRINT_DEC "\n", e->indirect_info->thunk_delta); - gsi = gsi_for_stmt (e->call_stmt); - gsi_computed = true; - gimple_adjust_this_by_delta (&gsi, - size_int (e->indirect_info->thunk_delta)); - e->indirect_info->thunk_delta = 0; - } - if (e->callee->clone.combined_args_to_skip) { int lp_nr; @@ -2426,8 +2410,7 @@ cgraph_redirect_edge_call_stmt_to_callee (struct cgraph_edge *e) && TREE_CODE (gimple_vdef (new_stmt)) == SSA_NAME) SSA_NAME_DEF_STMT (gimple_vdef (new_stmt)) = new_stmt; - if (!gsi_computed) - gsi = gsi_for_stmt (e->call_stmt); + gsi = gsi_for_stmt (e->call_stmt); gsi_replace (&gsi, new_stmt, false); /* We need to defer cleaning EH info on the new statement to fixup-cfg. We may not have dominator information at this point diff --git a/gcc/config.gcc b/gcc/config.gcc index 81b542c7e4c..e442fa77f9b 100644 --- a/gcc/config.gcc +++ b/gcc/config.gcc @@ -2501,7 +2501,7 @@ sparc*-*-solaris2*) tm_file="sparc/biarch64.h ${tm_file} ${sol2_tm_file} sol2-bi.h" case ${target} in sparc64-*-* | sparcv9-*-*) - tm_file="sparc/sol2-64.h ${tm_file}" + tm_file="sparc/default-64.h ${tm_file}" ;; *) test x$with_cpu != x || with_cpu=v9 @@ -2523,7 +2523,7 @@ sparc64-*-rtems*) tmake_file="${tmake_file} t-rtems" ;; sparc64-*-linux*) - tm_file="sparc/biarch64.h ${tm_file} dbxelf.h elfos.h sparc/sysv4.h gnu-user.h linux.h glibc-stdint.h sparc/linux64.h" + tm_file="sparc/biarch64.h ${tm_file} dbxelf.h elfos.h sparc/sysv4.h gnu-user.h linux.h glibc-stdint.h sparc/default-64.h sparc/linux64.h" extra_options="${extra_options} sparc/long-double-switch.opt" tmake_file="${tmake_file} sparc/t-linux sparc/t-linux64" extra_parts="${extra_parts} crtfastmath.o" @@ -3482,7 +3482,8 @@ case "${target}" in | v8 | supersparc | hypersparc | leon \ | sparclite | f930 | f934 | sparclite86x \ | sparclet | tsc701 \ - | v9 | ultrasparc | ultrasparc3 | niagara | niagara2) + | v9 | ultrasparc | ultrasparc3 | niagara | niagara2 \ + | niagara3 | niagara4) # OK ;; *) diff --git a/gcc/config.host b/gcc/config.host index 61a00b57843..df8ba8fa801 100644 --- a/gcc/config.host +++ b/gcc/config.host @@ -165,6 +165,14 @@ case ${host} in ;; esac ;; + sparc*-*-linux*) + case ${target} in + sparc*-*-linux*) + host_extra_gcc_objs="driver-sparc.o" + host_xmake_file="${host_xmake_file} sparc/x-sparc" + ;; + esac + ;; esac # Machine-specific settings. diff --git a/gcc/config/arm/arm.c b/gcc/config/arm/arm.c index 00479692bd2..0a1a6518a1c 100644 --- a/gcc/config/arm/arm.c +++ b/gcc/config/arm/arm.c @@ -23026,7 +23026,7 @@ arm_array_mode_supported_p (enum machine_mode mode, return false; } -/* Use the option -mvectorize-with-neon-quad to override the use of doubleword +/* Use the option -mvectorize-with-neon-double to override the use of quardword registers when autovectorizing for Neon, at least until multiple vector widths are supported properly by the middle-end. */ @@ -23037,15 +23037,15 @@ arm_preferred_simd_mode (enum machine_mode mode) switch (mode) { case SFmode: - return TARGET_NEON_VECTORIZE_QUAD ? V4SFmode : V2SFmode; + return TARGET_NEON_VECTORIZE_DOUBLE ? V2SFmode : V4SFmode; case SImode: - return TARGET_NEON_VECTORIZE_QUAD ? V4SImode : V2SImode; + return TARGET_NEON_VECTORIZE_DOUBLE ? V2SImode : V4SImode; case HImode: - return TARGET_NEON_VECTORIZE_QUAD ? V8HImode : V4HImode; + return TARGET_NEON_VECTORIZE_DOUBLE ? V4HImode : V8HImode; case QImode: - return TARGET_NEON_VECTORIZE_QUAD ? V16QImode : V8QImode; + return TARGET_NEON_VECTORIZE_DOUBLE ? V8QImode : V16QImode; case DImode: - if (TARGET_NEON_VECTORIZE_QUAD) + if (!TARGET_NEON_VECTORIZE_DOUBLE) return V2DImode; break; @@ -24268,7 +24268,7 @@ arm_expand_sync (enum machine_mode mode, static unsigned int arm_autovectorize_vector_sizes (void) { - return TARGET_NEON_VECTORIZE_QUAD ? 16 | 8 : 0; + return TARGET_NEON_VECTORIZE_DOUBLE ? 0 : (16 | 8); } static bool diff --git a/gcc/config/arm/arm.opt b/gcc/config/arm/arm.opt index be5fd3c5383..4d29e2fb707 100644 --- a/gcc/config/arm/arm.opt +++ b/gcc/config/arm/arm.opt @@ -238,9 +238,13 @@ Target Report RejectNegative Mask(LITTLE_WORDS) Assume big endian bytes, little endian words. This option is deprecated. mvectorize-with-neon-quad -Target Report Mask(NEON_VECTORIZE_QUAD) +Target Report RejectNegative InverseMask(NEON_VECTORIZE_DOUBLE) Use Neon quad-word (rather than double-word) registers for vectorization +mvectorize-with-neon-double +Target Report RejectNegative Mask(NEON_VECTORIZE_DOUBLE) +Use Neon double-word (rather than quad-word) registers for vectorization + mword-relocations Target Report Var(target_word_relocations) Init(TARGET_DEFAULT_WORD_RELOCATIONS) Only generate absolute relocations on word sized values. diff --git a/gcc/config/arm/neon.md b/gcc/config/arm/neon.md index 24dd9419bec..c91b0cdb931 100644 --- a/gcc/config/arm/neon.md +++ b/gcc/config/arm/neon.md @@ -1600,7 +1600,7 @@ ;; where op3 is <, <=, ==, !=, >= or >. Operations are performed ;; element-wise. -(define_expand "vcond<mode>" +(define_expand "vcond<mode><mode>" [(set (match_operand:VDQW 0 "s_register_operand" "") (if_then_else:VDQW (match_operator 3 "arm_comparison_operator" @@ -1680,7 +1680,7 @@ DONE; }) -(define_expand "vcondu<mode>" +(define_expand "vcondu<mode><mode>" [(set (match_operand:VDQIW 0 "s_register_operand" "") (if_then_else:VDQIW (match_operator 3 "arm_comparison_operator" diff --git a/gcc/config/avr/avr.c b/gcc/config/avr/avr.c index d48f722bfae..f158cddefe9 100644 --- a/gcc/config/avr/avr.c +++ b/gcc/config/avr/avr.c @@ -113,6 +113,7 @@ static void avr_function_arg_advance (cumulative_args_t, enum machine_mode, static bool avr_function_ok_for_sibcall (tree, tree); static void avr_asm_named_section (const char *name, unsigned int flags, tree decl); static void avr_encode_section_info (tree, rtx, int); +static section* avr_asm_function_rodata_section (tree); /* Allocate registers from r25 to r8 for parameters for function calls. */ #define FIRST_CUM_REG 26 @@ -135,7 +136,8 @@ const struct base_arch_s *avr_current_arch; /* Current device. */ const struct mcu_type_s *avr_current_device; -section *progmem_section; +/* Section to put switch tables in. */ +static GTY(()) section *progmem_swtable_section; /* To track if code will use .bss and/or .data. */ bool avr_need_clear_bss_p = false; @@ -263,6 +265,8 @@ static const struct attribute_spec avr_attribute_table[] = #undef TARGET_EXPAND_BUILTIN #define TARGET_EXPAND_BUILTIN avr_expand_builtin +#undef TARGET_ASM_FUNCTION_RODATA_SECTION +#define TARGET_ASM_FUNCTION_RODATA_SECTION avr_asm_function_rodata_section struct gcc_target targetm = TARGET_INITIALIZER; @@ -518,6 +522,17 @@ sequent_regs_live (void) for (reg = 0; reg < 18; ++reg) { + if (fixed_regs[reg]) + { + /* Don't recognize sequences that contain global register + variables. */ + + if (live_seq != 0) + return 0; + else + continue; + } + if (!call_used_regs[reg]) { if (df_regs_ever_live_p (reg)) @@ -5036,18 +5051,6 @@ avr_insert_attributes (tree node, tree *attributes) } } -/* A get_unnamed_section callback for switching to progmem_section. */ - -static void -avr_output_progmem_section_asm_op (const void *arg ATTRIBUTE_UNUSED) -{ - fprintf (asm_out_file, - "\t.section .progmem.gcc_sw_table, \"%s\", @progbits\n", - AVR_HAVE_JMP_CALL ? "a" : "ax"); - /* Should already be aligned, this is just to be safe if it isn't. */ - fprintf (asm_out_file, "\t.p2align 1\n"); -} - /* Implement `ASM_OUTPUT_ALIGNED_DECL_LOCAL'. */ /* Implement `ASM_OUTPUT_ALIGNED_DECL_COMMON'. */ @@ -5098,9 +5101,23 @@ avr_output_bss_section_asm_op (const void *data) static void avr_asm_init_sections (void) { - progmem_section = get_unnamed_section (AVR_HAVE_JMP_CALL ? 0 : SECTION_CODE, - avr_output_progmem_section_asm_op, - NULL); + /* Set up a section for jump tables. Alignment is handled by + ASM_OUTPUT_BEFORE_CASE_LABEL. */ + + if (AVR_HAVE_JMP_CALL) + { + progmem_swtable_section + = get_unnamed_section (0, output_section_asm_op, + "\t.section\t.progmem.gcc_sw_table" + ",\"a\",@progbits"); + } + else + { + progmem_swtable_section + = get_unnamed_section (SECTION_CODE, output_section_asm_op, + "\t.section\t.progmem.gcc_sw_table" + ",\"ax\",@progbits"); + } /* Override section callbacks to keep track of `avr_need_clear_bss_p' resp. `avr_need_copy_data_p'. */ @@ -5111,6 +5128,69 @@ avr_asm_init_sections (void) } +/* Implement `TARGET_ASM_FUNCTION_RODATA_SECTION'. */ + +static section* +avr_asm_function_rodata_section (tree decl) +{ + /* If a function is unused and optimized out by -ffunction-sections + and --gc-sections, ensure that the same will happen for its jump + tables by putting them into individual sections. */ + + unsigned int flags; + section * frodata; + + /* Get the frodata section from the default function in varasm.c + but treat function-associated data-like jump tables as code + rather than as user defined data. AVR has no constant pools. */ + { + int fdata = flag_data_sections; + + flag_data_sections = flag_function_sections; + frodata = default_function_rodata_section (decl); + flag_data_sections = fdata; + flags = frodata->common.flags; + } + + if (frodata != readonly_data_section + && flags & SECTION_NAMED) + { + /* Adjust section flags and replace section name prefix. */ + + unsigned int i; + + static const char* const prefix[] = + { + ".rodata", ".progmem.gcc_sw_table", + ".gnu.linkonce.r.", ".gnu.linkonce.t." + }; + + for (i = 0; i < sizeof (prefix) / sizeof (*prefix); i += 2) + { + const char * old_prefix = prefix[i]; + const char * new_prefix = prefix[i+1]; + const char * name = frodata->named.name; + + if (STR_PREFIX_P (name, old_prefix)) + { + char *rname = (char*) alloca (1 + strlen (name) + + strlen (new_prefix) + - strlen (old_prefix)); + + strcat (stpcpy (rname, new_prefix), name + strlen (old_prefix)); + + flags &= ~SECTION_CODE; + flags |= AVR_HAVE_JMP_CALL ? 0 : SECTION_CODE; + + return get_section (rname, flags, frodata->named.decl); + } + } + } + + return progmem_swtable_section; +} + + /* Implement `TARGET_ASM_NAMED_SECTION'. */ /* Track need of __do_clear_bss, __do_copy_data for named sections. */ @@ -6693,7 +6773,6 @@ avr_output_bld (rtx operands[], int bit_nr) void avr_output_addr_vec_elt (FILE *stream, int value) { - switch_to_section (progmem_section); if (AVR_HAVE_JMP_CALL) fprintf (stream, "\t.word gs(.L%d)\n", value); else diff --git a/gcc/config/avr/avr.h b/gcc/config/avr/avr.h index 2af94030f59..dbb0b4c207a 100644 --- a/gcc/config/avr/avr.h +++ b/gcc/config/avr/avr.h @@ -127,10 +127,6 @@ extern const struct base_arch_s avr_arch_types[]; #define TARGET_CPU_CPP_BUILTINS() avr_cpu_cpp_builtins (pfile) -#if !defined(IN_LIBGCC2) && !defined(IN_TARGET_LIBS) -extern GTY(()) section *progmem_section; -#endif - #define AVR_HAVE_JMP_CALL (avr_current_arch->have_jmp_call && !TARGET_SHORT_CALLS) #define AVR_HAVE_MUL (avr_current_arch->have_mul) #define AVR_HAVE_MOVW (avr_current_arch->have_movw_lpmx) diff --git a/gcc/config/avr/elf.h b/gcc/config/avr/elf.h index f360e882a96..ebda5dd11e0 100644 --- a/gcc/config/avr/elf.h +++ b/gcc/config/avr/elf.h @@ -37,9 +37,10 @@ #define ASM_DECLARE_FUNCTION_NAME(FILE, NAME, DECL) \ avr_asm_declare_function_name ((FILE), (NAME), (DECL)) +/* Output alignment 2**1 for jump tables. */ #undef ASM_OUTPUT_BEFORE_CASE_LABEL #define ASM_OUTPUT_BEFORE_CASE_LABEL(FILE, PREFIX, NUM, TABLE) \ - switch_to_section (progmem_section); + fprintf (FILE, "\t.p2align\t1\n"); /* Be conservative in crtstuff.c. */ #undef INIT_SECTION_ASM_OP diff --git a/gcc/config/c6x/c6x-sched.md b/gcc/config/c6x/c6x-sched.md index 6cb4b66acd5..dc8e39cf452 100644 --- a/gcc/config/c6x/c6x-sched.md +++ b/gcc/config/c6x/c6x-sched.md @@ -183,14 +183,14 @@ (and (eq_attr "cross" "n") (and (eq_attr "units" "ls") (eq_attr "dest_regfile" "a")))) - "(s1,nothing*2,s1w)|(l1,nothing*2,l1w)") + "(fps1+s1,nothing*2,s1w)|(fpl1+l1,nothing*2,l1w)") (define_insn_reservation "adddp_ls1n" 7 (and (eq_attr "type" "adddp") (and (eq_attr "cross" "n") (and (eq_attr "units" "ls") (eq_attr "dest_regfile" "a")))) - "((s1)*2,nothing*3,s1w*2)|((l1)*2,nothing*3,l1w*2)") + "(adddps1+(s1)*2,nothing*3,s1w*2)|(adddpl1+(l1)*2,nothing*3,l1w*2)") (define_insn_reservation "single_dls1n" 1 (and (eq_attr "type" "single") @@ -416,14 +416,14 @@ (and (eq_attr "cross" "n") (and (eq_attr "units" "ls") (eq_attr "dest_regfile" "b")))) - "(s2,nothing*2,s2w)|(l2,nothing*2,l2w)") + "(fps2+s2,nothing*2,s2w)|(fpl2+l2,nothing*2,l2w)") (define_insn_reservation "adddp_ls2n" 7 (and (eq_attr "type" "adddp") (and (eq_attr "cross" "n") (and (eq_attr "units" "ls") (eq_attr "dest_regfile" "b")))) - "((s2)*2,nothing*3,s2w*2)|((l2)*2,nothing*3,l2w*2)") + "(adddps2+(s2)*2,nothing*3,s2w*2)|(adddpl2+(l2)*2,nothing*3,l2w*2)") (define_insn_reservation "single_dls2n" 1 (and (eq_attr "type" "single") @@ -649,14 +649,14 @@ (and (eq_attr "cross" "y") (and (eq_attr "units" "ls") (eq_attr "dest_regfile" "a")))) - "(s1+x1,nothing*2,s1w)|(l1+x1,nothing*2,l1w)") + "(fps1+s1+x1,nothing*2,s1w)|(fpl1+l1+x1,nothing*2,l1w)") (define_insn_reservation "adddp_ls1y" 7 (and (eq_attr "type" "adddp") (and (eq_attr "cross" "y") (and (eq_attr "units" "ls") (eq_attr "dest_regfile" "a")))) - "((s1+x1)*2,nothing*3,s1w*2)|((l1+x1)*2,nothing*3,l1w*2)") + "(adddps1+(s1+x1)*2,nothing*3,s1w*2)|(adddpl1+(l1+x1)*2,nothing*3,l1w*2)") (define_insn_reservation "single_dls1y" 1 (and (eq_attr "type" "single") @@ -882,14 +882,14 @@ (and (eq_attr "cross" "y") (and (eq_attr "units" "ls") (eq_attr "dest_regfile" "b")))) - "(s2+x2,nothing*2,s2w)|(l2+x2,nothing*2,l2w)") + "(fps2+s2+x2,nothing*2,s2w)|(fpl2+l2+x2,nothing*2,l2w)") (define_insn_reservation "adddp_ls2y" 7 (and (eq_attr "type" "adddp") (and (eq_attr "cross" "y") (and (eq_attr "units" "ls") (eq_attr "dest_regfile" "b")))) - "((s2+x2)*2,nothing*3,s2w*2)|((l2+x2)*2,nothing*3,l2w*2)") + "(adddps2+(s2+x2)*2,nothing*3,s2w*2)|(adddpl2+(l2+x2)*2,nothing*3,l2w*2)") (define_insn_reservation "single_dls2y" 1 (and (eq_attr "type" "single") diff --git a/gcc/config/c6x/c6x-sched.md.in b/gcc/config/c6x/c6x-sched.md.in index 271109b9cf5..0ba71433878 100644 --- a/gcc/config/c6x/c6x-sched.md.in +++ b/gcc/config/c6x/c6x-sched.md.in @@ -178,14 +178,14 @@ (and (eq_attr "cross" "_CROSS_") (and (eq_attr "units" "ls") (eq_attr "dest_regfile" "_RF_")))) - "(s_N__CUNIT_,nothing*2,s_N_w)|(l_N__CUNIT_,nothing*2,l_N_w)") + "(fps_N_+s_N__CUNIT_,nothing*2,s_N_w)|(fpl_N_+l_N__CUNIT_,nothing*2,l_N_w)") (define_insn_reservation "adddp_ls_N__CROSS_" 7 (and (eq_attr "type" "adddp") (and (eq_attr "cross" "_CROSS_") (and (eq_attr "units" "ls") (eq_attr "dest_regfile" "_RF_")))) - "((s_N__CUNIT_)*2,nothing*3,s_N_w*2)|((l_N__CUNIT_)*2,nothing*3,l_N_w*2)") + "(adddps_N_+(s_N__CUNIT_)*2,nothing*3,s_N_w*2)|(adddpl_N_+(l_N__CUNIT_)*2,nothing*3,l_N_w*2)") (define_insn_reservation "single_dls_N__CROSS_" 1 (and (eq_attr "type" "single") diff --git a/gcc/config/c6x/c6x.c b/gcc/config/c6x/c6x.c index e77ed70fd35..fd72babd2ae 100644 --- a/gcc/config/c6x/c6x.c +++ b/gcc/config/c6x/c6x.c @@ -111,6 +111,10 @@ typedef struct rtx new_cond; /* True for the first insn that was scheduled in an ebb. */ bool ebb_start; + /* The scheduler state after the insn, transformed into a mask of UNIT_QID + bits rather than storing the state. Meaningful only for the last + insn in a cycle. */ + unsigned int unit_mask; } c6x_sched_insn_info; DEF_VEC_O(c6x_sched_insn_info); @@ -124,13 +128,6 @@ static VEC(c6x_sched_insn_info, heap) *insn_info; static bool done_cfi_sections; -/* The DFA names of the units, in packet order. */ -static const char *const c6x_unit_names[] = -{ - "d1", "l1", "s1", "m1", - "d2", "l2", "s2", "m2", -}; - #define RESERVATION_FLAG_D 1 #define RESERVATION_FLAG_L 2 #define RESERVATION_FLAG_S 4 @@ -140,8 +137,29 @@ static const char *const c6x_unit_names[] = #define RESERVATION_FLAG_LS (RESERVATION_FLAG_L | RESERVATION_FLAG_S) #define RESERVATION_FLAG_DLS (RESERVATION_FLAG_D | RESERVATION_FLAG_LS) +/* The DFA names of the units. */ +static const char *const c6x_unit_names[] = +{ + "d1", "l1", "s1", "m1", "fps1", "fpl1", "adddps1", "adddpl1", + "d2", "l2", "s2", "m2", "fps2", "fpl2", "adddps2", "adddpl2" +}; + +/* The DFA unit number for each unit in c6x_unit_names[]. */ +static int c6x_unit_codes[ARRAY_SIZE (c6x_unit_names)]; + +/* Unit query IDs. */ +#define UNIT_QID_D1 0 +#define UNIT_QID_L1 1 +#define UNIT_QID_S1 2 +#define UNIT_QID_M1 3 +#define UNIT_QID_FPS1 4 +#define UNIT_QID_FPL1 5 +#define UNIT_QID_ADDDPS1 6 +#define UNIT_QID_ADDDPL1 7 +#define UNIT_QID_SIDE_OFFSET 8 + #define RESERVATION_S1 2 -#define RESERVATION_S2 6 +#define RESERVATION_S2 10 /* Register map for debugging. */ int const dbx_register_map[FIRST_PSEUDO_REGISTER] = @@ -169,6 +187,8 @@ c6x_init_machine_status (void) static void c6x_option_override (void) { + unsigned i; + if (global_options_set.x_c6x_arch_option) { c6x_arch = all_isas[c6x_arch_option].type; @@ -184,6 +204,9 @@ c6x_option_override (void) init_machine_status = c6x_init_machine_status; + for (i = 0; i < ARRAY_SIZE (c6x_unit_names); i++) + c6x_unit_codes[i] = get_cpu_unit_code (c6x_unit_names[i]); + if (flag_pic && !TARGET_DSBT) { error ("-fpic and -fPIC not supported without -mdsbt on this target"); @@ -2990,16 +3013,56 @@ assign_reservations (rtx head, rtx end) rtx insn; for (insn = head; insn != NEXT_INSN (end); insn = NEXT_INSN (insn)) { - rtx within; + unsigned int sched_mask, reserved; + rtx within, last; int pass; int rsrv[2]; int rsrv_count[2][4]; + int i; if (GET_MODE (insn) != TImode) continue; - rsrv[0] = rsrv[1] = 0; + reserved = 0; + last = NULL_RTX; + /* Find the last insn in the packet. It has a state recorded for it, + which we can use to determine the units we should be using. */ + for (within = insn; + (within != NEXT_INSN (end) + && (within == insn || GET_MODE (within) != TImode)); + within = NEXT_INSN (within)) + { + int icode; + if (!NONDEBUG_INSN_P (within)) + continue; + icode = recog_memoized (within); + if (icode < 0) + continue; + if (shadow_p (within)) + continue; + if (INSN_INFO_ENTRY (INSN_UID (within)).reservation != 0) + reserved |= 1 << INSN_INFO_ENTRY (INSN_UID (within)).reservation; + last = within; + } + if (last == NULL_RTX) + continue; + + sched_mask = INSN_INFO_ENTRY (INSN_UID (last)).unit_mask; + sched_mask &= ~reserved; + memset (rsrv_count, 0, sizeof rsrv_count); + rsrv[0] = rsrv[1] = ~0; + for (i = 0; i < 8; i++) + { + int side = i / 4; + int unit = i & 3; + unsigned unit_bit = 1 << (unit + side * UNIT_QID_SIDE_OFFSET); + /* Clear the bits which we expect to reserve in the following loop, + leaving the ones set which aren't present in the scheduler's + state and shouldn't be reserved. */ + if (sched_mask & unit_bit) + rsrv[i / 4] &= ~(1 << unit); + } /* Walk through the insns that occur in the same cycle. We use multiple passes to assign units, assigning for insns with the most specific @@ -3010,9 +3073,11 @@ assign_reservations (rtx head, rtx end) && (within == insn || GET_MODE (within) != TImode)); within = NEXT_INSN (within)) { + int uid = INSN_UID (within); int this_rsrv, side; int icode; enum attr_units units; + enum attr_type type; int j; if (!NONDEBUG_INSN_P (within)) @@ -3020,17 +3085,44 @@ assign_reservations (rtx head, rtx end) icode = recog_memoized (within); if (icode < 0) continue; + if (INSN_INFO_ENTRY (uid).reservation != 0) + continue; units = get_attr_units (within); + type = get_attr_type (within); this_rsrv = get_reservation_flags (units); if (this_rsrv == 0) continue; side = get_insn_side (within, units); + /* Certain floating point instructions are treated specially. If + an insn can choose between units it can reserve, and its + reservation spans more than one cycle, the reservation contains + special markers in the first cycle to help us reconstruct what + the automaton chose. */ + if ((type == TYPE_ADDDP || type == TYPE_FP4) + && units == UNITS_LS) + { + int test1_code = ((type == TYPE_FP4 ? UNIT_QID_FPL1 : UNIT_QID_ADDDPL1) + + side * UNIT_QID_SIDE_OFFSET); + int test2_code = ((type == TYPE_FP4 ? UNIT_QID_FPS1 : UNIT_QID_ADDDPS1) + + side * UNIT_QID_SIDE_OFFSET); + if ((sched_mask & (1 << test1_code)) != 0) + { + this_rsrv = RESERVATION_FLAG_L; + sched_mask &= ~(1 << test1_code); + } + else if ((sched_mask & (1 << test2_code)) != 0) + { + this_rsrv = RESERVATION_FLAG_S; + sched_mask &= ~(1 << test2_code); + } + } + if ((this_rsrv & (this_rsrv - 1)) == 0) { - int t = exact_log2 (this_rsrv) + side * 4; + int t = exact_log2 (this_rsrv) + side * UNIT_QID_SIDE_OFFSET; rsrv[side] |= this_rsrv; - INSN_INFO_ENTRY (INSN_UID (within)).reservation = t; + INSN_INFO_ENTRY (uid).reservation = t; continue; } @@ -3059,8 +3151,8 @@ assign_reservations (rtx head, rtx end) if ((this_rsrv & (1 << j)) && j != best) rsrv_count[side][j]--; - INSN_INFO_ENTRY (INSN_UID (within)).reservation - = best + side * 4; + INSN_INFO_ENTRY (uid).reservation + = best + side * UNIT_QID_SIDE_OFFSET; } } } @@ -3098,6 +3190,12 @@ typedef struct c6x_sched_context /* The following variable value is the last issued insn. */ rtx last_scheduled_insn; + /* The following variable value is DFA state before issuing the + first insn in the current clock cycle. We do not use this member + of the structure directly; we copy the data in and out of + prev_cycle_state. */ + state_t prev_cycle_state_ctx; + int reg_n_accesses[FIRST_PSEUDO_REGISTER]; int reg_n_xaccesses[FIRST_PSEUDO_REGISTER]; int reg_set_in_cycle[FIRST_PSEUDO_REGISTER]; @@ -3109,6 +3207,11 @@ typedef struct c6x_sched_context /* The current scheduling state. */ static struct c6x_sched_context ss; +/* The following variable value is DFA state before issueing the first insn + in the current clock cycle. This is used in c6x_variable_issue for + comparison with the state after issuing the last insn in a cycle. */ +static state_t prev_cycle_state; + /* Set when we discover while processing an insn that it would lead to too many accesses of the same register. */ static bool reg_access_stall; @@ -3181,6 +3284,7 @@ insn_set_clock (rtx insn, int cycle) INSN_INFO_ENTRY (uid).clock = cycle; INSN_INFO_ENTRY (uid).new_cond = NULL; + INSN_INFO_ENTRY (uid).reservation = 0; INSN_INFO_ENTRY (uid).ebb_start = false; } @@ -3317,9 +3421,13 @@ init_sched_state (c6x_sched_context_t sc) sc->delays_finished_at = 0; sc->curr_sched_clock = 0; + sc->prev_cycle_state_ctx = xmalloc (dfa_state_size); + memset (sc->reg_n_accesses, 0, sizeof sc->reg_n_accesses); memset (sc->reg_n_xaccesses, 0, sizeof sc->reg_n_xaccesses); memset (sc->reg_set_in_cycle, 0, sizeof sc->reg_set_in_cycle); + + state_reset (sc->prev_cycle_state_ctx); } /* Allocate store for new scheduling context. */ @@ -3341,7 +3449,11 @@ c6x_init_sched_context (void *_sc, bool clean_p) init_sched_state (sc); } else - *sc = ss; + { + *sc = ss; + sc->prev_cycle_state_ctx = xmalloc (dfa_state_size); + memcpy (sc->prev_cycle_state_ctx, prev_cycle_state, dfa_state_size); + } } /* Sets the global scheduling context to the one pointed to by _SC. */ @@ -3352,6 +3464,17 @@ c6x_set_sched_context (void *_sc) gcc_assert (sc != NULL); ss = *sc; + memcpy (prev_cycle_state, sc->prev_cycle_state_ctx, dfa_state_size); +} + +/* Clear data in _SC. */ +static void +c6x_clear_sched_context (void *_sc) +{ + c6x_sched_context_t sc = (c6x_sched_context_t) _sc; + gcc_assert (_sc != NULL); + + free (sc->prev_cycle_state_ctx); } /* Free _SC. */ @@ -3384,6 +3507,17 @@ c6x_issue_rate (void) return 8; } +/* Used together with the collapse_ndfa option, this ensures that we reach a + deterministic automaton state before trying to advance a cycle. + With collapse_ndfa, genautomata creates advance cycle arcs only for + such deterministic states. */ + +static rtx +c6x_sched_dfa_pre_cycle_insn (void) +{ + return const0_rtx; +} + /* We're beginning a new block. Initialize data structures as necessary. */ static void @@ -3391,7 +3525,28 @@ c6x_sched_init (FILE *dump ATTRIBUTE_UNUSED, int sched_verbose ATTRIBUTE_UNUSED, int max_ready ATTRIBUTE_UNUSED) { + if (prev_cycle_state == NULL) + { + prev_cycle_state = xmalloc (dfa_state_size); + } init_sched_state (&ss); + state_reset (prev_cycle_state); +} + +/* We are about to being issuing INSN. Return nonzero if we cannot + issue it on given cycle CLOCK and return zero if we should not sort + the ready queue on the next clock start. + For C6X, we use this function just to copy the previous DFA state + for comparison purposes. */ + +static int +c6x_dfa_new_cycle (FILE *dump ATTRIBUTE_UNUSED, int verbose ATTRIBUTE_UNUSED, + rtx insn ATTRIBUTE_UNUSED, int last_clock ATTRIBUTE_UNUSED, + int clock ATTRIBUTE_UNUSED, int *sort_p ATTRIBUTE_UNUSED) +{ + if (clock != last_clock) + memcpy (prev_cycle_state, curr_state, dfa_state_size); + return 0; } static void @@ -3766,11 +3921,14 @@ c6x_variable_issue (FILE *dump ATTRIBUTE_UNUSED, ss.issued_this_cycle++; if (insn_info) { + state_t st_after = alloca (dfa_state_size); int curr_clock = ss.curr_sched_clock; int uid = INSN_UID (insn); int icode = recog_memoized (insn); rtx first_cond; int first, first_cycle; + unsigned int mask; + int i; insn_set_clock (insn, curr_clock); INSN_INFO_ENTRY (uid).ebb_start @@ -3795,6 +3953,16 @@ c6x_variable_issue (FILE *dump ATTRIBUTE_UNUSED, || get_attr_type (insn) == TYPE_CALL)) INSN_INFO_ENTRY (uid).new_cond = first_cond; + memcpy (st_after, curr_state, dfa_state_size); + state_transition (st_after, const0_rtx); + + mask = 0; + for (i = 0; i < 2 * UNIT_QID_SIDE_OFFSET; i++) + if (cpu_unit_reservation_p (st_after, c6x_unit_codes[i]) + && !cpu_unit_reservation_p (prev_cycle_state, c6x_unit_codes[i])) + mask |= 1 << i; + INSN_INFO_ENTRY (uid).unit_mask = mask; + maybe_clobber_cond (insn, curr_clock); if (icode >= 0) @@ -4323,15 +4491,19 @@ reorg_split_calls (rtx *call_labels) if (can_use_callp (insn)) { /* Find the first insn of the next execute packet. If it - is outside the branch delay slots of this call, we may + is the shadow insn corresponding to this call, we may use a CALLP insn. */ - rtx next_cycle_start = next_nonnote_nondebug_insn (last_same_clock); + rtx shadow = next_nonnote_nondebug_insn (last_same_clock); - if (CALL_P (next_cycle_start) - && (insn_get_clock (next_cycle_start) == this_clock + 5)) + if (CALL_P (shadow) + && insn_get_clock (shadow) == this_clock + 5) { - convert_to_callp (next_cycle_start); - insn_set_clock (next_cycle_start, this_clock); + convert_to_callp (shadow); + insn_set_clock (shadow, this_clock); + INSN_INFO_ENTRY (INSN_UID (shadow)).reservation + = RESERVATION_S2; + INSN_INFO_ENTRY (INSN_UID (shadow)).unit_mask + = INSN_INFO_ENTRY (INSN_UID (last_same_clock)).unit_mask; if (GET_MODE (insn) == TImode) { rtx new_cycle_first = NEXT_INSN (insn); @@ -4340,13 +4512,13 @@ reorg_split_calls (rtx *call_labels) || GET_CODE (PATTERN (new_cycle_first)) == CLOBBER) new_cycle_first = NEXT_INSN (new_cycle_first); PUT_MODE (new_cycle_first, TImode); - if (new_cycle_first != next_cycle_start) - PUT_MODE (next_cycle_start, VOIDmode); + if (new_cycle_first != shadow) + PUT_MODE (shadow, VOIDmode); INSN_INFO_ENTRY (INSN_UID (new_cycle_first)).ebb_start = INSN_INFO_ENTRY (INSN_UID (insn)).ebb_start; } else - PUT_MODE (next_cycle_start, VOIDmode); + PUT_MODE (shadow, VOIDmode); delete_insn (insn); goto done; } @@ -4364,6 +4536,9 @@ reorg_split_calls (rtx *call_labels) INSN_INFO_ENTRY (INSN_UID (x1)).reservation = RESERVATION_S2; if (after1 == last_same_clock) PUT_MODE (x1, TImode); + else + INSN_INFO_ENTRY (INSN_UID (x1)).unit_mask + = INSN_INFO_ENTRY (INSN_UID (after1)).unit_mask; } else { @@ -4381,8 +4556,14 @@ reorg_split_calls (rtx *call_labels) INSN_INFO_ENTRY (INSN_UID (x2)).reservation = RESERVATION_S2; if (after1 == last_same_clock) PUT_MODE (x1, TImode); + else + INSN_INFO_ENTRY (INSN_UID (x1)).unit_mask + = INSN_INFO_ENTRY (INSN_UID (after1)).unit_mask; if (after1 == after2) PUT_MODE (x2, TImode); + else + INSN_INFO_ENTRY (INSN_UID (x2)).unit_mask + = INSN_INFO_ENTRY (INSN_UID (after2)).unit_mask; } } } @@ -5524,6 +5705,10 @@ c6x_expand_builtin (tree exp, rtx target ATTRIBUTE_UNUSED, #define TARGET_SCHED_REORDER c6x_sched_reorder #undef TARGET_SCHED_REORDER2 #define TARGET_SCHED_REORDER2 c6x_sched_reorder2 +#undef TARGET_SCHED_DFA_NEW_CYCLE +#define TARGET_SCHED_DFA_NEW_CYCLE c6x_dfa_new_cycle +#undef TARGET_SCHED_DFA_PRE_CYCLE_INSN +#define TARGET_SCHED_DFA_PRE_CYCLE_INSN c6x_sched_dfa_pre_cycle_insn #undef TARGET_SCHED_EXPOSED_PIPELINE #define TARGET_SCHED_EXPOSED_PIPELINE true @@ -5533,6 +5718,8 @@ c6x_expand_builtin (tree exp, rtx target ATTRIBUTE_UNUSED, #define TARGET_SCHED_INIT_SCHED_CONTEXT c6x_init_sched_context #undef TARGET_SCHED_SET_SCHED_CONTEXT #define TARGET_SCHED_SET_SCHED_CONTEXT c6x_set_sched_context +#undef TARGET_SCHED_CLEAR_SCHED_CONTEXT +#define TARGET_SCHED_CLEAR_SCHED_CONTEXT c6x_clear_sched_context #undef TARGET_SCHED_FREE_SCHED_CONTEXT #define TARGET_SCHED_FREE_SCHED_CONTEXT c6x_free_sched_context diff --git a/gcc/config/c6x/c6x.h b/gcc/config/c6x/c6x.h index 5d34d590ff3..9b1b1636b52 100644 --- a/gcc/config/c6x/c6x.h +++ b/gcc/config/c6x/c6x.h @@ -612,6 +612,8 @@ do { \ #define Pmode SImode #define FUNCTION_MODE QImode +#define CPU_UNITS_QUERY 1 + extern int c6x_initial_flag_pic; #endif /* GCC_C6X_H */ diff --git a/gcc/config/c6x/c6x.md b/gcc/config/c6x/c6x.md index 4554cd08130..c2502ca1a42 100644 --- a/gcc/config/c6x/c6x.md +++ b/gcc/config/c6x/c6x.md @@ -242,21 +242,27 @@ ] (const_string "unknown"))) -(define_automaton "c6x_1,c6x_w1,c6x_2,c6x_w2,c6x_m1,c6x_m2,c6x_t1,c6x_t2,c6x_branch") +(define_automaton "c6x_1,c6x_2,c6x_m1,c6x_m2,c6x_t1,c6x_t2,c6x_branch") +(automata_option "no-comb-vect") (automata_option "ndfa") +(automata_option "collapse-ndfa") -(define_cpu_unit "d1,l1,s1" "c6x_1") +(define_query_cpu_unit "d1,l1,s1" "c6x_1") (define_cpu_unit "x1" "c6x_1") -(define_cpu_unit "l1w,s1w" "c6x_w1") -(define_cpu_unit "m1" "c6x_m1") +(define_cpu_unit "l1w,s1w" "c6x_1") +(define_query_cpu_unit "m1" "c6x_m1") (define_cpu_unit "m1w" "c6x_m1") (define_cpu_unit "t1" "c6x_t1") -(define_cpu_unit "d2,l2,s2" "c6x_2") +(define_query_cpu_unit "d2,l2,s2" "c6x_2") (define_cpu_unit "x2" "c6x_2") -(define_cpu_unit "l2w,s2w" "c6x_w2") -(define_cpu_unit "m2" "c6x_m2") +(define_cpu_unit "l2w,s2w" "c6x_2") +(define_query_cpu_unit "m2" "c6x_m2") (define_cpu_unit "m2w" "c6x_m2") (define_cpu_unit "t2" "c6x_t2") +;; A special set of units used to identify specific reservations, rather than +;; just units. +(define_query_cpu_unit "fps1,fpl1,adddps1,adddpl1" "c6x_1") +(define_query_cpu_unit "fps2,fpl2,adddps2,adddpl2" "c6x_2") ;; There can be up to two branches in one cycle (on the .s1 and .s2 ;; units), but some instructions must not be scheduled in parallel diff --git a/gcc/config/darwin.h b/gcc/config/darwin.h index 762a460476b..18ce7496335 100644 --- a/gcc/config/darwin.h +++ b/gcc/config/darwin.h @@ -413,6 +413,7 @@ extern GTY(()) int darwin_ms_struct; #define DEBUG_PUBTYPES_SECTION "__DWARF,__debug_pubtypes,regular,debug" #define DEBUG_STR_SECTION "__DWARF,__debug_str,regular,debug" #define DEBUG_RANGES_SECTION "__DWARF,__debug_ranges,regular,debug" +#define DEBUG_MACRO_SECTION "__DWARF,__debug_macro,regular,debug" #define TARGET_WANT_DEBUG_PUB_SECTIONS true diff --git a/gcc/config/darwin10.h b/gcc/config/darwin10.h index 5c205945cdc..f52a91c3821 100644 --- a/gcc/config/darwin10.h +++ b/gcc/config/darwin10.h @@ -18,9 +18,6 @@ You should have received a copy of the GNU General Public License along with GCC; see the file COPYING3. If not see <http://www.gnu.org/licenses/>. */ -#undef LIB_SPEC -#define LIB_SPEC "%{!static: -lSystem }" - /* Fix PR41260 by passing -no_compact_unwind on darwin10 and later until unwinder in libSystem is fixed to digest new epilog unwinding notes. diff --git a/gcc/config/i386/i386.c b/gcc/config/i386/i386.c index d0e1be5df4a..ff8c49f0bf4 100644 --- a/gcc/config/i386/i386.c +++ b/gcc/config/i386/i386.c @@ -2168,7 +2168,15 @@ static unsigned int initial_ix86_tune_features[X86_TUNE_LAST] = { /* X86_TUNE_AVX128_OPTIMAL: Enable 128-bit AVX instruction generation for the auto-vectorizer. */ - m_BDVER + m_BDVER, + + /* X86_TUNE_REASSOC_INT_TO_PARALLEL: Try to produce parallel computations + during reassociation of integer computation. */ + m_ATOM, + + /* X86_TUNE_REASSOC_FP_TO_PARALLEL: Try to produce parallel computations + during reassociation of fp computation. */ + m_ATOM }; /* Feature tests against the various architecture variations. */ @@ -7007,7 +7015,7 @@ ix86_function_value_regno_p (const unsigned int regno) { switch (regno) { - case 0: + case AX_REG: return true; case FIRST_FLOAT_REG: @@ -7045,18 +7053,18 @@ function_value_32 (enum machine_mode orig_mode, enum machine_mode mode, we normally prevent this case when mmx is not available. However some ABIs may require the result to be returned like DImode. */ if (VECTOR_MODE_P (mode) && GET_MODE_SIZE (mode) == 8) - regno = TARGET_MMX ? FIRST_MMX_REG : 0; + regno = FIRST_MMX_REG; /* 16-byte vector modes in %xmm0. See ix86_return_in_memory for where we prevent this case when sse is not available. However some ABIs may require the result to be returned like integer TImode. */ else if (mode == TImode || (VECTOR_MODE_P (mode) && GET_MODE_SIZE (mode) == 16)) - regno = TARGET_SSE ? FIRST_SSE_REG : 0; + regno = FIRST_SSE_REG; /* 32-byte vector modes in %ymm0. */ else if (VECTOR_MODE_P (mode) && GET_MODE_SIZE (mode) == 32) - regno = TARGET_AVX ? FIRST_SSE_REG : 0; + regno = FIRST_SSE_REG; /* Floating point return values in %st(0) (unless -mno-fp-ret-in-387). */ else if (X87_FLOAT_MODE_P (mode) && TARGET_FLOAT_RETURNS_IN_80387) @@ -7090,6 +7098,8 @@ function_value_64 (enum machine_mode orig_mode, enum machine_mode mode, /* Handle libcalls, which don't provide a type node. */ if (valtype == NULL) { + unsigned int regno; + switch (mode) { case SFmode: @@ -7100,15 +7110,19 @@ function_value_64 (enum machine_mode orig_mode, enum machine_mode mode, case SDmode: case DDmode: case TDmode: - return gen_rtx_REG (mode, FIRST_SSE_REG); + regno = FIRST_SSE_REG; + break; case XFmode: case XCmode: - return gen_rtx_REG (mode, FIRST_FLOAT_REG); + regno = FIRST_FLOAT_REG; + break; case TCmode: return NULL; default: - return gen_rtx_REG (mode, AX_REG); + regno = AX_REG; } + + return gen_rtx_REG (mode, regno); } else if (POINTER_TYPE_P (valtype)) { @@ -18413,19 +18427,26 @@ ix86_expand_sse_cmp (rtx dest, enum rtx_code code, rtx cmp_op0, rtx cmp_op1, rtx op_true, rtx op_false) { enum machine_mode mode = GET_MODE (dest); + enum machine_mode cmp_mode = GET_MODE (cmp_op0); rtx x; - cmp_op0 = force_reg (mode, cmp_op0); - if (!nonimmediate_operand (cmp_op1, mode)) - cmp_op1 = force_reg (mode, cmp_op1); + cmp_op0 = force_reg (cmp_mode, cmp_op0); + if (!nonimmediate_operand (cmp_op1, cmp_mode)) + cmp_op1 = force_reg (cmp_mode, cmp_op1); if (optimize || reg_overlap_mentioned_p (dest, op_true) || reg_overlap_mentioned_p (dest, op_false)) dest = gen_reg_rtx (mode); - x = gen_rtx_fmt_ee (code, mode, cmp_op0, cmp_op1); - emit_insn (gen_rtx_SET (VOIDmode, dest, x)); + x = gen_rtx_fmt_ee (code, cmp_mode, cmp_op0, cmp_op1); + if (cmp_mode != mode) + { + x = force_reg (cmp_mode, x); + convert_move (dest, x, false); + } + else + emit_insn (gen_rtx_SET (VOIDmode, dest, x)); return dest; } @@ -34836,6 +34857,8 @@ ix86_enum_va_list (int idx, const char **pname, tree *ptree) #define TARGET_SCHED_DISPATCH has_dispatch #undef TARGET_SCHED_DISPATCH_DO #define TARGET_SCHED_DISPATCH_DO do_dispatch +#undef TARGET_SCHED_REASSOCIATION_WIDTH +#define TARGET_SCHED_REASSOCIATION_WIDTH ix86_reassociation_width /* The size of the dispatch window is the total number of bytes of object code allowed in a window. */ @@ -35633,6 +35656,32 @@ has_dispatch (rtx insn, int action) return false; } +/* Implementation of reassociation_width target hook used by + reassoc phase to identify parallelism level in reassociated + tree. Statements tree_code is passed in OPC. Arguments type + is passed in MODE. + + Currently parallel reassociation is enabled for Atom + processors only and we set reassociation width to be 2 + because Atom may issue up to 2 instructions per cycle. + + Return value should be fixed if parallel reassociation is + enabled for other processors. */ + +static int +ix86_reassociation_width (unsigned int opc ATTRIBUTE_UNUSED, + enum machine_mode mode) +{ + int res = 1; + + if (INTEGRAL_MODE_P (mode) && TARGET_REASSOC_INT_TO_PARALLEL) + res = 2; + else if (FLOAT_MODE_P (mode) && TARGET_REASSOC_FP_TO_PARALLEL) + res = 2; + + return res; +} + /* ??? No autovectorization into MMX or 3DNOW until we can reliably place emms and femms instructions. */ diff --git a/gcc/config/i386/i386.h b/gcc/config/i386/i386.h index 47442a0e50f..21f50755211 100644 --- a/gcc/config/i386/i386.h +++ b/gcc/config/i386/i386.h @@ -318,6 +318,8 @@ enum ix86_tune_indices { X86_TUNE_VECTORIZE_DOUBLE, X86_TUNE_SOFTWARE_PREFETCHING_BENEFICIAL, X86_TUNE_AVX128_OPTIMAL, + X86_TUNE_REASSOC_INT_TO_PARALLEL, + X86_TUNE_REASSOC_FP_TO_PARALLEL, X86_TUNE_LAST }; @@ -416,6 +418,11 @@ extern unsigned char ix86_tune_features[X86_TUNE_LAST]; ix86_tune_features[X86_TUNE_SOFTWARE_PREFETCHING_BENEFICIAL] #define TARGET_AVX128_OPTIMAL \ ix86_tune_features[X86_TUNE_AVX128_OPTIMAL] +#define TARGET_REASSOC_INT_TO_PARALLEL \ + ix86_tune_features[X86_TUNE_REASSOC_INT_TO_PARALLEL] +#define TARGET_REASSOC_FP_TO_PARALLEL \ + ix86_tune_features[X86_TUNE_REASSOC_FP_TO_PARALLEL] + /* Feature tests against the various architecture variations. */ enum ix86_arch_indices { X86_ARCH_CMOVE, /* || TARGET_SSE */ diff --git a/gcc/config/i386/sse.md b/gcc/config/i386/sse.md index 3678ea824ec..353f4b62a7d 100644 --- a/gcc/config/i386/sse.md +++ b/gcc/config/i386/sse.md @@ -1402,15 +1402,34 @@ (const_string "0"))) (set_attr "mode" "<MODE>")]) -(define_expand "vcond<mode>" - [(set (match_operand:VF 0 "register_operand" "") - (if_then_else:VF +(define_expand "vcond<V_256:mode><VF_256:mode>" + [(set (match_operand:V_256 0 "register_operand" "") + (if_then_else:V_256 (match_operator 3 "" - [(match_operand:VF 4 "nonimmediate_operand" "") - (match_operand:VF 5 "nonimmediate_operand" "")]) - (match_operand:VF 1 "general_operand" "") - (match_operand:VF 2 "general_operand" "")))] - "TARGET_SSE" + [(match_operand:VF_256 4 "nonimmediate_operand" "") + (match_operand:VF_256 5 "nonimmediate_operand" "")]) + (match_operand:V_256 1 "general_operand" "") + (match_operand:V_256 2 "general_operand" "")))] + "TARGET_AVX + && (GET_MODE_NUNITS (<V_256:MODE>mode) + == GET_MODE_NUNITS (<VF_256:MODE>mode))" +{ + bool ok = ix86_expand_fp_vcond (operands); + gcc_assert (ok); + DONE; +}) + +(define_expand "vcond<V_128:mode><VF_128:mode>" + [(set (match_operand:V_128 0 "register_operand" "") + (if_then_else:V_128 + (match_operator 3 "" + [(match_operand:VF_128 4 "nonimmediate_operand" "") + (match_operand:VF_128 5 "nonimmediate_operand" "")]) + (match_operand:V_128 1 "general_operand" "") + (match_operand:V_128 2 "general_operand" "")))] + "TARGET_SSE + && (GET_MODE_NUNITS (<V_128:MODE>mode) + == GET_MODE_NUNITS (<VF_128:MODE>mode))" { bool ok = ix86_expand_fp_vcond (operands); gcc_assert (ok); @@ -6171,29 +6190,31 @@ (set_attr "prefix" "orig,vex") (set_attr "mode" "TI")]) -(define_expand "vcond<mode>" - [(set (match_operand:VI124_128 0 "register_operand" "") - (if_then_else:VI124_128 +(define_expand "vcond<V_128:mode><VI124_128:mode>" + [(set (match_operand:V_128 0 "register_operand" "") + (if_then_else:V_128 (match_operator 3 "" [(match_operand:VI124_128 4 "nonimmediate_operand" "") (match_operand:VI124_128 5 "nonimmediate_operand" "")]) - (match_operand:VI124_128 1 "general_operand" "") - (match_operand:VI124_128 2 "general_operand" "")))] - "TARGET_SSE2" + (match_operand:V_128 1 "general_operand" "") + (match_operand:V_128 2 "general_operand" "")))] + "TARGET_SSE2 + && (GET_MODE_NUNITS (<V_128:MODE>mode) + == GET_MODE_NUNITS (<VI124_128:MODE>mode))" { bool ok = ix86_expand_int_vcond (operands); gcc_assert (ok); DONE; }) -(define_expand "vcondv2di" - [(set (match_operand:V2DI 0 "register_operand" "") - (if_then_else:V2DI +(define_expand "vcond<VI8F_128:mode>v2di" + [(set (match_operand:VI8F_128 0 "register_operand" "") + (if_then_else:VI8F_128 (match_operator 3 "" [(match_operand:V2DI 4 "nonimmediate_operand" "") (match_operand:V2DI 5 "nonimmediate_operand" "")]) - (match_operand:V2DI 1 "general_operand" "") - (match_operand:V2DI 2 "general_operand" "")))] + (match_operand:VI8F_128 1 "general_operand" "") + (match_operand:VI8F_128 2 "general_operand" "")))] "TARGET_SSE4_2" { bool ok = ix86_expand_int_vcond (operands); @@ -6201,29 +6222,31 @@ DONE; }) -(define_expand "vcondu<mode>" - [(set (match_operand:VI124_128 0 "register_operand" "") - (if_then_else:VI124_128 +(define_expand "vcondu<V_128:mode><VI124_128:mode>" + [(set (match_operand:V_128 0 "register_operand" "") + (if_then_else:V_128 (match_operator 3 "" [(match_operand:VI124_128 4 "nonimmediate_operand" "") (match_operand:VI124_128 5 "nonimmediate_operand" "")]) - (match_operand:VI124_128 1 "general_operand" "") - (match_operand:VI124_128 2 "general_operand" "")))] - "TARGET_SSE2" + (match_operand:V_128 1 "general_operand" "") + (match_operand:V_128 2 "general_operand" "")))] + "TARGET_SSE2 + && (GET_MODE_NUNITS (<V_128:MODE>mode) + == GET_MODE_NUNITS (<VI124_128:MODE>mode))" { bool ok = ix86_expand_int_vcond (operands); gcc_assert (ok); DONE; }) -(define_expand "vconduv2di" - [(set (match_operand:V2DI 0 "register_operand" "") - (if_then_else:V2DI +(define_expand "vcondu<VI8F_128:mode>v2di" + [(set (match_operand:VI8F_128 0 "register_operand" "") + (if_then_else:VI8F_128 (match_operator 3 "" [(match_operand:V2DI 4 "nonimmediate_operand" "") (match_operand:V2DI 5 "nonimmediate_operand" "")]) - (match_operand:V2DI 1 "general_operand" "") - (match_operand:V2DI 2 "general_operand" "")))] + (match_operand:VI8F_128 1 "general_operand" "") + (match_operand:VI8F_128 2 "general_operand" "")))] "TARGET_SSE4_2" { bool ok = ix86_expand_int_vcond (operands); diff --git a/gcc/config/ia64/vect.md b/gcc/config/ia64/vect.md index 1684c8092c2..2f068ebcb60 100644 --- a/gcc/config/ia64/vect.md +++ b/gcc/config/ia64/vect.md @@ -661,7 +661,7 @@ DONE; }) -(define_expand "vcond<mode>" +(define_expand "vcond<mode><mode>" [(set (match_operand:VECINT 0 "gr_register_operand" "") (if_then_else:VECINT (match_operator 3 "" @@ -675,7 +675,7 @@ DONE; }) -(define_expand "vcondu<mode>" +(define_expand "vcondu<mode><mode>" [(set (match_operand:VECINT 0 "gr_register_operand" "") (if_then_else:VECINT (match_operator 3 "" @@ -1382,7 +1382,7 @@ DONE; }) -(define_expand "vcondv2sf" +(define_expand "vcondv2sfv2sf" [(set (match_operand:V2SF 0 "fr_register_operand" "") (if_then_else:V2SF (match_operator 3 "" diff --git a/gcc/config/mips/mips-dsp.md b/gcc/config/mips/mips-dsp.md index 4f518cbc6dd..0f73d08502e 100644 --- a/gcc/config/mips/mips-dsp.md +++ b/gcc/config/mips/mips-dsp.md @@ -1105,10 +1105,8 @@ "ISA_HAS_DSP" { operands[2] = convert_to_mode (Pmode, operands[2], false); - if (Pmode == SImode) - emit_insn (gen_mips_lbux_si (operands[0], operands[1], operands[2])); - else - emit_insn (gen_mips_lbux_di (operands[0], operands[1], operands[2])); + emit_insn (PMODE_INSN (gen_mips_lbux, + (operands[0], operands[1], operands[2]))); DONE; }) @@ -1129,10 +1127,8 @@ "ISA_HAS_DSP" { operands[2] = convert_to_mode (Pmode, operands[2], false); - if (Pmode == SImode) - emit_insn (gen_mips_lhx_si (operands[0], operands[1], operands[2])); - else - emit_insn (gen_mips_lhx_di (operands[0], operands[1], operands[2])); + emit_insn (PMODE_INSN (gen_mips_lhx, + (operands[0], operands[1], operands[2]))); DONE; }) @@ -1153,10 +1149,8 @@ "ISA_HAS_DSP" { operands[2] = convert_to_mode (Pmode, operands[2], false); - if (Pmode == SImode) - emit_insn (gen_mips_lwx_si (operands[0], operands[1], operands[2])); - else - emit_insn (gen_mips_lwx_di (operands[0], operands[1], operands[2])); + emit_insn (PMODE_INSN (gen_mips_lwx, + (operands[0], operands[1], operands[2]))); DONE; }) diff --git a/gcc/config/mips/mips-ps-3d.md b/gcc/config/mips/mips-ps-3d.md index 8e942307cb9..504f43ce46c 100644 --- a/gcc/config/mips/mips-ps-3d.md +++ b/gcc/config/mips/mips-ps-3d.md @@ -597,7 +597,7 @@ [(set_attr "type" "frdiv2") (set_attr "mode" "<UNITMODE>")]) -(define_expand "vcondv2sf" +(define_expand "vcondv2sfv2sf" [(set (match_operand:V2SF 0 "register_operand") (if_then_else:V2SF (match_operator 3 "" diff --git a/gcc/config/mips/mips.c b/gcc/config/mips/mips.c index f5c4cbe60f6..a0e93c53bb2 100644 --- a/gcc/config/mips/mips.c +++ b/gcc/config/mips/mips.c @@ -2522,9 +2522,7 @@ mips_unspec_offset_high (rtx temp, rtx base, rtx addr, static rtx gen_load_const_gp (rtx reg) { - return (Pmode == SImode - ? gen_load_const_gp_si (reg) - : gen_load_const_gp_di (reg)); + return PMODE_INSN (gen_load_const_gp, (reg)); } /* Return a pseudo register that contains the value of $gp throughout @@ -2626,9 +2624,7 @@ mips_got_load (rtx temp, rtx addr, enum mips_symbol_type type) if (type == SYMBOL_GOTOFF_CALL) return mips_unspec_call (high, lo_sum_symbol); else - return (Pmode == SImode - ? gen_unspec_gotsi (high, lo_sum_symbol) - : gen_unspec_gotdi (high, lo_sum_symbol)); + return PMODE_INSN (gen_unspec_got, (high, lo_sum_symbol)); } /* If MODE is MAX_MACHINE_MODE, ADDR appears as a move operand, otherwise @@ -5601,7 +5597,7 @@ mips_gimplify_va_arg_expr (tree valist, tree type, gimple_seq *pre_p, } /* [2] Emit code to branch if off == 0. */ - t = build2 (NE_EXPR, boolean_type_node, off, + t = build2 (NE_EXPR, boolean_type_node, unshare_expr (off), build_int_cst (TREE_TYPE (off), 0)); addr = build3 (COND_EXPR, ptr_type_node, t, NULL_TREE, NULL_TREE); @@ -5624,7 +5620,7 @@ mips_gimplify_va_arg_expr (tree valist, tree type, gimple_seq *pre_p, /* [9] Emit: ovfl = ((intptr_t) ovfl + osize - 1) & -osize. */ t = fold_build_pointer_plus_hwi (unshare_expr (ovfl), osize - 1); u = build_int_cst (TREE_TYPE (t), -osize); - t = build2 (BIT_AND_EXPR, sizetype, t, u); + t = build2 (BIT_AND_EXPR, TREE_TYPE (t), t, u); align = build2 (MODIFY_EXPR, TREE_TYPE (ovfl), unshare_expr (ovfl), t); } @@ -6676,9 +6672,7 @@ mips_expand_synci_loop (rtx begin, rtx end) /* Load INC with the cache line size (rdhwr INC,$1). */ inc = gen_reg_rtx (Pmode); - emit_insn (Pmode == SImode - ? gen_rdhwr_synci_step_si (inc) - : gen_rdhwr_synci_step_di (inc)); + emit_insn (PMODE_INSN (gen_rdhwr_synci_step, (inc))); /* Check if inc is 0. */ cmp_result = gen_rtx_EQ (VOIDmode, inc, const0_rtx); @@ -9526,7 +9520,7 @@ mips_save_gp_to_cprestore_slot (rtx mem, rtx offset, rtx gp, rtx temp) if (TARGET_CPRESTORE_DIRECTIVE) { gcc_assert (gp == pic_offset_table_rtx); - emit_insn (gen_cprestore (mem, offset)); + emit_insn (PMODE_INSN (gen_cprestore, (mem, offset))); } else mips_emit_move (mips_cprestore_slot (temp, false), gp); @@ -9913,9 +9907,8 @@ mips_emit_loadgp (void) mips_gnu_local_gp = gen_rtx_SYMBOL_REF (Pmode, "__gnu_local_gp"); SYMBOL_REF_FLAGS (mips_gnu_local_gp) |= SYMBOL_FLAG_LOCAL; } - emit_insn (Pmode == SImode - ? gen_loadgp_absolute_si (pic_reg, mips_gnu_local_gp) - : gen_loadgp_absolute_di (pic_reg, mips_gnu_local_gp)); + emit_insn (PMODE_INSN (gen_loadgp_absolute, + (pic_reg, mips_gnu_local_gp))); break; case LOADGP_OLDABI: @@ -9926,17 +9919,14 @@ mips_emit_loadgp (void) addr = XEXP (DECL_RTL (current_function_decl), 0); offset = mips_unspec_address (addr, SYMBOL_GOTOFF_LOADGP); incoming_address = gen_rtx_REG (Pmode, PIC_FUNCTION_ADDR_REGNUM); - emit_insn (Pmode == SImode - ? gen_loadgp_newabi_si (pic_reg, offset, incoming_address) - : gen_loadgp_newabi_di (pic_reg, offset, incoming_address)); + emit_insn (PMODE_INSN (gen_loadgp_newabi, + (pic_reg, offset, incoming_address))); break; case LOADGP_RTP: base = gen_rtx_SYMBOL_REF (Pmode, ggc_strdup (VXWORKS_GOTT_BASE)); index = gen_rtx_SYMBOL_REF (Pmode, ggc_strdup (VXWORKS_GOTT_INDEX)); - emit_insn (Pmode == SImode - ? gen_loadgp_rtp_si (pic_reg, base, index) - : gen_loadgp_rtp_di (pic_reg, base, index)); + emit_insn (PMODE_INSN (gen_loadgp_rtp, (pic_reg, base, index))); break; default: @@ -9944,7 +9934,8 @@ mips_emit_loadgp (void) } if (TARGET_MIPS16) - emit_insn (gen_copygp_mips16 (pic_offset_table_rtx, pic_reg)); + emit_insn (PMODE_INSN (gen_copygp_mips16, + (pic_offset_table_rtx, pic_reg))); /* Emit a blockage if there are implicit uses of the GP register. This includes profiled functions, because FUNCTION_PROFILE uses @@ -10200,11 +10191,12 @@ mips_expand_prologue (void) temp = (SMALL_OPERAND (offset) ? gen_rtx_SCRATCH (Pmode) : MIPS_PROLOGUE_TEMP (Pmode)); - emit_insn (gen_potential_cprestore (mem, GEN_INT (offset), gp, temp)); + emit_insn (PMODE_INSN (gen_potential_cprestore, + (mem, GEN_INT (offset), gp, temp))); mips_get_cprestore_base_and_offset (&base, &offset, true); mem = gen_frame_mem (Pmode, plus_constant (base, offset)); - emit_insn (gen_use_cprestore (mem)); + emit_insn (PMODE_INSN (gen_use_cprestore, (mem))); } /* We need to search back to the last use of K0 or K1. */ @@ -15400,8 +15392,32 @@ mips_option_override (void) /* End of code shared with GAS. */ - /* If no -mlong* option was given, infer it from the other options. */ - if ((target_flags_explicit & MASK_LONG64) == 0) + /* If a -mlong* option was given, check that it matches the ABI, + otherwise infer the -mlong* setting from the other options. */ + if ((target_flags_explicit & MASK_LONG64) != 0) + { + if (TARGET_LONG64) + { + if (mips_abi == ABI_N32) + error ("%qs is incompatible with %qs", "-mabi=n32", "-mlong64"); + else if (mips_abi == ABI_32) + error ("%qs is incompatible with %qs", "-mabi=32", "-mlong64"); + else if (mips_abi == ABI_O64 && TARGET_ABICALLS) + /* We have traditionally allowed non-abicalls code to use + an LP64 form of o64. However, it would take a bit more + effort to support the combination of 32-bit GOT entries + and 64-bit pointers, so we treat the abicalls case as + an error. */ + error ("the combination of %qs and %qs is incompatible with %qs", + "-mabi=o64", "-mabicalls", "-mlong64"); + } + else + { + if (mips_abi == ABI_64) + error ("%qs is incompatible with %qs", "-mabi=64", "-mlong32"); + } + } + else { if ((mips_abi == ABI_EABI && TARGET_64BIT) || mips_abi == ABI_64) target_flags |= MASK_LONG64; diff --git a/gcc/config/mips/mips.h b/gcc/config/mips/mips.h index 92e932a29c9..236afbb4a34 100644 --- a/gcc/config/mips/mips.h +++ b/gcc/config/mips/mips.h @@ -792,7 +792,9 @@ struct mips_cpu_info { the ABI's file format, but it can be overridden by -msym32. Note that overriding the size with -msym32 changes the ABI of relocatable objects, although it doesn't change the ABI of a fully-linked object. */ -#define ABI_HAS_64BIT_SYMBOLS (FILE_HAS_64BIT_SYMBOLS && !TARGET_SYM32) +#define ABI_HAS_64BIT_SYMBOLS (FILE_HAS_64BIT_SYMBOLS \ + && Pmode == DImode \ + && !TARGET_SYM32) /* ISA has instructions for managing 64-bit fp and gp regs (e.g. mips3). */ #define ISA_HAS_64BIT_REGS (ISA_MIPS3 \ @@ -2916,3 +2918,10 @@ extern GTY(()) struct target_globals *mips16_globals; /* For switching between MIPS16 and non-MIPS16 modes. */ #define SWITCHABLE_TARGET 1 + +/* Several named MIPS patterns depend on Pmode. These patterns have the + form <NAME>_si for Pmode == SImode and <NAME>_di for Pmode == DImode. + Add the appropriate suffix to generator function NAME and invoke it + with arguments ARGS. */ +#define PMODE_INSN(NAME, ARGS) \ + (Pmode == SImode ? NAME ## _si ARGS : NAME ## _di ARGS) diff --git a/gcc/config/mips/mips.md b/gcc/config/mips/mips.md index 0606f92f7b6..de953211523 100644 --- a/gcc/config/mips/mips.md +++ b/gcc/config/mips/mips.md @@ -3866,7 +3866,7 @@ (set_attr "mode" "<MODE>")]) ;; Convenience expander that generates the rhs of a load_got<mode> insn. -(define_expand "unspec_got<mode>" +(define_expand "unspec_got_<mode>" [(unspec:P [(match_operand:P 0) (match_operand:P 1)] UNSPEC_LOAD_GOT)]) @@ -4783,10 +4783,10 @@ ;; Initialize the global pointer for MIPS16 code. Operand 0 is the ;; global pointer and operand 1 is the MIPS16 register that holds ;; the required value. -(define_insn_and_split "copygp_mips16" - [(set (match_operand:SI 0 "register_operand" "=y") - (unspec:SI [(match_operand:SI 1 "register_operand" "d")] - UNSPEC_COPYGP))] +(define_insn_and_split "copygp_mips16_<mode>" + [(set (match_operand:P 0 "register_operand" "=y") + (unspec:P [(match_operand:P 1 "register_operand" "d")] + UNSPEC_COPYGP))] "TARGET_MIPS16" { return mips_must_initialize_gp_p () ? "#" : ""; } "&& mips_must_initialize_gp_p ()" @@ -4800,12 +4800,12 @@ ;; ;; The "cprestore" pattern requires operand 2 to be pic_offset_table_rtx, ;; otherwise any register that holds the correct value will do. -(define_insn_and_split "potential_cprestore" - [(set (match_operand:SI 0 "cprestore_save_slot_operand" "=X,X") - (unspec:SI [(match_operand:SI 1 "const_int_operand" "I,i") - (match_operand:SI 2 "register_operand" "d,d")] - UNSPEC_POTENTIAL_CPRESTORE)) - (clobber (match_operand:SI 3 "scratch_operand" "=X,&d"))] +(define_insn_and_split "potential_cprestore_<mode>" + [(set (match_operand:P 0 "cprestore_save_slot_operand" "=X,X") + (unspec:P [(match_operand:P 1 "const_int_operand" "I,i") + (match_operand:P 2 "register_operand" "d,d")] + UNSPEC_POTENTIAL_CPRESTORE)) + (clobber (match_operand:P 3 "scratch_operand" "=X,&d"))] "!TARGET_CPRESTORE_DIRECTIVE || operands[2] == pic_offset_table_rtx" { return mips_must_initialize_gp_p () ? "#" : ""; } "mips_must_initialize_gp_p ()" @@ -4822,11 +4822,11 @@ ;; for the cprestore slot. Operand 1 is the offset of the slot from ;; the stack pointer. (This is redundant with operand 0, but it makes ;; things a little simpler.) -(define_insn "cprestore" - [(set (match_operand:SI 0 "cprestore_save_slot_operand" "=X,X") - (unspec:SI [(match_operand:SI 1 "const_int_operand" "I,i") - (reg:SI 28)] - UNSPEC_CPRESTORE))] +(define_insn "cprestore_<mode>" + [(set (match_operand:P 0 "cprestore_save_slot_operand" "=X,X") + (unspec:P [(match_operand:P 1 "const_int_operand" "I,i") + (reg:P 28)] + UNSPEC_CPRESTORE))] "TARGET_CPRESTORE_DIRECTIVE" { if (mips_nomacro.nesting_level > 0 && which_alternative == 1) @@ -4837,9 +4837,9 @@ [(set_attr "type" "store") (set_attr "length" "4,12")]) -(define_insn "use_cprestore" - [(set (reg:SI CPRESTORE_SLOT_REGNUM) - (match_operand:SI 0 "cprestore_load_slot_operand"))] +(define_insn "use_cprestore_<mode>" + [(set (reg:P CPRESTORE_SLOT_REGNUM) + (match_operand:P 0 "cprestore_load_slot_operand"))] "" "" [(set_attr "type" "ghost")]) @@ -4856,9 +4856,7 @@ { mips_expand_synci_loop (operands[0], operands[1]); emit_insn (gen_sync ()); - emit_insn (Pmode == SImode - ? gen_clear_hazard_si () - : gen_clear_hazard_di ()); + emit_insn (PMODE_INSN (gen_clear_hazard, ())); } else if (mips_cache_flush_func && mips_cache_flush_func[0]) { @@ -5567,14 +5565,11 @@ "" { operands[0] = force_reg (Pmode, operands[0]); - if (Pmode == SImode) - emit_jump_insn (gen_indirect_jumpsi (operands[0])); - else - emit_jump_insn (gen_indirect_jumpdi (operands[0])); + emit_jump_insn (PMODE_INSN (gen_indirect_jump, (operands[0]))); DONE; }) -(define_insn "indirect_jump<mode>" +(define_insn "indirect_jump_<mode>" [(set (pc) (match_operand:P 0 "register_operand" "d"))] "" "%*j\t%0%/" @@ -5605,14 +5600,11 @@ start, 0, 0, OPTAB_WIDEN); } - if (Pmode == SImode) - emit_jump_insn (gen_tablejumpsi (operands[0], operands[1])); - else - emit_jump_insn (gen_tablejumpdi (operands[0], operands[1])); + emit_jump_insn (PMODE_INSN (gen_tablejump, (operands[0], operands[1]))); DONE; }) -(define_insn "tablejump<mode>" +(define_insn "tablejump_<mode>" [(set (pc) (match_operand:P 0 "register_operand" "d")) (use (label_ref (match_operand 1 "" "")))] @@ -5844,8 +5836,10 @@ emit_insn (gen_set_got_version ()); /* If we have a call-clobbered $gp, restore it from its save slot. */ - if (HAVE_restore_gp) - emit_insn (gen_restore_gp ()); + if (HAVE_restore_gp_si) + emit_insn (gen_restore_gp_si ()); + else if (HAVE_restore_gp_di) + emit_insn (gen_restore_gp_di ()); DONE; }) @@ -5860,10 +5854,10 @@ ;; Restore $gp from its .cprestore stack slot. The instruction remains ;; volatile until all uses of $28 are exposed. -(define_insn_and_split "restore_gp" - [(set (reg:SI 28) - (unspec_volatile:SI [(const_int 0)] UNSPEC_RESTORE_GP)) - (clobber (match_scratch:SI 0 "=&d"))] +(define_insn_and_split "restore_gp_<mode>" + [(set (reg:P 28) + (unspec_volatile:P [(const_int 0)] UNSPEC_RESTORE_GP)) + (clobber (match_scratch:P 0 "=&d"))] "TARGET_CALL_CLOBBERED_GP" "#" "&& epilogue_completed" diff --git a/gcc/config/mn10300/mn10300.c b/gcc/config/mn10300/mn10300.c index eca88713349..2cd178a5d83 100644 --- a/gcc/config/mn10300/mn10300.c +++ b/gcc/config/mn10300/mn10300.c @@ -3150,6 +3150,7 @@ mn10300_insert_setlb_lcc (rtx label, rtx branch) lcc = emit_jump_insn_before (lcc, branch); mark_jump_label (XVECEXP (PATTERN (lcc), 0, 0), lcc, 0); + JUMP_LABEL (lcc) = label; DUMP ("Replacing branch insn...", branch); DUMP ("... with Lcc insn:", lcc); delete_insn (branch); diff --git a/gcc/config/pa/pa-protos.h b/gcc/config/pa/pa-protos.h index d481c3d0ec2..8c733e4f6f4 100644 --- a/gcc/config/pa/pa-protos.h +++ b/gcc/config/pa/pa-protos.h @@ -93,6 +93,7 @@ extern int and_mask_p (unsigned HOST_WIDE_INT); extern int cint_ok_for_move (HOST_WIDE_INT); extern void hppa_expand_prologue (void); extern void hppa_expand_epilogue (void); +extern bool pa_can_use_return_insn (void); extern int ior_mask_p (unsigned HOST_WIDE_INT); extern void compute_zdepdi_operands (unsigned HOST_WIDE_INT, unsigned *); diff --git a/gcc/config/pa/pa.c b/gcc/config/pa/pa.c index db404cd3c2e..e3ad4c80d89 100644 --- a/gcc/config/pa/pa.c +++ b/gcc/config/pa/pa.c @@ -4329,6 +4329,24 @@ hppa_expand_epilogue (void) } } +bool +pa_can_use_return_insn (void) +{ + if (!reload_completed) + return false; + + if (frame_pointer_needed) + return false; + + if (df_regs_ever_live_p (2)) + return false; + + if (crtl->profile) + return false; + + return compute_frame_size (get_frame_size (), 0) == 0; +} + rtx hppa_pic_save_rtx (void) { diff --git a/gcc/config/pa/pa.md b/gcc/config/pa/pa.md index ee94b2e9324..62369a5e2b5 100644 --- a/gcc/config/pa/pa.md +++ b/gcc/config/pa/pa.md @@ -6671,6 +6671,20 @@ ;; Unconditional and other jump instructions. +;; Trivial return used when no epilogue is needed. +(define_insn "return" + [(return) + (use (reg:SI 2))] + "pa_can_use_return_insn ()" + "* +{ + if (TARGET_PA_20) + return \"bve%* (%%r2)\"; + return \"bv%* %%r0(%%r2)\"; +}" + [(set_attr "type" "branch") + (set_attr "length" "4")]) + ;; This is used for most returns. (define_insn "return_internal" [(return) @@ -6719,11 +6733,8 @@ rtx x; /* Try to use the trivial return first. Else use the full epilogue. */ - if (reload_completed - && !frame_pointer_needed - && !df_regs_ever_live_p (2) - && (compute_frame_size (get_frame_size (), 0) ? 0 : 1)) - x = gen_return_internal (); + if (pa_can_use_return_insn ()) + x = gen_return (); else { hppa_expand_epilogue (); diff --git a/gcc/config/rs6000/paired.md b/gcc/config/rs6000/paired.md index d1b0e8e45f2..f0bf7f9a5e3 100644 --- a/gcc/config/rs6000/paired.md +++ b/gcc/config/rs6000/paired.md @@ -507,7 +507,7 @@ DONE; }) -(define_expand "vcondv2sf" +(define_expand "vcondv2sfv2sf" [(set (match_operand:V2SF 0 "gpc_reg_operand" "=f") (if_then_else:V2SF (match_operator 3 "gpc_reg_operand" diff --git a/gcc/config/rs6000/rs6000.c b/gcc/config/rs6000/rs6000.c index a94a4f6c40b..1ab57e5363a 100644 --- a/gcc/config/rs6000/rs6000.c +++ b/gcc/config/rs6000/rs6000.c @@ -4503,7 +4503,9 @@ paired_expand_vector_init (rtx target, rtx vals) for (i = 0; i < n_elts; ++i) { x = XVECEXP (vals, 0, i); - if (!CONSTANT_P (x)) + if (!(CONST_INT_P (x) + || GET_CODE (x) == CONST_DOUBLE + || GET_CODE (x) == CONST_FIXED)) ++n_var; } if (n_var == 0) @@ -4655,7 +4657,9 @@ rs6000_expand_vector_init (rtx target, rtx vals) for (i = 0; i < n_elts; ++i) { x = XVECEXP (vals, 0, i); - if (!CONSTANT_P (x)) + if (!(CONST_INT_P (x) + || GET_CODE (x) == CONST_DOUBLE + || GET_CODE (x) == CONST_FIXED)) ++n_var, one_var = i; else if (x != CONST0_RTX (inner_mode)) all_const_zero = false; @@ -17941,7 +17945,7 @@ compute_save_world_info (rs6000_stack_t *info_ptr) info_ptr->world_save_p = (WORLD_SAVE_P (info_ptr) && DEFAULT_ABI == ABI_DARWIN - && ! (cfun->calls_setjmp && flag_exceptions) + && !cfun->has_nonlocal_label && info_ptr->first_fp_reg_save == FIRST_SAVED_FP_REGNO && info_ptr->first_gp_reg_save == FIRST_SAVED_GP_REGNO && info_ptr->first_altivec_reg_save == FIRST_SAVED_ALTIVEC_REGNO diff --git a/gcc/config/rs6000/vector.md b/gcc/config/rs6000/vector.md index 4799ff29e0a..0179cd9df90 100644 --- a/gcc/config/rs6000/vector.md +++ b/gcc/config/rs6000/vector.md @@ -370,7 +370,7 @@ ;; Vector comparisons -(define_expand "vcond<mode>" +(define_expand "vcond<mode><mode>" [(set (match_operand:VEC_F 0 "vfloat_operand" "") (if_then_else:VEC_F (match_operator 3 "comparison_operator" @@ -388,7 +388,7 @@ FAIL; }") -(define_expand "vcond<mode>" +(define_expand "vcond<mode><mode>" [(set (match_operand:VEC_I 0 "vint_operand" "") (if_then_else:VEC_I (match_operator 3 "comparison_operator" @@ -406,7 +406,7 @@ FAIL; }") -(define_expand "vcondu<mode>" +(define_expand "vcondu<mode><mode>" [(set (match_operand:VEC_I 0 "vint_operand" "") (if_then_else:VEC_I (match_operator 3 "comparison_operator" diff --git a/gcc/config/sparc/sol2-64.h b/gcc/config/sparc/default-64.h index 41e228114a6..ae884ea25c7 100644 --- a/gcc/config/sparc/sol2-64.h +++ b/gcc/config/sparc/default-64.h @@ -1,5 +1,5 @@ -/* Definitions of target machine for GCC, for bi-arch SPARC - running Solaris 2, defaulting to 64-bit code generation. +/* Definitions of target machine for GCC, for bi-arch SPARC, + defaulting to 64-bit code generation. Copyright (C) 1999, 2010, 2011 Free Software Foundation, Inc. diff --git a/gcc/config/sparc/driver-sparc.c b/gcc/config/sparc/driver-sparc.c index e5b91bc2ba8..96227289db5 100644 --- a/gcc/config/sparc/driver-sparc.c +++ b/gcc/config/sparc/driver-sparc.c @@ -55,10 +55,24 @@ static const struct cpu_names { { "UltraSPARC-T2", "niagara2" }, { "UltraSPARC-T2", "niagara2" }, { "UltraSPARC-T2+", "niagara2" }, - { "SPARC-T3", "niagara2" }, - { "SPARC-T4", "niagara2" }, + { "SPARC-T3", "niagara3" }, + { "SPARC-T4", "niagara4" }, #else - /* FIXME: Provide Linux/SPARC values. */ + { "SuperSPARC", "supersparc" }, + { "HyperSparc", "hypersparc" }, + { "SpitFire", "ultrasparc" }, + { "BlackBird", "ultrasparc" }, + { "Sabre", "ultrasparc" }, + { "Hummingbird", "ultrasparc" }, + { "Cheetah", "ultrasparc3" }, + { "Jalapeno", "ultrasparc3" }, + { "Jaguar", "ultrasparc3" }, + { "Panther", "ultrasparc3" }, + { "Serrano", "ultrasparc3" }, + { "UltraSparc T1", "niagara" }, + { "UltraSparc T2", "niagara2" }, + { "UltraSparc T3", "niagara3" }, + { "UltraSparc T4", "niagara4" }, #endif { NULL, NULL } }; @@ -137,7 +151,7 @@ host_detect_local_cpu (int argc, const char **argv) return NULL; while (fgets (buf, sizeof (buf), f) != NULL) - if (strncmp (buf, "cpu model", sizeof ("cpu model") - 1) == 0) + if (strncmp (buf, "cpu\t\t:", sizeof ("cpu\t\t:") - 1) == 0) { for (i = 0; cpu_names [i].name; i++) if (strstr (buf, cpu_names [i].name) != NULL) diff --git a/gcc/config/sparc/linux.h b/gcc/config/sparc/linux.h index a9b630e6184..0ad4b3482f1 100644 --- a/gcc/config/sparc/linux.h +++ b/gcc/config/sparc/linux.h @@ -39,6 +39,22 @@ along with GCC; see the file COPYING3. If not see "%{shared|pie:crtendS.o%s;:crtend.o%s} crtn.o%s\ %{Ofast|ffast-math|funsafe-math-optimizations:crtfastmath.o%s}" +/* -mcpu=native handling only makes sense with compiler running on + a SPARC chip. */ +#if defined(__sparc__) +extern const char *host_detect_local_cpu (int argc, const char **argv); +# define EXTRA_SPEC_FUNCTIONS \ + { "local_cpu_detect", host_detect_local_cpu }, + +# define MCPU_MTUNE_NATIVE_SPECS \ + " %{mcpu=native:%<mcpu=native %:local_cpu_detect(cpu)}" \ + " %{mtune=native:%<mtune=native %:local_cpu_detect(tune)}" +#else +# define MCPU_MTUNE_NATIVE_SPECS "" +#endif + +#define DRIVER_SELF_SPECS MCPU_MTUNE_NATIVE_SPECS + /* This is for -profile to use -lc_p instead of -lc. */ #undef CC1_SPEC #define CC1_SPEC "%{profile:-p} \ diff --git a/gcc/config/sparc/linux64.h b/gcc/config/sparc/linux64.h index 7f8b37891cf..3c83d2d0a6e 100644 --- a/gcc/config/sparc/linux64.h +++ b/gcc/config/sparc/linux64.h @@ -31,18 +31,11 @@ along with GCC; see the file COPYING3. If not see } \ while (0) -#if TARGET_CPU_DEFAULT == TARGET_CPU_v9 \ - || TARGET_CPU_DEFAULT == TARGET_CPU_ultrasparc \ - || TARGET_CPU_DEFAULT == TARGET_CPU_ultrasparc3 \ - || TARGET_CPU_DEFAULT == TARGET_CPU_niagara \ - || TARGET_CPU_DEFAULT == TARGET_CPU_niagara2 -/* A 64 bit v9 compiler with stack-bias, - in a Medium/Low code model environment. */ - +#ifdef TARGET_64BIT_DEFAULT #undef TARGET_DEFAULT #define TARGET_DEFAULT \ - (MASK_V9 + MASK_PTR64 + MASK_64BIT /* + MASK_HARD_QUAD */ \ - + MASK_STACK_BIAS + MASK_APP_REGS + MASK_FPU + MASK_LONG_DOUBLE_128) + (MASK_V9 + MASK_PTR64 + MASK_64BIT + MASK_STACK_BIAS + \ + MASK_APP_REGS + MASK_FPU + MASK_LONG_DOUBLE_128) #endif /* This must be v9a not just v9 because by default we enable @@ -142,6 +135,22 @@ along with GCC; see the file COPYING3. If not see %{!mno-relax:%{!r:-relax}} \ " +/* -mcpu=native handling only makes sense with compiler running on + a SPARC chip. */ +#if defined(__sparc__) +extern const char *host_detect_local_cpu (int argc, const char **argv); +# define EXTRA_SPEC_FUNCTIONS \ + { "local_cpu_detect", host_detect_local_cpu }, + +# define MCPU_MTUNE_NATIVE_SPECS \ + " %{mcpu=native:%<mcpu=native %:local_cpu_detect(cpu)}" \ + " %{mtune=native:%<mtune=native %:local_cpu_detect(tune)}" +#else +# define MCPU_MTUNE_NATIVE_SPECS "" +#endif + +#define DRIVER_SELF_SPECS MCPU_MTUNE_NATIVE_SPECS + #undef CC1_SPEC #if DEFAULT_ARCH32_P #define CC1_SPEC "%{profile:-p} \ diff --git a/gcc/config/sparc/niagara2.md b/gcc/config/sparc/niagara2.md index 298ebe013f9..9d899f288d9 100644 --- a/gcc/config/sparc/niagara2.md +++ b/gcc/config/sparc/niagara2.md @@ -1,5 +1,5 @@ -;; Scheduling description for Niagara-2. -;; Copyright (C) 2007 Free Software Foundation, Inc. +;; Scheduling description for Niagara-2 and Niagara-3. +;; Copyright (C) 2007, 2011 Free Software Foundation, Inc. ;; ;; This file is part of GCC. ;; @@ -17,74 +17,74 @@ ;; along with GCC; see the file COPYING3. If not see ;; <http://www.gnu.org/licenses/>. -;; Niagara-2 is a single-issue processor. +;; Niagara-2 and Niagara-3 are single-issue processors. (define_automaton "niagara2_0") (define_cpu_unit "niag2_pipe" "niagara2_0") (define_insn_reservation "niag2_25cycle" 25 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "flushw")) "niag2_pipe*25") (define_insn_reservation "niag2_5cycle" 5 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "multi,flushw,iflush,trap")) "niag2_pipe*5") (define_insn_reservation "niag2_6cycle" 4 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "savew")) "niag2_pipe*4") /* Most basic operations are single-cycle. */ (define_insn_reservation "niag2_ialu" 1 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "ialu,shift,compare,cmove")) "niag2_pipe") (define_insn_reservation "niag2_imul" 5 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "imul")) "niag2_pipe*5") (define_insn_reservation "niag2_idiv" 31 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "idiv")) "niag2_pipe*31") (define_insn_reservation "niag2_branch" 5 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "call,sibcall,call_no_delay_slot,uncond_branch,branch")) "niag2_pipe*5") (define_insn_reservation "niag2_3cycle_load" 3 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "load,fpload")) "niag2_pipe*3") (define_insn_reservation "niag2_1cycle_store" 1 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "store,fpstore")) "niag2_pipe") (define_insn_reservation "niag2_fp" 3 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "fpmove,fpcmove,fpcrmove,fpcmp,fpmul")) "niag2_pipe*3") (define_insn_reservation "niag2_fdivs" 19 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "fpdivs")) "niag2_pipe*19") (define_insn_reservation "niag2_fdivd" 33 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "fpdivd")) "niag2_pipe*33") (define_insn_reservation "niag2_vis" 6 - (and (eq_attr "cpu" "niagara2") + (and (eq_attr "cpu" "niagara2,niagara3") (eq_attr "type" "fga,fgm_pack,fgm_mul,fgm_cmp,fgm_pdist")) "niag2_pipe*6") diff --git a/gcc/config/sparc/sol2.h b/gcc/config/sparc/sol2.h index 86afbbefe52..bd58c9f8c7b 100644 --- a/gcc/config/sparc/sol2.h +++ b/gcc/config/sparc/sol2.h @@ -121,6 +121,28 @@ along with GCC; see the file COPYING3. If not see #define ASM_CPU_DEFAULT_SPEC ASM_CPU32_DEFAULT_SPEC #endif +#if TARGET_CPU_DEFAULT == TARGET_CPU_niagara3 +#undef CPP_CPU64_DEFAULT_SPEC +#define CPP_CPU64_DEFAULT_SPEC "" +#undef ASM_CPU32_DEFAULT_SPEC +#define ASM_CPU32_DEFAULT_SPEC "-xarch=v8plusb" +#undef ASM_CPU64_DEFAULT_SPEC +#define ASM_CPU64_DEFAULT_SPEC AS_SPARC64_FLAG "b" +#undef ASM_CPU_DEFAULT_SPEC +#define ASM_CPU_DEFAULT_SPEC ASM_CPU32_DEFAULT_SPEC +#endif + +#if TARGET_CPU_DEFAULT == TARGET_CPU_niagara4 +#undef CPP_CPU64_DEFAULT_SPEC +#define CPP_CPU64_DEFAULT_SPEC "" +#undef ASM_CPU32_DEFAULT_SPEC +#define ASM_CPU32_DEFAULT_SPEC "-xarch=v8plusb" +#undef ASM_CPU64_DEFAULT_SPEC +#define ASM_CPU64_DEFAULT_SPEC AS_SPARC64_FLAG "b" +#undef ASM_CPU_DEFAULT_SPEC +#define ASM_CPU_DEFAULT_SPEC ASM_CPU32_DEFAULT_SPEC +#endif + /* Both Sun as and GNU as understand -K PIC. */ #undef ASM_SPEC #define ASM_SPEC ASM_SPEC_BASE ASM_PIC_SPEC @@ -131,7 +153,7 @@ along with GCC; see the file COPYING3. If not see %{mcpu=sparclite|mcpu-f930|mcpu=f934:-D__sparclite__} \ %{mcpu=v8:" DEF_ARCH32_SPEC("-D__sparcv8") "} \ %{mcpu=supersparc:-D__supersparc__ " DEF_ARCH32_SPEC("-D__sparcv8") "} \ -%{mcpu=v9|mcpu=ultrasparc|mcpu=ultrasparc3|mcpu=niagara|mcpu=niagara2:" DEF_ARCH32_SPEC("-D__sparcv8") "} \ +%{mcpu=v9|mcpu=ultrasparc|mcpu=ultrasparc3|mcpu=niagara|mcpu=niagara2|mcpu=niagara3|mcpu=niagara4:" DEF_ARCH32_SPEC("-D__sparcv8") "} \ %{!mcpu*:%(cpp_cpu_default)} \ " @@ -218,7 +240,9 @@ extern const char *host_detect_local_cpu (int argc, const char **argv); %{mcpu=ultrasparc3:" DEF_ARCH32_SPEC("-xarch=v8plusb") DEF_ARCH64_SPEC(AS_SPARC64_FLAG "b") "} \ %{mcpu=niagara:" DEF_ARCH32_SPEC("-xarch=v8plusb") DEF_ARCH64_SPEC(AS_SPARC64_FLAG "b") "} \ %{mcpu=niagara2:" DEF_ARCH32_SPEC("-xarch=v8plusb") DEF_ARCH64_SPEC(AS_SPARC64_FLAG "b") "} \ -%{!mcpu=niagara2:%{!mcpu=niagara:%{!mcpu=ultrasparc3:%{!mcpu=ultrasparc:%{!mcpu=v9:%{mcpu*:" DEF_ARCH32_SPEC("-xarch=v8") DEF_ARCH64_SPEC(AS_SPARC64_FLAG) "}}}}}} \ +%{mcpu=niagara3:" DEF_ARCH32_SPEC("-xarch=v8plusb") DEF_ARCH64_SPEC(AS_SPARC64_FLAG "b") "} \ +%{mcpu=niagara4:" DEF_ARCH32_SPEC("-xarch=v8plusb") DEF_ARCH64_SPEC(AS_SPARC64_FLAG "b") "} \ +%{!mcpu=niagara4:%{!mcpu=niagara3:%{!mcpu=niagara2:%{!mcpu=niagara:%{!mcpu=ultrasparc3:%{!mcpu=ultrasparc:%{!mcpu=v9:%{mcpu*:" DEF_ARCH32_SPEC("-xarch=v8") DEF_ARCH64_SPEC(AS_SPARC64_FLAG) "}}}}}}}} \ %{!mcpu*:%(asm_cpu_default)} \ " diff --git a/gcc/config/sparc/sparc-opts.h b/gcc/config/sparc/sparc-opts.h index aef69b4d3c9..266cb1403ac 100644 --- a/gcc/config/sparc/sparc-opts.h +++ b/gcc/config/sparc/sparc-opts.h @@ -42,6 +42,8 @@ enum processor_type { PROCESSOR_ULTRASPARC3, PROCESSOR_NIAGARA, PROCESSOR_NIAGARA2, + PROCESSOR_NIAGARA3, + PROCESSOR_NIAGARA4, PROCESSOR_NATIVE }; diff --git a/gcc/config/sparc/sparc.c b/gcc/config/sparc/sparc.c index de9a7eb6929..cf9e1971562 100644 --- a/gcc/config/sparc/sparc.c +++ b/gcc/config/sparc/sparc.c @@ -709,6 +709,8 @@ sparc_option_override (void) { TARGET_CPU_ultrasparc3, PROCESSOR_ULTRASPARC3 }, { TARGET_CPU_niagara, PROCESSOR_NIAGARA }, { TARGET_CPU_niagara2, PROCESSOR_NIAGARA2 }, + { TARGET_CPU_niagara3, PROCESSOR_NIAGARA3 }, + { TARGET_CPU_niagara4, PROCESSOR_NIAGARA4 }, { -1, PROCESSOR_V7 } }; const struct cpu_default *def; @@ -749,6 +751,10 @@ sparc_option_override (void) MASK_V9|MASK_DEPRECATED_V8_INSNS}, /* UltraSPARC T2 */ { MASK_ISA, MASK_V9}, + /* UltraSPARC T3 */ + { MASK_ISA, MASK_V9}, + /* UltraSPARC T4 */ + { MASK_ISA, MASK_V9}, }; const struct cpu_table *cpu; unsigned int i; @@ -857,7 +863,9 @@ sparc_option_override (void) && (sparc_cpu == PROCESSOR_ULTRASPARC || sparc_cpu == PROCESSOR_ULTRASPARC3 || sparc_cpu == PROCESSOR_NIAGARA - || sparc_cpu == PROCESSOR_NIAGARA2)) + || sparc_cpu == PROCESSOR_NIAGARA2 + || sparc_cpu == PROCESSOR_NIAGARA3 + || sparc_cpu == PROCESSOR_NIAGARA4)) align_functions = 32; /* Validate PCC_STRUCT_RETURN. */ @@ -909,6 +917,8 @@ sparc_option_override (void) sparc_costs = &niagara_costs; break; case PROCESSOR_NIAGARA2: + case PROCESSOR_NIAGARA3: + case PROCESSOR_NIAGARA4: sparc_costs = &niagara2_costs; break; case PROCESSOR_NATIVE: @@ -923,7 +933,9 @@ sparc_option_override (void) maybe_set_param_value (PARAM_SIMULTANEOUS_PREFETCHES, ((sparc_cpu == PROCESSOR_ULTRASPARC || sparc_cpu == PROCESSOR_NIAGARA - || sparc_cpu == PROCESSOR_NIAGARA2) + || sparc_cpu == PROCESSOR_NIAGARA2 + || sparc_cpu == PROCESSOR_NIAGARA3 + || sparc_cpu == PROCESSOR_NIAGARA4) ? 2 : (sparc_cpu == PROCESSOR_ULTRASPARC3 ? 8 : 3)), @@ -933,7 +945,9 @@ sparc_option_override (void) ((sparc_cpu == PROCESSOR_ULTRASPARC || sparc_cpu == PROCESSOR_ULTRASPARC3 || sparc_cpu == PROCESSOR_NIAGARA - || sparc_cpu == PROCESSOR_NIAGARA2) + || sparc_cpu == PROCESSOR_NIAGARA2 + || sparc_cpu == PROCESSOR_NIAGARA3 + || sparc_cpu == PROCESSOR_NIAGARA4) ? 64 : 32), global_options.x_param_values, global_options_set.x_param_values); @@ -8342,7 +8356,9 @@ sparc32_initialize_trampoline (rtx m_tramp, rtx fnaddr, rtx cxt) if (sparc_cpu != PROCESSOR_ULTRASPARC && sparc_cpu != PROCESSOR_ULTRASPARC3 && sparc_cpu != PROCESSOR_NIAGARA - && sparc_cpu != PROCESSOR_NIAGARA2) + && sparc_cpu != PROCESSOR_NIAGARA2 + && sparc_cpu != PROCESSOR_NIAGARA3 + && sparc_cpu != PROCESSOR_NIAGARA4) emit_insn (gen_flush (validize_mem (adjust_address (m_tramp, SImode, 8)))); /* Call __enable_execute_stack after writing onto the stack to make sure @@ -8385,7 +8401,9 @@ sparc64_initialize_trampoline (rtx m_tramp, rtx fnaddr, rtx cxt) if (sparc_cpu != PROCESSOR_ULTRASPARC && sparc_cpu != PROCESSOR_ULTRASPARC3 && sparc_cpu != PROCESSOR_NIAGARA - && sparc_cpu != PROCESSOR_NIAGARA2) + && sparc_cpu != PROCESSOR_NIAGARA2 + && sparc_cpu != PROCESSOR_NIAGARA3 + && sparc_cpu != PROCESSOR_NIAGARA4) emit_insn (gen_flushdi (validize_mem (adjust_address (m_tramp, DImode, 8)))); /* Call __enable_execute_stack after writing onto the stack to make sure @@ -8578,7 +8596,9 @@ static int sparc_use_sched_lookahead (void) { if (sparc_cpu == PROCESSOR_NIAGARA - || sparc_cpu == PROCESSOR_NIAGARA2) + || sparc_cpu == PROCESSOR_NIAGARA2 + || sparc_cpu == PROCESSOR_NIAGARA3 + || sparc_cpu == PROCESSOR_NIAGARA4) return 0; if (sparc_cpu == PROCESSOR_ULTRASPARC || sparc_cpu == PROCESSOR_ULTRASPARC3) @@ -8597,6 +8617,8 @@ sparc_issue_rate (void) { case PROCESSOR_NIAGARA: case PROCESSOR_NIAGARA2: + case PROCESSOR_NIAGARA3: + case PROCESSOR_NIAGARA4: default: return 1; case PROCESSOR_V9: @@ -9635,7 +9657,9 @@ sparc_register_move_cost (enum machine_mode mode ATTRIBUTE_UNUSED, if (sparc_cpu == PROCESSOR_ULTRASPARC || sparc_cpu == PROCESSOR_ULTRASPARC3 || sparc_cpu == PROCESSOR_NIAGARA - || sparc_cpu == PROCESSOR_NIAGARA2) + || sparc_cpu == PROCESSOR_NIAGARA2 + || sparc_cpu == PROCESSOR_NIAGARA3 + || sparc_cpu == PROCESSOR_NIAGARA4) return 12; return 6; diff --git a/gcc/config/sparc/sparc.h b/gcc/config/sparc/sparc.h index 81308e79b3d..afdca1e3aab 100644 --- a/gcc/config/sparc/sparc.h +++ b/gcc/config/sparc/sparc.h @@ -208,8 +208,8 @@ extern enum cmodel sparc_cmodel; which requires the following macro to be true if enabled. Prior to V9, there are no instructions to even talk about memory synchronization. Note that the UltraSPARC III processors don't implement RMO, unlike the - UltraSPARC II processors. Niagara and Niagara-2 do not implement RMO - either. + UltraSPARC II processors. Niagara, Niagara-2, and Niagara-3 do not + implement RMO either. Default to false; for example, Solaris never enables RMO, only ever uses total memory ordering (TMO). */ @@ -247,12 +247,16 @@ extern enum cmodel sparc_cmodel; #define TARGET_CPU_ultrasparc3 10 #define TARGET_CPU_niagara 11 #define TARGET_CPU_niagara2 12 +#define TARGET_CPU_niagara3 13 +#define TARGET_CPU_niagara4 14 #if TARGET_CPU_DEFAULT == TARGET_CPU_v9 \ || TARGET_CPU_DEFAULT == TARGET_CPU_ultrasparc \ || TARGET_CPU_DEFAULT == TARGET_CPU_ultrasparc3 \ || TARGET_CPU_DEFAULT == TARGET_CPU_niagara \ - || TARGET_CPU_DEFAULT == TARGET_CPU_niagara2 + || TARGET_CPU_DEFAULT == TARGET_CPU_niagara2 \ + || TARGET_CPU_DEFAULT == TARGET_CPU_niagara3 \ + || TARGET_CPU_DEFAULT == TARGET_CPU_niagara4 #define CPP_CPU32_DEFAULT_SPEC "" #define ASM_CPU32_DEFAULT_SPEC "" @@ -281,6 +285,14 @@ extern enum cmodel sparc_cmodel; #define CPP_CPU64_DEFAULT_SPEC "-D__sparc_v9__" #define ASM_CPU64_DEFAULT_SPEC "-Av9b" #endif +#if TARGET_CPU_DEFAULT == TARGET_CPU_niagara3 +#define CPP_CPU64_DEFAULT_SPEC "-D__sparc_v9__" +#define ASM_CPU64_DEFAULT_SPEC "-Av9b" +#endif +#if TARGET_CPU_DEFAULT == TARGET_CPU_niagara4 +#define CPP_CPU64_DEFAULT_SPEC "-D__sparc_v9__" +#define ASM_CPU64_DEFAULT_SPEC "-Av9b" +#endif #else @@ -373,6 +385,8 @@ extern enum cmodel sparc_cmodel; %{mcpu=ultrasparc3:-D__sparc_v9__} \ %{mcpu=niagara:-D__sparc_v9__} \ %{mcpu=niagara2:-D__sparc_v9__} \ +%{mcpu=niagara3:-D__sparc_v9__} \ +%{mcpu=niagara4:-D__sparc_v9__} \ %{!mcpu*:%(cpp_cpu_default)} \ " #define CPP_ARCH32_SPEC "" @@ -417,6 +431,8 @@ extern enum cmodel sparc_cmodel; %{mcpu=ultrasparc3:%{!mv8plus:-Av9b}} \ %{mcpu=niagara:%{!mv8plus:-Av9b}} \ %{mcpu=niagara2:%{!mv8plus:-Av9b}} \ +%{mcpu=niagara3:%{!mv8plus:-Av9b}} \ +%{mcpu=niagara4:%{!mv8plus:-Av9b}} \ %{!mcpu*:%(asm_cpu_default)} \ " @@ -1658,8 +1674,8 @@ do { \ On Niagara, normal branches insert 3 bubbles into the pipe and annulled branches insert 4 bubbles. - On Niagara-2, a not-taken branch costs 1 cycle whereas a taken - branch costs 6 cycles. */ + On Niagara-2 and Niagara-3, a not-taken branch costs 1 cycle whereas + a taken branch costs 6 cycles. */ #define BRANCH_COST(speed_p, predictable_p) \ ((sparc_cpu == PROCESSOR_V9 \ @@ -1669,7 +1685,8 @@ do { \ ? 9 \ : (sparc_cpu == PROCESSOR_NIAGARA \ ? 4 \ - : (sparc_cpu == PROCESSOR_NIAGARA2 \ + : ((sparc_cpu == PROCESSOR_NIAGARA2 \ + || sparc_cpu == PROCESSOR_NIAGARA3) \ ? 5 \ : 3)))) diff --git a/gcc/config/sparc/sparc.md b/gcc/config/sparc/sparc.md index 7d5d6dc4410..721db934a36 100644 --- a/gcc/config/sparc/sparc.md +++ b/gcc/config/sparc/sparc.md @@ -115,7 +115,9 @@ ultrasparc, ultrasparc3, niagara, - niagara2" + niagara2, + niagara3, + niagara4" (const (symbol_ref "sparc_cpu_attr"))) ;; Attribute for the instruction set. diff --git a/gcc/config/sparc/sparc.opt b/gcc/config/sparc/sparc.opt index 84bf2883c4b..ce6fa94fde8 100644 --- a/gcc/config/sparc/sparc.opt +++ b/gcc/config/sparc/sparc.opt @@ -154,6 +154,12 @@ Enum(sparc_processor_type) String(niagara) Value(PROCESSOR_NIAGARA) EnumValue Enum(sparc_processor_type) String(niagara2) Value(PROCESSOR_NIAGARA2) +EnumValue +Enum(sparc_processor_type) String(niagara3) Value(PROCESSOR_NIAGARA3) + +EnumValue +Enum(sparc_processor_type) String(niagara4) Value(PROCESSOR_NIAGARA4) + mcmodel= Target RejectNegative Joined Var(sparc_cmodel_string) Use given SPARC-V9 code model diff --git a/gcc/config/spu/spu.md b/gcc/config/spu/spu.md index 5742e0d96c1..676d54e8de0 100644 --- a/gcc/config/spu/spu.md +++ b/gcc/config/spu/spu.md @@ -3874,7 +3874,7 @@ selb\t%0,%4,%0,%3" ;; vector conditional compare patterns -(define_expand "vcond<mode>" +(define_expand "vcond<mode><mode>" [(set (match_operand:VCMP 0 "spu_reg_operand" "=r") (if_then_else:VCMP (match_operator 3 "comparison_operator" @@ -3891,7 +3891,7 @@ selb\t%0,%4,%0,%3" FAIL; }) -(define_expand "vcondu<mode>" +(define_expand "vcondu<mode><mode>" [(set (match_operand:VCMPU 0 "spu_reg_operand" "=r") (if_then_else:VCMPU (match_operator 3 "comparison_operator" diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index 96ac2377be3..2fe60fe03c7 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,47 @@ +2011-09-06 Jason Merrill <jason@redhat.com> + + PR c++/50296 + * semantics.c (register_constexpr_fundef): Call is_valid_constexpr_fn. + (cx_check_missing_mem_inits): Handle bases and empty trivial members. + (validate_constexpr_fundecl): Remove. + * decl.c (start_preparsed_function): Don't call it. + * cp-tree.h: Don't declare it. + +2011-09-04 Jason Merrill <jason@redhat.com> + + PR c++/49267 + * call.c (reference_binding): Don't set is_lvalue for an rvalue + reference rfrom. + + PR c++/49267 + PR c++/49458 + DR 1328 + * call.c (reference_binding): Set rvaluedness_matches_p properly + for reference to function conversion ops. + (compare_ics): Adjust. + + * class.c (trivial_default_constructor_is_constexpr): Rename from + synthesized_default_constructor_is_constexpr. + (type_has_constexpr_default_constructor): Adjust. + (add_implicitly_declared_members): Call it instead. + (explain_non_literal_class): Explain about non-constexpr default ctor. + * cp-tree.h: Adjust. + * method.c (synthesized_method_walk): Adjust. + * semantics.c (explain_invalid_constexpr_fn): Handle defaulted + functions, too. + + PR c++/50248 + Core 1358 + * init.c (perform_member_init): Don't diagnose missing inits here. + (emit_mem_initializers): Or here. + * method.c (process_subob_fn): Don't instantiate constexpr ctors. + * semantics.c (cx_check_missing_mem_inits): New. + (explain_invalid_constexpr_fn): Call it. + (register_constexpr_fundef): Likewise. Leave + DECL_DECLARED_CONSTEXPR_P set when the body is unsuitable. + (cxx_eval_call_expression): Adjust diagnostics. + (cxx_eval_constant_expression): Catch use of 'this' in a constructor. + 2011-08-30 Jason Merrill <jason@redhat.com> PR c++/50084 diff --git a/gcc/cp/call.c b/gcc/cp/call.c index 84212603b1a..c707d663e24 100644 --- a/gcc/cp/call.c +++ b/gcc/cp/call.c @@ -1576,9 +1576,10 @@ reference_binding (tree rto, tree rfrom, tree expr, bool c_cast_p, int flags) if (TREE_CODE (from) == REFERENCE_TYPE) { - /* Anything with reference type is an lvalue. */ - is_lvalue = clk_ordinary; from = TREE_TYPE (from); + if (!TYPE_REF_IS_RVALUE (rfrom) + || TREE_CODE (from) == FUNCTION_TYPE) + is_lvalue = clk_ordinary; } if (expr && BRACE_ENCLOSED_INITIALIZER_P (expr)) @@ -1652,6 +1653,10 @@ reference_binding (tree rto, tree rfrom, tree expr, bool c_cast_p, int flags) /* The top-level caller requested that we pretend that the lvalue be treated as an rvalue. */ conv->rvaluedness_matches_p = TYPE_REF_IS_RVALUE (rto); + else if (TREE_CODE (rfrom) == REFERENCE_TYPE) + /* Handle rvalue reference to function properly. */ + conv->rvaluedness_matches_p + = (TYPE_REF_IS_RVALUE (rto) == TYPE_REF_IS_RVALUE (rfrom)); else conv->rvaluedness_matches_p = (TYPE_REF_IS_RVALUE (rto) == !is_lvalue); @@ -7960,13 +7965,13 @@ compare_ics (conversion *ics1, conversion *ics2) if (ref_conv1 && ref_conv2) { - if (!ref_conv1->this_p && !ref_conv2->this_p - && (TYPE_REF_IS_RVALUE (ref_conv1->type) - != TYPE_REF_IS_RVALUE (ref_conv2->type))) + if (!ref_conv1->this_p && !ref_conv2->this_p) { - if (ref_conv1->rvaluedness_matches_p) + if (ref_conv1->rvaluedness_matches_p + > ref_conv2->rvaluedness_matches_p) return 1; - if (ref_conv2->rvaluedness_matches_p) + if (ref_conv2->rvaluedness_matches_p + > ref_conv1->rvaluedness_matches_p) return -1; } diff --git a/gcc/cp/class.c b/gcc/cp/class.c index 2a4bc77aa5e..a4a7468bad1 100644 --- a/gcc/cp/class.c +++ b/gcc/cp/class.c @@ -2726,7 +2726,8 @@ add_implicitly_declared_members (tree t, CLASSTYPE_LAZY_DEFAULT_CTOR (t) = 1; if (cxx_dialect >= cxx0x) TYPE_HAS_CONSTEXPR_CTOR (t) - = synthesized_default_constructor_is_constexpr (t); + /* This might force the declaration. */ + = type_has_constexpr_default_constructor (t); } /* [class.ctor] @@ -4355,15 +4356,15 @@ type_has_user_provided_default_constructor (tree t) return false; } -/* Returns true iff for class T, a synthesized default constructor +/* Returns true iff for class T, a trivial synthesized default constructor would be constexpr. */ bool -synthesized_default_constructor_is_constexpr (tree t) +trivial_default_constructor_is_constexpr (tree t) { - /* A defaulted default constructor is constexpr + /* A defaulted trivial default constructor is constexpr if there is nothing to initialize. */ - /* FIXME adjust for non-static data member initializers. */ + gcc_assert (!TYPE_HAS_COMPLEX_DFLT (t)); return is_really_empty_class (t); } @@ -4381,7 +4382,12 @@ type_has_constexpr_default_constructor (tree t) return false; } if (CLASSTYPE_LAZY_DEFAULT_CTOR (t)) - return synthesized_default_constructor_is_constexpr (t); + { + if (!TYPE_HAS_COMPLEX_DFLT (t)) + return trivial_default_constructor_is_constexpr (t); + /* Non-trivial, we need to check subobject constructors. */ + lazily_declare_fn (sfk_constructor, t); + } fns = locate_ctor (t); return (fns && DECL_DECLARED_CONSTEXPR_P (fns)); } @@ -4608,9 +4614,14 @@ explain_non_literal_class (tree t) else if (CLASSTYPE_NON_AGGREGATE (t) && !TYPE_HAS_TRIVIAL_DFLT (t) && !TYPE_HAS_CONSTEXPR_CTOR (t)) - inform (0, " %q+T is not an aggregate, does not have a trivial " - "default constructor, and has no constexpr constructor that " - "is not a copy or move constructor", t); + { + inform (0, " %q+T is not an aggregate, does not have a trivial " + "default constructor, and has no constexpr constructor that " + "is not a copy or move constructor", t); + if (TYPE_HAS_DEFAULT_CONSTRUCTOR (t) + && !type_has_user_provided_default_constructor (t)) + explain_invalid_constexpr_fn (locate_ctor (t)); + } else { tree binfo, base_binfo, field; int i; diff --git a/gcc/cp/cp-tree.h b/gcc/cp/cp-tree.h index d18599b0c53..ae4cd075f91 100644 --- a/gcc/cp/cp-tree.h +++ b/gcc/cp/cp-tree.h @@ -4823,7 +4823,7 @@ extern tree in_class_defaulted_default_constructor (tree); extern bool user_provided_p (tree); extern bool type_has_user_provided_constructor (tree); extern bool type_has_user_provided_default_constructor (tree); -extern bool synthesized_default_constructor_is_constexpr (tree); +extern bool trivial_default_constructor_is_constexpr (tree); extern bool type_has_constexpr_default_constructor (tree); extern bool type_has_virtual_destructor (tree); extern bool type_has_move_constructor (tree); @@ -5367,7 +5367,6 @@ extern void finish_handler_parms (tree, tree); extern void finish_handler (tree); extern void finish_cleanup (tree, tree); extern bool literal_type_p (tree); -extern tree validate_constexpr_fundecl (tree); extern tree register_constexpr_fundef (tree, tree); extern bool check_constexpr_ctor_body (tree, tree); extern tree ensure_literal_type_for_constexpr_object (tree); diff --git a/gcc/cp/decl.c b/gcc/cp/decl.c index 39a0b0e22fc..eed45352871 100644 --- a/gcc/cp/decl.c +++ b/gcc/cp/decl.c @@ -12659,10 +12659,6 @@ start_preparsed_function (tree decl1, tree attrs, int flags) maybe_apply_pragma_weak (decl1); } - /* constexpr functions must have literal argument types and - literal return type. */ - validate_constexpr_fundecl (decl1); - /* Reset this in case the call to pushdecl changed it. */ current_function_decl = decl1; diff --git a/gcc/cp/init.c b/gcc/cp/init.c index 847f5199f1b..ff1884b361d 100644 --- a/gcc/cp/init.c +++ b/gcc/cp/init.c @@ -606,15 +606,6 @@ perform_member_init (tree member, tree init) core_type = strip_array_types (type); - if (DECL_DECLARED_CONSTEXPR_P (current_function_decl) - && !type_has_constexpr_default_constructor (core_type)) - { - if (!DECL_TEMPLATE_INSTANTIATION (current_function_decl)) - error ("uninitialized member %qD in %<constexpr%> constructor", - member); - DECL_DECLARED_CONSTEXPR_P (current_function_decl) = false; - } - if (CLASS_TYPE_P (core_type) && (CLASSTYPE_READONLY_FIELDS_NEED_INIT (core_type) || CLASSTYPE_REF_FIELDS_NEED_INIT (core_type))) @@ -962,16 +953,6 @@ emit_mem_initializers (tree mem_inits) OPT_Wextra, "base class %q#T should be explicitly " "initialized in the copy constructor", BINFO_TYPE (subobject)); - - if (DECL_DECLARED_CONSTEXPR_P (current_function_decl) - && !(type_has_constexpr_default_constructor - (BINFO_TYPE (subobject)))) - { - if (!DECL_TEMPLATE_INSTANTIATION (current_function_decl)) - error ("uninitialized base %qT in %<constexpr%> constructor", - BINFO_TYPE (subobject)); - DECL_DECLARED_CONSTEXPR_P (current_function_decl) = false; - } } /* Initialize the base. */ diff --git a/gcc/cp/method.c b/gcc/cp/method.c index 3d272a33f61..5b24f8f0285 100644 --- a/gcc/cp/method.c +++ b/gcc/cp/method.c @@ -952,23 +952,14 @@ process_subob_fn (tree fn, bool move_p, tree *spec_p, bool *trivial_p, goto bad; } - if (constexpr_p) + if (constexpr_p && !DECL_DECLARED_CONSTEXPR_P (fn)) { - /* If this is a specialization of a constexpr template, we need to - force the instantiation now so that we know whether or not it's - really constexpr. */ - if (DECL_DECLARED_CONSTEXPR_P (fn) && DECL_TEMPLATE_INSTANTIATION (fn) - && !DECL_TEMPLATE_INSTANTIATED (fn)) - instantiate_decl (fn, /*defer_ok*/false, /*expl_class*/false); - if (!DECL_DECLARED_CONSTEXPR_P (fn)) + *constexpr_p = false; + if (msg) { - *constexpr_p = false; - if (msg) - { - inform (0, "defaulted constructor calls non-constexpr " - "%q+D", fn); - explain_invalid_constexpr_fn (fn); - } + inform (0, "defaulted constructor calls non-constexpr " + "%q+D", fn); + explain_invalid_constexpr_fn (fn); } } @@ -1196,7 +1187,7 @@ synthesized_method_walk (tree ctype, special_function_kind sfk, bool const_p, && (!copy_arg_p || cxx_dialect < cxx0x)) { if (constexpr_p && sfk == sfk_constructor) - *constexpr_p = synthesized_default_constructor_is_constexpr (ctype); + *constexpr_p = trivial_default_constructor_is_constexpr (ctype); return; } diff --git a/gcc/cp/semantics.c b/gcc/cp/semantics.c index ce84062f918..f782df9ec36 100644 --- a/gcc/cp/semantics.c +++ b/gcc/cp/semantics.c @@ -5485,7 +5485,6 @@ is_valid_constexpr_fn (tree fun, bool complain) } } - /* Check this again here for cxx_eval_call_expression. */ if (DECL_NONSTATIC_MEMBER_FUNCTION_P (fun) && !CLASSTYPE_LITERAL_P (DECL_CONTEXT (fun))) { @@ -5502,29 +5501,6 @@ is_valid_constexpr_fn (tree fun, bool complain) return ret; } -/* Return non-null if FUN certainly designates a valid constexpr function - declaration. Otherwise return NULL. Issue appropriate diagnostics - if necessary. Note that we only check the declaration, not the body - of the function. */ - -tree -validate_constexpr_fundecl (tree fun) -{ - if (processing_template_decl || !DECL_DECLARED_CONSTEXPR_P (fun)) - return NULL; - else if (DECL_CLONED_FUNCTION_P (fun)) - /* We already checked the original function. */ - return fun; - - if (!is_valid_constexpr_fn (fun, !DECL_TEMPLATE_INFO (fun))) - { - DECL_DECLARED_CONSTEXPR_P (fun) = false; - return NULL; - } - - return fun; -} - /* Subroutine of build_constexpr_constructor_member_initializers. The expression tree T represents a data member initialization in a (constexpr) constructor definition. Build a pairing of @@ -5775,6 +5751,63 @@ massage_constexpr_body (tree fun, tree body) return body; } +/* FUN is a constexpr constructor with massaged body BODY. Return true + if some bases/fields are uninitialized, and complain if COMPLAIN. */ + +static bool +cx_check_missing_mem_inits (tree fun, tree body, bool complain) +{ + bool bad; + tree field; + unsigned i, nelts; + + if (TREE_CODE (body) != CONSTRUCTOR) + return false; + + bad = false; + nelts = CONSTRUCTOR_NELTS (body); + field = TYPE_FIELDS (DECL_CONTEXT (fun)); + for (i = 0; i <= nelts; ++i) + { + tree index; + if (i == nelts) + index = NULL_TREE; + else + { + index = CONSTRUCTOR_ELT (body, i)->index; + /* Skip base and vtable inits. */ + if (TREE_CODE (index) != FIELD_DECL) + continue; + } + for (; field != index; field = DECL_CHAIN (field)) + { + tree ftype; + if (TREE_CODE (field) != FIELD_DECL + || (DECL_C_BIT_FIELD (field) && !DECL_NAME (field))) + continue; + if (!complain) + return true; + ftype = strip_array_types (TREE_TYPE (field)); + if (type_has_constexpr_default_constructor (ftype)) + { + /* It's OK to skip a member with a trivial constexpr ctor. + A constexpr ctor that isn't trivial should have been + added in by now. */ + gcc_checking_assert (!TYPE_HAS_COMPLEX_DFLT (ftype)); + continue; + } + error ("uninitialized member %qD in %<constexpr%> constructor", + field); + bad = true; + } + if (field == NULL_TREE) + break; + field = DECL_CHAIN (field); + } + + return bad; +} + /* We are processing the definition of the constexpr function FUN. Check that its BODY fulfills the propriate requirements and enter it in the constexpr function definition table. @@ -5787,6 +5820,9 @@ register_constexpr_fundef (tree fun, tree body) constexpr_fundef entry; constexpr_fundef **slot; + if (!is_valid_constexpr_fn (fun, !DECL_TEMPLATE_INFO (fun))) + return NULL; + body = massage_constexpr_body (fun, body); if (body == NULL_TREE || body == error_mark_node) { @@ -5797,12 +5833,15 @@ register_constexpr_fundef (tree fun, tree body) if (!potential_rvalue_constant_expression (body)) { - DECL_DECLARED_CONSTEXPR_P (fun) = false; if (!DECL_TEMPLATE_INFO (fun)) require_potential_rvalue_constant_expression (body); return NULL; } + if (DECL_CONSTRUCTOR_P (fun) + && cx_check_missing_mem_inits (fun, body, !DECL_TEMPLATE_INFO (fun))) + return NULL; + /* Create the constexpr function table if necessary. */ if (constexpr_fundef_table == NULL) constexpr_fundef_table = htab_create_ggc (101, @@ -5831,8 +5870,9 @@ explain_invalid_constexpr_fn (tree fun) static struct pointer_set_t *diagnosed; tree body; location_t save_loc; - /* Only diagnose instantiations of constexpr templates. */ - if (!is_instantiation_of_constexpr (fun)) + /* Only diagnose defaulted functions or instantiations. */ + if (!DECL_DEFAULTED_FN (fun) + && !is_instantiation_of_constexpr (fun)) return; if (diagnosed == NULL) diagnosed = pointer_set_create (); @@ -5842,8 +5882,7 @@ explain_invalid_constexpr_fn (tree fun) save_loc = input_location; input_location = DECL_SOURCE_LOCATION (fun); - inform (0, "%q+D is not constexpr because it does not satisfy the " - "requirements:", fun); + inform (0, "%q+D is not usable as a constexpr function because:", fun); /* First check the declaration. */ if (is_valid_constexpr_fn (fun, true)) { @@ -5854,6 +5893,8 @@ explain_invalid_constexpr_fn (tree fun) { body = massage_constexpr_body (fun, DECL_SAVED_TREE (fun)); require_potential_rvalue_constant_expression (body); + if (DECL_CONSTRUCTOR_P (fun)) + cx_check_missing_mem_inits (fun, body, true); } } input_location = save_loc; @@ -6203,7 +6244,16 @@ cxx_eval_call_expression (const constexpr_call *old_call, tree t, if (new_call.fundef == NULL || new_call.fundef->body == NULL) { if (!allow_non_constant) - error_at (loc, "%qD used before its definition", fun); + { + if (DECL_SAVED_TREE (fun)) + { + /* The definition of fun was somehow unsuitable. */ + error_at (loc, "%qD called in a constant expression", fun); + explain_invalid_constexpr_fn (fun); + } + else + error_at (loc, "%qD used before its definition", fun); + } *non_constant_p = true; return t; } @@ -7176,7 +7226,17 @@ cxx_eval_constant_expression (const constexpr_call *call, tree t, case PARM_DECL: if (call && DECL_CONTEXT (t) == call->fundef->decl) - r = lookup_parameter_binding (call, t); + { + if (DECL_ARTIFICIAL (t) && DECL_CONSTRUCTOR_P (DECL_CONTEXT (t))) + { + if (!allow_non_constant) + sorry ("use of the value of the object being constructed " + "in a constant expression"); + *non_constant_p = true; + } + else + r = lookup_parameter_binding (call, t); + } else if (addr) /* Defer in case this is only used for its type. */; else diff --git a/gcc/doc/configfiles.texi b/gcc/doc/configfiles.texi index d122225f38e..d8b15c5089b 100644 --- a/gcc/doc/configfiles.texi +++ b/gcc/doc/configfiles.texi @@ -59,6 +59,14 @@ these include the autoconfigured headers generated by machine. @item @file{tm_p.h}, which includes the header @file{@var{machine}-protos.h} -that contains prototypes for functions in the target @file{.c} file. -FIXME: why is such a separate header necessary? +that contains prototypes for functions in the target +@file{@var{machine}.c} file. The header @file{@var{machine}-protos.h} +can include prototypes of functions that use rtl and tree data +structures inside appropriate @code{#ifdef RTX_CODE} and @code{#ifdef +TREE_CODE} conditional code segements. The +@file{@var{machine}-protos.h} is included after the @file{rtl.h} +and/or @file{tree.h} would have been included. The @file{tm_p.h} also +includes the header @file{tm-preds.h} which is generated by +@file{genpreds} program during the build to define the declarations +and inline functions for the predicate functions. @end itemize diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index 1dd760d6264..3bca09cf649 100644 --- a/gcc/doc/invoke.texi +++ b/gcc/doc/invoke.texi @@ -9082,6 +9082,11 @@ The smallest number of different values for which it is best to use a jump-table instead of a tree of conditional branches. If the value is 0, use the default for the machine. The default is 0. +@item tree-reassoc-width +Set the maximum number of instructions executed in parallel in +reassociated tree. This parameter overrides target dependent +heuristics used by default if has non zero value. + @end table @end table @@ -17289,9 +17294,10 @@ for machine type @var{cpu_type}. Supported values for @var{cpu_type} are @samp{v7}, @samp{cypress}, @samp{v8}, @samp{supersparc}, @samp{hypersparc}, @samp{leon}, @samp{sparclite}, @samp{f930}, @samp{f934}, @samp{sparclite86x}, @samp{sparclet}, @samp{tsc701}, @samp{v9}, @samp{ultrasparc}, -@samp{ultrasparc3}, @samp{niagara} and @samp{niagara2}. +@samp{ultrasparc3}, @samp{niagara}, @samp{niagara2}, @samp{niagara3}, +and @samp{niagara4}. -Native Solaris toolchains also support the value @samp{native}, +Native Solaris and Linux toolchains also support the value @samp{native}, which selects the best architecture option for the host processor. @option{-mcpu=native} has no effect if GCC does not recognize the processor. @@ -17308,7 +17314,7 @@ implementations. v8: supersparc, hypersparc, leon sparclite: f930, f934, sparclite86x sparclet: tsc701 - v9: ultrasparc, ultrasparc3, niagara, niagara2 + v9: ultrasparc, ultrasparc3, niagara, niagara2, niagara3, niagara4 @end smallexample By default (unless configured otherwise), GCC generates code for the V7 @@ -17347,7 +17353,10 @@ optimizes it for the Sun UltraSPARC I/II/IIi chips. With Sun UltraSPARC III/III+/IIIi/IIIi+/IV/IV+ chips. With @option{-mcpu=niagara}, the compiler additionally optimizes it for Sun UltraSPARC T1 chips. With @option{-mcpu=niagara2}, the compiler -additionally optimizes it for Sun UltraSPARC T2 chips. +additionally optimizes it for Sun UltraSPARC T2 chips. With +@option{-mcpu=niagara3}, the compiler additionally optimizes it for Sun +UltraSPARC T3 chips. With @option{-mcpu=niagara4}, the compiler +additionally optimizes it for Sun UltraSPARC T4 chips. @item -mtune=@var{cpu_type} @opindex mtune @@ -17360,8 +17369,8 @@ The same values for @option{-mcpu=@var{cpu_type}} can be used for that select a particular CPU implementation. Those are @samp{cypress}, @samp{supersparc}, @samp{hypersparc}, @samp{leon}, @samp{f930}, @samp{f934}, @samp{sparclite86x}, @samp{tsc701}, @samp{ultrasparc}, @samp{ultrasparc3}, -@samp{niagara}, and @samp{niagara2}. With native Solaris toolchains, -@samp{native} can also be used. +@samp{niagara}, @samp{niagara2}, @samp{niagara3} and @samp{niagara4}. With +native Solaris and Linux toolchains, @samp{native} can also be used. @item -mv8plus @itemx -mno-v8plus diff --git a/gcc/doc/md.texi b/gcc/doc/md.texi index 7fc1a5ee2cc..1aa8552c5d4 100644 --- a/gcc/doc/md.texi +++ b/gcc/doc/md.texi @@ -4017,6 +4017,17 @@ and input vectors should have the same modes (@code{N} elements). The low Initialize the vector to given values. Operand 0 is the vector to initialize and operand 1 is parallel containing values for individual fields. +@cindex @code{vcond@var{m}@var{n}} instruction pattern +@item @samp{vcond@var{m}@var{n}} +Output a conditional vector move. Operand 0 is the destination to +receive a combination of operand 1 and operand 2, which are of mode @var{m}, +dependent on the outcome of the predicate in operand 3 which is a +vector comparison with operands of mode @var{n} in operands 4 and 5. The +modes @var{m} and @var{n} should have the same size. Operand 0 +will be set to the value @var{op1} & @var{msk} | @var{op2} & ~@var{msk} +where @var{msk} is computed by element-wise evaluation of the vector +comparison with a truth value of all-ones and a false value of all-zeros. + @cindex @code{push@var{m}1} instruction pattern @item @samp{push@var{m}1} Output a push instruction. Operand 0 is value to push. Used only when diff --git a/gcc/doc/tm.texi b/gcc/doc/tm.texi index 7364aa1c5ed..335c1d1f51d 100644 --- a/gcc/doc/tm.texi +++ b/gcc/doc/tm.texi @@ -6840,6 +6840,11 @@ the order of instructions is important for correctness when scheduling, but also the latencies of operations. @end deftypevr +@deftypefn {Target Hook} int TARGET_SCHED_REASSOCIATION_WIDTH (unsigned int @var{opc}, enum machine_mode @var{mode}) +This hook is called by tree reassociator to determine a level of +parallelism required in output calculations chain. +@end deftypefn + @node Sections @section Dividing the Output into Sections (Texts, Data, @dots{}) @c the above section title is WAY too long. maybe cut the part between diff --git a/gcc/doc/tm.texi.in b/gcc/doc/tm.texi.in index 4535fd65cef..67838269dff 100644 --- a/gcc/doc/tm.texi.in +++ b/gcc/doc/tm.texi.in @@ -6774,6 +6774,8 @@ in its second parameter. @hook TARGET_SCHED_EXPOSED_PIPELINE +@hook TARGET_SCHED_REASSOCIATION_WIDTH + @node Sections @section Dividing the Output into Sections (Texts, Data, @dots{}) @c the above section title is WAY too long. maybe cut the part between diff --git a/gcc/dwarf2out.c b/gcc/dwarf2out.c index a38bcf8f21c..c11f666bfbf 100644 --- a/gcc/dwarf2out.c +++ b/gcc/dwarf2out.c @@ -11695,12 +11695,22 @@ mem_loc_descriptor (rtx rtl, enum machine_mode mode, break; case MEM: + { + rtx new_rtl = avoid_constant_pool_reference (rtl); + if (new_rtl != rtl) + { + mem_loc_result = mem_loc_descriptor (new_rtl, mode, mem_mode, + initialized); + if (mem_loc_result != NULL) + return mem_loc_result; + } + } mem_loc_result = mem_loc_descriptor (XEXP (rtl, 0), get_address_mode (rtl), mode, VAR_INIT_STATUS_INITIALIZED); if (mem_loc_result == NULL) mem_loc_result = tls_mem_loc_descriptor (rtl); - if (mem_loc_result != 0) + if (mem_loc_result != NULL) { if (GET_MODE_SIZE (mode) > DWARF2_ADDR_SIZE || GET_MODE_CLASS (mode) != MODE_INT) @@ -11728,12 +11738,6 @@ mem_loc_descriptor (rtx rtl, enum machine_mode mode, new_loc_descr (DW_OP_deref_size, GET_MODE_SIZE (mode), 0)); } - else - { - rtx new_rtl = avoid_constant_pool_reference (rtl); - if (new_rtl != rtl) - return mem_loc_descriptor (new_rtl, mode, mem_mode, initialized); - } break; case LO_SUM: diff --git a/gcc/fold-const.c b/gcc/fold-const.c index 0f4ca5e6222..5807a5533ba 100644 --- a/gcc/fold-const.c +++ b/gcc/fold-const.c @@ -5888,9 +5888,11 @@ 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, we cannot do this since it will change - the result if the original computation overflowed. */ - if (TYPE_OVERFLOW_UNDEFINED (ctype) + 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))) && ((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 397aa771040..b8c5e0119ba 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2011-09-04 Janus Weil <janus@gcc.gnu.org> + + PR fortran/50227 + * trans-types.c (gfc_sym_type): Check for proc_name. + 2011-08-30 Tobias Burnus <burnus@net-b.de> PR fortran/45044 diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index f66878a1c89..43f1a19cc83 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2109,7 +2109,8 @@ gfc_sym_type (gfc_symbol * sym) { /* We must use pointer types for potentially absent variables. The optimizers assume a reference type argument is never NULL. */ - if (sym->attr.optional || sym->ns->proc_name->attr.entry_master) + if (sym->attr.optional + || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master)) type = build_pointer_type (type); else { diff --git a/gcc/genopinit.c b/gcc/genopinit.c index 4855e5ae3cd..ec4a4733c1d 100644 --- a/gcc/genopinit.c +++ b/gcc/genopinit.c @@ -253,8 +253,8 @@ static const char * const optabs[] = "set_optab_handler (vec_shl_optab, $A, CODE_FOR_$(vec_shl_$a$))", "set_optab_handler (vec_shr_optab, $A, CODE_FOR_$(vec_shr_$a$))", "set_optab_handler (vec_realign_load_optab, $A, CODE_FOR_$(vec_realign_load_$a$))", - "set_direct_optab_handler (vcond_optab, $A, CODE_FOR_$(vcond$a$))", - "set_direct_optab_handler (vcondu_optab, $A, CODE_FOR_$(vcondu$a$))", + "set_convert_optab_handler (vcond_optab, $A, $B, CODE_FOR_$(vcond$a$b$))", + "set_convert_optab_handler (vcondu_optab, $A, $B, CODE_FOR_$(vcondu$a$b$))", "set_optab_handler (ssum_widen_optab, $A, CODE_FOR_$(widen_ssum$I$a3$))", "set_optab_handler (usum_widen_optab, $A, CODE_FOR_$(widen_usum$I$a3$))", "set_optab_handler (udot_prod_optab, $A, CODE_FOR_$(udot_prod$I$a$))", diff --git a/gcc/gimple-fold.c b/gcc/gimple-fold.c index be5535bf113..9500a6ab26a 100644 --- a/gcc/gimple-fold.c +++ b/gcc/gimple-fold.c @@ -982,51 +982,6 @@ gimple_fold_builtin (gimple stmt) return result; } -/* Return a declaration of a function which an OBJ_TYPE_REF references. TOKEN - is integer form of OBJ_TYPE_REF_TOKEN of the reference expression. - KNOWN_BINFO carries the binfo describing the true type of - OBJ_TYPE_REF_OBJECT(REF). If a call to the function must be accompanied - with a this adjustment, the constant which should be added to this pointer - is stored to *DELTA. If REFUSE_THUNKS is true, return NULL if the function - is a thunk (other than a this adjustment which is dealt with by DELTA). */ - -tree -gimple_get_virt_method_for_binfo (HOST_WIDE_INT token, tree known_binfo, - tree *delta) -{ - HOST_WIDE_INT i; - tree v, fndecl; - - v = BINFO_VIRTUALS (known_binfo); - /* If there is no virtual methods leave the OBJ_TYPE_REF alone. */ - if (!v) - return NULL_TREE; - i = 0; - while (i != token) - { - i += (TARGET_VTABLE_USES_DESCRIPTORS - ? TARGET_VTABLE_USES_DESCRIPTORS : 1); - v = TREE_CHAIN (v); - } - - /* If BV_VCALL_INDEX is non-NULL, give up. */ - if (TREE_TYPE (v)) - return NULL_TREE; - - fndecl = TREE_VALUE (v); - - /* When cgraph node is missing and function is not public, we cannot - devirtualize. This can happen in WHOPR when the actual method - ends up in other partition, because we found devirtualization - possibility too late. */ - if (!can_refer_decl_in_current_unit_p (TREE_VALUE (v))) - return NULL_TREE; - - *delta = TREE_PURPOSE (v); - gcc_checking_assert (host_integerp (*delta, 0)); - return fndecl; -} - /* Generate code adjusting the first parameter of a call statement determined by GSI by DELTA. */ @@ -1149,7 +1104,7 @@ gimple_fold_call (gimple_stmt_iterator *gsi, bool inplace) callee = gimple_call_fn (stmt); if (callee && TREE_CODE (callee) == OBJ_TYPE_REF) { - tree binfo, fndecl, delta, obj; + tree binfo, fndecl, obj; HOST_WIDE_INT token; if (gimple_call_addr_fndecl (OBJ_TYPE_REF_EXPR (callee)) != NULL_TREE) @@ -1163,10 +1118,9 @@ gimple_fold_call (gimple_stmt_iterator *gsi, bool inplace) if (!binfo) return false; token = TREE_INT_CST_LOW (OBJ_TYPE_REF_TOKEN (callee)); - fndecl = gimple_get_virt_method_for_binfo (token, binfo, &delta); + fndecl = gimple_get_virt_method_for_binfo (token, binfo); if (!fndecl) return false; - gcc_assert (integer_zerop (delta)); gimple_call_set_fndecl (stmt, fndecl); return true; } @@ -3064,6 +3018,60 @@ fold_const_aggregate_ref (tree t) return fold_const_aggregate_ref_1 (t, NULL); } +/* Return a declaration of a function which an OBJ_TYPE_REF references. TOKEN + is integer form of OBJ_TYPE_REF_TOKEN of the reference expression. + KNOWN_BINFO carries the binfo describing the true type of + OBJ_TYPE_REF_OBJECT(REF). */ + +tree +gimple_get_virt_method_for_binfo (HOST_WIDE_INT token, tree known_binfo) +{ + unsigned HOST_WIDE_INT offset, size; + tree v, fn; + + v = BINFO_VTABLE (known_binfo); + /* If there is no virtual methods table, leave the OBJ_TYPE_REF alone. */ + if (!v) + return NULL_TREE; + + if (TREE_CODE (v) == POINTER_PLUS_EXPR) + { + offset = tree_low_cst (TREE_OPERAND (v, 1), 1) * BITS_PER_UNIT; + v = TREE_OPERAND (v, 0); + } + else + offset = 0; + + if (TREE_CODE (v) != ADDR_EXPR) + return NULL_TREE; + v = TREE_OPERAND (v, 0); + + if (TREE_CODE (v) != VAR_DECL + || !DECL_VIRTUAL_P (v) + || !DECL_INITIAL (v)) + return NULL_TREE; + gcc_checking_assert (TREE_CODE (TREE_TYPE (v)) == ARRAY_TYPE); + size = tree_low_cst (TYPE_SIZE (TREE_TYPE (TREE_TYPE (v))), 1); + offset += token * size; + fn = fold_ctor_reference (TREE_TYPE (TREE_TYPE (v)), DECL_INITIAL (v), + offset, size); + if (!fn) + return NULL_TREE; + gcc_assert (TREE_CODE (fn) == ADDR_EXPR + || TREE_CODE (fn) == FDESC_EXPR); + fn = TREE_OPERAND (fn, 0); + gcc_assert (TREE_CODE (fn) == FUNCTION_DECL); + + /* When cgraph node is missing and function is not public, we cannot + devirtualize. This can happen in WHOPR when the actual method + ends up in other partition, because we found devirtualization + possibility too late. */ + if (!can_refer_decl_in_current_unit_p (fn)) + return NULL_TREE; + + return fn; +} + /* Return true iff VAL is a gimple expression that is known to be non-negative. Restricted to floating-point inputs. */ diff --git a/gcc/gimple.h b/gcc/gimple.h index 7f831dffcaf..80b6cbde180 100644 --- a/gcc/gimple.h +++ b/gcc/gimple.h @@ -909,7 +909,7 @@ unsigned get_gimple_rhs_num_ops (enum tree_code); gimple gimple_alloc_stat (enum gimple_code, unsigned MEM_STAT_DECL); const char *gimple_decl_printable_name (tree, int); bool gimple_fold_call (gimple_stmt_iterator *gsi, bool inplace); -tree gimple_get_virt_method_for_binfo (HOST_WIDE_INT, tree, tree *); +tree gimple_get_virt_method_for_binfo (HOST_WIDE_INT, tree); void gimple_adjust_this_by_delta (gimple_stmt_iterator *, tree); tree gimple_extract_devirt_binfo_from_cst (tree); /* Returns true iff T is a valid GIMPLE statement. */ diff --git a/gcc/hooks.c b/gcc/hooks.c index 90251834e4e..1ba44f9c7bb 100644 --- a/gcc/hooks.c +++ b/gcc/hooks.c @@ -161,6 +161,13 @@ default_can_output_mi_thunk_no_vcall (const_tree a ATTRIBUTE_UNUSED, } int +hook_int_uint_mode_1 (unsigned int a ATTRIBUTE_UNUSED, + enum machine_mode b ATTRIBUTE_UNUSED) +{ + return 1; +} + +int hook_int_const_tree_0 (const_tree a ATTRIBUTE_UNUSED) { return 0; diff --git a/gcc/hooks.h b/gcc/hooks.h index 156d708ac01..54ace243f76 100644 --- a/gcc/hooks.h +++ b/gcc/hooks.h @@ -68,6 +68,7 @@ extern void hook_void_tree_treeptr (tree, tree *); extern void hook_void_int_int (int, int); extern void hook_void_gcc_optionsp (struct gcc_options *); +extern int hook_int_uint_mode_1 (unsigned int, enum machine_mode); extern int hook_int_const_tree_0 (const_tree); extern int hook_int_const_tree_const_tree_1 (const_tree, const_tree); extern int hook_int_rtx_0 (rtx); diff --git a/gcc/ipa-cp.c b/gcc/ipa-cp.c index 94118b7b1a5..f6e083e6654 100644 --- a/gcc/ipa-cp.c +++ b/gcc/ipa-cp.c @@ -221,7 +221,7 @@ static struct ipcp_value *values_topo; static inline struct ipcp_lattice * ipa_get_lattice (struct ipa_node_params *info, int i) { - gcc_assert (i >= 0 && i <= ipa_get_param_count (info)); + gcc_assert (i >= 0 && i < ipa_get_param_count (info)); gcc_checking_assert (!info->ipcp_orig_node); gcc_checking_assert (info->lattices); return &(info->lattices[i]); @@ -360,7 +360,6 @@ print_all_lattices (FILE * f, bool dump_sources, bool dump_benefits) static void determine_versionability (struct cgraph_node *node) { - struct cgraph_edge *edge; const char *reason = NULL; /* There are a number of generic reasons functions cannot be versioned. We @@ -368,33 +367,16 @@ determine_versionability (struct cgraph_node *node) present. */ if (node->alias || node->thunk.thunk_p) reason = "alias or thunk"; - else if (!inline_summary (node)->versionable) - reason = "inliner claims it is so"; - else if (TYPE_ATTRIBUTES (TREE_TYPE (node->decl))) - reason = "there are type attributes"; + else if (!node->local.versionable) + reason = "not a tree_versionable_function"; else if (cgraph_function_body_availability (node) <= AVAIL_OVERWRITABLE) reason = "insufficient body availability"; - else - /* Removing arguments doesn't work if the function takes varargs - or use __builtin_apply_args. - FIXME: handle this together with can_change_signature flag. */ - for (edge = node->callees; edge; edge = edge->next_callee) - { - tree t = edge->callee->decl; - if (DECL_BUILT_IN_CLASS (t) == BUILT_IN_NORMAL - && (DECL_FUNCTION_CODE (t) == BUILT_IN_APPLY_ARGS - || DECL_FUNCTION_CODE (t) == BUILT_IN_VA_START)) - { - reason = "prohibitive builtins called"; - break; - }; - } if (reason && dump_file && !node->alias && !node->thunk.thunk_p) fprintf (dump_file, "Function %s/%i is not versionable, reason: %s.\n", cgraph_node_name (node), node->uid, reason); - IPA_NODE_REF (node)->node_versionable = (reason == NULL); + node->local.versionable = (reason == NULL); } /* Return true if it is at all technically possible to create clones of a @@ -403,7 +385,7 @@ determine_versionability (struct cgraph_node *node) static bool ipcp_versionable_function_p (struct cgraph_node *node) { - return IPA_NODE_REF (node)->node_versionable; + return node->local.versionable; } /* Structure holding accumulated information about callers of a node. */ @@ -610,9 +592,7 @@ initialize_node_lattices (struct cgraph_node *node) int i; gcc_checking_assert (cgraph_function_with_gimple_body_p (node)); - if (ipa_is_called_with_var_arguments (info)) - disable = true; - else if (!node->local.local) + if (!node->local.local) { /* When cloning is allowed, we can assume that externally visible functions are not called. We will compensate this by cloning @@ -1068,18 +1048,17 @@ propagate_constants_accross_call (struct cgraph_edge *cs) struct cgraph_node *callee, *alias_or_thunk; struct ipa_edge_args *args; bool ret = false; - int i, count; + int i, args_count, parms_count; callee = cgraph_function_node (cs->callee, &availability); if (!callee->analyzed) return false; gcc_checking_assert (cgraph_function_with_gimple_body_p (callee)); callee_info = IPA_NODE_REF (callee); - if (ipa_is_called_with_var_arguments (callee_info)) - return false; args = IPA_EDGE_REF (cs); - count = ipa_get_cs_argument_count (args); + args_count = ipa_get_cs_argument_count (args); + parms_count = ipa_get_param_count (callee_info); /* If this call goes through a thunk we must not propagate to the first (0th) parameter. However, we might need to uncover a thunk from below a series @@ -1095,7 +1074,7 @@ propagate_constants_accross_call (struct cgraph_edge *cs) else i = 0; - for (; i < count; i++) + for (; (i < args_count) && (i < parms_count); i++) { struct ipa_jump_func *jump_func = ipa_get_ith_jump_func (args, i); struct ipcp_lattice *dest_lat = ipa_get_lattice (callee_info, i); @@ -1105,16 +1084,18 @@ propagate_constants_accross_call (struct cgraph_edge *cs) else ret |= propagate_accross_jump_function (cs, jump_func, dest_lat); } + for (; i < parms_count; i++) + ret |= set_lattice_contains_variable (ipa_get_lattice (callee_info, i)); + return ret; } /* If an indirect edge IE can be turned into a direct one based on KNOWN_VALS (which can contain both constants and binfos) or KNOWN_BINFOS (which can be - NULL) return the destination. If simple thunk delta must be applied too, - store it to DELTA. */ + NULL) return the destination. */ static tree -get_indirect_edge_target (struct cgraph_edge *ie, tree *delta, +get_indirect_edge_target (struct cgraph_edge *ie, VEC (tree, heap) *known_vals, VEC (tree, heap) *known_binfos) { @@ -1132,10 +1113,7 @@ get_indirect_edge_target (struct cgraph_edge *ie, tree *delta, if (t && TREE_CODE (t) == ADDR_EXPR && TREE_CODE (TREE_OPERAND (t, 0)) == FUNCTION_DECL) - { - *delta = NULL_TREE; - return TREE_OPERAND (t, 0); - } + return TREE_OPERAND (t, 0); else return NULL_TREE; } @@ -1159,7 +1137,7 @@ get_indirect_edge_target (struct cgraph_edge *ie, tree *delta, binfo = get_binfo_at_offset (binfo, anc_offset, otr_type); if (!binfo) return NULL_TREE; - return gimple_get_virt_method_for_binfo (token, binfo, delta); + return gimple_get_virt_method_for_binfo (token, binfo); } else { @@ -1168,7 +1146,7 @@ get_indirect_edge_target (struct cgraph_edge *ie, tree *delta, binfo = get_binfo_at_offset (t, anc_offset, otr_type); if (!binfo) return NULL_TREE; - return gimple_get_virt_method_for_binfo (token, binfo, delta); + return gimple_get_virt_method_for_binfo (token, binfo); } } @@ -1187,9 +1165,9 @@ devirtualization_time_bonus (struct cgraph_node *node, { struct cgraph_node *callee; struct inline_summary *isummary; - tree delta, target; + tree target; - target = get_indirect_edge_target (ie, &delta, known_csts, known_binfos); + target = get_indirect_edge_target (ie, known_csts, known_binfos); if (!target) continue; @@ -1674,12 +1652,12 @@ ipcp_discover_new_direct_edges (struct cgraph_node *node, for (ie = node->indirect_calls; ie; ie = next_ie) { - tree delta, target; + tree target; next_ie = ie->next_callee; - target = get_indirect_edge_target (ie, &delta, known_vals, NULL); + target = get_indirect_edge_target (ie, known_vals, NULL); if (target) - ipa_make_edge_direct_to_target (ie, target, delta); + ipa_make_edge_direct_to_target (ie, target); } } @@ -2008,7 +1986,11 @@ create_specialized_node (struct cgraph_node *node, } } else - args_to_skip = NULL; + { + args_to_skip = NULL; + if (dump_file && (dump_flags & TDF_DETAILS)) + fprintf (dump_file, " cannot change function signature\n"); + } for (i = 0; i < count ; i++) { @@ -2467,14 +2449,11 @@ ipcp_generate_summary (void) fprintf (dump_file, "\nIPA constant propagation start:\n"); ipa_register_cgraph_hooks (); - /* FIXME: We could propagate through thunks happily and we could be - even able to clone them, if needed. Do that later. */ FOR_EACH_FUNCTION_WITH_GIMPLE_BODY (node) { /* Unreachable nodes should have been eliminated before ipcp. */ gcc_assert (node->needed || node->reachable); - - inline_summary (node)->versionable = tree_versionable_function_p (node->decl); + node->local.versionable = tree_versionable_function_p (node->decl); ipa_analyze_node (node); } } diff --git a/gcc/ipa-inline-analysis.c b/gcc/ipa-inline-analysis.c index b56c66944e5..f9254165183 100644 --- a/gcc/ipa-inline-analysis.c +++ b/gcc/ipa-inline-analysis.c @@ -986,8 +986,6 @@ dump_inline_summary (FILE * f, struct cgraph_node *node) fprintf (f, " always_inline"); if (s->inlinable) fprintf (f, " inlinable"); - if (s->versionable) - fprintf (f, " versionable"); fprintf (f, "\n self time: %i\n", s->self_time); fprintf (f, " global time: %i\n", s->time); @@ -1187,6 +1185,8 @@ set_cond_stmt_execution_predicate (struct ipa_node_params *info, || gimple_call_num_args (set_stmt) != 1) return; op2 = gimple_call_arg (set_stmt, 0); + if (TREE_CODE (op2) != SSA_NAME) + return; if (!SSA_NAME_IS_DEFAULT_DEF (op2)) return; index = ipa_get_param_decl_index (info, SSA_NAME_VAR (op2)); @@ -1642,7 +1642,7 @@ compute_inline_parameters (struct cgraph_node *node, bool early) struct inline_edge_summary *es = inline_edge_summary (node->callees); struct predicate t = true_predicate (); - info->inlinable = info->versionable = 0; + info->inlinable = 0; node->callees->call_stmt_cannot_inline_p = true; node->local.can_change_signature = false; es->call_stmt_time = 1; @@ -2408,7 +2408,6 @@ inline_read_section (struct lto_file_decl_data *file_data, const char *data, bp = streamer_read_bitpack (&ib); info->inlinable = bp_unpack_value (&bp, 1); - info->versionable = bp_unpack_value (&bp, 1); count2 = streamer_read_uhwi (&ib); gcc_assert (!info->conds); @@ -2539,7 +2538,6 @@ inline_write_summary (cgraph_node_set set, int i; size_time_entry *e; struct condition *c; - streamer_write_uhwi (ob, lto_cgraph_encoder_encode (encoder, node)); streamer_write_hwi (ob, info->estimated_self_stack_size); @@ -2547,7 +2545,6 @@ inline_write_summary (cgraph_node_set set, streamer_write_hwi (ob, info->self_time); bp = bitpack_create (ob->main_stream); bp_pack_value (&bp, info->inlinable, 1); - bp_pack_value (&bp, info->versionable, 1); streamer_write_bitpack (&bp); streamer_write_uhwi (ob, VEC_length (condition, info->conds)); for (i = 0; VEC_iterate (condition, info->conds, i, c); i++) diff --git a/gcc/ipa-inline.h b/gcc/ipa-inline.h index 8162cf2d777..bba13b6af46 100644 --- a/gcc/ipa-inline.h +++ b/gcc/ipa-inline.h @@ -85,9 +85,6 @@ struct GTY(()) inline_summary /* False when there something makes inlining impossible (such as va_arg). */ unsigned inlinable : 1; - /* False when there something makes versioning impossible. - Currently computed and used only by ipa-cp. */ - unsigned versionable : 1; /* Information about function that will result after applying all the inline decisions present in the callgraph. Generally kept up to diff --git a/gcc/ipa-prop.c b/gcc/ipa-prop.c index a81bb3cb1cd..066bbdbf03e 100644 --- a/gcc/ipa-prop.c +++ b/gcc/ipa-prop.c @@ -143,25 +143,6 @@ ipa_initialize_node_params (struct cgraph_node *node) } } -/* Count number of arguments callsite CS has and store it in - ipa_edge_args structure corresponding to this callsite. */ - -static void -ipa_count_arguments (struct cgraph_edge *cs) -{ - gimple stmt; - int arg_num; - - stmt = cs->call_stmt; - gcc_assert (is_gimple_call (stmt)); - arg_num = gimple_call_num_args (stmt); - if (VEC_length (ipa_edge_args_t, ipa_edge_args_vector) - <= (unsigned) cgraph_edge_max_uid) - VEC_safe_grow_cleared (ipa_edge_args_t, gc, - ipa_edge_args_vector, cgraph_edge_max_uid + 1); - ipa_set_cs_argument_count (IPA_EDGE_REF (cs), arg_num); -} - /* Print the jump functions associated with call graph edge CS to file F. */ static void @@ -696,7 +677,7 @@ compute_known_type_jump_func (tree op, struct ipa_jump_func *jfunc, static void compute_scalar_jump_functions (struct ipa_node_params *info, - struct ipa_jump_func *functions, + struct ipa_edge_args *args, gimple call) { tree arg; @@ -704,12 +685,13 @@ compute_scalar_jump_functions (struct ipa_node_params *info, for (num = 0; num < gimple_call_num_args (call); num++) { + struct ipa_jump_func *jfunc = ipa_get_ith_jump_func (args, num); arg = gimple_call_arg (call, num); if (is_gimple_ip_invariant (arg)) { - functions[num].type = IPA_JF_CONST; - functions[num].value.constant = arg; + jfunc->type = IPA_JF_CONST; + jfunc->value.constant = arg; } else if (TREE_CODE (arg) == SSA_NAME) { @@ -718,26 +700,24 @@ compute_scalar_jump_functions (struct ipa_node_params *info, int index = ipa_get_param_decl_index (info, SSA_NAME_VAR (arg)); if (index >= 0 - && !detect_type_change_ssa (arg, call, &functions[num])) + && !detect_type_change_ssa (arg, call, jfunc)) { - functions[num].type = IPA_JF_PASS_THROUGH; - functions[num].value.pass_through.formal_id = index; - functions[num].value.pass_through.operation = NOP_EXPR; + jfunc->type = IPA_JF_PASS_THROUGH; + jfunc->value.pass_through.formal_id = index; + jfunc->value.pass_through.operation = NOP_EXPR; } } else { gimple stmt = SSA_NAME_DEF_STMT (arg); if (is_gimple_assign (stmt)) - compute_complex_assign_jump_func (info, &functions[num], - call, stmt, arg); + compute_complex_assign_jump_func (info, jfunc, call, stmt, arg); else if (gimple_code (stmt) == GIMPLE_PHI) - compute_complex_ancestor_jump_func (info, &functions[num], - call, stmt); + compute_complex_ancestor_jump_func (info, jfunc, call, stmt); } } else - compute_known_type_jump_func (arg, &functions[num], call); + compute_known_type_jump_func (arg, jfunc, call); } } @@ -821,7 +801,7 @@ is_parm_modified_before_call (struct param_analysis_info *parm_info, static bool compute_pass_through_member_ptrs (struct ipa_node_params *info, struct param_analysis_info *parms_info, - struct ipa_jump_func *functions, + struct ipa_edge_args *args, gimple call) { bool undecided_members = false; @@ -841,9 +821,11 @@ compute_pass_through_member_ptrs (struct ipa_node_params *info, gcc_assert (index >=0); if (!is_parm_modified_before_call (&parms_info[index], call, arg)) { - functions[num].type = IPA_JF_PASS_THROUGH; - functions[num].value.pass_through.formal_id = index; - functions[num].value.pass_through.operation = NOP_EXPR; + struct ipa_jump_func *jfunc = ipa_get_ith_jump_func (args, + num); + jfunc->type = IPA_JF_PASS_THROUGH; + jfunc->value.pass_through.formal_id = index; + jfunc->value.pass_through.operation = NOP_EXPR; } else undecided_members = true; @@ -969,7 +951,7 @@ determine_cst_member_ptr (gimple call, tree arg, tree method_field, associated with the call. */ static void -compute_cst_member_ptr_arguments (struct ipa_jump_func *functions, +compute_cst_member_ptr_arguments (struct ipa_edge_args *args, gimple call) { unsigned num; @@ -977,13 +959,13 @@ compute_cst_member_ptr_arguments (struct ipa_jump_func *functions, for (num = 0; num < gimple_call_num_args (call); num++) { + struct ipa_jump_func *jfunc = ipa_get_ith_jump_func (args, num); arg = gimple_call_arg (call, num); - if (functions[num].type == IPA_JF_UNKNOWN + if (jfunc->type == IPA_JF_UNKNOWN && type_like_member_ptr_p (TREE_TYPE (arg), &method_field, &delta_field)) - determine_cst_member_ptr (call, arg, method_field, delta_field, - &functions[num]); + determine_cst_member_ptr (call, arg, method_field, delta_field, jfunc); } } @@ -996,29 +978,25 @@ ipa_compute_jump_functions_for_edge (struct param_analysis_info *parms_info, struct cgraph_edge *cs) { struct ipa_node_params *info = IPA_NODE_REF (cs->caller); - struct ipa_edge_args *arguments = IPA_EDGE_REF (cs); - gimple call; + struct ipa_edge_args *args = IPA_EDGE_REF (cs); + gimple call = cs->call_stmt; + int arg_num = gimple_call_num_args (call); - if (ipa_get_cs_argument_count (arguments) == 0 || arguments->jump_functions) + if (arg_num == 0 || args->jump_functions) return; - arguments->jump_functions = ggc_alloc_cleared_vec_ipa_jump_func - (ipa_get_cs_argument_count (arguments)); - - call = cs->call_stmt; - gcc_assert (is_gimple_call (call)); + VEC_safe_grow_cleared (ipa_jump_func_t, gc, args->jump_functions, arg_num); /* We will deal with constants and SSA scalars first: */ - compute_scalar_jump_functions (info, arguments->jump_functions, call); + compute_scalar_jump_functions (info, args, call); /* Let's check whether there are any potential member pointers and if so, whether we can determine their functions as pass_through. */ - if (!compute_pass_through_member_ptrs (info, parms_info, - arguments->jump_functions, call)) + if (!compute_pass_through_member_ptrs (info, parms_info, args, call)) return; /* Finally, let's check whether we actually pass a new constant member pointer here... */ - compute_cst_member_ptr_arguments (arguments->jump_functions, call); + compute_cst_member_ptr_arguments (args, call); } /* Compute jump functions for all edges - both direct and indirect - outgoing @@ -1032,27 +1010,17 @@ ipa_compute_jump_functions (struct cgraph_node *node, for (cs = node->callees; cs; cs = cs->next_callee) { - struct cgraph_node *callee = cgraph_function_or_thunk_node (cs->callee, NULL); + struct cgraph_node *callee = cgraph_function_or_thunk_node (cs->callee, + NULL); /* We do not need to bother analyzing calls to unknown functions unless they may become known during lto/whopr. */ - if (!cs->callee->analyzed && !flag_lto) + if (!callee->analyzed && !flag_lto) continue; - ipa_count_arguments (cs); - /* If the descriptor of the callee is not initialized yet, we have to do - it now. */ - if (callee->analyzed) - ipa_initialize_node_params (callee); - if (ipa_get_cs_argument_count (IPA_EDGE_REF (cs)) - != ipa_get_param_count (IPA_NODE_REF (callee))) - ipa_set_called_with_variable_arg (IPA_NODE_REF (callee)); ipa_compute_jump_functions_for_edge (parms_info, cs); } for (cs = node->indirect_calls; cs; cs = cs->next_callee) - { - ipa_count_arguments (cs); - ipa_compute_jump_functions_for_edge (parms_info, cs); - } + ipa_compute_jump_functions_for_edge (parms_info, cs); } /* If RHS looks like a rhs of a statement loading pfn from a member @@ -1614,12 +1582,10 @@ update_jump_functions_after_inlining (struct cgraph_edge *cs, } /* If TARGET is an addr_expr of a function declaration, make it the destination - of an indirect edge IE and return the edge. Otherwise, return NULL. Delta, - if non-NULL, is an integer constant that must be added to this pointer - (first parameter). */ + of an indirect edge IE and return the edge. Otherwise, return NULL. */ struct cgraph_edge * -ipa_make_edge_direct_to_target (struct cgraph_edge *ie, tree target, tree delta) +ipa_make_edge_direct_to_target (struct cgraph_edge *ie, tree target) { struct cgraph_node *callee; @@ -1632,11 +1598,11 @@ ipa_make_edge_direct_to_target (struct cgraph_edge *ie, tree target, tree delta) return NULL; ipa_check_create_node_params (); - /* We can not make edges to inline clones. It is bug that someone removed the cgraph - node too early. */ + /* We can not make edges to inline clones. It is bug that someone removed + the cgraph node too early. */ gcc_assert (!callee->global.inlined_to); - cgraph_make_edge_direct (ie, callee, delta ? tree_low_cst (delta, 0) : 0); + cgraph_make_edge_direct (ie, callee); if (dump_file) { fprintf (dump_file, "ipa-prop: Discovered %s call to a known target " @@ -1648,20 +1614,9 @@ ipa_make_edge_direct_to_target (struct cgraph_edge *ie, tree target, tree delta) print_gimple_stmt (dump_file, ie->call_stmt, 2, TDF_SLIM); else fprintf (dump_file, "with uid %i\n", ie->lto_stmt_uid); - - if (delta) - { - fprintf (dump_file, " Thunk delta is "); - print_generic_expr (dump_file, delta, 0); - fprintf (dump_file, "\n"); - } } callee = cgraph_function_or_thunk_node (callee, NULL); - if (ipa_get_cs_argument_count (IPA_EDGE_REF (ie)) - != ipa_get_param_count (IPA_NODE_REF (callee))) - ipa_set_called_with_variable_arg (IPA_NODE_REF (callee)); - return ie; } @@ -1683,7 +1638,7 @@ try_make_edge_direct_simple_call (struct cgraph_edge *ie, else return NULL; - return ipa_make_edge_direct_to_target (ie, target, NULL_TREE); + return ipa_make_edge_direct_to_target (ie, target); } /* Try to find a destination for indirect edge IE that corresponds to a @@ -1695,7 +1650,7 @@ static struct cgraph_edge * try_make_edge_direct_virtual_call (struct cgraph_edge *ie, struct ipa_jump_func *jfunc) { - tree binfo, type, target, delta; + tree binfo, type, target; HOST_WIDE_INT token; if (jfunc->type == IPA_JF_KNOWN_TYPE) @@ -1710,12 +1665,12 @@ try_make_edge_direct_virtual_call (struct cgraph_edge *ie, type = ie->indirect_info->otr_type; binfo = get_binfo_at_offset (binfo, ie->indirect_info->anc_offset, type); if (binfo) - target = gimple_get_virt_method_for_binfo (token, binfo, &delta); + target = gimple_get_virt_method_for_binfo (token, binfo); else return NULL; if (target) - return ipa_make_edge_direct_to_target (ie, target, delta); + return ipa_make_edge_direct_to_target (ie, target); else return NULL; } @@ -1919,19 +1874,6 @@ ipa_node_removal_hook (struct cgraph_node *node, void *data ATTRIBUTE_UNUSED) ipa_free_node_params_substructures (IPA_NODE_REF (node)); } -static struct ipa_jump_func * -duplicate_ipa_jump_func_array (const struct ipa_jump_func * src, size_t n) -{ - struct ipa_jump_func *p; - - if (!src) - return NULL; - - p = ggc_alloc_vec_ipa_jump_func (n); - memcpy (p, src, n * sizeof (struct ipa_jump_func)); - return p; -} - /* Hook that is called by cgraph.c when a node is duplicated. */ static void @@ -1939,17 +1881,14 @@ ipa_edge_duplication_hook (struct cgraph_edge *src, struct cgraph_edge *dst, __attribute__((unused)) void *data) { struct ipa_edge_args *old_args, *new_args; - int arg_count; ipa_check_create_edge_args (); old_args = IPA_EDGE_REF (src); new_args = IPA_EDGE_REF (dst); - arg_count = ipa_get_cs_argument_count (old_args); - ipa_set_cs_argument_count (new_args, arg_count); - new_args->jump_functions = - duplicate_ipa_jump_func_array (old_args->jump_functions, arg_count); + new_args->jump_functions = VEC_copy (ipa_jump_func_t, gc, + old_args->jump_functions); if (iinlining_processed_edges && bitmap_bit_p (iinlining_processed_edges, src->uid)) @@ -1973,7 +1912,6 @@ ipa_node_duplication_hook (struct cgraph_node *src, struct cgraph_node *dst, new_info->lattices = NULL; new_info->ipcp_orig_node = old_info->ipcp_orig_node; - new_info->called_with_var_arguments = old_info->called_with_var_arguments; new_info->uses_analysis_done = old_info->uses_analysis_done; new_info->node_enqueued = old_info->node_enqueued; } @@ -2822,12 +2760,10 @@ ipa_read_node_info (struct lto_input_block *ib, struct cgraph_node *node, struct ipa_edge_args *args = IPA_EDGE_REF (e); int count = streamer_read_uhwi (ib); - ipa_set_cs_argument_count (args, count); if (!count) continue; + VEC_safe_grow_cleared (ipa_jump_func_t, gc, args->jump_functions, count); - args->jump_functions = ggc_alloc_cleared_vec_ipa_jump_func - (ipa_get_cs_argument_count (args)); for (k = 0; k < ipa_get_cs_argument_count (args); k++) ipa_read_jump_function (ib, ipa_get_ith_jump_func (args, k), data_in); } @@ -2836,13 +2772,13 @@ ipa_read_node_info (struct lto_input_block *ib, struct cgraph_node *node, struct ipa_edge_args *args = IPA_EDGE_REF (e); int count = streamer_read_uhwi (ib); - ipa_set_cs_argument_count (args, count); if (count) { - args->jump_functions = ggc_alloc_cleared_vec_ipa_jump_func - (ipa_get_cs_argument_count (args)); + VEC_safe_grow_cleared (ipa_jump_func_t, gc, args->jump_functions, + count); for (k = 0; k < ipa_get_cs_argument_count (args); k++) - ipa_read_jump_function (ib, ipa_get_ith_jump_func (args, k), data_in); + ipa_read_jump_function (ib, ipa_get_ith_jump_func (args, k), + data_in); } ipa_read_indirect_edge_info (ib, data_in, e); } @@ -2958,7 +2894,6 @@ void ipa_update_after_lto_read (void) { struct cgraph_node *node; - struct cgraph_edge *cs; ipa_check_create_node_params (); ipa_check_create_edge_args (); @@ -2966,17 +2901,4 @@ ipa_update_after_lto_read (void) for (node = cgraph_nodes; node; node = node->next) if (node->analyzed) ipa_initialize_node_params (node); - - for (node = cgraph_nodes; node; node = node->next) - if (node->analyzed) - for (cs = node->callees; cs; cs = cs->next_callee) - { - struct cgraph_node *callee; - - callee = cgraph_function_or_thunk_node (cs->callee, NULL); - if (ipa_get_cs_argument_count (IPA_EDGE_REF (cs)) - != ipa_get_param_count (IPA_NODE_REF (callee))) - ipa_set_called_with_variable_arg (IPA_NODE_REF (callee)); - } } - diff --git a/gcc/ipa-prop.h b/gcc/ipa-prop.h index 994e4ac146d..fafd17d2fce 100644 --- a/gcc/ipa-prop.h +++ b/gcc/ipa-prop.h @@ -119,7 +119,7 @@ struct GTY(()) ipa_member_ptr_cst /* A jump function for a callsite represents the values passed as actual arguments of the callsite. See enum jump_func_type for the various types of jump functions supported. */ -struct GTY (()) ipa_jump_func +typedef struct GTY (()) ipa_jump_func { enum jump_func_type type; /* Represents a value of a jump function. pass_through is used only in jump @@ -133,7 +133,10 @@ struct GTY (()) ipa_jump_func struct ipa_pass_through_data GTY ((tag ("IPA_JF_PASS_THROUGH"))) pass_through; struct ipa_ancestor_jf_data GTY ((tag ("IPA_JF_ANCESTOR"))) ancestor; } GTY ((desc ("%1.type"))) value; -}; +} ipa_jump_func_t; + +DEF_VEC_O (ipa_jump_func_t); +DEF_VEC_ALLOC_O (ipa_jump_func_t, gc); /* Summary describing a single formal parameter. */ @@ -168,11 +171,6 @@ struct ipa_node_params /* If this node is an ipa-cp clone, these are the known values that describe what it has been specialized for. */ VEC (tree, heap) *known_vals; - /* Whether this function is called with variable number of actual - arguments. */ - unsigned called_with_var_arguments : 1; - /* Set when it is possible to create specialized versions of this node. */ - unsigned node_versionable : 1; /* Whether the param uses analysis has already been performed. */ unsigned uses_analysis_done : 1; /* Whether the function is enqueued in ipa-cp propagation stack. */ @@ -224,51 +222,23 @@ ipa_is_param_used (struct ipa_node_params *info, int i) return VEC_index (ipa_param_descriptor_t, info->descriptors, i)->used; } -/* Flag this node as having callers with variable number of arguments. */ - -static inline void -ipa_set_called_with_variable_arg (struct ipa_node_params *info) -{ - info->called_with_var_arguments = 1; -} - -/* Have we detected this node was called with variable number of arguments? */ - -static inline bool -ipa_is_called_with_var_arguments (struct ipa_node_params *info) -{ - return info->called_with_var_arguments; -} - /* ipa_edge_args stores information related to a callsite and particularly its arguments. It can be accessed by the IPA_EDGE_REF macro. */ typedef struct GTY(()) ipa_edge_args { - /* Number of actual arguments in this callsite. When set to 0, - this callsite's parameters would not be analyzed by the different - stages of IPA CP. */ - int argument_count; - /* Array of the callsite's jump function of each parameter. */ - struct ipa_jump_func GTY ((length ("%h.argument_count"))) *jump_functions; + /* Vector of the callsite's jump function of each parameter. */ + VEC (ipa_jump_func_t, gc) *jump_functions; } ipa_edge_args_t; /* ipa_edge_args access functions. Please use these to access fields that are or will be shared among various passes. */ -/* Set the number of actual arguments. */ - -static inline void -ipa_set_cs_argument_count (struct ipa_edge_args *args, int count) -{ - args->argument_count = count; -} - /* Return the number of actual arguments. */ static inline int ipa_get_cs_argument_count (struct ipa_edge_args *args) { - return args->argument_count; + return VEC_length (ipa_jump_func_t, args->jump_functions); } /* Returns a pointer to the jump function for the ith argument. Please note @@ -278,8 +248,7 @@ ipa_get_cs_argument_count (struct ipa_edge_args *args) static inline struct ipa_jump_func * ipa_get_ith_jump_func (struct ipa_edge_args *args, int i) { - gcc_assert (i >= 0 && i <= args->argument_count); - return &args->jump_functions[i]; + return VEC_index (ipa_jump_func_t, args->jump_functions, i); } /* Vectors need to have typedefs of structures. */ @@ -367,8 +336,7 @@ bool ipa_propagate_indirect_call_infos (struct cgraph_edge *cs, VEC (cgraph_edge_p, heap) **new_edges); /* Indirect edge and binfo processing. */ -struct cgraph_edge *ipa_make_edge_direct_to_target (struct cgraph_edge *, tree, - tree); +struct cgraph_edge *ipa_make_edge_direct_to_target (struct cgraph_edge *, tree); /* Functions related to both. */ void ipa_analyze_node (struct cgraph_node *); diff --git a/gcc/ipa-split.c b/gcc/ipa-split.c index 4373a1b423e..d5e5c69b5d8 100644 --- a/gcc/ipa-split.c +++ b/gcc/ipa-split.c @@ -988,6 +988,9 @@ split_function (struct split_point *split_point) arg = gimple_default_def (cfun, parm); if (!arg) { + /* This parm wasn't used up to now, but is going to be used, + hence register it. */ + add_referenced_var (parm); arg = make_ssa_name (parm, gimple_build_nop ()); set_default_def (parm, arg); } diff --git a/gcc/lto-cgraph.c b/gcc/lto-cgraph.c index 5bcc342d83f..edc3ad7759e 100644 --- a/gcc/lto-cgraph.c +++ b/gcc/lto-cgraph.c @@ -495,6 +495,7 @@ lto_output_node (struct lto_simple_output_block *ob, struct cgraph_node *node, bp_pack_value (&bp, node->local.local, 1); bp_pack_value (&bp, node->local.externally_visible, 1); bp_pack_value (&bp, node->local.finalized, 1); + bp_pack_value (&bp, node->local.versionable, 1); bp_pack_value (&bp, node->local.can_change_signature, 1); bp_pack_value (&bp, node->local.redefined_extern_inline, 1); bp_pack_value (&bp, node->needed, 1); @@ -896,6 +897,7 @@ input_overwrite_node (struct lto_file_decl_data *file_data, node->local.local = bp_unpack_value (bp, 1); node->local.externally_visible = bp_unpack_value (bp, 1); node->local.finalized = bp_unpack_value (bp, 1); + node->local.versionable = bp_unpack_value (bp, 1); node->local.can_change_signature = bp_unpack_value (bp, 1); node->local.redefined_extern_inline = bp_unpack_value (bp, 1); node->needed = bp_unpack_value (bp, 1); @@ -1501,22 +1503,9 @@ input_cgraph (void) /* True when we need optimization summary for NODE. */ static int -output_cgraph_opt_summary_p (struct cgraph_node *node, cgraph_node_set set) +output_cgraph_opt_summary_p (struct cgraph_node *node, + cgraph_node_set set ATTRIBUTE_UNUSED) { - struct cgraph_edge *e; - - if (cgraph_node_in_set_p (node, set)) - { - for (e = node->callees; e; e = e->next_callee) - if (e->indirect_info - && e->indirect_info->thunk_delta != 0) - return true; - - for (e = node->indirect_calls; e; e = e->next_callee) - if (e->indirect_info->thunk_delta != 0) - return true; - } - return (node->clone_of && (node->clone.tree_map || node->clone.args_to_skip @@ -1525,13 +1514,9 @@ output_cgraph_opt_summary_p (struct cgraph_node *node, cgraph_node_set set) /* Output optimization summary for EDGE to OB. */ static void -output_edge_opt_summary (struct output_block *ob, - struct cgraph_edge *edge) +output_edge_opt_summary (struct output_block *ob ATTRIBUTE_UNUSED, + struct cgraph_edge *edge ATTRIBUTE_UNUSED) { - if (edge->indirect_info) - streamer_write_hwi (ob, edge->indirect_info->thunk_delta); - else - streamer_write_hwi (ob, 0); } /* Output optimization summary for NODE to OB. */ @@ -1631,17 +1616,9 @@ output_cgraph_opt_summary (cgraph_node_set set) /* Input optimisation summary of EDGE. */ static void -input_edge_opt_summary (struct cgraph_edge *edge, - struct lto_input_block *ib_main) +input_edge_opt_summary (struct cgraph_edge *edge ATTRIBUTE_UNUSED, + struct lto_input_block *ib_main ATTRIBUTE_UNUSED) { - HOST_WIDE_INT thunk_delta; - thunk_delta = streamer_read_hwi (ib_main); - if (thunk_delta != 0) - { - gcc_assert (!edge->indirect_info); - edge->indirect_info = cgraph_allocate_init_indirect_info (); - edge->indirect_info->thunk_delta = thunk_delta; - } } /* Input optimisation summary of NODE. */ diff --git a/gcc/optabs.c b/gcc/optabs.c index 886b259ce34..5cdcd95f12a 100644 --- a/gcc/optabs.c +++ b/gcc/optabs.c @@ -6620,27 +6620,33 @@ vector_compare_rtx (tree cond, bool unsignedp, enum insn_code icode) return gen_rtx_fmt_ee (rcode, VOIDmode, ops[0].value, ops[1].value); } -/* Return insn code for TYPE, the type of a VEC_COND_EXPR. */ +/* Return insn code for a conditional operator with a comparison in + mode CMODE, unsigned if UNS is true, resulting in a value of mode VMODE. */ static inline enum insn_code -get_vcond_icode (tree type, enum machine_mode mode) +get_vcond_icode (enum machine_mode vmode, enum machine_mode cmode, bool uns) { enum insn_code icode = CODE_FOR_nothing; - - if (TYPE_UNSIGNED (type)) - icode = direct_optab_handler (vcondu_optab, mode); + if (uns) + icode = convert_optab_handler (vcondu_optab, vmode, cmode); else - icode = direct_optab_handler (vcond_optab, mode); + icode = convert_optab_handler (vcond_optab, vmode, cmode); return icode; } /* Return TRUE iff, appropriate vector insns are available - for vector cond expr with type TYPE in VMODE mode. */ + for vector cond expr with vector type VALUE_TYPE and a comparison + with operand vector types in CMP_OP_TYPE. */ bool -expand_vec_cond_expr_p (tree type, enum machine_mode vmode) -{ - if (get_vcond_icode (type, vmode) == CODE_FOR_nothing) +expand_vec_cond_expr_p (tree value_type, tree cmp_op_type) +{ + enum machine_mode value_mode = TYPE_MODE (value_type); + enum machine_mode cmp_op_mode = TYPE_MODE (cmp_op_type); + if (GET_MODE_SIZE (value_mode) != GET_MODE_SIZE (cmp_op_mode) + || GET_MODE_NUNITS (value_mode) != GET_MODE_NUNITS (cmp_op_mode) + || get_vcond_icode (TYPE_MODE (value_type), TYPE_MODE (cmp_op_type), + TYPE_UNSIGNED (cmp_op_type)) == CODE_FOR_nothing) return false; return true; } @@ -6656,9 +6662,18 @@ expand_vec_cond_expr (tree vec_cond_type, tree op0, tree op1, tree op2, enum insn_code icode; rtx comparison, rtx_op1, rtx_op2; enum machine_mode mode = TYPE_MODE (vec_cond_type); - bool unsignedp = TYPE_UNSIGNED (vec_cond_type); + enum machine_mode cmp_op_mode; + bool unsignedp; + + gcc_assert (COMPARISON_CLASS_P (op0)); + + unsignedp = TYPE_UNSIGNED (TREE_TYPE (TREE_OPERAND (op0, 0))); + cmp_op_mode = TYPE_MODE (TREE_TYPE (TREE_OPERAND (op0, 0))); + + gcc_assert (GET_MODE_SIZE (mode) == GET_MODE_SIZE (cmp_op_mode) + && GET_MODE_NUNITS (mode) == GET_MODE_NUNITS (cmp_op_mode)); - icode = get_vcond_icode (vec_cond_type, mode); + icode = get_vcond_icode (mode, cmp_op_mode, unsignedp); if (icode == CODE_FOR_nothing) return 0; diff --git a/gcc/optabs.h b/gcc/optabs.h index cf5a659647b..56df6718462 100644 --- a/gcc/optabs.h +++ b/gcc/optabs.h @@ -589,6 +589,10 @@ enum convert_optab_index COI_vec_load_lanes, COI_vec_store_lanes, + /* Vector conditional operations. */ + COI_vcond, + COI_vcondu, + COI_MAX }; @@ -611,6 +615,8 @@ enum convert_optab_index #define satfractuns_optab (&convert_optab_table[COI_satfractuns]) #define vec_load_lanes_optab (&convert_optab_table[COI_vec_load_lanes]) #define vec_store_lanes_optab (&convert_optab_table[COI_vec_store_lanes]) +#define vcond_optab (&convert_optab_table[(int) COI_vcond]) +#define vcondu_optab (&convert_optab_table[(int) COI_vcondu]) /* Contains the optab used for each rtx code. */ extern optab code_to_optab[NUM_RTX_CODE + 1]; @@ -632,10 +638,6 @@ enum direct_optab_index DOI_reload_in, DOI_reload_out, - /* Vector conditional operations. */ - DOI_vcond, - DOI_vcondu, - /* Block move operation. */ DOI_movmem, @@ -699,8 +701,6 @@ typedef struct direct_optab_d *direct_optab; #endif #define reload_in_optab (&direct_optab_table[(int) DOI_reload_in]) #define reload_out_optab (&direct_optab_table[(int) DOI_reload_out]) -#define vcond_optab (&direct_optab_table[(int) DOI_vcond]) -#define vcondu_optab (&direct_optab_table[(int) DOI_vcondu]) #define movmem_optab (&direct_optab_table[(int) DOI_movmem]) #define setmem_optab (&direct_optab_table[(int) DOI_setmem]) #define cmpstr_optab (&direct_optab_table[(int) DOI_cmpstr]) @@ -877,7 +877,7 @@ extern bool expand_sfix_optab (rtx, rtx, convert_optab); extern rtx expand_widening_mult (enum machine_mode, rtx, rtx, rtx, int, optab); /* Return tree if target supports vector operations for COND_EXPR. */ -bool expand_vec_cond_expr_p (tree, enum machine_mode); +bool expand_vec_cond_expr_p (tree, tree); /* Generate code for VEC_COND_EXPR. */ extern rtx expand_vec_cond_expr (tree, tree, tree, tree, rtx); diff --git a/gcc/optc-gen.awk b/gcc/optc-gen.awk index 71a03fbdcb6..e28c397f48a 100644 --- a/gcc/optc-gen.awk +++ b/gcc/optc-gen.awk @@ -169,6 +169,9 @@ for (i = 0; i < n_langs; i++) { print " 0\n};\n" print "const unsigned int cl_options_count = N_OPTS;\n" +print "#if (1U << " n_langs ") > CL_MIN_OPTION_CLASS" +print " #error the number of languages exceeds the implementation limit" +print "#endif" print "const unsigned int cl_lang_count = " n_langs ";\n" print "const struct cl_option cl_options[] =\n{" diff --git a/gcc/opts.c b/gcc/opts.c index 59e8910f18c..5d5bcb96028 100644 --- a/gcc/opts.c +++ b/gcc/opts.c @@ -1125,7 +1125,7 @@ print_specific_help (unsigned int include_flags, /* Sanity check: Make sure that we do not have more languages than we have bits available to enumerate them. */ - gcc_assert ((1U << cl_lang_count) < CL_MIN_OPTION_CLASS); + gcc_assert ((1U << cl_lang_count) <= CL_MIN_OPTION_CLASS); /* If we have not done so already, obtain the desired maximum width of the output. */ diff --git a/gcc/opts.h b/gcc/opts.h index 3c0fe3f8cb7..621cdea4934 100644 --- a/gcc/opts.h +++ b/gcc/opts.h @@ -127,12 +127,12 @@ extern const unsigned int cl_options_count; extern const char *const lang_names[]; extern const unsigned int cl_lang_count; -#define CL_PARAMS (1U << 11) /* Fake entry. Used to display --param info with --help. */ -#define CL_WARNING (1U << 12) /* Enables an (optional) warning message. */ -#define CL_OPTIMIZATION (1U << 13) /* Enables an (optional) optimization. */ -#define CL_DRIVER (1U << 14) /* Driver option. */ -#define CL_TARGET (1U << 15) /* Target-specific option. */ -#define CL_COMMON (1U << 16) /* Language-independent. */ +#define CL_PARAMS (1U << 16) /* Fake entry. Used to display --param info with --help. */ +#define CL_WARNING (1U << 17) /* Enables an (optional) warning message. */ +#define CL_OPTIMIZATION (1U << 18) /* Enables an (optional) optimization. */ +#define CL_DRIVER (1U << 19) /* Driver option. */ +#define CL_TARGET (1U << 20) /* Target-specific option. */ +#define CL_COMMON (1U << 21) /* Language-independent. */ #define CL_MIN_OPTION_CLASS CL_PARAMS #define CL_MAX_OPTION_CLASS CL_COMMON @@ -142,9 +142,9 @@ extern const unsigned int cl_lang_count; This distinction is important because --help will not list options which only have these higher bits set. */ -#define CL_JOINED (1U << 17) /* If takes joined argument. */ -#define CL_SEPARATE (1U << 18) /* If takes a separate argument. */ -#define CL_UNDOCUMENTED (1U << 19) /* Do not output with --help. */ +#define CL_JOINED (1U << 22) /* If takes joined argument. */ +#define CL_SEPARATE (1U << 23) /* If takes a separate argument. */ +#define CL_UNDOCUMENTED (1U << 24) /* Do not output with --help. */ /* Flags for an enumerated option argument. */ #define CL_ENUM_CANONICAL (1 << 0) /* Canonical for this value. */ diff --git a/gcc/params.def b/gcc/params.def index 3a4bcb9b55c..fd8b0f3efa3 100644 --- a/gcc/params.def +++ b/gcc/params.def @@ -938,6 +938,13 @@ DEFPARAM (PARAM_ALLOW_STORE_DATA_RACES, "Allow new data races on stores to be introduced", 1, 0, 1) +/* Reassociation width to be used by tree reassoc optimization. */ +DEFPARAM (PARAM_TREE_REASSOC_WIDTH, + "tree-reassoc-width", + "Set the maximum number of instructions executed in parallel in " + "reassociated tree. If 0, use the target dependent heuristic.", + 0, 0, 0) + /* Local variables: diff --git a/gcc/po/ChangeLog b/gcc/po/ChangeLog index b8e1e0c6a2a..c4ba7cf2f54 100644 --- a/gcc/po/ChangeLog +++ b/gcc/po/ChangeLog @@ -1,3 +1,7 @@ +2011-09-02 Joseph Myers <joseph@codesourcery.com> + + * ja.po: Update. + 2011-08-28 Joseph Myers <joseph@codesourcery.com> * ja.po: Update. diff --git a/gcc/po/ja.po b/gcc/po/ja.po index ccab076786a..0e71fa80ed5 100644 --- a/gcc/po/ja.po +++ b/gcc/po/ja.po @@ -20,7 +20,7 @@ msgstr "" "Project-Id-Version: gcc 4.6.1\n" "Report-Msgid-Bugs-To: http://gcc.gnu.org/bugs.html\n" "POT-Creation-Date: 2011-06-21 10:27+0000\n" -"PO-Revision-Date: 2011-08-28 15:06+0900\n" +"PO-Revision-Date: 2011-09-02 18:40+0900\n" "Last-Translator: Yasuaki Taniguchi <yasuakit@gmail.com>\n" "Language-Team: Japanese <translation-team-ja@lists.sourceforge.net>\n" "Language: ja\n" @@ -20088,7 +20088,7 @@ msgstr "~で反転された格上げ符号無し型と定数との比較です" #: c-family/c-common.c:9425 #, gcc-internal-format msgid "comparison of promoted ~unsigned with unsigned" -msgstr "~で反転された格上げ符号無し型と符合無し型との比較です" +msgstr "~で反転された格上げ符号無し型と符号無し型との比較です" #: c-family/c-format.c:127 c-family/c-format.c:314 #, gcc-internal-format diff --git a/gcc/pretty-print.h b/gcc/pretty-print.h index ae1dadfe4a6..bb1d156d31d 100644 --- a/gcc/pretty-print.h +++ b/gcc/pretty-print.h @@ -276,6 +276,8 @@ struct pretty_print_info } \ while (0) #define pp_decimal_int(PP, I) pp_scalar (PP, "%d", I) +#define pp_unsigned_wide_integer(PP, I) \ + pp_scalar (PP, HOST_WIDE_INT_PRINT_UNSIGNED, (unsigned HOST_WIDE_INT) I) #define pp_wide_integer(PP, I) \ pp_scalar (PP, HOST_WIDE_INT_PRINT_DEC, (HOST_WIDE_INT) I) #define pp_widest_integer(PP, I) \ diff --git a/gcc/recog.c b/gcc/recog.c index 22a5402f00f..d3ecb73c4e8 100644 --- a/gcc/recog.c +++ b/gcc/recog.c @@ -118,6 +118,25 @@ init_recog (void) } +/* Return true if labels in asm operands BODY are LABEL_REFs. */ + +static bool +asm_labels_ok (rtx body) +{ + rtx asmop; + int i; + + asmop = extract_asm_operands (body); + if (asmop == NULL_RTX) + return true; + + for (i = 0; i < ASM_OPERANDS_LABEL_LENGTH (asmop); i++) + if (GET_CODE (ASM_OPERANDS_LABEL (asmop, i)) != LABEL_REF) + return false; + + return true; +} + /* Check that X is an insn-body for an `asm' with operands and that the operands mentioned in it are legitimate. */ @@ -129,6 +148,9 @@ check_asm_operands (rtx x) const char **constraints; int i; + if (!asm_labels_ok (x)) + return 0; + /* Post-reload, be more strict with things. */ if (reload_completed) { diff --git a/gcc/stor-layout.c b/gcc/stor-layout.c index f15da0ce30f..359541e02df 100644 --- a/gcc/stor-layout.c +++ b/gcc/stor-layout.c @@ -1959,16 +1959,15 @@ layout_type (tree type) if (integer_zerop (element_size)) length = size_zero_node; - /* The computation should happen in the original type so - that (possible) negative values are handled appropriately. */ + /* The computation should happen in the original signedness so + that (possible) negative values are handled appropriately + when determining overflow. */ else length = fold_convert (sizetype, - fold_build2 (PLUS_EXPR, TREE_TYPE (lb), - build_int_cst (TREE_TYPE (lb), 1), - fold_build2 (MINUS_EXPR, - TREE_TYPE (lb), - ub, lb))); + size_binop (PLUS_EXPR, + build_int_cst (TREE_TYPE (lb), 1), + size_binop (MINUS_EXPR, ub, lb))); TYPE_SIZE (type) = size_binop (MULT_EXPR, element_size, fold_convert (bitsizetype, diff --git a/gcc/target.def b/gcc/target.def index 857f463217f..1e09ba7bfad 100644 --- a/gcc/target.def +++ b/gcc/target.def @@ -913,6 +913,16 @@ the order of instructions is important for correctness when scheduling, but\n\ also the latencies of operations.", bool, false) +/* The following member value is a function that returns number + of operations reassociator should try to put in parallel for + statements of the given type. By default 1 is used. */ +DEFHOOK +(reassociation_width, +"This hook is called by tree reassociator to determine a level of\n\ +parallelism required in output calculations chain.", +int, (unsigned int opc, enum machine_mode mode), +hook_int_uint_mode_1) + HOOK_VECTOR_END (sched) /* Functions relating to vectorization. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3c4932a2374..04d41dcb511 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,181 @@ +2011-09-07 Jiangning Liu <jiangning.liu@arm.com> + + PR tree-optimization/46021 + * gcc.dg/tree-ssa/20040204-1.c: Don't XFAIL on arm*-*-*. + +2011-09-06 Michael Meissner <meissner@linux.vnet.ibm.com> + + * g++.dg/ext/altivec-17.C: Fix dg-error to match current compiler. + +2011-09-06 Eric Botcazou <ebotcazou@adacore.com> + + * gcc.c-torture/compile/20110906-1.c: New test. + +2011-09-06 Uros Bizjak <ubizjak@gmail.com> + + * gcc.target/i386/builtin-apply-mmx.c: Require ia32 effective target. + +2011-09-06 Enkovich Ilya <ilya.enkovich@intel.com> + + * gcc.dg/tree-ssa/pr38533.c (dg-options): Added option + --param tree-reassoc-width=1. + + * gcc.dg/tree-ssa/reassoc-24.c: New test. + * gcc.dg/tree-ssa/reassoc-25.c: Likewise. + +2011-09-06 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/48149 + * gcc.dg/tree-ssa/ssa-fre-32.c: New testcase. + +2011-09-06 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/48317 + * gcc.dg/tree-ssa/ssa-fre-31.c: New testcase. + +2011-09-06 Ira Rosen <ira.rosen@linaro.org> + + * lib/target-supports.exp (check_effective_target_vect_multiple_sizes): + New procedure. + (add_options_for_quad_vectors): Replace with ... + (add_options_for_double_vectors): ... this. + * gfortran.dg/vect/pr19049.f90: Expect more printings on targets that + support multiple vector sizes since the vectorizer attempts to + vectorize with both vector sizes. + * gcc.dg/vect/no-vfa-vect-79.c, + gcc.dg/vect/no-vfa-vect-102a.c, gcc.dg/vect/vect-outer-1a.c, + gcc.dg/vect/vect-outer-1b.c, gcc.dg/vect/vect-outer-2b.c, + gcc.dg/vect/vect-outer-3a.c, gcc.dg/vect/no-vfa-vect-37.c, + gcc.dg/vect/vect-outer-3b.c, gcc.dg/vect/no-vfa-vect-101.c, + gcc.dg/vect/no-vfa-vect-102.c, gcc.dg/vect/vect-reduc-dot-s8b.c, + gcc.dg/vect/vect-outer-1.c, gcc.dg/vect/vect-104.c: Likewise. + * gcc.dg/vect/vect-42.c: Run with 64 bit vectors if applicable. + * gcc.dg/vect/vect-multitypes-6.c, gcc.dg/vect/vect-52.c, + gcc.dg/vect/vect-54.c, gcc.dg/vect/vect-46.c, gcc.dg/vect/vect-48.c, + gcc.dg/vect/vect-96.c, gcc.dg/vect/vect-multitypes-3.c, + gcc.dg/vect/vect-40.c: Likewise. + * gcc.dg/vect/vect-outer-5.c: Remove quad-vectors option as + redundant. + * gcc.dg/vect/vect-109.c, gcc.dg/vect/vect-peel-1.c, + gcc.dg/vect/vect-peel-2.c, gcc.dg/vect/slp-25.c, + gcc.dg/vect/vect-multitypes-1.c, gcc.dg/vect/slp-3.c, + gcc.dg/vect/no-vfa-pr29145.c, gcc.dg/vect/vect-multitypes-4.c: + Likewise. + * gcc.dg/vect/vect-peel-4.c: Make ia global. + +2011-09-05 Richard Sandiford <rdsandiford@googlemail.com> + + PR target/49606 + * gcc.target/mips/abi-main.h: New file. + * gcc.target/mips/abi-o32-long32.c: New test. + * gcc.target/mips/abi-o32-long64.c: Likewise. + * gcc.target/mips/abi-o64-long32.c: Likewise. + * gcc.target/mips/abi-o64-long64.c: Likewise. + * gcc.target/mips/abi-n32-long32.c: Likewise. + * gcc.target/mips/abi-n32-long64.c: Likewise. + * gcc.target/mips/abi-n64-long32.c: Likewise. + * gcc.target/mips/abi-n64-long64.c: Likewise. + * gcc.target/mips/abi-o32-long32-no-shared.c: Likewise. + * gcc.target/mips/abi-o32-long64-no-shared.c: Likewise. + * gcc.target/mips/abi-o64-long32-no-shared.c: Likewise. + * gcc.target/mips/abi-o64-long64-no-shared.c: Likewise. + * gcc.target/mips/abi-n32-long32-no-shared.c: Likewise. + * gcc.target/mips/abi-n32-long64-no-shared.c: Likewise. + * gcc.target/mips/abi-n64-long32-no-shared.c: Likewise. + * gcc.target/mips/abi-n64-long64-no-shared.c: Likewise. + * gcc.target/mips/abi-o32-long32-pic.c: Likewise. + * gcc.target/mips/abi-o32-long64-pic.c: Likewise. + * gcc.target/mips/abi-o64-long32-pic.c: Likewise. + * gcc.target/mips/abi-o64-long64-pic.c: Likewise. + * gcc.target/mips/abi-n32-long32-pic.c: Likewise. + * gcc.target/mips/abi-n32-long64-pic.c: Likewise. + * gcc.target/mips/abi-n64-long32-pic.c: Likewise. + * gcc.target/mips/abi-n64-long64-pic.c: Likewise. + * gcc.target/mips/abi-eabi32-long32.c: Likewise. + * gcc.target/mips/abi-eabi32-long64.c: Likewise. + * gcc.target/mips/abi-eabi64-long32.c: Likewise. + * gcc.target/mips/abi-eabi64-long64.c: Likewise. + * gcc.target/mips/mips.exp: Make -mshared implied -mabicalls. + * gcc.target/mips/branch-2.c: Remove -mabicalls. + * gcc.target/mips/branch-3.c: Likewise. + * gcc.target/mips/branch-4.c: Likewise. + * gcc.target/mips/branch-5.c: Likewise. + * gcc.target/mips/branch-6.c: Likewise. + * gcc.target/mips/branch-7.c: Likewise. + * gcc.target/mips/branch-8.c: Likewise. + * gcc.target/mips/branch-9.c: Likewise. + * gcc.target/mips/branch-10.c: Likewise. + * gcc.target/mips/branch-11.c: Likewise. + * gcc.target/mips/branch-12.c: Likewise. + * gcc.target/mips/branch-13.c: Likewise. + * gcc.target/mips/lazy-binding-1.c: Likewise. + +2011-09-05 Georg-Johann Lay <avr@gjlay.de> + + * gcc.dg/ipa/ipcp-3.c (mark_cell): Use mask 1 << 14 instead of 1 + << 18 to avoid warning on int=16 platforms.. + +2011-09-05 Jakub Jelinek <jakub@redhat.com> + + * gcc.dg/compat/struct-layout-1_test.h: Decrease bitfield size + to work even with -fshort-enums. + +2011-09-04 Jan Hubicka <jh@suse.cz> + + * gcc.c-torture/compile/20110902.c: new testcase. + +2011-09-04 Jason Merrill <jason@redhat.com> + + PR c++/49267 + * g++.dg/cpp0x/rv-conv1.C: New. + + DR 1328 + * g++.dg/cpp0x/rv-func3.C: New. + + * g++.dg/cpp0x/constexpr-default-ctor.C: New. + + PR c++/50248 + Core 1358 + * g++.dg/cpp0x/constexpr-template1.C: New. + * g++.dg/cpp0x/constexpr-template2.C: New. + * g++.dg/cpp0x/constexpr-48089.C: Adjust error markup. + * g++.dg/cpp0x/constexpr-ex1.C: Adjust error markup. + +2011-09-04 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/specs/debug1.ads: Tweak pattern. + +2011-09-04 Janus Weil <janus@gcc.gnu.org> + + PR fortran/50227 + * gfortran.dg/class_45a.f03: New. + * gfortran.dg/class_45b.f03: New. + +2011-09-04 Jakub Jelinek <jakub@redhat.com> + Ira Rosen <ira.rosen@linaro.org> + + PR tree-optimization/50208 + * gcc.dg/vect/no-fre-pre-pr50208.c: New test. + * gcc.dg/vect/vect.exp: Run no-fre-pre-*.c tests with + -fno-tree-fre -fno-tree-pre. + +2011-09-02 Martin Jambor <mjambor@suse.cz> + + * gcc.dg/ipa/ipcp-3.c: New test. + +2011-09-02 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/27460 + PR middle-end/29269 + * gcc.dg/vect/vect-cond-7.c: New testcase. + +2011-09-02 Martin Jambor <mjambor@suse.cz> + + * g++.dg/ipa/devirt-3.C: Added a distraction method. + * g++.dg/ipa/ivinline-7.C: Added a test for direct call discovery, + xfailed test for inlining. + * g++.dg/ipa/ivinline-9.C: Likewise. + 2011-09-01 Ira Rosen <ira.rosen@linaro.org> PR tree-optimization/50178 @@ -63,7 +241,7 @@ * gcc.dg/tree-ssa/ssa-ccp-26.c: Likewise. * gcc.dg/pr36902.c: XFAIL. -2011-08-30 Ilya Tocar <ilya.tocar@intel.com> +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. diff --git a/gcc/testsuite/g++.dg/cpp0x/constexpr-48089.C b/gcc/testsuite/g++.dg/cpp0x/constexpr-48089.C index 5124f7c7f49..a6cf4080756 100644 --- a/gcc/testsuite/g++.dg/cpp0x/constexpr-48089.C +++ b/gcc/testsuite/g++.dg/cpp0x/constexpr-48089.C @@ -14,7 +14,7 @@ struct s { int v; }; -constexpr s bang; // { dg-error "" } +constexpr s bang; // { dg-message "" } struct R { int i,j; @@ -33,7 +33,7 @@ struct T { constexpr T t1; // Ill-formed (diagnostic required) -constexpr T t2(t1); // { dg-error "" } +constexpr T t2(t1); // { dg-message "" } // Well-formed struct U { diff --git a/gcc/testsuite/g++.dg/cpp0x/constexpr-default-ctor.C b/gcc/testsuite/g++.dg/cpp0x/constexpr-default-ctor.C new file mode 100644 index 00000000000..d3868b599ac --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/constexpr-default-ctor.C @@ -0,0 +1,12 @@ +// { dg-options -std=c++0x } + +struct A { + int i; + constexpr A():i(42) { }; +}; +struct B: A { }; +constexpr int f(B b) { return b.i; } + +struct C { C(); }; // { dg-message "calls non-constexpr" } +struct D: C { }; // { dg-message "no constexpr constructor" } +constexpr int g(D d) { return 42; } // { dg-error "invalid type" } diff --git a/gcc/testsuite/g++.dg/cpp0x/constexpr-diag1.C b/gcc/testsuite/g++.dg/cpp0x/constexpr-diag1.C index 44e6bc7e089..cbd4983e84b 100644 --- a/gcc/testsuite/g++.dg/cpp0x/constexpr-diag1.C +++ b/gcc/testsuite/g++.dg/cpp0x/constexpr-diag1.C @@ -17,4 +17,4 @@ constexpr int b = A<B>().f(); // { dg-error "non-constexpr function" } template <class T> constexpr int f (T t) { return 42; } // { dg-error "parameter" } -constexpr int x = f(B()); // { dg-error "constexpr function" } +constexpr int x = f(B()); // { dg-error "constexpr" } diff --git a/gcc/testsuite/g++.dg/cpp0x/constexpr-ex1.C b/gcc/testsuite/g++.dg/cpp0x/constexpr-ex1.C index 584a5a09b69..3df7956fd28 100644 --- a/gcc/testsuite/g++.dg/cpp0x/constexpr-ex1.C +++ b/gcc/testsuite/g++.dg/cpp0x/constexpr-ex1.C @@ -89,6 +89,6 @@ struct resource { }; constexpr resource f(resource d) { return d; } // { dg-error "non-constexpr" } -constexpr resource d = f(9); // { dg-error "resource" } +constexpr resource d = f(9); // { dg-message "constexpr" } // 4.4 floating-point constant expressions diff --git a/gcc/testsuite/g++.dg/cpp0x/constexpr-friend.C b/gcc/testsuite/g++.dg/cpp0x/constexpr-friend.C index 1831a2b003c..57782cf349a 100644 --- a/gcc/testsuite/g++.dg/cpp0x/constexpr-friend.C +++ b/gcc/testsuite/g++.dg/cpp0x/constexpr-friend.C @@ -19,5 +19,5 @@ struct C constexpr int i = f(C<int>()); constexpr int j = C<int>().m(C<int>()); -constexpr int k = C<double>().m(A()); // { dg-error "non-constexpr function" } -constexpr int l = g(C<double>(),A()); // { dg-error "non-constexpr function" } +constexpr int k = C<double>().m(A()); // { dg-error "constexpr" } +constexpr int l = g(C<double>(),A()); // { dg-error "constexpr" } diff --git a/gcc/testsuite/g++.dg/cpp0x/constexpr-template1.C b/gcc/testsuite/g++.dg/cpp0x/constexpr-template1.C new file mode 100644 index 00000000000..88077231b0d --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/constexpr-template1.C @@ -0,0 +1,27 @@ +// PR c++/50248, DR 1358 +// { dg-options -std=c++0x } + +template<class Elt, unsigned max> +struct earray +{ + Elt elts[max]; + earray() = default; + template<typename... Elt2> + constexpr earray(Elt2&& ... e): elts(0) { } +}; + +struct SessionData +{ + SessionData(SessionData&) = delete; + SessionData() = default; +}; + +struct MapSessionData : SessionData +{ + earray<short, 11> equip_index; +}; + +void test() +{ + MapSessionData *sd = new MapSessionData; +} diff --git a/gcc/testsuite/g++.dg/cpp0x/constexpr-template2.C b/gcc/testsuite/g++.dg/cpp0x/constexpr-template2.C new file mode 100644 index 00000000000..6786d1651e5 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/constexpr-template2.C @@ -0,0 +1,12 @@ +// { dg-options -std=c++0x } + +template <class T> struct A +{ + T t; + constexpr A() { } // { dg-error "uninitialized" } +}; + +int main() +{ + constexpr A<int> a; // { dg-error "A()" } +} diff --git a/gcc/testsuite/g++.dg/cpp0x/rv-conv1.C b/gcc/testsuite/g++.dg/cpp0x/rv-conv1.C new file mode 100644 index 00000000000..38529913f85 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/rv-conv1.C @@ -0,0 +1,9 @@ +// PR c++/49267 +// { dg-options -std=c++0x } + +struct X { + operator int&(); + operator int&&(); +}; + +int&&x = X(); diff --git a/gcc/testsuite/g++.dg/cpp0x/rv-func3.C b/gcc/testsuite/g++.dg/cpp0x/rv-func3.C new file mode 100644 index 00000000000..8504682d791 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/rv-func3.C @@ -0,0 +1,10 @@ +// DR 1328 +// { dg-options -std=c++0x } + +template <class T> struct A { + operator T&(); // #1 + operator T&&(); // #2 +}; +typedef int Fn(); +A<Fn> a; +Fn&& f = a; diff --git a/gcc/testsuite/g++.dg/ext/altivec-17.C b/gcc/testsuite/g++.dg/ext/altivec-17.C index 54eff8a24ed..099f8742e78 100644 --- a/gcc/testsuite/g++.dg/ext/altivec-17.C +++ b/gcc/testsuite/g++.dg/ext/altivec-17.C @@ -12,5 +12,5 @@ typedef vector__ bool__ int bool_simd_type; void Foo (bool_simd_type const &a) { - simd_type const &v = a; // { dg-error "'const simd_type&' from expression of type 'const bool_simd_type'" } + simd_type const &v = a; // { dg-error "invalid initialization of reference of type" } } diff --git a/gcc/testsuite/g++.dg/ipa/devirt-3.C b/gcc/testsuite/g++.dg/ipa/devirt-3.C index 2d7bb0ab04e..a68eb024fb4 100644 --- a/gcc/testsuite/g++.dg/ipa/devirt-3.C +++ b/gcc/testsuite/g++.dg/ipa/devirt-3.C @@ -9,6 +9,7 @@ class A { public: int data; + virtual float distraction (float f); virtual int foo (int i); }; @@ -24,6 +25,12 @@ public: virtual int foo (int i); }; +float A::distraction (float f) +{ + f += 6.2; + return f/2; +} + int A::foo (int i) { return i + 1; diff --git a/gcc/testsuite/g++.dg/ipa/ivinline-7.C b/gcc/testsuite/g++.dg/ipa/ivinline-7.C index 5f3596d8d6e..2630dffa9da 100644 --- a/gcc/testsuite/g++.dg/ipa/ivinline-7.C +++ b/gcc/testsuite/g++.dg/ipa/ivinline-7.C @@ -75,5 +75,6 @@ int main (int argc, char *argv[]) return 0; } -/* { dg-final { scan-ipa-dump "B::foo\[^\\n\]*inline copy in int main" "inline" } } */ +/* { dg-final { scan-ipa-dump "Discovered a virtual call to a known target.*B::.*foo" "inline" } } */ +/* { dg-final { scan-ipa-dump "B::foo\[^\\n\]*inline copy in int main" "inline" { xfail *-*-* } } } */ /* { dg-final { cleanup-ipa-dump "inline" } } */ diff --git a/gcc/testsuite/g++.dg/ipa/ivinline-9.C b/gcc/testsuite/g++.dg/ipa/ivinline-9.C index 429b6f4f00c..4ff07a9bbd8 100644 --- a/gcc/testsuite/g++.dg/ipa/ivinline-9.C +++ b/gcc/testsuite/g++.dg/ipa/ivinline-9.C @@ -89,5 +89,6 @@ int main (int argc, char *argv[]) return 0; } -/* { dg-final { scan-ipa-dump "B::foo\[^\\n\]*inline copy in int main" "inline" } } */ +/* { dg-final { scan-ipa-dump "Discovered a virtual call to a known target.*B::.*foo" "inline" } } */ +/* { dg-final { scan-ipa-dump "B::foo\[^\\n\]*inline copy in int main" "inline" { xfail *-*-* } } } */ /* { dg-final { cleanup-ipa-dump "inline" } } */ diff --git a/gcc/testsuite/gcc.c-torture/compile/20110902.c b/gcc/testsuite/gcc.c-torture/compile/20110902.c new file mode 100644 index 00000000000..1556e4a3673 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/compile/20110902.c @@ -0,0 +1,14 @@ +static inline __attribute__((always_inline)) int f (unsigned int n, unsigned int size) +{ + return (__builtin_constant_p (size != 0 && n > ~0 / size) + ? !!(size != 0 && n > ~0 / size) + : ({ static unsigned int count[2] = { 0, 0 }; + int r = !!(size != 0 && n > ~0 / size); + count[r]++; + r; })); +} + +int g (unsigned int size) +{ + return f (size / 4096, 4); +} diff --git a/gcc/testsuite/gcc.c-torture/compile/20110906-1.c b/gcc/testsuite/gcc.c-torture/compile/20110906-1.c new file mode 100644 index 00000000000..50ea9e241b4 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/compile/20110906-1.c @@ -0,0 +1,22 @@ +/* PR middle-end/50266 */ +/* Testcase by <bero@arklinux.org> */ + +struct a { + unsigned int a; + unsigned int b; +}; + +struct a *const p = (struct a *)0x4A004100; + +void foo(void) +{ + unsigned int i = 0; + unsigned int *const x[] = { + &p->a, + &p->b, + 0 + }; + + (*(volatile unsigned int *)((x[i])) + = (unsigned int)((unsigned int)((*(volatile unsigned int *)(x[i]))))); +} diff --git a/gcc/testsuite/gcc.dg/compat/struct-layout-1_test.h b/gcc/testsuite/gcc.dg/compat/struct-layout-1_test.h index 4a70dfd0601..affddcaefa8 100644 --- a/gcc/testsuite/gcc.dg/compat/struct-layout-1_test.h +++ b/gcc/testsuite/gcc.dg/compat/struct-layout-1_test.h @@ -1,5 +1 @@ -#if (__SIZEOF_INT__ >= 4) -T(0,enum E2 a:31;,B(0,a,e2_m1,e2_0)) -#else -T(0,enum E2 a:15;,B(0,a,e2_m1,e2_0)) -#endif +T(0,enum E2 a:7;,B(0,a,e2_m1,e2_0)) diff --git a/gcc/testsuite/gcc.dg/ipa/ipcp-3.c b/gcc/testsuite/gcc.dg/ipa/ipcp-3.c new file mode 100644 index 00000000000..af4f50b2739 --- /dev/null +++ b/gcc/testsuite/gcc.dg/ipa/ipcp-3.c @@ -0,0 +1,70 @@ +/* Verify that IPA-CP can clone mark_cell without miscompiling it despite its + type_attributes. */ +/* { dg-do run } */ +/* { dg-options "-O3 -fdump-ipa-cp" } */ + + +struct PMC { + unsigned flags; +}; + +typedef struct Pcc_cell +{ + struct PMC *p; + long bla; + long type; +} Pcc_cell; + +int gi; + +extern void abort (); +extern void never_ever(int * interp, struct PMC *pmc) + __attribute__((noinline)); + +void never_ever (int * interp, struct PMC *pmc) +{ + abort (); +} + +static void mark_cell(int * interp, Pcc_cell *c) + __attribute__((__nonnull__(1))) + __attribute__((noinline)); + +static void +mark_cell(int * interp, Pcc_cell *c) +{ + if (c && c->type == 4 && c->p + && !(c->p->flags & (1<<14))) + never_ever(interp, c->p); +} + +static void foo(int * interp, Pcc_cell *c) + __attribute__((noinline)); + +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; + + for (i = 0; i < 100; i++) + foo (&gi, getnull ()); + return 0; +} + + +/* { dg-final { scan-ipa-dump "Creating a specialized node of mark_cell" "cp" } } */ +/* { dg-final { cleanup-ipa-dump "cp" } } */ + diff --git a/gcc/testsuite/gcc.dg/tree-ssa/20040204-1.c b/gcc/testsuite/gcc.dg/tree-ssa/20040204-1.c index 45e44a1b26a..470b585fd53 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/20040204-1.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/20040204-1.c @@ -33,5 +33,5 @@ void test55 (int x, int y) that the && should be emitted (based on BRANCH_COST). Fix this by teaching dom to look through && and register all components as true. */ -/* { dg-final { scan-tree-dump-times "link_error" 0 "optimized" { xfail { ! "alpha*-*-* powerpc*-*-* cris-*-* crisv32-*-* hppa*-*-* i?86-*-* mmix-*-* mips*-*-* m68k*-*-* moxie-*-* sparc*-*-* spu-*-* x86_64-*-*" } } } } */ +/* { dg-final { scan-tree-dump-times "link_error" 0 "optimized" { xfail { ! "alpha*-*-* arm*-*-* powerpc*-*-* cris-*-* crisv32-*-* hppa*-*-* i?86-*-* mmix-*-* mips*-*-* m68k*-*-* moxie-*-* sparc*-*-* spu-*-* x86_64-*-*" } } } } */ /* { dg-final { cleanup-tree-dump "optimized" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr38533.c b/gcc/testsuite/gcc.dg/tree-ssa/pr38533.c index e7872276047..a80a5a81390 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/pr38533.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr38533.c @@ -1,6 +1,6 @@ /* PR middle-end/38533 */ /* { dg-do compile } */ -/* { dg-options "-O2 -fdump-tree-reassoc1" } */ +/* { dg-options "-O2 --param tree-reassoc-width=1 -fdump-tree-reassoc1" } */ #define A asm volatile ("" : "=r" (f) : "0" (0)); e |= f; #define B A A A A A A A A A A A diff --git a/gcc/testsuite/gcc.dg/tree-ssa/reassoc-24.c b/gcc/testsuite/gcc.dg/tree-ssa/reassoc-24.c new file mode 100644 index 00000000000..c871628abc6 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/reassoc-24.c @@ -0,0 +1,25 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 --param tree-reassoc-width=2 -fdump-tree-reassoc1" } */ + +unsigned int +foo (void) +{ + unsigned int a = 0; + unsigned int b; + + asm volatile ("" : "=r" (b) : "0" (0)); + a += b; + asm volatile ("" : "=r" (b) : "0" (0)); + a += b; + asm volatile ("" : "=r" (b) : "0" (0)); + a += b; + asm volatile ("" : "=r" (b) : "0" (0)); + a += b; + + return a; +} + +/* Verify there are two pairs of __asm__ statements with no + intervening stmts. */ +/* { dg-final { scan-tree-dump-times "__asm__\[^;\n]*;\n *__asm__" 2 "reassoc1"} } */ +/* { dg-final { cleanup-tree-dump "reassoc1" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/reassoc-25.c b/gcc/testsuite/gcc.dg/tree-ssa/reassoc-25.c new file mode 100644 index 00000000000..4ff66ef8d05 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/reassoc-25.c @@ -0,0 +1,19 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 --param tree-reassoc-width=3 -fdump-tree-reassoc1-details" } */ + +unsigned int +foo (int a, int b, int c, int d) +{ + unsigned int s = 0; + + s += a; + s += b; + s += c; + s += d; + + return s; +} + +/* Verify reassociation width was chosen to be 2. */ +/* { dg-final { scan-tree-dump-times "Width = 2" 1 "reassoc1"} } */ +/* { dg-final { cleanup-tree-dump "reassoc1" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-31.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-31.c new file mode 100644 index 00000000000..42257cca5ad --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-31.c @@ -0,0 +1,46 @@ +/* { dg-do compile } */ +/* { dg-options "-O -fdump-tree-fre1-details" } */ + +typedef double d128 __attribute__((vector_size(16))); +typedef float f128 __attribute__((vector_size(16))); +typedef short s128 __attribute__((vector_size(16))); +typedef char c256 __attribute__((vector_size(32))); + +d128 d; +f128 f; +s128 s; +c256 c; + +void test1 (double x) +{ + d = (d128){x + x, x + x}; + d = (d128){x + x, x + x}; +} + +void test2 (float x) +{ + f = (f128){x + x, x + x, x + x, x + x}; + f = (f128){x + x, x + x, x + x, x + x}; +} + +void test3 (short x) +{ + s = (s128){x + x, x + x, x + x, x + x, x + x, x + x, x + x, x + x}; + s = (s128){x + x, x + x, x + x, x + x, x + x, x + x, x + x, x + x}; +} + +void test4 (unsigned char x) +{ + c = (c256){x + x, x + x, x + x, x + x, x + x, x + x, x + x, x + x, + x + x, x + x, x + x, x + x, x + x, x + x, x + x, x + x, + x + x, x + x, x + x, x + x, x + x, x + x, x + x, x + x, + x + x, x + x, x + x, x + x, x + x, x + x, x + x, x + x}; + c = (c256){x + x, x + x, x + x, x + x, x + x, x + x, x + x, x + x, + x + x, x + x, x + x, x + x, x + x, x + x, x + x, x + x, + x + x, x + x, x + x, x + x, x + x, x + x, x + x, x + x, + x + x, x + x, x + x, x + x, x + x, x + x, x + x, x + x}; +} + +/* { dg-final { scan-tree-dump-times "Replaced \{" 4 "fre1" } } */ +/* { dg-final { scan-tree-dump-times "Deleted redundant store" 4 "fre1" } } */ +/* { dg-final { cleanup-tree-dump "fre1" } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-32.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-32.c new file mode 100644 index 00000000000..537fd5a6bcb --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-fre-32.c @@ -0,0 +1,28 @@ +/* { dg-do compile } */ +/* { dg-options "-O -fdump-tree-fre1-details" } */ + +_Complex float +foo (_Complex float x) +{ + float r = __real x; + float i = __imag x; + _Complex float z; + __real z = r; + __imag z = i; + return z; +} + +_Complex float +bar (_Complex float x) +{ + float r = __real x; + float i = __imag x; + _Complex float z = x; + __real z = r; + __imag z = i; + return z; +} + +/* We should CSE all the way to replace the final assignment to z with x. */ +/* { dg-final { scan-tree-dump-times "with x_1\\\(D\\\) in z" 3 "fre1" } } */ +/* { dg-final { cleanup-tree-dump "fre1" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/no-fre-pre-pr50208.c b/gcc/testsuite/gcc.dg/vect/no-fre-pre-pr50208.c new file mode 100644 index 00000000000..26e2a644694 --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/no-fre-pre-pr50208.c @@ -0,0 +1,17 @@ +/* { dg-do compile } */ + +char c; +int a, b; + +void foo (int j) +{ + int i; + while (--j) + { + b = 3; + for (i = 0; i < 2; ++i) + a = b ^ c; + } +} + +/* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/no-vfa-pr29145.c b/gcc/testsuite/gcc.dg/vect/no-vfa-pr29145.c index 0bbb8e943ce..e475ffff638 100644 --- a/gcc/testsuite/gcc.dg/vect/no-vfa-pr29145.c +++ b/gcc/testsuite/gcc.dg/vect/no-vfa-pr29145.c @@ -1,5 +1,4 @@ /* { dg-require-effective-target vect_int } */ -/* { dg-add-options quad_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/no-vfa-vect-101.c b/gcc/testsuite/gcc.dg/vect/no-vfa-vect-101.c index 1830eb8aa27..3a54a753065 100644 --- a/gcc/testsuite/gcc.dg/vect/no-vfa-vect-101.c +++ b/gcc/testsuite/gcc.dg/vect/no-vfa-vect-101.c @@ -45,6 +45,7 @@ int main (void) } /* { dg-final { scan-tree-dump-times "vectorized 1 loops" 0 "vect" } } */ -/* { dg-final { scan-tree-dump-times "can't determine dependence" 1 "vect" } } */ +/* { dg-final { scan-tree-dump-times "can't determine dependence" 1 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "can't determine dependence" 2 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/no-vfa-vect-102.c b/gcc/testsuite/gcc.dg/vect/no-vfa-vect-102.c index e49633e0253..a8d3b042dc6 100644 --- a/gcc/testsuite/gcc.dg/vect/no-vfa-vect-102.c +++ b/gcc/testsuite/gcc.dg/vect/no-vfa-vect-102.c @@ -53,6 +53,7 @@ int main (void) } /* { dg-final { scan-tree-dump-times "vectorized 1 loops" 0 "vect" } } */ -/* { dg-final { scan-tree-dump-times "possible dependence between data-refs" 1 "vect" } } */ +/* { dg-final { scan-tree-dump-times "possible dependence between data-refs" 1 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "possible dependence between data-refs" 2 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/no-vfa-vect-102a.c b/gcc/testsuite/gcc.dg/vect/no-vfa-vect-102a.c index da8afaa1a7d..41bbbc15cb2 100644 --- a/gcc/testsuite/gcc.dg/vect/no-vfa-vect-102a.c +++ b/gcc/testsuite/gcc.dg/vect/no-vfa-vect-102a.c @@ -53,6 +53,7 @@ int main (void) } /* { dg-final { scan-tree-dump-times "vectorized 1 loops" 0 "vect" } } */ -/* { dg-final { scan-tree-dump-times "possible dependence between data-refs" 1 "vect" } } */ +/* { dg-final { scan-tree-dump-times "possible dependence between data-refs" 1 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "possible dependence between data-refs" 2 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/no-vfa-vect-37.c b/gcc/testsuite/gcc.dg/vect/no-vfa-vect-37.c index dc17239a3b4..c8cf2cafb90 100644 --- a/gcc/testsuite/gcc.dg/vect/no-vfa-vect-37.c +++ b/gcc/testsuite/gcc.dg/vect/no-vfa-vect-37.c @@ -58,5 +58,6 @@ int main (void) If/when the aliasing problems are resolved, unalignment may prevent vectorization on some targets. */ /* { dg-final { scan-tree-dump-times "vectorized 2 loops" 1 "vect" { xfail *-*-* } } } */ -/* { dg-final { scan-tree-dump-times "can't determine dependence between" 2 "vect" } } */ +/* { dg-final { scan-tree-dump-times "can't determine dependence" 2 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "can't determine dependence" 4 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/no-vfa-vect-79.c b/gcc/testsuite/gcc.dg/vect/no-vfa-vect-79.c index 1a694b33e05..3c5ce4be847 100644 --- a/gcc/testsuite/gcc.dg/vect/no-vfa-vect-79.c +++ b/gcc/testsuite/gcc.dg/vect/no-vfa-vect-79.c @@ -46,5 +46,6 @@ int main (void) If/when the aliasing problems are resolved, unalignment may prevent vectorization on some targets. */ /* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ -/* { dg-final { scan-tree-dump-times "can't determine dependence between" 1 "vect" } } */ +/* { dg-final { scan-tree-dump-times "can't determine dependence" 1 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "can't determine dependence" 2 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/slp-25.c b/gcc/testsuite/gcc.dg/vect/slp-25.c index 45176398834..0dec2f11cdc 100644 --- a/gcc/testsuite/gcc.dg/vect/slp-25.c +++ b/gcc/testsuite/gcc.dg/vect/slp-25.c @@ -1,5 +1,4 @@ /* { dg-require-effective-target vect_int } */ -/* { dg-add-options quad_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/slp-3.c b/gcc/testsuite/gcc.dg/vect/slp-3.c index 9a504d901e0..7d9bd563739 100644 --- a/gcc/testsuite/gcc.dg/vect/slp-3.c +++ b/gcc/testsuite/gcc.dg/vect/slp-3.c @@ -1,5 +1,4 @@ /* { dg-require-effective-target vect_int } */ -/* { dg-add-options quad_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-104.c b/gcc/testsuite/gcc.dg/vect/vect-104.c index 5ea2f801a28..2b56ddfb3c7 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-104.c +++ b/gcc/testsuite/gcc.dg/vect/vect-104.c @@ -64,6 +64,7 @@ int main (void) } /* { dg-final { scan-tree-dump-times "vectorized 1 loops" 0 "vect" } } */ -/* { dg-final { scan-tree-dump-times "possible dependence between data-refs" 1 "vect" } } */ +/* { dg-final { scan-tree-dump-times "possible dependence between data-refs" 1 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "possible dependence between data-refs" 2 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/vect-109.c b/gcc/testsuite/gcc.dg/vect/vect-109.c index 1f2f53ed9eb..854c9707a6d 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-109.c +++ b/gcc/testsuite/gcc.dg/vect/vect-109.c @@ -1,5 +1,4 @@ /* { dg-require-effective-target vect_int } */ -/* { dg-add-options quad_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-40.c b/gcc/testsuite/gcc.dg/vect/vect-40.c index d2c17d1d97d..269b0895549 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-40.c +++ b/gcc/testsuite/gcc.dg/vect/vect-40.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target vect_float } */ +/* { dg-add-options double_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-42.c b/gcc/testsuite/gcc.dg/vect/vect-42.c index b9faea491d9..31810817b46 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-42.c +++ b/gcc/testsuite/gcc.dg/vect/vect-42.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target vect_float } */ +/* { dg-add-options double_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-46.c b/gcc/testsuite/gcc.dg/vect/vect-46.c index d506d4329c0..26e0e520b9e 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-46.c +++ b/gcc/testsuite/gcc.dg/vect/vect-46.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target vect_float } */ +/* { dg-add-options double_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-48.c b/gcc/testsuite/gcc.dg/vect/vect-48.c index e47ee00de91..d2eed3a6b97 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-48.c +++ b/gcc/testsuite/gcc.dg/vect/vect-48.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target vect_float } */ +/* { dg-add-options double_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-52.c b/gcc/testsuite/gcc.dg/vect/vect-52.c index af485abbd14..69c097966ed 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-52.c +++ b/gcc/testsuite/gcc.dg/vect/vect-52.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target vect_float } */ +/* { dg-add-options double_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-54.c b/gcc/testsuite/gcc.dg/vect/vect-54.c index 629e82df59b..d563cc34b2d 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-54.c +++ b/gcc/testsuite/gcc.dg/vect/vect-54.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target vect_float } */ +/* { dg-add-options double_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-96.c b/gcc/testsuite/gcc.dg/vect/vect-96.c index 049ac243403..0060d4eb4bf 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-96.c +++ b/gcc/testsuite/gcc.dg/vect/vect-96.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target vect_int } */ +/* { dg-add-options double_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-multitypes-1.c b/gcc/testsuite/gcc.dg/vect/vect-multitypes-1.c index 5e2b41a82f6..7981c4a475f 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-multitypes-1.c +++ b/gcc/testsuite/gcc.dg/vect/vect-multitypes-1.c @@ -1,5 +1,4 @@ /* { dg-require-effective-target vect_int } */ -/* { dg-add-options quad_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-multitypes-3.c b/gcc/testsuite/gcc.dg/vect/vect-multitypes-3.c index 3346e71e523..93796d0cec3 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-multitypes-3.c +++ b/gcc/testsuite/gcc.dg/vect/vect-multitypes-3.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target vect_int } */ +/* { dg-add-options double_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-multitypes-4.c b/gcc/testsuite/gcc.dg/vect/vect-multitypes-4.c index 9cb6817cec1..ed6ac6eda6b 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-multitypes-4.c +++ b/gcc/testsuite/gcc.dg/vect/vect-multitypes-4.c @@ -1,5 +1,4 @@ /* { dg-require-effective-target vect_int } */ -/* { dg-add-options quad_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-multitypes-6.c b/gcc/testsuite/gcc.dg/vect/vect-multitypes-6.c index 5bb4be8c37a..7f72785069a 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-multitypes-6.c +++ b/gcc/testsuite/gcc.dg/vect/vect-multitypes-6.c @@ -1,4 +1,5 @@ /* { dg-require-effective-target vect_int } */ +/* { dg-add-options double_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-outer-1.c b/gcc/testsuite/gcc.dg/vect/vect-outer-1.c index f0df5d4cd9d..2ce8f8ebac8 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-outer-1.c +++ b/gcc/testsuite/gcc.dg/vect/vect-outer-1.c @@ -22,5 +22,6 @@ foo (){ } /* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" { xfail *-*-* } } } */ -/* { dg-final { scan-tree-dump-times "strided access in outer loop" 1 "vect" } } */ +/* { dg-final { scan-tree-dump-times "strided access in outer loop" 1 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "strided access in outer loop" 2 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/vect-outer-1a.c b/gcc/testsuite/gcc.dg/vect/vect-outer-1a.c index f88dd21059b..a9b786e235c 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-outer-1a.c +++ b/gcc/testsuite/gcc.dg/vect/vect-outer-1a.c @@ -20,5 +20,6 @@ foo (){ } /* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" { xfail *-*-* } } } */ -/* { dg-final { scan-tree-dump-times "strided access in outer loop" 1 "vect" } } */ +/* { dg-final { scan-tree-dump-times "strided access in outer loop" 1 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "strided access in outer loop" 2 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/vect-outer-1b.c b/gcc/testsuite/gcc.dg/vect/vect-outer-1b.c index e093d0ea365..815758c766f 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-outer-1b.c +++ b/gcc/testsuite/gcc.dg/vect/vect-outer-1b.c @@ -22,5 +22,6 @@ foo (){ } /* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" { xfail *-*-* } } } */ -/* { dg-final { scan-tree-dump-times "strided access in outer loop" 1 "vect" } } */ +/* { dg-final { scan-tree-dump-times "strided access in outer loop" 1 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "strided access in outer loop" 2 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/vect-outer-2b.c b/gcc/testsuite/gcc.dg/vect/vect-outer-2b.c index df2e6a7b129..cb62881f004 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-outer-2b.c +++ b/gcc/testsuite/gcc.dg/vect/vect-outer-2b.c @@ -37,5 +37,6 @@ int main (void) return 0; } -/* { dg-final { scan-tree-dump-times "strided access in outer loop." 1 "vect" } } */ +/* { dg-final { scan-tree-dump-times "strided access in outer loop" 1 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "strided access in outer loop" 2 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/vect-outer-3a.c b/gcc/testsuite/gcc.dg/vect/vect-outer-3a.c index 4b5107dcf4e..1759ee38db7 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-outer-3a.c +++ b/gcc/testsuite/gcc.dg/vect/vect-outer-3a.c @@ -49,5 +49,6 @@ int main (void) } /* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" { xfail vect_no_align } } } */ -/* { dg-final { scan-tree-dump-times "step doesn't divide the vector-size" 2 "vect" } } */ +/* { dg-final { scan-tree-dump-times "step doesn't divide the vector-size" 2 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "step doesn't divide the vector-size" 3 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/vect-outer-3b.c b/gcc/testsuite/gcc.dg/vect/vect-outer-3b.c index f11cb751ca4..fda8727bf68 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-outer-3b.c +++ b/gcc/testsuite/gcc.dg/vect/vect-outer-3b.c @@ -49,5 +49,6 @@ int main (void) } /* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" { xfail *-*-* } } } */ -/* { dg-final { scan-tree-dump-times "strided access in outer loop" 2 "vect" } } */ +/* { dg-final { scan-tree-dump-times "strided access in outer loop" 2 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "strided access in outer loop" 4 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/vect-outer-5.c b/gcc/testsuite/gcc.dg/vect/vect-outer-5.c index 05ed39a3da2..e319d77e492 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-outer-5.c +++ b/gcc/testsuite/gcc.dg/vect/vect-outer-5.c @@ -1,5 +1,4 @@ /* { dg-require-effective-target vect_float } */ -/* { dg-add-options quad_vectors } */ #include <stdarg.h> #include <signal.h> diff --git a/gcc/testsuite/gcc.dg/vect/vect-peel-1.c b/gcc/testsuite/gcc.dg/vect/vect-peel-1.c index 2a150e91203..342da1827a2 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-peel-1.c +++ b/gcc/testsuite/gcc.dg/vect/vect-peel-1.c @@ -1,5 +1,4 @@ /* { dg-require-effective-target vect_int } */ -/* { dg-add-options quad_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-peel-2.c b/gcc/testsuite/gcc.dg/vect/vect-peel-2.c index 126c2cf1139..6a764c15040 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-peel-2.c +++ b/gcc/testsuite/gcc.dg/vect/vect-peel-2.c @@ -1,5 +1,4 @@ /* { dg-require-effective-target vect_int } */ -/* { dg-add-options quad_vectors } */ #include <stdarg.h> #include "tree-vect.h" diff --git a/gcc/testsuite/gcc.dg/vect/vect-peel-4.c b/gcc/testsuite/gcc.dg/vect/vect-peel-4.c index 1b47f2682bb..dffb858e2b2 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-peel-4.c +++ b/gcc/testsuite/gcc.dg/vect/vect-peel-4.c @@ -6,12 +6,12 @@ #define N 128 int ib[N+7]; +int ia[N+1]; __attribute__ ((noinline)) int main1 () { int i; - int ia[N+1]; /* Don't peel keeping one load and the store aligned. */ for (i = 0; i <= N; i++) diff --git a/gcc/testsuite/gcc.dg/vect/vect-reduc-dot-s8b.c b/gcc/testsuite/gcc.dg/vect/vect-reduc-dot-s8b.c index 53a240118c6..dc9eb61580d 100644 --- a/gcc/testsuite/gcc.dg/vect/vect-reduc-dot-s8b.c +++ b/gcc/testsuite/gcc.dg/vect/vect-reduc-dot-s8b.c @@ -58,7 +58,8 @@ int main (void) } /* { dg-final { scan-tree-dump-times "vect_recog_dot_prod_pattern: detected" 1 "vect" { xfail *-*-* } } } */ -/* { dg-final { scan-tree-dump-times "vect_recog_widen_mult_pattern: detected" 1 "vect" } } */ +/* { dg-final { scan-tree-dump-times "vect_recog_widen_mult_pattern: detected" 1 "vect" { xfail vect_multiple_sizes } } } */ +/* { dg-final { scan-tree-dump-times "vect_recog_widen_mult_pattern: detected" 2 "vect" { target vect_multiple_sizes } } } */ /* { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { xfail *-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/vect/vect.exp b/gcc/testsuite/gcc.dg/vect/vect.exp index ab92be47ab8..8f57f29ad09 100644 --- a/gcc/testsuite/gcc.dg/vect/vect.exp +++ b/gcc/testsuite/gcc.dg/vect/vect.exp @@ -263,6 +263,12 @@ lappend DEFAULT_VECTCFLAGS "-fno-tree-fre" dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/no-tree-fre-*.\[cS\]]] \ "" $DEFAULT_VECTCFLAGS +# -fno-tree-fre -fno-tree-pre +set DEFAULT_VECTCFLAGS $SAVED_DEFAULT_VECTCFLAGS +lappend DEFAULT_VECTCFLAGS "-fno-tree-fre" "-fno-tree-pre" +dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/no-fre-pre*.\[cS\]]] \ + "" $DEFAULT_VECTCFLAGS + # Clean up. set dg-do-what-default ${save-dg-do-what-default} diff --git a/gcc/testsuite/gcc.target/i386/builtin-apply-mmx.c b/gcc/testsuite/gcc.target/i386/builtin-apply-mmx.c index f6477e264a2..badfe03a97d 100644 --- a/gcc/testsuite/gcc.target/i386/builtin-apply-mmx.c +++ b/gcc/testsuite/gcc.target/i386/builtin-apply-mmx.c @@ -11,7 +11,7 @@ /* { dg-do run { xfail { ! *-*-darwin* } } } */ /* { dg-options "-O2 -mmmx" } */ -/* { dg-require-effective-target ilp32 } */ +/* { dg-require-effective-target ia32 } */ #include "mmx-check.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-eabi32-long32.c b/gcc/testsuite/gcc.target/mips/abi-eabi32-long32.c new file mode 100644 index 00000000000..ebc5dd67240 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-eabi32-long32.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=eabi -mgp32 -mlong32 -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-eabi32-long64.c b/gcc/testsuite/gcc.target/mips/abi-eabi32-long64.c new file mode 100644 index 00000000000..5a776eca988 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-eabi32-long64.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=eabi -mgp32 -mlong64 -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-eabi64-long32.c b/gcc/testsuite/gcc.target/mips/abi-eabi64-long32.c new file mode 100644 index 00000000000..3882e48fa35 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-eabi64-long32.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=eabi -mgp64 -mlong32 -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-eabi64-long64.c b/gcc/testsuite/gcc.target/mips/abi-eabi64-long64.c new file mode 100644 index 00000000000..5569bf521e8 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-eabi64-long64.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=eabi -mgp64 -mlong64 -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-main.h b/gcc/testsuite/gcc.target/mips/abi-main.h new file mode 100644 index 00000000000..f47a2e30492 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-main.h @@ -0,0 +1,74 @@ +#define FOR_EACH_SCALAR(F) \ + F(sc, signed char) \ + F(uc, unsigned char) \ + F(ss, short) \ + F(us, unsigned short) \ + F(si, int) \ + F(ui, unsigned int) \ + F(sl, long) \ + F(ul, unsigned long) \ + F(sll, long long) \ + F(ull, unsigned long long) \ + F(f, float) \ + F(d, double) \ + F(ld, long double) \ + F(ptr, void *) + +#define EXTERN(SUFFIX, TYPE) extern TYPE x##SUFFIX; +#define STATIC(SUFFIX, TYPE) static TYPE s##SUFFIX; +#define COMMON(SUFFIX, TYPE) TYPE c##SUFFIX; + +#define GETADDR(SUFFIX, TYPE) \ + TYPE *get##SUFFIX (int which) \ + { \ + return (which == 0 ? &c##SUFFIX \ + : which == 1 ? &s##SUFFIX \ + : &x##SUFFIX); \ + } + +#define COPY(SUFFIX, TYPE) c##SUFFIX = s##SUFFIX; s##SUFFIX = x##SUFFIX; + +FOR_EACH_SCALAR (EXTERN) +FOR_EACH_SCALAR (STATIC) +FOR_EACH_SCALAR (COMMON) + +FOR_EACH_SCALAR (GETADDR) + +void +copy (void) +{ + FOR_EACH_SCALAR (COPY); +} + +extern void foo (int); + +void +sibcall1 (void) +{ + foo (1); +} + +void +sibcall2 (void) +{ + foo (csi + ssi + xsi); +} + +static void +sibcall3 (void) +{ + foo (1); + foo (2); + foo (3); +} + +extern void bar (void (*) (void)); + +int +nested (int x) +{ + void sub (void) { foo (x); } + bar (sub); + bar (sibcall3); + return 1; +} diff --git a/gcc/testsuite/gcc.target/mips/abi-n32-long32-no-shared.c b/gcc/testsuite/gcc.target/mips/abi-n32-long32-no-shared.c new file mode 100644 index 00000000000..5cab4c97a62 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n32-long32-no-shared.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=n32 -mlong32 -mabicalls -mno-shared -mno-plt -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-n32-long32-pic.c b/gcc/testsuite/gcc.target/mips/abi-n32-long32-pic.c new file mode 100644 index 00000000000..eb455da96a8 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n32-long32-pic.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=n32 -mlong32 -fpic -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-n32-long32.c b/gcc/testsuite/gcc.target/mips/abi-n32-long32.c new file mode 100644 index 00000000000..6a0f7023c9d --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n32-long32.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=n32 -mlong32 addressing=absolute -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-n32-long64-no-shared.c b/gcc/testsuite/gcc.target/mips/abi-n32-long64-no-shared.c new file mode 100644 index 00000000000..3edf86787cb --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n32-long64-no-shared.c @@ -0,0 +1,3 @@ +/* { dg-options "-mabi=n32 -mlong64 -mabicalls -mno-shared -mno-plt -O2" } */ +/* { dg-error "is incompatible with" "" { target *-*-* } 0 } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-n32-long64-pic.c b/gcc/testsuite/gcc.target/mips/abi-n32-long64-pic.c new file mode 100644 index 00000000000..b444209e3b9 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n32-long64-pic.c @@ -0,0 +1,3 @@ +/* { dg-options "-mabi=n32 -mlong64 -fpic -O2" } */ +/* { dg-error "is incompatible with" "" { target *-*-* } 0 } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-n32-long64.c b/gcc/testsuite/gcc.target/mips/abi-n32-long64.c new file mode 100644 index 00000000000..868719c445f --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n32-long64.c @@ -0,0 +1,3 @@ +/* { dg-options "-mabi=n32 -mlong64 addressing=absolute -O2" } */ +/* { dg-error "is incompatible with" "" { target *-*-* } 0 } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-n64-long32-no-shared.c b/gcc/testsuite/gcc.target/mips/abi-n64-long32-no-shared.c new file mode 100644 index 00000000000..b268d888a46 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n64-long32-no-shared.c @@ -0,0 +1,3 @@ +/* { dg-options "-mabi=64 -mlong32 -mabicalls -mno-shared -mno-plt -O2" } */ +/* { dg-error "is incompatible with" "" { target *-*-* } 0 } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-n64-long32-pic.c b/gcc/testsuite/gcc.target/mips/abi-n64-long32-pic.c new file mode 100644 index 00000000000..5a0d9172651 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n64-long32-pic.c @@ -0,0 +1,3 @@ +/* { dg-options "-mabi=64 -mlong32 -fpic -O2" } */ +/* { dg-error "is incompatible with" "" { target *-*-* } 0 } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-n64-long32.c b/gcc/testsuite/gcc.target/mips/abi-n64-long32.c new file mode 100644 index 00000000000..4227169ec7e --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n64-long32.c @@ -0,0 +1,3 @@ +/* { dg-options "-mabi=64 -mlong32 addressing=absolute -O2" } */ +/* { dg-error "is incompatible with" "" { target *-*-* } 0 } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-n64-long64-no-shared.c b/gcc/testsuite/gcc.target/mips/abi-n64-long64-no-shared.c new file mode 100644 index 00000000000..5301cfc5b73 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n64-long64-no-shared.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=64 -mlong64 -mabicalls -mno-shared -mno-plt -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-n64-long64-pic.c b/gcc/testsuite/gcc.target/mips/abi-n64-long64-pic.c new file mode 100644 index 00000000000..f43e9157bad --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n64-long64-pic.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=64 -mlong64 -fpic -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-n64-long64.c b/gcc/testsuite/gcc.target/mips/abi-n64-long64.c new file mode 100644 index 00000000000..a670fe5af91 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-n64-long64.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=64 -mlong64 addressing=absolute -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o32-long32-no-shared.c b/gcc/testsuite/gcc.target/mips/abi-o32-long32-no-shared.c new file mode 100644 index 00000000000..2032b36d9d0 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o32-long32-no-shared.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=32 -mlong32 -mabicalls -mno-shared -mno-plt -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o32-long32-pic.c b/gcc/testsuite/gcc.target/mips/abi-o32-long32-pic.c new file mode 100644 index 00000000000..5a3e93effaf --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o32-long32-pic.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=32 -mlong32 -fpic -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o32-long32.c b/gcc/testsuite/gcc.target/mips/abi-o32-long32.c new file mode 100644 index 00000000000..bdb9464c74a --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o32-long32.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=32 -mlong32 addressing=absolute -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o32-long64-no-shared.c b/gcc/testsuite/gcc.target/mips/abi-o32-long64-no-shared.c new file mode 100644 index 00000000000..6340b63252b --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o32-long64-no-shared.c @@ -0,0 +1,3 @@ +/* { dg-options "-mabi=32 -mlong64 -mabicalls -mno-shared -mno-plt -O2" } */ +/* { dg-error "is incompatible with" "" { target *-*-* } 0 } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o32-long64-pic.c b/gcc/testsuite/gcc.target/mips/abi-o32-long64-pic.c new file mode 100644 index 00000000000..1583034b2a3 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o32-long64-pic.c @@ -0,0 +1,3 @@ +/* { dg-options "-mabi=32 -mlong64 -fpic -O2" } */ +/* { dg-error "is incompatible with" "" { target *-*-* } 0 } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o32-long64.c b/gcc/testsuite/gcc.target/mips/abi-o32-long64.c new file mode 100644 index 00000000000..4a88739b695 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o32-long64.c @@ -0,0 +1,3 @@ +/* { dg-options "-mabi=32 -mlong64 addressing=absolute -O2" } */ +/* { dg-error "is incompatible with" "" { target *-*-* } 0 } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o64-long32-no-shared.c b/gcc/testsuite/gcc.target/mips/abi-o64-long32-no-shared.c new file mode 100644 index 00000000000..548ae0d4a13 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o64-long32-no-shared.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=o64 -mlong32 -mabicalls -mno-shared -mno-plt -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o64-long32-pic.c b/gcc/testsuite/gcc.target/mips/abi-o64-long32-pic.c new file mode 100644 index 00000000000..89d03ab6740 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o64-long32-pic.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=o64 -mlong32 -fpic -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o64-long32.c b/gcc/testsuite/gcc.target/mips/abi-o64-long32.c new file mode 100644 index 00000000000..db5893e4527 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o64-long32.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=o64 -mlong32 addressing=absolute -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o64-long64-no-shared.c b/gcc/testsuite/gcc.target/mips/abi-o64-long64-no-shared.c new file mode 100644 index 00000000000..df164b22f6c --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o64-long64-no-shared.c @@ -0,0 +1,3 @@ +/* { dg-options "-mabi=o64 -mlong64 -mabicalls -mno-shared -mno-plt -O2" } */ +/* { dg-error "is incompatible with" "" { target *-*-* } 0 } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o64-long64-pic.c b/gcc/testsuite/gcc.target/mips/abi-o64-long64-pic.c new file mode 100644 index 00000000000..df58d1f0285 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o64-long64-pic.c @@ -0,0 +1,3 @@ +/* { dg-options "-mabi=o64 -mlong64 -fpic -O2" } */ +/* { dg-error "is incompatible with" "" { target *-*-* } 0 } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/abi-o64-long64.c b/gcc/testsuite/gcc.target/mips/abi-o64-long64.c new file mode 100644 index 00000000000..8177f5ab17a --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/abi-o64-long64.c @@ -0,0 +1,2 @@ +/* { dg-options "-mabi=o64 -mlong64 addressing=absolute -O2" } */ +#include "abi-main.h" diff --git a/gcc/testsuite/gcc.target/mips/branch-10.c b/gcc/testsuite/gcc.target/mips/branch-10.c index 7fdebfcc3f6..8186030e6e1 100644 --- a/gcc/testsuite/gcc.target/mips/branch-10.c +++ b/gcc/testsuite/gcc.target/mips/branch-10.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=n32" } */ +/* { dg-options "-mshared -mabi=n32" } */ /* { dg-final { scan-assembler-not "(\\\$28|%gp_rel|%got)" } } */ /* { dg-final { scan-assembler-not "\tjr\t\\\$1\n" } } */ diff --git a/gcc/testsuite/gcc.target/mips/branch-11.c b/gcc/testsuite/gcc.target/mips/branch-11.c index 1c57f82f533..a314740655d 100644 --- a/gcc/testsuite/gcc.target/mips/branch-11.c +++ b/gcc/testsuite/gcc.target/mips/branch-11.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=n32" } */ +/* { dg-options "-mshared -mabi=n32" } */ /* { dg-final { scan-assembler "\tsd\t\\\$28," } } */ /* { dg-final { scan-assembler "\tld\t\\\$28," } } */ /* { dg-final { scan-assembler "\taddiu\t\\\$28,\\\$28,%lo\\(%neg\\(%gp_rel\\(foo\\)\\)\\)\n" } } */ diff --git a/gcc/testsuite/gcc.target/mips/branch-12.c b/gcc/testsuite/gcc.target/mips/branch-12.c index f1b6f1e8244..3e5b421cf87 100644 --- a/gcc/testsuite/gcc.target/mips/branch-12.c +++ b/gcc/testsuite/gcc.target/mips/branch-12.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=64" } */ +/* { dg-options "-mshared -mabi=64" } */ /* { dg-final { scan-assembler-not "(\\\$28|%gp_rel|%got)" } } */ /* { dg-final { scan-assembler-not "\tjr\t\\\$1\n" } } */ diff --git a/gcc/testsuite/gcc.target/mips/branch-13.c b/gcc/testsuite/gcc.target/mips/branch-13.c index cc0b607d728..9bd94146a6f 100644 --- a/gcc/testsuite/gcc.target/mips/branch-13.c +++ b/gcc/testsuite/gcc.target/mips/branch-13.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=64" } */ +/* { dg-options "-mshared -mabi=64" } */ /* { dg-final { scan-assembler "\tsd\t\\\$28," } } */ /* { dg-final { scan-assembler "\tld\t\\\$28," } } */ /* { dg-final { scan-assembler "\tdaddiu\t\\\$28,\\\$28,%lo\\(%neg\\(%gp_rel\\(foo\\)\\)\\)\n" } } */ diff --git a/gcc/testsuite/gcc.target/mips/branch-2.c b/gcc/testsuite/gcc.target/mips/branch-2.c index 845e7481729..f6642cb8743 100644 --- a/gcc/testsuite/gcc.target/mips/branch-2.c +++ b/gcc/testsuite/gcc.target/mips/branch-2.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=32" } */ +/* { dg-options "-mshared -mabi=32" } */ /* { dg-final { scan-assembler-not "(\\\$25|\\\$28|cpload)" } } */ /* { dg-final { scan-assembler-not "\tjr\t\\\$1\n" } } */ /* { dg-final { scan-assembler-not "cprestore" } } */ diff --git a/gcc/testsuite/gcc.target/mips/branch-3.c b/gcc/testsuite/gcc.target/mips/branch-3.c index 0a4ffbba604..198d6ec6484 100644 --- a/gcc/testsuite/gcc.target/mips/branch-3.c +++ b/gcc/testsuite/gcc.target/mips/branch-3.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=32" } */ +/* { dg-options "-mshared -mabi=32" } */ /* { dg-final { scan-assembler "\t\\.cpload\t\\\$25\n" } } */ /* { dg-final { scan-assembler "\tjr\t\\\$1\n" } } */ /* { dg-final { scan-assembler-not "cprestore" } } */ diff --git a/gcc/testsuite/gcc.target/mips/branch-4.c b/gcc/testsuite/gcc.target/mips/branch-4.c index 277bd0af76f..31e4909e58f 100644 --- a/gcc/testsuite/gcc.target/mips/branch-4.c +++ b/gcc/testsuite/gcc.target/mips/branch-4.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=n32" } */ +/* { dg-options "-mshared -mabi=n32" } */ /* { dg-final { scan-assembler-not "(\\\$25|\\\$28|%gp_rel|%got)" } } */ /* { dg-final { scan-assembler-not "\tjr\t\\\$1\n" } } */ diff --git a/gcc/testsuite/gcc.target/mips/branch-5.c b/gcc/testsuite/gcc.target/mips/branch-5.c index 3d151d824ef..1e9c120c834 100644 --- a/gcc/testsuite/gcc.target/mips/branch-5.c +++ b/gcc/testsuite/gcc.target/mips/branch-5.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=n32" } */ +/* { dg-options "-mshared -mabi=n32" } */ /* { dg-final { scan-assembler "\taddiu\t\\\$3,\\\$3,%lo\\(%neg\\(%gp_rel\\(foo\\)\\)\\)\n" } } */ /* { dg-final { scan-assembler "\tlw\t\\\$1,%got_page\\(\[^)\]*\\)\\(\\\$3\\)\\n" } } */ /* { dg-final { scan-assembler "\tjr\t\\\$1\n" } } */ diff --git a/gcc/testsuite/gcc.target/mips/branch-6.c b/gcc/testsuite/gcc.target/mips/branch-6.c index 9bf73f01c9b..77e0340eb2e 100644 --- a/gcc/testsuite/gcc.target/mips/branch-6.c +++ b/gcc/testsuite/gcc.target/mips/branch-6.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=64" } */ +/* { dg-options "-mshared -mabi=64" } */ /* { dg-final { scan-assembler-not "(\\\$25|\\\$28|%gp_rel|%got)" } } */ /* { dg-final { scan-assembler-not "\tjr\t\\\$1\n" } } */ diff --git a/gcc/testsuite/gcc.target/mips/branch-7.c b/gcc/testsuite/gcc.target/mips/branch-7.c index 053ec610c3d..8ad6808c8df 100644 --- a/gcc/testsuite/gcc.target/mips/branch-7.c +++ b/gcc/testsuite/gcc.target/mips/branch-7.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=64" } */ +/* { dg-options "-mshared -mabi=64" } */ /* { dg-final { scan-assembler "\tdaddiu\t\\\$3,\\\$3,%lo\\(%neg\\(%gp_rel\\(foo\\)\\)\\)\n" } } */ /* { dg-final { scan-assembler "\tld\t\\\$1,%got_page\\(\[^)\]*\\)\\(\\\$3\\)\\n" } } */ /* { dg-final { scan-assembler "\tjr\t\\\$1\n" } } */ diff --git a/gcc/testsuite/gcc.target/mips/branch-8.c b/gcc/testsuite/gcc.target/mips/branch-8.c index c2cbae36905..4595feafa61 100644 --- a/gcc/testsuite/gcc.target/mips/branch-8.c +++ b/gcc/testsuite/gcc.target/mips/branch-8.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=32" } */ +/* { dg-options "-mshared -mabi=32" } */ /* { dg-final { scan-assembler-not "(\\\$28|cpload|cprestore)" } } */ /* { dg-final { scan-assembler-not "\tjr\t\\\$1\n" } } */ diff --git a/gcc/testsuite/gcc.target/mips/branch-9.c b/gcc/testsuite/gcc.target/mips/branch-9.c index 2b83ea5b591..417507cc48e 100644 --- a/gcc/testsuite/gcc.target/mips/branch-9.c +++ b/gcc/testsuite/gcc.target/mips/branch-9.c @@ -1,4 +1,4 @@ -/* { dg-options "-mabicalls -mshared -mabi=32" } */ +/* { dg-options "-mshared -mabi=32" } */ /* { dg-final { scan-assembler "\t\\.cpload\t\\\$25\n" } } */ /* { dg-final { scan-assembler "\t\\.cprestore\t16\n" } } */ /* { dg-final { scan-assembler "\tlw\t\\\$1,16\\(\\\$fp\\)\n" } } */ diff --git a/gcc/testsuite/gcc.target/mips/lazy-binding-1.c b/gcc/testsuite/gcc.target/mips/lazy-binding-1.c index e85727c42d7..e281a270a6e 100644 --- a/gcc/testsuite/gcc.target/mips/lazy-binding-1.c +++ b/gcc/testsuite/gcc.target/mips/lazy-binding-1.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-mabicalls -mshared -mexplicit-relocs -O2 -fno-delayed-branch" } */ +/* { dg-options "-mshared -mexplicit-relocs -O2 -fno-delayed-branch" } */ void bar (void); diff --git a/gcc/testsuite/gcc.target/mips/mips.exp b/gcc/testsuite/gcc.target/mips/mips.exp index 0535c48f542..5889902456a 100644 --- a/gcc/testsuite/gcc.target/mips/mips.exp +++ b/gcc/testsuite/gcc.target/mips/mips.exp @@ -850,6 +850,7 @@ proc mips-dg-options { args } { mips_option_dependency options "-mrelax-pic-calls" "-mexplicit-relocs" mips_option_dependency options "-fpic" "-mshared" mips_option_dependency options "-mshared" "-mno-plt" + mips_option_dependency options "-mshared" "-mabicalls" mips_option_dependency options "-mno-plt" "addressing=unknown" mips_option_dependency options "-mabicalls" "-G0" mips_option_dependency options "-mno-gpopt" "-mexplicit-relocs" diff --git a/gcc/testsuite/gfortran.dg/class_45a.f03 b/gcc/testsuite/gfortran.dg/class_45a.f03 new file mode 100644 index 00000000000..af8932a6b18 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_45a.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 50227: [4.7 Regression] [OOP] ICE-on-valid with allocatable class variable +! +! Contributed by Andrew Benson <abenson@caltech.edu> + +module G_Nodes + private + + type, public :: t0 + end type + + type, public, extends(t0) :: t1 + end type + +contains + + function basicGet(self) + implicit none + class(t0), pointer :: basicGet + class(t0), intent(in) :: self + select type (self) + type is (t1) + basicGet => self + end select + end function basicGet + +end module G_Nodes diff --git a/gcc/testsuite/gfortran.dg/class_45b.f03 b/gcc/testsuite/gfortran.dg/class_45b.f03 new file mode 100644 index 00000000000..e37fa96d3c2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_45b.f03 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-additional-sources class_45a.f03 } +! +! PR 50227: [4.7 Regression] [OOP] ICE-on-valid with allocatable class variable +! +! Contributed by Andrew Benson <abenson@caltech.edu> + +program Test + use G_Nodes + class(t0), allocatable :: c + allocate(t1 :: c) +end program Test + +! { dg-final { cleanup-modules "G_Nodes" } } diff --git a/gcc/testsuite/gfortran.dg/vect/pr19049.f90 b/gcc/testsuite/gfortran.dg/vect/pr19049.f90 index 6c8030cce30..5552af6da84 100644 --- a/gcc/testsuite/gfortran.dg/vect/pr19049.f90 +++ b/gcc/testsuite/gfortran.dg/vect/pr19049.f90 @@ -19,6 +19,7 @@ subroutine s111 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc) end ! { dg-final { scan-tree-dump-times "vectorized 1 loops" 0 "vect" } } -! { dg-final { scan-tree-dump-times "complicated access pattern" 1 "vect" } } +! { dg-final { scan-tree-dump-times "complicated access pattern" 1 "vect" { xfail vect_multiple_sizes } } } +! { dg-final { scan-tree-dump-times "complicated access pattern" 2 "vect" { target vect_multiple_sizes } } } ! { dg-final { cleanup-tree-dump "vect" } } diff --git a/gcc/testsuite/gnat.dg/specs/debug1.ads b/gcc/testsuite/gnat.dg/specs/debug1.ads index 9389c26226b..ef7a86e3ddb 100644 --- a/gcc/testsuite/gnat.dg/specs/debug1.ads +++ b/gcc/testsuite/gnat.dg/specs/debug1.ads @@ -11,4 +11,4 @@ package Debug1 is end Debug1; --- { dg-final { scan-assembler-times "byte\t0x1\t# DW_AT_artificial" 4 } } +-- { dg-final { scan-assembler-times "# DW_AT_artificial" 4 } } diff --git a/gcc/testsuite/lib/target-supports.exp b/gcc/testsuite/lib/target-supports.exp index 54dc6b60bd5..5470dafafc2 100644 --- a/gcc/testsuite/lib/target-supports.exp +++ b/gcc/testsuite/lib/target-supports.exp @@ -3375,6 +3375,24 @@ foreach N {2 3 4 8} { }] } +# Return 1 if the target supports multiple vector sizes + +proc check_effective_target_vect_multiple_sizes { } { + global et_vect_multiple_sizes + + if [info exists et_vect_multiple_sizes_saved] { + verbose "check_effective_target_vect_multiple_sizes: using cached result" 2 + } else { + set et_vect_multiple_sizes_saved 0 + if { ([istarget arm*-*-*] && [check_effective_target_arm_neon]) } { + set et_vect_multiple_sizes_saved 1 + } + } + + verbose "check_effective_target_vect_multiple_sizes: returning $et_vect_multiple_sizes_saved" 2 + return $et_vect_multiple_sizes_saved +} + # Return 1 if the target supports section-anchors proc check_effective_target_section_anchors { } { @@ -3758,11 +3776,11 @@ proc add_options_for_bind_pic_locally { flags } { return $flags } -# Add to FLAGS the flags needed to enable 128-bit vectors. +# Add to FLAGS the flags needed to enable 64-bit vectors. -proc add_options_for_quad_vectors { flags } { +proc add_options_for_double_vectors { flags } { if [is-effective-target arm_neon_ok] { - return "$flags -mvectorize-with-neon-quad" + return "$flags -mvectorize-with-neon-double" } return $flags diff --git a/gcc/tree-cfg.c b/gcc/tree-cfg.c index 62e2da0c12f..20feff91f72 100644 --- a/gcc/tree-cfg.c +++ b/gcc/tree-cfg.c @@ -1566,9 +1566,11 @@ replace_uses_by (tree name, tree val) if (gimple_code (stmt) != GIMPLE_PHI) { + gimple_stmt_iterator gsi = gsi_for_stmt (stmt); size_t i; - fold_stmt_inplace (stmt); + fold_stmt (&gsi); + stmt = gsi_stmt (gsi); if (cfgcleanup_altered_bbs && !is_gimple_debug (stmt)) bitmap_set_bit (cfgcleanup_altered_bbs, gimple_bb (stmt)->index); diff --git a/gcc/tree-inline.c b/gcc/tree-inline.c index 741e8e4d005..3610289dc35 100644 --- a/gcc/tree-inline.c +++ b/gcc/tree-inline.c @@ -4840,6 +4840,8 @@ copy_arguments_for_versioning (tree orig_parm, copy_body_data * id, if (!args_to_skip || !bitmap_bit_p (args_to_skip, i)) { tree new_tree = remap_decl (arg, id); + if (TREE_CODE (new_tree) != PARM_DECL) + new_tree = id->copy_decl (arg, id); lang_hooks.dup_lang_specific_decl (new_tree); *parg = new_tree; parg = &DECL_CHAIN (new_tree); diff --git a/gcc/tree-pretty-print.c b/gcc/tree-pretty-print.c index 2c4b5bf7395..e30d60a365f 100644 --- a/gcc/tree-pretty-print.c +++ b/gcc/tree-pretty-print.c @@ -1002,7 +1002,11 @@ dump_generic_node (pretty_printer *buffer, tree node, int spc, int flags, pp_wide_integer (buffer, TREE_INT_CST_LOW (node)); pp_string (buffer, "B"); /* pseudo-unit */ } - else if (! host_integerp (node, 0)) + else if (host_integerp (node, 0)) + pp_wide_integer (buffer, TREE_INT_CST_LOW (node)); + else if (host_integerp (node, 1)) + pp_unsigned_wide_integer (buffer, TREE_INT_CST_LOW (node)); + else { tree val = node; unsigned HOST_WIDE_INT low = TREE_INT_CST_LOW (val); @@ -1021,8 +1025,6 @@ dump_generic_node (pretty_printer *buffer, tree node, int spc, int flags, (unsigned HOST_WIDE_INT) high, low); pp_string (buffer, pp_buffer (buffer)->digit_buffer); } - else - pp_wide_integer (buffer, TREE_INT_CST_LOW (node)); break; case REAL_CST: diff --git a/gcc/tree-sra.c b/gcc/tree-sra.c index 2d97845ffe6..203c4823db5 100644 --- a/gcc/tree-sra.c +++ b/gcc/tree-sra.c @@ -1825,7 +1825,6 @@ create_access_replacement (struct access *access, bool rename) tree repl; repl = create_tmp_var (access->type, "SR"); - get_var_ann (repl); add_referenced_var (repl); if (rename) mark_sym_for_renaming (repl); @@ -4106,7 +4105,6 @@ get_replaced_param_substitute (struct ipa_parm_adjustment *adj) DECL_NAME (repl) = get_identifier (pretty_name); obstack_free (&name_obstack, pretty_name); - get_var_ann (repl); add_referenced_var (repl); adj->new_ssa_base = repl; } diff --git a/gcc/tree-ssa-alias.c b/gcc/tree-ssa-alias.c index bac11810c6b..10c529b114f 100644 --- a/gcc/tree-ssa-alias.c +++ b/gcc/tree-ssa-alias.c @@ -1254,6 +1254,7 @@ ref_maybe_used_by_call_p_1 (gimple call, ao_ref *ref) case BUILT_IN_SINCOSF: case BUILT_IN_SINCOSL: case BUILT_IN_ASSUME_ALIGNED: + case BUILT_IN_VA_END: return false; /* __sync_* builtins and some OpenMP builtins act as threading barriers. */ @@ -1518,6 +1519,7 @@ call_may_clobber_ref_p_1 (gimple call, ao_ref *ref) the call has to serve as a barrier for moving loads and stores across it. */ case BUILT_IN_FREE: + case BUILT_IN_VA_END: { tree ptr = gimple_call_arg (call, 0); return ptr_deref_may_alias_ref_p_1 (ptr, ref); @@ -1763,10 +1765,23 @@ stmt_kills_ref_p_1 (gimple stmt, ao_ref *ref) / BITS_PER_UNIT))) return true; } + break; + } + + case BUILT_IN_VA_END: + { + tree ptr = gimple_call_arg (stmt, 0); + if (TREE_CODE (ptr) == ADDR_EXPR) + { + tree base = ao_ref_base (ref); + if (TREE_OPERAND (ptr, 0) == base) + return true; + } + break; } + default:; } - } return false; } diff --git a/gcc/tree-ssa-ccp.c b/gcc/tree-ssa-ccp.c index 007e17dd8b6..fc59d386cad 100644 --- a/gcc/tree-ssa-ccp.c +++ b/gcc/tree-ssa-ccp.c @@ -1702,9 +1702,11 @@ fold_builtin_alloca_for_var (gimple stmt) /* Detect constant argument. */ arg = get_constant_value (gimple_call_arg (stmt, 0)); - if (arg == NULL_TREE || TREE_CODE (arg) != INTEGER_CST + 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. */ @@ -1722,6 +1724,8 @@ fold_builtin_alloca_for_var (gimple stmt) elem_type = build_nonstandard_integer_type (BITS_PER_UNIT, 1); n_elem = size * 8 / BITS_PER_UNIT; align = MIN (size * 8, BIGGEST_ALIGNMENT); + if (align < BITS_PER_UNIT) + align = BITS_PER_UNIT; array_type = build_array_type_nelts (elem_type, n_elem); var = create_tmp_var (array_type, NULL); DECL_ALIGN (var) = align; @@ -1804,12 +1808,12 @@ ccp_fold_stmt (gimple_stmt_iterator *gsi) 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; + if (new_rhs) + { + bool res = update_call_from_tree (gsi, new_rhs); + gcc_assert (res); + return true; + } } /* Propagate into the call arguments. Compared to replace_uses_in diff --git a/gcc/tree-ssa-dce.c b/gcc/tree-ssa-dce.c index bf69bbf26b2..c9ad3117eb8 100644 --- a/gcc/tree-ssa-dce.c +++ b/gcc/tree-ssa-dce.c @@ -836,6 +836,7 @@ propagate_necessity (struct edge_list *el) || DECL_FUNCTION_CODE (callee) == BUILT_IN_MALLOC || DECL_FUNCTION_CODE (callee) == BUILT_IN_CALLOC || DECL_FUNCTION_CODE (callee) == BUILT_IN_FREE + || DECL_FUNCTION_CODE (callee) == BUILT_IN_VA_END || DECL_FUNCTION_CODE (callee) == BUILT_IN_ALLOCA || DECL_FUNCTION_CODE (callee) == BUILT_IN_STACK_SAVE || DECL_FUNCTION_CODE (callee) == BUILT_IN_STACK_RESTORE diff --git a/gcc/tree-ssa-phiopt.c b/gcc/tree-ssa-phiopt.c index 30eea319edc..42753447575 100644 --- a/gcc/tree-ssa-phiopt.c +++ b/gcc/tree-ssa-phiopt.c @@ -1269,10 +1269,7 @@ cond_store_replacement (basic_block middle_bb, basic_block join_bb, /* 2) Create a temporary where we can store the old content of the memory touched by the store, if we need to. */ if (!condstoretemp || TREE_TYPE (lhs) != TREE_TYPE (condstoretemp)) - { - condstoretemp = create_tmp_reg (TREE_TYPE (lhs), "cstore"); - get_var_ann (condstoretemp); - } + condstoretemp = create_tmp_reg (TREE_TYPE (lhs), "cstore"); add_referenced_var (condstoretemp); /* 3) Insert a load from the memory of the store to the temporary @@ -1355,10 +1352,7 @@ cond_if_else_store_replacement_1 (basic_block then_bb, basic_block else_bb, /* 2) Create a temporary where we can store the old content of the memory touched by the store, if we need to. */ if (!condstoretemp || TREE_TYPE (lhs) != TREE_TYPE (condstoretemp)) - { - condstoretemp = create_tmp_reg (TREE_TYPE (lhs), "cstore"); - get_var_ann (condstoretemp); - } + condstoretemp = create_tmp_reg (TREE_TYPE (lhs), "cstore"); add_referenced_var (condstoretemp); /* 3) Create a PHI node at the join block, with one argument diff --git a/gcc/tree-ssa-pre.c b/gcc/tree-ssa-pre.c index d784bac6818..f69aec0dd4d 100644 --- a/gcc/tree-ssa-pre.c +++ b/gcc/tree-ssa-pre.c @@ -1399,7 +1399,7 @@ get_representative_for (const pre_expr e) if (!pretemp || exprtype != TREE_TYPE (pretemp)) { pretemp = create_tmp_reg (exprtype, "pretmp"); - get_var_ann (pretemp); + add_referenced_var (pretemp); } name = make_ssa_name (pretemp, gimple_build_nop ()); @@ -1443,20 +1443,18 @@ phi_translate_1 (pre_expr expr, bitmap_set_t set1, bitmap_set_t set2, unsigned int i; bool changed = false; vn_nary_op_t nary = PRE_EXPR_NARY (expr); - struct vn_nary_op_s newnary; - /* The NARY structure is only guaranteed to have been - allocated to the nary->length operands. */ - memcpy (&newnary, nary, (sizeof (struct vn_nary_op_s) - - sizeof (tree) * (4 - nary->length))); + vn_nary_op_t newnary = XALLOCAVAR (struct vn_nary_op_s, + sizeof_vn_nary_op (nary->length)); + memcpy (newnary, nary, sizeof_vn_nary_op (nary->length)); - for (i = 0; i < newnary.length; i++) + for (i = 0; i < newnary->length; i++) { - if (TREE_CODE (newnary.op[i]) != SSA_NAME) + if (TREE_CODE (newnary->op[i]) != SSA_NAME) continue; else { pre_expr leader, result; - unsigned int op_val_id = VN_INFO (newnary.op[i])->value_id; + unsigned int op_val_id = VN_INFO (newnary->op[i])->value_id; leader = find_leader_in_sets (op_val_id, set1, set2); result = phi_translate (leader, set1, set2, pred, phiblock); if (result && result != leader) @@ -1464,12 +1462,12 @@ phi_translate_1 (pre_expr expr, bitmap_set_t set1, bitmap_set_t set2, tree name = get_representative_for (result); if (!name) return NULL; - newnary.op[i] = name; + newnary->op[i] = name; } else if (!result) return NULL; - changed |= newnary.op[i] != nary->op[i]; + changed |= newnary->op[i] != nary->op[i]; } } if (changed) @@ -1477,13 +1475,10 @@ phi_translate_1 (pre_expr expr, bitmap_set_t set1, bitmap_set_t set2, pre_expr constant; unsigned int new_val_id; - tree result = vn_nary_op_lookup_pieces (newnary.length, - newnary.opcode, - newnary.type, - newnary.op[0], - newnary.op[1], - newnary.op[2], - newnary.op[3], + tree result = vn_nary_op_lookup_pieces (newnary->length, + newnary->opcode, + newnary->type, + &newnary->op[0], &nary); if (result && is_gimple_min_invariant (result)) return get_or_alloc_expr_for_constant (result); @@ -1507,13 +1502,10 @@ phi_translate_1 (pre_expr expr, bitmap_set_t set1, bitmap_set_t set2, VEC_safe_grow_cleared (bitmap_set_t, heap, value_expressions, get_max_value_id() + 1); - nary = vn_nary_op_insert_pieces (newnary.length, - newnary.opcode, - newnary.type, - newnary.op[0], - newnary.op[1], - newnary.op[2], - newnary.op[3], + nary = vn_nary_op_insert_pieces (newnary->length, + newnary->opcode, + newnary->type, + &newnary->op[0], result, new_val_id); PRE_EXPR_NARY (expr) = nary; constant = fully_constant_expression (expr); @@ -1708,9 +1700,7 @@ phi_translate_1 (pre_expr expr, bitmap_set_t set1, bitmap_set_t set2, nresult = vn_nary_op_lookup_pieces (1, TREE_CODE (result), TREE_TYPE (result), - TREE_OPERAND (result, 0), - NULL_TREE, NULL_TREE, - NULL_TREE, + &TREE_OPERAND (result, 0), &nary); if (nresult && is_gimple_min_invariant (nresult)) return get_or_alloc_expr_for_constant (nresult); @@ -1734,9 +1724,8 @@ phi_translate_1 (pre_expr expr, bitmap_set_t set1, bitmap_set_t set2, get_max_value_id() + 1); nary = vn_nary_op_insert_pieces (1, TREE_CODE (result), TREE_TYPE (result), - TREE_OPERAND (result, 0), - NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, + &TREE_OPERAND (result, 0), + NULL_TREE, new_val_id); PRE_EXPR_NARY (expr) = nary; constant = fully_constant_expression (expr); @@ -3087,50 +3076,49 @@ create_expression_by_pieces (basic_block block, pre_expr expr, case NARY: { vn_nary_op_t nary = PRE_EXPR_NARY (expr); - switch (nary->length) + tree genop[4]; + unsigned i; + for (i = 0; i < nary->length; ++i) { - case 2: - { - pre_expr op1 = get_or_alloc_expr_for (nary->op[0]); - pre_expr op2 = get_or_alloc_expr_for (nary->op[1]); - tree genop1 = find_or_generate_expression (block, op1, - stmts, domstmt); - tree genop2 = find_or_generate_expression (block, op2, - stmts, domstmt); - if (!genop1 || !genop2) - return NULL_TREE; - /* Ensure op2 is a ptrofftype for POINTER_PLUS_EXPR. It - may be a constant with the wrong type. */ - if (nary->opcode == POINTER_PLUS_EXPR) - { - genop1 = fold_convert (nary->type, genop1); - genop2 = convert_to_ptrofftype (genop2); - } - else - { - genop1 = fold_convert (TREE_TYPE (nary->op[0]), genop1); - genop2 = fold_convert (TREE_TYPE (nary->op[1]), genop2); - } - - folded = fold_build2 (nary->opcode, nary->type, - genop1, genop2); - } - break; - case 1: - { - pre_expr op1 = get_or_alloc_expr_for (nary->op[0]); - tree genop1 = find_or_generate_expression (block, op1, - stmts, domstmt); - if (!genop1) - return NULL_TREE; - genop1 = fold_convert (TREE_TYPE (nary->op[0]), genop1); - - folded = fold_build1 (nary->opcode, nary->type, - genop1); - } - break; - default: - return NULL_TREE; + pre_expr op = get_or_alloc_expr_for (nary->op[i]); + genop[i] = find_or_generate_expression (block, op, + stmts, domstmt); + if (!genop[i]) + return NULL_TREE; + /* Ensure genop[1] is a ptrofftype for POINTER_PLUS_EXPR. It + may be a constant with the wrong type. */ + if (i == 1 + && nary->opcode == POINTER_PLUS_EXPR) + genop[i] = convert_to_ptrofftype (genop[i]); + else + genop[i] = fold_convert (TREE_TYPE (nary->op[i]), genop[i]); + } + if (nary->opcode == CONSTRUCTOR) + { + VEC(constructor_elt,gc) *elts = NULL; + for (i = 0; i < nary->length; ++i) + CONSTRUCTOR_APPEND_ELT (elts, NULL_TREE, genop[i]); + folded = build_constructor (nary->type, elts); + } + else + { + switch (nary->length) + { + case 1: + folded = fold_build1 (nary->opcode, nary->type, + genop[0]); + break; + case 2: + folded = fold_build2 (nary->opcode, nary->type, + genop[0], genop[1]); + break; + case 3: + folded = fold_build3 (nary->opcode, nary->type, + genop[0], genop[1], genop[3]); + break; + default: + gcc_unreachable (); + } } } break; @@ -3178,10 +3166,7 @@ create_expression_by_pieces (basic_block block, pre_expr expr, /* Build and insert the assignment of the end result to the temporary that we will return. */ if (!pretemp || exprtype != TREE_TYPE (pretemp)) - { - pretemp = create_tmp_reg (exprtype, "pretmp"); - get_var_ann (pretemp); - } + pretemp = create_tmp_reg (exprtype, "pretmp"); temp = pretemp; add_referenced_var (temp); @@ -3441,10 +3426,7 @@ insert_into_preds_of_block (basic_block block, unsigned int exprnum, /* Now build a phi for the new variable. */ if (!prephitemp || TREE_TYPE (prephitemp) != type) - { - prephitemp = create_tmp_var (type, "prephitmp"); - get_var_ann (prephitemp); - } + prephitemp = create_tmp_var (type, "prephitmp"); temp = prephitemp; add_referenced_var (temp); @@ -4059,9 +4041,8 @@ compute_avail (void) vn_nary_op_lookup_pieces (gimple_num_ops (stmt) - 1, gimple_assign_rhs_code (stmt), gimple_expr_type (stmt), - gimple_assign_rhs1 (stmt), - gimple_assign_rhs2 (stmt), - NULL_TREE, NULL_TREE, &nary); + gimple_assign_rhs1_ptr (stmt), + &nary); if (!nary) continue; diff --git a/gcc/tree-ssa-reassoc.c b/gcc/tree-ssa-reassoc.c index 51f7ef88798..03e06724266 100644 --- a/gcc/tree-ssa-reassoc.c +++ b/gcc/tree-ssa-reassoc.c @@ -40,6 +40,8 @@ along with GCC; see the file COPYING3. If not see #include "pointer-set.h" #include "cfgloop.h" #include "flags.h" +#include "target.h" +#include "params.h" /* This is a simple global reassociation pass. It is, in part, based on the LLVM pass of the same name (They do some things more/less @@ -1617,6 +1619,62 @@ remove_visited_stmt_chain (tree var) } } +/* This function checks three consequtive operands in + passed operands vector OPS starting from OPINDEX and + swaps two operands if it is profitable for binary operation + consuming OPINDEX + 1 abnd OPINDEX + 2 operands. + + We pair ops with the same rank if possible. + + The alternative we try is to see if STMT is a destructive + update style statement, which is like: + b = phi (a, ...) + a = c + b; + In that case, we want to use the destructive update form to + expose the possible vectorizer sum reduction opportunity. + In that case, the third operand will be the phi node. This + check is not performed if STMT is null. + + We could, of course, try to be better as noted above, and do a + lot of work to try to find these opportunities in >3 operand + cases, but it is unlikely to be worth it. */ + +static void +swap_ops_for_binary_stmt (VEC(operand_entry_t, heap) * ops, + unsigned int opindex, gimple stmt) +{ + operand_entry_t oe1, oe2, oe3; + + oe1 = VEC_index (operand_entry_t, ops, opindex); + oe2 = VEC_index (operand_entry_t, ops, opindex + 1); + oe3 = VEC_index (operand_entry_t, ops, opindex + 2); + + if ((oe1->rank == oe2->rank + && oe2->rank != oe3->rank) + || (stmt && is_phi_for_stmt (stmt, oe3->op) + && !is_phi_for_stmt (stmt, oe1->op) + && !is_phi_for_stmt (stmt, oe2->op))) + { + struct operand_entry temp = *oe3; + oe3->op = oe1->op; + oe3->rank = oe1->rank; + oe1->op = temp.op; + oe1->rank= temp.rank; + } + else if ((oe1->rank == oe3->rank + && oe2->rank != oe3->rank) + || (stmt && is_phi_for_stmt (stmt, oe2->op) + && !is_phi_for_stmt (stmt, oe1->op) + && !is_phi_for_stmt (stmt, oe3->op))) + { + struct operand_entry temp = *oe2; + oe2->op = oe1->op; + oe2->rank = oe1->rank; + oe1->op = temp.op; + oe1->rank= temp.rank; + } +} + /* Recursively rewrite our linearized statements so that the operators match those in OPS[OPINDEX], putting the computation in rank order. */ @@ -1629,53 +1687,10 @@ rewrite_expr_tree (gimple stmt, unsigned int opindex, tree rhs2 = gimple_assign_rhs2 (stmt); operand_entry_t oe; - /* If we have three operands left, then we want to make sure the one - that gets the double binary op are the ones with the same rank. - - The alternative we try is to see if this is a destructive - update style statement, which is like: - b = phi (a, ...) - a = c + b; - In that case, we want to use the destructive update form to - expose the possible vectorizer sum reduction opportunity. - In that case, the third operand will be the phi node. - - We could, of course, try to be better as noted above, and do a - lot of work to try to find these opportunities in >3 operand - cases, but it is unlikely to be worth it. */ + /* If we have three operands left, then we want to make sure the ones + that get the double binary op are chosen wisely. */ if (opindex + 3 == VEC_length (operand_entry_t, ops)) - { - operand_entry_t oe1, oe2, oe3; - - oe1 = VEC_index (operand_entry_t, ops, opindex); - oe2 = VEC_index (operand_entry_t, ops, opindex + 1); - oe3 = VEC_index (operand_entry_t, ops, opindex + 2); - - if ((oe1->rank == oe2->rank - && oe2->rank != oe3->rank) - || (is_phi_for_stmt (stmt, oe3->op) - && !is_phi_for_stmt (stmt, oe1->op) - && !is_phi_for_stmt (stmt, oe2->op))) - { - struct operand_entry temp = *oe3; - oe3->op = oe1->op; - oe3->rank = oe1->rank; - oe1->op = temp.op; - oe1->rank= temp.rank; - } - else if ((oe1->rank == oe3->rank - && oe2->rank != oe3->rank) - || (is_phi_for_stmt (stmt, oe2->op) - && !is_phi_for_stmt (stmt, oe1->op) - && !is_phi_for_stmt (stmt, oe3->op))) - { - struct operand_entry temp = *oe2; - oe2->op = oe1->op; - oe2->rank = oe1->rank; - oe1->op = temp.op; - oe1->rank= temp.rank; - } - } + swap_ops_for_binary_stmt (ops, opindex, stmt); /* The final recursion case for this function is that you have exactly two operations left. @@ -1760,6 +1775,178 @@ rewrite_expr_tree (gimple stmt, unsigned int opindex, rewrite_expr_tree (SSA_NAME_DEF_STMT (rhs1), opindex + 1, ops, moved); } +/* Find out how many cycles we need to compute statements chain. + OPS_NUM holds number os statements in a chain. CPU_WIDTH is a + maximum number of independent statements we may execute per cycle. */ + +static int +get_required_cycles (int ops_num, int cpu_width) +{ + int res; + int elog; + unsigned int rest; + + /* While we have more than 2 * cpu_width operands + we may reduce number of operands by cpu_width + per cycle. */ + res = ops_num / (2 * cpu_width); + + /* Remained operands count may be reduced twice per cycle + until we have only one operand. */ + rest = (unsigned)(ops_num - res * cpu_width); + elog = exact_log2 (rest); + if (elog >= 0) + res += elog; + else + res += floor_log2 (rest) + 1; + + return res; +} + +/* Returns an optimal number of registers to use for computation of + given statements. */ + +static int +get_reassociation_width (int ops_num, enum tree_code opc, + enum machine_mode mode) +{ + int param_width = PARAM_VALUE (PARAM_TREE_REASSOC_WIDTH); + int width; + int width_min; + int cycles_best; + + if (param_width > 0) + width = param_width; + else + width = targetm.sched.reassociation_width (opc, mode); + + if (width == 1) + return width; + + /* Get the minimal time required for sequence computation. */ + cycles_best = get_required_cycles (ops_num, width); + + /* Check if we may use less width and still compute sequence for + the same time. It will allow us to reduce registers usage. + get_required_cycles is monotonically increasing with lower width + so we can perform a binary search for the minimal width that still + results in the optimal cycle count. */ + width_min = 1; + while (width > width_min) + { + int width_mid = (width + width_min) / 2; + + if (get_required_cycles (ops_num, width_mid) == cycles_best) + width = width_mid; + else if (width_min < width_mid) + width_min = width_mid; + else + break; + } + + return width; +} + +/* Recursively rewrite our linearized statements so that the operators + match those in OPS[OPINDEX], putting the computation in rank + order and trying to allow operations to be executed in + parallel. */ + +static void +rewrite_expr_tree_parallel (gimple stmt, int width, + VEC(operand_entry_t, heap) * ops) +{ + enum tree_code opcode = gimple_assign_rhs_code (stmt); + int op_num = VEC_length (operand_entry_t, ops); + int stmt_num = op_num - 1; + gimple *stmts = XALLOCAVEC (gimple, stmt_num); + int op_index = op_num - 1; + int stmt_index = 0; + int ready_stmts_end = 0; + int i = 0; + tree last_rhs1 = gimple_assign_rhs1 (stmt); + tree lhs_var; + + /* We start expression rewriting from the top statements. + So, in this loop we create a full list of statements + we will work with. */ + stmts[stmt_num - 1] = stmt; + for (i = stmt_num - 2; i >= 0; i--) + stmts[i] = SSA_NAME_DEF_STMT (gimple_assign_rhs1 (stmts[i+1])); + + lhs_var = create_tmp_reg (TREE_TYPE (last_rhs1), NULL); + add_referenced_var (lhs_var); + + for (i = 0; i < stmt_num; i++) + { + tree op1, op2; + + /* Determine whether we should use results of + already handled statements or not. */ + if (ready_stmts_end == 0 + && (i - stmt_index >= width || op_index < 1)) + ready_stmts_end = i; + + /* Now we choose operands for the next statement. Non zero + value in ready_stmts_end means here that we should use + the result of already generated statements as new operand. */ + if (ready_stmts_end > 0) + { + op1 = gimple_assign_lhs (stmts[stmt_index++]); + if (ready_stmts_end > stmt_index) + op2 = gimple_assign_lhs (stmts[stmt_index++]); + else if (op_index >= 0) + op2 = VEC_index (operand_entry_t, ops, op_index--)->op; + else + { + gcc_assert (stmt_index < i); + op2 = gimple_assign_lhs (stmts[stmt_index++]); + } + + if (stmt_index >= ready_stmts_end) + ready_stmts_end = 0; + } + else + { + if (op_index > 1) + swap_ops_for_binary_stmt (ops, op_index - 2, NULL); + op2 = VEC_index (operand_entry_t, ops, op_index--)->op; + op1 = VEC_index (operand_entry_t, ops, op_index--)->op; + } + + /* If we emit the last statement then we should put + operands into the last statement. It will also + break the loop. */ + if (op_index < 0 && stmt_index == i) + i = stmt_num - 1; + + if (dump_file && (dump_flags & TDF_DETAILS)) + { + fprintf (dump_file, "Transforming "); + print_gimple_stmt (dump_file, stmts[i], 0, 0); + } + + /* We keep original statement only for the last one. All + others are recreated. */ + if (i == stmt_num - 1) + { + gimple_assign_set_rhs1 (stmts[i], op1); + gimple_assign_set_rhs2 (stmts[i], op2); + update_stmt (stmts[i]); + } + else + stmts[i] = build_and_add_sum (lhs_var, op1, op2, opcode); + + if (dump_file && (dump_flags & TDF_DETAILS)) + { + fprintf (dump_file, " into "); + print_gimple_stmt (dump_file, stmts[i], 0, 0); + } + } + + remove_visited_stmt_chain (last_rhs1); +} + /* Transform STMT, which is really (A +B) + (C + D) into the left linear form, ((A+B)+C)+D. Recurse on D if necessary. */ @@ -2282,7 +2469,21 @@ reassociate_bb (basic_block bb) } } else - rewrite_expr_tree (stmt, 0, ops, false); + { + enum machine_mode mode = TYPE_MODE (TREE_TYPE (lhs)); + int ops_num = VEC_length (operand_entry_t, ops); + int width = get_reassociation_width (ops_num, rhs_code, mode); + + if (dump_file && (dump_flags & TDF_DETAILS)) + fprintf (dump_file, + "Width = %d was chosen for reassociation\n", width); + + if (width > 1 + && VEC_length (operand_entry_t, ops) > 3) + rewrite_expr_tree_parallel (stmt, width, ops); + else + rewrite_expr_tree (stmt, 0, ops, false); + } VEC_free (operand_entry_t, heap, ops); } diff --git a/gcc/tree-ssa-sccvn.c b/gcc/tree-ssa-sccvn.c index 4ccc0a29fd5..811cb65b424 100644 --- a/gcc/tree-ssa-sccvn.c +++ b/gcc/tree-ssa-sccvn.c @@ -217,6 +217,7 @@ vn_get_expr_for (tree name) vn_ssa_aux_t vn = VN_INFO (name); gimple def_stmt; tree expr = NULL_TREE; + enum tree_code code; if (vn->valnum == VN_TOP) return name; @@ -241,37 +242,34 @@ vn_get_expr_for (tree name) /* Otherwise use the defining statement to build the expression. */ def_stmt = SSA_NAME_DEF_STMT (vn->valnum); - /* If the value number is a default-definition or a PHI result - use it directly. */ - if (gimple_nop_p (def_stmt) - || gimple_code (def_stmt) == GIMPLE_PHI) - return vn->valnum; - + /* If the value number is not an assignment use it directly. */ if (!is_gimple_assign (def_stmt)) return vn->valnum; /* FIXME tuples. This is incomplete and likely will miss some simplifications. */ - switch (TREE_CODE_CLASS (gimple_assign_rhs_code (def_stmt))) + code = gimple_assign_rhs_code (def_stmt); + switch (TREE_CODE_CLASS (code)) { case tcc_reference: - if ((gimple_assign_rhs_code (def_stmt) == VIEW_CONVERT_EXPR - || gimple_assign_rhs_code (def_stmt) == REALPART_EXPR - || gimple_assign_rhs_code (def_stmt) == IMAGPART_EXPR) - && TREE_CODE (gimple_assign_rhs1 (def_stmt)) == SSA_NAME) - expr = fold_build1 (gimple_assign_rhs_code (def_stmt), + if ((code == REALPART_EXPR + || code == IMAGPART_EXPR + || code == VIEW_CONVERT_EXPR) + && TREE_CODE (TREE_OPERAND (gimple_assign_rhs1 (def_stmt), + 0)) == SSA_NAME) + expr = fold_build1 (code, gimple_expr_type (def_stmt), TREE_OPERAND (gimple_assign_rhs1 (def_stmt), 0)); break; case tcc_unary: - expr = fold_build1 (gimple_assign_rhs_code (def_stmt), + expr = fold_build1 (code, gimple_expr_type (def_stmt), gimple_assign_rhs1 (def_stmt)); break; case tcc_binary: - expr = fold_build2 (gimple_assign_rhs_code (def_stmt), + expr = fold_build2 (code, gimple_expr_type (def_stmt), gimple_assign_rhs1 (def_stmt), gimple_assign_rhs2 (def_stmt)); @@ -1923,6 +1921,9 @@ vn_nary_op_eq (const void *p1, const void *p2) if (vno1->hashcode != vno2->hashcode) return false; + if (vno1->length != vno2->length) + return false; + if (vno1->opcode != vno2->opcode || !types_compatible_p (vno1->type, vno2->type)) return false; @@ -1938,22 +1939,12 @@ vn_nary_op_eq (const void *p1, const void *p2) static void init_vn_nary_op_from_pieces (vn_nary_op_t vno, unsigned int length, - enum tree_code code, tree type, tree op0, - tree op1, tree op2, tree op3) + enum tree_code code, tree type, tree *ops) { vno->opcode = code; vno->length = length; vno->type = type; - switch (length) - { - /* The fallthrus here are deliberate. */ - case 4: vno->op[3] = op3; - case 3: vno->op[2] = op2; - case 2: vno->op[1] = op1; - case 1: vno->op[0] = op0; - default: - break; - } + memcpy (&vno->op[0], ops, sizeof (tree) * length); } /* Initialize VNO from OP. */ @@ -1970,6 +1961,26 @@ init_vn_nary_op_from_op (vn_nary_op_t vno, tree op) vno->op[i] = TREE_OPERAND (op, i); } +/* Return the number of operands for a vn_nary ops structure from STMT. */ + +static unsigned int +vn_nary_length_from_stmt (gimple stmt) +{ + switch (gimple_assign_rhs_code (stmt)) + { + case REALPART_EXPR: + case IMAGPART_EXPR: + case VIEW_CONVERT_EXPR: + return 1; + + case CONSTRUCTOR: + return CONSTRUCTOR_NELTS (gimple_assign_rhs1 (stmt)); + + default: + return gimple_num_ops (stmt) - 1; + } +} + /* Initialize VNO from STMT. */ static void @@ -1978,14 +1989,27 @@ init_vn_nary_op_from_stmt (vn_nary_op_t vno, gimple stmt) unsigned i; vno->opcode = gimple_assign_rhs_code (stmt); - vno->length = gimple_num_ops (stmt) - 1; vno->type = gimple_expr_type (stmt); - for (i = 0; i < vno->length; ++i) - vno->op[i] = gimple_op (stmt, i + 1); - if (vno->opcode == REALPART_EXPR - || vno->opcode == IMAGPART_EXPR - || vno->opcode == VIEW_CONVERT_EXPR) - vno->op[0] = TREE_OPERAND (vno->op[0], 0); + switch (vno->opcode) + { + case REALPART_EXPR: + case IMAGPART_EXPR: + case VIEW_CONVERT_EXPR: + vno->length = 1; + vno->op[0] = TREE_OPERAND (gimple_assign_rhs1 (stmt), 0); + break; + + case CONSTRUCTOR: + vno->length = CONSTRUCTOR_NELTS (gimple_assign_rhs1 (stmt)); + for (i = 0; i < vno->length; ++i) + vno->op[i] = CONSTRUCTOR_ELT (gimple_assign_rhs1 (stmt), i)->value; + break; + + default: + vno->length = gimple_num_ops (stmt) - 1; + for (i = 0; i < vno->length; ++i) + vno->op[i] = gimple_op (stmt, i + 1); + } } /* Compute the hashcode for VNO and look for it in the hash table; @@ -2023,12 +2047,12 @@ vn_nary_op_lookup_1 (vn_nary_op_t vno, vn_nary_op_t *vnresult) tree vn_nary_op_lookup_pieces (unsigned int length, enum tree_code code, - tree type, tree op0, tree op1, tree op2, - tree op3, vn_nary_op_t *vnresult) + tree type, tree *ops, vn_nary_op_t *vnresult) { - struct vn_nary_op_s vno1; - init_vn_nary_op_from_pieces (&vno1, length, code, type, op0, op1, op2, op3); - return vn_nary_op_lookup_1 (&vno1, vnresult); + vn_nary_op_t vno1 = XALLOCAVAR (struct vn_nary_op_s, + sizeof_vn_nary_op (length)); + init_vn_nary_op_from_pieces (vno1, length, code, type, ops); + return vn_nary_op_lookup_1 (vno1, vnresult); } /* Lookup OP in the current hash table, and return the resulting value @@ -2040,9 +2064,11 @@ vn_nary_op_lookup_pieces (unsigned int length, enum tree_code code, tree vn_nary_op_lookup (tree op, vn_nary_op_t *vnresult) { - struct vn_nary_op_s vno1; - init_vn_nary_op_from_op (&vno1, op); - return vn_nary_op_lookup_1 (&vno1, vnresult); + vn_nary_op_t vno1 + = XALLOCAVAR (struct vn_nary_op_s, + sizeof_vn_nary_op (TREE_CODE_LENGTH (TREE_CODE (op)))); + init_vn_nary_op_from_op (vno1, op); + return vn_nary_op_lookup_1 (vno1, vnresult); } /* Lookup the rhs of STMT in the current hash table, and return the resulting @@ -2053,17 +2079,11 @@ vn_nary_op_lookup (tree op, vn_nary_op_t *vnresult) tree vn_nary_op_lookup_stmt (gimple stmt, vn_nary_op_t *vnresult) { - struct vn_nary_op_s vno1; - init_vn_nary_op_from_stmt (&vno1, stmt); - return vn_nary_op_lookup_1 (&vno1, vnresult); -} - -/* Return the size of a vn_nary_op_t with LENGTH operands. */ - -static size_t -sizeof_vn_nary_op (unsigned int length) -{ - return sizeof (struct vn_nary_op_s) - sizeof (tree) * (4 - length); + vn_nary_op_t vno1 + = XALLOCAVAR (struct vn_nary_op_s, + sizeof_vn_nary_op (vn_nary_length_from_stmt (stmt))); + init_vn_nary_op_from_stmt (vno1, stmt); + return vn_nary_op_lookup_1 (vno1, vnresult); } /* Allocate a vn_nary_op_t with LENGTH operands on STACK. */ @@ -2114,15 +2134,11 @@ vn_nary_op_insert_into (vn_nary_op_t vno, htab_t table, bool compute_hash) vn_nary_op_t vn_nary_op_insert_pieces (unsigned int length, enum tree_code code, - tree type, tree op0, - tree op1, tree op2, tree op3, - tree result, - unsigned int value_id) + tree type, tree *ops, + tree result, unsigned int value_id) { - vn_nary_op_t vno1; - - vno1 = alloc_vn_nary_op (length, result, value_id); - init_vn_nary_op_from_pieces (vno1, length, code, type, op0, op1, op2, op3); + vn_nary_op_t vno1 = alloc_vn_nary_op (length, result, value_id); + init_vn_nary_op_from_pieces (vno1, length, code, type, ops); return vn_nary_op_insert_into (vno1, current_info->nary, true); } @@ -2147,10 +2163,9 @@ vn_nary_op_insert (tree op, tree result) vn_nary_op_t vn_nary_op_insert_stmt (gimple stmt, tree result) { - unsigned length = gimple_num_ops (stmt) - 1; - vn_nary_op_t vno1; - - vno1 = alloc_vn_nary_op (length, result, VN_INFO (result)->value_id); + vn_nary_op_t vno1 + = alloc_vn_nary_op (vn_nary_length_from_stmt (stmt), + result, VN_INFO (result)->value_id); init_vn_nary_op_from_stmt (vno1, stmt); return vn_nary_op_insert_into (vno1, current_info->nary, true); } @@ -2805,6 +2820,19 @@ stmt_has_constants (gimple stmt) return false; } +/* Valueize NAME if it is an SSA name, otherwise just return it. */ + +static inline tree +vn_valueize (tree name) +{ + if (TREE_CODE (name) == SSA_NAME) + { + tree tem = SSA_VAL (name); + return tem == VN_TOP ? name : tem; + } + return name; +} + /* Replace SSA_NAMES in expr with their value numbers, and return the result. This is performed in place. */ @@ -2814,21 +2842,13 @@ valueize_expr (tree expr) { switch (TREE_CODE_CLASS (TREE_CODE (expr))) { - case tcc_unary: - if (TREE_CODE (TREE_OPERAND (expr, 0)) == SSA_NAME - && SSA_VAL (TREE_OPERAND (expr, 0)) != VN_TOP) - TREE_OPERAND (expr, 0) = SSA_VAL (TREE_OPERAND (expr, 0)); - break; case tcc_binary: - if (TREE_CODE (TREE_OPERAND (expr, 0)) == SSA_NAME - && SSA_VAL (TREE_OPERAND (expr, 0)) != VN_TOP) - TREE_OPERAND (expr, 0) = SSA_VAL (TREE_OPERAND (expr, 0)); - if (TREE_CODE (TREE_OPERAND (expr, 1)) == SSA_NAME - && SSA_VAL (TREE_OPERAND (expr, 1)) != VN_TOP) - TREE_OPERAND (expr, 1) = SSA_VAL (TREE_OPERAND (expr, 1)); - break; - default: + TREE_OPERAND (expr, 1) = vn_valueize (TREE_OPERAND (expr, 1)); + /* Fallthru. */ + case tcc_unary: + TREE_OPERAND (expr, 0) = vn_valueize (TREE_OPERAND (expr, 0)); break; + default:; } return expr; } @@ -2842,6 +2862,7 @@ simplify_binary_expression (gimple stmt) tree result = NULL_TREE; tree op0 = gimple_assign_rhs1 (stmt); tree op1 = gimple_assign_rhs2 (stmt); + enum tree_code code = gimple_assign_rhs_code (stmt); /* This will not catch every single case we could combine, but will catch those with constants. The goal here is to simultaneously @@ -2850,23 +2871,25 @@ simplify_binary_expression (gimple stmt) if (TREE_CODE (op0) == SSA_NAME) { if (VN_INFO (op0)->has_constants - || TREE_CODE_CLASS (gimple_assign_rhs_code (stmt)) == tcc_comparison) + || TREE_CODE_CLASS (code) == tcc_comparison + || code == COMPLEX_EXPR) op0 = valueize_expr (vn_get_expr_for (op0)); - else if (SSA_VAL (op0) != VN_TOP && SSA_VAL (op0) != op0) - op0 = SSA_VAL (op0); + else + op0 = vn_valueize (op0); } if (TREE_CODE (op1) == SSA_NAME) { - if (VN_INFO (op1)->has_constants) + if (VN_INFO (op1)->has_constants + || code == COMPLEX_EXPR) op1 = valueize_expr (vn_get_expr_for (op1)); - else if (SSA_VAL (op1) != VN_TOP && SSA_VAL (op1) != op1) - op1 = SSA_VAL (op1); + else + op1 = vn_valueize (op1); } /* Pointer plus constant can be represented as invariant address. Do so to allow further propatation, see also tree forwprop. */ - if (gimple_assign_rhs_code (stmt) == POINTER_PLUS_EXPR + if (code == POINTER_PLUS_EXPR && host_integerp (op1, 1) && TREE_CODE (op0) == ADDR_EXPR && is_gimple_min_invariant (op0)) @@ -2881,8 +2904,7 @@ simplify_binary_expression (gimple stmt) fold_defer_overflow_warnings (); - result = fold_binary (gimple_assign_rhs_code (stmt), - gimple_expr_type (stmt), op0, op1); + result = fold_binary (code, gimple_expr_type (stmt), op0, op1); if (result) STRIP_USELESS_TYPE_CONVERSION (result); @@ -2907,12 +2929,13 @@ simplify_unary_expression (gimple stmt) { tree result = NULL_TREE; tree orig_op0, op0 = gimple_assign_rhs1 (stmt); + enum tree_code code = gimple_assign_rhs_code (stmt); /* We handle some tcc_reference codes here that are all GIMPLE_ASSIGN_SINGLE codes. */ - if (gimple_assign_rhs_code (stmt) == REALPART_EXPR - || gimple_assign_rhs_code (stmt) == IMAGPART_EXPR - || gimple_assign_rhs_code (stmt) == VIEW_CONVERT_EXPR) + if (code == REALPART_EXPR + || code == IMAGPART_EXPR + || code == VIEW_CONVERT_EXPR) op0 = TREE_OPERAND (op0, 0); if (TREE_CODE (op0) != SSA_NAME) @@ -2921,10 +2944,10 @@ simplify_unary_expression (gimple stmt) orig_op0 = op0; if (VN_INFO (op0)->has_constants) op0 = valueize_expr (vn_get_expr_for (op0)); - else if (gimple_assign_cast_p (stmt) - || gimple_assign_rhs_code (stmt) == REALPART_EXPR - || gimple_assign_rhs_code (stmt) == IMAGPART_EXPR - || gimple_assign_rhs_code (stmt) == VIEW_CONVERT_EXPR) + else if (CONVERT_EXPR_CODE_P (code) + || code == REALPART_EXPR + || code == IMAGPART_EXPR + || code == VIEW_CONVERT_EXPR) { /* We want to do tree-combining on conversion-like expressions. Make sure we feed only SSA_NAMEs or constants to fold though. */ @@ -2941,8 +2964,7 @@ simplify_unary_expression (gimple stmt) if (op0 == orig_op0) return NULL_TREE; - result = fold_unary_ignore_overflow (gimple_assign_rhs_code (stmt), - gimple_expr_type (stmt), op0); + result = fold_unary_ignore_overflow (code, gimple_expr_type (stmt), op0); if (result) { STRIP_USELESS_TYPE_CONVERSION (result); @@ -2953,19 +2975,6 @@ simplify_unary_expression (gimple stmt) return NULL_TREE; } -/* Valueize NAME if it is an SSA name, otherwise just return it. */ - -static inline tree -vn_valueize (tree name) -{ - if (TREE_CODE (name) == SSA_NAME) - { - tree tem = SSA_VAL (name); - return tem == VN_TOP ? name : tem; - } - return name; -} - /* Try to simplify RHS using equivalences and constant folding. */ static tree @@ -3043,16 +3052,17 @@ visit_use (tree use) changed = defs_to_varying (stmt); else if (is_gimple_assign (stmt)) { + enum tree_code code = gimple_assign_rhs_code (stmt); tree lhs = gimple_assign_lhs (stmt); + tree rhs1 = gimple_assign_rhs1 (stmt); tree simplified; /* Shortcut for copies. Simplifying copies is pointless, since we copy the expression and value they represent. */ - if (gimple_assign_copy_p (stmt) - && TREE_CODE (gimple_assign_rhs1 (stmt)) == SSA_NAME + if (code == SSA_NAME && TREE_CODE (lhs) == SSA_NAME) { - changed = visit_copy (lhs, gimple_assign_rhs1 (stmt)); + changed = visit_copy (lhs, rhs1); goto done; } simplified = try_to_simplify (stmt); @@ -3119,24 +3129,22 @@ visit_use (tree use) /* We can substitute SSA_NAMEs that are live over abnormal edges with their constant value. */ && !(gimple_assign_copy_p (stmt) - && is_gimple_min_invariant (gimple_assign_rhs1 (stmt))) + && is_gimple_min_invariant (rhs1)) && !(simplified && is_gimple_min_invariant (simplified)) && SSA_NAME_OCCURS_IN_ABNORMAL_PHI (lhs)) /* Stores or copies from SSA_NAMEs that are live over abnormal edges are a problem. */ - || (gimple_assign_single_p (stmt) - && TREE_CODE (gimple_assign_rhs1 (stmt)) == SSA_NAME - && SSA_NAME_OCCURS_IN_ABNORMAL_PHI (gimple_assign_rhs1 (stmt)))) + || (code == SSA_NAME + && SSA_NAME_OCCURS_IN_ABNORMAL_PHI (rhs1))) changed = defs_to_varying (stmt); - else if (REFERENCE_CLASS_P (lhs) || DECL_P (lhs)) - { - changed = visit_reference_op_store (lhs, gimple_assign_rhs1 (stmt), stmt); - } + else if (REFERENCE_CLASS_P (lhs) + || DECL_P (lhs)) + changed = visit_reference_op_store (lhs, rhs1, stmt); else if (TREE_CODE (lhs) == SSA_NAME) { if ((gimple_assign_copy_p (stmt) - && is_gimple_min_invariant (gimple_assign_rhs1 (stmt))) + && is_gimple_min_invariant (rhs1)) || (simplified && is_gimple_min_invariant (simplified))) { @@ -3144,11 +3152,11 @@ visit_use (tree use) if (simplified) changed = set_ssa_val_to (lhs, simplified); else - changed = set_ssa_val_to (lhs, gimple_assign_rhs1 (stmt)); + changed = set_ssa_val_to (lhs, rhs1); } else { - switch (get_gimple_rhs_class (gimple_assign_rhs_code (stmt))) + switch (get_gimple_rhs_class (code)) { case GIMPLE_UNARY_RHS: case GIMPLE_BINARY_RHS: @@ -3156,31 +3164,33 @@ visit_use (tree use) changed = visit_nary_op (lhs, stmt); break; case GIMPLE_SINGLE_RHS: - switch (TREE_CODE_CLASS (gimple_assign_rhs_code (stmt))) + switch (TREE_CODE_CLASS (code)) { case tcc_reference: /* VOP-less references can go through unary case. */ - if ((gimple_assign_rhs_code (stmt) == REALPART_EXPR - || gimple_assign_rhs_code (stmt) == IMAGPART_EXPR - || gimple_assign_rhs_code (stmt) == VIEW_CONVERT_EXPR) - && TREE_CODE (TREE_OPERAND (gimple_assign_rhs1 (stmt), 0)) == SSA_NAME) + if ((code == REALPART_EXPR + || code == IMAGPART_EXPR + || code == VIEW_CONVERT_EXPR) + && TREE_CODE (TREE_OPERAND (rhs1, 0)) == SSA_NAME) { changed = visit_nary_op (lhs, stmt); break; } /* Fallthrough. */ case tcc_declaration: - changed = visit_reference_op_load - (lhs, gimple_assign_rhs1 (stmt), stmt); + changed = visit_reference_op_load (lhs, rhs1, stmt); break; - case tcc_expression: - if (gimple_assign_rhs_code (stmt) == ADDR_EXPR) + default: + if (code == ADDR_EXPR) + { + changed = visit_nary_op (lhs, stmt); + break; + } + else if (code == CONSTRUCTOR) { changed = visit_nary_op (lhs, stmt); break; } - /* Fallthrough. */ - default: changed = defs_to_varying (stmt); } break; diff --git a/gcc/tree-ssa-sccvn.h b/gcc/tree-ssa-sccvn.h index bf99702e43a..97d7f8f3921 100644 --- a/gcc/tree-ssa-sccvn.h +++ b/gcc/tree-ssa-sccvn.h @@ -42,10 +42,18 @@ typedef struct vn_nary_op_s hashval_t hashcode; tree result; tree type; - tree op[4]; + tree op[1]; } *vn_nary_op_t; typedef const struct vn_nary_op_s *const_vn_nary_op_t; +/* Return the size of a vn_nary_op_t with LENGTH operands. */ + +static inline size_t +sizeof_vn_nary_op (unsigned int length) +{ + return sizeof (struct vn_nary_op_s) + sizeof (tree) * (length - 1); +} + /* Phi nodes in the hashtable consist of their non-VN_TOP phi arguments, and the basic block the phi is in. Result is the value number of the operation, and hashcode is stored to avoid having to @@ -176,13 +184,11 @@ void free_scc_vn (void); tree vn_nary_op_lookup (tree, vn_nary_op_t *); tree vn_nary_op_lookup_stmt (gimple, vn_nary_op_t *); tree vn_nary_op_lookup_pieces (unsigned int, enum tree_code, - tree, tree, tree, tree, tree, - vn_nary_op_t *); + tree, tree *, vn_nary_op_t *); vn_nary_op_t vn_nary_op_insert (tree, tree); vn_nary_op_t vn_nary_op_insert_stmt (gimple, tree); vn_nary_op_t vn_nary_op_insert_pieces (unsigned int, enum tree_code, - tree, tree, tree, tree, - tree, tree, unsigned int); + tree, tree *, tree, unsigned int); void vn_reference_fold_indirect (VEC (vn_reference_op_s, heap) **, unsigned int *); void copy_reference_ops_from_ref (tree, VEC(vn_reference_op_s, heap) **); diff --git a/gcc/tree-ssa-structalias.c b/gcc/tree-ssa-structalias.c index d69f14c3fd5..edfbd649d73 100644 --- a/gcc/tree-ssa-structalias.c +++ b/gcc/tree-ssa-structalias.c @@ -4187,27 +4187,32 @@ find_func_aliases_for_builtin_call (gimple t) mode as well. */ case BUILT_IN_VA_START: { + tree valist = gimple_call_arg (t, 0); + struct constraint_expr rhs, *lhsp; + unsigned i; + get_constraint_for (valist, &lhsc); + do_deref (&lhsc); + /* The va_list gets access to pointers in variadic + arguments. Which we know in the case of IPA analysis + and otherwise are just all nonlocal variables. */ if (in_ipa_mode) { - tree valist = gimple_call_arg (t, 0); - struct constraint_expr rhs, *lhsp; - unsigned i; - /* The va_list gets access to pointers in variadic - arguments. */ fi = lookup_vi_for_tree (cfun->decl); - gcc_assert (fi != NULL); - get_constraint_for (valist, &lhsc); - do_deref (&lhsc); rhs = get_function_part_constraint (fi, ~0); rhs.type = ADDRESSOF; - FOR_EACH_VEC_ELT (ce_s, lhsc, i, lhsp) - process_constraint (new_constraint (*lhsp, rhs)); - VEC_free (ce_s, heap, lhsc); - /* va_list is clobbered. */ - make_constraint_to (get_call_clobber_vi (t)->id, valist); - return true; } - break; + else + { + rhs.var = nonlocal_id; + rhs.type = ADDRESSOF; + rhs.offset = 0; + } + FOR_EACH_VEC_ELT (ce_s, lhsc, i, lhsp) + process_constraint (new_constraint (*lhsp, rhs)); + VEC_free (ce_s, heap, lhsc); + /* va_list is clobbered. */ + make_constraint_to (get_call_clobber_vi (t)->id, valist); + return true; } /* va_end doesn't have any effect that matters. */ case BUILT_IN_VA_END: diff --git a/gcc/tree-streamer-in.c b/gcc/tree-streamer-in.c index efa4bd877be..0a79a249151 100644 --- a/gcc/tree-streamer-in.c +++ b/gcc/tree-streamer-in.c @@ -841,7 +841,6 @@ lto_input_ts_binfo_tree_pointers (struct lto_input_block *ib, BINFO_OFFSET (expr) = stream_read_tree (ib, data_in); BINFO_VTABLE (expr) = stream_read_tree (ib, data_in); - BINFO_VIRTUALS (expr) = stream_read_tree (ib, data_in); BINFO_VPTR_FIELD (expr) = stream_read_tree (ib, data_in); len = streamer_read_uhwi (ib); diff --git a/gcc/tree-streamer-out.c b/gcc/tree-streamer-out.c index 61e674ab4f7..093b4b3e6f3 100644 --- a/gcc/tree-streamer-out.c +++ b/gcc/tree-streamer-out.c @@ -701,11 +701,6 @@ write_ts_binfo_tree_pointers (struct output_block *ob, tree expr, bool ref_p) stream_write_tree (ob, BINFO_OFFSET (expr), ref_p); stream_write_tree (ob, BINFO_VTABLE (expr), ref_p); - /* BINFO_VIRTUALS is used to drive type based devirtualizatoin. It often links - together large portions of programs making it harder to partition. Becuase - devirtualization is interesting before inlining, only, there is no real - need to ship it into ltrans partition. */ - stream_write_tree (ob, flag_wpa ? NULL : BINFO_VIRTUALS (expr), ref_p); stream_write_tree (ob, BINFO_VPTR_FIELD (expr), ref_p); streamer_write_uhwi (ob, VEC_length (tree, BINFO_BASE_ACCESSES (expr))); diff --git a/gcc/tree-vect-patterns.c b/gcc/tree-vect-patterns.c index ef6a4fd372d..0d788827513 100644 --- a/gcc/tree-vect-patterns.c +++ b/gcc/tree-vect-patterns.c @@ -344,12 +344,14 @@ vect_recog_dot_prod_pattern (VEC (gimple, heap) **stmts, tree *type_in, replace a_T = (TYPE) a_t; with a_it - (interm_type) a_t; */ static bool -vect_handle_widen_mult_by_const (tree const_oprnd, tree *oprnd, +vect_handle_widen_mult_by_const (gimple stmt, tree const_oprnd, tree *oprnd, VEC (gimple, heap) **stmts, tree type, tree *half_type, gimple def_stmt) { tree new_type, new_oprnd, tmp; gimple new_stmt; + loop_vec_info loop_info = STMT_VINFO_LOOP_VINFO (vinfo_for_stmt (stmt)); + struct loop *loop = LOOP_VINFO_LOOP (loop_info); if (int_fits_type_p (const_oprnd, *half_type)) { @@ -359,6 +361,8 @@ vect_handle_widen_mult_by_const (tree const_oprnd, tree *oprnd, } if (TYPE_PRECISION (type) < (TYPE_PRECISION (*half_type) * 4) + || !gimple_bb (def_stmt) + || !flow_bb_inside_loop_p (loop, gimple_bb (def_stmt)) || !vinfo_for_stmt (def_stmt)) return false; @@ -527,7 +531,8 @@ vect_recog_widen_mult_pattern (VEC (gimple, heap) **stmts, { if (TREE_CODE (oprnd0) == INTEGER_CST && TREE_CODE (half_type1) == INTEGER_TYPE - && vect_handle_widen_mult_by_const (oprnd0, &oprnd1, stmts, type, + && vect_handle_widen_mult_by_const (last_stmt, oprnd0, &oprnd1, + stmts, type, &half_type1, def_stmt1)) half_type0 = half_type1; else @@ -537,7 +542,8 @@ vect_recog_widen_mult_pattern (VEC (gimple, heap) **stmts, { if (TREE_CODE (oprnd1) == INTEGER_CST && TREE_CODE (half_type0) == INTEGER_TYPE - && vect_handle_widen_mult_by_const (oprnd1, &oprnd0, stmts, type, + && vect_handle_widen_mult_by_const (last_stmt, oprnd1, &oprnd0, + stmts, type, &half_type0, def_stmt0)) half_type1 = half_type0; else @@ -868,6 +874,8 @@ vect_operation_fits_smaller_type (gimple stmt, tree def, tree *new_type, tree interm_type = NULL_TREE, half_type, tmp, new_oprnd, type; gimple def_stmt, new_stmt; bool first = false; + loop_vec_info loop_info = STMT_VINFO_LOOP_VINFO (vinfo_for_stmt (stmt)); + struct loop *loop = LOOP_VINFO_LOOP (loop_info); *new_def_stmt = NULL; @@ -898,6 +906,8 @@ vect_operation_fits_smaller_type (gimple stmt, tree def, tree *new_type, { first = true; if (!widened_name_p (oprnd, stmt, &half_type, &def_stmt, false) + || !gimple_bb (def_stmt) + || !flow_bb_inside_loop_p (loop, gimple_bb (def_stmt)) || !vinfo_for_stmt (def_stmt)) return false; } diff --git a/gcc/tree-vect-stmts.c b/gcc/tree-vect-stmts.c index 2a1318195e5..2c770919a2a 100644 --- a/gcc/tree-vect-stmts.c +++ b/gcc/tree-vect-stmts.c @@ -4680,15 +4680,19 @@ vectorizable_load (gimple stmt, gimple_stmt_iterator *gsi, gimple *vec_stmt, LOOP - the loop that is being vectorized. COND - Condition that is checked for simple use. + Output: + *COMP_VECTYPE - the vector type for the comparison. + Returns whether a COND can be vectorized. Checks whether condition operands are supportable using vec_is_simple_use. */ static bool -vect_is_simple_cond (tree cond, loop_vec_info loop_vinfo) +vect_is_simple_cond (tree cond, loop_vec_info loop_vinfo, tree *comp_vectype) { tree lhs, rhs; tree def; enum vect_def_type dt; + tree vectype1 = NULL_TREE, vectype2 = NULL_TREE; if (!COMPARISON_CLASS_P (cond)) return false; @@ -4699,8 +4703,8 @@ vect_is_simple_cond (tree cond, loop_vec_info loop_vinfo) if (TREE_CODE (lhs) == SSA_NAME) { gimple lhs_def_stmt = SSA_NAME_DEF_STMT (lhs); - if (!vect_is_simple_use (lhs, loop_vinfo, NULL, &lhs_def_stmt, &def, - &dt)) + if (!vect_is_simple_use_1 (lhs, loop_vinfo, NULL, &lhs_def_stmt, &def, + &dt, &vectype1)) return false; } else if (TREE_CODE (lhs) != INTEGER_CST && TREE_CODE (lhs) != REAL_CST @@ -4710,14 +4714,15 @@ vect_is_simple_cond (tree cond, loop_vec_info loop_vinfo) if (TREE_CODE (rhs) == SSA_NAME) { gimple rhs_def_stmt = SSA_NAME_DEF_STMT (rhs); - if (!vect_is_simple_use (rhs, loop_vinfo, NULL, &rhs_def_stmt, &def, - &dt)) + if (!vect_is_simple_use_1 (rhs, loop_vinfo, NULL, &rhs_def_stmt, &def, + &dt, &vectype2)) return false; } else if (TREE_CODE (rhs) != INTEGER_CST && TREE_CODE (rhs) != REAL_CST && TREE_CODE (rhs) != FIXED_CST) return false; + *comp_vectype = vectype1 ? vectype1 : vectype2; return true; } @@ -4743,12 +4748,12 @@ vectorizable_condition (gimple stmt, gimple_stmt_iterator *gsi, tree cond_expr, then_clause, else_clause; stmt_vec_info stmt_info = vinfo_for_stmt (stmt); tree vectype = STMT_VINFO_VECTYPE (stmt_info); + tree comp_vectype; tree vec_cond_lhs = NULL_TREE, vec_cond_rhs = NULL_TREE; tree vec_then_clause = NULL_TREE, vec_else_clause = NULL_TREE; tree vec_compare, vec_cond_expr; tree new_temp; loop_vec_info loop_vinfo = STMT_VINFO_LOOP_VINFO (stmt_info); - enum machine_mode vec_mode; tree def; enum vect_def_type dt, dts[4]; int nunits = TYPE_VECTOR_SUBPARTS (vectype); @@ -4797,13 +4802,8 @@ vectorizable_condition (gimple stmt, gimple_stmt_iterator *gsi, then_clause = gimple_assign_rhs2 (stmt); else_clause = gimple_assign_rhs3 (stmt); - if (!vect_is_simple_cond (cond_expr, loop_vinfo)) - return false; - - /* We do not handle two different vector types for the condition - and the values. */ - if (!types_compatible_p (TREE_TYPE (TREE_OPERAND (cond_expr, 0)), - TREE_TYPE (vectype))) + if (!vect_is_simple_cond (cond_expr, loop_vinfo, &comp_vectype) + || !comp_vectype) return false; if (TREE_CODE (then_clause) == SSA_NAME) @@ -4830,14 +4830,10 @@ vectorizable_condition (gimple stmt, gimple_stmt_iterator *gsi, && TREE_CODE (else_clause) != FIXED_CST) return false; - - vec_mode = TYPE_MODE (vectype); - if (!vec_stmt) { STMT_VINFO_TYPE (stmt_info) = condition_vec_info_type; - return expand_vec_cond_expr_p (TREE_TYPE (gimple_assign_lhs (stmt)), - vec_mode); + return expand_vec_cond_expr_p (vectype, comp_vectype); } /* Transform */ diff --git a/gcc/tree-vectorizer.c b/gcc/tree-vectorizer.c index 2170627483e..d76fe0c3e84 100644 --- a/gcc/tree-vectorizer.c +++ b/gcc/tree-vectorizer.c @@ -149,16 +149,12 @@ vect_print_dump_info (enum vect_verbosity_levels vl) if (!current_function_decl || !vect_dump) return false; - if (dump_file) - fprintf (vect_dump, "\n"); - - else if (vect_location == UNKNOWN_LOC) + if (vect_location == UNKNOWN_LOC) fprintf (vect_dump, "\n%s:%d: note: ", DECL_SOURCE_FILE (current_function_decl), DECL_SOURCE_LINE (current_function_decl)); else - fprintf (vect_dump, "\n%s:%d: note: ", - LOC_FILE (vect_location), LOC_LINE (vect_location)); + fprintf (vect_dump, "\n%d: ", LOC_LINE (vect_location)); return true; } @@ -199,12 +195,22 @@ vectorize_loops (void) loop_vec_info loop_vinfo; vect_location = find_loop_location (loop); + if (vect_location != UNKNOWN_LOC + && vect_verbosity_level > REPORT_NONE) + fprintf (vect_dump, "\nAnalyzing loop at %s:%d\n", + LOC_FILE (vect_location), LOC_LINE (vect_location)); + loop_vinfo = vect_analyze_loop (loop); loop->aux = loop_vinfo; if (!loop_vinfo || !LOOP_VINFO_VECTORIZABLE_P (loop_vinfo)) continue; + if (vect_location != UNKNOWN_LOC + && vect_verbosity_level > REPORT_NONE) + fprintf (vect_dump, "\n\nVectorizing loop at %s:%d\n", + LOC_FILE (vect_location), LOC_LINE (vect_location)); + vect_transform_loop (loop_vinfo); num_vectorized_loops++; } diff --git a/gcc/tree.c b/gcc/tree.c index 714ccbb8a66..a53c9f432ee 100644 --- a/gcc/tree.c +++ b/gcc/tree.c @@ -4397,7 +4397,7 @@ free_lang_data_in_one_sizepos (tree *expr_p) /* Reset all the fields in a binfo node BINFO. We only keep - BINFO_VIRTUALS, which is used by gimple_fold_obj_type_ref. */ + BINFO_VTABLE, which is used by gimple_fold_obj_type_ref. */ static void free_lang_data_in_binfo (tree binfo) @@ -4407,7 +4407,7 @@ free_lang_data_in_binfo (tree binfo) gcc_assert (TREE_CODE (binfo) == TREE_BINFO); - BINFO_VTABLE (binfo) = NULL_TREE; + BINFO_VIRTUALS (binfo) = NULL_TREE; BINFO_BASE_ACCESSES (binfo) = NULL; BINFO_INHERITANCE_CHAIN (binfo) = NULL_TREE; BINFO_SUBVTT_INDEX (binfo) = NULL_TREE; |