diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-07-15 11:24:46 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2009-07-15 11:24:46 +0000 |
| commit | 56fcd3fede0e1c4489a3c108d95fd1ff38dfa1a5 (patch) | |
| tree | f21ec6dd55e434aff16e698b0286153465775d62 | |
| parent | c2ce85c4e04bda844aa35dfdf41e69e585d97b2e (diff) | |
| download | gcc-56fcd3fede0e1c4489a3c108d95fd1ff38dfa1a5.tar.gz | |
2009-07-15 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk rev 149655
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@149682 138bc75d-0d04-0410-961f-82ee72b054a4
363 files changed, 11093 insertions, 7830 deletions
diff --git a/ChangeLog.MELT b/ChangeLog.MELT index 335cce78cf0..5c386104ccc 100644 --- a/ChangeLog.MELT +++ b/ChangeLog.MELT @@ -1,4 +1,7 @@ +2009-07-15 Basile Starynkevitch <basile@starynkevitch.net> + MELT branch merged with trunk rev 149655 + 2009-07-09 Basile Starynkevitch <basile@starynkevitch.net> MELT branch merged with trunk rev 149427 diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 01dff9e73c6..201a3ef8c77 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,13 +1,327 @@ +2009-07-15 DJ Delorie <dj@redhat.com> + + * config/mep/mep.md (sibcall_internal): Change register to allow + for 24-bit addresses. + (sibcall_value_internal): Likewise. + +2009-07-14 Ghassan Shobaki <ghassan.shobaki@amd.com> + + * doc/invoke.texi: Added descriptions of the + scheduling heuristics that are enabled/disabled + by the flags introduced by a previous patch. + +2009-07-14 DJ Delorie <dj@redhat.com> + + * config/mep/mep.md (sibcall_internal): Include non-toggling + non-jmp case. + (sibcall_value_internal): Likewise. + +2009-07-14 Taras Glek <tglek@mozilla.com> + Rafael Espindola <espindola@google.com> + + * doc/sourcebuild.texi: Document install-plugin target. + * configure.ac: Added install-plugin target to language makefiles. + * configure: Regenerate. + * Makefile.in: (install-plugin): Install more headers, + depend on lang.install-plugin. + +2009-07-15 Manuel López-Ibáñez <manu@gcc.gnu.org> + + * tree-vrp.c (vrp_evaluate_conditional): Mark strings for + translation. + +2009-07-14 DJ Delorie <dj@redhat.com> + + * config/mep/mep.c (mep_vliw_jmp_match): New function. + * config/mep/mep-protos.h (mep_vliw_jmp_match): Prototype it. + * config/mep/mep.md (sibcall_internal): Change test from + mep_vliw_mode_match to mep_vliw_jmp_match. + (sibcall_value_internal): Likewise. + +2009-07-14 Uros Bizjak <ubizjak@gmail.com> + + * config/i386/sse.md (copysign<mode>3): New expander. + * config/i386/i386-protos.h (ix86_build_signbit_mask): New prototype. + * config/i386/i386.c (ix86_build_signbit_mask): Make public. + Use ix86_build_const_vector. + (enum ix86_builtins): Add IX86_BUILTIN_CPYSGNPS and + IX86_BUILTIN_CPYSGNPD. + (builtin_description): Add __builtin_ia32_copysignps and + __builtin_ia32_copysignpd. + (ix86_builtin_vectorized_function): Handle BUILT_IN_COPYSIGN + and BUILT_IN_COPYSIGNF. + +2009-07-13 Jason Merrill <jason@redhat.com> + + * builtins.c (can_trust_pointer_alignment): New fn. + (get_pointer_alignment): Factor it out from here. + * tree.h: Declare it. + +2009-07-14 David Edelsohn <edelsohn@gnu.org> + + * config/rs6000/predicates.md (offsettable_mem_operand): Test + RTX_AUTOINC class. + +2009-07-14 Dodji Seketeli <dodji@redhat.com> + + PR debug/40705 + PR c++/403057 + * dwarf2.out.c (gen_type_die_with_usage): Added comment. + +2009-07-14 Richard Guenther <rguenther@suse.de> + Andrey Belevantsev <abel@ispras.ru> + + PR middle-end/40745 + * cfgexpand.c (partition_stack_vars): Do not bother to update + alias information when not optimizing. + +2009-07-14 Richard Guenther <rguenther@suse.de> + Andrey Belevantsev <abel@ispras.ru> + + * tree-ssa-alias.h (refs_may_alias_p_1): Declare. + (pt_solution_set): Likewise. + * tree-ssa-alias.c (refs_may_alias_p_1): Export. + * tree-ssa-structalias.c (pt_solution_set): New function. + * final.c (rest_of_clean_state): Free SSA data structures. + * print-rtl.c (print_decl_name): Remove. + (print_mem_expr): Implement in terms of print_generic_expr. + * alias.c (ao_ref_from_mem): New function. + (rtx_refs_may_alias_p): Likewise. + (true_dependence): Query alias-export info. + (canon_true_dependence): Likewise. + (write_dependence_p): Likewise. + * tree-dfa.c (get_ref_base_and_extent): For void types leave + size unknown. + * emit-rtl.c (component_ref_for_mem_expr): Remove. + (mem_expr_equal_p): Use operand_equal_p. + (set_mem_attributes_minus_bitpos): Do not use + component_ref_for_mem_expr. + * cfgexpand.c (add_partitioned_vars_to_ptset): New function. + (update_alias_info_with_stack_vars): Likewise. + (partition_stack_vars): Call update_alias_info_with_stack_vars. + * tree-ssa.c (delete_tree_ssa): Do not release SSA names + explicitly nor clear stmt operands. + Free the decl-to-pointer map. + * tree-optimize.c (execute_free_datastructures): Do not free + SSA data structures here. + * tree-flow.h (struct gimple_df): Add decls_to_pointers member. + * Makefile.in (emit-rtl.o): Add pointer-set.h dependency. + (alias.o): Add tree-ssa-alias.h, pointer-set.h and $(TREE_FLOW_H) + dependencies. + (print-rtl.o): Add $(DIAGNOSTIC_H) dependency. + +2009-07-13 DJ Delorie <dj@redhat.com> + + * config/mep/mep.h (CC1_SPEC): Tweak parameters to trigger + unrolling at the right iteration count. + + * config/mep/mep.c (mep_expand_prologue): Fix frame pointer + calculations. + +2009-07-13 Ghassan Shobaki <ghassan.shobaki@amd.com> + + * haifa-sched.c (rank_for_schedule): Introduced flags to + enable/disable individual scheduling heuristics. + * common.opt: Introduced flags to enable/disable individual + heuristics in the scheduler. + * doc/invoke.texi: Introduced flags to enable/disable individual + heuristics in the scheduler. + +2009-07-13 Kai Tietz <kai.tietz@onevision.com> + + * config/i386/t-gthr-win32 (LIB2FUNCS_EXTRA): Remove file + config/i386/mingw-tls.c. + * config/i386/mingw-tls.c: Removed. + +2009-07-13 Ira Rosen <irar@il.ibm.com> + + * tree-vect-loop.c (get_initial_def_for_reduction): Ensure that the + checks access only relevant statements. + (vectorizable_reduction): Likewise. + +2009-07-12 Kai Tietz <kai.tietz@onevision.com> + + * config/i386/cygming.h (TARGET_OS_CPP_BUILTINS): Define _X86_ + just for 32-bit case. + +2009-07-12 Jan Hubicka <jh@suse.cz> + + PR tree-optimization/40585 + * except.c (expand_resx_expr): When there already is resume + instruction, produce linked list. + (build_post_landing_pads): Assert that resume is empty. + (connect_post_landing_pads): Handle resume lists. + (dump_eh_tree): Dump resume list. + +2009-07-12 Ira Rosen <irar@il.ibm.com> + + * tree-parloops.c (loop_parallel_p): Call vect_is_simple_reduction + with additional argument. + * tree-vectorizer.h (enum vect_def_type): Add + vect_double_reduction_def. + (vect_is_simple_reduction): Add argument. + * tree-vect-loop.c (vect_determine_vectorization_factor): Fix + indentation. + (vect_analyze_scalar_cycles_1): Detect double reduction. Call + vect_is_simple_reduction with additional argument. + (vect_analyze_loop_operations): Handle exit phi nodes in case of + double reduction. + (reduction_code_for_scalar_code): Handle additional codes by + returning ERROR_MARK for them. Fix comment and indentation. + (vect_is_simple_reduction): Fix comment, add argument to specify + double reduction. Detect double reduction. + (get_initial_def_for_induction): Fix indentation. + (get_initial_def_for_reduction): Fix comment and indentation. + Handle double reduction. Create initial definitions that do not + require adjustment if ADJUSTMENT_DEF is NULL. Handle additional cases. + (vect_create_epilog_for_reduction): Fix comment, add argument to + handle double reduction. Use PLUS_EXPR in case of MINUS_EXPR in + epilogue result extraction. Create double reduction phi node and + replace relevant uses. + (vectorizable_reduction): Call vect_is_simple_reduction with + additional argument. Fix indentation. Update epilogue code treatment + according to the changes in reduction_code_for_scalar_code. Check + for double reduction. Call vect_create_epilog_for_reduction with + additional argument. + * tree-vect-stmts.c (process_use): Handle double reduction, update + documentation. + (vect_mark_stmts_to_be_vectorized): Handle double reduction. + (vect_get_vec_def_for_operand): Likewise. + +2009-07-12 Danny Smith <dansmister@gmail.com> + + * config/i386/winnt.c (i386_pe_determine_dllexport_p): Don't + dllexport if !TREE_PUBLIC. + (i386_pe_maybe_record_exported_symbol): Assert TREE_PUBLIC. + +2009-07-11 Anatoly Sokolov <aesok@post.ru> + + * config/avr/avr.h (TARGET_CPU_CPP_BUILTINS): Redefine. + (avr_extra_arch_macro) Remove declatation. + * config/avr/avr.c (avr_cpu_cpp_builtins): New function. + (avr_extra_arch_macro) Declare as static. + * config/avr/avr-protos.h (avr_cpu_cpp_builtins): Dclare. + +2009-07-11 Jan Hubicka <jh@suse.cz> + + PR middle-end/48388 + * except.c (can_be_reached_by_runtime): Test for NULL aka bitmap. + +2009-07-11 Jakub Jelinek <jakub@redhat.com> + + PR debug/40713 + * dwarf2out.c (dw_fde_struct): Add in_std_section and + cold_in_std_section bits. + (dwarf2out_begin_prologue): Initialize them. + (dwarf2out_finish): Don't emit FDE range into .debug_ranges + if already covered by text_section or cold_text_section range. + + PR rtl-optimization/40667 + * defaults.h (MINIMUM_ALIGNMENT): Define if not defined. + * doc/tm.texi (MINIMUM_ALIGNMENT): Document it. + * config/i386/i386.h (MINIMUM_ALIGNMENT): Define. + * config/i386/i386.c (ix86_minimum_alignment): New function. + * config/i386/i386-protos.h (ix86_minimum_alignment): New prototype. + * cfgexpand.c (expand_one_var): Use MINIMIM_ALIGNMENT. + * emit-rtl.c (gen_reg_rtx): Likewise. + * function.c (assign_parms): Likewise. If nominal_type needs + bigger alignment than FUNCTION_ARG_BOUNDARY, use its alignment + rather than passed_type's alignment. + + PR target/40668 + * function.c (assign_parm_setup_stack): Adjust + MEM_OFFSET (data->stack_parm) if promoted_mode is different + from nominal_mode on big endian. + +2009-07-11 Paolo Bonzini <bonzini@gnu.org> + + * expmed.c (emit_store_flag_1): Fix choice of zero vs. sign extension. + +2009-07-10 DJ Delorie <dj@redhat.com> + + * config/mep/mep.c (mep_can_inline_p): Correct logic, and simplify. + +2009-07-10 Mark Mitchell <mark@codesourcery.com> + + * config/arm/thumb2.md (thumb2_cbz): Correct computation of length + attribute. + (thumb2_cbnz): Likewise. + +2009-07-10 David Daney <ddaney@caviumnetworks.com> + + PR target/39079 + * config.gcc (supported_defaults): Add synci. + (with_synci): Add validation. + (all_defaults): Add synci. + * config/mips/mips.md (clear_cache): Use TARGET_SYNCI instead of + ISA_HAS_SYNCI. + (synci): Same. + * config/mips/mips.opt (msynci): New option. + * config/mips/mips.c (mips_override_options): Warn on use of + -msynci for targets that do now support it. + * gcc/config/mips/mips.h (OPTION_DEFAULT_SPECS): Add a default for + msynci. + * gcc/doc/invoke.texi (-msynci): Document the new option. + * doc/install.texi (--with-synci): Document the new option. + +2009-07-10 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/40496 + * tree-ssa-loop-manip.c (tree_transform_and_unroll_loop): Create + the PHI result with a compatible type. + +2009-07-10 Manuel López-Ibáñez <manu@gcc.gnu.org> + + PR 25509 + PR 40614 + * c.opt (Wunused-result): New. + * doc/invoke.texi: Document it. + * c-common.c (c_warn_unused_result): Use it. + +2009-07-09 DJ Delorie <dj@redhat.com> + + * targhooks.c (default_target_can_inline_p): Rename from + default_target_option_can_inline_p. + * targhooks.h (default_target_can_inline_p): Likewise. + * target-def.h (TARGET_CAN_INLINE_P): Rename from + TARGET_OPTION_CAN_INLINE_P. + * config/i386/i386.c (TARGET_CAN_INLINE_P): Likewise. + * config/mep/mep.c (TARGET_CAN_INLINE_P): Likewise. + (mep_target_can_inline_p): Rename from + mep_target_option_can_inline_p. + + PR target/40626 + * config/mep/mep.h (FUNCTION_ARG_REGNO_P): Add coprocessor + registers used to pass vectors. + + * config/mep/mep.c (mep_option_can_inline_p): Remove error call. + +2009-07-09 Tom Tromey <tromey@redhat.com> + + * unwind-dw2-fde-darwin.c: Include dwarf2.h. + * config/mmix/mmix.c: Include dwarf2.h. + * config/rs6000/darwin-fallback.c: Include dwarf2.h. + * config/xtensa/unwind-dw2-xtensa.c: Include dwarf2.h. + * config/sh/sh.c: Include dwarf2.h. + * config/i386/i386.c: Include dwarf2.h. + * Makefile.in (DWARF2_H): Remove 'elf'. + * except.c: Include dwarf2.h. + * unwind-dw2.c: Include dwarf2.h. + * dwarf2out.c: Include dwarf2.h. + * unwind-dw2-fde-glibc.c: Include dwarf2.h. + * unwind-dw2-fde.c: Include dwarf2.h. + * dwarf2asm.c: Include dwarf2.h. + 2009-07-09 Maxim Kuvyrkov <maxim@codesourcery.com> - + * haifa-sched.c (insn_finishes_cycle_p): New static function. - (max_issue): Use it. - * sched-int.h (struct sched_info: insn_finishes_block_p): New - scheduler hook. - * sched-rgn.c (rgn_insn_finishes_block_p): Implement it. - (region_sched_info): Update. - * sched-ebb.c (ebb_sched_info): Update. - * modulo-sched.c (sms_sched_info): Update. + (max_issue): Use it. + * sched-int.h (struct sched_info: insn_finishes_block_p): New + scheduler hook. + * sched-rgn.c (rgn_insn_finishes_block_p): Implement it. + (region_sched_info): Update. + * sched-ebb.c (ebb_sched_info): Update. + * modulo-sched.c (sms_sched_info): Update. * sel-sched-ir.c (sched_sel_haifa_sched_info): Update. 2009-07-09 Maxim Kuvyrkov <maxim@codesourcery.com> @@ -26,8 +340,8 @@ 2009-07-08 Adam Nemet <anemet@caviumnetworks.com> - * simplify-rtx.c (simplify_binary_operation_1) <AND>: Transform (and - (truncate)) into (truncate (and)). + * simplify-rtx.c (simplify_binary_operation_1) <AND>: + Transform (and (truncate)) into (truncate (and)). 2009-07-08 Adam Nemet <anemet@caviumnetworks.com> @@ -142,9 +456,9 @@ 2009-07-07 Duncan Sands <baldrick@free.fr> - * final.c (pass_clean_state): Give the pass a name. - * passes.c (pass_rest_of_compilation): Likewise. - * tree-optimize.c (pass_all_optimizations): Likewise. + * final.c (pass_clean_state): Give the pass a name. + * passes.c (pass_rest_of_compilation): Likewise. + * tree-optimize.c (pass_all_optimizations): Likewise. 2009-07-07 H.J. Lu <hongjiu.lu@intel.com> @@ -169,8 +483,7 @@ 2009-07-07 Manuel López-Ibáñez <manu@gcc.gnu.org> - * cgraphunit.c: Replace %J by an explicit location. Update all - calls. + * cgraphunit.c: Replace %J by an explicit location. Update all calls. * c-decl.c: Likewise. * function.c: Likewise. * varasm.c: Likewise. @@ -222,8 +535,7 @@ 2009-07-06 Diego Novillo <dnovillo@google.com> - * tree-pretty-print.c (dump_generic_node): Protect - against NULL op0. + * tree-pretty-print.c (dump_generic_node): Protect against NULL op0. (debug_tree_chain): Handle cycles. 2009-07-06 Nick Clifton <nickc@redhat.com> @@ -237,8 +549,7 @@ (TARGET_CPU_CPP_BUILTINS): Define __FMOVD_ENABLED__ if TARGET_FMOVD is true. * config/sh/sh.md (movdf_i4): For alternative 0 use either one or - two fmov instructions depending upon whether TARGET_FMOVD is - enabled. + two fmov instructions depending upon whether TARGET_FMOVD is enabled. (split for DF load from memory into register): Also handle MEMs which consist of REG+DISP addressing. (split for DF store from register to memory): Likewise. @@ -283,8 +594,7 @@ 2009-07-03 Vladimir Makarov <vmakarov@redhat.com> PR target/40587 - * ira.c (build_insn_chain): Use DF_LR_OUT instead of - df_get_live_out. + * ira.c (build_insn_chain): Use DF_LR_OUT instead of df_get_live_out. 2009-07-03 Richard Guenther <rguenther@suse.de> @@ -300,9 +610,9 @@ 2009-07-03 Richard Guenther <rguenther@suse.de> PR middle-end/34163 - * tree-chrec.c (chrec_convert_1): Fold (T2)(t +- x) to - (T2)t +- (T2)x if t +- x is known to not overflow and - the conversion widens the operation. + * tree-chrec.c (chrec_convert_1): Fold (T2)(t +- x) to (T2)t +- (T2)x + if t +- x is known to not overflow and the conversion widens the + operation. * Makefile.in (tree-chrec.o): Add $(FLAGS_H) dependency. 2009-07-03 Jan Hubicka <jh@suse.cz> @@ -2626,7 +2936,7 @@ (vect_finalize_reduction): Handle subtraction, fix comments. (vectorizable_reduction): Handle nested cycles. In case of nested cycle keep track of the reduction variable position. Call - vect_is_simple_reduction with additional parameter. Use original + vect_is_simple_reduction with additional parameter. Use original statement code in reduction epilogue for nested cycle. Call vect_create_epilog_for_reduction with additional parameter. * tree-vect-patterns.c (vect_recog_dot_prod_pattern): Assert @@ -4217,26 +4527,26 @@ 2009-06-01 Ira Rosen <irar@il.ibm.com> PR tree-optimization/39129 - * tree-vect-loop-manip.c (conservative_cost_threshold): Change the + * tree-vect-loop-manip.c (conservative_cost_threshold): Change the printed message. - (vect_do_peeling_for_loop_bound): Use + (vect_do_peeling_for_loop_bound): Use LOOP_REQUIRES_VERSIONING_FOR_ALIGNMENT and LOOP_REQUIRES_VERSIONING_FOR_ALIAS macros. (vect_loop_versioning): Likewise. (vect_create_cond_for_alias_checks): Fix indentation. - * tree-vectorizer.h (struct _loop_vec_info): Fix indentation of the + * tree-vectorizer.h (struct _loop_vec_info): Fix indentation of the macros. (LOOP_REQUIRES_VERSIONING_FOR_ALIGNMENT): Define. (LOOP_REQUIRES_VERSIONING_FOR_ALIAS): Likewise. - * tree-vect-loop.c (vect_analyze_loop_form): Change "too many BBs" to + * tree-vect-loop.c (vect_analyze_loop_form): Change "too many BBs" to "control flow in loop". - (vect_estimate_min_profitable_iters): Use + (vect_estimate_min_profitable_iters): Use LOOP_REQUIRES_VERSIONING_FOR_ALIGNMENT and LOOP_REQUIRES_VERSIONING_FOR_ALIAS macros. * tree-vect-data-refs.c (vect_enhance_data_refs_alignment): Likewise. (vect_create_data_ref_ptr): Don't mention array dimension in printing. - * tree-vect-stmts.c (vectorizable_store): Replace the check that the - statement belongs to a group of strided accesses with the exact code + * tree-vect-stmts.c (vectorizable_store): Replace the check that the + statement belongs to a group of strided accesses with the exact code check. (vectorizable_load): Likewise. * tree-vect-slp.c (vect_analyze_slp_instance): Spell out "basic block". diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 0ac0e839b57..3ae0245a06c 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20090709 +20090715 diff --git a/gcc/Makefile.in b/gcc/Makefile.in index e030050e455..e4b06d60cd3 100644 --- a/gcc/Makefile.in +++ b/gcc/Makefile.in @@ -422,7 +422,7 @@ SPLAY_TREE_H= $(srcdir)/../include/splay-tree.h FIBHEAP_H = $(srcdir)/../include/fibheap.h PARTITION_H = $(srcdir)/../include/partition.h MD5_H = $(srcdir)/../include/md5.h -DWARF2_H = $(srcdir)/../include/elf/dwarf2.h +DWARF2_H = $(srcdir)/../include/dwarf2.h # Default native SYSTEM_HEADER_DIR, to be overridden by targets. NATIVE_SYSTEM_HEADER_DIR = /usr/include @@ -2615,7 +2615,7 @@ rtl.o : rtl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ print-rtl.o : print-rtl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(RTL_H) $(TREE_H) hard-reg-set.h $(BASIC_BLOCK_H) $(FLAGS_H) \ - $(BCONFIG_H) $(REAL_H) + $(BCONFIG_H) $(REAL_H) $(DIAGNOSTIC_H) rtlanal.o : rtlanal.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TOPLEV_H) \ $(RTL_H) hard-reg-set.h $(TM_P_H) insn-config.h $(RECOG_H) $(REAL_H) \ $(FLAGS_H) $(REGS_H) output.h $(TARGET_H) $(FUNCTION_H) $(TREE_H) \ @@ -2703,7 +2703,7 @@ emit-rtl.o : emit-rtl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ $(TREE_H) $(FLAGS_H) $(FUNCTION_H) $(REGS_H) insn-config.h $(RECOG_H) \ $(GGC_H) $(EXPR_H) hard-reg-set.h $(BITMAP_H) $(TOPLEV_H) $(BASIC_BLOCK_H) \ $(HASHTAB_H) $(TM_P_H) debug.h langhooks.h $(TREE_PASS_H) gt-emit-rtl.h \ - $(REAL_H) $(DF_H) + $(REAL_H) $(DF_H) pointer-set.h real.o : real.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ $(TOPLEV_H) $(TM_P_H) $(REAL_H) dfp.h dfp.o : dfp.c dfp.h $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \ @@ -3028,7 +3028,8 @@ alias.o : alias.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ $(FLAGS_H) hard-reg-set.h $(BASIC_BLOCK_H) $(REGS_H) $(TOPLEV_H) output.h \ $(ALIAS_H) $(EMIT_RTL_H) $(GGC_H) $(FUNCTION_H) cselib.h $(TREE_H) $(TM_P_H) \ langhooks.h $(TARGET_H) gt-alias.h $(TIMEVAR_H) $(CGRAPH_H) \ - $(SPLAY_TREE_H) $(VARRAY_H) $(IPA_TYPE_ESCAPE_H) $(DF_H) $(TREE_PASS_H) + $(SPLAY_TREE_H) $(VARRAY_H) $(IPA_TYPE_ESCAPE_H) $(DF_H) $(TREE_PASS_H) \ + tree-ssa-alias.h pointer-set.h $(TREE_FLOW_H) stack-ptr-mod.o : stack-ptr-mod.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(TREE_H) $(RTL_H) $(REGS_H) $(EXPR_H) $(TREE_PASS_H) \ $(BASIC_BLOCK_H) $(FLAGS_H) output.h $(DF_H) @@ -4139,10 +4140,11 @@ PLUGIN_HEADERS = $(TREE_H) $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ $(GGC_H) $(TREE_DUMP_H) $(PRETTY_PRINT_H) \ $(tm_file_list) $(tm_include_list) $(tm_p_file_list) $(tm_p_include_list) \ $(host_xm_file_list) $(host_xm_include_list) $(xm_include_list) \ - intl.h $(PLUGIN_VERSION_H) + intl.h $(PLUGIN_VERSION_H) $(DIAGNOSTIC_H) $(C_COMMON_H) $(C_PRETTY_PRINT_H) \ + tree-iterator.h $(PLUGIN_H) $(TREE_FLOW_H) langhooks.h # Install the headers needed to build a plugin. -install-plugin: installdirs +install-plugin: installdirs lang.install-plugin # We keep the directory structure for files in config and .def files. All # other files are flattened to a single directory. $(mkinstalldirs) $(DESTDIR)$(plugin_includedir) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b3eef9e2469..a3162c2e289 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,723 @@ +2009-07-14 Taras Glek <tglek@mozilla.com> + Rafael Espindola <espindola@google.com> + + * gcc-interface/Make-lang.in (ada.install-plugin): New target for + installing plugin headers. + +2009-07-13 Ed Schonberg <schonberg@adacore.com> + + * exp_ch7.adb, exp_util.adb, tbuild.adb, tbuild.ads, exp_ch4.adb, + exp_aggr.adb (Make_Temporary): Utility to create a defining identifier + and link it to the expression whose value it captures. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * output.adb: Minor comment addition for last change + + * sinfo.ads: Minor reformatting + +2009-07-13 Vasiliy Fofanov <fofanov@adacore.com> + + * adaint.c (__gnat_portable_no_block_spawn): on Windows, return -1 when + spawn failed like on all other targets. + +2009-07-13 Ed Schonberg <schonberg@adacore.com> + + * exp_ch7.adb: Indicate origin of temporary for transient expression. + +2009-07-13 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c: Add comment. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * sinfo.adb, sinfo.ads, sem_util.adb, atree.adb, atree.ads: Minor + reformatting. Minor code reorganization (add 9 argument version of + Nkind_In). + + * impunit.adb: Remove s-os_lib from list of system extensions. + + * sem_util.ads: Minor reformatting + + * output.adb: Add warnings off/on around System.OS_Lib. + +2009-07-13 Bob Duff <duff@adacore.com> + + * exp_dist.adb: Minor comment updates. + +2009-07-13 Gary Dismukes <dismukes@adacore.com> + + * sem_ch10.adb, sem_ch12.adb, gnat1drv.adb, exp_ch4.adb: Fix casing of + several references to CodePeer. + +2009-07-13 Bob Duff <duff@adacore.com> + + * exp_dist.adb (Build_From_Any_Function,Build_To_Any_Function, + Build_TypeCode_Function_All): Do not recurse if the type is the base + type. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb: Minor comment change + +2009-07-13 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Iteration_Scheme): Generate dummy reference for + type of iteration, to prevent spurious warnings. + +2009-07-13 Nicolas Roche <roche@adacore.com> + + * s-oscons-tmplt.c: On VxWorks target ensure that vxWorks.h is always + included. + +2009-07-13 Arnaud Charlet <charlet@adacore.com> + + * switch-c.adb, usage.adb, sem_ch9.adb, gnat_ugn.texi, rtsfind.adb, + gnat1drv.adb, opt.ads, sem_ch13.adb (Inspector_Mode): Renamed to + Generate_SCIL. + (CodePeer_Mode): New -gnatC switch. + (Adjust_Global_Switches): Adjust settings for Generate_SCIL and + CodePeer_Mode. + +2009-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * checks.adb (Selected_Range_Checks): Do not consider that a non-static + integer bound forces the check if it is compared to its subtype range. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * prj.ads, prj-dect.adb, prj-err.ads, prj-err.adb, prj-nmsc.adb, + prj-strt.ads: Minor reformatting + +2009-07-13 Thomas Quinot <quinot@adacore.com> + + * exp_dist.adb (Build_From_Any_Call): For the case of a generic type, + set the type of the From_Any call to the base type. + +2009-07-13 Doug Rupp <rupp@adacore.com> + + * symbols-processing-vms-ia64.adb (Process): Add variables and + constants to retrieve and check for symbol visibility. + +2009-07-13 Javier Miranda <miranda@adacore.com> + + * exp_ch4.adb (Expand_N_Unchecked_Type_Conversion): If conversion is to + the identical type we remove the conversion completely because + it is useless. + +2009-07-13 Emmanuel Briot <briot@adacore.com> + + * prj-err.adb (Error_Msg): One more case where a message should be + considered as a warning. + + * gnatcmd.adb (GNATCmd): Fix previous change, which negated a test. + +2009-07-13 Thomas Quinot <quinot@adacore.com> + + * exp_dist.adb (Expand_All_Calls_Remote_Subprogram_Call): Analyze + calling stubs in the (library level) scope of the RCI locator, where it + is attached, not in the caller's scope. + +2009-07-13 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): In case of class-wide + interface object declarations we delay the generation of the equivalent + record type declarations until its expansion because there are cases in + which they are not required. + + * sem_util.adb (Implements_Interface): Add missing support for subtypes. + + * sem_disp.adb (Check_Controlling_Formals): Minor code cleanup plus + addition of assertion. + + * exp_util.adb (Expand_Subtype_From_Expr): Renamings of class-wide + interface types require no equivalent constrained type declarations + because the expanded code only references the tag component associated + with the interface. + (Find_Interface_Tag): Improve management of interfaces that are + ancestors of tagged types. + + * exp_ch3.adb (Expand_N_Object_Declaration): Improve the expansion of + class-wide object declarations to add missing support to statically + displace the pointer to the object to reference the tag component + associated with the interface. + + * exp_disp.adb (Make_Tags) Avoid generation of internally generated + auxiliary types associated with user-defined dispatching calls if the + type has no user-defined primitives. + +2009-07-13 Vasiliy Fofanov <fofanov@adacore.com> + + * mingw32.h: Make it explicit that we need XP or later. + + * initialize.c: Remove useless extern symbol declaration. + + * adaint.h: Ditto, also expose __gnat_win32_remove_handle to allow + code reuse in expect.c. + + * adaint.c: Changes throughout the Windows section to redesign storage + of the child process list and the process identification. + + * expect.c (__gnat_kill, __gnat_waitpid): Simplify, cleanup, use pids + for interfacing, fix errors. + (__gnat_expect_portable_execvp): use function in adaint.c + +2009-07-13 Emmanuel Briot <briot@adacore.com> + + * prj-proc.adb, prj-part.adb, prj-part.ads, prj-strt.adb, + prj-strt.ads, prj.adb, prj.ads, prj-makr.adb, prj-makr.ads, + prj-dect.adb, prj-dect.ads, prj-nmsc.adb, prj-pars.adb, errutil.adb, + errutil.ads, prj-conf.adb, gnatname.adb, prj-err.adb, prj-err.ads + (Prj.Nmsc.Report_Error): Removed, no longer needed. + Always use Prj.Err.Report_Message. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * prj.adb, sem_ch4.adb, sem_res.adb, prj-nmsc.adb: Minor reformatting + & comment edits. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * opt.ads, prj-conf.adb, prj-env.adb, prj-ext.adb, prj-nmsc.adb, + prj-proc.adb, prj-tree.adb, prj-tree.ads: Minor reformatting + +2009-07-13 Emmanuel Briot <briot@adacore.com> + + * prj.adb, prj.ads, prj-env.adb, prj-conf.adb, prj-tree.adb, + mlib-prj.adb (Private_Part.Ada_Prj_Objects_File_Set, + Ada_Prj_Include_File_Set): Removed, since not needed + Code clean up. + +2009-07-13 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Analyze_Set_Membership): New procedure, subsidiary of + Analyze_Membership_Op. + + * sem_res.adb (Resolve_Set_Membership): New procedure, subsidiary of + Resolve_Membership_Op. + + * exp_ch4.adb (Expand_Set_Membership): New procedure, subsidiary of + Expand_N_In. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * clean.adb: Minor reformattting + +2009-07-13 Emmanuel Briot <briot@adacore.com> + + * gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj-ext.adb, + gnat_ugn.texi, prj.adb, prj.ads, clean.adb, prj-nmsc.adb, prj-util.adb, + prj-conf.adb, gnatname.adb, prj-env.adb, prj-env.ads, prj-tree.adb, + prj-tree.ads (Prj.Tree.Create*): New subprograms to create new packages + and attributes in a project tree. + (Add_Default_GNAT_Naming_Scheme): Provide real implementation. + Remove last remaining mode-specific code (ada_only or + multi_language). This was duplicating code + (Get_Mode, Set_Mode): removed, no longer used. + (Initialize_Project_Path): all tools will now take into account both + GPR_PROJECT_PATH and ADA_PROJECT_PATH (in that order). + Remove some global variables and subprograms no longer used + Make temporary files tree-specific, to avoid interferences between + trees loaded in memory at the same time. + (Prj.Delete_Temporary_File): new subprogram + (Object_Paths, Source_Paths): fields no longer stored in the project + tree, since they are only needed locally in Set_Ada_Paths. + (Set_Mapping_File_Initial_State_To_Empty): removed, since had no + effect in practice. + (Project_Tree_Data.Ada_Path_Buffer): removed, since it can be replaced + by local variables in the appropriate subprograms + (Has_Foreign_Sources): removed. + + * gcc-interface/Makefile.in: prj-pp.o is now needed to build gnatmake + +2009-07-13 Arnaud Charlet <charlet@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): No longer set + Back_Annotate_Rep_Info in inspector mode. + (Gnat1Drv): Need to call the back-end in inspector mode to generate SCIL + + * opt.ads: Update comment. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * lib.adb, prj-nmsc.adb, prj-proc.adb, prj-proc.ads, prj.adb, + prj.ads: Minor reformatting and code reorganization. + + * par-ch3.adb (Check_Restricted_Expression): New procedure + +2009-07-13 Ed Schonberg <schonberg@adacore.com> + + * exp_attr.adb (Rewrite_Stream_Proc_Call): When rewriting a stream + attribute into a call of the corresponding suprogram, create extra + formals for the subprogram, because it may be a renaming whose + analysis does not create extra formals. + +2009-07-13 Emmanuel Briot <briot@adacore.com> + + * gnatcmd.adb, prj-proc.adb, prj-proc.ads, make.adb, prj-part.adb, + prj.adb, prj.ads, clean.adb, prj-nmsc.adb, prj-nmsc.ads, prj-pars.adb, + prj-pars.ads, prj-conf.adb, prj-conf.ads, prj-env.adb, prj-tree.adb, + prj-tree.ads: Minor reformatting. + (Processing_Flags): new record to encapsulate the set of common + parameters to several subprograms in the project manager. + (Prj.Nmsc.Process_Naming_Scheme): renames Check, and moved to body + Remove the need for the Current_Dir parameter in subprograms. + (Look_For_Sources): minor refactoring, now that we no longer need to + share subprograms between the two Ada_Only and Multi_Language modes + (Processing_Flags): New field Error_On_Unknown_Language. + Merge tests for library project between gnatmake and gprbuild. + +2009-07-13 Arnaud Charlet <charlet@adacore.com> + + * lib.adb, make.adb, mlib.adb, exp_dist.adb: Update comments. + Minor reformatting. + +2009-07-13 Emmanuel Briot <briot@adacore.com> + + * prj-env.adb (Create_Config_Pragmas_File): Iterate on sources rather + than units. + +2009-07-13 Thomas Quinot <quinot@adacore.com> + + * sem_ch3.adb (Process_Full_View): Propagate Has_Specified_Stream_{Read, + Write,Input,Output} from private view to full view. + + * sem_type.adb, sem_type.ads: Minor reformatting + +2009-07-13 Nicolas Setton <setton@adacore.com> + + * exp_dbug.ads: Add documentation note on the utility of + DW_AT_GNAT_encoding for IDEs. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * g-socthi-vxworks.adb: Minor reformatting + + * gnatcmd.adb: Minor reformatting + +2009-07-13 Thomas Quinot <quinot@adacore.com> + + * rtsfind.ads, exp_dist.adb (RE_Allocate_Buffer): Runtime entry + removed, not used anymore. + (Exp_Dist.PolyORB_Support.Helpers.Assign_Opaque_From_Any): + New subprogram, implements copy of an Any value into a limited object. + (Exp_Dist.PolyORB_Support.Build_General_Calling_Stubs, + Exp_Dist.PolyORB_Support.Build_Subprogram_Receiving_Stubs, + Exp_Dist.PolyORB_Support.Helpers.Build_From_Any_Function): For the case + of parameters of a limited type, use the above new subprogram. + +2009-07-13 Emmanuel Briot <briot@adacore.com> + + * prj-nmsc.adb, prj-proc.adb, mlib.adb (Add_Source): new parameter + Location. + (Copy_ALI_Files): Avoid calls to read when pointing outside of the + allocated space. + (Error_Report): Remove global variable, replaced by parameters. + +2009-07-13 Thomas Quinot <quinot@adacore.com> + + * g-socthi-vxworks.adb (C_Sendto): VxWorks does not support the + standard sendto(2) interface for connected sockets (passing a null + destination address). Use send(2) instead for that case. + +2009-07-13 Pascal Obry <obry@adacore.com> + + * adaint.c: Fix __gnat_stat() with Win32 UNC paths. + +2009-07-13 Emmanuel Briot <briot@adacore.com> + + * prj-proc.adb, prj-proc.ads, prj.ads, prj-nmsc.adb, prj-nmsc.ads, + prj-pars.adb, prj-conf.adb, prj-conf.ads: Remove all remaining global + variables and tables in prj-nmsc.adb. + (Tree_Processing_Data): Renames Processing_Data, some new fields added + (Project_Processing_Data): New record + Simplify/unify check for missing sources. + +2009-07-13 Emmanuel Briot <briot@adacore.com> + + * gnatcmd.adb, make.adb, mlib-prj.adb, prj-part.adb, mlib.adb, + prj.adb, prj.ads, clean.adb, prj-nmsc.adb, prj-nmsc.ads, prj-pars.adb, + prj-pars.ads, prj-conf.adb, prj-conf.ads, prj-tree.adb, + prj-tree.ads (Immediate_Directory_Of): Removed. + (Prj.Pars): Now parse the project simulating a default config file. + (Add_Default_GNAT_Naming_Scheme): New subprogram + (Check_Naming_Multi_Lang): Fix default value for Dot_Replacement. + Remove gnatmake-specific parsing of source files. + (Check_Illegal_Suffix): Renames Is_Illegal_Suffix, since it now raises + the error itself to provide more precise diagnostics. + (Process_Exceptions_Unit_Based): Avoid duplicate error message when + a unit belongs to several projects. + (Copy_Interface_Sources): Search the full path of files to copy in the + list of sources of the application rather than in the list of units. + (Parse_Project_And_Apply_Config): Do not reset the name of the main + project file. + (Check_File): Use htables to find out whether a source is duplicated. + (Add_Source): check whether the source or unit were already seen earlier + + * gcc-interface/Makefile.in: Update gnatmake dependencies. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * par-ch3.adb (P_Discrete_Choice_List): Choice can only be simple + expression if extensions permitted. + + * par-ch4.adb (P_Membership_Test): New procedure (implement membership + set tests). + (P_Relation): Use P_Membership_Test + + * par.adb (P_Membership_Test): New procedure (implement membership set + tests). + + * sinfo.ads, sinfo.adb (N_In, N_Not_In) Add Alternatives field for sets. + + * sprint.adb (Sprint_Node): Handle set form for membership tests. + +2009-07-13 Thomas Quinot <quinot@adacore.com> + + * exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): + Do not attempt to generate stubs for predefined primitives of + synchronized interfaces. + (Add_Stub_Type): Factor some code from the PCS-specific variants of + Build_Stub_Type. + +2009-07-13 Ed Schonberg <schonberg@adacore.com> + + * sem_disp.adb (Override_Dispatching_Operation): Functions inherit the + Controlling_Result flag from the operation they override. + +2009-07-13 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in: Update dependencies + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: The gnatf switch no longer is needed to get full + details on unsupported constructs. + + * rtsfind.adb: Remove references to All_Errors_Mode, give errors + unconditionally. + + * s-trafor-default.adb: Correct some warnings + + * s-valwch.adb, a-calend.adb, freeze.adb, prj.ads, s-vmexta.adb, + sem.adb, sem_ch10.adb, sem_ch6.adb, sem_disp.adb, vxaddr2line.adb: + Minor reformatting. + + * par-ch4.adb (Conditional_Expression): Capture proper location for + conditional expression, should point to IF. + + * s-tassta.adb, a-wtdeau.adb, s-tasren.adb, s-arit64.adb, s-imgdec.adb, + s-direio.adb, s-tpobop.adb, g-socket.adb, s-tposen.adb, s-taskin.adb, + g-calend.adb, s-regpat.adb, s-scaval.adb, g-catiio.adb: Minor code + reorganization (use conditional expressions). + +2009-07-13 Ed Schonberg <schonberg@adacore.com> + + * exp_util.adb (Remove_Side_Effects): If the expression is a call to a + build-in-place function that returns an inherently limited type (not + just a task type) create proper object declaration so that extra + build-in-place actuals are properly added to the call. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Freeze_Entity): Implement Warn_On_Suspicious_Modulus_Value + + * gnat_ugn.texi: Add documentation for -gnatw.m/.M + + * opt.ads (Warn_On_Suspicious_Modulus_Value): New flag + + * sem_warn.adb (Set_Dot_Warning_Flag): Set/reset + Warn_On_Suspicious_Modulus_Value. + + * ug_words: Add entries for -gnatw.m/-gnatw.M. + + * usage.adb: Add lines for -gnatw.m/.M switches. + + * vms_data.ads: Add [NO]SUSPICIOUS_MODULUS for -gnatw.m/w.M + +2009-07-13 Javier Miranda <miranda@adacore.com> + + * sem_ch6.adb (Check_Synchronized_Overriding): Add missing check before + reading the Is_Interface attribute of the dispatching type. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * a-convec.adb: Minor code reorganization (use conditional expressions) + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Check_Suspicious_Modulus): New procedure. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * i-cobol.ads: Minor code fix (2**4 instead of 16 as modulus to avoid + warning). + + * par-ch4.adb: Minor reformatting + +2009-07-13 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb, freeze.ads, exp_aggr.adb: Rename Expand_Atomic_Aggregate + => Is_Atomic_Aggregate + +2009-07-13 Emmanuel Briot <briot@adacore.com> + + * prj-nmsc.adb: Avoid traversing the list of source files if + we have already processed all locally removed files. + +2009-07-13 Jose Ruiz <ruiz@adacore.com> + + * gnat_ugn.texi: Fix typo. + +2009-07-13 Robert Dewar <dewar@adacore.com> + + * freeze.adb: Minor reformatting + Minor code reorganization (use Nkind_In) + + * exp_ch6.adb, prj.adb, sem_res.adb: Minor reformatting + +2009-07-11 Eric Botcazou <ebotcazou@adacore.com> + + * checks.adb (Apply_Address_Clause_Check): Remove Size_Warning_Output + local variable and do not test it in Compile_Time_Bad_Alignment. + Do not issue size or alignment warnings for the X'Address form. + * sem_util.ads (Find_Overlaid_Object): Delete. + (Find_Overlaid_Entity): New procedure. + * sem_util.adb (Find_Overlaid_Object): Rename to... + (Find_Overlaid_Entity): ...this and turn into a procedure. Report + whether the address is offseted within the overlaid entity. + (Has_Compatible_Alignment): Track the offset globally instead of + passing it to Check_Offset. For an indexed component, compute the + full offset when possible. If the resulting offset is zero, only + check the prefix. + (Check_Offset): Delete. + * sem_ch13.adb (Address_Clause_Check_Record): Add Off field. + (Address_Aliased_Entity): Delete. + (Analyze_Attribute_Definition_Clause) <Attribute_Address>: Call + Find_Overlaid_Entity to find the overlaid entity and the offset. + Adjust throughout for above change. + (Validate_Address_Clauses): Always use attributes of entities, not of + their type. Tweak message for warning. Call Has_Compatible_Alignment + if the address is offseted to warn about incompatible alignments. + * gcc-interface/gigi.h (annotate_object): Declare. + * gcc-interface/decl.c (gnat_to_gnu_entity) <object>: Annotate renaming + entity. Call annotate_object instead of annotating manually objects. + (annotate_object): New function. + * gcc-interface/trans.c (Subprogram_Body_to_gnu): Annotate parameters + at the end. + +2009-07-11 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/ada-tree.h: Minor reorganization. + * gcc-interface/misc.c (gnat_print_decl): Minor tweaks. + (gnat_print_type): Likewise. + +2009-07-11 Thomas Quinot <quinot@adacore.com> + + * sem_util.adb, sem_res.adb, sem_warn.adb: Minor comment editing: + Lvalue -> lvalue + + * exp_ch6.adb: Minor reformatting + +2009-07-11 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Expand_Atomic_Aggregate): Clean up code, take into + account possible type qualification to determine whether aggregate + needs a target temporary to respect atomic type or object. + + * exp_aggr.adb (Expand_Record_Aggregate): Use new version of + Expand_Atomic_Aggregate. + +2009-07-11 Emmanuel Briot <briot@adacore.com> + + * prj.adb, prj.ads, prj-nmsc.adb (Mark_Excluded_Sources): Speed up + algorithm. + (Excluded_Sources_Htable): No longer a global table. + Change error message to indicate which files are illegal in the list + of excluded files, as opposed to only the location in the project + file. + (Find_Source): New subprogram. + +2009-07-10 Thomas Quinot <quinot@adacore.com> + + * exp_ch7.adb: Update comments. + +2009-07-10 Arnaud Charlet <charlet@adacore.com> + + * exp_ch13.adb (Expand_N_Record_Representation_Clause): Ignore mod + clause if -gnatI is set instead of crashing. + +2009-07-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch11.adb (Same_Expression): Null is always equal to itself. + Additional work to remove redundant successive raise statements, in + this case access checks. + +2009-07-10 Vincent Celier <celier@adacore.com> + + * make.adb (Compile): Always create a deep copy of the mapping file + argument (-gnatem=...) as it may be deallocate/reallocate by + Normalize_Arguments. + +2009-07-10 Javier Miranda <miranda@adacore.com> + + * einfo.adb (Directly_Designated_Type): Add assertion. + + * sem_res.adb (Check_Fully_Declared_Prefix): Add missing check on + access types before using attribute Directly_Designated_Type. + +2009-07-10 Emmanuel Briot <briot@adacore.com> + + * prj.ads: Minor typo fix + +2009-07-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Add_Extra_Formal): Protected operations do no need + special treatment. + + * exp_ch6.adb (Expand_Protected_Subprogram_Call): If rewritten + subprogram is a function call, resolve properly, to ensure that extra + actuals are added as needed. + +2009-07-10 Thomas Quinot <quinot@adacore.com> + + * sem_aggr.adb: Minor comments editing + + * exp_tss.adb, exp_ch3.adb: Minor reformatting + +2009-07-10 Robert Dewar <dewar@adacore.com> + + * exp_util.adb: Minor code reorganization (use N_Short_Circuit) + + * exp_ch4.adb: Add ??? comment for conditional expressions on limited + types. + + * checks.adb (In_Declarative_Region_Of_Subprogram_Body): New procedure, + replaces Safe_To_Capture_In_Parameter_Value, and properly handles the + case of conditional expressions that may not be elaborated. + + * sem_util.adb (Safe_To_Capture_Value): Properly handle case of + conditional expression where we may not execute then then or else + branches. + +2009-07-10 Arnaud Charlet <charlet@adacore.com> + + * i-cexten.ads (bool): New type. + +2009-07-10 Robert Dewar <dewar@adacore.com> + + * sinfo.ads (N_Short_Circuit): New definition + + * sem_ch13.adb, sem_ch6.adb, sem_eval.adb, sem_res.adb, + treepr.adb: Minor code reorganization (use N_Short_Circuit) + +2009-07-10 Javier Miranda <miranda@adacore.com> + + * exp_ch3.adb (Expand_Freeze_Record_Type): Handle constructors of + non-tagged record types. + + * sem_prag.adb + (Process_Import_Or_Interface): Allow the use of "pragma Import (CPP,..)" + with non-tagged types. Required to import C++ classes that have no + virtual primitives. + (Analyze_Pragma): For pragma CPP_Constructor. Allow the use of functions + returning non-tagged types. For backward compatibility, if the + constructor returns a class wide type we internally change the + returned type to the corresponding non class-wide type. + + * sem_aggr.adb + (Valid_Ancestor_Type): CPP_Constructors code cleanup. + (Resolve_Extension_Aggregate): CPP_Constructors code cleanup. + (Resolve_Aggr_Expr): CPP_Constructors code cleanup. + (Resolve_Record_Aggregate): CPP_Constructors code cleanup. + + * sem_ch3.adb + (Analyze_Object_Declaration): CPP_Constructors code cleanup. + + * sem_ch5.adb (Analyze_Assignment): CPP_Constructors code cleanup. + + * sem_util.adb (Is_CPP_Constructor_Call): Code cleanup. + + * sem_res.adb (Resolve_Allocator): CPP_Constructors code cleanup. + + * exp_ch4.adb (Expand_Allocator_Expression): CPP_Constructors code + cleanup. + + * exp_aggr.adb (Build_Record_Aggr_Code): CPP_Constructors code clean up. + + * gnat_rm.texi + (pragma CPP_Class): Document that it can be used now with non-tagged + record types. + (pragma CPP_Constructor): Document that it can be used now with + functions returning specific types. For backward compatibility + we also support functions returning class-wide types. + + * gnat_ugn.texi + (Interfacing with C++ constructors): Update the examples to incorporate + the new syntax in which the functions used to import C++ constructors + return specific types. + (Interfacing with C++ at the Class Level): Update the examples to + incorporate the new syntax in which the functions used to import + C++ constructors return specific types. + +2009-07-10 Thomas Quinot <quinot@adacore.com> + + * exp_disp.adb (Make_Disp_Asynchronous_Select_Body, + Make_Disp_Conditional_Select_Body, + Make_Disp_Timed_Select_Body): For the case of a type that is neither an + interface nor a concurrent type, the primitive body is empty. Generate + a null statement so that it remains well formed. + +2009-07-10 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Build_Record_Aggr_Code): If the type has discriminants, + replace references to them in defaulted component expressions with + references to the values of the discriminants of the target object. + +2009-07-10 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Analyze pragma, case Task_Name): Analyze argument of + pragma, to capture global references if the context is generic. + + * exp_ch2.adb (Expand_Discriminant): If a task type discriminant + appears within the initialization procedure for the corresponding + record, replace it with the proper discriminal. + +2009-07-10 Vincent Celier <celier@adacore.com> + + * make.adb: Do not include object directories or library ALI + directories of library projects in the object path. + +2009-07-10 Javier Miranda <miranda@adacore.com> + + * exp_util.adb (Find_Interface_Tag): Reorder processing of incoming + Typ argument to ensure proper management of access types. + +2009-07-10 Ed Schonberg <schonberg@adacore.com> + + * exp_ch7.adb (Build_Final_List): If the list is being built for a + Taft-Amendment type, place the finalization list in the package body, + to ensure that the tree for the spec is identical whenever it is + compiled. + +2009-07-10 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Build_Derived_Record_Type): Use the full-view when + inheriting attributes from a private Parent_Base. + +2009-07-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch11.adb (analyze_raise_xxx_error): Remove consecutive raise + statements with the same condition. + +2009-07-10 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb (Raise_Accessibility_Error): New procedure + +2009-07-09 Tom Tromey <tromey@redhat.com> + + * raise-gcc.c: Include dwarf2h (unconditionally). + 2009-07-09 Ed Schonberg <schonberg@adacore.com> * sem_ch10.adb (Install_Context): If the unit is a package body, @@ -38,7 +758,7 @@ * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Address): Do not warn for a constant overlaying any constant object -2009-06-25 Arnaud Charlet <charlet@adacore.com> +2009-07-09 Arnaud Charlet <charlet@adacore.com> * gcc-interface/Make-lang.in: Update dependencies diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb index 04ea98b1884..05c327db3b3 100644 --- a/gcc/ada/a-calend.adb +++ b/gcc/ada/a-calend.adb @@ -1357,8 +1357,8 @@ package body Ada.Calendar is Res_N := Res_N + Duration_To_Time_Rep (Day_Secs); else - Res_N := Res_N + - Time_Rep (Hour * 3_600 + Minute * 60 + Second) * Nano; + Res_N := + Res_N + Time_Rep (Hour * 3_600 + Minute * 60 + Second) * Nano; if Sub_Sec = 1.0 then Res_N := Res_N + Time_Rep (1) * Nano; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 6618e779478..b876e8ee971 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -485,11 +485,10 @@ package body Ada.Containers.Vectors is Index := Int'Base (Container.Last) - Int'Base (Count); - if Index < Index_Type'Pos (Index_Type'First) then - Container.Last := No_Index; - else - Container.Last := Index_Type (Index); - end if; + Container.Last := + (if Index < Index_Type'Pos (Index_Type'First) + then No_Index + else Index_Type (Index)); end Delete_Last; ------------- @@ -881,7 +880,6 @@ package body Ada.Containers.Vectors is and then Index_Type'Last >= 0 then CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; - else CC := UInt (Int (Index_Type'Last) - First + 1); end if; @@ -1325,7 +1323,6 @@ package body Ada.Containers.Vectors is and then Index_Type'Last >= 0 then CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; - else CC := UInt (Int (Index_Type'Last) - First + 1); end if; @@ -1953,13 +1950,10 @@ package body Ada.Containers.Vectors is raise Program_Error with "Position cursor denotes wrong container"; end if; - if Position.Container = null - or else Position.Index > Container.Last - then - Last := Container.Last; - else - Last := Position.Index; - end if; + Last := + (if Position.Container = null or else Position.Index > Container.Last + then Container.Last + else Position.Index); for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then @@ -1979,15 +1973,10 @@ package body Ada.Containers.Vectors is Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index is - Last : Index_Type'Base; + Last : constant Index_Type'Base := + Index_Type'Min (Container.Last, Index); begin - if Index > Container.Last then - Last := Container.Last; - else - Last := Index; - end if; - for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then return Indx; diff --git a/gcc/ada/a-wtdeau.adb b/gcc/ada/a-wtdeau.adb index 48bb16cd3b2..78b10299b2c 100644 --- a/gcc/ada/a-wtdeau.adb +++ b/gcc/ada/a-wtdeau.adb @@ -244,11 +244,10 @@ package body Ada.Wide_Text_IO.Decimal_Aux is Ptr : Natural := 0; begin - if Exp = 0 then - Fore := To'Length - 1 - Aft; - else - Fore := To'Length - 2 - Aft - Exp; - end if; + Fore := + (if Exp = 0 + then To'Length - 1 - Aft + else To'Length - 2 - Aft - Exp); if Fore < 1 then raise Layout_Error; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index fd7b1b31ff9..7452f626a5d 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -188,6 +188,7 @@ struct vstring #endif #if defined (_WIN32) + #include <dir.h> #include <windows.h> #include <accctrl.h> @@ -1655,10 +1656,14 @@ __gnat_stat (char *name, STRUCT_STAT *statbuf) { #ifdef __MINGW32__ /* Under Windows the directory name for the stat function must not be - terminated by a directory separator except if just after a drive name. */ + terminated by a directory separator except if just after a drive name + or with UNC path without directory (only the name of the shared + resource), for example: \\computer\share\ */ + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; - int name_len; + int name_len, k; TCHAR last_char; + int dirsep_count = 0; S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); name_len = _tcslen (wname); @@ -1675,9 +1680,17 @@ __gnat_stat (char *name, STRUCT_STAT *statbuf) last_char = wname[name_len - 1]; } + /* Count back-slashes. */ + + for (k=0; k<name_len; k++) + if (wname[k] == _T('\\') || wname[k] == _T('/')) + dirsep_count++; + /* Only a drive letter followed by ':', we must add a directory separator for the stat routine to work properly. */ - if (name_len == 2 && wname[1] == _T(':')) + if ((name_len == 2 && wname[1] == _T(':')) + || (name_len > 3 && wname[0] == _T('\\') && wname[1] == _T('\\') + && dirsep_count == 3)) _tcscat (wname, _T("\\")); return _tstat (wname, (struct _stat *)statbuf); @@ -1897,9 +1910,9 @@ __gnat_set_OWNER_ACL DWORD AccessMode, DWORD AccessPermissions) { - ACL* pOldDACL = NULL; - ACL* pNewDACL = NULL; - SECURITY_DESCRIPTOR* pSD = NULL; + PACL pOldDACL = NULL; + PACL pNewDACL = NULL; + PSECURITY_DESCRIPTOR pSD = NULL; EXPLICIT_ACCESS ea; TCHAR username [100]; DWORD unsize = 100; @@ -2304,70 +2317,58 @@ extern void (*Unlock_Task) (void); #endif -typedef struct _process_list -{ - HANDLE h; - struct _process_list *next; -} Process_List; - -static Process_List *PLIST = NULL; - -static int plist_length = 0; +static HANDLE *HANDLES_LIST = NULL; +static int *PID_LIST = NULL, plist_length = 0, plist_max_length = 0; static void add_handle (HANDLE h) { - Process_List *pl; - - pl = (Process_List *) xmalloc (sizeof (Process_List)); /* -------------------- critical section -------------------- */ (*Lock_Task) (); - pl->h = h; - pl->next = PLIST; - PLIST = pl; + if (plist_length == plist_max_length) + { + plist_max_length += 1000; + HANDLES_LIST = + xrealloc (HANDLES_LIST, sizeof (HANDLE) * plist_max_length); + PID_LIST = + xrealloc (PID_LIST, sizeof (int) * plist_max_length); + } + + HANDLES_LIST[plist_length] = h; + PID_LIST[plist_length] = GetProcessId (h); ++plist_length; (*Unlock_Task) (); /* -------------------- critical section -------------------- */ } -static void -remove_handle (HANDLE h) +void +__gnat_win32_remove_handle (HANDLE h, int pid) { - Process_List *pl; - Process_List *prev = NULL; + int j; /* -------------------- critical section -------------------- */ (*Lock_Task) (); - pl = PLIST; - while (pl) + for (j = 0; j < plist_length; j++) { - if (pl->h == h) + if ((HANDLES_LIST[j] == h) || (PID_LIST[j] == pid)) { - if (pl == PLIST) - PLIST = pl->next; - else - prev->next = pl->next; - free (pl); + CloseHandle (h); + --plist_length; + HANDLES_LIST[j] = HANDLES_LIST[plist_length]; + PID_LIST[j] = PID_LIST[plist_length]; break; } - else - { - prev = pl; - pl = pl->next; - } } - --plist_length; - (*Unlock_Task) (); /* -------------------- critical section -------------------- */ } -static int +static HANDLE win32_no_block_spawn (char *command, char *args[]) { BOOL result; @@ -2432,23 +2433,21 @@ win32_no_block_spawn (char *command, char *args[]) if (result == TRUE) { - add_handle (PI.hProcess); CloseHandle (PI.hThread); - return (int) PI.hProcess; + return PI.hProcess; } else - return -1; + return NULL; } static int win32_wait (int *status) { - DWORD exitcode; + DWORD exitcode, pid; HANDLE *hl; HANDLE h; DWORD res; int k; - Process_List *pl; int hl_len; if (plist_length == 0) @@ -2466,27 +2465,22 @@ win32_wait (int *status) hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len); - pl = PLIST; - while (pl) - { - hl[k++] = pl->h; - pl = pl->next; - } + memmove (hl, HANDLES_LIST, sizeof (HANDLE) * hl_len); (*Unlock_Task) (); /* -------------------- critical section -------------------- */ res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE); h = hl[res - WAIT_OBJECT_0]; - free (hl); - - remove_handle (h); GetExitCodeProcess (h, &exitcode); - CloseHandle (h); + pid = GetProcessId (h); + __gnat_win32_remove_handle (h, -1); + + free (hl); *status = (int) exitcode; - return (int) h; + return (int) pid; } #endif @@ -2494,7 +2488,6 @@ win32_wait (int *status) int __gnat_portable_no_block_spawn (char *args[]) { - int pid = 0; #if defined (__vxworks) || defined (__nucleus__) || defined (RTX) return -1; @@ -2514,11 +2507,20 @@ __gnat_portable_no_block_spawn (char *args[]) #elif defined (_WIN32) - pid = win32_no_block_spawn (args[0], args); - return pid; + HANDLE h = NULL; + + h = win32_no_block_spawn (args[0], args); + if (h != NULL) + { + add_handle (h); + return GetProcessId (h); + } + else + return -1; #else - pid = fork (); + + int pid = fork (); if (pid == 0) { @@ -2531,9 +2533,9 @@ __gnat_portable_no_block_spawn (char *args[]) #endif } -#endif - return pid; + + #endif } int @@ -3244,7 +3246,8 @@ __gnat_to_canonical_file_list_init char * __gnat_to_canonical_file_list_next (void) { - return (char *) ""; + static char *empty = ""; + return empty; } void diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index e8fb40bc4a9..57cedf87350 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -199,8 +199,11 @@ extern void __gnat_os_filename (char *, char *, char *, extern void *__gnat_lwp_self (void); #endif -#if defined (__MINGW32__) && !defined (RTX) -extern void __gnat_plist_init (void); +#if defined (_WIN32) +/* Interface to delete a handle from internally maintained list of child + process handles on Windows */ +extern void +__gnat_win32_remove_handle (HANDLE h, int pid); #endif #ifdef IN_RTS diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 79f2ffda5b5..b22732668a5 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -1227,6 +1227,21 @@ package body Atree is return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8); end Nkind_In; + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind; + V9 : Node_Kind) return Boolean + is + begin + return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9); + end Nkind_In; -------- -- No -- -------- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index ae6a1ac7588..da0b28874c6 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -602,6 +602,18 @@ package Atree is V7 : Node_Kind; V8 : Node_Kind) return Boolean; + function Nkind_In + (N : Node_Id; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind; + V9 : Node_Kind) return Boolean; + pragma Inline (Nkind_In); -- Inline all above functions diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 28131e58fe3..015256e9dad 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -532,16 +532,11 @@ package body Checks is -- when Aexp is a reference to a constant, in which case Expr gets -- reset to reference the value expression of the constant. - Size_Warning_Output : Boolean := False; - -- If we output a size warning we set this True, to stop generating - -- what is likely to be an unuseful redundant alignment warning. - procedure Compile_Time_Bad_Alignment; -- Post error warnings when alignment is known to be incompatible. Note -- that we do not go as far as inserting a raise of Program_Error since -- this is an erroneous case, and it may happen that we are lucky and an - -- underaligned address turns out to be OK after all. Also this warning - -- is suppressed if we already complained about the size. + -- underaligned address turns out to be OK after all. -------------------------------- -- Compile_Time_Bad_Alignment -- @@ -549,9 +544,7 @@ package body Checks is procedure Compile_Time_Bad_Alignment is begin - if not Size_Warning_Output - and then Address_Clause_Overlay_Warnings - then + if Address_Clause_Overlay_Warnings then Error_Msg_FE ("?specified address for& may be inconsistent with alignment ", Aexp, E); @@ -565,7 +558,24 @@ package body Checks is -- Start of processing for Apply_Address_Clause_Check begin - -- First obtain expression from address clause + -- See if alignment check needed. Note that we never need a check if the + -- maximum alignment is one, since the check will always succeed. + + -- Note: we do not check for checks suppressed here, since that check + -- was done in Sem_Ch13 when the address clause was processed. We are + -- only called if checks were not suppressed. The reason for this is + -- that we have to delay the call to Apply_Alignment_Check till freeze + -- time (so that all types etc are elaborated), but we have to check + -- the status of check suppressing at the point of the address clause. + + if No (AC) + or else not Check_Address_Alignment (AC) + or else Maximum_Alignment = 1 + then + return; + end if; + + -- Obtain expression from address clause Expr := Expression (AC); @@ -603,69 +613,7 @@ package body Checks is end if; end loop; - -- Output a warning if we have the situation of - - -- for X'Address use Y'Address - - -- and X and Y both have known object sizes, and Y is smaller than X - - if Nkind (Expr) = N_Attribute_Reference - and then Attribute_Name (Expr) = Name_Address - and then Is_Entity_Name (Prefix (Expr)) - then - declare - Exp_Ent : constant Entity_Id := Entity (Prefix (Expr)); - Obj_Size : Uint := No_Uint; - Exp_Size : Uint := No_Uint; - - begin - if Known_Esize (E) then - Obj_Size := Esize (E); - elsif Known_Esize (Etype (E)) then - Obj_Size := Esize (Etype (E)); - end if; - - if Known_Esize (Exp_Ent) then - Exp_Size := Esize (Exp_Ent); - elsif Known_Esize (Etype (Exp_Ent)) then - Exp_Size := Esize (Etype (Exp_Ent)); - end if; - - if Obj_Size /= No_Uint - and then Exp_Size /= No_Uint - and then Obj_Size > Exp_Size - and then not Has_Warnings_Off (E) - then - if Address_Clause_Overlay_Warnings then - Error_Msg_FE - ("?& overlays smaller object", Aexp, E); - Error_Msg_FE - ("\?program execution may be erroneous", Aexp, E); - Size_Warning_Output := True; - Set_Address_Warning_Posted (AC); - end if; - end if; - end; - end if; - - -- See if alignment check needed. Note that we never need a check if the - -- maximum alignment is one, since the check will always succeed. - - -- Note: we do not check for checks suppressed here, since that check - -- was done in Sem_Ch13 when the address clause was processed. We are - -- only called if checks were not suppressed. The reason for this is - -- that we have to delay the call to Apply_Alignment_Check till freeze - -- time (so that all types etc are elaborated), but we have to check - -- the status of check suppressing at the point of the address clause. - - if No (AC) - or else not Check_Address_Alignment (AC) - or else Maximum_Alignment = 1 - then - return; - end if; - - -- See if we know that Expr is a bad alignment at compile time + -- See if we know that Expr has a bad alignment at compile time if Compile_Time_Known_Value (Expr) and then (Known_Alignment (E) or else Known_Alignment (Typ)) @@ -690,20 +638,14 @@ package body Checks is -- If the expression has the form X'Address, then we can find out if -- the object X has an alignment that is compatible with the object E. + -- If it hasn't or we don't know, we defer issuing the warning until + -- the end of the compilation to take into account back end annotations. elsif Nkind (Expr) = N_Attribute_Reference and then Attribute_Name (Expr) = Name_Address + and then Has_Compatible_Alignment (E, Prefix (Expr)) = Known_Compatible then - declare - AR : constant Alignment_Result := - Has_Compatible_Alignment (E, Prefix (Expr)); - begin - if AR = Known_Compatible then - return; - elsif AR = Known_Incompatible then - Compile_Time_Bad_Alignment; - end if; - end; + return; end if; -- Here we do not know if the value is acceptable. Stricly we don't have @@ -5253,31 +5195,31 @@ package body Checks is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); - function In_Declarative_Region_Of_Subprogram_Body return Boolean; - -- Determine whether node N, a reference to an *in* parameter, is - -- inside the declarative region of the current subprogram body. + function Safe_To_Capture_In_Parameter_Value return Boolean; + -- Determines if it is safe to capture Known_Non_Null status for an + -- the entity referenced by node N. The caller ensures that N is indeed + -- an entity name. It is safe to capture the non-null status for an IN + -- parameter when the reference occurs within a declaration that is sure + -- to be executed as part of the declarative region. procedure Mark_Non_Null; -- After installation of check, if the node in question is an entity -- name, then mark this entity as non-null if possible. - ---------------------------------------------- - -- In_Declarative_Region_Of_Subprogram_Body -- - ---------------------------------------------- - - function In_Declarative_Region_Of_Subprogram_Body return Boolean is + function Safe_To_Capture_In_Parameter_Value return Boolean is E : constant Entity_Id := Entity (N); S : constant Entity_Id := Current_Scope; S_Par : Node_Id; begin - pragma Assert (Ekind (E) = E_In_Parameter); + if Ekind (E) /= E_In_Parameter then + return False; + end if; -- Two initial context checks. We must be inside a subprogram body -- with declarations and reference must not appear in nested scopes. - if (Ekind (S) /= E_Function - and then Ekind (S) /= E_Procedure) + if (Ekind (S) /= E_Function and then Ekind (S) /= E_Procedure) or else Scope (E) /= S then return False; @@ -5303,6 +5245,26 @@ package body Checks is N_Decl := Empty; while Present (P) loop + -- If we have a short circuit form, and we are within the right + -- hand expression, we return false, since the right hand side + -- is not guaranteed to be elaborated. + + if Nkind (P) in N_Short_Circuit + and then N = Right_Opnd (P) + then + return False; + end if; + + -- Similarly, if we are in a conditional expression and not + -- part of the condition, then we return False, since neither + -- the THEN or ELSE expressions will always be elaborated. + + if Nkind (P) = N_Conditional_Expression + and then N /= First (Expressions (P)) + then + return False; + end if; + -- While traversing the parent chain, we find that N -- belongs to a statement, thus it may never appear in -- a declarative region. @@ -5313,6 +5275,8 @@ package body Checks is return False; end if; + -- If we are at a declaration, record it and exit + if Nkind (P) in N_Declaration and then Nkind (P) not in N_Subprogram_Specification then @@ -5329,7 +5293,7 @@ package body Checks is return List_Containing (N_Decl) = Declarations (S_Par); end; - end In_Declarative_Region_Of_Subprogram_Body; + end Safe_To_Capture_In_Parameter_Value; ------------------- -- Mark_Non_Null -- @@ -5350,13 +5314,14 @@ package body Checks is -- safe to capture the value, or in the case of an IN parameter, -- which is a constant, if the check we just installed is in the -- declarative region of the subprogram body. In this latter case, - -- a check is decisive for the rest of the body, since we know we - -- must complete all declarations before executing the body. + -- a check is decisive for the rest of the body if the expression + -- is sure to be elaborated, since we know we have to elaborate + -- all declarations before executing the body. + + -- Couldn't this always be part of Safe_To_Capture_Value ??? if Safe_To_Capture_Value (N, Entity (N)) - or else - (Ekind (Entity (N)) = E_In_Parameter - and then In_Declarative_Region_Of_Subprogram_Body) + or else Safe_To_Capture_In_Parameter_Value then Set_Is_Known_Non_Null (Entity (N)); end if; @@ -6679,27 +6644,65 @@ package body Checks is declare T_LB : constant Node_Id := Type_Low_Bound (T_Typ); T_HB : constant Node_Id := Type_High_Bound (T_Typ); - LB : constant Node_Id := Low_Bound (Ck_Node); - HB : constant Node_Id := High_Bound (Ck_Node); - Null_Range : Boolean; + Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB); + Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB); + + LB : Node_Id := Low_Bound (Ck_Node); + HB : Node_Id := High_Bound (Ck_Node); + Known_LB : Boolean; + Known_HB : Boolean; + Null_Range : Boolean; Out_Of_Range_L : Boolean; Out_Of_Range_H : Boolean; begin - -- Check for case where everything is static and we can - -- do the check at compile time. This is skipped if we - -- have an access type, since the access value may be null. - - -- ??? This code can be improved since you only need to know - -- that the two respective bounds (LB & T_LB or HB & T_HB) - -- are known at compile time to emit pertinent messages. - - if Compile_Time_Known_Value (LB) - and then Compile_Time_Known_Value (HB) - and then Compile_Time_Known_Value (T_LB) - and then Compile_Time_Known_Value (T_HB) - and then not Do_Access + -- Compute what is known at compile time + + if Known_T_LB and Known_T_HB then + if Compile_Time_Known_Value (LB) then + Known_LB := True; + + -- There's no point in checking that a bound is within its + -- own range so pretend that it is known in this case. First + -- deal with low bound. + + elsif Ekind (Etype (LB)) = E_Signed_Integer_Subtype + and then Scalar_Range (Etype (LB)) = Scalar_Range (T_Typ) + then + LB := T_LB; + Known_LB := True; + + else + Known_LB := False; + end if; + + -- Likewise for the high bound + + if Compile_Time_Known_Value (HB) then + Known_HB := True; + + elsif Ekind (Etype (HB)) = E_Signed_Integer_Subtype + and then Scalar_Range (Etype (HB)) = Scalar_Range (T_Typ) + then + HB := T_HB; + Known_HB := True; + + else + Known_HB := False; + end if; + end if; + + -- Check for case where everything is static and we can do the + -- check at compile time. This is skipped if we have an access + -- type, since the access value may be null. + + -- ??? This code can be improved since you only need to know that + -- the two respective bounds (LB & T_LB or HB & T_HB) are known at + -- compile time to emit pertinent messages. + + if Known_T_LB and Known_T_HB and Known_LB and Known_HB + and not Do_Access then -- Floating-point case @@ -6707,12 +6710,12 @@ package body Checks is Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB); Out_Of_Range_L := (Expr_Value_R (LB) < Expr_Value_R (T_LB)) - or else + or else (Expr_Value_R (LB) > Expr_Value_R (T_HB)); Out_Of_Range_H := (Expr_Value_R (HB) > Expr_Value_R (T_HB)) - or else + or else (Expr_Value_R (HB) < Expr_Value_R (T_LB)); -- Fixed or discrete type case @@ -6721,12 +6724,12 @@ package body Checks is Null_Range := Expr_Value (HB) < Expr_Value (LB); Out_Of_Range_L := (Expr_Value (LB) < Expr_Value (T_LB)) - or else + or else (Expr_Value (LB) > Expr_Value (T_HB)); Out_Of_Range_H := (Expr_Value (HB) > Expr_Value (T_HB)) - or else + or else (Expr_Value (HB) < Expr_Value (T_LB)); end if; @@ -6760,7 +6763,6 @@ package body Checks is "static range out of bounds of}?", T_Typ)); end if; end if; - end if; else @@ -6862,15 +6864,17 @@ package body Checks is or else (Expr_Value_R (Ck_Node) > Expr_Value_R (UB)); - else -- fixed or discrete type + -- Fixed or discrete type + + else Out_Of_Range := Expr_Value (Ck_Node) < Expr_Value (LB) or else Expr_Value (Ck_Node) > Expr_Value (UB); end if; - -- Bounds of the type are static and the literal is - -- out of range so make a warning message. + -- Bounds of the type are static and the literal is out of + -- range so output a warning message. if Out_Of_Range then if No (Warn_Node) then @@ -6971,7 +6975,6 @@ package body Checks is Next (L_Index); Next (R_Index); - end if; end loop; end; @@ -6998,7 +7001,6 @@ package body Checks is (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx)); end loop; end; - end if; else @@ -7094,8 +7096,8 @@ package body Checks is Add_Check (Make_Raise_Constraint_Error (Loc, - Condition => Cond, - Reason => CE_Range_Check_Failed)); + Condition => Cond, + Reason => CE_Range_Check_Failed)); end if; return Ret_Result; diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index e909cae2527..790b8423529 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -1044,7 +1044,19 @@ package body Clean is begin Proj := Project_Tree.Projects; while Proj /= null loop - if Has_Foreign_Sources (Proj.Project) then + + -- For gnatmake, when the project specifies more than + -- just Ada as a language (even if course we could not + -- find any source file for the other languages), we + -- will take all the object files found in the object + -- directories. Since we know the project supports at + -- least Ada, we just have to test whether it has at + -- least two languages, and we do not care about the + -- sources. + + if Proj.Project.Languages /= null + and then Proj.Project.Languages.Next /= null + then Global_Archive := True; exit; end if; @@ -1391,8 +1403,8 @@ package body Clean is (Project => Main_Project, In_Tree => Project_Tree, Project_File_Name => Project_File_Name.all, - Packages_To_Check => Packages_To_Check_By_Gnatmake, - Is_Config_File => False); + Flags => Gnatmake_Flags, + Packages_To_Check => Packages_To_Check_By_Gnatmake); if Main_Project = No_Project then Fail ("""" & Project_File_Name.all & """ processing failed"); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index b28293a2946..f038f233599 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -808,6 +808,7 @@ package body Einfo is function Directly_Designated_Type (Id : E) return E is begin + pragma Assert (Is_Access_Type (Id)); return Node20 (Id); end Directly_Designated_Type; diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index 28c0140aa6f..28db086274c 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1991-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/errutil.ads b/gcc/ada/errutil.ads index 440f69b3bd8..91ac4f1083b 100644 --- a/gcc/ada/errutil.ads +++ b/gcc/ada/errutil.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index db9e1d7784c..11174614df1 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -2379,11 +2379,34 @@ package body Exp_Aggr is end if; end Gen_Ctrl_Actions_For_Aggr; + function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result; + -- If default expression of a component mentions a discriminant of the + -- type, it must be rewritten as the discriminant of the target object. + function Replace_Type (Expr : Node_Id) return Traverse_Result; -- If the aggregate contains a self-reference, traverse each expression -- to replace a possible self-reference with a reference to the proper -- component of the target of the assignment. + -------------------------- + -- Rewrite_Discriminant -- + -------------------------- + + function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is + begin + if Nkind (Expr) = N_Identifier + and then Present (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_In_Parameter + and then Present (Discriminal_Link (Entity (Expr))) + then + Rewrite (Expr, + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Obj, Loc), + Selector_Name => Make_Identifier (Loc, Chars (Expr)))); + end if; + return OK; + end Rewrite_Discriminant; + ------------------ -- Replace_Type -- ------------------ @@ -2430,6 +2453,9 @@ package body Exp_Aggr is procedure Replace_Self_Reference is new Traverse_Proc (Replace_Type); + procedure Replace_Discriminants is + new Traverse_Proc (Rewrite_Discriminant); + -- Start of processing for Build_Record_Aggr_Code begin @@ -2538,7 +2564,7 @@ package body Exp_Aggr is -- Handle calls to C++ constructors elsif Is_CPP_Constructor_Call (A) then - Init_Typ := Etype (Etype (A)); + Init_Typ := Etype (A); Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); Set_Assignment_OK (Ref); @@ -2970,13 +2996,11 @@ package body Exp_Aggr is -- will be used to capture the aggregate assignments. TmpE : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + Make_Temporary (Loc, New_Internal_Name ('A'), N); TmpD : constant Node_Id := Make_Object_Declaration (Loc, - Defining_Identifier => - TmpE, + Defining_Identifier => TmpE, Object_Definition => New_Reference_To (SubE, Loc)); @@ -3019,10 +3043,14 @@ package body Exp_Aggr is -- Expr_Q is not delayed aggregate else + if Has_Discriminants (Typ) then + Replace_Discriminants (Expr_Q); + end if; + Instr := Make_OK_Assignment_Statement (Loc, Name => Comp_Expr, - Expression => Expression (Comp)); + Expression => Expr_Q); Set_No_Ctrl_Actions (Instr); Append_To (L, Instr); @@ -3558,7 +3586,7 @@ package body Exp_Aggr is Rewrite (Parent (N), Make_Null_Statement (Loc)); else - Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Temp := Make_Temporary (Loc, New_Internal_Name ('A'), N); -- If the type inherits unknown discriminants, use the view with -- known discriminants if available. @@ -5173,7 +5201,7 @@ package body Exp_Aggr is else Maybe_In_Place_OK := False; - Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Tmp := Make_Temporary (Loc, New_Internal_Name ('A'), N); Tmp_Decl := Make_Object_Declaration (Loc, @@ -5445,11 +5473,9 @@ package body Exp_Aggr is -- an atomic move for it. if Is_Atomic (Typ) - and then Nkind_In (Parent (N), N_Object_Declaration, - N_Assignment_Statement) and then Comes_From_Source (Parent (N)) + and then Is_Atomic_Aggregate (N, Typ) then - Expand_Atomic_Aggregate (N, Typ); return; -- No special management required for aggregates used to initialize diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index c22598582ca..2df553c4585 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -593,6 +593,14 @@ package body Exp_Attr is end if; end if; + -- The stream operation to call maybe a renaming created by + -- an attribute definition clause, and may not be frozen yet. + -- Ensure that it has the necessary extra formals. + + if not Is_Frozen (Pname) then + Create_Extra_Formals (Pname); + end if; + -- And now rewrite the call Rewrite (N, diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 7d903eb6fed..3b682cf04ae 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -396,7 +396,7 @@ package body Exp_Ch13 is AtM_Nod : Node_Id; begin - if Present (Mod_Clause (N)) then + if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then Mod_Val := Expr_Value (Expression (Mod_Clause (N))); Citems := Pragmas_Before (Mod_Clause (N)); diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 2963ae87246..47b17487b29 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -308,6 +308,17 @@ package body Exp_Ch2 is and then In_Entry then Set_Entity (N, CR_Discriminant (Entity (N))); + + -- Finally, if the entity is the discriminant of the original + -- type declaration, and we are within the initialization + -- procedure for a task, the designated entity is the + -- discriminal of the task body. This can happen when the + -- argument of pragma Task_Name mentions a discriminant, + -- because the pragma is analyzed in the task declaration + -- but is expanded in the call to Create_Task in the init_proc. + + elsif Within_Init_Proc then + Set_Entity (N, Discriminal (CR_Discriminant (Entity (N)))); else Set_Entity (N, Discriminal (Entity (N))); end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 8cacbeb880e..92bcc03bdab 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2622,13 +2622,15 @@ package body Exp_Ch3 is Stmts := Build_Initialization_Call (Loc, - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => New_Occurrence_Of (Id, Loc)), - Typ, - In_Init_Proc => True, - Enclos_Type => Rec_Type, - Discr_Map => Discr_Map, + Id_Ref => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ => Typ, + In_Init_Proc => True, + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map, Constructor_Ref => Expression (Decl)); else Stmts := Build_Assignment (Id, Expression (Decl)); @@ -2642,13 +2644,14 @@ package body Exp_Ch3 is Stmts := Build_Initialization_Call (Loc, - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => New_Occurrence_Of (Id, Loc)), - Typ, + Id_Ref => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => New_Occurrence_Of (Id, Loc)), + Typ => Typ, In_Init_Proc => True, - Enclos_Type => Rec_Type, - Discr_Map => Discr_Map); + Enclos_Type => Rec_Type, + Discr_Map => Discr_Map); Clean_Task_Names (Typ, Proc_Id); @@ -4494,6 +4497,196 @@ 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. + + elsif Comes_From_Source (N) + and then Is_Interface (Typ) + then + pragma Assert (Is_Class_Wide_Type (Typ)); + + if Tagged_Type_Expansion then + declare + Iface : constant Entity_Id := Root_Type (Typ); + Expr_N : Node_Id := Expr; + Expr_Typ : Entity_Id; + + Decl_1 : Node_Id; + Decl_2 : Node_Id; + New_Expr : Node_Id; + + begin + -- If the original node of the expression was a conversion + -- to this specific class-wide interface type then we + -- restore the original node to generate code that + -- statically displaces the pointer to the interface + -- component. + + if not Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Unchecked_Type_Conversion + and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion + and then Etype (Original_Node (Expr_N)) = Typ + then + Rewrite (Expr_N, Original_Node (Expression (N))); + end if; + + -- Avoid expansion of redundant interface conversion + + if Is_Interface (Etype (Expr_N)) + and then Nkind (Expr_N) = N_Type_Conversion + and then Etype (Expr_N) = Typ + then + Expr_N := Expression (Expr_N); + Set_Expression (N, Expr_N); + end if; + + Expr_Typ := Base_Type (Etype (Expr_N)); + + if Is_Class_Wide_Type (Expr_Typ) then + Expr_Typ := Root_Type (Expr_Typ); + end if; + + -- Replace + -- CW : I'Class := Obj; + -- by + -- Tmp : T := Obj; + -- CW : I'Class renames TiC!(Tmp.I_Tag); + + if Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Identifier + and then not Is_Interface (Expr_Typ) + and then (Expr_Typ = Etype (Expr_Typ) + or else not + Is_Variable_Size_Record (Etype (Expr_Typ))) + then + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Object_Definition => + New_Occurrence_Of (Expr_Typ, Loc), + Expression => + Unchecked_Convert_To (Expr_Typ, + Relocate_Node (Expr_N))); + + -- Statically reference the tag associated with the + -- interface + + Decl_2 := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Name => + Unchecked_Convert_To (Typ, + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier (Decl_1), Loc), + Selector_Name => + New_Reference_To + (Find_Interface_Tag (Expr_Typ, Iface), + Loc)))); + + -- General case: + + -- Replace + -- IW : I'Class := Obj; + -- by + -- type Equiv_Record is record ... end record; + -- implicit subtype CW is <Class_Wide_Subtype>; + -- Temp : CW := CW!(Obj'Address); + -- IW : I'Class renames Displace (Temp, I'Tag); + + else + -- Generate the equivalent record type + + Expand_Subtype_From_Expr + (N => N, + Unc_Type => Typ, + Subtype_Indic => Object_Definition (N), + Exp => Expression (N)); + + if not Is_Interface (Etype (Expression (N))) then + New_Expr := Relocate_Node (Expression (N)); + else + New_Expr := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Expression (N)), + Attribute_Name => Name_Address))); + end if; + + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Object_Definition => + New_Occurrence_Of + (Etype (Object_Definition (N)), Loc), + Expression => + Unchecked_Convert_To + (Etype (Object_Definition (N)), New_Expr)); + + Decl_2 := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Name => + Unchecked_Convert_To (Typ, + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier (Decl_1), Loc), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Iface))), + Loc)))))))); + end if; + + Insert_Action (N, Decl_1); + Rewrite (N, Decl_2); + Analyze (N); + + -- Replace internal identifier of Decl_2 by the identifier + -- found in the sources. We also have to exchange entities + -- containing their defining identifiers to ensure the + -- correct replacement of the object declaration by this + -- object renaming declaration (because such definings + -- identifier have been previously added by Enter_Name to + -- the current scope). We must preserve the homonym chain + -- of the source entity as well. + + Set_Chars (Defining_Identifier (N), Chars (Def_Id)); + Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); + Exchange_Entities (Defining_Identifier (N), Def_Id); + end; + end if; + + return; + else -- In most cases, we must check that the initial value meets any -- constraint imposed by the declared type. However, there is one @@ -4527,119 +4720,6 @@ package body Exp_Ch3 is end if; end if; - -- 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. - - -- Replace - -- CW : I'Class := Obj; - -- by - -- Temp : I'Class := I'Class (Base_Address (Obj'Address)); - -- CW : I'Class renames Displace (Temp, I'Tag); - - if Is_Interface (Typ) - and then Is_Class_Wide_Type (Typ) - and then - (Is_Class_Wide_Type (Etype (Expr)) - or else - not Is_Ancestor (Root_Type (Typ), Etype (Expr))) - and then Comes_From_Source (Def_Id) - and then Tagged_Type_Expansion - then - declare - Decl_1 : Node_Id; - Decl_2 : Node_Id; - - begin - Decl_1 := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - - Object_Definition => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Root_Type (Etype (Def_Id)), Loc), - Attribute_Name => Name_Class), - - Expression => - Unchecked_Convert_To - (Class_Wide_Type (Root_Type (Etype (Def_Id))), - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Base_Address), - Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Expr), - Attribute_Name => Name_Address))))))); - - Insert_Action (N, Decl_1); - - Decl_2 := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - - Subtype_Mark => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Root_Type (Etype (Def_Id)), Loc), - Attribute_Name => Name_Class), - - Name => - Unchecked_Convert_To ( - Class_Wide_Type (Root_Type (Etype (Def_Id))), - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Displace), Loc), - - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To - (Defining_Identifier (Decl_1), Loc), - Attribute_Name => Name_Address), - - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To - (Node - (First_Elmt - (Access_Disp_Table - (Root_Type (Typ)))), - Loc)))))))); - - Rewrite (N, Decl_2); - Analyze (N); - - -- Replace internal identifier of Decl_2 by the identifier - -- found in the sources. We also have to exchange entities - -- containing their defining identifiers to ensure the - -- correct replacement of the object declaration by this - -- object renaming declaration (because such definings - -- identifier have been previously added by Enter_Name to - -- the current scope). We must preserve the homonym chain - -- of the source entity as well. - - Set_Chars (Defining_Identifier (N), Chars (Def_Id)); - Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); - Exchange_Entities (Defining_Identifier (N), Def_Id); - - return; - end; - end if; - -- If the type is controlled and not inherently limited, then -- the target is adjusted after the copy and attached to the -- finalization list. However, no adjustment is done in the case @@ -5702,6 +5782,12 @@ package body Exp_Ch3 is Next_Component (Comp); end loop; + -- Handle constructors of non-tagged CPP_Class types + + if not Is_Tagged_Type (Def_Id) and then Is_CPP_Class (Def_Id) then + Set_CPP_Constructors (Def_Id); + end if; + -- Creation of the Dispatch Table. Note that a Dispatch Table is built -- for regular tagged types as well as for Ada types deriving from a C++ -- Class, but not for tagged types directly corresponding to C++ classes diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 22179e0b588..f8f2caa79b3 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -580,8 +580,7 @@ package body Exp_Ch4 is -- Allocate the object with no expression Node := Relocate_Node (N); - Set_Expression (Node, - New_Reference_To (Root_Type (Etype (Exp)), Loc)); + Set_Expression (Node, New_Reference_To (Etype (Exp), Loc)); -- Avoid its expansion to avoid generating a call to the default -- C++ constructor @@ -615,7 +614,7 @@ package body Exp_Ch4 is Id_Ref => Make_Explicit_Dereference (Loc, Prefix => New_Reference_To (Temp, Loc)), - Typ => Root_Type (Etype (Exp)), + Typ => Etype (Exp), Constructor_Ref => Exp)); end; @@ -3988,8 +3987,7 @@ package body Exp_Ch4 is else pragma Assert (Expr_Value_E (Right) = Standard_False); Remove_Side_Effects (Left); - Rewrite - (N, New_Occurrence_Of (Standard_False, Loc)); + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); end if; end if; @@ -4029,8 +4027,23 @@ package body Exp_Ch4 is -- and replace the conditional expression by a reference to Cnn + -- ??? Note: this expansion is wrong for limited types, since it does + -- a copy of a limited value. The proper fix would be to do the + -- following expansion: + + -- Cnn : access typ; + -- if cond then + -- <<then actions>> + -- Cnn := then-expr'Unrestricted_Access; + -- else + -- <<else actions>> + -- Cnn := else-expr'Unrestricted_Access; + -- end if; + + -- and replace the conditional expresion by a reference to Cnn.all ??? + if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then - Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + Cnn := Make_Temporary (Loc, New_Internal_Name ('C'), N); New_If := Make_Implicit_If_Statement (N, @@ -4079,10 +4092,6 @@ package body Exp_Ch4 is Insert_Action (N, New_If); Analyze_And_Resolve (N, Typ); - - -- Link temporary to original expression, for Codepeer - - Set_Related_Expression (Cnn, Original_Node (N)); end if; end Expand_N_Conditional_Expression; @@ -4108,6 +4117,67 @@ package body Exp_Ch4 is Rop : constant Node_Id := Right_Opnd (N); Static : constant Boolean := Is_OK_Static_Expression (N); + procedure Expand_Set_Membership; + -- For each disjunct we create a simple equality or membership test. + -- The whole membership is rewritten as a short-circuit disjunction. + + --------------------------- + -- Expand_Set_Membership -- + --------------------------- + + procedure Expand_Set_Membership is + Alt : Node_Id; + Res : Node_Id; + + function Make_Cond (Alt : Node_Id) return Node_Id; + -- If the alternative is a subtype mark, create a simple membership + -- test. Otherwise create an equality test for it. + + --------------- + -- Make_Cond -- + --------------- + + function Make_Cond (Alt : Node_Id) return Node_Id is + Cond : Node_Id; + L : constant Node_Id := New_Copy (Lop); + R : constant Node_Id := Relocate_Node (Alt); + + begin + if Is_Entity_Name (Alt) + and then Is_Type (Entity (Alt)) + then + Cond := + Make_In (Sloc (Alt), + Left_Opnd => L, + Right_Opnd => R); + else + Cond := Make_Op_Eq (Sloc (Alt), + Left_Opnd => L, + Right_Opnd => R); + end if; + + return Cond; + end Make_Cond; + + -- Start of proessing for Expand_N_In + + begin + Alt := Last (Alternatives (N)); + Res := Make_Cond (Alt); + + Prev (Alt); + while Present (Alt) loop + Res := + Make_Or_Else (Sloc (Alt), + Left_Opnd => Make_Cond (Alt), + Right_Opnd => Res); + Prev (Alt); + end loop; + + Rewrite (N, Res); + Analyze_And_Resolve (N, Standard_Boolean); + end Expand_Set_Membership; + procedure Substitute_Valid_Check; -- Replaces node N by Lop'Valid. This is done when we have an explicit -- test for the left operand being in range of its subtype. @@ -4133,6 +4203,13 @@ package body Exp_Ch4 is -- Start of processing for Expand_N_In begin + + if Present (Alternatives (N)) then + Remove_Side_Effects (Lop); + Expand_Set_Membership; + return; + end if; + -- Check case of explicit test for an expression in range of its -- subtype. This is suspicious usage and we replace it with a 'Valid -- test and give a warning. @@ -4720,6 +4797,10 @@ package body Exp_Ch4 is Left_Opnd => Left_Opnd (N), Right_Opnd => Right_Opnd (N)))); + -- If this is a set membership, preserve list of alternatives + + Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N))); + -- We want this to appear as coming from source if original does (see -- transformations in Expand_N_In). @@ -7519,6 +7600,11 @@ package body Exp_Ch4 is -- assignment to temporary. If there is no change of representation, -- then the conversion node is unchanged. + procedure Raise_Accessibility_Error; + -- Called when we know that an accessibility check will fail. Rewrites + -- node N to an appropriate raise statement and outputs warning msgs. + -- The Etype of the raise node is set to Target_Type. + procedure Real_Range_Check; -- Handles generation of range check for real target value @@ -7648,6 +7734,22 @@ package body Exp_Ch4 is end if; end Handle_Changed_Representation; + ------------------------------- + -- Raise_Accessibility_Error -- + ------------------------------- + + procedure Raise_Accessibility_Error is + begin + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Target_Type); + + Error_Msg_N ("?accessibility check failure", N); + Error_Msg_NE + ("\?& will be raised at run time", N, Standard_Program_Error); + end Raise_Accessibility_Error; + ---------------------- -- Real_Range_Check -- ---------------------- @@ -7810,9 +7912,14 @@ package body Exp_Ch4 is begin -- Nothing at all to do if conversion is to the identical type so remove - -- the conversion completely, it is useless. + -- the conversion completely, it is useless, except that it may carry + -- an Assignment_OK attribute, which must be propagated to the operand. if Operand_Type = Target_Type then + if Assignment_OK (N) then + Set_Assignment_OK (Operand); + end if; + Rewrite (N, Relocate_Node (Operand)); return; end if; @@ -7884,10 +7991,7 @@ package body Exp_Ch4 is and then Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type) then - Rewrite (N, - Make_Raise_Program_Error (Sloc (N), - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Target_Type); + Raise_Accessibility_Error; -- When the operand is a selected access discriminant the check needs -- to be made against the level of the object denoted by the prefix @@ -7901,11 +8005,7 @@ package body Exp_Ch4 is and then Object_Access_Level (Operand) > Type_Access_Level (Target_Type) then - Rewrite (N, - Make_Raise_Program_Error (Sloc (N), - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Target_Type); - + Raise_Accessibility_Error; return; end if; end if; @@ -8407,6 +8507,19 @@ package body Exp_Ch4 is Operand_Type : constant Entity_Id := Etype (Operand); begin + -- Nothing at all to do if conversion is to the identical type so remove + -- the conversion completely, it is useless, except that it may carry + -- an Assignment_OK indication which must be proprgated to the operand. + + if Operand_Type = Target_Type then + if Assignment_OK (N) then + Set_Assignment_OK (Operand); + end if; + + Rewrite (N, Relocate_Node (Operand)); + return; + end if; + -- If we have a conversion of a compile time known value to a target -- type and the value is in range of the target type, then we can simply -- replace the construct by an integer literal of the correct type. We diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 785da600bf3..2d80cbcc62c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1146,7 +1146,7 @@ package body Exp_Ch6 is -- resulting variable is a temporary which does not designate -- the proper out-parameter, which may not be addressable. In -- that case, generate an assignment to the original expression - -- (before expansion of the packed reference) so that the proper + -- (before expansion of the packed reference) so that the proper -- expansion of assignment to a packed component can take place. declare @@ -3236,6 +3236,7 @@ package body Exp_Ch6 is (Passoc, Next_Named_Actual (Parent (Temp))); end loop; end; + end if; end; end if; @@ -4652,14 +4653,22 @@ package body Exp_Ch6 is end if; - Analyze (N); - -- If it is a function call it can appear in elaboration code and -- the called entity must be frozen here. if Ekind (Subp) = E_Function then Freeze_Expression (Name (N)); end if; + + -- Analyze and resolve the new call. The actuals have already been + -- resolved, but expansion of a function call will add extra actuals + -- if needed. Analysis of a procedure call already includes resolution. + + Analyze (N); + + if Ekind (Subp) = E_Function then + Resolve (N, Etype (Subp)); + end if; end Expand_Protected_Subprogram_Call; -------------------------------- diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 03f0909e7cb..9dd58574214 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -442,39 +442,19 @@ package body Exp_Ch7 is New_Reference_To (RTE (RE_List_Controller), Loc)); + -- If the type is declared in a package declaration and designates a + -- Taft amendment type that requires finalization, place declaration + -- of finalization list in the body, because no client of the package + -- can create objects of the type and thus make use of this list. This + -- ensures the tree for the spec is identical whenever it is compiled. + if Has_Completion_In_Body (Directly_Designated_Type (Typ)) and then In_Package_Body (Current_Scope) and then Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body and then Nkind (Parent (Declaration_Node (Typ))) = N_Package_Specification then - -- The type is declared in a package declaration and designates a - -- Taft amendment type that requires finalization. In general we - -- assume that TA types are controlled, but we inhibit this - -- worst-case assumption for runtime files, for efficiency reasons - -- (see exp_ch3.adb). The reference to RE_List_Controller may have - -- added a with_clause to the current body. Formally the spec needs - -- the with_clause as well, so we add it now, for use by Codepeer. - -- We verify that we are within a package body, because this code - -- can also be invoked within a package instantiation. - - declare - Loc : constant Source_Ptr := Sloc (Typ); - Spec_Unit : constant Node_Id := - Library_Unit (Cunit (Current_Sem_Unit)); - List_Scope : constant Entity_Id := - Scope (RTE (RE_List_Controller)); - With_Clause : constant Node_Id := - Make_With_Clause (Loc, - Name => New_Occurrence_Of (List_Scope, Loc)); - begin - Set_Library_Unit - (With_Clause, Parent (Unit_Declaration_Node (List_Scope))); - Set_Corresponding_Spec (With_Clause, List_Scope); - Set_Implicit_With (With_Clause); - Append (With_Clause, Context_Items (Spec_Unit)); - end; - end if; + Insert_Action (Parent (Designated_Type (Typ)), Decl); -- The type may have been frozen already, and this is a late freezing -- action, in which case the declaration must be elaborated at once. @@ -482,11 +462,12 @@ package body Exp_Ch7 is -- because the freezing of the type does not build one. Otherwise, the -- declaration is one of the freezing actions for a user-defined type. - if Is_Frozen (Typ) + elsif Is_Frozen (Typ) or else (Nkind (N) = N_Allocator and then Ekind (Etype (N)) = E_Anonymous_Access_Type) then Insert_Action (N, Decl); + else Append_Freeze_Action (Typ, Decl); end if; @@ -3571,7 +3552,7 @@ package body Exp_Ch7 is procedure Wrap_Transient_Expression (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); E : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Make_Temporary (Loc, New_Internal_Name ('E'), N); Etyp : constant Entity_Id := Etype (N); begin diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index 3a6297ce9ee..15e83aaf113 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1522,33 +1522,38 @@ package Exp_Dbug is -- to DWARF2/3 are generated, with the following variations from the above -- specification. - -- Change in the contents of the DW_AT_name attribute. - -- The operators are represented in their natural form. (Ie, the addition - -- operator is written as "+" instead of "Oadd"). - -- The component separation string is "." instead of "__" + -- Change in the contents of the DW_AT_name attribute - -- Introduction of DW_AT_GNAT_encoding, encoded with value 0x2301. - -- Any debugging information entry representing a program entity, named - -- or implicit, may have a DW_AT_GNAT_encoding attribute. The value of - -- this attribute is a string representing the suffix internally added - -- by GNAT for various purposes, mainly for representing debug - -- information compatible with other formats. + -- The operators are represented in their natural form. (for example, + -- the addition operator is written as "+" instead of "Oadd"). The + -- component separator is "." instead of "__" - -- If a debugging information entry has multiple encodings, all of them - -- will be listed in DW_AT_GNAT_encoding. The separator for this list - -- is ':'. + -- Introduction of DW_AT_GNAT_encoding, encoded with value 0x2301 + + -- Any debugging information entry representing a program entity, named + -- or implicit, may have a DW_AT_GNAT_encoding attribute. The value of + -- this attribute is a string representing the suffix internally added + -- by GNAT for various purposes, mainly for representing debug + -- information compatible with other formats. In particular this is + -- useful for IDEs which need to filter out information internal to + -- GNAT from their graphical interfaces. + + -- If a debugging information entry has multiple encodings, all of them + -- will be listed in DW_AT_GNAT_encoding using the list separator ':'. -- Introduction of DW_AT_GNAT_descriptive_type, encoded with value 0x2302 - -- Any debugging information entry representing a type may have a - -- DW_AT_GNAT_descriptive_type attribute whose value is a reference, - -- pointing to a debugging information entry representing another type - -- associated to the type. - - -- Modification of the contents of the DW_AT_producer string. - -- When emitting full GNAT Vendor extensions to DWARF2/3, "-gdwarf+" - -- is appended to the DW_AT_producer string. + + -- Any debugging information entry representing a type may have a + -- DW_AT_GNAT_descriptive_type attribute whose value is a reference, + -- pointing to a debugging information entry representing another type + -- associated to the type. + + -- Modification of the contents of the DW_AT_producer string + + -- When emitting full GNAT Vendor extensions to DWARF2/3, "-gdwarf+" + -- is appended to the DW_AT_producer string. -- - -- When emitting only DW_AT_GNAT_descriptive_type, "-gdwarf+-" is - -- appended to the DW_AT_producer string. + -- When emitting only DW_AT_GNAT_descriptive_type, "-gdwarf+-" is + -- appended to the DW_AT_producer string. end Exp_Dbug; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 5c5534b7a3e..99f918b7477 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1831,6 +1831,11 @@ package body Exp_Disp is RTE (RE_Asynchronous_Call), Loc), Make_Identifier (Loc, Name_uF)))); -- status flag end if; + + else + -- Ensure that the statements list is non-empty + + Append_To (Stmts, Make_Null_Statement (Loc)); end if; return @@ -2199,6 +2204,11 @@ package body Exp_Disp is RTE (RE_Conditional_Call), Loc), Make_Identifier (Loc, Name_uF)))); -- status flag end if; + + else + -- Ensure that the statements list is non-empty + + Append_To (Stmts, Make_Null_Statement (Loc)); end if; return @@ -3022,6 +3032,11 @@ package body Exp_Disp is Make_Identifier (Loc, Name_uM), -- delay mode Make_Identifier (Loc, Name_uF)))); -- status flag end if; + + else + -- Ensure that the statements list is non-empty + + Append_To (Stmts, Make_Null_Statement (Loc)); end if; return @@ -6103,64 +6118,71 @@ package body Exp_Disp is end loop; end if; - -- 3) At the end of Access_Disp_Table we add the entity of an access - -- type declaration. It is used by Build_Get_Prim_Op_Address to - -- expand dispatching calls through the primary dispatch table. + -- 3) At the end of Access_Disp_Table, if the type has user-defined + -- primitives, we add the entity of an access type declaration that + -- is used by Build_Get_Prim_Op_Address to expand dispatching calls + -- through the primary dispatch table. + + if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then + Analyze_List (Result); -- Generate: -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr; -- type Typ_DT_Acc is access Typ_DT; - declare - Name_DT_Prims : constant Name_Id := - New_External_Name (Tname, 'G'); - Name_DT_Prims_Acc : constant Name_Id := - New_External_Name (Tname, 'H'); - DT_Prims : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_DT_Prims); - DT_Prims_Acc : constant Entity_Id := - Make_Defining_Identifier (Loc, - Name_DT_Prims_Acc); - begin - Append_To (Result, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => DT_Prims, - Type_Definition => - Make_Constrained_Array_Definition (Loc, - Discrete_Subtype_Definitions => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Make_Integer_Literal (Loc, - DT_Entry_Count - (First_Tag_Component (Typ))))), - Component_Definition => - Make_Component_Definition (Loc, - Subtype_Indication => - New_Reference_To (RTE (RE_Prim_Ptr), Loc))))); + else + declare + Name_DT_Prims : constant Name_Id := + New_External_Name (Tname, 'G'); + Name_DT_Prims_Acc : constant Name_Id := + New_External_Name (Tname, 'H'); + DT_Prims : constant Entity_Id := + Make_Defining_Identifier (Loc, + Name_DT_Prims); + DT_Prims_Acc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Name_DT_Prims_Acc); + begin + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims, + Type_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, + DT_Entry_Count + (First_Tag_Component (Typ))))), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Reference_To (RTE (RE_Prim_Ptr), Loc))))); - Append_To (Result, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => DT_Prims_Acc, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (DT_Prims, Loc)))); + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims_Acc, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (DT_Prims, Loc)))); - Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); + Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); - -- Analyze the resulting list and suppress the generation of the - -- Init_Proc associated with the above array declaration because - -- we never use such type in object declarations; this type is only - -- used to simplify the expansion associated with dispatching calls. + -- Analyze the resulting list and suppress the generation of the + -- Init_Proc associated with the above array declaration because + -- this type is never used in object declarations. It is only used + -- to simplify the expansion associated with dispatching calls. - Analyze_List (Result); - Set_Suppress_Init_Proc (Base_Type (DT_Prims)); + Analyze_List (Result); + Set_Suppress_Init_Proc (Base_Type (DT_Prims)); - -- Mark entity of dispatch table. Required by the backend to handle - -- the properly. + -- Mark entity of dispatch table. Required by the back end to + -- handle them properly. - Set_Is_Dispatch_Table_Entity (DT_Prims); - end; + Set_Is_Dispatch_Table_Entity (DT_Prims); + end; + end if; Set_Ekind (DT_Ptr, E_Constant); Set_Is_Tag (DT_Ptr); diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 75b400d2644..14d470c1f01 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -27,6 +27,7 @@ with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; with Exp_Atag; use Exp_Atag; +with Exp_Disp; use Exp_Disp; with Exp_Strm; use Exp_Strm; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -55,8 +56,7 @@ with GNAT.HTable; use GNAT.HTable; package body Exp_Dist is -- The following model has been used to implement distributed objects: - -- given a designated type D and a RACW type R, then a record of the - -- form: + -- given a designated type D and a RACW type R, then a record of the form: -- type Stub is tagged record -- [...declaration similar to s-parint.ads RACW_Stub_Type...] @@ -64,8 +64,8 @@ package body Exp_Dist is -- is built. This type has two properties: - -- 1) Since it has the same structure than RACW_Stub_Type, it can be - -- converted to and from this type to make it suitable for + -- 1) Since it has the same structure than RACW_Stub_Type, it can + -- be converted to and from this type to make it suitable for -- System.Partition_Interface.Get_Unique_Remote_Pointer in order -- to avoid memory leaks when the same remote object arrive on the -- same partition through several paths; @@ -82,11 +82,10 @@ package body Exp_Dist is -- RCI subprograms are numbered starting at 2. The RCI receiver for -- an RCI package can thus identify calls received through remote -- access-to-subprogram dereferences by the fact that they have a - -- (primitive) subprogram id of 0, and 1 is used for the internal - -- RAS information lookup operation. (This is for the Garlic code - -- generation, where subprograms are identified by numbers; in the - -- PolyORB version, they are identified by name, with a numeric suffix - -- for homonyms.) + -- (primitive) subprogram id of 0, and 1 is used for the internal RAS + -- information lookup operation. (This is for the Garlic code generation, + -- where subprograms are identified by numbers; in the PolyORB version, + -- they are identified by name, with a numeric suffix for homonyms.) type Hash_Index is range 0 .. 50; @@ -95,13 +94,13 @@ package body Exp_Dist is ----------------------- function Hash (F : Entity_Id) return Hash_Index; - -- DSA expansion associates stubs to distributed object types using - -- a hash table on entity ids. + -- DSA expansion associates stubs to distributed object types using a hash + -- table on entity ids. function Hash (F : Name_Id) return Hash_Index; -- The generation of subprogram identifiers requires an overload counter - -- to be associated with each remote subprogram names. These counters - -- are maintained in a hash table on name ids. + -- to be associated with each remote subprogram names. These counters are + -- maintained in a hash table on name ids. type Subprogram_Identifiers is record Str_Identifier : String_Id; @@ -115,8 +114,8 @@ package body Exp_Dist is Key => Entity_Id, Hash => Hash, Equal => "="); - -- Mapping between a remote subprogram and the corresponding - -- subprogram identifiers. + -- Mapping between a remote subprogram and the corresponding subprogram + -- identifiers. package Overload_Counter_Table is new Simple_HTable (Header_Num => Hash_Index, @@ -125,9 +124,9 @@ package body Exp_Dist is Key => Name_Id, Hash => Hash, Equal => "="); - -- Mapping between a subprogram name and an integer that - -- counts the number of defining subprogram names with that - -- Name_Id encountered so far in a given context (an interface). + -- Mapping between a subprogram name and an integer that counts the number + -- of defining subprogram names with that Name_Id encountered so far in a + -- given context (an interface). function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers; function Get_Subprogram_Id (Def : Entity_Id) return String_Id; @@ -264,8 +263,8 @@ package body Exp_Dist is (Loc : Source_Ptr; Prefix : Entity_Id; Selector_Name : Name_Id) return Node_Id; - -- Return a selected_component whose prefix denotes the given entity, - -- and with the given Selector_Name. + -- Return a selected_component whose prefix denotes the given entity, and + -- with the given Selector_Name. function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; -- Return the scope represented by a given spec @@ -274,8 +273,8 @@ package body Exp_Dist is (Typ : Entity_Id; Nam : Entity_Id; TSS_Nam : TSS_Name_Type); - -- Create a renaming declaration of subprogram Nam, - -- and register it as a TSS for Typ with name TSS_Nam. + -- Create a renaming declaration of subprogram Nam, and register it as a + -- TSS for Typ with name TSS_Nam. function Need_Extra_Constrained (Parameter : Node_Id) return Boolean; -- Return True if the current parameter needs an extra formal to reflect @@ -563,11 +562,10 @@ package body Exp_Dist is procedure Specific_Build_Stub_Type (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; + Stub_Type_Comps : out List_Id; RPC_Receiver_Decl : out Node_Id); - -- Build a type declaration for the stub type associated with an RACW - -- type, and the necessary RPC receiver, if applicable. PCS-specific + -- Build a components list for the stub type associated with an RACW type, + -- and build the necessary RPC receiver, if applicable. PCS-specific -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration -- is generated, then RPC_Receiver_Decl is set to Empty. @@ -616,6 +614,10 @@ package body Exp_Dist is Stmts : List_Id); -- Add receiving stubs to the declarative part of an RCI unit + -------------------- + -- GARLIC_Support -- + -------------------- + package GARLIC_Support is -- Support for generating DSA code that uses the GARLIC PCS @@ -657,8 +659,7 @@ package body Exp_Dist is procedure Build_Stub_Type (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; + Stub_Type_Comps : out List_Id; RPC_Receiver_Decl : out Node_Id); function Build_Subprogram_Receiving_Stubs @@ -690,6 +691,10 @@ package body Exp_Dist is end GARLIC_Support; + --------------------- + -- PolyORB_Support -- + --------------------- + package PolyORB_Support is -- Support for generating DSA code that uses the PolyORB PCS @@ -731,8 +736,7 @@ package body Exp_Dist is procedure Build_Stub_Type (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; + Stub_Type_Comps : out List_Id; RPC_Receiver_Decl : out Node_Id); function Build_Subprogram_Receiving_Stubs @@ -769,6 +773,10 @@ package body Exp_Dist is -- their methods to be accessed as objects, for the implementation of -- remote access-to-subprogram types). + ------------- + -- Helpers -- + ------------- + package Helpers is -- Routines to build distribution helper subprograms for user-defined @@ -855,6 +863,21 @@ package body Exp_Dist is -- for entity E (a distributed object type or operation): one -- containing the name of E, the second containing its repository id. + procedure Assign_Opaque_From_Any + (Loc : Source_Ptr; + Stms : List_Id; + Typ : Entity_Id; + N : Node_Id; + Target : Entity_Id); + -- For a Target object of type Typ, which has opaque representation + -- as a sequence of octets determined by stream attributes (which + -- includes all limited types), append code to Stmts performing the + -- equivalent of: + -- Target := Typ'From_Any (N) + -- + -- or, if Target is Empty: + -- return Typ'From_Any (N) + end Helpers; end PolyORB_Support; @@ -1146,7 +1169,6 @@ package body Exp_Dist is end if; else - -- Case of declaring the RACW in another package than its designated -- type: use the private declarations list if present; otherwise -- use the visible declarations. @@ -1317,11 +1339,12 @@ package body Exp_Dist is Is_TSS (Current_Primitive, TSS_Stream_Input) or else Is_TSS (Current_Primitive, TSS_Stream_Output) or else Is_TSS (Current_Primitive, TSS_Stream_Read) or else - Is_TSS (Current_Primitive, TSS_Stream_Write)) + Is_TSS (Current_Primitive, TSS_Stream_Write) or else + Is_Predefined_Interface_Primitive (Current_Primitive)) and then not Is_Hidden (Current_Primitive) then -- The first thing to do is build an up-to-date copy of the - -- spec with all the formals referencing Designated_Type + -- spec with all the formals referencing Controlling_Type -- transformed into formals referencing Stub_Type. Since this -- primitive may have been inherited, go back the alias chain -- until the real primitive has been found. @@ -1337,7 +1360,7 @@ package body Exp_Dist is -- Copy the spec from the original declaration for the purpose -- of declaring an overriding subprogram: we need to replace -- the type of each controlling formal with Stub_Type. The - -- primitive may have been declared for Designated_Type or + -- primitive may have been declared for Controlling_Type or -- inherited from some ancestor type for which we do not have -- an easily determined Entity_Id. We have no systematic way -- of knowing which type to substitute Stub_Type for. Instead, @@ -1858,8 +1881,9 @@ package body Exp_Dist is is Loc : constant Source_Ptr := Sloc (RACW_Type); - Stub_Elements : constant Stub_Structure := - Stubs_Table.Get (Designated_Type); + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + Stub_Type_Comps : List_Id; Stub_Type_Decl : Node_Id; Stub_Type_Access_Decl : Node_Id; @@ -1875,8 +1899,7 @@ package body Exp_Dist is Existing := False; Stub_Type := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); Set_Ekind (Stub_Type, E_Record_Type); Set_Is_RACW_Stub_Type (Stub_Type); Stub_Type_Access := @@ -1884,9 +1907,24 @@ package body Exp_Dist is Chars => New_External_Name (Related_Id => Chars (Stub_Type), Suffix => 'A')); - Specific_Build_Stub_Type - (RACW_Type, Stub_Type, - Stub_Type_Decl, RPC_Receiver_Decl); + Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl); + + Stub_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type, + Type_Definition => + Make_Record_Definition (Loc, + Tagged_Present => True, + Limited_Present => True, + Component_List => + Make_Component_List (Loc, + Component_Items => Stub_Type_Comps))); + + -- Does the stub type need to explicitly implement interfaces from the + -- designated type??? + + -- In particular are there issues in the case where the designated type + -- is a synchronized interface??? Stub_Type_Access_Decl := Make_Full_Type_Declaration (Loc, @@ -1901,9 +1939,10 @@ package body Exp_Dist is Append_To (Decls, Stub_Type_Access_Decl); Analyze (Last (Decls)); - -- This is in no way a type derivation, but we fake it to make sure that - -- the dispatching table gets built with the corresponding primitive - -- operations at the right place. + -- We can't directly derive the stub type from the designated type, + -- because we don't want any components or discriminants from the real + -- type, so instead we manually fake a derivation to get an appropriate + -- dispatch table. Derive_Subprograms (Parent_Type => Designated_Type, Derived_Type => Stub_Type); @@ -1930,6 +1969,7 @@ package body Exp_Dist is procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is E : Entity_Id; + begin E := First_Entity (Spec_Id); while Present (E) loop @@ -1960,10 +2000,9 @@ package body Exp_Dist is Get_Name_String (N); - -- Homonym handling: as in Exp_Dbug, but much simpler, - -- because the only entities for which we have to generate - -- names here need only to be disambiguated within their - -- own scope. + -- Homonym handling: as in Exp_Dbug, but much simpler, because the only + -- entities for which we have to generate names here need only to be + -- disambiguated within their own scope. if Overload_Order > 1 then Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__"; @@ -1972,8 +2011,9 @@ package body Exp_Dist is end if; Id := String_From_Name_Buffer; - Subprogram_Identifier_Table.Set (Def, - Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn)); + Subprogram_Identifier_Table.Set + (Def, + Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn)); end Assign_Subprogram_Identifier; ------------------------------------- @@ -1988,6 +2028,7 @@ package body Exp_Dist is Decls : List_Id) is Loc : constant Source_Ptr := Sloc (Object); + begin -- Declare a temporary object for the actual, possibly initialized with -- a 'Input/From_Any call. @@ -2071,7 +2112,6 @@ package body Exp_Dist is end if; else - -- General case of a regular object declaration. Object is flagged -- constant unless it has mode out or in out, to allow the backend -- to optimize where possible. @@ -2715,11 +2755,11 @@ package body Exp_Dist is --------------------------------------------- procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); Called_Subprogram : constant Entity_Id := Entity (Name (N)); RCI_Package : constant Entity_Id := Scope (Called_Subprogram); - Loc : constant Source_Ptr := Sloc (N); - RCI_Locator : Node_Id; - RCI_Cache : Entity_Id; + RCI_Locator_Decl : Node_Id; + RCI_Locator : Entity_Id; Calling_Stubs : Node_Id; E_Calling_Stubs : Entity_Id; @@ -2727,41 +2767,35 @@ package body Exp_Dist is E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); if E_Calling_Stubs = Empty then - RCI_Cache := RCI_Locator_Table.Get (RCI_Package); - - if RCI_Cache = Empty then - RCI_Locator := - RCI_Package_Locator - (Loc, Specification (Unit_Declaration_Node (RCI_Package))); - Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator); - - -- The RCI_Locator package is inserted at the top level in the - -- current unit, and must appear in the proper scope, so that it - -- is not prematurely removed by the GCC back-end. + RCI_Locator := RCI_Locator_Table.Get (RCI_Package); - declare - Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); - - begin - if Ekind (Scop) = E_Package_Body then - Push_Scope (Spec_Entity (Scop)); + -- The RCI_Locator package and calling stub are is inserted at the + -- top level in the current unit, and must appear in the proper scope + -- so that it is not prematurely removed by the GCC back end. - elsif Ekind (Scop) = E_Subprogram_Body then - Push_Scope - (Corresponding_Spec (Unit_Declaration_Node (Scop))); - - else - Push_Scope (Scop); - end if; - - Analyze (RCI_Locator); - Pop_Scope; - end; + declare + Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + begin + if Ekind (Scop) = E_Package_Body then + Push_Scope (Spec_Entity (Scop)); + elsif Ekind (Scop) = E_Subprogram_Body then + Push_Scope + (Corresponding_Spec (Unit_Declaration_Node (Scop))); + else + Push_Scope (Scop); + end if; + end; - RCI_Cache := Defining_Unit_Name (RCI_Locator); + if RCI_Locator = Empty then + RCI_Locator_Decl := + RCI_Package_Locator + (Loc, Specification (Unit_Declaration_Node (RCI_Package))); + Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl); + Analyze (RCI_Locator_Decl); + RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl); else - RCI_Locator := Parent (RCI_Cache); + RCI_Locator_Decl := Parent (RCI_Locator); end if; Calling_Stubs := Build_Subprogram_Calling_Stubs @@ -2771,10 +2805,12 @@ package body Exp_Dist is Asynchronous => Nkind (N) = N_Procedure_Call_Statement and then Is_Asynchronous (Called_Subprogram), - Locator => RCI_Cache, + Locator => RCI_Locator, New_Name => New_Internal_Name ('S')); - Insert_After (RCI_Locator, Calling_Stubs); + Insert_After (RCI_Locator_Decl, Calling_Stubs); Analyze (Calling_Stubs); + Pop_Scope; + E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); end if; @@ -4084,8 +4120,8 @@ package body Exp_Dist is Loc : constant Source_Ptr := Sloc (Nod); Stream_Parameter : Node_Id; - -- Name of the stream used to transmit parameters to the - -- remote package. + -- Name of the stream used to transmit parameters to the remote + -- package. Result_Parameter : Node_Id; -- Name of the result parameter (in non-APC cases) which get the @@ -4410,8 +4446,8 @@ package body Exp_Dist is else -- Loop around parameters and assign out (or in out) -- parameters. In the case of RACW, controlling arguments - -- cannot possibly have changed since they are remote, so we do - -- not read them from the stream. + -- cannot possibly have changed since they are remote, so + -- we do not read them from the stream. Current_Parameter := First (Ordered_Parameters_List); while Present (Current_Parameter) loop @@ -4619,62 +4655,49 @@ package body Exp_Dist is procedure Build_Stub_Type (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; + Stub_Type_Comps : out List_Id; RPC_Receiver_Decl : out Node_Id) is - Loc : constant Source_Ptr := Sloc (Stub_Type); + Loc : constant Source_Ptr := Sloc (RACW_Type); Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); begin - Stub_Type_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Stub_Type, - Type_Definition => - Make_Record_Definition (Loc, - Tagged_Present => True, - Limited_Present => True, - Component_List => - Make_Component_List (Loc, - Component_Items => New_List ( - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Origin), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of ( - RTE (RE_Partition_ID), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Receiver), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Addr), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Asynchronous), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of ( - Standard_Boolean, Loc))))))); + Stub_Type_Comps := New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Origin), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Receiver), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Addr), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Asynchronous), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc)))); if Is_RAS then RPC_Receiver_Decl := Empty; @@ -5193,7 +5216,9 @@ package body Exp_Dist is ------------------------------- function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is - Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig); Body_Decls : List_Id; @@ -5311,15 +5336,15 @@ package body Exp_Dist is Typ : Entity_Id; begin - -- If the kind of the parameter is E_Void, then it is not a - -- controlling formal (this can happen in the context of RAS). + -- If the kind of the parameter is E_Void, then it is not a controlling + -- formal (this can happen in the context of RAS). if Ekind (Defining_Identifier (Parameter)) = E_Void then return False; end if; - -- If the parameter is not a controlling formal, then it cannot - -- be possibly a RACW_Controlling_Formal. + -- If the parameter is not a controlling formal, then it cannot be + -- possibly a RACW_Controlling_Formal. if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then return False; @@ -5636,7 +5661,6 @@ package body Exp_Dist is is Loc : constant Source_Ptr := Sloc (RACW_Type); Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); - Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (RACW_Type), 'F')); @@ -5648,8 +5672,8 @@ package body Exp_Dist is Statements : List_Id; -- Various parts of the subprogram - Any_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_A); + Any_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_A); Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); @@ -5852,19 +5876,17 @@ package body Exp_Dist is Func_Decl : Node_Id; Func_Body : Node_Id; - Decls : List_Id; - Statements : List_Id; + Decls : List_Id; + Statements : List_Id; -- Various parts of the subprogram RACW_Parameter : constant Entity_Id := Make_Defining_Identifier (Loc, Name_R); - Reference : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('R')); - Any : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('A')); + Reference : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Any : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); begin Func_Spec := @@ -5992,7 +6014,6 @@ package body Exp_Dist is Func_Body : Node_Id; begin - -- The spec for this subprogram has a dummy 'access RACW' argument, -- which serves only for overloading purposes. @@ -6314,14 +6335,14 @@ package body Exp_Dist is Append_To (Proc_Statements, - -- if L then + -- if L then Make_Implicit_If_Statement (N, Condition => New_Occurrence_Of (Is_Local, Loc), Then_Statements => New_List ( - -- if A.Target = null then + -- if A.Target = null then Make_Implicit_If_Statement (N, Condition => @@ -6336,7 +6357,7 @@ package body Exp_Dist is Then_Statements => New_List ( - -- A.Target := Entity_Of (Ref); + -- A.Target := Entity_Of (Ref); Make_Assignment_Statement (Loc, Name => @@ -6352,7 +6373,8 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc)))), - -- Inc_Usage (A.Target); + -- Inc_Usage (A.Target); + -- end if; Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), @@ -6365,10 +6387,9 @@ package body Exp_Dist is Selector_Name => Make_Identifier (Loc, Name_Target)))))), - -- end if; - -- if not All_Calls_Remote then - -- return Fat_Type!(A); - -- end if; + -- if not All_Calls_Remote then + -- return Fat_Type!(A); + -- end if; Make_Implicit_If_Statement (N, Condition => @@ -6384,7 +6405,7 @@ package body Exp_Dist is Append_List_To (Proc_Statements, New_List ( - -- Stub.Target := Entity_Of (Ref); + -- Stub.Target := Entity_Of (Ref); Set_Field (Name_Target, Make_Function_Call (Loc, @@ -6392,7 +6413,7 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (Subp_Ref, Loc)))), - -- Inc_Usage (Stub.Target); + -- Inc_Usage (Stub.Target); Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), @@ -6401,12 +6422,12 @@ package body Exp_Dist is Prefix => Stub_Ptr, Selector_Name => Name_Target))), - -- E.4.1(9) A remote call is asynchronous if it is a call to - -- a procedure, or a call through a value of an access-to-procedure - -- type, to which a pragma Asynchronous applies. + -- E.4.1(9) A remote call is asynchronous if it is a call to + -- a procedure, or a call through a value of an access-to-procedure + -- type, to which a pragma Asynchronous applies. - -- Parameter Asynch_P is true when the procedure is asynchronous; - -- Expression Asynch_T is true when the type is asynchronous. + -- Parameter Asynch_P is true when the procedure is asynchronous; + -- Expression Asynch_T is true when the type is asynchronous. Set_Field (Name_Asynchronous, Make_Or_Else (Loc, @@ -6669,8 +6690,8 @@ package body Exp_Dist is -- Request object received from neutral layer Subp_Id : Entity_Id; - -- Subprogram identifier as received from the neutral - -- distribution core. + -- Subprogram identifier as received from the neutral distribution + -- core. Subp_Index : Entity_Id; -- Internal index as determined by matching either the method name @@ -6787,9 +6808,9 @@ package body Exp_Dist is begin -- Building receiving stubs consist in several operations: - -- - a package RPC receiver must be built. This subprogram - -- will get a Subprogram_Id from the incoming stream - -- and will dispatch the call to the right subprogram; + -- - a package RPC receiver must be built. This subprogram will get + -- a Subprogram_Id from the incoming stream and will dispatch the + -- call to the right subprogram; -- - a receiving stub for each subprogram visible in the package -- spec. This stub will read all the parameters from the stream, @@ -6837,9 +6858,9 @@ package body Exp_Dist is New_Occurrence_Of (Is_Local, Loc), New_Occurrence_Of (Local_Address, Loc)))); - -- For each subprogram, the receiving stub will be built and a - -- case statement will be made on the Subprogram_Id to dispatch - -- to the right subprogram. + -- For each subprogram, the receiving stub will be built and a case + -- statement will be made on the Subprogram_Id to dispatch to the + -- right subprogram. All_Calls_Remote_E := Boolean_Literals ( Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); @@ -7393,17 +7414,25 @@ package body Exp_Dist is if Out_Present (Current_Parameter) and then not Is_Controlling_Formal then - Append_To (After_Statements, - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), - Expression => - PolyORB_Support.Helpers.Build_From_Any_Call - (Etype (Parameter_Type (Current_Parameter)), - New_Occurrence_Of (Any, Loc), - Decls))); - + if Is_Limited_Type (Etyp) then + Helpers.Assign_Opaque_From_Any (Loc, + Stms => After_Statements, + Typ => Etyp, + N => New_Occurrence_Of (Any, Loc), + Target => + Defining_Identifier (Current_Parameter)); + else + Append_To (After_Statements, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Expression => + PolyORB_Support.Helpers.Build_From_Any_Call + (Etyp, + New_Occurrence_Of (Any, Loc), + Decls))); + end if; end if; end; end if; @@ -7615,44 +7644,31 @@ package body Exp_Dist is procedure Build_Stub_Type (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; + Stub_Type_Comps : out List_Id; RPC_Receiver_Decl : out Node_Id) is - Loc : constant Source_Ptr := Sloc (Stub_Type); - - pragma Unreferenced (RACW_Type); + Loc : constant Source_Ptr := Sloc (RACW_Type); begin - Stub_Type_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Stub_Type, - Type_Definition => - Make_Record_Definition (Loc, - Tagged_Present => True, - Limited_Present => True, - Component_List => - Make_Component_List (Loc, - Component_Items => New_List ( - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Target), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Asynchronous), - - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (Standard_Boolean, Loc))))))); + Stub_Type_Comps := New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Target), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Asynchronous), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc)))); RPC_Receiver_Decl := Make_Object_Declaration (Loc, @@ -7758,8 +7774,8 @@ package body Exp_Dist is Decls : constant List_Id := New_List; -- All the parameters will get declared before calling the real - -- subprograms. Also the out parameters will be declared. - -- At this level, parameters may be unconstrained. + -- subprograms. Also the out parameters will be declared. At this + -- level, parameters may be unconstrained. Statements : constant List_Id := New_List; @@ -7835,8 +7851,10 @@ package body Exp_Dist is -- Controlling formals in distributed object primitive -- operations are handled specially: + -- - the first controlling formal is used as the -- target of the call; + -- - the remaining controlling formals are transmitted -- as RACWs. @@ -7932,22 +7950,32 @@ package body Exp_Dist is -- the object declaration and the variable is set using -- 'Input instead of 'Read. - Expr := PolyORB_Support.Helpers.Build_From_Any_Call ( - Etyp, New_Occurrence_Of (Any, Loc), Decls); + if Constrained and then Is_Limited_Type (Etyp) then + Helpers.Assign_Opaque_From_Any (Loc, + Stms => Statements, + Typ => Etyp, + N => New_Occurrence_Of (Any, Loc), + Target => Object); - if Constrained then - Append_To (Statements, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Object, Loc), - Expression => Expr)); - Expr := Empty; else - null; + Expr := Helpers.Build_From_Any_Call + (Etyp, New_Occurrence_Of (Any, Loc), Decls); - -- Expr will be used to initialize (and constrain) the - -- parameter when it is declared. - end if; + if Constrained then + Append_To (Statements, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Object, Loc), + Expression => Expr)); + Expr := Empty; + else + -- Expr will be used to initialize (and constrain) the + -- parameter when it is declared. + null; + end if; + + null; + end if; end if; Need_Extra_Constrained := @@ -8006,10 +8034,7 @@ package body Exp_Dist is (Defining_Identifier (Current_Parameter), Loc), Explicit_Actual_Parameter => Make_Explicit_Dereference (Loc, - Prefix => - Unchecked_Convert_To (RACW_Type, - OK_Convert_To (RTE (RE_Address), - New_Occurrence_Of (Object, Loc)))))); + Prefix => New_Occurrence_Of (Object, Loc)))); else Append_To (Parameter_List, @@ -8019,9 +8044,7 @@ package body Exp_Dist is (Defining_Identifier (Current_Parameter), Loc), Explicit_Actual_Parameter => - Unchecked_Convert_To (RACW_Type, - OK_Convert_To (RTE (RE_Address), - New_Occurrence_Of (Object, Loc))))); + New_Occurrence_Of (Object, Loc))); end if; else @@ -8201,10 +8224,10 @@ package body Exp_Dist is Parameter_Type => New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); - -- An exception raised during the execution of an incoming - -- remote subprogram call and that needs to be sent back - -- to the caller is propagated by the receiving stubs, and - -- will be handled by the caller (the distribution runtime). + -- An exception raised during the execution of an incoming remote + -- subprogram call and that needs to be sent back to the caller is + -- propagated by the receiving stubs, and will be handled by the + -- caller (the distribution runtime). if Asynchronous and then not Dynamically_Asynchronous then @@ -8368,6 +8391,122 @@ package body Exp_Dist is end if; end Append_Record_Traversal; + ----------------------------- + -- Assign_Opaque_From_Any -- + ----------------------------- + + procedure Assign_Opaque_From_Any + (Loc : Source_Ptr; + Stms : List_Id; + Typ : Entity_Id; + N : Node_Id; + Target : Entity_Id) + is + Strm : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + Expr : Node_Id; + + Read_Call_List : List_Id; + -- List on which to place the 'Read attribute reference + + begin + -- Strm : Buffer_Stream_Type; + + Append_To (Stms, + Make_Object_Declaration (Loc, + Defining_Identifier => Strm, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); + + -- Any_To_BS (Strm, A); + + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), + Parameter_Associations => New_List ( + N, + New_Occurrence_Of (Strm, Loc)))); + + if Transmit_As_Unconstrained (Typ) then + Expr := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Strm, Loc), + Attribute_Name => Name_Access))); + + -- Target := Typ'Input (Strm'Access) + + if Present (Target) then + Append_To (Stms, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Target, Loc), + Expression => Expr)); + + -- return Typ'Input (Strm'Access); + + else + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => Expr)); + end if; + + else + if Present (Target) then + Read_Call_List := Stms; + Expr := New_Occurrence_Of (Target, Loc); + + else + declare + Temp : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('R')); + + begin + Read_Call_List := New_List; + Expr := New_Occurrence_Of (Temp, Loc); + + Append_To (Stms, Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => + Temp, + Object_Definition => + New_Occurrence_Of (Typ, Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Read_Call_List))); + end; + end if; + + -- Typ'Read (Strm'Access, [Target|Temp]) + + Append_To (Read_Call_List, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Strm, Loc), + Attribute_Name => Name_Access), + Expr))); + + if No (Target) then + + -- return Temp + + Append_To (Read_Call_List, + Make_Simple_Return_Statement (Loc, + Expression => New_Copy (Expr))); + end if; + end if; + end Assign_Opaque_From_Any; + ------------------------- -- Build_From_Any_Call -- ------------------------- @@ -8478,17 +8617,16 @@ package body Exp_Dist is else declare Decl : Entity_Id; - Typ : Entity_Id := U_Type; begin -- For the subtype representing a generic actual type, go -- to the base type. - if Is_Generic_Actual_Type (Typ) then - Typ := Base_Type (Typ); + if Is_Generic_Actual_Type (U_Type) then + U_Type := Base_Type (U_Type); end if; - Build_From_Any_Function (Loc, Typ, Decl, Fnam); + Build_From_Any_Function (Loc, U_Type, Decl, Fnam); Append_To (Decls, Decl); end; end if; @@ -8534,7 +8672,12 @@ package body Exp_Dist is Use_Opaque_Representation : Boolean; begin - if Is_Itype (Typ) then + -- For a derived type, we can't go past the base type (to the + -- parent type) here, because that would cause the attribute's + -- formal parameter to have the wrong type; hence the Base_Type + -- check here. + + if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then Build_From_Any_Function (Loc => Loc, Typ => Etype (Typ), @@ -8636,11 +8779,13 @@ package body Exp_Dist is Rec : Entity_Id; Field : Node_Id) is + Ctyp : Entity_Id; begin if Nkind (Field) = N_Defining_Identifier then - -- A regular component + Ctyp := Etype (Field); + Append_To (Stmts, Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, @@ -8648,14 +8793,15 @@ package body Exp_Dist is New_Occurrence_Of (Rec, Loc), Selector_Name => New_Occurrence_Of (Field, Loc)), + Expression => - Build_From_Any_Call (Etype (Field), + Build_From_Any_Call (Ctyp, Build_Get_Aggregate_Element (Loc, Any => Any, - TC => Build_TypeCode_Call (Loc, - Etype (Field), Decls), - Idx => Make_Integer_Literal (Loc, - Counter)), + TC => + Build_TypeCode_Call (Loc, Ctyp, Decls), + Idx => + Make_Integer_Literal (Loc, Counter)), Decls))); else @@ -9105,124 +9251,11 @@ package body Exp_Dist is end if; if Use_Opaque_Representation then - - -- Default: type is represented as an opaque sequence of bytes - - declare - Strm : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - Res : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - - begin - -- Strm : Buffer_Stream_Type; - - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Strm, - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); - - -- Allocate_Buffer (Strm); - - Append_To (Stms, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Strm, Loc)))); - - -- Any_To_BS (Strm, A); - - Append_To (Stms, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Any_Parameter, Loc), - New_Occurrence_Of (Strm, Loc)))); - - if Transmit_As_Unconstrained (Typ) then - - -- declare - -- Res : constant T := T'Input (Strm); - -- begin - -- Release_Buffer (Strm); - -- return Res; - -- end; - - Append_To (Stms, Make_Block_Statement (Loc, - Declarations => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Res, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Input, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Strm, Loc), - Attribute_Name => Name_Access))))), - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Release_Buffer), Loc), - Parameter_Associations => - New_List (New_Occurrence_Of (Strm, Loc))), - - Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (Res, Loc)))))); - - else - -- declare - -- Res : T; - -- begin - -- T'Read (Strm, Res); - -- Release_Buffer (Strm); - -- return Res; - -- end; - - Append_To (Stms, Make_Block_Statement (Loc, - Declarations => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Res, - Constant_Present => False, - Object_Definition => - New_Occurrence_Of (Typ, Loc))), - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Strm, Loc), - Attribute_Name => Name_Access), - New_Occurrence_Of (Res, Loc))), - - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Release_Buffer), Loc), - Parameter_Associations => - New_List (New_Occurrence_Of (Strm, Loc))), - - Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (Res, Loc)))))); - end if; - end; + Assign_Opaque_From_Any (Loc, + Stms => Stms, + Typ => Typ, + N => New_Occurrence_Of (Any_Parameter, Loc), + Target => Empty); end if; Decl := @@ -9290,11 +9323,11 @@ package body Exp_Dist is is Loc : constant Source_Ptr := Sloc (N); - Typ : Entity_Id := Etype (N); - U_Type : Entity_Id; - C_Type : Entity_Id; - Fnam : Entity_Id := Empty; - Lib_RE : RE_Id := RE_Null; + Typ : Entity_Id := Etype (N); + U_Type : Entity_Id; + C_Type : Entity_Id; + Fnam : Entity_Id := Empty; + Lib_RE : RE_Id := RE_Null; begin -- If N is a selected component, then maybe its Etype has not been @@ -9303,6 +9336,7 @@ package body Exp_Dist is if No (Typ) and then Nkind (N) = N_Selected_Component then Typ := Etype (Selector_Name (N)); end if; + pragma Assert (Present (Typ)); -- Get full view for private type, completion for incomplete type @@ -9468,7 +9502,12 @@ package body Exp_Dist is -- opaque sequence of bytes. begin - if Is_Itype (Typ) then + -- For a derived type, we can't go past the base type (to the + -- parent type) here, because that would cause the attribute's + -- formal parameter to have the wrong type; hence the Base_Type + -- check here. + + if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then Build_To_Any_Function (Loc => Loc, Typ => Etype (Typ), @@ -9731,19 +9770,19 @@ package body Exp_Dist is Struct_Counter := 0; - TA_Append_Record_Traversal ( - Stmts => VP_Stmts, - Clist => Component_List (Variant), - Container => Struct_Any, - Counter => Struct_Counter); + TA_Append_Record_Traversal + (Stmts => VP_Stmts, + Clist => Component_List (Variant), + Container => Struct_Any, + Counter => Struct_Counter); -- Append inner struct to union aggregate Append_To (VP_Stmts, Make_Procedure_Call_Statement (Loc, Name => - New_Occurrence_Of ( - RTE (RE_Add_Aggregate_Element), Loc), + New_Occurrence_Of + (RTE (RE_Add_Aggregate_Element), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Union_Any, Loc), New_Occurrence_Of (Struct_Any, Loc)))); @@ -9753,8 +9792,8 @@ package body Exp_Dist is Append_To (VP_Stmts, Make_Procedure_Call_Statement (Loc, Name => - New_Occurrence_Of ( - RTE (RE_Add_Aggregate_Element), Loc), + New_Occurrence_Of + (RTE (RE_Add_Aggregate_Element), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Container, Loc), New_Occurrence_Of @@ -9860,8 +9899,8 @@ package body Exp_Dist is Set_Expression (Any_Decl, Make_Function_Call (Loc, - Name => New_Occurrence_Of ( - RTE (RE_Any_Aggregate_Build), Loc), + Name => New_Occurrence_Of + (RTE (RE_Any_Aggregate_Build), Loc), Parameter_Associations => New_List ( Result_TC, Make_Aggregate (Loc, @@ -10003,16 +10042,6 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); -- Generate: - -- Allocate_Buffer (Strm); - - Append_To (Stms, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Strm, Loc)))); - - -- Generate: -- T'Output (Strm'Access, E); Append_To (Stms, @@ -10605,8 +10634,15 @@ package body Exp_Dist is Type_Name_Str : String_Id; Type_Repo_Id_Str : String_Id; + -- Start of processing for Build_TypeCode_Function + begin - if Is_Itype (Typ) then + -- For a derived type, we can't go past the base type (to the + -- parent type) here, because that would cause the attribute's + -- formal parameter to have the wrong type; hence the Base_Type + -- check here. + + if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then Build_TypeCode_Function (Loc => Loc, Typ => Etype (Typ), @@ -10993,6 +11029,7 @@ package body Exp_Dist is Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Any, Loc))); + else Inner_Any_TypeCode_Expr := Make_Function_Call (Loc, @@ -11002,6 +11039,7 @@ package body Exp_Dist is New_Occurrence_Of (Any, Loc), Make_Integer_Literal (Loc, Ndim))); end if; + else Inner_Any_TypeCode_Expr := Make_Function_Call (Loc, @@ -11161,9 +11199,12 @@ package body Exp_Dist is Inst := Make_Package_Instantiation (Loc, Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('R')), + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')), + Name => New_Occurrence_Of (RTE (RE_RCI_Locator), Loc), + Generic_Associations => New_List ( Make_Generic_Association (Loc, Selector_Name => @@ -11171,6 +11212,7 @@ package body Exp_Dist is Explicit_Generic_Actual_Parameter => Make_String_Literal (Loc, Strval => Pkg_Name)), + Make_Generic_Association (Loc, Selector_Name => Make_Identifier (Loc, Name_Version), @@ -11181,8 +11223,9 @@ package body Exp_Dist is Attribute_Name => Name_Version)))); - RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec), - Defining_Unit_Name (Inst)); + RCI_Locator_Table.Set + (Defining_Unit_Name (Package_Spec), + Defining_Unit_Name (Inst)); return Inst; end RCI_Package_Locator; @@ -11292,11 +11335,11 @@ package body Exp_Dist is begin case Get_PCS_Name is when Name_PolyORB_DSA => - PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc, - Decls, RPC_Receiver, Stub_Elements); + PolyORB_Support.Add_Obj_RPC_Receiver_Completion + (Loc, Decls, RPC_Receiver, Stub_Elements); when others => - GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc, - Decls, RPC_Receiver, Stub_Elements); + GARLIC_Support.Add_Obj_RPC_Receiver_Completion + (Loc, Decls, RPC_Receiver, Stub_Elements); end case; end Specific_Add_Obj_RPC_Receiver_Completion; @@ -11470,12 +11513,14 @@ package body Exp_Dist is begin case Get_PCS_Name is when Name_PolyORB_DSA => - return PolyORB_Support.Build_Stub_Target (Loc, - Decls, RCI_Locator, Controlling_Parameter); + return + PolyORB_Support.Build_Stub_Target + (Loc, Decls, RCI_Locator, Controlling_Parameter); when others => - return GARLIC_Support.Build_Stub_Target (Loc, - Decls, RCI_Locator, Controlling_Parameter); + return + GARLIC_Support.Build_Stub_Target + (Loc, Decls, RCI_Locator, Controlling_Parameter); end case; end Specific_Build_Stub_Target; @@ -11485,24 +11530,25 @@ package body Exp_Dist is procedure Specific_Build_Stub_Type (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; + Stub_Type_Comps : out List_Id; RPC_Receiver_Decl : out Node_Id) is begin case Get_PCS_Name is when Name_PolyORB_DSA => - PolyORB_Support.Build_Stub_Type ( - RACW_Type, Stub_Type, - Stub_Type_Decl, RPC_Receiver_Decl); + PolyORB_Support.Build_Stub_Type + (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl); when others => - GARLIC_Support.Build_Stub_Type ( - RACW_Type, Stub_Type, - Stub_Type_Decl, RPC_Receiver_Decl); + GARLIC_Support.Build_Stub_Type + (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl); end case; end Specific_Build_Stub_Type; + ----------------------------------------------- + -- Specific_Build_Subprogram_Receiving_Stubs -- + ----------------------------------------------- + function Specific_Build_Subprogram_Receiving_Stubs (Vis_Decl : Node_Id; Asynchronous : Boolean; @@ -11514,22 +11560,24 @@ package body Exp_Dist is begin case Get_PCS_Name is when Name_PolyORB_DSA => - return PolyORB_Support.Build_Subprogram_Receiving_Stubs - (Vis_Decl, - Asynchronous, - Dynamically_Asynchronous, - Stub_Type, - RACW_Type, - Parent_Primitive); + return + PolyORB_Support.Build_Subprogram_Receiving_Stubs + (Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); when others => - return GARLIC_Support.Build_Subprogram_Receiving_Stubs - (Vis_Decl, - Asynchronous, - Dynamically_Asynchronous, - Stub_Type, - RACW_Type, - Parent_Primitive); + return + GARLIC_Support.Build_Subprogram_Receiving_Stubs + (Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); end case; end Specific_Build_Subprogram_Receiving_Stubs; diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index 902d4e7b593..b1a28517948 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -212,9 +212,8 @@ package body Exp_Tss is if not Is_CPP_Class (Typ) then return Node (Elmt); - -- In case of CPP classes we are searching here for the - -- default constructor and hence we must skip non-default - -- constructors (if any) + -- For CPP classes, we are looking for the default constructor, + -- and so we must skip any non-default constructor. elsif No (Next @@ -228,13 +227,13 @@ package body Exp_Tss is Next_Elmt (Elmt); end loop; - -- Non-default constructors are currently supported only in the - -- context of interfacing with C++ + -- Non-default constructors are currently supported only in the context + -- of interfacing with C++. else pragma Assert (Is_CPP_Class (Typ)); - -- Use the referenced function to locate the IP procedure that - -- corresponds with the C++ constructor + -- Use the referenced function to locate the init_proc matching + -- the C++ constructor. Elmt := First_Elmt (TSS_Elist (FN)); while Present (Elmt) loop diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index af7d0aa0d2d..bd7f90cbe39 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -255,9 +255,8 @@ package body Exp_Util is -- to reset its type, since Standard.Boolean is just fine, and -- such operations always do Adjust_Condition on their operands. - elsif KP in N_Op_Boolean - or else KP = N_And_Then - or else KP = N_Or_Else + elsif KP in N_Op_Boolean + or else KP in N_Short_Circuit or else KP = N_Op_Not then return; @@ -1351,7 +1350,18 @@ package body Exp_Util is Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type))); end if; - -- In Ada95, Nothing to be done if the type of the expression is + -- Renamings of class-wide interface types require no equivalent + -- constrained type declarations because we only need to reference + -- the tag component associated with the interface. + + elsif Present (N) + and then Nkind (N) = N_Object_Renaming_Declaration + and then Is_Interface (Unc_Type) + then + pragma Assert (Is_Class_Wide_Type (Unc_Type)); + null; + + -- In Ada95, nothing to be done if the type of the expression is -- limited, because in this case the expression cannot be copied, -- and its use can only be by reference. @@ -1372,16 +1382,6 @@ package body Exp_Util is then null; - -- For limited interfaces, nothing to be done - - -- This branch may be redundant once the limited interface issue is - -- sorted out??? - - elsif Is_Interface (Exp_Typ) - and then Is_Limited_Interface (Exp_Typ) - then - null; - -- For limited objects initialized with build in place function calls, -- nothing to be done; otherwise we prematurely introduce an N_Reference -- node in the expression initializing the object, which breaks the @@ -1547,15 +1547,10 @@ package body Exp_Util is AI : Node_Id; begin - -- Check if the interface is an immediate ancestor of the type and - -- therefore shares the main tag. + -- This routine does not handle the case in which the interface is an + -- ancestor of Typ. That case is handled by the enclosing subprogram. - if Typ = Iface then - pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); - AI_Tag := First_Tag_Component (Typ); - Found := True; - return; - end if; + pragma Assert (Typ /= Iface); -- Climb to the root type handling private types @@ -1600,6 +1595,18 @@ package body Exp_Util is begin pragma Assert (Is_Interface (Iface)); + -- Handle access types + + if Is_Access_Type (Typ) then + Typ := Directly_Designated_Type (Typ); + end if; + + -- Handle class-wide types + + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + -- Handle private types if Has_Private_Declaration (Typ) @@ -1608,10 +1615,11 @@ package body Exp_Util is Typ := Full_View (Typ); end if; - -- Handle access types + -- Handle entities from the limited view - if Is_Access_Type (Typ) then - Typ := Directly_Designated_Type (Typ); + if Ekind (Typ) = E_Incomplete_Type then + pragma Assert (Present (Non_Limited_View (Typ))); + Typ := Non_Limited_View (Typ); end if; -- Handle task and protected types implementing interfaces @@ -1620,20 +1628,20 @@ package body Exp_Util is Typ := Corresponding_Record_Type (Typ); end if; - if Is_Class_Wide_Type (Typ) then - Typ := Etype (Typ); - end if; + -- If the interface is an ancestor of the type, then it shared the + -- primary dispatch table. - -- Handle entities from the limited view + if Is_Ancestor (Iface, Typ) then + pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); + return First_Tag_Component (Typ); - if Ekind (Typ) = E_Incomplete_Type then - pragma Assert (Present (Non_Limited_View (Typ))); - Typ := Non_Limited_View (Typ); - end if; + -- Otherwise we need to search for its associated tag component - Find_Tag (Typ); - pragma Assert (Found); - return AI_Tag; + else + Find_Tag (Typ); + pragma Assert (Found); + return AI_Tag; + end if; end Find_Interface_Tag; ------------------ @@ -2303,7 +2311,7 @@ package body Exp_Util is -- Nothing special needs to be done for the left operand since -- in that case the actions are executed unconditionally. - when N_And_Then | N_Or_Else => + when N_Short_Circuit => if N = Right_Opnd (P) then -- We are now going to either append the actions to the @@ -4393,12 +4401,10 @@ package body Exp_Util is -- are side effect free. For this purpose binary operators -- include membership tests and short circuit forms - when N_Binary_Op | - N_Membership_Test | - N_And_Then | - N_Or_Else => + when N_Binary_Op | N_Membership_Test | N_Short_Circuit => return Side_Effect_Free (Left_Opnd (N)) - and then Side_Effect_Free (Right_Opnd (N)); + and then + Side_Effect_Free (Right_Opnd (N)); -- An explicit dereference is side effect free only if it is -- a side effect free prefixed reference. @@ -4582,7 +4588,7 @@ package body Exp_Util is or else Nkind (Exp) in N_Op or else (not Name_Req and then Is_Volatile_Reference (Exp))) then - Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Def_Id := Make_Temporary (Loc, New_Internal_Name ('R'), Exp); Set_Etype (Def_Id, Exp_Type); Res := New_Reference_To (Def_Id, Loc); @@ -4595,14 +4601,12 @@ package body Exp_Util is Set_Assignment_OK (E); Insert_Action (Exp, E); - Set_Related_Expression (Def_Id, Exp); -- If the expression has the form v.all then we can just capture -- the pointer, and then do an explicit dereference on the result. elsif Nkind (Exp) = N_Explicit_Dereference then - Def_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Def_Id := Make_Temporary (Loc, New_Internal_Name ('R'), Exp); Res := Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc)); @@ -4613,7 +4617,6 @@ package body Exp_Util is New_Reference_To (Etype (Prefix (Exp)), Loc), Constant_Present => True, Expression => Relocate_Node (Prefix (Exp)))); - Set_Related_Expression (Def_Id, Exp); -- Similar processing for an unchecked conversion of an expression -- of the form v.all, where we want the same kind of treatment. @@ -4647,7 +4650,7 @@ package body Exp_Util is -- Use a renaming to capture the expression, rather than create -- a controlled temporary. - Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Def_Id := Make_Temporary (Loc, New_Internal_Name ('R'), Exp); Res := New_Reference_To (Def_Id, Loc); Insert_Action (Exp, @@ -4655,10 +4658,9 @@ package body Exp_Util is Defining_Identifier => Def_Id, Subtype_Mark => New_Reference_To (Exp_Type, Loc), Name => Relocate_Node (Exp))); - Set_Related_Expression (Def_Id, Exp); else - Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Def_Id := Make_Temporary (Loc, New_Internal_Name ('R'), Exp); Set_Etype (Def_Id, Exp_Type); Res := New_Reference_To (Def_Id, Loc); @@ -4671,7 +4673,6 @@ package body Exp_Util is Set_Assignment_OK (E); Insert_Action (Exp, E); - Set_Related_Expression (Def_Id, Exp); end if; -- For expressions that denote objects, we can use a renaming scheme. @@ -4682,7 +4683,7 @@ package body Exp_Util is and then Nkind (Exp) /= N_Function_Call and then (Name_Req or else not Is_Volatile_Reference (Exp)) then - Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Def_Id := Make_Temporary (Loc, New_Internal_Name ('R'), Exp); if Nkind (Exp) = N_Selected_Component and then Nkind (Prefix (Exp)) = N_Function_Call @@ -4715,8 +4716,6 @@ package body Exp_Util is Name => Relocate_Node (Exp))); end if; - Set_Related_Expression (Def_Id, Exp); - -- If this is a packed reference, or a selected component with a -- non-standard representation, a reference to the temporary will -- be replaced by a copy of the original expression (see @@ -4737,21 +4736,22 @@ package body Exp_Util is -- Otherwise we generate a reference to the value else - -- Special processing for function calls that return a task. We need - -- to build a declaration that will enable build-in-place expansion - -- of the call. + -- Special processing for function calls that return a limited type. + -- We need to build a declaration that will enable build-in-place + -- expansion of the call. This is not done if the context is already + -- an object declaration, to prevent infinite recursion. -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have -- to accommodate functions returning limited objects by reference. if Nkind (Exp) = N_Function_Call - and then Is_Task_Type (Etype (Exp)) + and then Is_Inherently_Limited_Type (Etype (Exp)) + and then Nkind (Parent (Exp)) /= N_Object_Declaration and then Ada_Version >= Ada_05 then declare Obj : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('F')); + Make_Temporary (Loc, New_Internal_Name ('F'), Exp); Decl : Node_Id; begin @@ -4762,7 +4762,6 @@ package body Exp_Util is Expression => Relocate_Node (Exp)); Insert_Action (Exp, Decl); Set_Etype (Obj, Exp_Type); - Set_Related_Expression (Obj, Exp); Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); return; end; @@ -4782,7 +4781,7 @@ package body Exp_Util is E := Exp; Insert_Action (Exp, Ptr_Typ_Decl); - Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Def_Id := Make_Temporary (Loc, New_Internal_Name ('R'), Exp); Set_Etype (Def_Id, Exp_Type); Res := @@ -4820,7 +4819,6 @@ package body Exp_Util is Defining_Identifier => Def_Id, Object_Definition => New_Reference_To (Ref_Type, Loc), Expression => New_Exp)); - Set_Related_Expression (Def_Id, Exp); end if; -- Preserve the Assignment_OK flag in all copies, since at least diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c index aa18a339481..c11a3aa8652 100644 --- a/gcc/ada/expect.c +++ b/gcc/ada/expect.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2001-2007, AdaCore * + * Copyright (C) 2001-2009, 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- * @@ -78,42 +78,51 @@ #ifdef _WIN32 +/* We need functionality available only starting with Windows XP */ +#define _WIN32_WINNT 0x0501 + #include <windows.h> #include <process.h> +#include <signal.h> void __gnat_kill (int pid, int sig, int close) { + HANDLE h = OpenProcess (PROCESS_ALL_ACCESS, FALSE, pid); + if (h == NULL) + return; if (sig == 9) { - if ((HANDLE)pid != NULL) - { - TerminateProcess ((HANDLE)pid, 0); - if (close) - CloseHandle ((HANDLE)pid); - } - } - else if (sig == 2) - { - GenerateConsoleCtrlEvent (CTRL_C_EVENT, (HANDLE)pid); - if (close) - CloseHandle ((HANDLE)pid); + TerminateProcess (h, 0); + __gnat_win32_remove_handle (NULL, pid); } + else if (sig == SIGINT) + GenerateConsoleCtrlEvent (CTRL_C_EVENT, pid); + else if (sig == SIGBREAK) + GenerateConsoleCtrlEvent (CTRL_BREAK_EVENT, pid); + /* ??? The last two alternatives don't really work. SIGBREAK requires setting + up process groups at start time which we don't do; treating SIGINT is just + not possible apparently. So we really only support signal 9. Fortunately + that's all we use in GNAT.Expect */ + + CloseHandle (h); } int __gnat_waitpid (int pid) { + HANDLE h = OpenProcess (PROCESS_ALL_ACCESS, FALSE, pid); DWORD exitcode = 1; DWORD res; - if ((HANDLE)pid != NULL) + if (h != NULL) { - res = WaitForSingleObject ((HANDLE)pid, INFINITE); - GetExitCodeProcess ((HANDLE)pid, &exitcode); - CloseHandle ((HANDLE)pid); + res = WaitForSingleObject (h, INFINITE); + GetExitCodeProcess (h, &exitcode); + CloseHandle (h); } + __gnat_win32_remove_handle (NULL, pid); return (int) exitcode; } @@ -126,61 +135,7 @@ __gnat_expect_fork (void) void __gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[]) { - BOOL result; - STARTUPINFO SI; - PROCESS_INFORMATION PI; - SECURITY_ATTRIBUTES SA; - int csize = 1; - char *full_command; - int k; - - /* compute the total command line length. */ - k = 0; - while (argv[k]) - { - csize += strlen (argv[k]) + 1; - k++; - } - - full_command = (char *) malloc (csize); - full_command[0] = '\0'; - - /* Startup info. */ - SI.cb = sizeof (STARTUPINFO); - SI.lpReserved = NULL; - SI.lpReserved2 = NULL; - SI.lpDesktop = NULL; - SI.cbReserved2 = 0; - SI.lpTitle = NULL; - SI.dwFlags = 0; - SI.wShowWindow = SW_HIDE; - - /* Security attributes. */ - SA.nLength = sizeof (SECURITY_ATTRIBUTES); - SA.bInheritHandle = TRUE; - SA.lpSecurityDescriptor = NULL; - - k = 0; - while (argv[k]) - { - strcat (full_command, argv[k]); - strcat (full_command, " "); - k++; - } - - result = CreateProcess - (NULL, (char *) full_command, &SA, NULL, TRUE, - GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI); - - free (full_command); - - if (result == TRUE) - { - CloseHandle (PI.hThread); - *pid = (int) PI.hProcess; - } - else - *pid = -1; + *pid = __gnat_portable_no_block_spawn (argv); } int diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index e66dc14f101..302b4317306 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1111,19 +1111,30 @@ package body Freeze is end loop; end Check_Unsigned_Type; - ----------------------------- - -- Expand_Atomic_Aggregate -- - ----------------------------- + ------------------------- + -- Is_Atomic_Aggregate -- + ------------------------- - procedure Expand_Atomic_Aggregate (E : Entity_Id; Typ : Entity_Id) is + function Is_Atomic_Aggregate + (E : Entity_Id; + Typ : Entity_Id) return Boolean + is Loc : constant Source_Ptr := Sloc (E); New_N : Node_Id; + Par : Node_Id; Temp : Entity_Id; begin - if (Nkind (Parent (E)) = N_Object_Declaration - or else Nkind (Parent (E)) = N_Assignment_Statement) - and then Comes_From_Source (Parent (E)) + Par := Parent (E); + + -- Array may be qualified, so find outer context + + if Nkind (Par) = N_Qualified_Expression then + Par := Parent (Par); + end if; + + if Nkind_In (Par, N_Object_Declaration, N_Assignment_Statement) + and then Comes_From_Source (Par) then Temp := Make_Defining_Identifier (Loc, @@ -1134,13 +1145,16 @@ package body Freeze is Defining_Identifier => Temp, Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Relocate_Node (E)); - Insert_Before (Parent (E), New_N); + Insert_Before (Par, New_N); Analyze (New_N); - Set_Expression (Parent (E), New_Occurrence_Of (Temp, Loc)); + Set_Expression (Par, New_Occurrence_Of (Temp, Loc)); + return True; + else + return False; end if; - end Expand_Atomic_Aggregate; + end Is_Atomic_Aggregate; ---------------- -- Freeze_All -- @@ -1441,6 +1455,11 @@ package body Freeze is -- which is the current instance type can only be applied when the type -- is limited. + procedure Check_Suspicious_Modulus (Utype : Entity_Id); + -- Give warning for modulus of 8, 16, 32, or 64 given as an explicit + -- integer literal without an explicit corresponding size clause. The + -- caller has checked that Utype is a modular integer type. + function After_Last_Declaration return Boolean; -- If Loc is a freeze_entity that appears after the last declaration -- in the scope, inhibit error messages on late completion. @@ -1454,7 +1473,7 @@ package body Freeze is ---------------------------- function After_Last_Declaration return Boolean is - Spec : constant Node_Id := Parent (Current_Scope); + Spec : constant Node_Id := Parent (Current_Scope); begin if Nkind (Spec) = N_Package_Specification then if Present (Private_Declarations (Spec)) then @@ -1519,9 +1538,7 @@ package body Freeze is -- either a tagged type, or a limited record. if Is_Limited_Type (Rec_Type) - and then - (Ada_Version < Ada_05 - or else Is_Tagged_Type (Rec_Type)) + and then (Ada_Version < Ada_05 or else Is_Tagged_Type (Rec_Type)) then return; @@ -1535,6 +1552,76 @@ package body Freeze is end if; end Check_Current_Instance; + ------------------------------ + -- Check_Suspicious_Modulus -- + ------------------------------ + + procedure Check_Suspicious_Modulus (Utype : Entity_Id) is + Decl : constant Node_Id := Declaration_Node (Underlying_Type (Utype)); + + begin + if Nkind (Decl) = N_Full_Type_Declaration then + declare + Tdef : constant Node_Id := Type_Definition (Decl); + begin + if Nkind (Tdef) = N_Modular_Type_Definition then + declare + Modulus : constant Node_Id := + Original_Node (Expression (Tdef)); + begin + if Nkind (Modulus) = N_Integer_Literal then + declare + Modv : constant Uint := Intval (Modulus); + Sizv : constant Uint := RM_Size (Utype); + + begin + -- First case, modulus and size are the same. This + -- happens if you have something like mod 32, with + -- an explicit size of 32, this is for sure a case + -- where the warning is given, since it is seems + -- very unlikely that someone would want e.g. a + -- five bit type stored in 32 bits. It is much + -- more likely they wanted a 32-bit type. + + if Modv = Sizv then + null; + + -- Second case, the modulus is 32 or 64 and no + -- size clause is present. This is a less clear + -- case for giving the warning, but in the case + -- of 32/64 (5-bit or 6-bit types) these seem rare + -- enough that it is a likely error (and in any + -- case using 2**5 or 2**6 in these cases seems + -- clearer. We don't include 8 or 16 here, simply + -- because in practice 3-bit and 4-bit types are + -- more common and too many false positives if + -- we warn in these cases. + + elsif not Has_Size_Clause (Utype) + and then (Modv = Uint_32 or else Modv = Uint_64) + then + null; + + -- No warning needed + + else + return; + end if; + + -- If we fall through, give warning + + Error_Msg_Uint_1 := Modv; + Error_Msg_N + ("?2 '*'*^' may have been intended here", + Modulus); + end; + end if; + end; + end if; + end; + end if; + end Check_Suspicious_Modulus; + ------------------------ -- Freeze_Record_Type -- ------------------------ @@ -2351,15 +2438,17 @@ package body Freeze is and then Nkind (Parent (E)) = N_Object_Declaration and then Present (Expression (Parent (E))) and then Nkind (Expression (Parent (E))) = N_Aggregate + and then + Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E)) then - Expand_Atomic_Aggregate (Expression (Parent (E)), Etype (E)); + null; end if; -- For a subprogram, freeze all parameter types and also the return -- type (RM 13.14(14)). However skip this for internal subprograms. -- This is also the point where any extra formal parameters are - -- created since we now know whether the subprogram will use - -- a foreign convention. + -- created since we now know whether the subprogram will use a + -- foreign convention. if Is_Subprogram (E) then if not Is_Internal (E) then @@ -2385,12 +2474,10 @@ package body Freeze is -- If the type of a formal is incomplete, subprogram -- is being frozen prematurely. Within an instance -- (but not within a wrapper package) this is an - -- an artifact of our need to regard the end of an + -- artifact of our need to regard the end of an -- instantiation as a freeze point. Otherwise it is -- a definite error. - -- and then not Is_Wrapper_Package (Current_Scope) ??? - if In_Instance then Set_Is_Frozen (E, False); return No_List; @@ -3605,6 +3692,12 @@ package body Freeze is elsif Is_Integer_Type (E) then Adjust_Esize_For_Alignment (E); + if Is_Modular_Integer_Type (E) + and then Warn_On_Suspicious_Modulus_Value + then + Check_Suspicious_Modulus (E); + end if; + elsif Is_Access_Type (E) then -- Check restriction for standard storage pool diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index 1afec171845..f78321057c9 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -175,12 +175,17 @@ package Freeze is -- do not allow a size clause if the size would not otherwise be known at -- compile time in any case. - procedure Expand_Atomic_Aggregate (E : Entity_Id; Typ : Entity_Id); + function Is_Atomic_Aggregate + (E : Entity_Id; + Typ : Entity_Id) return Boolean; + -- If an atomic object is initialized with an aggregate or is assigned -- an aggregate, we have to prevent a piecemeal access or assignment -- to the object, even if the aggregate is to be expanded. We create -- a temporary for the aggregate, and assign the temporary instead, - -- so that the back end can generate an atomic move for it. + -- so that the back end can generate an atomic move for it. This is + -- only done in the context of an object declaration or an assignment. + -- Function is a noop and returns false in other contexts. function Freeze_Entity (E : Entity_Id; Loc : Source_Ptr) return List_Id; -- Freeze an entity, and return Freeze nodes, to be inserted at the diff --git a/gcc/ada/g-calend.adb b/gcc/ada/g-calend.adb index 8ccd4337b61..46d647f8af3 100644 --- a/gcc/ada/g-calend.adb +++ b/gcc/ada/g-calend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2008, AdaCore -- +-- Copyright (C) 1999-2009, 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- -- @@ -182,12 +182,7 @@ package body GNAT.Calendar is begin Split (Date, Year, Month, Day, Day_Secs); - if Day_Secs = 0.0 then - Secs := 0; - else - Secs := Natural (Day_Secs - 0.5); - end if; - + Secs := (if Day_Secs = 0.0 then 0 else Natural (Day_Secs - 0.5)); Sub_Second := Second_Duration (Day_Secs - Day_Duration (Secs)); Hour := Hour_Number (Secs / 3_600); Secs := Secs mod 3_600; @@ -370,18 +365,9 @@ package body GNAT.Calendar is begin if Last_Year then - if Is_Leap (Year - 1) then - Shift := -2; - else - Shift := -1; - end if; - + Shift := (if Is_Leap (Year - 1) then -2 else -1); elsif Next_Year then - if Is_Leap (Year) then - Shift := 2; - else - Shift := 1; - end if; + Shift := (if Is_Leap (Year) then 2 else 1); end if; return Day_Name'Val ((Day_Name'Pos (Jan_1) + Shift) mod 7); @@ -452,11 +438,11 @@ package body GNAT.Calendar is -- when special casing the first week of January and the last week of -- December. - if Day = 1 and then Month = 1 then - Jan_1 := Day_Of_Week (Date); - else - Jan_1 := Day_Of_Week (Time_Of (Year, 1, 1, 0.0)); - end if; + Jan_1 := Day_Of_Week (if Day = 1 and then Month = 1 + then Date + else (Time_Of (Year, 1, 1, 0.0))); + + -- Special cases for January if Month = 1 then @@ -479,11 +465,7 @@ package body GNAT.Calendar is or else (Day = 3 and then Jan_1 = Friday) then - if Last_Year_Has_53_Weeks (Jan_1, Year) then - Week := 53; - else - Week := 52; - end if; + Week := (if Last_Year_Has_53_Weeks (Jan_1, Year) then 53 else 52); -- January 1, 2 and 3 belong to the previous year @@ -516,6 +498,8 @@ package body GNAT.Calendar is return; end if; + -- Month other than 1 + -- Special case 3: December 29, 30 and 31. These days may belong to -- next year's first week. @@ -551,11 +535,7 @@ package body GNAT.Calendar is -- not belong to the first week of the input year, then the next week -- is the first week. - if Jan_1 in Friday .. Sunday then - Start_Week := 1; - else - Start_Week := 2; - end if; + Start_Week := (if Jan_1 in Friday .. Sunday then 1 else 2); -- At this point all special combinations have been accounted for and -- the proper start week has been found. Since January 1 may not fall diff --git a/gcc/ada/g-catiio.adb b/gcc/ada/g-catiio.adb index 469d1c18a93..66a6480b38d 100644 --- a/gcc/ada/g-catiio.adb +++ b/gcc/ada/g-catiio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2008, AdaCore -- +-- Copyright (C) 1999-2009, 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- -- @@ -471,15 +471,11 @@ package body GNAT.Calendar.Time_IO is when 'w' => declare - DOW : Natural range 0 .. 6; - + DOW : constant Natural range 0 .. 6 := + (if Day_Of_Week (Date) = Sunday + then 0 + else Day_Name'Pos (Day_Of_Week (Date))); begin - if Day_Of_Week (Date) = Sunday then - DOW := 0; - else - DOW := Day_Name'Pos (Day_Of_Week (Date)); - end if; - Result := Result & Image (DOW, Length => 1); end; diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 22c28ec5ded..badebbca599 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -1150,11 +1150,7 @@ package body GNAT.Sockets is -- Start of processing for Image begin - if Hex then - Separator := ':'; - else - Separator := '.'; - end if; + Separator := (if Hex then ':' else '.'); for J in Val'Range loop if Hex then @@ -1592,6 +1588,7 @@ package body GNAT.Sockets is -- Last is set to Stream_Element_Offset'Last. Last := Ada.Streams.Stream_Element_Offset'Last; + else Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); end if; @@ -1873,6 +1870,7 @@ package body GNAT.Sockets is -- Last is set to Stream_Element_Offset'Last. Last := Ada.Streams.Stream_Element_Offset'Last; + else Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); end if; @@ -1904,11 +1902,10 @@ package body GNAT.Sockets is pragma Warnings (Off); -- Following test may be compile time known on some targets - if Vector'Length - Iov_Count > SOSC.IOV_MAX then - This_Iov_Count := SOSC.IOV_MAX; - else - This_Iov_Count := Vector'Length - Iov_Count; - end if; + This_Iov_Count := + (if Vector'Length - Iov_Count > SOSC.IOV_MAX + then SOSC.IOV_MAX + else Vector'Length - Iov_Count); pragma Warnings (On); diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb index 67e6c25eeb8..96d0cfca7a3 100644 --- a/gcc/ada/g-socthi-vxworks.adb +++ b/gcc/ada/g-socthi-vxworks.adb @@ -108,6 +108,13 @@ package body GNAT.Sockets.Thin is Flags : C.int) return C.int; pragma Import (C, Syscall_Sendmsg, "sendmsg"); + function Syscall_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Send, "send"); + function Syscall_Sendto (S : C.int; Msg : System.Address; @@ -355,11 +362,26 @@ package body GNAT.Sockets.Thin is To : System.Address; Tolen : C.int) return C.int is + use System; + Res : C.int; begin loop - Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); + if To = Null_Address then + + -- In violation of the standard sockets API, VxWorks does not + -- support sendto(2) calls on connected sockets with a null + -- destination address, so use send(2) instead in that case. + + Res := Syscall_Send (S, Msg, Len, Flags); + + -- Normal case where destination address is non-null + + else + Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); + end if; + exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 423d1972385..0f4082a7c2b 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -714,6 +714,7 @@ install-gnatlib-obj: $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib-obj ada.install-man: +ada.install-plugin: ada.uninstall: -$(RM) $(DESTDIR)$(bindir)/gnatbind$(exeext) @@ -1430,7 +1431,7 @@ ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/unchdeal.ads ada/urealp.ads ada/csets.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/csets.ads \ - ada/csets.adb ada/debug.ads ada/hostparm.ads ada/opt.ads ada/system.ads \ + ada/csets.adb ada/hostparm.ads ada/opt.ads ada/system.ads \ ada/s-exctab.ads ada/s-stalib.ads ada/s-string.ads ada/s-unstyp.ads \ ada/s-wchcon.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads @@ -1438,28 +1439,28 @@ ada/cstand.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/cstand.ads \ ada/cstand.adb ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_disp.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/interfac.ads ada/layout.ads ada/lib.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_mech.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/layout.ads ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypef.ads ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/widechar.ads ada/debug.o : ada/debug.ads ada/debug.adb ada/system.ads @@ -1617,33 +1618,33 @@ ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_attr.ads ada/exp_attr.adb ada/exp_ch2.ads ada/exp_ch3.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_imgv.ads ada/exp_pakd.ads ada/exp_strm.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/validsw.ads ada/widechar.ads + ada/exp_attr.ads ada/exp_attr.adb ada/exp_ch11.ads ada/exp_ch2.ads \ + ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads \ + ada/exp_disp.ads ada/exp_dist.ads ada/exp_imgv.ads ada/exp_pakd.ads \ + ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/exp_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1922,29 +1923,29 @@ ada/exp_code.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/eval_fat.ads ada/exp_code.ads ada/exp_code.adb \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/widechar.ads + ada/erroutc.ads ada/eval_fat.ads ada/exp_ch11.ads ada/exp_code.ads \ + ada/exp_code.adb ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/exp_dbug.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1968,19 +1969,19 @@ ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads \ - ada/exp_disp.adb ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads \ - ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/itypes.ads ada/layout.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads \ + ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads ada/exp_tss.adb \ + ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/layout.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ @@ -1996,25 +1997,25 @@ ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/elists.adb ada/exp_atag.ads ada/exp_dist.ads ada/exp_dist.adb \ - ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \ - ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_dist.ads \ - ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads + ada/elists.adb ada/exp_atag.ads ada/exp_disp.ads ada/exp_dist.ads \ + ada/exp_dist.adb ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \ + ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch8.ads \ + ada/sem_dist.ads ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/exp_fixd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2295,33 +2296,33 @@ ada/freeze.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_aggr.ads ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/expander.ads ada/fname.ads ada/freeze.ads \ - ada/freeze.adb ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/layout.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch13.ads ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_mech.ads \ - ada/sem_prag.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch3.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ + ada/freeze.ads ada/freeze.adb ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch4.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/frontend.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2396,16 +2397,17 @@ ada/gnat1drv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch9.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_prag.ads \ ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-assert.ads ada/s-bitops.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_gen.ads ada/tree_io.ads \ - ada/treepr.ads ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/usage.ads ada/widechar.ads + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stylesw.ads \ + ada/system.ads ada/s-assert.ads ada/s-bitops.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_gen.ads \ + ada/tree_io.ads ada/treepr.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/usage.ads ada/validsw.ads \ + ada/widechar.ads ada/gnatbind.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/ali.ads \ @@ -2511,28 +2513,28 @@ ada/layout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_ch3.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ - ada/layout.ads ada/layout.adb ada/lib.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/repinfo.ads \ - ada/repinfo.adb ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch13.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/erroutc.ads ada/exp_ch11.ads ada/exp_ch3.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/interfac.ads ada/layout.ads ada/layout.adb ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/repinfo.ads ada/repinfo.adb ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch13.ads \ + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/lib-load.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2682,12 +2684,12 @@ ada/nmake.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/urealp.ads ada/opt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/debug.ads ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/opt.adb \ - ada/system.ads ada/s-exctab.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads + ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/opt.adb ada/system.ads \ + ada/s-exctab.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/osint-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ @@ -3166,14 +3168,14 @@ ada/sem_cat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ + ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads \ + ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch8.ads ada/sem_eval.ads \ ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ @@ -3192,31 +3194,31 @@ ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/impunit.ads ada/inline.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch10.adb \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_dist.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/impunit.ads ada/inline.ads \ + ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch10.ads \ + ada/sem_ch10.adb ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3242,11 +3244,11 @@ ada/sem_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_disp.ads \ + ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ @@ -3349,32 +3351,32 @@ ada/sem_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/expander.ads ada/fname.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch4.adb ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/namet-sp.ads \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch4.adb \ + ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads \ + ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3414,12 +3416,12 @@ ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_ch6.ads ada/exp_ch7.ads \ - ada/exp_ch9.ads ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/layout.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_ch6.ads \ + ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/expander.ads ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ @@ -3448,15 +3450,15 @@ ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_dbug.ads ada/exp_disp.ads \ - ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_dbug.ads \ + ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads \ + ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch3.ads \ ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch7.adb ada/sem_ch8.ads \ ada/sem_disp.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads \ @@ -3479,33 +3481,33 @@ ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/expander.ads ada/fname.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ - ada/hostparm.ads ada/impunit.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/namet-sp.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_ch8.adb ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ + ada/g-htable.ads ada/hostparm.ads ada/impunit.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch12.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_ch8.adb ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads \ + ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3545,12 +3547,12 @@ ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads \ - ada/exp_disp.adb ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads \ + ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads ada/exp_util.ads \ + ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/layout.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ @@ -3592,30 +3594,30 @@ ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/expander.ads ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_elab.ads ada/sem_elab.adb ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_elab.ads ada/sem_elab.adb \ + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3639,11 +3641,11 @@ ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ @@ -3702,38 +3704,38 @@ ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ - ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-writ.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/namet-sp.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads ada/sem_prag.adb \ - ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_vfpt.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/snames.adb ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ - ada/widechar.ads + ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch12.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ + ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \ + ada/sem_mech.ads ada/sem_prag.ads ada/sem_prag.adb ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_vfpt.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/snames.adb ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/validsw.ads ada/widechar.ads ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3790,18 +3792,18 @@ ada/sem_type.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ - ada/errout.ads ada/erroutc.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ - ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads \ - ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_ch12.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ - ada/sem_type.adb ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/opt.ads ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_ch12.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_res.ads \ + ada/sem_type.ads ada/sem_type.adb ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ @@ -3818,30 +3820,30 @@ ada/sem_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/casing.adb ada/checks.ads ada/csets.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ - ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ - ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ - ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-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/widechar.ads + ada/exp_ch11.ads ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-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/widechar.ads ada/sem_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3861,14 +3863,14 @@ ada/sem_warn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_code.ads ada/exp_disp.ads ada/exp_tss.ads \ - ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ - ada/interfac.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/erroutc.ads ada/exp_ch11.ads ada/exp_code.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ + ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads \ + ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb \ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ @@ -4026,10 +4028,10 @@ ada/styleg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/stylesw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/debug.ads ada/hostparm.ads ada/opt.ads ada/stylesw.ads \ - ada/stylesw.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads + ada/hostparm.ads ada/opt.ads ada/stylesw.ads ada/stylesw.adb \ + ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/switch-b.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/gnatvsn.ads \ @@ -4217,18 +4219,17 @@ ada/usage.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/unchconv.ads ada/unchdeal.ads ada/usage.ads ada/usage.adb ada/validsw.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads \ - ada/debug.ads ada/hostparm.ads ada/opt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-stalib.ads ada/s-string.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/validsw.ads ada/validsw.adb + ada/hostparm.ads ada/opt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/validsw.ads \ + ada/validsw.adb ada/widechar.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/debug.ads ada/hostparm.ads ada/interfac.ads \ - ada/opt.ads ada/system.ads ada/s-exctab.ads ada/s-parame.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcnv.ads ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads \ - ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads \ - ada/widechar.adb + ada/a-uncdea.ads ada/hostparm.ads ada/interfac.ads ada/opt.ads \ + ada/system.ads ada/s-exctab.ads ada/s-parame.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcnv.ads \ + ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads ada/widechar.adb # end of regular dependencies diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 35ea1e32aa8..9ec41afa8ba 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -295,6 +295,7 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o s-casuti.o \ make.o makeusg.o makeutl.o mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o \ mlib-tgt-specific.o mlib-utl.o namet.o nlists.o opt.o osint.o osint-m.o \ output.o prj.o prj-attr.o prj-attr-pm.o prj-com.o prj-dect.o prj-env.o \ + prj-conf.o prj-pp.o \ prj-err.o prj-ext.o prj-nmsc.o prj-pars.o prj-part.o prj-proc.o prj-strt.o \ prj-tree.o prj-util.o rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \ scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o sinfo.o sinput.o \ diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index 8d157224f29..8983139815c 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -165,13 +165,14 @@ do { \ /* True if TYPE can alias any other types. */ #define TYPE_UNIVERSAL_ALIASING_P(NODE) TYPE_LANG_FLAG_6 (NODE) -/* This field is only defined for FUNCTION_TYPE nodes. If the Ada subprogram - contains no parameters passed by copy in/copy out then this field is zero. - Otherwise it points to a list of nodes used to specify the return values - of the out (or in out) parameters that qualify to be passed by copy in/ - copy out. For a full description of the copy in/copy out parameter passing - mechanism refer to the routine gnat_to_gnu_entity. */ -#define TYPE_CI_CO_LIST(NODE) TYPE_LANG_SLOT_1 (FUNCTION_TYPE_CHECK (NODE)) +/* In an UNCONSTRAINED_ARRAY_TYPE, this is the record containing both the + template and the object. + + ??? We also put this on an ENUMERAL_TYPE that is dummy. Technically, + this is a conflict on the minval field, but there doesn't seem to be + simple fix, so we'll live with this kludge for now. */ +#define TYPE_OBJECT_RECORD_TYPE(NODE) \ + (TREE_CHECK2 ((NODE), UNCONSTRAINED_ARRAY_TYPE, ENUMERAL_TYPE)->type.minval) /* For numerical types, this is the GCC lower bound of the type. The GCC type system is based on the invariant that an object X of a given type @@ -187,6 +188,13 @@ do { \ considers that the assertion X <= UB is always true. */ #define TYPE_GCC_MAX_VALUE(NODE) (NUMERICAL_TYPE_CHECK (NODE)->type.maxval) +/* For a FUNCTION_TYPE, if the subprogram has parameters passed by copy in/ + copy out, this is the list of nodes used to specify the return values of + the out (or in out) parameters that are passed by copy in/copy out. For + a full description of the copy in/copy out parameter passing mechanism + refer to the routine gnat_to_gnu_entity. */ +#define TYPE_CI_CO_LIST(NODE) TYPE_LANG_SLOT_1 (FUNCTION_TYPE_CHECK (NODE)) + /* For numerical types, this holds various RM-defined values. */ #define TYPE_RM_VALUES(NODE) TYPE_LANG_SLOT_1 (NUMERICAL_TYPE_CHECK (NODE)) @@ -256,15 +264,6 @@ do { \ (TYPE_RM_MAX_VALUE (NODE) \ ? TYPE_RM_MAX_VALUE (NODE) : TYPE_GCC_MAX_VALUE (NODE)) -/* In an UNCONSTRAINED_ARRAY_TYPE, points to the record containing both - the template and object. - - ??? We also put this on an ENUMERAL_TYPE that's dummy. Technically, - this is a conflict on the minval field, but there doesn't seem to be - simple fix, so we'll live with this kludge for now. */ -#define TYPE_OBJECT_RECORD_TYPE(NODE) \ - (TREE_CHECK2 ((NODE), UNCONSTRAINED_ARRAY_TYPE, ENUMERAL_TYPE)->type.minval) - /* For an INTEGER_TYPE with TYPE_MODULAR_P, this is the value of the modulus. */ #define TYPE_MODULUS(NODE) GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) @@ -293,7 +292,7 @@ do { \ #define SET_TYPE_ACTUAL_BOUNDS(NODE, X) \ SET_TYPE_LANG_SPECIFIC (TREE_CHECK2 (NODE, INTEGER_TYPE, ARRAY_TYPE), X) -/* For a RECORD_TYPE that is a fat pointer, point to the type for the +/* For a RECORD_TYPE that is a fat pointer, this is the type for the unconstrained object. Likewise for a RECORD_TYPE that is pointed to by a thin pointer. */ #define TYPE_UNCONSTRAINED_ARRAY(NODE) \ @@ -301,9 +300,9 @@ do { \ #define SET_TYPE_UNCONSTRAINED_ARRAY(NODE, X) \ SET_TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE), X) -/* For other RECORD_TYPEs and all UNION_TYPEs and QUAL_UNION_TYPEs, the Ada - size of the object. This differs from the GCC size in that it does not - include any rounding up to the alignment of the type. */ +/* For other RECORD_TYPEs and all UNION_TYPEs and QUAL_UNION_TYPEs, this is + the Ada size of the object. This differs from the GCC size in that it + does not include any rounding up to the alignment of the type. */ #define TYPE_ADA_SIZE(NODE) \ GET_TYPE_LANG_SPECIFIC (RECORD_OR_UNION_CHECK (NODE)) #define SET_TYPE_ADA_SIZE(NODE, X) \ diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 42086128cd7..67d8cd1b0c4 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -905,6 +905,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) mark_visited (&gnu_decl); save_gnu_tree (gnat_entity, gnu_decl, true); saved = true; + annotate_object (gnat_entity, gnu_type, NULL_TREE, + false); break; } @@ -1382,32 +1384,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && Exception_Mechanism != Back_End_Exceptions) TREE_ADDRESSABLE (gnu_decl) = 1; - gnu_type = TREE_TYPE (gnu_decl); - - /* Back-annotate Alignment and Esize of the object if not already - known, except for when the object is actually a pointer to the - real object, since alignment and size of a pointer don't have - anything to do with those of the designated object. Note that - we pick the values of the type, not those of the object, to - shield ourselves from low-level platform-dependent adjustments - like alignment promotion. This is both consistent with all the - treatment above, where alignment and size are set on the type of - the object and not on the object directly, and makes it possible - to support confirming representation clauses in all cases. */ - - if (!used_by_ref && Unknown_Alignment (gnat_entity)) - Set_Alignment (gnat_entity, - UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); - - if (!used_by_ref && Unknown_Esize (gnat_entity)) - { - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) - gnu_object_size - = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))); - - Set_Esize (gnat_entity, annotate_value (gnu_object_size)); - } + /* Back-annotate Esize and Alignment of the object if not already + known. Note that we pick the values of the type, not those of + the object, to shield ourselves from low-level platform-dependent + adjustments like alignment promotion. This is both consistent with + all the treatment above, where alignment and size are set on the + type of the object and not on the object directly, and makes it + possible to support all confirming representation clauses. */ + annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size, + used_by_ref); } break; @@ -7223,6 +7208,39 @@ annotate_value (tree gnu_size) return ret; } +/* Given GNAT_ENTITY, an object (constant, variable, parameter, exception) + and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the + size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null. + BY_REF is true if the object is used by reference. */ + +void +annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref) +{ + if (by_ref) + { + if (TYPE_FAT_POINTER_P (gnu_type)) + gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type); + else + gnu_type = TREE_TYPE (gnu_type); + } + + if (Unknown_Esize (gnat_entity)) + { + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + size = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))); + else if (!size) + size = TYPE_SIZE (gnu_type); + + if (size) + Set_Esize (gnat_entity, annotate_value (size)); + } + + if (Unknown_Alignment (gnat_entity)) + Set_Alignment (gnat_entity, + UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); +} + /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type, set Component_Bit_Offset and Esize to the position and size used by Gigi. */ diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 7bc89eef6fd..de253b8d939 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -135,6 +135,13 @@ extern tree maybe_pad_type (tree type, tree size, unsigned int align, the value passed against the list of choices. */ extern tree choices_to_gnu (tree operand, Node_Id choices); +/* Given GNAT_ENTITY, an object (constant, variable, parameter, exception) + and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the + size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null. + BY_REF is true if the object is used by reference. */ +extern void annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, + bool by_ref); + /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new type with all size expressions that contain F updated by replacing F with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index fb306206fc1..587eab3379e 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -470,17 +470,17 @@ gnat_print_decl (FILE *file, tree node, int indent) switch (TREE_CODE (node)) { case CONST_DECL: - print_node (file, "const_corresponding_var", + print_node (file, "corresponding var", DECL_CONST_CORRESPONDING_VAR (node), indent + 4); break; case FIELD_DECL: - print_node (file, "original_field", DECL_ORIGINAL_FIELD (node), + print_node (file, "original field", DECL_ORIGINAL_FIELD (node), indent + 4); break; case VAR_DECL: - print_node (file, "renamed_object", DECL_RENAMED_OBJECT (node), + print_node (file, "renamed object", DECL_RENAMED_OBJECT (node), indent + 4); break; @@ -497,7 +497,7 @@ gnat_print_type (FILE *file, tree node, int indent) switch (TREE_CODE (node)) { case FUNCTION_TYPE: - print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4); + print_node (file, "ci/co list", TYPE_CI_CO_LIST (node), indent + 4); break; case INTEGER_TYPE: diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 76200ab34a9..5b4e5e86318 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -2328,13 +2328,18 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) end_subprog_body (gnu_result, false); - /* Disconnect the trees for parameters that we made variables for from the - GNAT entities since these are unusable after we end the function. */ + /* Finally annotate the parameters and disconnect the trees for parameters + that we have turned into variables since they are now unusable. */ for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); Present (gnat_param); gnat_param = Next_Formal_With_Extras (gnat_param)) - if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL) - save_gnu_tree (gnat_param, NULL_TREE, false); + { + tree gnu_param = get_gnu_tree (gnat_param); + annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE, + DECL_BY_REF_P (gnu_param)); + if (TREE_CODE (gnu_param) == VAR_DECL) + save_gnu_tree (gnat_param, NULL_TREE, false); + } if (DECL_FUNCTION_STUB (gnu_subprog_decl)) build_function_stub (gnu_subprog_decl, gnat_subprog_id); diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index b5a3354323e..c8d9cb35b73 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -61,6 +61,7 @@ with Sinput.L; use Sinput.L; with Snames; with Sprint; use Sprint; with Stringt; +with Stylesw; use Stylesw; with Targparm; use Targparm; with Tree_Gen; with Treepr; use Treepr; @@ -70,6 +71,7 @@ with Uintp; use Uintp; with Uname; use Uname; with Urealp; with Usage; +with Validsw; use Validsw; with System.Assertions; @@ -108,6 +110,11 @@ procedure Gnat1drv is procedure Adjust_Global_Switches is begin + -- Debug flag -gnatd.I is a synonym of Generate_SCIL + + if Debug_Flag_Dot_II then + Generate_SCIL := True; + end if; -- Set ASIS mode if -gnatt and -gnatc are set @@ -117,23 +124,106 @@ procedure Gnat1drv is -- Turn off inlining in ASIS mode, since ASIS cannot handle the extra -- information in the trees caused by inlining being active. - -- More specifically, the tree seems to malformed from the ASIS point - -- of view if -gnatc and -gnatn appear together ??? + -- More specifically, the tree seems to be malformed from the ASIS + -- point of view if -gnatc and -gnatn appear together??? Inline_Active := False; - -- Turn off inspector mode in ASIS mode. For reasons that need - -- clearer documentation, Inspector cannot function in this mode ??? + -- Turn off SCIL generation in ASIS mode, since SCIL requires front- + -- end expansion. - Inspector_Mode := False; + Generate_SCIL := False; end if; - -- Inspeector mode requires back-end rep info and also needs to disable - -- front-end inlining (but -gnatn does not need to be disabled). + -- SCIL mode needs to disable front-end inlining since the generated + -- trees (in particular order and consistency between specs compiled + -- as part of a main unit or as part of a with-clause) are causing + -- troubles. + + if Generate_SCIL then + Front_End_Inlining := False; + end if; + + -- Tune settings for optimal SCIL generation in CodePeer_Mode + + if CodePeer_Mode then + + -- Turn off inlining, confuses CodePeer output and gains nothing - if Inspector_Mode then - Back_Annotate_Rep_Info := True; Front_End_Inlining := False; + Inline_Active := False; + + -- Turn off ASIS mode: incompatible with front-end expansion. + + ASIS_Mode := False; + + -- Turn off dynamic elaboration checks: generates inconsitencies in + -- trees between specs compiled as part of a main unit or as part of + -- a with-clause. + + Dynamic_Elaboration_Checks := False; + + -- Suppress overflow checks since this is handled implicitely by + -- CodePeer. Enable all other language checks. + + Suppress_Options := (Overflow_Check => True, others => False); + Enable_Overflow_Checks := False; + + -- Kill debug of generated code, since it messes up sloc values + + Debug_Generated_Code := False; + + -- Turn cross-referencing on in case it was disabled (by e.g. -gnatD) + -- Do we really need to spend time generating xref in CodePeer + -- mode??? Consider setting Xref_Active to False. + + Xref_Active := True; + + -- Polling mode forced off, since it generates confusing junk + + Polling_Required := False; + + -- Set operating mode to check semantics with full front-end + -- expansion, but no back-end code generation. + + Operating_Mode := Check_Semantics; + Debug_Flag_X := True; + + -- We need SCIL generation of course + + Generate_SCIL := True; + + -- Enable assertions and debug pragmas, since they give CodePeer + -- valuable extra information. + + Assertions_Enabled := True; + Debug_Pragmas_Enabled := True; + + -- Suppress compiler warnings, since what we are interested in here + -- is what CodePeer can find out. Also disable all simple value + -- propagation. This is an optimization which is valuable for code + -- optimization, and also for generation of compiler warnings, but + -- these are being turned off anyway, and CodePeer understands + -- things more clearly if references are not optimized in this way. + + Warning_Mode := Suppress; + Debug_Flag_MM := True; + + -- Set normal RM validity checking, and checking of IN OUT parameters + -- (this might give CodePeer more useful checks to analyze, to be + -- confirmed???). All other validity checking is turned off, since + -- this can generate very complex trees that only confuse CodePeer + -- and do not bring enough useful info. + + Reset_Validity_Check_Options; + Validity_Check_Default := True; + Validity_Check_In_Out_Params := True; + Validity_Check_In_Params := True; + + -- Turn off style check options since we are not interested in any + -- front-end warnings when we are getting CodePeer output. + + Reset_Style_Check_Options; end if; -- Set Configurable_Run_Time mode if system.ads flag set @@ -751,7 +841,7 @@ begin -- a VM, since representations are largely symbolic there. if Back_End_Mode = Declarations_Only - and then (not Back_Annotate_Rep_Info + and then (not (Back_Annotate_Rep_Info or Generate_SCIL) or else Main_Kind = N_Subunit or else Targparm.Frontend_Layout_On_Target or else Targparm.VM_Target /= No_VM) diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index ad63bac196e..3e85ef79921 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -1494,9 +1494,10 @@ pragma CPP_Class ([Entity =>] LOCAL_NAME); @noindent The argument denotes an entity in the current declarative region that is -declared as a tagged record type. It indicates that the type corresponds -to an externally declared C++ class type, and is to be laid out the same -way that C++ would lay out the type. +declared as a record type. It indicates that the type corresponds to an +externally declared C++ class type, and is to be laid out the same way +that C++ would lay out the type. If the C++ class has virtual primitives +then the record must be declared as a tagged record type. Types for which @code{CPP_Class} is specified do not have assignment or equality operators defined (such operations can be imported or declared @@ -1536,20 +1537,28 @@ must be of one of the following forms: @itemize @bullet @item +@code{function @var{Fname} return @var{T}} + +@itemize @bullet +@item @code{function @var{Fname} return @var{T}'Class} @item +@code{function @var{Fname} (@dots{}) return @var{T}} +@end itemize + +@item @code{function @var{Fname} (@dots{}) return @var{T}'Class} @end itemize @noindent -where @var{T} is a tagged limited type imported from C++ with pragma +where @var{T} is a limited record type imported from C++ with pragma @code{Import} and @code{Convention} = @code{CPP}. -The first form is the default constructor, used when an object of type -@var{T} is created on the Ada side with no explicit constructor. The -second form covers all the non-default constructors of the type. See -the GNAT users guide for details. +The first two forms import the default constructor, used when an object +of type @var{T} is created on the Ada side with no explicit constructor. +The latter two forms cover all the non-default constructors of the type. +See the GNAT users guide for details. If no constructors are imported, it is impossible to create any objects on the Ada side and the type is implicitly declared abstract. @@ -1558,6 +1567,12 @@ Pragma @code{CPP_Constructor} is intended primarily for automatic generation using an automatic binding generator tool. See @ref{Interfacing to C++} for more related information. +Note: The use of functions returning class-wide types for constructors is +currently obsolete. They are supported for backward compatibility. The +use of functions returning the type T leave the Ada sources more clear +because the imported C++ constructors always return an object of type T; +that is, they never return an object whose type is a descendant of type T. + @node Pragma CPP_Virtual @unnumberedsec Pragma CPP_Virtual @cindex Interfacing to C++ diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 9f6178d56ab..779a7614c6a 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -3278,13 +3278,13 @@ package Pkg_Root is function Get_Value (Obj : Root) return int; pragma Import (CPP, Get_Value); - function Constructor return Root'Class; + function Constructor return Root; pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ev"); - function Constructor (v : Integer) return Root'Class; + function Constructor (v : Integer) return Root; pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ei"); - function Constructor (v, w : Integer) return Root'Class; + function Constructor (v, w : Integer) return Root; pragma Cpp_Constructor (Constructor, "_ZN4RootC1Eii"); end Pkg_Root; @end smallexample @@ -3527,7 +3527,7 @@ package Animals is procedure Set_Owner (A : in out Dog; Name : Chars_Ptr); pragma Import (C_Plus_Plus, Set_Owner); - function New_Dog return Dog'Class; + function New_Dog return Dog; pragma CPP_Constructor (New_Dog); pragma Import (CPP, New_Dog, "_ZN3DogC2Ev"); end Animals; @@ -4090,6 +4090,14 @@ Assume no invalid (bad) values except for 'Valid attribute use. @cindex @option{-gnatc} (@command{gcc}) Check syntax and semantics only (no code generation attempted). +@item -gnatC +@cindex @option{-gnatC} (@command{gcc}) +Generate CodePeer information (no code generation attempted). +This switch will generate an intermediate representation suitable for +use by CodePeer (@file{.scil} files). This switch is not compatible with +code generation (it will, among other things, disable some switches such +as -gnatn, and enable others such as -gnata). + @item -gnatd @cindex @option{-gnatd} (@command{gcc}) Specify debug options for the compiler. The string of characters after @@ -4784,8 +4792,6 @@ some error messages. Some examples are: @itemize @bullet @item -Full details on entities not available in high integrity mode -@item Details on possibly non-portable unchecked conversion @item List possible interpretations for ambiguous calls @@ -5347,6 +5353,20 @@ The default is that these warnings are not given. This switch disables warnings for variables that are assigned or initialized, but never read. +@item -gnatw.m +@emph{Activate warnings on suspicious modulus values.} +@cindex @option{-gnatw.m} (@command{gcc}) +This switch activates warnings for modulus values that seem suspicious. +The cases caught are where the size is the same as the modulus (e.g. +a modulus of 7 with a size of 7 bits), and modulus values of 32 or 64 +with no size clause. The guess in both cases is that 2**x was intended +rather than x. The default is that these warnings are given. + +@item -gnatw.M +@emph{Disable warnings on suspicious modulus values.} +@cindex @option{-gnatw.M} (@command{gcc}) +This switch disables warnings for suspicious modulus values. + @item -gnatwn @emph{Set normal warnings mode.} @cindex @option{-gnatwn} (@command{gcc}) @@ -12237,6 +12257,7 @@ is equivalent to the @command{gnatmake} invocation using the project file @node Importing Other Projects @subsection Importing Other Projects @cindex @code{ADA_PROJECT_PATH} +@cindex @code{GPR_PROJECT_PATH} @noindent A compilation unit in a source file in one project may depend on compilation @@ -12323,15 +12344,17 @@ if either The imported project file is in the same directory as the importing project file, or @item -You have defined ^an environment variable^a logical name^ +You have defined one or two ^environment variables^logical names^ that includes the directory containing -the needed project file. The syntax of @code{ADA_PROJECT_PATH} is the same as +the needed project file. The syntax of @code{GPR_PROJECT_PATH} and +@code{ADA_PROJECT_PATH} is the same as the syntax of @code{ADA_INCLUDE_PATH} and @code{ADA_OBJECTS_PATH}: a list of directory names separated by colons (semicolons on Windows). @end itemize @noindent -Thus, if we define @code{ADA_PROJECT_PATH} to include @file{^/gui^[GUI]^} and +Thus, if we define @code{ADA_PROJECT_PATH} or @code{GPR_PROJECT_PATH} +to include @file{^/gui^[GUI]^} and @file{^/comm^[COMM]^}, then our project file @file{app_proj.gpr} can be written as follows: @@ -13310,7 +13333,7 @@ file. If the order of the source directories is not known statically, it is an error to have several files with the same source file name. Projects can be specified to have no Ada source -files: the value of (@code{Source_Dirs} or @code{Source_Files} may be an empty +files: the value of @code{Source_Dirs} or @code{Source_Files} may be an empty list, or the @code{"Ada"} may be absent from @code{Languages}: @smallexample @c projectfile @@ -13333,6 +13356,7 @@ define a package @code{Naming} (@pxref{Naming Schemes}). @node Importing Projects @section Importing Projects @cindex @code{ADA_PROJECT_PATH} +@cindex @code{GPR_PROJECT_PATH} @noindent An immediate source of a project P may depend on source files that @@ -13373,7 +13397,8 @@ files giving access to standard support libraries. @item In between, all the directories referenced in the -^environment variable^logical name^ @env{ADA_PROJECT_PATH} if it exists. +^environment variables^logical names^ @env{GPR_PROJECT_PATH} +and @env{ADA_PROJECT_PATH} if they exist, and in that order. @end itemize @noindent @@ -19037,6 +19062,7 @@ be accessed by the directive @option{-l@var{xxx}} at link time. @node Installing a library @subsection Installing a library @cindex @code{ADA_PROJECT_PATH} +@cindex @code{GPR_PROJECT_PATH} @noindent If you use project files, library installation is part of the library build @@ -19076,7 +19102,7 @@ responsibility of the library provider to install the necessary sources, ALI files and libraries in the directories mentioned in the project file. For convenience, the user's library project file should be installed in a location that will be searched automatically by the GNAT -builder. These are the directories referenced in the @env{ADA_PROJECT_PATH} +builder. These are the directories referenced in the @env{GPR_PROJECT_PATH} environment variable (@pxref{Importing Projects}), and also the default GNAT library location that can be queried with @command{gnatls -v} and is usually of the form $gnat_install_root/lib/gnat. @@ -22833,7 +22859,7 @@ The corresponding Ada code is generated: (this : access Dog; Name : Interfaces.C.Strings.chars_ptr); pragma Import (CPP, Set_Owner, "_ZN3Dog9Set_OwnerEPc"); - function New_Dog return Dog'Class; + function New_Dog return Dog; pragma CPP_Constructor (New_Dog); pragma Import (CPP, New_Dog, "_ZN3DogC1Ev"); end; diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 68ed4c77718..c3ec70c241a 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -364,8 +364,7 @@ procedure GNATCmd is File := new String' (Get_Name_String - (Proj.Project.Object_Directory.Name) & - Directory_Separator & + (Proj.Project.Object_Directory.Name) & B_Start.all & MLib.Fil.Ext_To (Get_Name_String @@ -391,8 +390,7 @@ procedure GNATCmd is File := new String' (Get_Name_String - (Proj.Project.Object_Directory.Name) & - Directory_Separator & + (Proj.Project.Object_Directory.Name) & B_Start.all & Get_Name_String (Proj.Project.Library_Name) & ".ci"); @@ -514,7 +512,6 @@ procedure GNATCmd is (Get_Name_String (Unit.File_Names (Impl).Project. Object_Directory.Name) & - Directory_Separator & MLib.Fil.Ext_To (Get_Name_String (Unit.File_Names (Impl).Display_File), @@ -684,16 +681,8 @@ procedure GNATCmd is Proj := Project_Tree.Projects; while Proj /= null loop if Proj.Project.Config_File_Temp then - if Verbose_Mode then - Output.Write_Str ("Deleting temp configuration file """); - Output.Write_Str - (Get_Name_String (Proj.Project.Config_File_Name)); - Output.Write_Line (""""); - end if; - - Delete_File - (Name => Get_Name_String (Proj.Project.Config_File_Name), - Success => Success); + Delete_Temporary_File + (Project_Tree, Proj.Project.Config_File_Name); end if; Proj := Proj.Next; @@ -704,7 +693,7 @@ procedure GNATCmd is -- has been created, delete this temporary file. if Temp_File_Name /= No_Path then - Delete_File (Get_Name_String (Temp_File_Name), Success); + Delete_Temporary_File (Project_Tree, Temp_File_Name); end if; end Delete_Temp_Config_Files; @@ -1077,16 +1066,13 @@ procedure GNATCmd is begin if Is_Regular_File (Dir & - Directory_Separator & ALI_File (1 .. Last)) then -- We have found the correct project, so we -- replace the file with the absolute path. Last_Switches.Table (J) := - new String' - (Dir & Directory_Separator & - ALI_File (1 .. Last)); + new String'(Dir & ALI_File (1 .. Last)); -- And we are done @@ -1155,7 +1141,6 @@ procedure GNATCmd is Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'(Name_Buffer (1 .. Name_Len) & - Directory_Separator & Executable_Name (Base_Name (Arg (Arg'First .. Last)))); exit; @@ -1297,8 +1282,6 @@ begin VMS_Conv.Initialize; - Set_Mode (Ada_Only); - -- Add the default search directories, to be able to find system.ads in the -- subsequent call to Targparm.Get_Target_Parameters. @@ -1784,8 +1767,8 @@ begin (Project => Project, In_Tree => Project_Tree, Project_File_Name => Project_File.all, - Packages_To_Check => Packages_To_Check, - Is_Config_File => False); + Flags => Gnatmake_Flags, + Packages_To_Check => Packages_To_Check); if Project = Prj.No_Project then Fail ("""" & Project_File.all & """ processing failed"); @@ -2134,18 +2117,16 @@ begin end if; end loop; - -- If the naming scheme of the project file is not standard, - -- and if the file name ends with the spec suffix, then - -- indicate to gnatstub the name of the body file with - -- a -o switch. + -- If the project file naming scheme is not standard, and if + -- the file name ends with the spec suffix, then indicate to + -- gnatstub the name of the body file with a -o switch. - if Lang.Config.Naming_Data.Body_Suffix /= - Prj.Default_Ada_Spec_Suffix - then + if not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then if File_Index /= 0 then declare Spec : constant String := - Base_Name (Last_Switches.Table (File_Index).all); + Base_Name + (Last_Switches.Table (File_Index).all); Last : Natural := Spec'Last; begin @@ -2212,8 +2193,7 @@ begin end if; -- For gnat check, -rules and the following switches need to be the - -- last options. So, we move all these switches to table - -- Rules_Switches. + -- last options, so move all these switches to table Rules_Switches. if The_Command = Check then declare @@ -2362,7 +2342,7 @@ begin exception when Error_Exit => if not Keep_Temporary_Files then - Prj.Env.Delete_All_Path_Files (Project_Tree); + Prj.Delete_All_Temp_Files (Project_Tree); Delete_Temp_Config_Files; end if; @@ -2370,7 +2350,7 @@ exception when Normal_Exit => if not Keep_Temporary_Files then - Prj.Env.Delete_All_Path_Files (Project_Tree); + Prj.Delete_All_Temp_Files (Project_Tree); Delete_Temp_Config_Files; end if; diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index 7e817b5bf03..4c6d00bd99e 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -524,8 +524,6 @@ procedure Gnatname is -- Start of processing for Gnatname begin - Prj.Set_Mode (Prj.Ada_Only); - -- Add the directory where gnatname is invoked in front of the -- path, if gnatname is invoked with directory information. -- Only do this if the platform is not VMS, where the notion of path @@ -622,7 +620,8 @@ begin (File_Path => File_Path.all, Project_File => Create_Project, Preproc_Switches => Prep_Switches, - Very_Verbose => Very_Verbose); + Very_Verbose => Very_Verbose, + Flags => Gnatmake_Flags); end; -- Process each section successively diff --git a/gcc/ada/i-cexten.ads b/gcc/ada/i-cexten.ads index 9f95e9f3a82..93f8dc68b51 100644 --- a/gcc/ada/i-cexten.ads +++ b/gcc/ada/i-cexten.ads @@ -36,6 +36,8 @@ with System; package Interfaces.C.Extensions is + -- Following 7 declarations need comments ??? + subtype void is System.Address; subtype void_ptr is System.Address; @@ -45,16 +47,14 @@ package Interfaces.C.Extensions is subtype incomplete_class_def is System.Address; type incomplete_class_def_ptr is access incomplete_class_def; - -- + subtype bool is plain_char; + -- 64bit integer types - -- subtype long_long is Long_Long_Integer; type unsigned_long_long is mod 2 ** 64; - -- -- Types for bitfields - -- type Unsigned_1 is mod 2 ** 1; for Unsigned_1'Size use 1; diff --git a/gcc/ada/i-cobol.ads b/gcc/ada/i-cobol.ads index 6178eb7e459..ad885e4a91a 100644 --- a/gcc/ada/i-cobol.ads +++ b/gcc/ada/i-cobol.ads @@ -55,7 +55,7 @@ package Interfaces.COBOL is Max_Digits_Binary : constant := 9; Max_Digits_Long_Binary : constant := 18; - type Decimal_Element is mod 16; + type Decimal_Element is mod 2**4; type Packed_Decimal is array (Positive range <>) of Decimal_Element; pragma Pack (Packed_Decimal); diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index c8d3fd10cf8..4cf3e0c01a5 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -327,7 +327,6 @@ package body Impunit is "s-addima", -- System.Address_Image "s-assert", -- System.Assertions "s-memory", -- System.Memory - "s-os_lib", -- System.Os_Lib "s-parint", -- System.Partition_Interface "s-pooglo", -- System.Pool_Global "s-pooloc", -- System.Pool_Local diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c index ccad170c108..fbbdf605275 100644 --- a/gcc/ada/initialize.c +++ b/gcc/ada/initialize.c @@ -67,12 +67,6 @@ extern void __gnat_install_SEH_handler (void *); extern int gnat_argc; extern char **gnat_argv; -#ifndef RTX -/* Do not define for RTX since it is only used for creating child processes - which is not supported in RTX. */ -extern void __gnat_plist_init (void); -#endif - #ifdef GNAT_UNICODE_SUPPORT #define EXPAND_ARGV_RATE 128 diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index a7c4128e0d4..63dd62025fe 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -605,10 +605,15 @@ package body Lib is -- If not in the table, must be a spec created for a main unit that is a -- child subprogram body which we have not inserted into the table yet. - if N /= Library_Unit (Cunit (Main_Unit)) then - raise Program_Error; - else + if N = Library_Unit (Cunit (Main_Unit)) then return Main_Unit; + + -- If it is anything else, something is seriously wrong, and we really + -- don't want to proceed, even if assertions are off, so we explicitly + -- raise an exception in this case to terminate compilation. + + else + raise Program_Error; end if; end Get_Cunit_Unit_Number; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 5c689bda5cf..c1afc14e17d 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -140,16 +140,16 @@ package body Make is -- Q | | ........ | | | | ....... | | -- +---+--------------+---+---+---+-----------+---+-------- -- ^ ^ ^ - -- Q.First Q_Front Q.Last - 1 + -- Q.First Q_Front Q.Last-1 -- - -- The elements comprised between Q.First and Q_Front - 1 are the elements + -- The elements comprised between Q.First and Q_Front-1 are the elements -- that have been enqueued and then dequeued, while the elements between - -- Q_Front and Q.Last - 1 are the elements currently in the Q. When the Q + -- Q_Front and Q.Last-1 are the elements currently in the Q. When the Q -- is initialized Q_Front = Q.First = Q.Last. After Compile_Sources has -- terminated its execution, Q_Front = Q.Last and the elements contained - -- between Q.Front and Q.Last-1 are those that were explored and thus + -- between Q.First and Q.Last-1 are those that were explored and thus -- marked by Compile_Sources. Whenever the Q is reinitialized, the elements - -- between Q.First and Q.Last - 1 are unmarked. + -- between Q.First and Q.Last-1 are unmarked. procedure Init_Q; -- Must be called to (re)initialize the Q @@ -835,10 +835,6 @@ package body Make is Gnatmake_Mapping_File : String_Access := null; -- The path name of a mapping file specified by switch -C= - procedure Delete_Mapping_Files; - -- Delete all temporary mapping files. Called only in Delete_All_Temp_Files - -- which ensures that Debug_Flag_N is False. - procedure Init_Mapping_File (Project : Project_Id; Data : in out Project_Compilation_Data; @@ -1978,12 +1974,8 @@ package body Make is Name_Len := 0; Add_Str_To_Name_Buffer (Res_Obj_Dir); - if Name_Len > 1 and then - (Name_Buffer (Name_Len) = '/' - or else - Name_Buffer (Name_Len) = Directory_Separator) - then - Name_Len := Name_Len - 1; + if not Is_Directory_Separator (Name_Buffer (Name_Len)) then + Add_Char_To_Name_Buffer (Directory_Separator); end if; Obj_Dir := Name_Find; @@ -3090,9 +3082,9 @@ package body Make is end if; end if; - if Create_Mapping_File then + if Create_Mapping_File and then Mapping_File_Arg /= null then Comp_Last := Comp_Last + 1; - Comp_Args (Comp_Last) := Mapping_File_Arg; + Comp_Args (Comp_Last) := new String'(Mapping_File_Arg.all); end if; Get_Name_String (S); @@ -3885,45 +3877,11 @@ package body Make is procedure Delete_All_Temp_Files is begin if not Debug.Debug_Flag_N then - Delete_Mapping_Files; Delete_Temp_Config_Files; - Prj.Env.Delete_All_Path_Files (Project_Tree); + Prj.Delete_All_Temp_Files (Project_Tree); end if; end Delete_All_Temp_Files; - -------------------------- - -- Delete_Mapping_Files -- - -------------------------- - - procedure Delete_Mapping_Files is - Success : Boolean; - pragma Warnings (Off, Success); - - Proj : Project_List; - Data : Project_Compilation_Access; - - begin - -- The caller is responsible for ensuring that Debug_Flag_N is False - - pragma Assert (not Debug.Debug_Flag_N); - - Proj := Project_Tree.Projects; - while Proj /= null loop - Data := Project_Compilation_Htable.Get - (Project_Compilation, Proj.Project); - - if Data /= null and then Data.Mapping_File_Names /= null then - for Index in 1 .. Data.Last_Mapping_File_Names loop - Delete_File - (Name => Get_Name_String (Data.Mapping_File_Names (Index)), - Success => Success); - end loop; - end if; - - Proj := Proj.Next; - end loop; - end Delete_Mapping_Files; - ------------------------------ -- Delete_Temp_Config_Files -- ------------------------------ @@ -3942,15 +3900,8 @@ package body Make is Proj := Project_Tree.Projects; while Proj /= null loop if Proj.Project.Config_File_Temp then - if Verbose_Mode then - Write_Str ("Deleting temp configuration file """); - Write_Str (Get_Name_String (Proj.Project.Config_File_Name)); - Write_Line (""""); - end if; - - Delete_File - (Name => Get_Name_String (Proj.Project.Config_File_Name), - Success => Success); + Delete_Temporary_File + (Project_Tree, Proj.Project.Config_File_Name); -- Make sure that we don't have a config file for this project, -- in case there are several mains. In this case, we will @@ -4379,7 +4330,7 @@ package body Make is begin Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path); - Record_Temp_File (Mapping_Path); + Record_Temp_File (Project_Tree, Mapping_Path); if Mapping_FD /= Invalid_FD then @@ -4450,8 +4401,8 @@ package body Make is (ALI_Project.Object_Directory.Name); end if; - if Name_Buffer (Name_Len) /= - Directory_Separator + if not + Is_Directory_Separator (Name_Buffer (Name_Len)) then Add_Char_To_Name_Buffer (Directory_Separator); end if; @@ -5312,7 +5263,9 @@ package body Make is if not Is_Absolute_Path (Exec_File_Name) then Get_Name_String (Main_Project.Exec_Directory.Name); - if Name_Buffer (Name_Len) /= Directory_Separator then + if not + Is_Directory_Separator (Name_Buffer (Name_Len)) + then Add_Char_To_Name_Buffer (Directory_Separator); end if; @@ -6051,9 +6004,10 @@ package body Make is if Main_Project /= No_Project then -- Put all the source directories in ADA_INCLUDE_PATH, - -- and all the object directories in ADA_OBJECTS_PATH. + -- and all the object directories in ADA_OBJECTS_PATH, + -- except those of library projects. - Prj.Env.Set_Ada_Paths (Main_Project, Project_Tree, True); + Prj.Env.Set_Ada_Paths (Main_Project, Project_Tree, False); -- If switch -C was specified, create a binder mapping file @@ -6070,13 +6024,10 @@ package body Make is exception when others => - -- If -dn was not specified, delete the temporary mapping - -- file, if one was created. + -- Delete the temporary mapping file, if one was created. - if not Debug.Debug_Flag_N - and then Mapping_Path /= No_Path - then - Delete_File (Get_Name_String (Mapping_Path), Discard); + if Mapping_Path /= No_Path then + Delete_Temporary_File (Project_Tree, Mapping_Path); end if; -- And reraise the exception @@ -6087,8 +6038,8 @@ package body Make is -- If -dn was not specified, delete the temporary mapping file, -- if one was created. - if not Debug.Debug_Flag_N and then Mapping_Path /= No_Path then - Delete_File (Get_Name_String (Mapping_Path), Discard); + if Mapping_Path /= No_Path then + Delete_Temporary_File (Project_Tree, Mapping_Path); end if; end Bind_Step; end if; @@ -6661,7 +6612,8 @@ package body Make is else Record_Temp_File - (Data.Mapping_File_Names (Data.Last_Mapping_File_Names)); + (Project_Tree, + Data.Mapping_File_Names (Data.Last_Mapping_File_Names)); end if; Close (FD, Status); @@ -6699,8 +6651,6 @@ package body Make is -- Start of processing for Initialize begin - Prj.Set_Mode (Ada_Only); - -- Override default initialization of Check_Object_Consistency since -- this is normally False for GNATBIND, but is True for GNATMAKE since -- we do not need to check source consistency again once GNATMAKE has @@ -6867,7 +6817,7 @@ package body Make is In_Tree => Project_Tree, Project_File_Name => Project_File_Name.all, Packages_To_Check => Packages_To_Check_By_Gnatmake, - Is_Config_File => False); + Flags => Gnatmake_Flags); -- The parsing of project files may have changed the current output @@ -7610,8 +7560,7 @@ package body Make is -- separator. if Argv (Argv'Last) = Directory_Separator then - Object_Directory_Path := - new String'(Argv); + Object_Directory_Path := new String'(Argv); else Object_Directory_Path := new String'(Argv & Directory_Separator); diff --git a/gcc/ada/mingw32.h b/gcc/ada/mingw32.h index 2c52920da69..2ad4d36dfa1 100644 --- a/gcc/ada/mingw32.h +++ b/gcc/ada/mingw32.h @@ -61,6 +61,9 @@ #define UNICODE /* For Win32 API */ #endif +/* We need functionality available only starting with Windows XP */ +#define _WIN32_WINNT 0x0501 + #include <tchar.h> #include <windows.h> diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index c7f0f0b73f0..d01a329945b 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -1328,7 +1328,14 @@ package body MLib.Prj is In_Main_Object_Directory := True; - Foreign_Sources := Has_Foreign_Sources (For_Project); + -- For gnatmake, when the project specifies more than just Ada as a + -- language (even if course we could not find any source file for + -- the other languages), we will take all object files found in the + -- object directories. Since we know the project supports at least + -- Ada, we just have to test whether it has at least two languages, + -- and not care about the sources. + + Foreign_Sources := For_Project.Languages.Next /= null; Current_Proj := For_Project; loop @@ -2152,20 +2159,12 @@ package body MLib.Prj is First_Unit : ALI.Unit_Id; Second_Unit : ALI.Unit_Id; - Data : Unit_Index; - Copy_Subunits : Boolean := False; -- When True, indicates that subunits, if any, need to be copied too procedure Copy (File_Name : File_Name_Type); -- Copy one source of the project to the target directory - function Is_Same_Or_Extension - (Extending : Project_Id; - Extended : Project_Id) return Boolean; - -- Return True if project Extending is equal to or extends project - -- Extended. - ---------- -- Copy -- ---------- @@ -2174,56 +2173,26 @@ package body MLib.Prj is Success : Boolean; pragma Warnings (Off, Success); + Source : Standard.Prj.Source_Id; begin - Data := Units_Htable.Get_First (In_Tree.Units_HT); - - Unit_Loop : - while Data /= No_Unit_Index loop - -- Find and copy the immediate or inherited source - - for J in Data.File_Names'Range loop - if Data.File_Names (J) /= null - and then Is_Same_Or_Extension - (For_Project, Data.File_Names (J).Project) - and then Data.File_Names (J).File = File_Name - then - Copy_File - (Get_Name_String (Data.File_Names (J).Path.Name), - Target, - Success, - Mode => Overwrite, - Preserve => Preserve); - exit Unit_Loop; - end if; - end loop; - - Data := Units_Htable.Get_Next (In_Tree.Units_HT); - end loop Unit_Loop; + Source := Find_Source + (In_Tree, For_Project, + In_Extended_Only => True, + Base_Name => File_Name); + + if Source /= No_Source + and then not Source.Locally_Removed + and then Source.Replaced_By = No_Source + then + Copy_File + (Get_Name_String (Source.Path.Name), + Target, + Success, + Mode => Overwrite, + Preserve => Preserve); + end if; end Copy; - -------------------------- - -- Is_Same_Or_Extension -- - -------------------------- - - function Is_Same_Or_Extension - (Extending : Project_Id; - Extended : Project_Id) return Boolean - is - Ext : Project_Id; - - begin - Ext := Extending; - while Ext /= No_Project loop - if Ext = Extended then - return True; - end if; - - Ext := Ext.Extends; - end loop; - - return False; - end Is_Same_Or_Extension; - -- Start of processing for Copy_Interface_Sources begin diff --git a/gcc/ada/mlib.adb b/gcc/ada/mlib.adb index 6c1a4918340..4c4d375f324 100644 --- a/gcc/ada/mlib.adb +++ b/gcc/ada/mlib.adb @@ -55,7 +55,7 @@ package body MLib is Write_Line (Output_File); end if; - Ar (Output_Dir & Directory_Separator & + Ar (Output_Dir & "lib" & Output_File & ".a", Objects => Ofiles); end Build_Library; @@ -202,16 +202,21 @@ package body MLib is if FD /= Invalid_FD then Len := Integer (File_Length (FD)); + -- ??? Why "+3" here + S := new String (1 .. Len + 3); -- Read the file. Note that the loop is not necessary -- since the whole file is read at once except on VMS. - Curr := 1; - Actual_Len := Len; - - while Actual_Len /= 0 loop + Curr := S'First; + while Curr <= Len loop Actual_Len := Read (FD, S (Curr)'Address, Len); + + -- Exit if we could not read for some reason + + exit when Actual_Len = 0; + Curr := Curr + Actual_Len; end loop; @@ -226,10 +231,10 @@ package body MLib is -- at the beginning of the P line. for Index in 1 .. Len - 3 loop - if (S (Index) = ASCII.LF or else - S (Index) = ASCII.CR) - and then - S (Index + 1) = 'P' + if (S (Index) = ASCII.LF + or else + S (Index) = ASCII.CR) + and then S (Index + 1) = 'P' then S (Index + 5 .. Len + 3) := S (Index + 2 .. Len); S (Index + 2 .. Index + 4) := " SL"; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index e999c646b77..906a782022e 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -38,7 +38,6 @@ -- use the Project Manager. These tools include gnatmake, gnatname, the gnat -- driver, gnatclean, gprbuild and gprclean. -with Debug; with Hostparm; use Hostparm; with Types; use Types; @@ -257,6 +256,11 @@ package Opt is -- Set to True to enable checking for unused withs, and also the case -- of withing a package and using none of the entities in the package. + CodePeer_Mode : Boolean := False; + -- GNAT + -- Enable full CodePeer mode (SCIL generation, disable switches that + -- interact badly with it, etc...). + Commands_To_Stdout : Boolean := False; -- GNATMAKE -- True if echoed commands to be written to stdout instead of stderr @@ -637,13 +641,9 @@ package Opt is -- then elaboration flag checks are to be generated in the binder -- generated file. - Inspector_Mode : Boolean renames Debug.Debug_Flag_Dot_II; + Generate_SCIL : Boolean := False; -- GNAT - -- True if compiling in inspector mode (-gnatd.I switch). - -- Enable inspector mode, in particular SCIL generation. - -- When VM_Target /= None, the compiler will also attempt to - -- generate code even in case of unsupported construct instead of - -- displaying an error. + -- Set True to activate SCIL code generation. Invalid_Value_Used : Boolean := False; -- GNAT @@ -651,17 +651,17 @@ package Opt is Follow_Links_For_Files : Boolean := False; -- PROJECT MANAGER - -- Set to True (-eL) to process the project files in trusted mode - -- If Follow_Links is False, it is assumed that the project doesn't contain + -- Set to True (-eL) to process the project files in trusted mode. If + -- Follow_Links is False, it is assumed that the project doesn't contain -- any file duplicated through symbolic links (although the latter are -- still valid if they point to a file which is outside of the project), -- and that no directory has a name which is a valid source name. Follow_Links_For_Dirs : Boolean := True; -- PROJECT MANAGER - -- Whether directories can be links in this project, and therefore - -- additional system calls should be performed to ensure we always see the - -- same full name for each directory. + -- Set to True if directories can be links in this project, and therefore + -- additional system calls must be performed to ensure that we always see + -- the same full name for each directory. Front_End_Inlining : Boolean := False; -- GNAT @@ -669,9 +669,9 @@ package Opt is Inline_Processing_Required : Boolean := False; -- GNAT - -- Set True if inline processing is required. Inline processing is - -- required if an active Inline pragma is processed. The flag is set - -- for a pragma Inline or Inline_Always that is actually active. + -- Set True if inline processing is required. Inline processing is required + -- if an active Inline pragma is processed. The flag is set for a pragma + -- Inline or Inline_Always that is actually active. In_Place_Mode : Boolean := False; -- GNATMAKE @@ -681,8 +681,8 @@ package Opt is Keep_Going : Boolean := False; -- GNATMAKE, GPRMAKE, GPRBUILD - -- When True signals to ignore compilation errors and keep - -- processing sources until there is no more work. + -- When True signals to ignore compilation errors and keep processing + -- sources until there is no more work. Keep_Temporary_Files : Boolean := False; -- GNATCMD @@ -696,8 +696,8 @@ package Opt is Link_Only : Boolean := False; -- GNATMAKE, GPRMAKE, GPRBUILD - -- Set to True to skip compile and bind steps - -- (except when Bind_Only is set to True). + -- Set to True to skip compile and bind steps (except when Bind_Only is + -- set to True). List_Restrictions : Boolean := False; -- GNATBIND @@ -730,21 +730,21 @@ package Opt is List_Representation_Info_To_File : Boolean := False; -- GNAT - -- Set true by -gnatRs switch. Causes information from -gnatR/1/2/3 - -- to be written to file.rep (where file is the name of the source - -- file) instead of stdout. For example, if file x.adb is compiled - -- using -gnatR2s then representation info is written to x.adb.ref. + -- Set true by -gnatRs switch. Causes information from -gnatR/1/2/3 to be + -- written to file.rep (where file is the name of the source file) instead + -- of stdout. For example, if file x.adb is compiled using -gnatR2s then + -- representation info is written to x.adb.ref. List_Representation_Info_Mechanisms : Boolean := False; -- GNAT - -- Set true by -gnatRm switch. Causes information on mechanisms to - -- be included in the representation output information. + -- Set true by -gnatRm switch. Causes information on mechanisms to be + -- included in the representation output information. List_Preprocessing_Symbols : Boolean := False; -- GNAT, GNATPREP -- Set to True if symbols for preprocessing a source are to be listed - -- before preprocessing occurs. Set to True by switch -s of gnatprep - -- or -s in preprocessing data file for the compiler. + -- before preprocessing occurs. Set to True by switch -s of gnatprep or + -- -s in preprocessing data file for the compiler. type Create_Repinfo_File_Proc is access procedure (Src : String); type Write_Repinfo_Line_Proc is access procedure (Info : String); @@ -755,12 +755,11 @@ package Opt is Write_Repinfo_Line_Access : Write_Repinfo_Line_Proc := null; Close_Repinfo_File_Access : Close_Repinfo_File_Proc := null; -- GNAT - -- These three locations are left null when operating in non-compiler - -- (e.g. ASIS mode), but when operating in compiler mode, they are - -- set to point to the three corresponding procedures in Osint-C. The - -- reason for this slightly strange interface is to prevent Repinfo - -- from dragging in Osint in ASIS mode, which would include a lot of - -- unwanted units in the ASIS build. + -- These three locations are left null when operating in non-compiler (e.g. + -- ASIS mode), but when operating in compiler mode, they are set to point + -- to the three corresponding procedures in Osint-C. The reason for this + -- slightly strange interface is to stop Repinfo from dragging in Osint in + -- ASIS mode, which would include lots of unwanted units in the ASIS build. type Create_List_File_Proc is access procedure (S : String); type Write_List_Info_Proc is access procedure (S : String); @@ -776,25 +775,25 @@ package Opt is -- set to point to the three corresponding procedures in Osint-C. The -- reason for this slightly strange interface is to prevent Repinfo -- from dragging in Osint-C in the binder, which would include unwanted - -- units in the binder. + -- units in the binder. Locking_Policy : Character := ' '; -- GNAT, GNATBIND - -- Set to ' ' for the default case (no locking policy specified). - -- Reset to first character (uppercase) of locking policy name if a - -- valid pragma Locking_Policy is encountered. + -- Set to ' ' for the default case (no locking policy specified). Reset to + -- first character (uppercase) of locking policy name if a valid pragma + -- Locking_Policy is encountered. Locking_Policy_Sloc : Source_Ptr := No_Location; -- GNAT, GNATBIND - -- Remember location of previous Locking_Policy pragma. This is used - -- for inconsistency error messages. A value of System_Location is - -- used if the policy is set in package System. + -- Remember location of previous Locking_Policy pragma. This is used for + -- inconsistency error messages. A value of System_Location is used if the + -- policy is set in package System. Look_In_Primary_Dir : Boolean := True; -- GNAT, GNATBIND, GNATMAKE, GNATCLEAN - -- Set to False if a -I- was present on the command line. - -- When True we are allowed to look in the primary directory to locate - -- other source or library files. + -- Set to False if a -I- was present on the command line. When True we are + -- allowed to look in the primary directory to locate other source or + -- library files. Make_Steps : Boolean := False; -- GNATMAKE @@ -902,9 +901,9 @@ package Opt is Original_Operating_Mode : Operating_Mode_Type := Generate_Code; -- GNAT - -- Indicates the original operating mode of the compiler as set by - -- compiler options. This is identical to Operating_Mode except that - -- this is not affected by errors. + -- Indicates the original operating mode of the compiler as set by compiler + -- options. This is identical to Operating_Mode except that this is not + -- affected by errors. Optimization_Level : Int; pragma Import (C, Optimization_Level, "optimize"); @@ -934,7 +933,7 @@ package Opt is Overflow_Checks_Unsuppressed : Boolean := False; -- GNAT - -- Set to True if at least one pragma Unsuppress + -- Set to True if at least one occurrence of pragma Unsuppress -- (All_Checks|Overflow_Checks) has been processed. Persistent_BSS_Mode : Boolean := False; @@ -974,20 +973,20 @@ package Opt is type Usage is (Unknown, Not_In_Use, In_Use); Project_File_In_Use : Usage := Unknown; -- GNAT - -- Indicates if a project file is used or not. - -- Set to In_Use by the first SFNP pragma. + -- Indicates if a project file is used or not. Set to In_Use by the first + -- SFNP pragma. Queuing_Policy : Character := ' '; -- GNAT, GNATBIND - -- Set to ' ' for the default case (no queuing policy specified). - -- Reset to first character (uppercase) of locking policy name if a valid + -- Set to ' ' for the default case (no queuing policy specified). Reset to + -- first character (uppercase) of locking policy name if a valid -- Queuing_Policy pragma is encountered. Queuing_Policy_Sloc : Source_Ptr := No_Location; -- GNAT, GNATBIND - -- Remember location of previous Queuing_Policy pragma. This is used - -- for inconsistency error messages. A value of System_Location is - -- used if the policy is set in package System. + -- Remember location of previous Queuing_Policy pragma. This is used for + -- inconsistency error messages. A value of System_Location is used if the + -- policy is set in package System. Quiet_Output : Boolean := False; -- GNATMAKE, GNATCLEAN, GPRMAKE, GPRBUILD, GPRCLEAN @@ -1014,17 +1013,17 @@ package Opt is Search_Directory_Present : Boolean := False; -- GNAT - -- Set to True when argument is -I. Reset to False when next argument, - -- a search directory path is taken into account. Note that this is - -- quite different from other switches in this section in that it is - -- only set in a transitory manner as a result of scanning a -I switch - -- with no file name, and if set, is an indication that the next argument - -- is to be treated as a file name. + -- Set to True when argument is -I. Reset to False when next argument, a + -- search directory path is taken into account. Note that this is quite + -- different from other switches in this section in that it is only set in + -- a transitory manner as a result of scanning a -I switch with no file + -- name, and if set, is an indication that the next argument is to be + -- treated as a file name. Sec_Stack_Used : Boolean := False; -- GNAT, GBATBIND - -- Set True if generated code uses the System.Secondary_Stack package. - -- For the binder, set if any unit uses the secondary stack package. + -- Set True if generated code uses the System.Secondary_Stack package. For + -- the binder, set if any unit uses the secondary stack package. Setup_Projects : Boolean := False; -- GNAT DRIVER @@ -1033,9 +1032,9 @@ package Opt is Shared_Libgnat : Boolean; -- GNATBIND - -- Set to True if a shared libgnat is requested by using the -shared - -- option for GNATBIND and to False when using the -static option. The - -- value of this flag is set by Gnatbind.Scan_Bind_Arg. + -- Set to True if a shared libgnat is requested by using the -shared option + -- for GNATBIND and to False when using the -static option. The value of + -- this flag is set by Gnatbind.Scan_Bind_Arg. Sprint_Line_Limit : Nat := 72; -- Limit values for chopping long lines in Sprint output, can be reset @@ -1052,9 +1051,9 @@ package Opt is Style_Check : Boolean := False; -- GNAT - -- Set True to perform style checks. Activates checks carried out - -- in package Style (see body of this package for details of checks) - -- This flag is set True by either the -gnatg or -gnaty switches. + -- Set True to perform style checks. Activates checks carried out in + -- package Style (see body of this package for details of checks) This + -- flag is set True by either the -gnatg or -gnaty switches. Suppress_All_Inlining : Boolean := False; -- GNAT @@ -1113,9 +1112,9 @@ package Opt is Tagged_Type_Expansion : Boolean := True; -- GNAT -- Set True if tagged types and interfaces should be expanded by the - -- front-end. If False, the original tree is left unexpanded for - -- tagged types and dispatching calls, assuming the underlying target - -- supports it (e.g. case of JVM). + -- front-end. If False, the original tree is left unexpanded for tagged + -- types and dispatching calls, assuming the underlying target supports + -- it (e.g. in the JVM case). Task_Dispatching_Policy : Character := ' '; -- GNAT, GNATBIND @@ -1377,6 +1376,11 @@ package Opt is -- clauses that are affected by non-standard bit-order. The default is -- that this warning is enabled. + Warn_On_Suspicious_Modulus_Value : Boolean := True; + -- GNAT + -- Set to True to generate warnings for suspicious modulus values. The + -- default is that this warning is enabled. + Warn_On_Unchecked_Conversion : Boolean := True; -- GNAT -- Set to True to generate warnings for unchecked conversions that may have diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index 141c12fb294..bb5f5ae50d9 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -29,7 +29,13 @@ -- -- ------------------------------------------------------------------------------ +-- Note: the pragma Warnings (Off) here is because ASIS compiles this unit +-- without -gnatg, and System.OS_Lib is an implementation unit. This is a +-- temporary kludge which will be better resolved later on ??? + +pragma Warnings (Off); with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); package body Output is diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 973f64360df..1b2683379e3 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -31,6 +31,10 @@ with Sinfo.CN; use Sinfo.CN; separate (Par) +--------- +-- Ch3 -- +--------- + package body Ch3 is ----------------------- @@ -55,6 +59,24 @@ package body Ch3 is function P_Variant return Node_Id; function P_Variant_Part return Node_Id; + procedure Check_Restricted_Expression (N : Node_Id); + -- Check that the expression N meets the Restricted_Expression syntax. + -- The syntax is as follows: + -- + -- RESTRICTED_EXPRESSION ::= + -- RESTRICTED_RELATION {and RESTRICTED_RELATION} + -- | RESTRICTED_RELATION {and then RESTRICTED_RELATION} + -- | RESTRICTED_RELATION {or RESTRICTED_RELATION} + -- | RESTRICTED_RELATION {or else RESTRICTED_RELATION} + -- | RESTRICTED_RELATION {xor RESTRICTED_RELATION} + -- + -- RESTRICTED_RELATION ::= + -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] + -- + -- This syntax is used for choices when extensions (and set notations) + -- are enabled, to remove the ambiguity of "when X in A | B". We consider + -- it very unlikely that this will ever arise in practice. + procedure P_Declarative_Items (Decls : List_Id; Done : out Boolean; @@ -89,6 +111,27 @@ package body Ch3 is -- current token, and if this is the first such message issued, saves -- the message id in Missing_Begin_Msg, for possible later replacement. + + --------------------------------- + -- Check_Restricted_Expression -- + --------------------------------- + + procedure Check_Restricted_Expression (N : Node_Id) is + begin + if Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor, N_And_Then, N_Or_Else) then + Check_Restricted_Expression (Left_Opnd (N)); + Check_Restricted_Expression (Right_Opnd (N)); + + elsif Nkind_In (N, N_In, N_Not_In) + and then Paren_Count (N) = 0 + then + Error_Msg_N + ("|this expression must be parenthesized!", N); + Error_Msg_N + ("\|since extensions (and set notation) are allowed", N); + end if; + end Check_Restricted_Expression; + ------------------- -- Init_Expr_Opt -- ------------------- @@ -2057,11 +2100,14 @@ package body Ch3 is -- Error recovery: cannot raise Error_Resync - function P_Range_Or_Subtype_Mark return Node_Id is + function P_Range_Or_Subtype_Mark + (Allow_Simple_Expression : Boolean := False) return Node_Id + is Expr_Node : Node_Id; Range_Node : Node_Id; Save_Loc : Source_Ptr; + -- Start of processing for P_Range_Or_Subtype_Mark begin @@ -2071,7 +2117,8 @@ package body Ch3 is -- Scan out either a simple expression or a range (this accepts more -- than is legal here, but as explained above, we like to allow more - -- with a proper diagnostic. + -- with a proper diagnostic, and in the case of a membership operation + -- where sets are allowed, a simple expression is permissible anyway. Expr_Node := P_Simple_Expression_Or_Range_Attribute; @@ -3555,7 +3602,6 @@ package body Ch3 is begin Choices := New_List; - loop if Token = Tok_Others then Append (New_Node (N_Others_Choice, Token_Ptr), Choices); @@ -3563,6 +3609,8 @@ package body Ch3 is else begin + -- Scan out expression or range attribute + Expr_Node := P_Expression_Or_Range_Attribute; Ignore (Tok_Right_Paren); @@ -3572,9 +3620,13 @@ package body Ch3 is Error_Msg_SP ("label not permitted in this context"); Scan; -- past colon + -- Range attribute + elsif Expr_Form = EF_Range_Attr then Append (Expr_Node, Choices); + -- Explicit range + elsif Token = Tok_Dot_Dot then Check_Simple_Expression (Expr_Node); Choice_Node := New_Node (N_Range, Token_Ptr); @@ -3585,14 +3637,16 @@ package body Ch3 is Set_High_Bound (Choice_Node, Expr_Node); Append (Choice_Node, Choices); + -- Simple name, must be subtype, so range allowed + elsif Expr_Form = EF_Simple_Name then if Token = Tok_Range then Append (P_Subtype_Indication (Expr_Node), Choices); elsif Token in Token_Class_Consk then Error_Msg_SC - ("the only constraint allowed here " & - "is a range constraint"); + ("the only constraint allowed here " & + "is a range constraint"); Discard_Junk_Node (P_Constraint_Opt); Append (Expr_Node, Choices); @@ -3600,8 +3654,39 @@ package body Ch3 is Append (Expr_Node, Choices); end if; + -- Expression + else - Check_Simple_Expression_In_Ada_83 (Expr_Node); + -- If extensions are permitted then the expression must be a + -- simple expression. The resaon for this restriction (i.e. + -- going back to the Ada 83 rule) is to avoid ambiguities + -- when set membership operations are allowed, consider the + -- following: + + -- when A in 1 .. 10 | 12 => + + -- This is ambiguous without parentheses, so we require one + -- of the following two parenthesized forms to disambuguate: + + -- one of the following: + + -- when (A in 1 .. 10 | 12) => + -- when (A in 1 .. 10) | 12 => + + -- To solve this, if extensins are enabled, we disallow + -- the use of membership operations in expressions in + -- choices. Technically in the grammar, the expression + -- must match the grammar for restricted expression. + + if Extensions_Allowed then + Check_Restricted_Expression (Expr_Node); + + -- In Ada 83 mode, the syntax required a simple expression + + else + Check_Simple_Expression_In_Ada_83 (Expr_Node); + end if; + Append (Expr_Node, Choices); end if; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 38eccb19294..0d8e33cf7d7 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -79,6 +79,11 @@ package body Ch4 is -- Called to place complaint about bad range attribute at the given -- source location. Terminates by raising Error_Resync. + procedure P_Membership_Test (N : Node_Id); + -- N is the node for a N_In or N_Not_In node whose right operand has not + -- yet been processed. It is called just after scanning out the IN keyword. + -- On return, either Right_Opnd or Alternatives is set, as appropriate. + function P_Range_Attribute_Reference (Prefix_Node : Node_Id) return Node_Id; -- Scan a range attribute reference. The caller has scanned out the -- prefix. The current token is known to be an apostrophe and the @@ -857,7 +862,6 @@ package body Ch4 is exception when Error_Resync => return Error; - end P_Function_Name; -- This function parses a restricted form of Names which are either @@ -929,7 +933,6 @@ package body Ch4 is exception when Error_Resync => return Error; - end P_Qualified_Simple_Name; -- This procedure differs from P_Qualified_Simple_Name only in that it @@ -994,7 +997,6 @@ package body Ch4 is Set_Selector_Name (Selector_Node, Designator_Node); return Selector_Node; end if; - end P_Qualified_Simple_Name_Resync; ---------------------- @@ -1760,7 +1762,7 @@ package body Ch4 is -- Case of IN or NOT IN if Prev_Token = Tok_In then - Set_Right_Opnd (Node2, P_Range_Or_Subtype_Mark); + P_Membership_Test (Node2); -- Case of relational operator (= /= < <= > >=) @@ -2106,7 +2108,6 @@ package body Ch4 is Resync_Expression; Expr_Form := EF_Simple; return Error; - end P_Simple_Expression; ----------------------------------------------- @@ -2482,15 +2483,15 @@ package body Ch4 is function P_Relational_Operator return Node_Kind is Op_Kind : Node_Kind; Relop_Node : constant array (Token_Class_Relop) of Node_Kind := - (Tok_Less => N_Op_Lt, - Tok_Equal => N_Op_Eq, - Tok_Greater => N_Op_Gt, - Tok_Not_Equal => N_Op_Ne, - Tok_Greater_Equal => N_Op_Ge, - Tok_Less_Equal => N_Op_Le, - Tok_In => N_In, - Tok_Not => N_Not_In, - Tok_Box => N_Op_Ne); + (Tok_Less => N_Op_Lt, + Tok_Equal => N_Op_Eq, + Tok_Greater => N_Op_Gt, + Tok_Not_Equal => N_Op_Ne, + Tok_Greater_Equal => N_Op_Ge, + Tok_Less_Equal => N_Op_Le, + Tok_In => N_In, + Tok_Not => N_Not_In, + Tok_Box => N_Op_Ne); begin if Token = Tok_Box then @@ -2528,9 +2529,9 @@ package body Ch4 is function P_Binary_Adding_Operator return Node_Kind is Addop_Node : constant array (Token_Class_Binary_Addop) of Node_Kind := - (Tok_Ampersand => N_Op_Concat, - Tok_Minus => N_Op_Subtract, - Tok_Plus => N_Op_Add); + (Tok_Ampersand => N_Op_Concat, + Tok_Minus => N_Op_Subtract, + Tok_Plus => N_Op_Add); begin return Addop_Node (Token); end P_Binary_Adding_Operator; @@ -2551,8 +2552,8 @@ package body Ch4 is function P_Unary_Adding_Operator return Node_Kind is Addop_Node : constant array (Token_Class_Unary_Addop) of Node_Kind := - (Tok_Minus => N_Op_Minus, - Tok_Plus => N_Op_Plus); + (Tok_Minus => N_Op_Minus, + Tok_Plus => N_Op_Plus); begin return Addop_Node (Token); end P_Unary_Adding_Operator; @@ -2662,7 +2663,7 @@ package body Ch4 is function P_Conditional_Expression return Node_Id is Exprs : constant List_Id := New_List; - Loc : constant Source_Ptr := Scan_Ptr; + Loc : constant Source_Ptr := Token_Ptr; Expr : Node_Id; State : Saved_Scan_State; @@ -2670,8 +2671,8 @@ package body Ch4 is Inside_Conditional_Expression := Inside_Conditional_Expression + 1; if Token = Tok_If and then not Extensions_Allowed then - Error_Msg_SC ("conditional expression is an Ada extension"); - Error_Msg_SC ("\use -gnatX switch to compile this unit"); + Error_Msg_SC ("|conditional expression is an Ada extension"); + Error_Msg_SC ("\|use -gnatX switch to compile this unit"); end if; Scan; -- past IF or ELSIF @@ -2738,4 +2739,42 @@ package body Ch4 is Expressions => Exprs); end P_Conditional_Expression; + ----------------------- + -- P_Membership_Test -- + ----------------------- + + procedure P_Membership_Test (N : Node_Id) is + Alt : constant Node_Id := + P_Range_Or_Subtype_Mark + (Allow_Simple_Expression => Extensions_Allowed); + + begin + -- Set case + + if Token = Tok_Vertical_Bar then + if not Extensions_Allowed then + Error_Msg_SC ("set notation is a language extension"); + Error_Msg_SC ("\|use -gnatX switch to compile this unit"); + end if; + + Set_Alternatives (N, New_List (Alt)); + Set_Right_Opnd (N, Empty); + + -- Loop to accumulate alternatives + + while Token = Tok_Vertical_Bar loop + Scan; -- past vertical bar + Append_To + (Alternatives (N), + P_Range_Or_Subtype_Mark (Allow_Simple_Expression => True)); + end loop; + + -- Not set case + + else + Set_Right_Opnd (N, Alt); + Set_Alternatives (N, No_List); + end if; + end P_Membership_Test; + end Ch4; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 769e3e47c34..a323d7ad8c7 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -577,7 +577,6 @@ is function P_Known_Discriminant_Part_Opt return List_Id; function P_Signed_Integer_Type_Definition return Node_Id; function P_Range return Node_Id; - function P_Range_Or_Subtype_Mark return Node_Id; function P_Range_Constraint return Node_Id; function P_Record_Definition return Node_Id; function P_Subtype_Mark return Node_Id; @@ -629,6 +628,11 @@ is -- Ada 2005 (AI-231): The flag Not_Null_Present indicates that the -- null-excluding part has been scanned out and it was present. + function P_Range_Or_Subtype_Mark + (Allow_Simple_Expression : Boolean := False) return Node_Id; + -- Scans out a range or subtype mark, and also permits a general simple + -- expression if Allow_Simple_Expresion is set to True. + function Init_Expr_Opt (P : Boolean := False) return Node_Id; -- If an initialization expression is present (:= expression), then -- it is scanned out and returned, otherwise Empty is returned if no diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 0520cf5253c..b258ee9d980 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -27,14 +27,15 @@ with Ada.Directories; use Ada.Directories; with GNAT.HTable; use GNAT.HTable; with Makeutl; use Makeutl; +with MLib.Tgt; with Opt; use Opt; with Output; use Output; with Prj.Part; +with Prj.PP; with Prj.Proc; use Prj.Proc; with Prj.Tree; use Prj.Tree; with Prj.Util; use Prj.Util; with Prj; use Prj; -with Sinput.P; with Snames; use Snames; with System.Case_Util; use System.Case_Util; with System; @@ -397,6 +398,7 @@ package body Prj.Conf is Config : out Prj.Project_Id; Config_File_Path : out String_Access; Automatically_Generated : out Boolean; + Flags : Processing_Flags; On_Load_Config : Config_File_Hook := null) is function Default_File_Name return String; @@ -844,7 +846,8 @@ package body Prj.Conf is Always_Errout_Finalize => False, Packages_To_Check => Packages_To_Check, Current_Directory => Current_Directory, - Is_Config_File => True); + Is_Config_File => True, + Flags => Flags); else -- Maybe the user will want to create his own configuration file Config_Project_Node := Empty_Node; @@ -863,7 +866,7 @@ package body Prj.Conf is Success => Success, From_Project_Node => Config_Project_Node, From_Project_Node_Tree => Project_Node_Tree, - Report_Error => null, + Flags => Flags, Reset_Tree => False); end if; @@ -905,10 +908,9 @@ package body Prj.Conf is Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; - Report_Error : Put_Line_Access := null; + Flags : Processing_Flags; On_Load_Config : Config_File_Hook := null; - Compiler_Driver_Mandatory : Boolean := True; - Allow_Duplicate_Basenames : Boolean := False) + Reset_Tree : Boolean := True) is Main_Config_Project : Project_Id; Success : Boolean; @@ -923,7 +925,8 @@ package body Prj.Conf is Success => Success, From_Project_Node => User_Project_Node, From_Project_Node_Tree => Project_Node_Tree, - Report_Error => Report_Error); + Flags => Flags, + Reset_Tree => Reset_Tree); if not Success then Main_Project := No_Project; @@ -945,26 +948,20 @@ package body Prj.Conf is Packages_To_Check => Packages_To_Check, Config_File_Path => Config_File_Path, Automatically_Generated => Automatically_Generated, + Flags => Flags, On_Load_Config => On_Load_Config); Apply_Config_File (Main_Config_Project, Project_Tree); -- Finish processing the user's project - Sinput.P.Reset_First; - Prj.Proc.Process_Project_Tree_Phase_2 - (In_Tree => Project_Tree, - Project => Main_Project, - Success => Success, - From_Project_Node => User_Project_Node, - From_Project_Node_Tree => Project_Node_Tree, - Report_Error => Report_Error, - Current_Dir => Current_Directory, - When_No_Sources => Warning, - Compiler_Driver_Mandatory => Compiler_Driver_Mandatory, - Allow_Duplicate_Basenames => Allow_Duplicate_Basenames, - Is_Config_File => False); + (In_Tree => Project_Tree, + Project => Main_Project, + Success => Success, + From_Project_Node => User_Project_Node, + From_Project_Node_Tree => Project_Node_Tree, + Flags => Flags); if not Success then Main_Project := No_Project; @@ -989,7 +986,7 @@ package body Prj.Conf is Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; - Report_Error : Put_Line_Access := null; + Flags : Processing_Flags; On_Load_Config : Config_File_Hook := null) is begin @@ -1008,7 +1005,8 @@ package body Prj.Conf is Always_Errout_Finalize => False, Packages_To_Check => Packages_To_Check, Current_Directory => Current_Directory, - Is_Config_File => False); + Is_Config_File => False, + Flags => Flags); if User_Project_Node = Empty_Node then User_Project_Node := Empty_Node; @@ -1028,7 +1026,7 @@ package body Prj.Conf is Config_File_Path => Config_File_Path, Target_Name => Target_Name, Normalized_Hostname => Normalized_Hostname, - Report_Error => Report_Error, + Flags => Flags, On_Load_Config => On_Load_Config); end Parse_Project_And_Apply_Config; @@ -1121,4 +1119,128 @@ package body Prj.Conf is end if; end Runtime_Name_For; + ------------------------------------ + -- Add_Default_GNAT_Naming_Scheme -- + ------------------------------------ + + procedure Add_Default_GNAT_Naming_Scheme + (Config_File : in out Project_Node_Id; + Project_Tree : Project_Node_Tree_Ref) + is + procedure Create_Attribute + (Name : Name_Id; + Value : String; + Index : String := ""; + Pkg : Project_Node_Id := Empty_Node); + + ---------------------- + -- Create_Attribute -- + ---------------------- + + procedure Create_Attribute + (Name : Name_Id; + Value : String; + Index : String := ""; + Pkg : Project_Node_Id := Empty_Node) + is + Attr : Project_Node_Id; + Val : Name_Id := No_Name; + Parent : Project_Node_Id := Config_File; + begin + if Index /= "" then + Name_Len := Index'Length; + Name_Buffer (1 .. Name_Len) := Index; + Val := Name_Find; + end if; + + if Pkg /= Empty_Node then + Parent := Pkg; + end if; + + Attr := Create_Attribute + (Tree => Project_Tree, + Prj_Or_Pkg => Parent, + Name => Name, + Index_Name => Val, + Kind => Prj.Single); + + Name_Len := Value'Length; + Name_Buffer (1 .. Name_Len) := Value; + Val := Name_Find; + + Set_Expression_Of + (Attr, Project_Tree, + Enclose_In_Expression + (Create_Literal_String (Val, Project_Tree), + Project_Tree)); + end Create_Attribute; + + Name : Name_Id; + Naming : Project_Node_Id; + + -- Start of processing for Add_Default_GNAT_Naming_Scheme + + begin + if Config_File = Empty_Node then + + -- Create a dummy config file is none was found + + Name_Len := Auto_Cgpr'Length; + Name_Buffer (1 .. Name_Len) := Auto_Cgpr; + Name := Name_Find; + + -- An invalid project name to avoid conflicts with user-created ones + + Name_Len := 5; + Name_Buffer (1 .. Name_Len) := "_auto"; + + Config_File := + Create_Project + (In_Tree => Project_Tree, + Name => Name_Find, + Full_Path => Path_Name_Type (Name), + Is_Config_File => True); + + -- Setup library support + + case MLib.Tgt.Support_For_Libraries is + when None => + null; + + when Static_Only => + Create_Attribute (Name_Library_Support, "static_only"); + + when Full => + Create_Attribute (Name_Library_Support, "full"); + end case; + + if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then + Create_Attribute (Name_Library_Auto_Init_Supported, "true"); + else + Create_Attribute (Name_Library_Auto_Init_Supported, "false"); + end if; + + -- Setup Ada support (Ada is the default language here, since this + -- is only called when no config file existed initially, ie for + -- gnatmake). + + Create_Attribute (Name_Default_Language, "ada"); + + Naming := Create_Package (Project_Tree, Config_File, "naming"); + Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming); + Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming); + Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming); + Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming); + Create_Attribute (Name_Casing, "lowercase", Pkg => Naming); + + if Current_Verbosity = High then + Write_Line ("Automatically generated (in-memory) config file"); + Prj.PP.Pretty_Print + (Project => Config_File, + In_Tree => Project_Tree, + Backward_Compatibility => False); + end if; + end if; + end Add_Default_GNAT_Naming_Scheme; + end Prj.Conf; diff --git a/gcc/ada/prj-conf.ads b/gcc/ada/prj-conf.ads index 4eb8691bfc4..89a30104808 100644 --- a/gcc/ada/prj-conf.ads +++ b/gcc/ada/prj-conf.ads @@ -55,7 +55,7 @@ package Prj.Conf is Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; - Report_Error : Put_Line_Access := null; + Flags : Processing_Flags; On_Load_Config : Config_File_Hook := null); -- Find the main configuration project and parse the project tree rooted at -- this configuration project. @@ -96,13 +96,21 @@ package Prj.Conf is Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; - Report_Error : Put_Line_Access := null; + Flags : Processing_Flags; On_Load_Config : Config_File_Hook := null; - Compiler_Driver_Mandatory : Boolean := True; - Allow_Duplicate_Basenames : Boolean := False); + Reset_Tree : Boolean := True); -- Same as above, except the project must already have been parsed through -- Prj.Part.Parse, and only the processing of the project and the -- configuration is done at this level. + -- + -- If Reset_Tree is true, all projects are first removed from the tree. + -- When_No_Sources indicates what should be done when no sources are found + -- for one of the languages of the project. + -- + -- If Require_Sources_Other_Lang is true, then all languages must have at + -- least one source file, or an error is reported via When_No_Sources. If + -- it is false, this is only required for Ada (and only if it is a language + -- of the project). Invalid_Config : exception; @@ -119,6 +127,7 @@ package Prj.Conf is Config : out Prj.Project_Id; Config_File_Path : out String_Access; Automatically_Generated : out Boolean; + Flags : Processing_Flags; On_Load_Config : Config_File_Hook := null); -- Compute the name of the configuration file that should be used. If no -- default configuration file is found, a new one will be automatically @@ -132,20 +141,19 @@ package Prj.Conf is -- -- The choice and generation of a configuration file depends on several -- attributes of the user's project file (given by the Project argument), - -- like the list of languages that must be supported. Project must - -- therefore have been partially processed (phase one of the processing - -- only). + -- e.g. list of languages that must be supported. Project must therefore + -- have been partially processed (phase one of the processing only). -- -- Config_File_Name should be set to the name of the config file specified -- by the user (either through gprbuild's --config or --autoconf switches). - -- In the latter case, Autoconf_Specified should be set to true, to - -- indicate that the configuration file can be regenerated to match target - -- and languages. This name can either be an absolute path, or the a base - -- name that will be searched in the default config file directories (which + -- In the latter case, Autoconf_Specified should be set to true to indicate + -- that the configuration file can be regenerated to match target and + -- languages. This name can either be an absolute path, or the a base name + -- that will be searched in the default config file directories (which -- depends on the installation path for the tools). -- - -- Target_Name is used to chose among several possibilities - -- the configuration file that will be used. + -- Target_Name is used to chose the configuration file that will be used + -- from among several possibilities. -- -- If a project file could be found, it is automatically parsed and -- processed (and Packages_To_Check is used to indicate which packages @@ -162,6 +170,15 @@ package Prj.Conf is -- projects, so that when the second phase of the processing is performed -- these attributes are automatically taken into account. + procedure Add_Default_GNAT_Naming_Scheme + (Config_File : in out Prj.Tree.Project_Node_Id; + Project_Tree : Prj.Tree.Project_Node_Tree_Ref); + -- A hook that will create a new config file (in memory), used for + -- Get_Or_Create_Configuration_File and Process_Project_And_Apply_Config + -- and add the default GNAT naming scheme to it. Nothing is done if the + -- config_file already exists, to avoid overriding what the user might + -- have put in there. + -------------- -- Runtimes -- -------------- @@ -174,7 +191,7 @@ package Prj.Conf is -- --config switch then automatically generating a configuration file. function Runtime_Name_For (Language : Name_Id) return String; - -- Returns the runtime name for a language. Returns an empty string if - -- no runtime was specified for the language using option --RTS. + -- Returns the runtime name for a language. Returns an empty string if no + -- runtime was specified for the language using option --RTS. end Prj.Conf; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 001b2596d48..b55a7edeeb7 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -54,7 +54,8 @@ package body Prj.Dect is First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; - Packages_To_Check : String_List_Access); + Packages_To_Check : String_List_Access; + Flags : Processing_Flags); -- Parse an attribute declaration procedure Parse_Case_Construction @@ -64,7 +65,8 @@ package body Prj.Dect is Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access; - Is_Config_File : Boolean); + Is_Config_File : Boolean; + Flags : Processing_Flags); -- Parse a case construction procedure Parse_Declarative_Items @@ -75,18 +77,19 @@ package body Prj.Dect is Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access; - Is_Config_File : Boolean); - -- Parse declarative items. Depending on In_Zone, some declarative - -- items may be forbidden. - -- Is_Config_File should be set to True if the project represents a config - -- file (.cgpr) since some specific checks apply. + Is_Config_File : Boolean; + Flags : Processing_Flags); + -- Parse declarative items. Depending on In_Zone, some declarative items + -- may be forbidden. Is_Config_File should be set to True if the project + -- represents a config file (.cgpr) since some specific checks apply. procedure Parse_Package_Declaration (In_Tree : Project_Node_Tree_Ref; Package_Declaration : out Project_Node_Id; Current_Project : Project_Node_Id; Packages_To_Check : String_List_Access; - Is_Config_File : Boolean); + Is_Config_File : Boolean; + Flags : Processing_Flags); -- Parse a package declaration. -- Is_Config_File should be set to True if the project represents a config -- file (.cgpr) since some specific checks apply. @@ -94,14 +97,16 @@ package body Prj.Dect is procedure Parse_String_Type_Declaration (In_Tree : Project_Node_Tree_Ref; String_Type : out Project_Node_Id; - Current_Project : Project_Node_Id); + Current_Project : Project_Node_Id; + Flags : Processing_Flags); -- type <name> is ( <literal_string> { , <literal_string> } ) ; procedure Parse_Variable_Declaration (In_Tree : Project_Node_Tree_Ref; Variable : out Project_Node_Id; Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id); + Current_Package : Project_Node_Id; + Flags : Processing_Flags); -- Parse a variable assignment -- <variable_Name> := <expression>; OR -- <variable_Name> : <string_type_Name> := <string_expression>; @@ -116,7 +121,8 @@ package body Prj.Dect is Current_Project : Project_Node_Id; Extends : Project_Node_Id; Packages_To_Check : String_List_Access; - Is_Config_File : Boolean) + Is_Config_File : Boolean; + Flags : Processing_Flags) is First_Declarative_Item : Project_Node_Id := Empty_Node; @@ -135,7 +141,8 @@ package body Prj.Dect is Current_Project => Current_Project, Current_Package => Empty_Node, Packages_To_Check => Packages_To_Check, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); Set_First_Declarative_Item_Of (Declarations, In_Tree, To => First_Declarative_Item); end Parse; @@ -150,7 +157,8 @@ package body Prj.Dect is First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; - Packages_To_Check : String_List_Access) + Packages_To_Check : String_List_Access; + Flags : Processing_Flags) is Current_Attribute : Attribute_Node_Id := First_Attribute; Full_Associative_Array : Boolean := False; @@ -224,7 +232,7 @@ package body Prj.Dect is if not Ignore then Error_Msg_Name_1 := Token_Name; - Error_Msg ("undefined attribute %%", Token_Ptr); + Error_Msg (Flags, "undefined attribute %%", Token_Ptr); end if; end if; @@ -234,7 +242,7 @@ package body Prj.Dect is if Is_Read_Only (Current_Attribute) then Error_Msg_Name_1 := Token_Name; Error_Msg - ("read-only attribute %% cannot be given a value", + (Flags, "read-only attribute %% cannot be given a value", Token_Ptr); end if; @@ -283,7 +291,8 @@ package body Prj.Dect is if Current_Attribute /= Empty_Attribute and then Attribute_Kind_Of (Current_Attribute) = Single then - Error_Msg ("the attribute """ & + Error_Msg (Flags, + "the attribute """ & Get_Name_String (Attribute_Name_Of (Current_Attribute)) & """ cannot be an associative array", @@ -335,7 +344,8 @@ package body Prj.Dect is UI_To_Int (Int_Literal_Value); begin if Index = 0 then - Error_Msg ("index cannot be zero", Token_Ptr); + Error_Msg + (Flags, "index cannot be zero", Token_Ptr); else Set_Source_Index_Of (Attribute, In_Tree, To => Index); @@ -346,7 +356,7 @@ package body Prj.Dect is end if; when others => - Error_Msg ("index not allowed here", Token_Ptr); + Error_Msg (Flags, "index not allowed here", Token_Ptr); Scan (In_Tree); if Token = Tok_Integer_Literal then @@ -428,7 +438,7 @@ package body Prj.Dect is (Current_Project, In_Tree, Token_Name); if No (The_Project) then - Error_Msg ("unknown project", Location); + Error_Msg (Flags, "unknown project", Location); Scan (In_Tree); -- past the project name else @@ -458,7 +468,7 @@ package body Prj.Dect is then The_Project := Empty_Node; Error_Msg - ("not the same package as " & + (Flags, "not the same package as " & Get_Name_String (Name_Of (Current_Package, In_Tree)), Token_Ptr); @@ -486,8 +496,9 @@ package body Prj.Dect is Error_Msg_Name_2 := Project_Name; Error_Msg_Name_1 := Token_Name; Error_Msg - ("package % not declared in project %", - Token_Ptr); + (Flags, + "package % not declared in project %", + Token_Ptr); end if; Scan (In_Tree); -- past the package name @@ -519,7 +530,8 @@ package body Prj.Dect is if Token_Name /= Attribute_Name then The_Project := Empty_Node; Error_Msg_Name_1 := Attribute_Name; - Error_Msg ("invalid name, should be %", Token_Ptr); + Error_Msg + (Flags, "invalid name, should be %", Token_Ptr); end if; Scan (In_Tree); -- past the attribute name @@ -561,6 +573,7 @@ package body Prj.Dect is Parse_Expression (In_Tree => In_Tree, Expression => Expression, + Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => Optional_Index); @@ -581,7 +594,7 @@ package body Prj.Dect is else Error_Msg - ("wrong expression kind for attribute """ & + (Flags, "wrong expression kind for attribute """ & Get_Name_String (Attribute_Name_Of (Current_Attribute)) & """", @@ -615,7 +628,8 @@ package body Prj.Dect is Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access; - Is_Config_File : Boolean) + Is_Config_File : Boolean; + Flags : Processing_Flags) is Current_Item : Project_Node_Id := Empty_Node; Next_Item : Project_Node_Id := Empty_Node; @@ -653,6 +667,7 @@ package body Prj.Dect is Parse_Variable_Reference (In_Tree => In_Tree, Variable => Case_Variable, + Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package); Set_Case_Variable_Reference_Of @@ -668,7 +683,8 @@ package body Prj.Dect is String_Type := String_Type_Of (Case_Variable, In_Tree); if No (String_Type) then - Error_Msg ("variable """ & + Error_Msg (Flags, + "variable """ & Get_Name_String (Name_Of (Case_Variable, In_Tree)) & """ is not typed", Variable_Location); @@ -739,7 +755,8 @@ package body Prj.Dect is Current_Project => Current_Project, Current_Package => Current_Package, Packages_To_Check => Packages_To_Check, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); -- "when others =>" must be the last branch, so save the -- Case_Item and exit @@ -751,7 +768,8 @@ package body Prj.Dect is else Parse_Choice_List (In_Tree => In_Tree, - First_Choice => First_Choice); + First_Choice => First_Choice, + Flags => Flags); Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice); Expect (Tok_Arrow, "`=>`"); @@ -766,7 +784,8 @@ package body Prj.Dect is Current_Project => Current_Project, Current_Package => Current_Package, Packages_To_Check => Packages_To_Check, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); Set_First_Declarative_Item_Of (Current_Item, In_Tree, To => First_Declarative_Item); @@ -776,7 +795,8 @@ package body Prj.Dect is End_Case_Construction (Check_All_Labels => not When_Others and not Quiet_Output, - Case_Location => Location_Of (Case_Construction, In_Tree)); + Case_Location => Location_Of (Case_Construction, In_Tree), + Flags => Flags); Expect (Tok_End, "`END CASE`"); Remove_Next_End_Node; @@ -812,7 +832,8 @@ package body Prj.Dect is Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access; - Is_Config_File : Boolean) + Is_Config_File : Boolean; + Flags : Processing_Flags) is Current_Declarative_Item : Project_Node_Id := Empty_Node; Next_Declarative_Item : Project_Node_Id := Empty_Node; @@ -861,7 +882,8 @@ package body Prj.Dect is if No (The_Variable) then Error_Msg - ("a variable cannot be declared " & + (Flags, + "a variable cannot be declared " & "for the first time here", Token_Ptr); end if; @@ -872,7 +894,8 @@ package body Prj.Dect is (In_Tree, Current_Declaration, Current_Project => Current_Project, - Current_Package => Current_Package); + Current_Package => Current_Package, + Flags => Flags); Set_End_Of_Line (Current_Declaration); Set_Previous_Line_Node (Current_Declaration); @@ -885,7 +908,8 @@ package body Prj.Dect is First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package, - Packages_To_Check => Packages_To_Check); + Packages_To_Check => Packages_To_Check, + Flags => Flags); Set_End_Of_Line (Current_Declaration); Set_Previous_Line_Node (Current_Declaration); @@ -899,7 +923,8 @@ package body Prj.Dect is -- Package declaration if In_Zone /= In_Project then - Error_Msg ("a package cannot be declared here", Token_Ptr); + Error_Msg + (Flags, "a package cannot be declared here", Token_Ptr); end if; Parse_Package_Declaration @@ -907,7 +932,8 @@ package body Prj.Dect is Package_Declaration => Current_Declaration, Current_Project => Current_Project, Packages_To_Check => Packages_To_Check, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); Set_Previous_End_Node (Current_Declaration); @@ -916,14 +942,16 @@ package body Prj.Dect is -- Type String Declaration if In_Zone /= In_Project then - Error_Msg ("a string type cannot be declared here", + Error_Msg (Flags, + "a string type cannot be declared here", Token_Ptr); end if; Parse_String_Type_Declaration (In_Tree => In_Tree, String_Type => Current_Declaration, - Current_Project => Current_Project); + Current_Project => Current_Project, + Flags => Flags); Set_End_Of_Line (Current_Declaration); Set_Previous_Line_Node (Current_Declaration); @@ -939,7 +967,8 @@ package body Prj.Dect is Current_Project => Current_Project, Current_Package => Current_Package, Packages_To_Check => Packages_To_Check, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); Set_Previous_End_Node (Current_Declaration); @@ -993,7 +1022,8 @@ package body Prj.Dect is Package_Declaration : out Project_Node_Id; Current_Project : Project_Node_Id; Packages_To_Check : String_List_Access; - Is_Config_File : Boolean) + Is_Config_File : Boolean; + Flags : Processing_Flags) is First_Attribute : Attribute_Node_Id := Empty_Attribute; Current_Package : Package_Node_Id := Empty_Package; @@ -1044,7 +1074,8 @@ package body Prj.Dect is -- misspelling has been found. if Verbose_Mode or else Index /= 0 then - Error_Msg ("?""" & + Error_Msg (Flags, + "?""" & Get_Name_String (Name_Of (Package_Declaration, In_Tree)) & """ is not a known package name", @@ -1053,7 +1084,8 @@ package body Prj.Dect is if Index /= 0 then Error_Msg -- CODEFIX - ("\?possible misspelling of """ & + (Flags, + "\?possible misspelling of """ & List (Index).all & """", Token_Ptr); end if; end; @@ -1095,7 +1127,8 @@ package body Prj.Dect is if Present (Current) then Error_Msg - ("package """ & + (Flags, + "package """ & Get_Name_String (Name_Of (Package_Declaration, In_Tree)) & """ is declared twice in the same project", Token_Ptr); @@ -1119,7 +1152,8 @@ package body Prj.Dect is if Token = Tok_Renames then if Is_Config_File then Error_Msg - ("no package renames in configuration projects", Token_Ptr); + (Flags, + "no package renames in configuration projects", Token_Ptr); end if; -- Scan past "renames" @@ -1164,7 +1198,8 @@ package body Prj.Dect is else Error_Msg_Name_1 := Project_Name; Error_Msg - ("% is not an imported or extended project", Token_Ptr); + (Flags, + "% is not an imported or extended project", Token_Ptr); end if; else Set_Project_Of_Renamed_Package_Of @@ -1181,7 +1216,7 @@ package body Prj.Dect is if Token = Tok_Identifier then if Name_Of (Package_Declaration, In_Tree) /= Token_Name then - Error_Msg ("not the same package name", Token_Ptr); + Error_Msg (Flags, "not the same package name", Token_Ptr); elsif Present (Project_Of_Renamed_Package_Of (Package_Declaration, In_Tree)) @@ -1203,7 +1238,7 @@ package body Prj.Dect is if No (Current) then Error_Msg - ("""" & + (Flags, """" & Get_Name_String (Token_Name) & """ is not a package declared by the project", Token_Ptr); @@ -1233,7 +1268,8 @@ package body Prj.Dect is Current_Project => Current_Project, Current_Package => Package_Declaration, Packages_To_Check => Packages_To_Check, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); Set_First_Declarative_Item_Of (Package_Declaration, In_Tree, To => First_Declarative_Item); @@ -1256,7 +1292,7 @@ package body Prj.Dect is and then Token_Name /= Name_Of (Package_Declaration, In_Tree) then Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree); - Error_Msg ("expected %%", Token_Ptr); + Error_Msg (Flags, "expected %%", Token_Ptr); end if; if Token /= Tok_Semicolon then @@ -1270,7 +1306,7 @@ package body Prj.Dect is Remove_Next_End_Node; else - Error_Msg ("expected IS or RENAMES", Token_Ptr); + Error_Msg (Flags, "expected IS or RENAMES", Token_Ptr); end if; end Parse_Package_Declaration; @@ -1282,7 +1318,8 @@ package body Prj.Dect is procedure Parse_String_Type_Declaration (In_Tree : Project_Node_Tree_Ref; String_Type : out Project_Node_Id; - Current_Project : Project_Node_Id) + Current_Project : Project_Node_Id; + Flags : Processing_Flags) is Current : Project_Node_Id := Empty_Node; First_String : Project_Node_Id := Empty_Node; @@ -1312,7 +1349,8 @@ package body Prj.Dect is end loop; if Present (Current) then - Error_Msg ("duplicate string type name """ & + Error_Msg (Flags, + "duplicate string type name """ & Get_Name_String (Token_Name) & """", Token_Ptr); @@ -1325,7 +1363,8 @@ package body Prj.Dect is end loop; if Present (Current) then - Error_Msg ("""" & + Error_Msg (Flags, + """" & Get_Name_String (Token_Name) & """ is already a variable name", Token_Ptr); else @@ -1355,7 +1394,7 @@ package body Prj.Dect is end if; Parse_String_Type_List - (In_Tree => In_Tree, First_String => First_String); + (In_Tree => In_Tree, First_String => First_String, Flags => Flags); Set_First_Literal_String (String_Type, In_Tree, To => First_String); Expect (Tok_Right_Paren, "`)`"); @@ -1374,7 +1413,8 @@ package body Prj.Dect is (In_Tree : Project_Node_Tree_Ref; Variable : out Project_Node_Id; Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id) + Current_Package : Project_Node_Id; + Flags : Processing_Flags) is Expression_Location : Source_Ptr; String_Type_Name : Name_Id := No_Name; @@ -1448,7 +1488,8 @@ package body Prj.Dect is if The_Project_Name_And_Node = Tree_Private_Part.No_Project_Name_And_Node then - Error_Msg ("unknown project """ & + Error_Msg (Flags, + "unknown project """ & Get_Name_String (Project_String_Type_Name) & """", @@ -1491,7 +1532,8 @@ package body Prj.Dect is end if; if No (Current) then - Error_Msg ("unknown string type """ & + Error_Msg (Flags, + "unknown string type """ & Get_Name_String (String_Type_Name) & """", Type_Location); @@ -1521,6 +1563,7 @@ package body Prj.Dect is Parse_Expression (In_Tree => In_Tree, Expression => Expression, + Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => False); @@ -1533,7 +1576,8 @@ package body Prj.Dect is and then Expression_Kind_Of (Expression, In_Tree) = List then Error_Msg - ("expression must be a single string", Expression_Location); + (Flags, + "expression must be a single string", Expression_Location); end if; Set_Expression_Kind_Of @@ -1587,7 +1631,8 @@ package body Prj.Dect is if Expression_Kind_Of (The_Variable, In_Tree) /= Expression_Kind_Of (Variable, In_Tree) then - Error_Msg ("wrong expression kind for variable """ & + Error_Msg (Flags, + "wrong expression kind for variable """ & Get_Name_String (Name_Of (The_Variable, In_Tree)) & """", diff --git a/gcc/ada/prj-dect.ads b/gcc/ada/prj-dect.ads index d5a592daae7..2af6e27fd0b 100644 --- a/gcc/ada/prj-dect.ads +++ b/gcc/ada/prj-dect.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,7 +35,8 @@ private package Prj.Dect is Current_Project : Prj.Tree.Project_Node_Id; Extends : Prj.Tree.Project_Node_Id; Packages_To_Check : String_List_Access; - Is_Config_File : Boolean); + Is_Config_File : Boolean; + Flags : Processing_Flags); -- Parse project declarative items -- -- In_Tree is the project node tree diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index e3766b5d70e..b070847c89a 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -36,26 +36,47 @@ package body Prj.Env is -- Local Subprograms -- ----------------------- + package Source_Path_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Name_Id, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100); + -- A table to store the source dirs before creating the source path file + + package Object_Path_Table is new GNAT.Dynamic_Tables + (Table_Component_Type => Path_Name_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100); + -- A table to store the object dirs, before creating the object path file + procedure Add_To_Path (Source_Dirs : String_List_Id; - In_Tree : Project_Tree_Ref); + In_Tree : Project_Tree_Ref; + Buffer : in out String_Access; + Buffer_Last : in out Natural); -- Add to Ada_Path_Buffer all the source directories in string list - -- Source_Dirs, if any. Increment Ada_Path_Length. + -- Source_Dirs, if any. - procedure Add_To_Path (Dir : String; In_Tree : Project_Tree_Ref); + procedure Add_To_Path + (Dir : String; + Buffer : in out String_Access; + Buffer_Last : in out Natural); -- If Dir is not already in the global variable Ada_Path_Buffer, add it. - -- Increment Ada_Path_Length. - -- If Ada_Path_Length /= 0, prepend a Path_Separator character to - -- Path. + -- If Buffer_Last /= 0, prepend a Path_Separator character to Path. procedure Add_To_Source_Path - (Source_Dirs : String_List_Id; In_Tree : Project_Tree_Ref); + (Source_Dirs : String_List_Id; + In_Tree : Project_Tree_Ref; + Source_Paths : in out Source_Path_Table.Instance); -- Add to Ada_Path_B all the source directories in string list -- Source_Dirs, if any. Increment Ada_Path_Length. procedure Add_To_Object_Path - (Object_Dir : Path_Name_Type; - In_Tree : Project_Tree_Ref); + (Object_Dir : Path_Name_Type; + Object_Paths : in out Object_Path_Table.Instance); -- Add Object_Dir to object path table. Make sure it is not duplicate -- and it is the last one in the current table. @@ -67,14 +88,26 @@ package body Prj.Env is -- Return a project that is either Project or an extended ancestor of -- Project that itself is not extended. + procedure Create_Temp_File + (In_Tree : Project_Tree_Ref; + Path_FD : out File_Descriptor; + Path_Name : out Path_Name_Type; + File_Use : String); + -- Create a temporary file, and fail with an error if it could not be + -- created. + ---------------------- -- Ada_Include_Path -- ---------------------- function Ada_Include_Path - (Project : Project_Id; - In_Tree : Project_Tree_Ref) return String_Access + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Recursive : Boolean := False) return String is + Buffer : String_Access; + Buffer_Last : Natural := 0; + procedure Add (Project : Project_Id; Dummy : in out Boolean); -- Add source dirs of Project to the path @@ -85,50 +118,41 @@ package body Prj.Env is procedure Add (Project : Project_Id; Dummy : in out Boolean) is pragma Unreferenced (Dummy); begin - Add_To_Path (Project.Source_Dirs, In_Tree); + Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last); end Add; procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Add); + Dummy : Boolean := False; -- Start of processing for Ada_Include_Path begin - -- If it is the first time we call this function for - -- this project, compute the source path - - if Project.Ada_Include_Path = null then - In_Tree.Private_Part.Ada_Path_Length := 0; - For_All_Projects (Project, Dummy); + if Recursive then - Project.Ada_Include_Path := - new String' - (In_Tree.Private_Part.Ada_Path_Buffer - (1 .. In_Tree.Private_Part.Ada_Path_Length)); - end if; + -- If it is the first time we call this function for + -- this project, compute the source path - return Project.Ada_Include_Path; - end Ada_Include_Path; + if Project.Ada_Include_Path = null then + Buffer := new String (1 .. 4096); + For_All_Projects (Project, Dummy); + Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last)); + Free (Buffer); + end if; - ---------------------- - -- Ada_Include_Path -- - ---------------------- + return Project.Ada_Include_Path.all; - function Ada_Include_Path - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Recursive : Boolean) return String - is - begin - if Recursive then - return Ada_Include_Path (Project, In_Tree).all; else - In_Tree.Private_Part.Ada_Path_Length := 0; - Add_To_Path (Project.Source_Dirs, In_Tree); - return - In_Tree.Private_Part.Ada_Path_Buffer - (1 .. In_Tree.Private_Part.Ada_Path_Length); + Buffer := new String (1 .. 4096); + Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last); + + declare + Result : constant String := Buffer (1 .. Buffer_Last); + begin + Free (Buffer); + return Result; + end; end if; end Ada_Include_Path; @@ -138,9 +162,11 @@ package body Prj.Env is function Ada_Objects_Path (Project : Project_Id; - In_Tree : Project_Tree_Ref; Including_Libraries : Boolean := True) return String_Access is + Buffer : String_Access; + Buffer_Last : Natural := 0; + procedure Add (Project : Project_Id; Dummy : in out Boolean); -- Add all the object directories of a project to the path @@ -157,12 +183,13 @@ package body Prj.Env is Only_If_Ada => False); begin if Path /= No_Path then - Add_To_Path (Get_Name_String (Path), In_Tree); + Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last); end if; end Add; procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Add); + Dummy : Boolean := False; -- Start of processing for Ada_Objects_Path @@ -172,13 +199,11 @@ package body Prj.Env is -- this project, compute the objects path if Project.Ada_Objects_Path = null then - In_Tree.Private_Part.Ada_Path_Length := 0; + Buffer := new String (1 .. 4096); For_All_Projects (Project, Dummy); - Project.Ada_Objects_Path := - new String' - (In_Tree.Private_Part.Ada_Path_Buffer - (1 .. In_Tree.Private_Part.Ada_Path_Length)); + Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last)); + Free (Buffer); end if; return Project.Ada_Objects_Path; @@ -189,39 +214,34 @@ package body Prj.Env is ------------------------ procedure Add_To_Object_Path - (Object_Dir : Path_Name_Type; In_Tree : Project_Tree_Ref) + (Object_Dir : Path_Name_Type; + Object_Paths : in out Object_Path_Table.Instance) is begin -- Check if the directory is already in the table for Index in Object_Path_Table.First .. - Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths) + Object_Path_Table.Last (Object_Paths) loop -- If it is, remove it, and add it as the last one - if In_Tree.Private_Part.Object_Paths.Table (Index) = Object_Dir then + if Object_Paths.Table (Index) = Object_Dir then for Index2 in Index + 1 .. - Object_Path_Table.Last - (In_Tree.Private_Part.Object_Paths) + Object_Path_Table.Last (Object_Paths) loop - In_Tree.Private_Part.Object_Paths.Table (Index2 - 1) := - In_Tree.Private_Part.Object_Paths.Table (Index2); + Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2); end loop; - In_Tree.Private_Part.Object_Paths.Table - (Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)) := - Object_Dir; + Object_Paths.Table + (Object_Path_Table.Last (Object_Paths)) := Object_Dir; return; end if; end loop; -- The directory is not already in the table, add it - Object_Path_Table.Increment_Last (In_Tree.Private_Part.Object_Paths); - In_Tree.Private_Part.Object_Paths.Table - (Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)) := - Object_Dir; + Object_Path_Table.Append (Object_Paths, Object_Dir); end Add_To_Object_Path; ----------------- @@ -230,19 +250,26 @@ package body Prj.Env is procedure Add_To_Path (Source_Dirs : String_List_Id; - In_Tree : Project_Tree_Ref) + In_Tree : Project_Tree_Ref; + Buffer : in out String_Access; + Buffer_Last : in out Natural) is Current : String_List_Id := Source_Dirs; Source_Dir : String_Element; begin while Current /= Nil_String loop Source_Dir := In_Tree.String_Elements.Table (Current); - Add_To_Path (Get_Name_String (Source_Dir.Display_Value), In_Tree); + Add_To_Path (Get_Name_String (Source_Dir.Display_Value), + Buffer, Buffer_Last); Current := Source_Dir.Next; end loop; end Add_To_Path; - procedure Add_To_Path (Dir : String; In_Tree : Project_Tree_Ref) is + procedure Add_To_Path + (Dir : String; + Buffer : in out String_Access; + Buffer_Last : in out Natural) + is Len : Natural; New_Buffer : String_Access; Min_Len : Natural; @@ -280,19 +307,16 @@ package body Prj.Env is -- Start of processing for Add_To_Path begin - if Is_Present (In_Tree.Private_Part.Ada_Path_Buffer - (1 .. In_Tree.Private_Part.Ada_Path_Length), - Dir) - then + if Is_Present (Buffer (1 .. Buffer_Last), Dir) then -- Dir is already in the path, nothing to do return; end if; - Min_Len := In_Tree.Private_Part.Ada_Path_Length + Dir'Length; + Min_Len := Buffer_Last + Dir'Length; - if In_Tree.Private_Part.Ada_Path_Length > 0 then + if Buffer_Last > 0 then -- Add 1 for the Path_Separator character @@ -301,7 +325,7 @@ package body Prj.Env is -- If Ada_Path_Buffer is too small, increase it - Len := In_Tree.Private_Part.Ada_Path_Buffer'Last; + Len := Buffer'Last; if Len < Min_Len then loop @@ -310,25 +334,18 @@ package body Prj.Env is end loop; New_Buffer := new String (1 .. Len); - New_Buffer (1 .. In_Tree.Private_Part.Ada_Path_Length) := - In_Tree.Private_Part.Ada_Path_Buffer - (1 .. In_Tree.Private_Part.Ada_Path_Length); - Free (In_Tree.Private_Part.Ada_Path_Buffer); - In_Tree.Private_Part.Ada_Path_Buffer := New_Buffer; + New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); + Free (Buffer); + Buffer := New_Buffer; end if; - if In_Tree.Private_Part.Ada_Path_Length > 0 then - In_Tree.Private_Part.Ada_Path_Length := - In_Tree.Private_Part.Ada_Path_Length + 1; - In_Tree.Private_Part.Ada_Path_Buffer - (In_Tree.Private_Part.Ada_Path_Length) := Path_Separator; + if Buffer_Last > 0 then + Buffer_Last := Buffer_Last + 1; + Buffer (Buffer_Last) := Path_Separator; end if; - In_Tree.Private_Part.Ada_Path_Buffer - (In_Tree.Private_Part.Ada_Path_Length + 1 .. - In_Tree.Private_Part.Ada_Path_Length + Dir'Length) := Dir; - In_Tree.Private_Part.Ada_Path_Length := - In_Tree.Private_Part.Ada_Path_Length + Dir'Length; + Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir; + Buffer_Last := Buffer_Last + Dir'Length; end Add_To_Path; ------------------------ @@ -336,7 +353,9 @@ package body Prj.Env is ------------------------ procedure Add_To_Source_Path - (Source_Dirs : String_List_Id; In_Tree : Project_Tree_Ref) + (Source_Dirs : String_List_Id; + In_Tree : Project_Tree_Ref; + Source_Paths : in out Source_Path_Table.Instance) is Current : String_List_Id := Source_Dirs; Source_Dir : String_Element; @@ -352,25 +371,18 @@ 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 - (In_Tree.Private_Part.Source_Paths) + Source_Path_Table.Last (Source_Paths) loop -- If it is already, no need to add it - if In_Tree.Private_Part.Source_Paths.Table (Index) = - Source_Dir.Value - then + if Source_Paths.Table (Index) = Source_Dir.Value then Add_It := False; exit; end if; end loop; if Add_It then - Source_Path_Table.Increment_Last - (In_Tree.Private_Part.Source_Paths); - In_Tree.Private_Part.Source_Paths.Table - (Source_Path_Table.Last (In_Tree.Private_Part.Source_Paths)) := - Source_Dir.Value; + Source_Path_Table.Append (Source_Paths, Source_Dir.Value); end if; -- Next source directory @@ -401,9 +413,9 @@ package body Prj.Env is File_Name : Path_Name_Type := No_Path; File : File_Descriptor := Invalid_FD; - Current_Unit : Unit_Index := Units_Htable.Get_First (In_Tree.Units_HT); - Current_Naming : Naming_Id; + Iter : Source_Iterator; + Source : Source_Id; Status : Boolean; -- For call to Close @@ -418,11 +430,7 @@ package body Prj.Env is -- If not, create one, and put its name in the project data, -- with the indication that it is a temporary file. - procedure Put - (Unit_Name : Name_Id; - File_Name : File_Name_Type; - Unit_Kind : Spec_Or_Body; - Index : Int); + procedure Put (Source : Source_Id); -- Put an SFN pragma in the temporary file procedure Put (File : File_Descriptor; S : String); @@ -449,7 +457,7 @@ package body Prj.Env is if Lang = null then if Current_Verbosity = High then - Write_Str ("Languages does not contain Ada, nothing to do"); + Write_Line (" Languages does not contain Ada, nothing to do"); end if; return; @@ -537,21 +545,8 @@ package body Prj.Env is procedure Check_Temp_File is begin if File = Invalid_FD then - Tempdir.Create_Temp_File (File, Name => File_Name); - - if File = Invalid_FD then - Prj.Com.Fail - ("unable to create temporary configuration pragmas file"); - - else - Record_Temp_File (File_Name); - - if Opt.Verbose_Mode then - Write_Str ("Creating temp file """); - Write_Str (Get_Name_String (File_Name)); - Write_Line (""""); - end if; - end if; + Create_Temp_File + (In_Tree, File, File_Name, "configuration pragmas"); end if; end Check_Temp_File; @@ -559,12 +554,7 @@ package body Prj.Env is -- Put -- --------- - procedure Put - (Unit_Name : Name_Id; - File_Name : File_Name_Type; - Unit_Kind : Spec_Or_Body; - Index : Int) - is + procedure Put (Source : Source_Id) is begin -- A temporary file needs to be open @@ -573,20 +563,20 @@ package body Prj.Env is -- Put the pragma SFN for the unit kind (spec or body) Put (File, "pragma Source_File_Name_Project ("); - Put (File, Namet.Get_Name_String (Unit_Name)); + Put (File, Namet.Get_Name_String (Source.Unit.Name)); - if Unit_Kind = Spec then + if Source.Kind = Spec then Put (File, ", Spec_File_Name => """); else Put (File, ", Body_File_Name => """); end if; - Put (File, Namet.Get_Name_String (File_Name)); + Put (File, Namet.Get_Name_String (Source.File)); Put (File, """"); - if Index /= 0 then + if Source.Index /= 0 then Put (File, ", Index =>"); - Put (File, Index'Img); + Put (File, Source.Index'Img); end if; Put_Line (File, ");"); @@ -652,30 +642,20 @@ package body Prj.Env is Check_Imported_Projects (For_Project, Dummy, Imported_First => False); - -- Visit all the units and process those that need an SFN pragma + -- Visit all the files and process those that need an SFN pragma - while Current_Unit /= No_Unit_Index loop - if Current_Unit.File_Names (Spec) /= null - and then Current_Unit.File_Names (Spec).Naming_Exception - and then not Current_Unit.File_Names (Spec).Locally_Removed - then - Put (Current_Unit.Name, - Current_Unit.File_Names (Spec).File, - Spec, - Current_Unit.File_Names (Spec).Index); - end if; + Iter := For_Each_Source (In_Tree, For_Project); + while Element (Iter) /= No_Source loop + Source := Element (Iter); - if Current_Unit.File_Names (Impl) /= null - and then Current_Unit.File_Names (Impl).Naming_Exception - and then not Current_Unit.File_Names (Impl).Locally_Removed + if Source.Index >= 1 + and then not Source.Locally_Removed + and then Source.Unit /= null then - Put (Current_Unit.Name, - Current_Unit.File_Names (Impl).File, - Impl, - Current_Unit.File_Names (Impl).Index); + Put (Source); end if; - Current_Unit := Units_Htable.Get_Next (In_Tree.Units_HT); + Next (Iter); end loop; -- If there are no non standard naming scheme, issue the GNAT @@ -814,7 +794,7 @@ package body Prj.Env is if Source.Unit /= No_Unit_Index then Get_Name_String (Source.Unit.Name); - if Get_Mode = Ada_Only then + if Source.Language.Config.Kind = Unit_Based then -- ??? Mapping_Spec_Suffix could be set in the case of -- gnatmake as well @@ -874,20 +854,7 @@ package body Prj.Env is -- Create the temporary file - Tempdir.Create_Temp_File (File, Name => Name); - - if File = Invalid_FD then - Prj.Com.Fail ("unable to create temporary mapping file"); - - else - Record_Temp_File (Name); - - if Opt.Verbose_Mode then - Write_Str ("Creating temp mapping file """); - Write_Str (Get_Name_String (Name)); - Write_Line (""""); - end if; - end if; + Create_Temp_File (In_Tree, File, Name, "mapping"); For_Every_Imported_Project (Project, Dummy); GNAT.OS_Lib.Close (File, Status); @@ -902,66 +869,45 @@ package body Prj.Env is end if; end Create_Mapping_File; - -------------------------- - -- Create_New_Path_File -- - -------------------------- + ---------------------- + -- Create_Temp_File -- + ---------------------- - procedure Create_New_Path_File + procedure Create_Temp_File (In_Tree : Project_Tree_Ref; Path_FD : out File_Descriptor; - Path_Name : out Path_Name_Type) + Path_Name : out Path_Name_Type; + File_Use : String) is begin Tempdir.Create_Temp_File (Path_FD, Path_Name); if Path_Name /= No_Path then - Record_Temp_File (Path_Name); + if Current_Verbosity = High then + Write_Line ("Create temp file (" & File_Use & ") " + & Get_Name_String (Path_Name)); + end if; - -- Record the name, so that the temp path file will be deleted at the - -- end of the program. + Record_Temp_File (In_Tree, Path_Name); - Path_File_Table.Increment_Last (In_Tree.Private_Part.Path_Files); - In_Tree.Private_Part.Path_Files.Table - (Path_File_Table.Last (In_Tree.Private_Part.Path_Files)) := - Path_Name; + else + Prj.Com.Fail + ("unable to create temporary " & File_Use & " file"); end if; - end Create_New_Path_File; + end Create_Temp_File; - --------------------------- - -- Delete_All_Path_Files -- - --------------------------- - - procedure Delete_All_Path_Files (In_Tree : Project_Tree_Ref) is - Disregard : Boolean := True; - pragma Unreferenced (Disregard); + -------------------------- + -- Create_New_Path_File -- + -------------------------- + procedure Create_New_Path_File + (In_Tree : Project_Tree_Ref; + Path_FD : out File_Descriptor; + Path_Name : out Path_Name_Type) + is begin - for Index in Path_File_Table.First .. - Path_File_Table.Last (In_Tree.Private_Part.Path_Files) - loop - if In_Tree.Private_Part.Path_Files.Table (Index) /= No_Path then - Delete_File - (Get_Name_String - (In_Tree.Private_Part.Path_Files.Table (Index)), - Disregard); - end if; - end loop; - - -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or - -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to - -- the empty string. On VMS, this has the effect of deassigning - -- the logical names. - - if In_Tree.Private_Part.Ada_Prj_Include_File_Set then - Setenv (Project_Include_Path_File, ""); - In_Tree.Private_Part.Ada_Prj_Include_File_Set := False; - end if; - - if In_Tree.Private_Part.Ada_Prj_Objects_File_Set then - Setenv (Project_Objects_Path_File, ""); - In_Tree.Private_Part.Ada_Prj_Objects_File_Set := False; - end if; - end Delete_All_Path_Files; + Create_Temp_File (In_Tree, Path_FD, Path_Name, "path file"); + end Create_New_Path_File; ------------------------------------ -- File_Name_Of_Library_Unit_Body -- @@ -1364,7 +1310,6 @@ package body Prj.Env is procedure Initialize (In_Tree : Project_Tree_Ref) is begin - In_Tree.Private_Part.Fill_Mapping_File := True; In_Tree.Private_Part.Current_Source_Path_File := No_Path; In_Tree.Private_Part.Current_Object_Path_File := No_Path; end Initialize; @@ -1544,8 +1489,15 @@ package body Prj.Env is Including_Libraries : Boolean) is + Source_Paths : Source_Path_Table.Instance; + Object_Paths : Object_Path_Table.Instance; + -- List of source or object dirs. Only computed the first time this + -- procedure is called (since Source_FD is then reused) + Source_FD : File_Descriptor := Invalid_FD; Object_FD : File_Descriptor := Invalid_FD; + -- The temporary files to store the paths. These are only created the + -- first time this procedure is called, and reused from then on. Process_Source_Dirs : Boolean := False; Process_Object_Dirs : Boolean := False; @@ -1577,7 +1529,7 @@ package body Prj.Env is -- Ada sources. if Has_Ada_Sources (Project) then - Add_To_Source_Path (Project.Source_Dirs, In_Tree); + Add_To_Source_Path (Project.Source_Dirs, In_Tree, Source_Paths); end if; end if; @@ -1588,7 +1540,7 @@ package body Prj.Env is Only_If_Ada => True); if Path /= No_Path then - Add_To_Object_Path (Path, In_Tree); + Add_To_Object_Path (Path, Object_Paths); end if; end if; end Recursive_Add; @@ -1604,6 +1556,7 @@ package body Prj.Env is -- compute the source path and/or the object path. if Project.Include_Path_File = No_Path then + Source_Path_Table.Init (Source_Paths); Process_Source_Dirs := True; Create_New_Path_File (In_Tree, Source_FD, Project.Include_Path_File); @@ -1614,6 +1567,7 @@ package body Prj.Env is if Including_Libraries then if Project.Objects_Path_File_With_Libs = No_Path then + Object_Path_Table.Init (Object_Paths); Process_Object_Dirs := True; Create_New_Path_File (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs); @@ -1621,6 +1575,7 @@ package body Prj.Env is else if Project.Objects_Path_File_Without_Libs = No_Path then + Object_Path_Table.Init (Object_Paths); Process_Object_Dirs := True; Create_New_Path_File (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs); @@ -1631,19 +1586,18 @@ package body Prj.Env is -- then call the recursive procedure Add for Project. if Process_Source_Dirs or Process_Object_Dirs then - Source_Path_Table.Set_Last (In_Tree.Private_Part.Source_Paths, 0); - Object_Path_Table.Set_Last (In_Tree.Private_Part.Object_Paths, 0); For_All_Projects (Project, Dummy); end if; - -- Write and close any file that has been created + -- Write and close any file that has been created. Source_FD is not set + -- when this subprogram is called a second time or more, since we reuse + -- the previous version of the file. if Source_FD /= Invalid_FD then for Index in Source_Path_Table.First .. - Source_Path_Table.Last - (In_Tree.Private_Part.Source_Paths) + Source_Path_Table.Last (Source_Paths) loop - Get_Name_String (In_Tree.Private_Part.Source_Paths.Table (Index)); + Get_Name_String (Source_Paths.Table (Index)); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len); @@ -1662,10 +1616,9 @@ package body Prj.Env is if Object_FD /= Invalid_FD then for Index in Object_Path_Table.First .. - Object_Path_Table.Last - (In_Tree.Private_Part.Object_Paths) + Object_Path_Table.Last (Object_Paths) loop - Get_Name_String (In_Tree.Private_Part.Object_Paths.Table (Index)); + Get_Name_String (Object_Paths.Table (Index)); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len); @@ -1693,7 +1646,6 @@ package body Prj.Env is Set_Path_File_Var (Project_Include_Path_File, Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File)); - In_Tree.Private_Part.Ada_Prj_Include_File_Set := True; end if; if Including_Libraries then @@ -1706,7 +1658,6 @@ package body Prj.Env is (Project_Objects_Path_File, Get_Name_String (In_Tree.Private_Part.Current_Object_Path_File)); - In_Tree.Private_Part.Ada_Prj_Objects_File_Set := True; end if; else @@ -1719,22 +1670,10 @@ package body Prj.Env is (Project_Objects_Path_File, Get_Name_String (In_Tree.Private_Part.Current_Object_Path_File)); - In_Tree.Private_Part.Ada_Prj_Objects_File_Set := True; end if; end if; end Set_Ada_Paths; - --------------------------------------------- - -- Set_Mapping_File_Initial_State_To_Empty -- - --------------------------------------------- - - procedure Set_Mapping_File_Initial_State_To_Empty - (In_Tree : Project_Tree_Ref) - is - begin - In_Tree.Private_Part.Fill_Mapping_File := False; - end Set_Mapping_File_Initial_State_To_Empty; - ----------------------- -- Set_Path_File_Var -- ----------------------- diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index 97a2d363d11..ffcea0756b6 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -55,12 +55,6 @@ package Prj.Env is -- -- See fmap for a description of the format of the mapping file - procedure Set_Mapping_File_Initial_State_To_Empty - (In_Tree : Project_Tree_Ref); - -- When creating a mapping file, create an empty map. This case occurs when - -- run time source files are found in the project files. This only applies - -- to the Ada_Only mode. - procedure Create_Config_Pragmas_File (For_Project : Project_Id; In_Tree : Project_Tree_Ref); @@ -72,19 +66,11 @@ package Prj.Env is Path_FD : out File_Descriptor; Path_Name : out Path_Name_Type); -- Create a new temporary path file. Get the file name in Path_Name. - -- The name is normally obtained by increasing the number in - -- Temp_Path_File_Name by 1. - - function Ada_Include_Path - (Project : Project_Id; - In_Tree : Project_Tree_Ref) return String_Access; - -- Get the source search path of a Project file. For the first call, - -- compute it and cache it. function Ada_Include_Path (Project : Project_Id; In_Tree : Project_Tree_Ref; - Recursive : Boolean) return String; + Recursive : Boolean := False) return String; -- Get the source search path of a Project file. If Recursive it True, get -- all the source directories of the imported and modified project files -- (recursively). If Recursive is False, just get the path for the source @@ -93,7 +79,6 @@ package Prj.Env is function Ada_Objects_Path (Project : Project_Id; - In_Tree : Project_Tree_Ref; Including_Libraries : Boolean := True) return String_Access; -- Get the ADA_OBJECTS_PATH of a Project file. For the first call, compute -- it and cache it. When Including_Libraries is False, do not include the @@ -106,9 +91,6 @@ package Prj.Env is -- Set the environment variables for additional project path files, after -- creating the path files if necessary. - procedure Delete_All_Path_Files (In_Tree : Project_Tree_Ref); - -- Delete all temporary path files that have been created by Set_Ada_Paths - function File_Name_Of_Library_Unit_Body (Name : String; Project : Project_Id; diff --git a/gcc/ada/prj-err.adb b/gcc/ada/prj-err.adb index 9ed4cb4df91..8e0d5627a67 100644 --- a/gcc/ada/prj-err.adb +++ b/gcc/ada/prj-err.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -68,4 +68,57 @@ package body Prj.Err is end if; end Post_Scan; + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg + (Flags : Processing_Flags; + Msg : String; + Location : Source_Ptr := No_Location; + Project : Project_Id := null) + is + Real_Location : Source_Ptr := Location; + + begin + -- Display the error message in the traces so that it appears in the + -- correct location in the traces (otherwise error messages are only + -- displayed at the end and it is difficult to see when they were + -- triggered) + + if Current_Verbosity = High then + Write_Line ("ERROR: " & Msg); + end if; + + -- If location of error is unknown, use the location of the project + + if Real_Location = No_Location + and then Project /= null + then + Real_Location := Project.Location; + end if; + + if Real_Location = No_Location then + + -- If still null, we are parsing a project that was created in-memory + -- so we shouldn't report errors for projects that the user has no + -- access to in any case. + + return; + end if; + + -- Report the error through Errutil, so that duplicate errors are + -- properly removed, messages are sorted, and correctly interpreted,... + + Errutil.Error_Msg (Msg, Real_Location); + + -- Let the application know there was an error + + if Flags.Report_Error /= null then + Flags.Report_Error + (Project, + Is_Warning => Msg (Msg'First) = '?' or else Msg (Msg'First) = '<'); + end if; + end Error_Msg; + end Prj.Err; diff --git a/gcc/ada/prj-err.ads b/gcc/ada/prj-err.ads index e937c353f32..d07285ecb2d 100644 --- a/gcc/ada/prj-err.ads +++ b/gcc/ada/prj-err.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -28,6 +28,14 @@ -- the GNAT tree packages (Atree, Sinfo, ...). It uses exactly the same global -- variables as Errout, located in package Err_Vars. Like Errout, it also uses -- the common variables and routines in package Erroutc. +-- +-- Parameters are set through Err_Vars.Error_Msg_File_* or +-- Err_Vars.Error_Msg_Name_*, and replaced automatically in the messages +-- ("{{" for files, "%%" for names). +-- +-- However, in this package you can configure the error messages to be sent +-- to your own callback by setting Report_Error in the flags. This ensures +-- that applications can control where error messages are displayed. with Scng; with Errutil; @@ -59,29 +67,21 @@ package Prj.Err is -- Finalize processing of error messages for one file and output message -- indicating the number of detected errors. - procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) - renames Errutil.Error_Msg; - -- Output a message at specified location - - procedure Error_Msg_S (Msg : String) renames Errutil.Error_Msg_S; - -- Output a message at current scan pointer location - - procedure Error_Msg_SC (Msg : String) renames Errutil.Error_Msg_SC; - -- Output a message at the start of the current token, unless we are at - -- the end of file, in which case we always output the message after the - -- last real token in the file. - - procedure Error_Msg_SP (Msg : String) renames Errutil.Error_Msg_SP; - -- Output a message at the start of the previous token + procedure Error_Msg + (Flags : Processing_Flags; + Msg : String; + Location : Source_Ptr := No_Location; + Project : Project_Id := null); + -- Output an error message, either through Flags.Error_Report or through + -- Errutil. The location defaults to the project's location ("project" + -- in the source code). If Msg starts with "?", this is a warning, and + -- Warning: is added at the beginning. If Msg starts with "<", see comment + -- for Err_Vars.Error_Msg_Warn. ------------- -- Scanner -- ------------- - package Style renames Errutil.Style; - -- Instantiation of the generic style package, needed for the instantiation - -- of the generic scanner below. - procedure Obsolescent_Check (S : Source_Ptr); -- Dummy null procedure for Scng instantiation @@ -90,12 +90,12 @@ package Prj.Err is package Scanner is new Scng (Post_Scan => Post_Scan, - Error_Msg => Error_Msg, - Error_Msg_S => Error_Msg_S, - Error_Msg_SC => Error_Msg_SC, - Error_Msg_SP => Error_Msg_SP, + Error_Msg => Errutil.Error_Msg, + Error_Msg_S => Errutil.Error_Msg_S, + Error_Msg_SC => Errutil.Error_Msg_SC, + Error_Msg_SP => Errutil.Error_Msg_SP, Obsolescent_Check => Obsolescent_Check, - Style => Style); + Style => Errutil.Style); -- Instantiation of the generic scanner end Prj.Err; diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb index 37c6296787f..8098a3a23b1 100644 --- a/gcc/ada/prj-ext.adb +++ b/gcc/ada/prj-ext.adb @@ -25,7 +25,6 @@ with Hostparm; with Makeutl; use Makeutl; -with Output; use Output; with Osint; use Osint; with Sdefault; with Table; @@ -139,23 +138,8 @@ package body Prj.Ext is Last : Positive; New_Len : Positive; New_Last : Positive; - Prj_Path : String_Access := Gpr_Prj_Path; begin - if Gpr_Prj_Path.all /= "" then - - -- In Ada only mode, warn if both environment variables are defined - - if Get_Mode = Ada_Only and then Ada_Prj_Path.all /= "" then - Write_Line - ("Warning: ADA_PROJECT_PATH is not taken into account"); - Write_Line (" when GPR_PROJECT_PATH is defined"); - end if; - - else - Prj_Path := Ada_Prj_Path; - end if; - -- The current directory is always first Name_Len := 1; @@ -172,11 +156,16 @@ package body Prj.Ext is -- If environment variable is defined and not empty, add its content - if Prj_Path.all /= "" then + if Gpr_Prj_Path.all /= "" then Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Path_Separator; + Add_Str_To_Name_Buffer (Gpr_Prj_Path.all); + end if; - Add_Str_To_Name_Buffer (Prj_Path.all); + if Ada_Prj_Path.all /= "" then + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Path_Separator; + Add_Str_To_Name_Buffer (Ada_Prj_Path.all); end if; -- Scan the directory path to see if "-" is one of the directories. @@ -255,17 +244,15 @@ package body Prj.Ext is if Add_Default_Dir then declare Prefix : String_Ptr := Sdefault.Search_Dir_Prefix; + begin if Prefix = null then Prefix := new String'(Executable_Prefix_Path); if Prefix.all /= "" then - if Get_Mode = Multi_Language then - Add_Str_To_Name_Buffer - (Path_Separator & Prefix.all & - "share" & Directory_Separator & "gpr"); - end if; - + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & + "share" & Directory_Separator & "gpr"); Add_Str_To_Name_Buffer (Path_Separator & Prefix.all & Directory_Separator & "lib" & diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index 7ae8c3d9a21..0f91936b1b7 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -766,7 +766,8 @@ package body Prj.Makr is (File_Path : String; Project_File : Boolean; Preproc_Switches : Argument_List; - Very_Verbose : Boolean) + Very_Verbose : Boolean; + Flags : Processing_Flags) is begin Makr.Very_Verbose := Initialize.Very_Verbose; @@ -846,6 +847,7 @@ package body Prj.Makr is Always_Errout_Finalize => False, Store_Comments => True, Is_Config_File => False, + Flags => Flags, Current_Directory => Get_Current_Dir, Packages_To_Check => Packages_To_Check_By_Gnatname); diff --git a/gcc/ada/prj-makr.ads b/gcc/ada/prj-makr.ads index b3a658fc3e9..91543a2ff79 100644 --- a/gcc/ada/prj-makr.ads +++ b/gcc/ada/prj-makr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -36,7 +36,8 @@ package Prj.Makr is (File_Path : String; Project_File : Boolean; Preproc_Switches : Argument_List; - Very_Verbose : Boolean); + Very_Verbose : Boolean; + Flags : Processing_Flags); -- Start the creation of a configuration pragmas file or the creation or -- modification of a project file, for gnatname. -- diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 2ff40e40706..7b04af75e69 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -25,20 +25,16 @@ with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.HTable; +with GNAT.Dynamic_HTables; with Err_Vars; use Err_Vars; -with Hostparm; -with MLib.Tgt; with Opt; use Opt; with Osint; use Osint; with Output; use Output; -with Prj.Env; use Prj.Env; -with Prj.Err; +with Prj.Err; use Prj.Err; with Prj.Util; use Prj.Util; with Sinput.P; with Snames; use Snames; -with Table; use Table; with Targparm; use Targparm; with Ada.Characters.Handling; use Ada.Characters.Handling; @@ -54,203 +50,166 @@ package body Prj.Nmsc is -- Used in Check_Library for continuation error messages at the same -- location. - Error_Report : Put_Line_Access := null; - -- Set to point to error reporting procedure - - When_No_Sources : Error_Warning := Error; - -- Indicates what should be done when there is no Ada sources in a non - -- extending Ada project. - - ALI_Suffix : constant String := ".ali"; - -- File suffix for ali files - type Name_Location is record - Name : File_Name_Type; + Name : File_Name_Type; -- ??? duplicates the key Location : Source_Ptr; Source : Source_Id := No_Source; - Except : Boolean := False; Found : Boolean := False; end record; - -- Information about file names found in string list attribute: - -- Source_Files or in a source list file, stored in hash table. - -- Source_Names, used by procedure Get_Path_Names_And_Record_Sources. - -- Except is set to True if source is a naming exception in the project. - No_Name_Location : constant Name_Location := - (Name => No_File, - Location => No_Location, - Source => No_Source, - Except => False, - Found => False); - - package Source_Names is new GNAT.HTable.Simple_HTable + (No_File, No_Location, No_Source, False); + package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Name_Location, No_Element => No_Name_Location, Key => File_Name_Type, Hash => Hash, Equal => "="); - -- Hash table to store file names found in string list attribute - -- Source_Files or in a source list file, stored in hash table - -- Source_Names, used by procedure Get_Path_Names_And_Record_Sources. - -- - -- ??? Should not be a global table, as it is needed only when processing - -- a project - - -- More documentation needed on what unit exceptions are about ??? + -- Information about file names 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. + -- This is used to check that all referenced files were indeed found on the + -- disk. type Unit_Exception is record - Name : Name_Id; + Name : Name_Id; -- ??? duplicates the key Spec : File_Name_Type; Impl : File_Name_Type; end record; - -- Record special naming schemes for Ada units (name of spec file and name - -- of implementation file). - No_Unit_Exception : constant Unit_Exception := - (Name => No_Name, - Spec => No_File, - Impl => No_File); + No_Unit_Exception : constant Unit_Exception := (No_Name, No_File, No_File); - package Unit_Exceptions is new GNAT.HTable.Simple_HTable + package Unit_Exceptions_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Unit_Exception, No_Element => No_Unit_Exception, Key => Name_Id, Hash => Hash, Equal => "="); - -- Hash table to store the unit exceptions. - -- ??? Seems to be used only by the multi_lang mode - -- ??? Should not be a global array, but stored in the project_data - - package Recursive_Dirs is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Element => Boolean, - No_Element => False, - Key => Name_Id, - Hash => Hash, - Equal => "="); - -- Hash table stores recursive source directories, to avoid looking several - -- times, and to avoid cycles that may be introduced by symbolic links. - - type Ada_Naming_Exception_Id is new Nat; - No_Ada_Naming_Exception : constant Ada_Naming_Exception_Id := 0; + -- Record special naming schemes for Ada units (name of spec file and name + -- of implementation file). The elements in this list come from the naming + -- exceptions specified in the project files. - type Unit_Info is record - Kind : Spec_Or_Body; - Unit : Name_Id; - Next : Ada_Naming_Exception_Id := No_Ada_Naming_Exception; + type File_Found is record + File : File_Name_Type := No_File; + Found : Boolean := False; + Location : Source_Ptr := No_Location; end record; - -- Comment needed??? - package Ada_Naming_Exception_Table is new Table.Table - (Table_Component_Type => Unit_Info, - Table_Index_Type => Ada_Naming_Exception_Id, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Prj.Nmsc.Ada_Naming_Exception_Table"); + No_File_Found : constant File_Found := (No_File, False, No_Location); - package Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable + package Excluded_Sources_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, - Element => Ada_Naming_Exception_Id, - No_Element => No_Ada_Naming_Exception, + Element => File_Found, + No_Element => No_File_Found, Key => File_Name_Type, Hash => Hash, Equal => "="); - -- A hash table to store naming exceptions for Ada. For each file name - -- there is one or several unit in table Ada_Naming_Exception_Table. - -- ??? This is for ada_only mode, we should be able to merge with - -- Unit_Exceptions table, used by multi_lang mode. + -- A hash table to store the base names of excluded files, if any. - package Object_File_Names is new GNAT.HTable.Simple_HTable + package Object_File_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, - Element => File_Name_Type, - No_Element => No_File, + Element => Source_Id, + No_Element => No_Source, Key => File_Name_Type, Hash => Hash, Equal => "="); -- A hash table to store the object file names for a project, to check that -- two different sources have different object file names. - type File_Found is record - File : File_Name_Type := No_File; - Found : Boolean := False; - Location : Source_Ptr := No_Location; + type Project_Processing_Data is record + Project : Project_Id; + Source_Names : Source_Names_Htable.Instance; + Unit_Exceptions : Unit_Exceptions_Htable.Instance; + Excluded : Excluded_Sources_Htable.Instance; + + Source_List_File_Location : Source_Ptr; + -- Location of the Source_List_File attribute, for error messages end record; - No_File_Found : constant File_Found := (No_File, False, No_Location); - -- Comments needed ??? + -- This is similar to Tree_Processing_Data, but contains project-specific + -- information which is only useful while processing the project, and can + -- be discarded as soon as we have finished processing the project - package Excluded_Sources_Htable is new GNAT.HTable.Simple_HTable + package Files_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, - Element => File_Found, - No_Element => No_File_Found, + Element => Source_Id, + No_Element => No_Source, Key => File_Name_Type, Hash => Hash, Equal => "="); - -- A hash table to store the excluded files, if any. This is filled by - -- Find_Excluded_Sources below. + -- Mapping from base file names to Source_Id (containing full info about + -- the source). + + type Tree_Processing_Data is record + Tree : Project_Tree_Ref; + File_To_Source : Files_Htable.Instance; + Flags : Prj.Processing_Flags; + end record; + -- Temporary data which is needed while parsing a project. It does not need + -- to be kept in memory once a project has been fully loaded, but is + -- necessary while performing consistency checks (duplicate sources,...) + -- This data must be initialized before processing any project, and the + -- same data is used for processing all projects in the tree. + + procedure Initialize + (Data : out Tree_Processing_Data; + Tree : Project_Tree_Ref; + Flags : Prj.Processing_Flags); + -- Initialize Data + + procedure Free (Data : in out Tree_Processing_Data); + -- Free the memory occupied by Data + + procedure Check + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Process the naming scheme for a single project. + + procedure Initialize + (Data : in out Project_Processing_Data; + Project : Project_Id); + procedure Free (Data : in out Project_Processing_Data); + -- Initialize or free memory for a project-specific data procedure Find_Excluded_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref); + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data); -- Find the list of files that should not be considered as source files - -- for this project. Sets the list in the Excluded_Sources_Htable. + -- for this project. Sets the list in the Project.Excluded_Sources_Htable. procedure Override_Kind (Source : Source_Id; Kind : Source_Kind); -- Override the reference kind for a source file. This properly updates -- the unit data if necessary. - function Hash (Unit : Unit_Info) return Header_Num; - - type Name_And_Index is record - Name : Name_Id := No_Name; - Index : Int := 0; - end record; - No_Name_And_Index : constant Name_And_Index := - (Name => No_Name, Index => 0); - -- Name of a unit, and its index inside the source file. The first unit has - -- index 1 (see doc for pragma Source_File_Name), but the index might be - -- set to 0 when the source file contains a single unit. - - package Reverse_Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Element => Name_And_Index, - No_Element => No_Name_And_Index, - Key => Unit_Info, - Hash => Hash, - Equal => "="); - -- A table to check if a unit with an exceptional name will hide a source - -- with a file name following the naming convention. - procedure Load_Naming_Exceptions - (Project : Project_Id; - In_Tree : Project_Tree_Ref); + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data); -- All source files in Data.First_Source are considered as naming -- exceptions, and copied into the Source_Names and Unit_Exceptions tables -- as appropriate. procedure Add_Source (Id : out Source_Id; - In_Tree : Project_Tree_Ref; + Data : in out Tree_Processing_Data; Project : Project_Id; Lang_Id : Language_Ptr; Kind : Source_Kind; File_Name : File_Name_Type; Display_File : File_Name_Type; - Naming_Exception : Boolean := False; + Naming_Exception : Boolean := False; Path : Path_Information := No_Path_Information; - Alternate_Languages : Language_List := null; - Unit : Name_Id := No_Name; - Index : Int := 0; - Source_To_Replace : Source_Id := No_Source); + Alternate_Languages : Language_List := null; + Unit : Name_Id := No_Name; + Index : Int := 0; + Locally_Removed : Boolean := False; + Location : Source_Ptr := No_Location); -- Add a new source to the different lists: list of all sources in the -- project tree, list of source of a project and list of sources of a -- language. -- -- If Path is specified, the file is also added to Source_Paths_HT. - -- If Source_To_Replace is specified, it points to the source in the - -- extended project that the new file is overriding. + -- + -- Location is used for error messages function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type; -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id. @@ -269,131 +228,78 @@ package body Prj.Nmsc is -- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is -- converted to lower-case at the same time. - function ALI_File_Name (Source : String) return String; - -- Return the ALI file name corresponding to a source - procedure Check_Ada_Name (Name : String; Unit : out Name_Id); -- Check that a name is a valid Ada unit name procedure Check_Package_Naming (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Is_Config_File : Boolean; + Data : in out Tree_Processing_Data; Bodies : out Array_Element_Id; Specs : out Array_Element_Id); -- Check the naming scheme part of Data, and initialize the naming scheme - -- data in the config of the various languages. Is_Config_File should be - -- True if Project is a config file (.cgpr) This also returns the naming - -- scheme exceptions for unit-based languages (Bodies and Specs are + -- data in the config of the various languages. This also returns the + -- naming scheme exceptions for unit-based languages (Bodies and Specs are -- associative arrays mapping individual unit names to source file names). procedure Check_Configuration - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Compiler_Driver_Mandatory : Boolean); + (Project : Project_Id; + Data : in out Tree_Processing_Data); -- Check the configuration attributes for the project - -- If Compiler_Driver_Mandatory is true, then a Compiler.Driver attribute - -- for each language must be defined, or we will not look for its source - -- files. procedure Check_If_Externally_Built (Project : Project_Id; - In_Tree : Project_Tree_Ref); + Data : in out Tree_Processing_Data); -- Check attribute Externally_Built of project Project in project tree - -- In_Tree and modify its data Data if it has the value "true". + -- Data.Tree and modify its data Data if it has the value "true". procedure Check_Interfaces (Project : Project_Id; - In_Tree : Project_Tree_Ref); + Data : in out Tree_Processing_Data); -- If a list of sources is specified in attribute Interfaces, set -- In_Interfaces only for the sources specified in the list. procedure Check_Library_Attributes - (Project : Project_Id; - In_Tree : Project_Tree_Ref); - -- Check the library attributes of project Project in project tree In_Tree + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check the library attributes of project Project in project tree -- and modify its data Data accordingly. - -- Current_Dir should represent the current directory, and is passed for - -- efficiency to avoid system calls to recompute it. procedure Check_Programming_Languages - (In_Tree : Project_Tree_Ref; - Project : Project_Id); + (Project : Project_Id; + Data : in out Tree_Processing_Data); -- Check attribute Languages for the project with data Data in project - -- tree In_Tree and set the components of Data for all the programming + -- tree Data.Tree and set the components of Data for all the programming -- languages indicated in attribute Languages, if any. - function Check_Project - (P : Project_Id; - Root_Project : Project_Id; - Extending : Boolean) return Boolean; - -- Returns True if P is Root_Project or, if Extending is True, a project - -- extended by Root_Project. - procedure Check_Stand_Alone_Library (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Current_Dir : String; - Extending : Boolean); - -- Check if project Project in project tree In_Tree is a Stand-Alone + Data : in out Tree_Processing_Data); + -- Check if project Project in project tree Data.Tree is a Stand-Alone -- Library project, and modify its data Data accordingly if it is one. - -- Current_Dir should represent the current directory, and is passed for - -- efficiency to avoid system calls to recompute it. - - procedure Check_And_Normalize_Unit_Names - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - List : Array_Element_Id; - Debug_Name : String); - -- Check that a list of unit names contains only valid names. Casing - -- is normalized where appropriate. - -- Debug_Name is the name representing the list, and is used for debug - -- output only. - - procedure Find_Ada_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Explicit_Sources_Only : Boolean; - Proc_Data : in out Processing_Data); - -- Find all Ada sources by traversing all source directories. If - -- Explicit_Sources_Only is True, then the sources found must belong to - -- the list of sources specified explicitly in the project file. If - -- Explicit_Sources_Only is False, then all sources matching the naming - -- scheme are recorded. function Compute_Directory_Last (Dir : String) return Natural; -- Return the index of the last significant character in Dir. This is used -- to avoid duplicate '/' (slash) characters at the end of directory names. - procedure Error_Msg - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Msg : String; - Flag_Location : Source_Ptr); - -- Output an error message. If Error_Report is null, simply call - -- Prj.Err.Error_Msg. Otherwise, disregard Flag_Location and use - -- Error_Report. - procedure Search_Directories - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - For_All_Sources : Boolean; - Allow_Duplicate_Basenames : Boolean); + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data; + For_All_Sources : Boolean); -- Search the source directories to find the sources. If For_All_Sources is -- True, check each regular file name against the naming schemes of the - -- different languages. Otherwise consider only the file names in the hash - -- table Source_Names. If Allow_Duplicate_Basenames, then files with the - -- same base names are authorized within a project for source-based - -- languages (never for unit based languages) + -- various languages. Otherwise consider only the file names in hash table + -- Source_Names. If Allow_Duplicate_Basenames then files with identical + -- base names are permitted within a project for source-based languages + -- (never for unit based languages). procedure Check_File - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Path : Path_Name_Type; - File_Name : File_Name_Type; - Display_File_Name : File_Name_Type; - For_All_Sources : Boolean; - Allow_Duplicate_Basenames : Boolean); + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data; + Path : Path_Name_Type; + File_Name : File_Name_Type; + Display_File_Name : File_Name_Type; + Locally_Removed : Boolean; + For_All_Sources : Boolean); -- Check if file File_Name is a valid source of the project. This is used -- in multi-language mode only. When the file matches one of the naming -- schemes, it is added to various htables through Add_Source and to @@ -405,21 +311,16 @@ package body Prj.Nmsc is -- File_Name is the same as Name, but has been normalized. -- Display_File_Name, however, has not been normalized. -- - -- Source_Directory is the directory in which the file - -- was found. It hasn't been normalized (nor has had links resolved). - -- It should not end with a directory separator, to avoid duplicates - -- later on. + -- Source_Directory is the directory in which the file was found. It is + -- neither normalized nor has had links resolved, and must not end with a + -- a directory separator, to avoid duplicates later on. -- -- If For_All_Sources is True, then all possible file names are analyzed - -- otherwise only those currently set in the Source_Names htable. - -- - -- If Allow_Duplicate_Basenames, then files with the same base names are - -- authorized within a project for source-based languages (never for unit - -- based languages) + -- otherwise only those currently set in the Source_Names hash table. procedure Check_File_Naming_Schemes (In_Tree : Project_Tree_Ref; - Project : Project_Id; + Project : Project_Processing_Data; File_Name : File_Name_Type; Alternate_Languages : out Language_List; Language : out Language_Ptr; @@ -433,36 +334,29 @@ package body Prj.Nmsc is -- being investigated. It has been normalized (case-folded). File_Name is -- the same value. - procedure Free_Ada_Naming_Exceptions; - -- Free the internal hash tables used for checking naming exceptions - procedure Get_Directories (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Current_Dir : String); + Data : in out Tree_Processing_Data); -- Get the object directory, the exec directory and the source directories - -- of a project. Current_Dir should represent the current directory, and is - -- passed for efficiency to avoid system calls to recompute it. + -- of a project. procedure Get_Mains (Project : Project_Id; - In_Tree : Project_Tree_Ref); + Data : in out Tree_Processing_Data); -- Get the mains of a project from attribute Main, if it exists, and put -- them in the project data. procedure Get_Sources_From_File (Path : String; Location : Source_Ptr; - Project : Project_Id; - In_Tree : Project_Tree_Ref); + Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data); -- Get the list of sources from a text file and put them in hash table -- Source_Names. procedure Find_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Proc_Data : in out Processing_Data; - Allow_Duplicate_Basenames : Boolean); + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data); -- Process the Source_Files and Source_List_File attributes, and store the -- list of source files into the Source_Names htable. When these attributes -- are not defined, find all files matching the naming schemes in the @@ -475,36 +369,30 @@ 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); -- 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. - procedure Get_Unit - (In_Tree : Project_Tree_Ref; - Canonical_File_Name : File_Name_Type; - Project : Project_Id; - Exception_Id : out Ada_Naming_Exception_Id; - Unit_Name : out Name_Id; - Unit_Kind : out Spec_Or_Body); - -- Find out, from a file name, the unit name, the unit kind and if a - -- specific SFN pragma is needed. If the file name corresponds to no unit, - -- then Unit_Name will be No_Name. If the file is a multi-unit source or an - -- exception to the naming scheme, then Exception_Id is set to the unit or - -- units that the source contains, and the other information are not set. - - function Is_Illegal_Suffix - (Suffix : File_Name_Type; - Dot_Replacement : File_Name_Type) return Boolean; - -- Returns True if the string Suffix cannot be used as a spec suffix, a - -- body suffix or a separate suffix. + procedure Check_Illegal_Suffix + (Project : Project_Id; + Suffix : File_Name_Type; + Dot_Replacement : File_Name_Type; + Attribute_Name : String; + Location : Source_Ptr; + Data : in out Tree_Processing_Data); + -- Display an error message if the given suffix is illegal for some reason. + -- The name of the attribute we are testing is specified in Attribute_Name, + -- which is used in the error message. Location is the location where the + -- suffix is defined. procedure Locate_Directory (Project : Project_Id; - In_Tree : Project_Tree_Ref; Name : File_Name_Type; Path : out Path_Information; Dir_Exists : out Boolean; + Data : in out Tree_Processing_Data; Create : String := ""; Location : Source_Ptr := No_Location; Must_Exist : Boolean := True; @@ -517,20 +405,15 @@ package body Prj.Nmsc is -- returned), or simply returned without checking for its existence (if -- Must_Exist is False) or No_Path_Information is returned. In all cases, -- Dir_Exists indicates whether the directory now exists. Create is also - -- used for debugging traces to show which path we are - -- computing + -- used for debugging traces to show which path we are computing. procedure Look_For_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Proc_Data : in out Processing_Data; - Allow_Duplicate_Basenames : Boolean); - -- Find all the sources of project Project in project tree In_Tree and + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data); + -- Find all the sources of project Project in project tree Data.Tree and -- update its Data accordingly. This assumes that Data.First_Source has -- been initialized with the list of excluded sources and special naming - -- exceptions. If Allow_Duplicate_Basenames, then files with the same base - -- names are authorized within a project for source-based languages (never - -- for unit based languages) + -- exceptions. function Path_Name_Of (File_Name : File_Name_Type; @@ -538,38 +421,18 @@ package body Prj.Nmsc is -- Returns the path name of a (non project) file. Returns an empty string -- if file cannot be found. - procedure Prepare_Ada_Naming_Exceptions - (List : Array_Element_Id; - In_Tree : Project_Tree_Ref; - Kind : Spec_Or_Body); - -- Prepare the internal hash tables used for checking naming exceptions - -- for Ada. Insert all elements of List in the tables. - - procedure Record_Ada_Source - (File_Name : File_Name_Type; - Path_Name : Path_Name_Type; - Project : Project_Id; - In_Tree : Project_Tree_Ref; - Proc_Data : in out Processing_Data; - Ada_Language : Language_Ptr; - Location : Source_Ptr; - Source_Recorded : in out Boolean); - -- Put a unit in the list of units of a project, if the file name - -- corresponds to a valid unit name. Ada_Language is a pointer to the - -- Language_Data for "Ada" in Project. - procedure Remove_Source (Id : Source_Id; Replaced_By : Source_Id); - -- Remove a file from the list of sources of a project. - -- This might be because the file is replaced by another one in an - -- extending project, or because a file was added as a naming exception - -- but was not found in the end. + -- Remove a file from the list of sources of a project. This might be + -- because the file is replaced by another one in an extending project, + -- or because a file was added as a naming exception but was not found + -- in the end. procedure Report_No_Sources (Project : Project_Id; Lang_Name : String; - In_Tree : Project_Tree_Ref; + Data : Tree_Processing_Data; Location : Source_Ptr; Continuation : Boolean := False); -- Report an error or a warning depending on the value of When_No_Sources @@ -579,15 +442,6 @@ package body Prj.Nmsc is (Project : Project_Id; In_Tree : Project_Tree_Ref); -- List all the source directories of a project - procedure Warn_If_Not_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Conventions : Array_Element_Id; - Specs : Boolean; - Extending : Boolean); - -- Check that individual naming conventions apply to immediate sources of - -- the project. If not, issue a warning. - procedure Write_Attr (Name, Value : String); -- Debug print a value for a specific property. Does nothing when not in -- debug mode @@ -679,29 +533,173 @@ package body Prj.Nmsc is procedure Add_Source (Id : out Source_Id; - In_Tree : Project_Tree_Ref; + Data : in out Tree_Processing_Data; Project : Project_Id; Lang_Id : Language_Ptr; Kind : Source_Kind; File_Name : File_Name_Type; Display_File : File_Name_Type; - Naming_Exception : Boolean := False; + Naming_Exception : Boolean := False; Path : Path_Information := No_Path_Information; - Alternate_Languages : Language_List := null; - Unit : Name_Id := No_Name; - Index : Int := 0; - Source_To_Replace : Source_Id := No_Source) + Alternate_Languages : Language_List := null; + Unit : Name_Id := No_Name; + Index : Int := 0; + Locally_Removed : Boolean := False; + Location : Source_Ptr := No_Location) is - Config : constant Language_Config := Lang_Id.Config; - UData : Unit_Index; + 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 + -- Check if the same file name or unit is used in the prj tree + + Add_Src := True; + + if Unit /= No_Name then + Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit); + end if; + + if Prev_Unit /= No_Unit_Index + and then (Kind = Impl or Kind = Spec) + and then Prev_Unit.File_Names (Kind) /= null + then + -- Suspicious, we need to check later whether this is authorized + + Add_Src := False; + Source := Prev_Unit.File_Names (Kind); + + else + Source := Files_Htable.Get (Data.File_To_Source, File_Name); + + if Source /= No_Source + and then Source.Index = Index + then + Add_Src := False; + end if; + end if; + + -- Duplication of file/unit in same project is allowed if order of + -- source directories is known. + + if Add_Src = False then + Add_Src := True; + + if Project = Source.Project then + if Prev_Unit = No_Unit_Index then + if Data.Flags.Allow_Duplicate_Basenames then + Add_Src := True; + + elsif Project.Known_Order_Of_Source_Dirs then + Add_Src := False; + + else + Error_Msg_File_1 := File_Name; + Error_Msg + (Data.Flags, "duplicate source file name {", + Location, Project); + Add_Src := False; + end if; + + else + if Project.Known_Order_Of_Source_Dirs then + Add_Src := False; + + -- We might be seeing the same file through a different path + -- (for instance because of symbolic links). + + elsif Source.Path.Name /= Path.Name then + Error_Msg_Name_1 := Unit; + Error_Msg + (Data.Flags, "duplicate unit %%", Location, Project); + Add_Src := False; + end if; + end if; + + -- Do not allow the same unit name in different projects, except + -- if one is extending the other. + + -- For a file based language, the same file name replaces a file + -- in a project being extended, but it is allowed to have the same + -- file name in unrelated projects. + + elsif Is_Extending (Project, Source.Project) then + if not Locally_Removed then + Source_To_Replace := Source; + end if; + + elsif Prev_Unit /= No_Unit_Index + and then not Source.Locally_Removed + then + -- Path is set if this is a source we found on the disk, in which + -- case we can provide more explicit error message. Path is unset + -- when the source is added from one of the naming exceptions in + -- the project. + + if Path /= No_Path_Information then + Error_Msg_Name_1 := Unit; + Error_Msg + (Data.Flags, + "unit %% cannot belong to several projects", + Location, Project); + + Error_Msg_Name_1 := Project.Name; + Error_Msg_Name_2 := Name_Id (Path.Name); + Error_Msg + (Data.Flags, "\ project %%, %%", Location, Project); + + Error_Msg_Name_1 := Source.Project.Name; + Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name); + Error_Msg + (Data.Flags, "\ project %%, %%", Location, Project); + + else + Error_Msg_Name_1 := Unit; + Error_Msg_Name_2 := Source.Project.Name; + Error_Msg + (Data.Flags, "unit %% already belongs to project %%", + Location, Project); + end if; + + Add_Src := False; + + elsif not Source.Locally_Removed + and then not Data.Flags.Allow_Duplicate_Basenames + and then Lang_Id.Config.Kind = Unit_Based + then + Error_Msg_File_1 := File_Name; + Error_Msg_File_2 := File_Name_Type (Source.Project.Name); + Error_Msg + (Data.Flags, + "{ is already a source of project {", Location, Project); + + -- Add the file anyway, to avoid further warnings like "language + -- unknown". + + Add_Src := True; + end if; + end if; + + if not Add_Src then + return; + end if; + + -- Add the new file + Id := new Source_Data; if Current_Verbosity = High then Write_Str ("Adding source File: "); Write_Str (Get_Name_String (File_Name)); + if Index /= 0 then + Write_Str (" at" & Index'Img); + end if; + if Lang_Id.Config.Kind = Unit_Based then Write_Str (" Unit: "); @@ -723,23 +721,18 @@ package body Prj.Nmsc is Id.Language := Lang_Id; Id.Kind := Kind; Id.Alternate_Languages := Alternate_Languages; + Id.Locally_Removed := Locally_Removed; -- Add the source id to the Unit_Sources_HT hash table, if the unit name -- is not null. if Unit /= No_Name then - Unit_Sources_Htable.Set (In_Tree.Unit_Sources_HT, Unit, Id); - - -- ??? Record_Unit has already fetched that earlier, so this isn't - -- the most efficient way. But we can't really pass a parameter since - -- Process_Exceptions_Unit_Based and Check_File haven't looked it up. - - UData := Units_Htable.Get (In_Tree.Units_HT, Unit); + UData := Units_Htable.Get (Data.Tree.Units_HT, Unit); if UData = No_Unit_Index then UData := new Unit_Data; UData.Name := Unit; - Units_Htable.Set (In_Tree.Units_HT, Unit, UData); + Units_Htable.Set (Data.Tree.Units_HT, Unit, UData); end if; Id.Unit := UData; @@ -763,7 +756,7 @@ package body Prj.Nmsc is if Path /= No_Path_Information then Id.Path := Path; - Source_Paths_Htable.Set (In_Tree.Source_Paths_HT, Path.Name, Id); + Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id); end if; -- Add the source to the language list @@ -774,26 +767,9 @@ package body Prj.Nmsc is if Source_To_Replace /= No_Source then Remove_Source (Source_To_Replace, Id); end if; - end Add_Source; - - ------------------- - -- ALI_File_Name -- - ------------------- - function ALI_File_Name (Source : String) return String is - begin - -- If the source name has extension, replace it with the ALI suffix - - for Index in reverse Source'First + 1 .. Source'Last loop - if Source (Index) = '.' then - return Source (Source'First .. Index - 1) & ALI_Suffix; - end if; - end loop; - - -- If no dot, or if it is the first character, just add the ALI suffix - - return Source & ALI_Suffix; - end ALI_File_Name; + Files_Htable.Set (Data.File_To_Source, File_Name, Id); + end Add_Source; ------------------------------ -- Canonical_Case_File_Name -- @@ -815,35 +791,26 @@ package body Prj.Nmsc is ----------- procedure Check - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Report_Error : Put_Line_Access; - When_No_Sources : Error_Warning; - Current_Dir : String; - Proc_Data : in out Processing_Data; - Is_Config_File : Boolean; - Compiler_Driver_Mandatory : Boolean; - Allow_Duplicate_Basenames : Boolean) + (Project : Project_Id; + Data : in out Tree_Processing_Data) is Specs : Array_Element_Id; Bodies : Array_Element_Id; Extending : Boolean := False; + Prj_Data : Project_Processing_Data; begin - Nmsc.When_No_Sources := When_No_Sources; - Error_Report := Report_Error; + Initialize (Prj_Data, Project); - Recursive_Dirs.Reset; - - Check_If_Externally_Built (Project, In_Tree); + Check_If_Externally_Built (Project, Data); -- Object, exec and source directories - Get_Directories (Project, In_Tree, Current_Dir); + Get_Directories (Project, Data); -- Get the programming languages - Check_Programming_Languages (In_Tree, Project); + Check_Programming_Languages (Project, Data); if Project.Qualifier = Dry and then Project.Source_Dirs /= Nil_String @@ -852,19 +819,19 @@ package body Prj.Nmsc is Source_Dirs : constant Variable_Value := Util.Value_Of (Name_Source_Dirs, - Project.Decl.Attributes, In_Tree); + Project.Decl.Attributes, Data.Tree); Source_Files : constant Variable_Value := Util.Value_Of (Name_Source_Files, - Project.Decl.Attributes, In_Tree); + Project.Decl.Attributes, Data.Tree); Source_List_File : constant Variable_Value := Util.Value_Of (Name_Source_List_File, - Project.Decl.Attributes, In_Tree); + Project.Decl.Attributes, Data.Tree); Languages : constant Variable_Value := Util.Value_Of (Name_Languages, - Project.Decl.Attributes, In_Tree); + Project.Decl.Attributes, Data.Tree); begin if Source_Dirs.Values = Nil_String @@ -876,62 +843,39 @@ package body Prj.Nmsc is else Error_Msg - (Project, In_Tree, + (Data.Flags, "at least one of Source_Files, Source_Dirs or Languages " & "must be declared empty for an abstract project", - Project.Location); + Project.Location, Project); end if; end; end if; - -- Check configuration in multi language mode + -- Check configuration. This must be done even for gnatmake (even though + -- no user configuration file was provided) since the default config we + -- generate indicates whether libraries are supported for instance. - if Must_Check_Configuration then - Check_Configuration - (Project, In_Tree, - Compiler_Driver_Mandatory => Compiler_Driver_Mandatory); - end if; + Check_Configuration (Project, Data); -- Library attributes - Check_Library_Attributes (Project, In_Tree); + Check_Library_Attributes (Project, Data); if Current_Verbosity = High then - Show_Source_Dirs (Project, In_Tree); + Show_Source_Dirs (Project, Data.Tree); end if; Extending := Project.Extends /= No_Project; - Check_Package_Naming (Project, In_Tree, Is_Config_File, Bodies, Specs); - - if Get_Mode = Ada_Only then - Prepare_Ada_Naming_Exceptions (Bodies, In_Tree, Impl); - Prepare_Ada_Naming_Exceptions (Specs, In_Tree, Spec); - end if; + Check_Package_Naming (Project, Data, Bodies => Bodies, Specs => Specs); -- Find the sources if Project.Source_Dirs /= Nil_String then - Look_For_Sources - (Project, In_Tree, Proc_Data, Allow_Duplicate_Basenames); - - if Get_Mode = Ada_Only then - - -- Check that all individual naming conventions apply to sources - -- of this project file. - - Warn_If_Not_Sources - (Project, In_Tree, Bodies, - Specs => False, - Extending => Extending); - Warn_If_Not_Sources - (Project, In_Tree, Specs, - Specs => True, - Extending => Extending); - - elsif Get_Mode = Multi_Language and then - (not Project.Externally_Built) and then - (not Extending) + Look_For_Sources (Prj_Data, Data); + + if not Project.Externally_Built + and then not Extending then declare Language : Language_Ptr; @@ -947,8 +891,11 @@ package body Prj.Nmsc is -- If there are no sources for this language, check if there -- are sources for which this is an alternate language. - if Language.First_Source = No_Source then - Iter := For_Each_Source (In_Tree => In_Tree, + if Language.First_Source = No_Source + and then (Data.Flags.Require_Sources_Other_Lang + or else Language.Name = Name_Ada) + then + Iter := For_Each_Source (In_Tree => Data.Tree, Project => Project); Source_Loop : loop Source := Element (Iter); @@ -965,11 +912,12 @@ package body Prj.Nmsc is end loop Source_Loop; if Source = No_Source then + Report_No_Sources (Project, Get_Name_String (Language.Display_Name), - In_Tree, - Project.Location, + Data, + Prj_Data.Source_List_File_Location, Continuation); Continuation := True; end if; @@ -981,26 +929,22 @@ package body Prj.Nmsc is end if; end if; - if Get_Mode = Multi_Language then + -- If a list of sources is specified in attribute Interfaces, set + -- In_Interfaces only for the sources specified in the list. - -- If a list of sources is specified in attribute Interfaces, set - -- In_Interfaces only for the sources specified in the list. - - Check_Interfaces (Project, In_Tree); - end if; + Check_Interfaces (Project, Data); -- If it is a library project file, check if it is a standalone library if Project.Library then - Check_Stand_Alone_Library - (Project, In_Tree, Current_Dir, Extending); + Check_Stand_Alone_Library (Project, Data); end if; -- Put the list of Mains, if any, in the project data - Get_Mains (Project, In_Tree); + Get_Mains (Project, Data); - Free_Ada_Naming_Exceptions; + Free (Prj_Data); end Check; -------------------- @@ -1193,9 +1137,8 @@ package body Prj.Nmsc is ------------------------- procedure Check_Configuration - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Compiler_Driver_Mandatory : Boolean) + (Project : Project_Id; + Data : in out Tree_Processing_Data) is Dot_Replacement : File_Name_Type := No_File; Casing : Casing_Type := All_Lower_Case; @@ -1258,11 +1201,11 @@ package body Prj.Nmsc is Current_Array_Id := Arrays; while Current_Array_Id /= No_Array loop - Current_Array := In_Tree.Arrays.Table (Current_Array_Id); + Current_Array := Data.Tree.Arrays.Table (Current_Array_Id); Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Element_Id); + Element := Data.Tree.Array_Elements.Table (Element_Id); if Element.Index /= All_Other_Names then @@ -1286,7 +1229,7 @@ package body Prj.Nmsc is (Into_List => Lang_Index.Config.Binder_Required_Switches, From_List => Element.Value.Values, - In_Tree => In_Tree); + In_Tree => Data.Tree); when Name_Prefix => @@ -1336,7 +1279,7 @@ package body Prj.Nmsc is Attribute_Id := Attributes; while Attribute_Id /= No_Variable loop Attribute := - In_Tree.Variable_Elements.Table (Attribute_Id); + Data.Tree.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Executable_Suffix then @@ -1369,11 +1312,11 @@ package body Prj.Nmsc is Current_Array_Id := Arrays; while Current_Array_Id /= No_Array loop - Current_Array := In_Tree.Arrays.Table (Current_Array_Id); + Current_Array := Data.Tree.Arrays.Table (Current_Array_Id); Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Element_Id); + Element := Data.Tree.Array_Elements.Table (Element_Id); if Element.Index /= All_Other_Names then @@ -1398,7 +1341,7 @@ package body Prj.Nmsc is Put (Into_List => Lang_Index.Config.Dependency_Option, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); end if; when Name_Dependency_Driver => @@ -1415,7 +1358,7 @@ package body Prj.Nmsc is Put (Into_List => Lang_Index.Config.Compute_Dependency, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); end if; when Name_Include_Switches => @@ -1426,16 +1369,13 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, - In_Tree, - "include option cannot be null", - Element.Value.Location); + (Data.Flags, "include option cannot be null", + Element.Value.Location, Project); end if; - Put (Into_List => - Lang_Index.Config.Include_Option, + Put (Into_List => Lang_Index.Config.Include_Option, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); when Name_Include_Path => @@ -1464,14 +1404,14 @@ package body Prj.Nmsc is Lang_Index.Config. Compiler_Leading_Required_Switches, From_List => Element.Value.Values, - In_Tree => In_Tree); + In_Tree => Data.Tree); when Name_Trailing_Required_Switches => Put (Into_List => Lang_Index.Config. Compiler_Trailing_Required_Switches, From_List => Element.Value.Values, - In_Tree => In_Tree); + In_Tree => Data.Tree); when Name_Path_Syntax => begin @@ -1482,18 +1422,17 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, - In_Tree, + (Data.Flags, "invalid value for Path_Syntax", - Element.Value.Location); + Element.Value.Location, Project); end; when Name_Object_File_Suffix => if Get_Name_String (Element.Value.Value) = "" then Error_Msg - (Project, In_Tree, + (Data.Flags, "object file suffix cannot be empty", - Element.Value.Location); + Element.Value.Location, Project); else Lang_Index.Config.Object_File_Suffix := @@ -1504,7 +1443,7 @@ package body Prj.Nmsc is Put (Into_List => Lang_Index.Config.Object_File_Switches, From_List => Element.Value.Values, - In_Tree => In_Tree); + In_Tree => Data.Tree); when Name_Pic_Option => @@ -1514,16 +1453,15 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, - In_Tree, + (Data.Flags, "compiler PIC option cannot be null", - Element.Value.Location); + Element.Value.Location, Project); end if; Put (Into_List => Lang_Index.Config.Compilation_PIC_Option, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); when Name_Mapping_File_Switches => @@ -1533,16 +1471,15 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, - In_Tree, + (Data.Flags, "mapping file switches cannot be null", - Element.Value.Location); + Element.Value.Location, Project); end if; Put (Into_List => - Lang_Index.Config.Mapping_File_Switches, + Lang_Index.Config.Mapping_File_Switches, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); when Name_Mapping_Spec_Suffix => @@ -1566,16 +1503,15 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, - In_Tree, + (Data.Flags, "config file switches cannot be null", - Element.Value.Location); + Element.Value.Location, Project); end if; Put (Into_List => Lang_Index.Config.Config_File_Switches, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); when Name_Objects_Path => @@ -1632,10 +1568,9 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, - In_Tree, + (Data.Flags, "illegal value for Config_File_Unique", - Element.Value.Location); + Element.Value.Location, Project); end; when others => @@ -1664,7 +1599,7 @@ package body Prj.Nmsc is Attribute_Id := Attributes; while Attribute_Id /= No_Variable loop - Attribute := In_Tree.Variable_Elements.Table (Attribute_Id); + Attribute := Data.Tree.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Separate_Suffix then @@ -1686,10 +1621,9 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, - In_Tree, + (Data.Flags, "invalid value for Casing", - Attribute.Value.Location); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Dot_Replacement then @@ -1716,11 +1650,11 @@ package body Prj.Nmsc is Current_Array_Id := Arrays; while Current_Array_Id /= No_Array loop - Current_Array := In_Tree.Arrays.Table (Current_Array_Id); + Current_Array := Data.Tree.Arrays.Table (Current_Array_Id); Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Element_Id); + Element := Data.Tree.Array_Elements.Table (Element_Id); -- Get the name of the language @@ -1778,7 +1712,7 @@ package body Prj.Nmsc is Attribute_Id := Attributes; while Attribute_Id /= No_Variable loop Attribute := - In_Tree.Variable_Elements.Table (Attribute_Id); + Data.Tree.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Driver then @@ -1804,7 +1738,7 @@ package body Prj.Nmsc is Put (Into_List => Project.Config.Minimum_Linker_Options, From_List => Attribute.Value.Values, - In_Tree => In_Tree); + In_Tree => Data.Tree); elsif Attribute.Name = Name_Map_File_Option then Project.Config.Map_File_Option := Attribute.Value.Value; @@ -1818,10 +1752,9 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, - In_Tree, + (Data.Flags, "value must be positive or equal to 0", - Attribute.Value.Location); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Response_File_Format then @@ -1847,17 +1780,16 @@ package body Prj.Nmsc is else Error_Msg - (Project, - In_Tree, + (Data.Flags, "illegal response file format", - Attribute.Value.Location); + Attribute.Value.Location, Project); end if; end; elsif Attribute.Name = Name_Response_File_Switches then Put (Into_List => Project.Config.Resp_File_Options, From_List => Attribute.Value.Values, - In_Tree => In_Tree); + In_Tree => Data.Tree); end if; end if; @@ -1870,7 +1802,7 @@ package body Prj.Nmsc is begin Packages := Project.Decl.Packages; while Packages /= No_Package loop - Element := In_Tree.Packages.Table (Packages); + Element := Data.Tree.Packages.Table (Packages); case Element.Name is when Name_Binder => @@ -1927,7 +1859,7 @@ package body Prj.Nmsc is Attribute_Id := Project.Decl.Attributes; while Attribute_Id /= No_Variable loop Attribute := - In_Tree.Variable_Elements.Table (Attribute_Id); + Data.Tree.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Target then @@ -1953,15 +1885,14 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, - In_Tree, + (Data.Flags, "archive builder cannot be null", - Attribute.Value.Location); + Attribute.Value.Location, Project); end if; Put (Into_List => Project.Config.Archive_Builder, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); elsif Attribute.Name = Name_Archive_Builder_Append_Option then @@ -1975,7 +1906,7 @@ package body Prj.Nmsc is (Into_List => Project.Config.Archive_Builder_Append_Option, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); end if; elsif Attribute.Name = Name_Archive_Indexer then @@ -1988,15 +1919,14 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, - In_Tree, + (Data.Flags, "archive indexer cannot be null", - Attribute.Value.Location); + Attribute.Value.Location, Project); end if; Put (Into_List => Project.Config.Archive_Indexer, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); elsif Attribute.Name = Name_Library_Partial_Linker then @@ -2008,25 +1938,23 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, - In_Tree, + (Data.Flags, "partial linker cannot be null", - Attribute.Value.Location); + Attribute.Value.Location, Project); end if; Put (Into_List => Project.Config.Lib_Partial_Linker, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); elsif Attribute.Name = Name_Library_GCC then Project.Config.Shared_Lib_Driver := File_Name_Type (Attribute.Value.Value); Error_Msg - (Project, - In_Tree, + (Data.Flags, "?Library_'G'C'C is an obsolescent attribute, " & "use Linker''Driver instead", - Attribute.Value.Location); + Attribute.Value.Location, Project); elsif Attribute.Name = Name_Archive_Suffix then Project.Config.Archive_Suffix := @@ -2041,15 +1969,14 @@ package body Prj.Nmsc is if List = Nil_String then Error_Msg - (Project, - In_Tree, + (Data.Flags, "linker executable option cannot be null", - Attribute.Value.Location); + Attribute.Value.Location, Project); end if; Put (Into_List => Project.Config.Linker_Executable_Option, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); elsif Attribute.Name = Name_Linker_Lib_Dir_Option then @@ -2061,10 +1988,9 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, - In_Tree, + (Data.Flags, "linker library directory option cannot be empty", - Attribute.Value.Location); + Attribute.Value.Location, Project); end if; Project.Config.Linker_Lib_Dir_Option := @@ -2080,10 +2006,9 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, - In_Tree, + (Data.Flags, "linker library name option cannot be empty", - Attribute.Value.Location); + Attribute.Value.Location, Project); end if; Project.Config.Linker_Lib_Name_Option := @@ -2099,7 +2024,7 @@ package body Prj.Nmsc is if List /= Nil_String then Put (Into_List => Project.Config.Run_Path_Option, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); end if; elsif Attribute.Name = Name_Separate_Run_Path_Options then @@ -2111,12 +2036,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, - In_Tree, + (Data.Flags, "invalid value """ & Get_Name_String (Attribute.Value.Value) & """ for Separate_Run_Path_Options", - Attribute.Value.Location); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Library_Support then @@ -2129,12 +2053,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, - In_Tree, + (Data.Flags, "invalid value """ & Get_Name_String (Attribute.Value.Value) & """ for Library_Support", - Attribute.Value.Location); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Shared_Library_Prefix then @@ -2155,12 +2078,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, - In_Tree, + (Data.Flags, "invalid value """ & Get_Name_String (Attribute.Value.Value) & """ for Symbolic_Link_Supported", - Attribute.Value.Location); + Attribute.Value.Location, Project); end; elsif @@ -2175,12 +2097,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, - In_Tree, + (Data.Flags, "invalid value """ & Get_Name_String (Attribute.Value.Value) & """ for Library_Major_Minor_Id_Supported", - Attribute.Value.Location); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Library_Auto_Init_Supported then @@ -2192,12 +2113,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, - In_Tree, + (Data.Flags, "invalid value """ & Get_Name_String (Attribute.Value.Value) & """ for Library_Auto_Init_Supported", - Attribute.Value.Location); + Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then @@ -2206,7 +2126,7 @@ package body Prj.Nmsc is if List /= Nil_String then Put (Into_List => Project.Config.Shared_Lib_Min_Options, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); end if; elsif Attribute.Name = Name_Library_Version_Switches then @@ -2215,7 +2135,7 @@ package body Prj.Nmsc is if List /= Nil_String then Put (Into_List => Project.Config.Lib_Version_Options, From_List => List, - In_Tree => In_Tree); + In_Tree => Data.Tree); end if; end if; end if; @@ -2240,11 +2160,11 @@ package body Prj.Nmsc is Current_Array_Id := Project.Decl.Arrays; while Current_Array_Id /= No_Array loop - Current_Array := In_Tree.Arrays.Table (Current_Array_Id); + Current_Array := Data.Tree.Arrays.Table (Current_Array_Id); Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Element_Id); + Element := Data.Tree.Array_Elements.Table (Element_Id); -- Get the name of the language @@ -2262,7 +2182,7 @@ package body Prj.Nmsc is (Into_List => Lang_Index.Config.Include_Compatible_Languages, From_List => List, - In_Tree => In_Tree, + In_Tree => Data.Tree, Lower_Case => True); end if; @@ -2316,12 +2236,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, - In_Tree, + (Data.Flags, "invalid value """ & Get_Name_String (Element.Value.Value) & """ for Object_Generated", - Element.Value.Location); + Element.Value.Location, Project); end; when Name_Objects_Linked => @@ -2344,12 +2263,11 @@ package body Prj.Nmsc is exception when Constraint_Error => Error_Msg - (Project, - In_Tree, + (Data.Flags, "invalid value """ & Get_Name_String (Element.Value.Value) & """ for Objects_Linked", - Element.Value.Location); + Element.Value.Location, Project); end; when others => null; @@ -2411,16 +2329,15 @@ package body Prj.Nmsc is -- For all languages, Compiler_Driver needs to be specified. This is -- only needed if we do intend to compile (not in GPS for instance). - if Compiler_Driver_Mandatory + if Data.Flags.Compiler_Driver_Mandatory and then Lang_Index.Config.Compiler_Driver = No_File then Error_Msg_Name_1 := Lang_Index.Display_Name; Error_Msg - (Project, - In_Tree, + (Data.Flags, "?no compiler specified for language %%" & ", ignoring all its sources", - No_Location); + No_Location, Project); if Lang_Index = Project.Languages then Project.Languages := Lang_Index.Next; @@ -2436,26 +2353,23 @@ package body Prj.Nmsc is if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then Error_Msg - (Project, - In_Tree, + (Data.Flags, "Dot_Replacement not specified for Ada", - No_Location); + No_Location, Project); end if; if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then Error_Msg - (Project, - In_Tree, + (Data.Flags, "Spec_Suffix not specified for Ada", - No_Location); + No_Location, Project); end if; if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then Error_Msg - (Project, - In_Tree, + (Data.Flags, "Body_Suffix not specified for Ada", - No_Location); + No_Location, Project); end if; else @@ -2464,15 +2378,15 @@ package body Prj.Nmsc is -- For file based languages, either Spec_Suffix or Body_Suffix -- need to be specified. - if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File and then - Lang_Index.Config.Naming_Data.Body_Suffix = No_File + if Data.Flags.Require_Sources_Other_Lang + and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File + and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File then Error_Msg_Name_1 := Lang_Index.Display_Name; Error_Msg - (Project, - In_Tree, + (Data.Flags, "no suffixes specified for %%", - No_Location); + No_Location, Project); end if; end if; @@ -2486,12 +2400,12 @@ package body Prj.Nmsc is procedure Check_If_Externally_Built (Project : Project_Id; - In_Tree : Project_Tree_Ref) + Data : in out Tree_Processing_Data) is Externally_Built : constant Variable_Value := Util.Value_Of (Name_Externally_Built, - Project.Decl.Attributes, In_Tree); + Project.Decl.Attributes, Data.Tree); begin if not Externally_Built.Default then @@ -2502,9 +2416,9 @@ package body Prj.Nmsc is Project.Externally_Built := True; elsif Name_Buffer (1 .. Name_Len) /= "false" then - Error_Msg (Project, In_Tree, + Error_Msg (Data.Flags, "Externally_Built may only be true or false", - Externally_Built.Location); + Externally_Built.Location, Project); end if; end if; @@ -2532,13 +2446,13 @@ package body Prj.Nmsc is procedure Check_Interfaces (Project : Project_Id; - In_Tree : Project_Tree_Ref) + Data : in out Tree_Processing_Data) is Interfaces : constant Prj.Variable_Value := Prj.Util.Value_Of (Snames.Name_Interfaces, Project.Decl.Attributes, - In_Tree); + Data.Tree); List : String_List_Id; Element : String_Element; @@ -2556,7 +2470,7 @@ package body Prj.Nmsc is Project_2 := Project; while Project_2 /= No_Project loop - Iter := For_Each_Source (In_Tree, Project_2); + Iter := For_Each_Source (Data.Tree, Project_2); loop Source := Prj.Element (Iter); exit when Source = No_Source; @@ -2569,13 +2483,13 @@ package body Prj.Nmsc is List := Interfaces.Values; while List /= Nil_String loop - Element := In_Tree.String_Elements.Table (List); + Element := Data.Tree.String_Elements.Table (List); Name := Canonical_Case_File_Name (Element.Value); Project_2 := Project; Big_Loop : while Project_2 /= No_Project loop - Iter := For_Each_Source (In_Tree, Project_2); + Iter := For_Each_Source (Data.Tree, Project_2); loop Source := Prj.Element (Iter); @@ -2613,11 +2527,10 @@ package body Prj.Nmsc is Error_Msg_Name_1 := Project.Name; Error_Msg - (Project, - In_Tree, + (Data.Flags, "{ cannot be an interface of project %% " & "as it is not one of its sources", - Element.Location); + Element.Location, Project); end if; List := Element.Next; @@ -2629,7 +2542,7 @@ package body Prj.Nmsc is Project.Interfaces_Defined := Project.Extends.Interfaces_Defined; if Project.Interfaces_Defined then - Iter := For_Each_Source (In_Tree, Project); + Iter := For_Each_Source (Data.Tree, Project); loop Source := Prj.Element (Iter); exit when Source = No_Source; @@ -2644,82 +2557,25 @@ package body Prj.Nmsc is end if; end Check_Interfaces; - ------------------------------------ - -- Check_And_Normalize_Unit_Names -- - ------------------------------------ - - procedure Check_And_Normalize_Unit_Names - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - List : Array_Element_Id; - Debug_Name : String) - is - Current : Array_Element_Id; - Element : Array_Element; - Unit_Name : Name_Id; - - begin - if Current_Verbosity = High then - Write_Line (" Checking unit names in " & Debug_Name); - end if; - - Current := List; - while Current /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Current); - Element.Value.Value := - Name_Id (Canonical_Case_File_Name (Element.Value.Value)); - - -- Check that it contains a valid unit name - - Get_Name_String (Element.Index); - Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit_Name); - - if Unit_Name = No_Name then - Err_Vars.Error_Msg_Name_1 := Element.Index; - Error_Msg - (Project, In_Tree, - "%% is not a valid unit name.", - Element.Value.Location); - - else - if Current_Verbosity = High then - Write_Str (" for unit: "); - Write_Line (Get_Name_String (Unit_Name)); - end if; - - Element.Index := Unit_Name; - In_Tree.Array_Elements.Table (Current) := Element; - end if; - - Current := Element.Next; - end loop; - end Check_And_Normalize_Unit_Names; - -------------------------- -- Check_Package_Naming -- -------------------------- procedure Check_Package_Naming (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Is_Config_File : Boolean; + Data : in out Tree_Processing_Data; Bodies : out Array_Element_Id; Specs : out Array_Element_Id) is Naming_Id : constant Package_Id := - Util.Value_Of (Name_Naming, Project.Decl.Packages, In_Tree); + Util.Value_Of + (Name_Naming, Project.Decl.Packages, Data.Tree); Naming : Package_Element; Ada_Body_Suffix_Loc : Source_Ptr := No_Location; - Ada_Spec_Suffix_Loc : Source_Ptr := No_Location; - procedure Check_Naming_Ada_Only; - -- Does Check_Naming_Schemes processing in Ada_Only mode. - -- If there is a package Naming, puts in Data.Naming the contents of - -- this package. - - procedure Check_Naming_Multi_Lang; - -- Does Check_Naming_Schemes processing for Multi_Language mode + procedure Check_Naming; + -- Check the validity of the Naming package (suffixes valid, ...) procedure Check_Common (Dot_Replacement : in out File_Name_Type; @@ -2727,7 +2583,7 @@ package body Prj.Nmsc is Casing_Defined : out Boolean; Separate_Suffix : in out File_Name_Type; Sep_Suffix_Loc : out Source_Ptr); - -- Check attributes common to Ada_Only and Multi_Lang modes + -- Check attributes common procedure Process_Exceptions_File_Based (Lang_Id : Language_Ptr; @@ -2735,8 +2591,7 @@ package body Prj.Nmsc is procedure Process_Exceptions_Unit_Based (Lang_Id : Language_Ptr; Kind : Source_Kind); - -- In Multi_Lang mode, process the naming exceptions for the two types - -- of languages we can have. + -- Process the naming exceptions for the two types of languages procedure Initialize_Naming_Data; -- Initialize internal naming data for the various languages @@ -2756,17 +2611,17 @@ package body Prj.Nmsc is Util.Value_Of (Name_Dot_Replacement, Naming.Decl.Attributes, - In_Tree); + Data.Tree); Casing_String : constant Variable_Value := Util.Value_Of (Name_Casing, Naming.Decl.Attributes, - In_Tree); + Data.Tree); Sep_Suffix : constant Variable_Value := Util.Value_Of (Name_Separate_Suffix, Naming.Decl.Attributes, - In_Tree); + Data.Tree); Dot_Repl_Loc : Source_Ptr; begin @@ -2778,9 +2633,8 @@ package body Prj.Nmsc is if Length_Of_Name (Dot_Repl.Value) = 0 then Error_Msg - (Project, In_Tree, - "Dot_Replacement cannot be empty", - Dot_Repl.Location); + (Data.Flags, "Dot_Replacement cannot be empty", + Dot_Repl.Location, Project); end if; Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value); @@ -2810,10 +2664,10 @@ package body Prj.Nmsc is Index (Source => Repl, Pattern => ".") /= 0) then Error_Msg - (Project, In_Tree, + (Data.Flags, '"' & Repl & """ is illegal for Dot_Replacement.", - Dot_Repl_Loc); + Dot_Repl_Loc, Project); end if; end; end if; @@ -2836,9 +2690,9 @@ package body Prj.Nmsc is begin if Casing_Image'Length = 0 then Error_Msg - (Project, In_Tree, + (Data.Flags, "Casing cannot be an empty string", - Casing_String.Location); + Casing_String.Location, Project); end if; Casing := Value (Casing_Image); @@ -2850,9 +2704,9 @@ package body Prj.Nmsc is Name_Buffer (1 .. Name_Len) := Casing_Image; Err_Vars.Error_Msg_Name_1 := Name_Find; Error_Msg - (Project, In_Tree, + (Data.Flags, "%% is not a correct Casing", - Casing_String.Location); + Casing_String.Location, Project); end; end if; @@ -2861,21 +2715,18 @@ package body Prj.Nmsc is if not Sep_Suffix.Default then if Length_Of_Name (Sep_Suffix.Value) = 0 then Error_Msg - (Project, In_Tree, + (Data.Flags, "Separate_Suffix cannot be empty", - Sep_Suffix.Location); + Sep_Suffix.Location, Project); else Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value); Sep_Suffix_Loc := Sep_Suffix.Location; - if Is_Illegal_Suffix (Separate_Suffix, Dot_Replacement) then - Err_Vars.Error_Msg_File_1 := Separate_Suffix; - Error_Msg - (Project, In_Tree, - "{ is illegal for Separate_Suffix", - Sep_Suffix.Location); - end if; + Check_Illegal_Suffix + (Project, Separate_Suffix, + Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location, + Data); end if; end if; @@ -2909,28 +2760,28 @@ package body Prj.Nmsc is Value_Of (Name_Implementation_Exceptions, In_Arrays => Naming.Decl.Arrays, - In_Tree => In_Tree); + In_Tree => Data.Tree); when Spec => Exceptions := Value_Of (Name_Specification_Exceptions, In_Arrays => Naming.Decl.Arrays, - In_Tree => In_Tree); + In_Tree => Data.Tree); end case; Exception_List := Value_Of (Index => Lang, In_Array => Exceptions, - In_Tree => In_Tree); + In_Tree => Data.Tree); if Exception_List /= Nil_Variable_Value then Element_Id := Exception_List.Values; while Element_Id /= Nil_String loop - Element := In_Tree.String_Elements.Table (Element_Id); + Element := Data.Tree.String_Elements.Table (Element_Id); File_Name := Canonical_Case_File_Name (Element.Value); - Iter := For_Each_Source (In_Tree, Project); + Iter := For_Each_Source (Data.Tree, Project); loop Source := Prj.Element (Iter); exit when Source = No_Source or else Source.File = File_Name; @@ -2940,7 +2791,7 @@ package body Prj.Nmsc is if Source = No_Source then Add_Source (Id => Source, - In_Tree => In_Tree, + Data => Data, Project => Project, Lang_Id => Lang_Id, Kind => Kind, @@ -2954,17 +2805,15 @@ package body Prj.Nmsc is if Source.Language /= Lang_Id then Error_Msg - (Project, - In_Tree, + (Data.Flags, "the same file cannot be a source of two languages", - Element.Location); + Element.Location, Project); elsif Source.Kind /= Kind then Error_Msg - (Project, - In_Tree, + (Data.Flags, "the same file cannot be a source and a template", - Element.Location); + Element.Location, Project); end if; -- If the file is already recorded for the same @@ -2986,31 +2835,29 @@ package body Prj.Nmsc is (Lang_Id : Language_Ptr; Kind : Source_Kind) is - Lang : constant Name_Id := Lang_Id.Name; - Exceptions : Array_Element_Id; - Element : Array_Element; - Unit : Name_Id; - Index : Int; - File_Name : File_Name_Type; - Source : Source_Id; - Source_To_Replace : Source_Id := No_Source; - Other_Project : Project_Id; - Iter : Source_Iterator; + Lang : constant Name_Id := Lang_Id.Name; + Exceptions : Array_Element_Id; + Element : Array_Element; + Unit : Name_Id; + Index : Int; + File_Name : File_Name_Type; + Source : Source_Id; begin case Kind is when Impl | Sep => - Exceptions := Value_Of - (Name_Body, - In_Arrays => Naming.Decl.Arrays, - In_Tree => In_Tree); + Exceptions := + Value_Of + (Name_Body, + In_Arrays => Naming.Decl.Arrays, + In_Tree => Data.Tree); if Exceptions = No_Array_Element then Exceptions := Value_Of (Name_Implementation, In_Arrays => Naming.Decl.Arrays, - In_Tree => In_Tree); + In_Tree => Data.Tree); end if; when Spec => @@ -3018,18 +2865,19 @@ package body Prj.Nmsc is Value_Of (Name_Spec, In_Arrays => Naming.Decl.Arrays, - In_Tree => In_Tree); + In_Tree => Data.Tree); if Exceptions = No_Array_Element then - Exceptions := Value_Of - (Name_Spec, - In_Arrays => Naming.Decl.Arrays, - In_Tree => In_Tree); + Exceptions := + Value_Of + (Name_Spec, + In_Arrays => Naming.Decl.Arrays, + In_Tree => Data.Tree); end if; end case; while Exceptions /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Exceptions); + Element := Data.Tree.Array_Elements.Table (Exceptions); File_Name := Canonical_Case_File_Name (Element.Value.Value); Get_Name_String (Element.Index); @@ -3046,189 +2894,39 @@ package body Prj.Nmsc is if Unit = No_Name then Err_Vars.Error_Msg_Name_1 := Element.Index; Error_Msg - (Project, In_Tree, + (Data.Flags, "%% is not a valid unit name.", - Element.Value.Location); + Element.Value.Location, Project); end if; end if; if Unit /= No_Name then - - -- Check if the source already exists - -- ??? In Ada_Only mode (Record_Unit), we use a htable for - -- efficiency - - Source_To_Replace := No_Source; - Iter := For_Each_Source (In_Tree); - - loop - Source := Prj.Element (Iter); - exit when Source = No_Source - or else (Source.Unit /= null - and then Source.Unit.Name = Unit - and then Source.Index = Index); - Next (Iter); - end loop; - - if Source /= No_Source then - if Source.Kind /= Kind then - loop - Next (Iter); - Source := Prj.Element (Iter); - - exit when Source = No_Source - or else (Source.Unit /= null - and then Source.Unit.Name = Unit - and then Source.Index = Index); - end loop; - end if; - - if Source /= No_Source then - Other_Project := Source.Project; - - if Is_Extending (Project, Other_Project) then - Source_To_Replace := Source; - Source := No_Source; - - else - Error_Msg_Name_1 := Unit; - Error_Msg_Name_2 := Other_Project.Name; - Error_Msg - (Project, - In_Tree, - "%% is already a source of project %%", - Element.Value.Location); - end if; - end if; - end if; - - if Source = No_Source then - Add_Source - (Id => Source, - In_Tree => In_Tree, - Project => Project, - Lang_Id => Lang_Id, - Kind => Kind, - File_Name => File_Name, - Display_File => File_Name_Type (Element.Value.Value), - Unit => Unit, - Index => Index, - Naming_Exception => True, - Source_To_Replace => Source_To_Replace); - end if; + Add_Source + (Id => Source, + Data => Data, + Project => Project, + Lang_Id => Lang_Id, + Kind => Kind, + File_Name => File_Name, + Display_File => File_Name_Type (Element.Value.Value), + Unit => Unit, + Index => Index, + Location => Element.Value.Location, + Naming_Exception => True); end if; Exceptions := Element.Next; end loop; end Process_Exceptions_Unit_Based; - --------------------------- - -- Check_Naming_Ada_Only -- - --------------------------- - - procedure Check_Naming_Ada_Only is - Ada : constant Language_Ptr := - Get_Language_From_Name (Project, "ada"); - - Casing_Defined : Boolean; - Sep_Suffix_Loc : Source_Ptr; - - begin - -- If no language, then nothing to do - - if Ada = null then - return; - end if; - - declare - Data : Lang_Naming_Data renames Ada.Config.Naming_Data; - - begin - -- The default value of separate suffix should be the same as the - -- body suffix, so we need to compute that first. - - Data.Separate_Suffix := Data.Body_Suffix; - Write_Attr ("Body_Suffix", Get_Name_String (Data.Body_Suffix)); - - -- We'll need the dot replacement below, so compute it now - - Check_Common - (Dot_Replacement => Data.Dot_Replacement, - Casing => Data.Casing, - Casing_Defined => Casing_Defined, - Separate_Suffix => Data.Separate_Suffix, - Sep_Suffix_Loc => Sep_Suffix_Loc); - - Bodies := Util.Value_Of (Name_Body, Naming.Decl.Arrays, In_Tree); - - if Bodies /= No_Array_Element then - Check_And_Normalize_Unit_Names - (Project, In_Tree, Bodies, "Naming.Bodies"); - end if; - - Specs := Util.Value_Of (Name_Spec, Naming.Decl.Arrays, In_Tree); - - if Specs /= No_Array_Element then - Check_And_Normalize_Unit_Names - (Project, In_Tree, Specs, "Naming.Specs"); - end if; - - -- Check Spec_Suffix - - if Is_Illegal_Suffix (Data.Spec_Suffix, Data.Dot_Replacement) then - Err_Vars.Error_Msg_File_1 := Data.Spec_Suffix; - Error_Msg - (Project, In_Tree, - "{ is illegal for Spec_Suffix", - Ada_Spec_Suffix_Loc); - end if; - - Write_Attr ("Spec_Suffix", Get_Name_String (Data.Spec_Suffix)); - - -- Check Body_Suffix - - if Is_Illegal_Suffix (Data.Body_Suffix, Data.Dot_Replacement) then - Err_Vars.Error_Msg_File_1 := Data.Body_Suffix; - Error_Msg - (Project, In_Tree, - "{ is illegal for Body_Suffix", - Ada_Body_Suffix_Loc); - end if; - - -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix, - -- since that would cause a clear ambiguity. Note that we do allow - -- a Spec_Suffix to have the same termination as one of these, - -- which causes a potential ambiguity, but we resolve that my - -- matching the longest possible suffix. - - if Data.Spec_Suffix = Data.Body_Suffix then - Error_Msg - (Project, In_Tree, - "Body_Suffix (""" - & Get_Name_String (Data.Body_Suffix) - & """) cannot be the same as Spec_Suffix.", - Ada_Body_Suffix_Loc); - end if; - - if Data.Body_Suffix /= Data.Separate_Suffix - and then Data.Spec_Suffix = Data.Separate_Suffix - then - Error_Msg - (Project, In_Tree, - "Separate_Suffix (""" - & Get_Name_String (Data.Separate_Suffix) - & """) cannot be the same as Spec_Suffix.", - Sep_Suffix_Loc); - end if; - end; - end Check_Naming_Ada_Only; - - ----------------------------- - -- Check_Naming_Multi_Lang -- - ----------------------------- + ------------------ + -- Check_Naming -- + ------------------ - procedure Check_Naming_Multi_Lang is - Dot_Replacement : File_Name_Type := No_File; + procedure Check_Naming is + Dot_Replacement : File_Name_Type := + File_Name_Type + (First_Name_Id + Character'Pos ('-')); Separate_Suffix : File_Name_Type := No_File; Casing : Casing_Type := All_Lower_Case; Casing_Defined : Boolean; @@ -3265,11 +2963,6 @@ package body Prj.Nmsc is if Casing_Defined then Lang_Id.Config.Naming_Data.Casing := Casing; end if; - - if Separate_Suffix /= No_File then - Lang_Id.Config.Naming_Data.Separate_Suffix := - Separate_Suffix; - end if; end if; Lang_Id := Lang_Id.Next; @@ -3288,47 +2981,113 @@ package body Prj.Nmsc is (Name => Lang, Attribute_Or_Array_Name => Name_Spec_Suffix, In_Package => Naming_Id, - In_Tree => In_Tree); + In_Tree => Data.Tree); if Suffix = Nil_Variable_Value then Suffix := Value_Of (Name => Lang, - Attribute_Or_Array_Name => Name_Spec_Suffix, + Attribute_Or_Array_Name => Name_Specification_Suffix, In_Package => Naming_Id, - In_Tree => In_Tree); + In_Tree => Data.Tree); end if; if Suffix /= Nil_Variable_Value then Lang_Id.Config.Naming_Data.Spec_Suffix := File_Name_Type (Suffix.Value); + + Check_Illegal_Suffix + (Project, + Lang_Id.Config.Naming_Data.Spec_Suffix, + Lang_Id.Config.Naming_Data.Dot_Replacement, + "Spec_Suffix", Suffix.Location, Data); + + Write_Attr + ("Spec_Suffix", + Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix)); end if; -- Body_Suffix - Suffix := Value_Of - (Name => Lang, - Attribute_Or_Array_Name => Name_Body_Suffix, - In_Package => Naming_Id, - In_Tree => In_Tree); + Suffix := + Value_Of + (Name => Lang, + Attribute_Or_Array_Name => Name_Body_Suffix, + In_Package => Naming_Id, + In_Tree => Data.Tree); if Suffix = Nil_Variable_Value then - Suffix := Value_Of - (Name => Lang, - Attribute_Or_Array_Name => Name_Implementation_Suffix, - In_Package => Naming_Id, - In_Tree => In_Tree); + Suffix := + Value_Of + (Name => Lang, + Attribute_Or_Array_Name => Name_Implementation_Suffix, + In_Package => Naming_Id, + In_Tree => Data.Tree); end if; if Suffix /= Nil_Variable_Value then Lang_Id.Config.Naming_Data.Body_Suffix := - File_Name_Type (Suffix.Value); + File_Name_Type (Suffix.Value); + + -- The default value of separate suffix should be the same as + -- the body suffix, so we need to compute that first. + + if Separate_Suffix = No_File then + Lang_Id.Config.Naming_Data.Separate_Suffix := + Lang_Id.Config.Naming_Data.Body_Suffix; + Write_Attr + ("Sep_Suffix", + Get_Name_String + (Lang_Id.Config.Naming_Data.Separate_Suffix)); + else + Lang_Id.Config.Naming_Data.Separate_Suffix := + Separate_Suffix; + end if; + + Check_Illegal_Suffix + (Project, + Lang_Id.Config.Naming_Data.Body_Suffix, + Lang_Id.Config.Naming_Data.Dot_Replacement, + "Body_Suffix", Suffix.Location, Data); + + Write_Attr + ("Body_Suffix", + Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)); + + elsif Separate_Suffix /= No_File then + Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix; end if; - -- ??? As opposed to what is done in Check_Naming_Ada_Only, - -- we do not check whether spec_suffix=body_suffix, which - -- should be illegal. Best would be to share this code into - -- Check_Common, but we access the attributes from the project - -- files slightly differently apparently. + -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix, + -- since that would cause a clear ambiguity. Note that we do allow + -- a Spec_Suffix to have the same termination as one of these, + -- which causes a potential ambiguity, but we resolve that my + -- matching the longest possible suffix. + + if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File + and then Lang_Id.Config.Naming_Data.Spec_Suffix = + Lang_Id.Config.Naming_Data.Body_Suffix + then + Error_Msg + (Data.Flags, + "Body_Suffix (""" + & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix) + & """) cannot be the same as Spec_Suffix.", + Ada_Body_Suffix_Loc, Project); + end if; + + if Lang_Id.Config.Naming_Data.Body_Suffix /= + Lang_Id.Config.Naming_Data.Separate_Suffix + and then Lang_Id.Config.Naming_Data.Spec_Suffix = + Lang_Id.Config.Naming_Data.Separate_Suffix + then + Error_Msg + (Data.Flags, + "Separate_Suffix (""" + & Get_Name_String + (Lang_Id.Config.Naming_Data.Separate_Suffix) + & """) cannot be the same as Spec_Suffix.", + Sep_Suffix_Loc, Project); + end if; Lang_Id := Lang_Id.Next; end loop; @@ -3339,17 +3098,17 @@ package body Prj.Nmsc is Lang_Id := Project.Languages; while Lang_Id /= No_Language_Index loop case Lang_Id.Config.Kind is - when File_Based => - Process_Exceptions_File_Based (Lang_Id, Kind); + when File_Based => + Process_Exceptions_File_Based (Lang_Id, Kind); - when Unit_Based => - Process_Exceptions_Unit_Based (Lang_Id, Kind); + when Unit_Based => + Process_Exceptions_Unit_Based (Lang_Id, Kind); end case; Lang_Id := Lang_Id.Next; end loop; end loop; - end Check_Naming_Multi_Lang; + end Check_Naming; ---------------------------- -- Initialize_Naming_Data -- @@ -3360,13 +3119,13 @@ package body Prj.Nmsc is Util.Value_Of (Name_Spec_Suffix, Naming.Decl.Arrays, - In_Tree); + Data.Tree); Impls : Array_Element_Id := Util.Value_Of (Name_Body_Suffix, Naming.Decl.Arrays, - In_Tree); + Data.Tree); Lang : Language_Ptr; Lang_Name : Name_Id; @@ -3379,16 +3138,16 @@ package body Prj.Nmsc is -- user project, and they override the default. while Specs /= No_Array_Element loop - Lang_Name := In_Tree.Array_Elements.Table (Specs).Index; - Lang := Get_Language_From_Name - (Project, Name => Get_Name_String (Lang_Name)); + Lang_Name := Data.Tree.Array_Elements.Table (Specs).Index; + Lang := + Get_Language_From_Name + (Project, Name => Get_Name_String (Lang_Name)); -- An extending project inherits its parent projects' languages -- so if needed we should create entries for those languages if Lang = null then Extended := Project.Extends; - while Extended /= null loop Lang := Get_Language_From_Name (Extended, Name => Get_Name_String (Lang_Name)); @@ -3414,12 +3173,9 @@ package body Prj.Nmsc is & Get_Name_String (Lang_Name) & " since language is not defined for this project"); end if; - else - Value := In_Tree.Array_Elements.Table (Specs).Value; - if Lang.Name = Name_Ada then - Ada_Spec_Suffix_Loc := Value.Location; - end if; + else + Value := Data.Tree.Array_Elements.Table (Specs).Value; if Value.Kind = Single then Lang.Config.Naming_Data.Spec_Suffix := @@ -3427,13 +3183,14 @@ package body Prj.Nmsc is end if; end if; - Specs := In_Tree.Array_Elements.Table (Specs).Next; + Specs := Data.Tree.Array_Elements.Table (Specs).Next; end loop; while Impls /= No_Array_Element loop - Lang_Name := In_Tree.Array_Elements.Table (Impls).Index; - Lang := Get_Language_From_Name - (Project, Name => Get_Name_String (Lang_Name)); + Lang_Name := Data.Tree.Array_Elements.Table (Impls).Index; + Lang := + Get_Language_From_Name + (Project, Name => Get_Name_String (Lang_Name)); if Lang = null then if Current_Verbosity = High then @@ -3443,7 +3200,7 @@ package body Prj.Nmsc is & " since language is not defined for this project"); end if; else - Value := In_Tree.Array_Elements.Table (Impls).Value; + Value := Data.Tree.Array_Elements.Table (Impls).Value; if Lang.Name = Name_Ada then Ada_Body_Suffix_Loc := Value.Location; @@ -3455,7 +3212,7 @@ package body Prj.Nmsc is end if; end if; - Impls := In_Tree.Array_Elements.Table (Impls).Next; + Impls := Data.Tree.Array_Elements.Table (Impls).Next; end loop; end Initialize_Naming_Data; @@ -3467,8 +3224,10 @@ package body Prj.Nmsc is -- No Naming package or parsing a configuration file? nothing to do - if Naming_Id /= No_Package and not Is_Config_File then - Naming := In_Tree.Packages.Table (Naming_Id); + if Naming_Id /= No_Package + and Project.Qualifier /= Configuration + then + Naming := Data.Tree.Packages.Table (Naming_Id); if Current_Verbosity = High then Write_Line ("Checking package Naming for project " @@ -3476,13 +3235,7 @@ package body Prj.Nmsc is end if; Initialize_Naming_Data; - - case Get_Mode is - when Ada_Only => - Check_Naming_Ada_Only; - when Multi_Language => - Check_Naming_Multi_Lang; - end case; + Check_Naming; end if; end Check_Package_Naming; @@ -3491,34 +3244,34 @@ package body Prj.Nmsc is ------------------------------ procedure Check_Library_Attributes - (Project : Project_Id; - In_Tree : Project_Tree_Ref) + (Project : Project_Id; + Data : in out Tree_Processing_Data) is Attributes : constant Prj.Variable_Id := Project.Decl.Attributes; Lib_Dir : constant Prj.Variable_Value := Prj.Util.Value_Of - (Snames.Name_Library_Dir, Attributes, In_Tree); + (Snames.Name_Library_Dir, Attributes, Data.Tree); Lib_Name : constant Prj.Variable_Value := Prj.Util.Value_Of - (Snames.Name_Library_Name, Attributes, In_Tree); + (Snames.Name_Library_Name, Attributes, Data.Tree); Lib_Version : constant Prj.Variable_Value := Prj.Util.Value_Of - (Snames.Name_Library_Version, Attributes, In_Tree); + (Snames.Name_Library_Version, Attributes, Data.Tree); Lib_ALI_Dir : constant Prj.Variable_Value := Prj.Util.Value_Of - (Snames.Name_Library_Ali_Dir, Attributes, In_Tree); + (Snames.Name_Library_Ali_Dir, Attributes, Data.Tree); Lib_GCC : constant Prj.Variable_Value := Prj.Util.Value_Of - (Snames.Name_Library_GCC, Attributes, In_Tree); + (Snames.Name_Library_GCC, Attributes, Data.Tree); The_Lib_Kind : constant Prj.Variable_Value := Prj.Util.Value_Of - (Snames.Name_Library_Kind, Attributes, In_Tree); + (Snames.Name_Library_Kind, Attributes, Data.Tree); Imported_Project_List : Project_List; @@ -3536,8 +3289,8 @@ package body Prj.Nmsc is ------------------- procedure Check_Library (Proj : Project_Id; Extends : Boolean) is - Src_Id : Source_Id; - Iter : Source_Iterator; + Src_Id : Source_Id; + Iter : Source_Iterator; begin if Proj /= No_Project then @@ -3547,7 +3300,7 @@ package body Prj.Nmsc is -- have no sources. However, header files from non-Ada -- languages are OK, as there is nothing to compile. - Iter := For_Each_Source (In_Tree, Proj); + Iter := For_Each_Source (Data.Tree, Proj); loop Src_Id := Prj.Element (Iter); exit when Src_Id = No_Source @@ -3563,11 +3316,11 @@ package body Prj.Nmsc is if Extends then if Project.Library_Kind /= Static then Error_Msg - (Project, In_Tree, + (Data.Flags, Continuation.all & "shared library project %% cannot extend " & "project %% that is not a library project", - Project.Location); + Project.Location, Project); Continuation := Continuation_String'Access; end if; @@ -3575,11 +3328,11 @@ package body Prj.Nmsc is and then Project.Library_Kind /= Static then Error_Msg - (Project, In_Tree, + (Data.Flags, Continuation.all & "shared library project %% cannot import project %% " & "that is not a shared library project", - Project.Location); + Project.Location, Project); Continuation := Continuation_String'Access; end if; end if; @@ -3592,20 +3345,20 @@ package body Prj.Nmsc is if Extends then Error_Msg - (Project, In_Tree, + (Data.Flags, Continuation.all & "shared library project %% cannot extend static " & "library project %%", - Project.Location); + Project.Location, Project); Continuation := Continuation_String'Access; elsif not Unchecked_Shared_Lib_Imports then Error_Msg - (Project, In_Tree, + (Data.Flags, Continuation.all & "shared library project %% cannot import static " & "library project %%", - Project.Location); + Project.Location, Project); Continuation := Continuation_String'Access; end if; @@ -3631,9 +3384,9 @@ package body Prj.Nmsc is if Project.Extends.Library then if Project.Qualifier = Standard then Error_Msg - (Project, In_Tree, + (Data.Flags, "a standard project cannot extend a library project", - Project.Location); + Project.Location, Project); else if Lib_Name.Default then @@ -3643,10 +3396,10 @@ package body Prj.Nmsc is if Lib_Dir.Default then if not Project.Virtual then Error_Msg - (Project, In_Tree, + (Data.Flags, "a project extending a library project must " & "specify an attribute Library_Dir", - Project.Location); + Project.Location, Project); else -- For a virtual project extending a library project, @@ -3694,10 +3447,10 @@ package body Prj.Nmsc is if Project.Library_Dir = No_Path_Information then Locate_Directory (Project, - In_Tree, File_Name_Type (Lib_Dir.Value), Path => Project.Library_Dir, Dir_Exists => Dir_Exists, + Data => Data, Create => "library", Must_Exist => False, Location => Lib_Dir.Location, @@ -3718,19 +3471,19 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Project.Library_Dir.Display_Name); Error_Msg - (Project, In_Tree, + (Data.Flags, "library directory { does not exist", - Lib_Dir.Location); + Lib_Dir.Location, Project); -- The library directory cannot be the same as the Object -- directory. elsif Project.Library_Dir.Name = Project.Object_Directory.Name then Error_Msg - (Project, In_Tree, + (Data.Flags, "library directory cannot be the same " & "as object directory", - Lib_Dir.Location); + Lib_Dir.Location, Project); Project.Library_Dir := No_Path_Information; else @@ -3746,7 +3499,7 @@ package body Prj.Nmsc is Dirs_Id := Project.Source_Dirs; while Dirs_Id /= Nil_String loop - Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); + Dir_Elem := Data.Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; if Project.Library_Dir.Name = @@ -3755,10 +3508,10 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg - (Project, In_Tree, + (Data.Flags, "library directory cannot be the same " & "as source directory {", - Lib_Dir.Location); + Lib_Dir.Location, Project); OK := False; exit; end if; @@ -3769,7 +3522,7 @@ package body Prj.Nmsc is -- The library directory cannot be the same as a source -- directory of another project either. - Pid := In_Tree.Projects; + Pid := Data.Tree.Projects; Project_Loop : loop exit Project_Loop when Pid = null; @@ -3778,7 +3531,7 @@ package body Prj.Nmsc is Dir_Loop : while Dirs_Id /= Nil_String loop Dir_Elem := - In_Tree.String_Elements.Table (Dirs_Id); + Data.Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; if Project.Library_Dir.Name = @@ -3789,10 +3542,10 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_Name_1 := Pid.Project.Name; Error_Msg - (Project, In_Tree, + (Data.Flags, "library directory cannot be the same " & "as source directory { of project %%", - Lib_Dir.Location); + Lib_Dir.Location, Project); OK := False; exit Project_Loop; end if; @@ -3829,25 +3582,25 @@ package body Prj.Nmsc is when Standard => if Project.Library then Error_Msg - (Project, In_Tree, + (Data.Flags, "a standard project cannot be a library project", - Lib_Name.Location); + Lib_Name.Location, Project); end if; when Library => if not Project.Library then if Project.Library_Dir = No_Path_Information then Error_Msg - (Project, In_Tree, + (Data.Flags, "\attribute Library_Dir not declared", - Project.Location); + Project.Location, Project); end if; if Project.Library_Name = No_Name then Error_Msg - (Project, In_Tree, + (Data.Flags, "\attribute Library_Name not declared", - Project.Location); + Project.Location, Project); end if; end if; @@ -3858,18 +3611,13 @@ package body Prj.Nmsc is end if; if Project.Library then - if Get_Mode = Multi_Language then - Support_For_Libraries := Project.Config.Lib_Support; - - else - Support_For_Libraries := MLib.Tgt.Support_For_Libraries; - end if; + Support_For_Libraries := Project.Config.Lib_Support; if Support_For_Libraries = Prj.None then Error_Msg - (Project, In_Tree, + (Data.Flags, "?libraries are not supported on this platform", - Lib_Name.Location); + Lib_Name.Location, Project); Project.Library := False; else @@ -3885,11 +3633,11 @@ package body Prj.Nmsc is Locate_Directory (Project, - In_Tree, File_Name_Type (Lib_ALI_Dir.Value), Path => Project.Library_ALI_Dir, Create => "library ALI", Dir_Exists => Dir_Exists, + Data => Data, Must_Exist => False, Location => Lib_ALI_Dir.Location, Externally_Built => Project.Externally_Built); @@ -3902,9 +3650,9 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Project.Library_ALI_Dir.Display_Name); Error_Msg - (Project, In_Tree, + (Data.Flags, "library 'A'L'I directory { does not exist", - Lib_ALI_Dir.Location); + Lib_ALI_Dir.Location, Project); end if; if Project.Library_ALI_Dir /= Project.Library_Dir then @@ -3914,10 +3662,10 @@ package body Prj.Nmsc is if Project.Library_ALI_Dir = Project.Object_Directory then Error_Msg - (Project, In_Tree, + (Data.Flags, "library 'A'L'I directory cannot be the same " & "as object directory", - Lib_ALI_Dir.Location); + Lib_ALI_Dir.Location, Project); Project.Library_ALI_Dir := No_Path_Information; else @@ -3933,7 +3681,8 @@ package body Prj.Nmsc is Dirs_Id := Project.Source_Dirs; while Dirs_Id /= Nil_String loop - Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); + Dir_Elem := + Data.Tree.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; if Project.Library_ALI_Dir.Name = @@ -3942,10 +3691,10 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg - (Project, In_Tree, + (Data.Flags, "library 'A'L'I directory cannot be " & "the same as source directory {", - Lib_ALI_Dir.Location); + Lib_ALI_Dir.Location, Project); OK := False; exit; end if; @@ -3956,7 +3705,7 @@ package body Prj.Nmsc is -- The library ALI directory cannot be the same as -- a source directory of another project either. - Pid := In_Tree.Projects; + Pid := Data.Tree.Projects; ALI_Project_Loop : loop exit ALI_Project_Loop when Pid = null; @@ -3966,7 +3715,8 @@ package body Prj.Nmsc is ALI_Dir_Loop : while Dirs_Id /= Nil_String loop Dir_Elem := - In_Tree.String_Elements.Table (Dirs_Id); + Data.Tree.String_Elements.Table + (Dirs_Id); Dirs_Id := Dir_Elem.Next; if Project.Library_ALI_Dir.Name = @@ -3978,11 +3728,11 @@ package body Prj.Nmsc is Pid.Project.Name; Error_Msg - (Project, In_Tree, + (Data.Flags, "library 'A'L'I directory cannot " & "be the same as source directory " & "{ of project %%", - Lib_ALI_Dir.Location); + Lib_ALI_Dir.Location, Project); OK := False; exit ALI_Project_Loop; end if; @@ -4048,9 +3798,9 @@ package body Prj.Nmsc is else Error_Msg - (Project, In_Tree, + (Data.Flags, "illegal value for Library_Kind", - The_Lib_Kind.Location); + The_Lib_Kind.Location, Project); OK := False; end if; @@ -4061,10 +3811,10 @@ package body Prj.Nmsc is if Project.Library_Kind /= Static then if Support_For_Libraries = Prj.Static_Only then Error_Msg - (Project, In_Tree, + (Data.Flags, "only static libraries are supported " & "on this platform", - The_Lib_Kind.Location); + The_Lib_Kind.Location, Project); Project.Library := False; else @@ -4073,11 +3823,10 @@ package body Prj.Nmsc is if Lib_GCC.Value /= Empty_String then Error_Msg - (Project, - In_Tree, + (Data.Flags, "?Library_'G'C'C is an obsolescent attribute, " & "use Linker''Driver instead", - Lib_GCC.Location); + Lib_GCC.Location, Project); Project.Config.Shared_Lib_Driver := File_Name_Type (Lib_GCC.Value); @@ -4087,15 +3836,14 @@ package body Prj.Nmsc is Value_Of (Name_Linker, Project.Decl.Packages, - In_Tree); + Data.Tree); Driver : constant Variable_Value := Value_Of - (Name => No_Name, + (Name => No_Name, Attribute_Or_Array_Name => Name_Driver, - In_Package => Linker, - In_Tree => - In_Tree); + In_Package => Linker, + In_Tree => Data.Tree); begin if Driver /= Nil_Variable_Value @@ -4116,17 +3864,15 @@ package body Prj.Nmsc is Write_Line ("This is a library project file"); end if; - if Get_Mode = Multi_Language then - Check_Library (Project.Extends, Extends => True); + Check_Library (Project.Extends, Extends => True); - Imported_Project_List := Project.Imported_Projects; - while Imported_Project_List /= null loop - Check_Library - (Imported_Project_List.Project, - Extends => False); - Imported_Project_List := Imported_Project_List.Next; - end loop; - end if; + Imported_Project_List := Project.Imported_Projects; + while Imported_Project_List /= null loop + Check_Library + (Imported_Project_List.Project, + Extends => False); + Imported_Project_List := Imported_Project_List.Next; + end loop; end if; end if; @@ -4141,34 +3887,34 @@ package body Prj.Nmsc is Linker_Package_Id : constant Package_Id := Util.Value_Of (Name_Linker, - Project.Decl.Packages, In_Tree); + Project.Decl.Packages, Data.Tree); Linker_Package : Package_Element; Switches : Array_Element_Id := No_Array_Element; begin if Linker_Package_Id /= No_Package then - Linker_Package := In_Tree.Packages.Table (Linker_Package_Id); + Linker_Package := Data.Tree.Packages.Table (Linker_Package_Id); Switches := Value_Of (Name => Name_Switches, In_Arrays => Linker_Package.Decl.Arrays, - In_Tree => In_Tree); + In_Tree => Data.Tree); if Switches = No_Array_Element then Switches := Value_Of (Name => Name_Default_Switches, In_Arrays => Linker_Package.Decl.Arrays, - In_Tree => In_Tree); + In_Tree => Data.Tree); end if; if Switches /= No_Array_Element then Error_Msg - (Project, In_Tree, + (Data.Flags, "?Linker switches not taken into account in library " & "projects", - No_Location); + No_Location, Project); end if; end if; end; @@ -4184,8 +3930,8 @@ package body Prj.Nmsc is --------------------------------- procedure Check_Programming_Languages - (In_Tree : Project_Tree_Ref; - Project : Project_Id) + (Project : Project_Id; + Data : in out Tree_Processing_Data) is Languages : Variable_Value := Nil_Variable_Value; Def_Lang : Variable_Value := Nil_Variable_Value; @@ -4215,29 +3961,12 @@ package body Prj.Nmsc is Lang := new Language_Data'(No_Language_Data); Lang.Next := Project.Languages; Project.Languages := Lang; - Lang.Name := Name; + Lang.Name := Name; Lang.Display_Name := Display_Name; if Name = Name_Ada then - Lang.Config.Kind := Unit_Based; + Lang.Config.Kind := Unit_Based; Lang.Config.Dependency_Kind := ALI_File; - - if Get_Mode = Ada_Only then - - -- Create a default config for Ada (since there is no - -- configuration file to create it for us). - - -- ??? We should do as GPS does and create a dummy config file - - Lang.Config.Naming_Data := - (Dot_Replacement => File_Name_Type - (First_Name_Id + Character'Pos ('-')), - Casing => All_Lower_Case, - Separate_Suffix => Default_Ada_Body_Suffix, - Spec_Suffix => Default_Ada_Spec_Suffix, - Body_Suffix => Default_Ada_Body_Suffix); - end if; - else Lang.Config.Kind := File_Based; end if; @@ -4248,13 +3977,10 @@ package body Prj.Nmsc is begin Project.Languages := null; Languages := - Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, In_Tree); + Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Data.Tree); Def_Lang := Prj.Util.Value_Of - (Name_Default_Language, Project.Decl.Attributes, In_Tree); - - -- Shouldn't these be set to False by default, and only set to True when - -- we actually find some source file??? + (Name_Default_Language, Project.Decl.Attributes, Data.Tree); if Project.Source_Dirs /= Nil_String then @@ -4262,32 +3988,19 @@ package body Prj.Nmsc is if Languages.Default then - -- In Ada_Only mode, the default language is Ada + -- Fail if there is no default language defined - if Get_Mode = Ada_Only then - Def_Lang_Id := Name_Ada; + if Def_Lang.Default then + Error_Msg + (Data.Flags, + "no languages defined for this project", + Project.Location, Project); + Def_Lang_Id := No_Name; else - -- Fail if there is no default language defined - - if Def_Lang.Default then - if not Default_Language_Is_Ada then - Error_Msg - (Project, - In_Tree, - "no languages defined for this project", - Project.Location); - Def_Lang_Id := No_Name; - - else - Def_Lang_Id := Name_Ada; - end if; - - else - Get_Name_String (Def_Lang.Value); - To_Lower (Name_Buffer (1 .. Name_Len)); - Def_Lang_Id := Name_Find; - end if; + Get_Name_String (Def_Lang.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Def_Lang_Id := Name_Find; end if; if Def_Lang_Id /= No_Name then @@ -4311,10 +4024,9 @@ package body Prj.Nmsc is if Project.Qualifier = Standard then Error_Msg - (Project, - In_Tree, + (Data.Flags, "a standard project must have at least one language", - Languages.Location); + Languages.Location, Project); end if; else @@ -4322,7 +4034,7 @@ package body Prj.Nmsc is -- Languages. while Current /= Nil_String loop - Element := In_Tree.String_Elements.Table (Current); + Element := Data.Tree.String_Elements.Table (Current); Get_Name_String (Element.Value); To_Lower (Name_Buffer (1 .. Name_Len)); @@ -4338,80 +4050,49 @@ package body Prj.Nmsc is end if; end Check_Programming_Languages; - ------------------- - -- Check_Project -- - ------------------- - - function Check_Project - (P : Project_Id; - Root_Project : Project_Id; - Extending : Boolean) return Boolean - is - Prj : Project_Id; - - begin - if P = Root_Project then - return True; - - elsif Extending then - Prj := Root_Project; - while Prj.Extends /= No_Project loop - if P = Prj.Extends then - return True; - end if; - - Prj := Prj.Extends; - end loop; - end if; - - return False; - end Check_Project; - ------------------------------- -- Check_Stand_Alone_Library -- ------------------------------- procedure Check_Stand_Alone_Library (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Current_Dir : String; - Extending : Boolean) + Data : in out Tree_Processing_Data) is Lib_Interfaces : constant Prj.Variable_Value := Prj.Util.Value_Of (Snames.Name_Library_Interface, Project.Decl.Attributes, - In_Tree); + Data.Tree); Lib_Auto_Init : constant Prj.Variable_Value := Prj.Util.Value_Of (Snames.Name_Library_Auto_Init, Project.Decl.Attributes, - In_Tree); + Data.Tree); Lib_Src_Dir : constant Prj.Variable_Value := Prj.Util.Value_Of (Snames.Name_Library_Src_Dir, Project.Decl.Attributes, - In_Tree); + Data.Tree); Lib_Symbol_File : constant Prj.Variable_Value := Prj.Util.Value_Of (Snames.Name_Library_Symbol_File, Project.Decl.Attributes, - In_Tree); + Data.Tree); Lib_Symbol_Policy : constant Prj.Variable_Value := Prj.Util.Value_Of (Snames.Name_Library_Symbol_Policy, Project.Decl.Attributes, - In_Tree); + Data.Tree); Lib_Ref_Symbol_File : constant Prj.Variable_Value := Prj.Util.Value_Of (Snames.Name_Library_Reference_Symbol_File, Project.Decl.Attributes, - In_Tree); + Data.Tree); Auto_Init_Supported : Boolean; OK : Boolean := True; @@ -4420,12 +4101,7 @@ package body Prj.Nmsc is Iter : Source_Iterator; begin - if Get_Mode = Multi_Language then - Auto_Init_Supported := Project.Config.Auto_Init_Supported; - else - Auto_Init_Supported := - MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported; - end if; + Auto_Init_Supported := Project.Config.Auto_Init_Supported; pragma Assert (Lib_Interfaces.Kind = List); @@ -4433,52 +4109,10 @@ package body Prj.Nmsc is -- Library_Interface is defined. if not Lib_Interfaces.Default then - SAL_Library : declare + declare Interfaces : String_List_Id := Lib_Interfaces.Values; Interface_ALIs : String_List_Id := Nil_String; Unit : Name_Id; - UData : Unit_Index; - - procedure Add_ALI_For (Source : File_Name_Type); - -- Add an ALI file name to the list of Interface ALIs - - ----------------- - -- Add_ALI_For -- - ----------------- - - procedure Add_ALI_For (Source : File_Name_Type) is - begin - Get_Name_String (Source); - - declare - ALI : constant String := - ALI_File_Name (Name_Buffer (1 .. Name_Len)); - ALI_Name_Id : Name_Id; - - begin - Name_Len := ALI'Length; - Name_Buffer (1 .. Name_Len) := ALI; - ALI_Name_Id := Name_Find; - - String_Element_Table.Increment_Last - (In_Tree.String_Elements); - In_Tree.String_Elements.Table - (String_Element_Table.Last - (In_Tree.String_Elements)) := - (Value => ALI_Name_Id, - Index => 0, - Display_Value => ALI_Name_Id, - Location => - In_Tree.String_Elements.Table - (Interfaces).Location, - Flag => False, - Next => Interface_ALIs); - Interface_ALIs := String_Element_Table.Last - (In_Tree.String_Elements); - end; - end Add_ALI_For; - - -- Start of processing for SAL_Library begin Project.Standalone_Library := True; @@ -4487,9 +4121,9 @@ package body Prj.Nmsc is if Interfaces = Nil_String then Error_Msg - (Project, In_Tree, + (Data.Flags, "Library_Interface cannot be an empty list", - Lib_Interfaces.Location); + Lib_Interfaces.Location, Project); end if; -- Process each unit name specified in the attribute @@ -4497,184 +4131,94 @@ package body Prj.Nmsc is while Interfaces /= Nil_String loop Get_Name_String - (In_Tree.String_Elements.Table (Interfaces).Value); + (Data.Tree.String_Elements.Table (Interfaces).Value); To_Lower (Name_Buffer (1 .. Name_Len)); if Name_Len = 0 then Error_Msg - (Project, In_Tree, + (Data.Flags, "an interface cannot be an empty string", - In_Tree.String_Elements.Table (Interfaces).Location); + Data.Tree.String_Elements.Table (Interfaces).Location, + Project); else Unit := Name_Find; Error_Msg_Name_1 := Unit; - if Get_Mode = Ada_Only then - UData := Units_Htable.Get (In_Tree.Units_HT, Unit); - - if UData = No_Unit_Index then - Error_Msg - (Project, In_Tree, - "unknown unit %%", - In_Tree.String_Elements.Table - (Interfaces).Location); - - else - -- Check that the unit is part of the project - - if UData.File_Names (Impl) /= null - and then not UData.File_Names (Impl).Locally_Removed - then - if Check_Project - (UData.File_Names (Impl).Project, - Project, Extending) - then - -- There is a body for this unit. If there is - -- no spec, we need to check that it is not a - -- subunit. - - if UData.File_Names (Spec) = null then - declare - Src_Ind : Source_File_Index; - - begin - Src_Ind := - Sinput.P.Load_Project_File - (Get_Name_String (UData.File_Names - (Impl).Path.Name)); - - if Sinput.P.Source_File_Is_Subunit - (Src_Ind) - then - Error_Msg - (Project, In_Tree, - "%% is a subunit; " & - "it cannot be an interface", - In_Tree. - String_Elements.Table - (Interfaces).Location); - end if; - end; - end if; - - -- The unit is not a subunit, so we add the - -- ALI file for its body to the Interface ALIs. - - Add_ALI_For - (UData.File_Names (Impl).File); - - else - Error_Msg - (Project, In_Tree, - "%% is not an unit of this project", - In_Tree.String_Elements.Table - (Interfaces).Location); - end if; - - elsif UData.File_Names (Spec) /= null - and then not UData.File_Names (Spec).Locally_Removed - and then Check_Project - (UData.File_Names (Spec).Project, - Project, Extending) - - then - -- The unit is part of the project, it has a spec, - -- but no body. We add the ALI for its spec to the - -- Interface ALIs. - - Add_ALI_For - (UData.File_Names (Spec).File); - - else - Error_Msg - (Project, In_Tree, - "%% is not an unit of this project", - In_Tree.String_Elements.Table - (Interfaces).Location); - end if; - end if; - - else - -- Multi_Language mode - - Next_Proj := Project.Extends; - Iter := For_Each_Source (In_Tree, Project); + Next_Proj := Project.Extends; + Iter := For_Each_Source (Data.Tree, Project); + loop + while Prj.Element (Iter) /= No_Source + and then + (Prj.Element (Iter).Unit = null + or else Prj.Element (Iter).Unit.Name /= Unit) loop - while Prj.Element (Iter) /= No_Source - and then - (Prj.Element (Iter).Unit = null - or else Prj.Element (Iter).Unit.Name /= Unit) - loop - Next (Iter); - end loop; + Next (Iter); + end loop; - Source := Prj.Element (Iter); - exit when Source /= No_Source - or else Next_Proj = No_Project; + Source := Prj.Element (Iter); + exit when Source /= No_Source + or else Next_Proj = No_Project; - Iter := For_Each_Source (In_Tree, Next_Proj); - Next_Proj := Next_Proj.Extends; - end loop; + Iter := For_Each_Source (Data.Tree, Next_Proj); + Next_Proj := Next_Proj.Extends; + end loop; - if Source /= No_Source then - if Source.Kind = Sep then - Source := No_Source; + if Source /= No_Source then + if Source.Kind = Sep then + Source := No_Source; - elsif Source.Kind = Spec - and then Other_Part (Source) /= No_Source - then - Source := Other_Part (Source); - end if; + elsif Source.Kind = Spec + and then Other_Part (Source) /= No_Source + then + Source := Other_Part (Source); end if; + end if; - if Source /= No_Source then - if Source.Project /= Project - and then not Is_Extending (Project, Source.Project) - then - Source := No_Source; - end if; + if Source /= No_Source then + if Source.Project /= Project + and then not Is_Extending (Project, Source.Project) + then + Source := No_Source; end if; + end if; - if Source = No_Source then - Error_Msg - (Project, In_Tree, - "%% is not an unit of this project", - In_Tree.String_Elements.Table - (Interfaces).Location); - - else - if Source.Kind = Spec - and then Other_Part (Source) /= No_Source - then - Source := Other_Part (Source); - end if; - - String_Element_Table.Increment_Last - (In_Tree.String_Elements); - - In_Tree.String_Elements.Table - (String_Element_Table.Last - (In_Tree.String_Elements)) := - (Value => Name_Id (Source.Dep_Name), - Index => 0, - Display_Value => Name_Id (Source.Dep_Name), - Location => - In_Tree.String_Elements.Table - (Interfaces).Location, - Flag => False, - Next => Interface_ALIs); + if Source = No_Source then + Error_Msg + (Data.Flags, + "%% is not a unit of this project", + Data.Tree.String_Elements.Table + (Interfaces).Location, Project); - Interface_ALIs := - String_Element_Table.Last (In_Tree.String_Elements); + else + if Source.Kind = Spec + and then Other_Part (Source) /= No_Source + then + Source := Other_Part (Source); end if; + String_Element_Table.Increment_Last + (Data.Tree.String_Elements); + + Data.Tree.String_Elements.Table + (String_Element_Table.Last + (Data.Tree.String_Elements)) := + (Value => Name_Id (Source.Dep_Name), + Index => 0, + Display_Value => Name_Id (Source.Dep_Name), + Location => + Data.Tree.String_Elements.Table + (Interfaces).Location, + Flag => False, + Next => Interface_ALIs); + + Interface_ALIs := + String_Element_Table.Last + (Data.Tree.String_Elements); end if; - end if; - Interfaces := - In_Tree.String_Elements.Table (Interfaces).Next; + Interfaces := Data.Tree.String_Elements.Table (Interfaces).Next; end loop; -- Put the list of Interface ALIs in the project data @@ -4707,20 +4251,20 @@ package body Prj.Nmsc is -- supported. Error_Msg - (Project, In_Tree, + (Data.Flags, "library auto init not supported " & "on this platform", - Lib_Auto_Init.Location); + Lib_Auto_Init.Location, Project); end if; else Error_Msg - (Project, In_Tree, + (Data.Flags, "invalid value for attribute Library_Auto_Init", - Lib_Auto_Init.Location); + Lib_Auto_Init.Location, Project); end if; end if; - end SAL_Library; + end; -- If attribute Library_Src_Dir is defined and not the empty string, -- check if the directory exist and is not the object directory or @@ -4737,10 +4281,10 @@ package body Prj.Nmsc is begin Locate_Directory (Project, - In_Tree, Dir_Id, Path => Project.Library_Src_Dir, Dir_Exists => Dir_Exists, + Data => Data, Must_Exist => False, Create => "library source copy", Location => Lib_Src_Dir.Location, @@ -4756,18 +4300,18 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Project.Library_Src_Dir.Display_Name); Error_Msg - (Project, In_Tree, + (Data.Flags, "Directory { does not exist", - Lib_Src_Dir.Location); + Lib_Src_Dir.Location, Project); -- Report error if it is the same as the object directory elsif Project.Library_Src_Dir = Project.Object_Directory then Error_Msg - (Project, In_Tree, + (Data.Flags, "directory to copy interfaces cannot be " & "the object directory", - Lib_Src_Dir.Location); + Lib_Src_Dir.Location, Project); Project.Library_Src_Dir := No_Path_Information; else @@ -4782,18 +4326,18 @@ package body Prj.Nmsc is Src_Dirs := Project.Source_Dirs; while Src_Dirs /= Nil_String loop - Src_Dir := In_Tree.String_Elements.Table (Src_Dirs); + Src_Dir := Data.Tree.String_Elements.Table (Src_Dirs); -- Report error if it is one of the source directories if Project.Library_Src_Dir.Name = - Path_Name_Type (Src_Dir.Value) + Path_Name_Type (Src_Dir.Value) then Error_Msg - (Project, In_Tree, + (Data.Flags, "directory to copy interfaces cannot " & "be one of the source directories", - Lib_Src_Dir.Location); + Lib_Src_Dir.Location, Project); Project.Library_Src_Dir := No_Path_Information; exit; end if; @@ -4806,17 +4350,17 @@ package body Prj.Nmsc is -- It cannot be a source directory of any other -- project either. - Pid := In_Tree.Projects; + Pid := Data.Tree.Projects; Project_Loop : loop exit Project_Loop when Pid = null; Src_Dirs := Pid.Project.Source_Dirs; Dir_Loop : while Src_Dirs /= Nil_String loop Src_Dir := - In_Tree.String_Elements.Table (Src_Dirs); + Data.Tree.String_Elements.Table (Src_Dirs); -- Report error if it is one of the source - -- directories + -- directories. if Project.Library_Src_Dir.Name = Path_Name_Type (Src_Dir.Value) @@ -4825,11 +4369,11 @@ package body Prj.Nmsc is File_Name_Type (Src_Dir.Value); Error_Msg_Name_1 := Pid.Project.Name; Error_Msg - (Project, In_Tree, + (Data.Flags, "directory to copy interfaces cannot " & "be the same as source directory { of " & "project %%", - Lib_Src_Dir.Location); + Lib_Src_Dir.Location, Project); Project.Library_Src_Dir := No_Path_Information; exit Project_Loop; @@ -4864,8 +4408,8 @@ package body Prj.Nmsc is if not Lib_Symbol_Policy.Default then declare Value : constant String := - To_Lower - (Get_Name_String (Lib_Symbol_Policy.Value)); + To_Lower + (Get_Name_String (Lib_Symbol_Policy.Value)); begin -- Symbol policy must hove one of a limited number of values @@ -4887,9 +4431,9 @@ package body Prj.Nmsc is else Error_Msg - (Project, In_Tree, + (Data.Flags, "illegal value for Library_Symbol_Policy", - Lib_Symbol_Policy.Location); + Lib_Symbol_Policy.Location, Project); end if; end; end if; @@ -4900,10 +4444,10 @@ package body Prj.Nmsc is if Lib_Symbol_File.Default then if Project.Symbol_Data.Symbol_Policy = Restricted then Error_Msg - (Project, In_Tree, + (Data.Flags, "Library_Symbol_File needs to be defined when " & "symbol policy is Restricted", - Lib_Symbol_Policy.Location); + Lib_Symbol_Policy.Location, Project); end if; else @@ -4916,9 +4460,9 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, In_Tree, + (Data.Flags, "symbol file name cannot be an empty string", - Lib_Symbol_File.Location); + Lib_Symbol_File.Location, Project); else OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)); @@ -4937,10 +4481,10 @@ package body Prj.Nmsc is if not OK then Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value); Error_Msg - (Project, In_Tree, + (Data.Flags, "symbol file name { is illegal. " & "Name cannot include directory info.", - Lib_Symbol_File.Location); + Lib_Symbol_File.Location, Project); end if; end if; end if; @@ -4953,9 +4497,9 @@ package body Prj.Nmsc is or else Project.Symbol_Data.Symbol_Policy = Controlled then Error_Msg - (Project, In_Tree, + (Data.Flags, "a reference symbol file needs to be defined", - Lib_Symbol_Policy.Location); + Lib_Symbol_Policy.Location, Project); end if; else @@ -4968,23 +4512,22 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, In_Tree, + (Data.Flags, "reference symbol file name cannot be an empty string", - Lib_Symbol_File.Location); + Lib_Symbol_File.Location, Project); else if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then Name_Len := 0; Add_Str_To_Name_Buffer (Get_Name_String (Project.Directory.Name)); - Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (Get_Name_String (Lib_Ref_Symbol_File.Value)); Project.Symbol_Data.Reference := Name_Find; end if; if not Is_Regular_File - (Get_Name_String (Project.Symbol_Data.Reference)) + (Get_Name_String (Project.Symbol_Data.Reference)) then Error_Msg_File_1 := File_Name_Type (Lib_Ref_Symbol_File.Value); @@ -4998,9 +4541,9 @@ package body Prj.Nmsc is and then Project.Symbol_Data.Symbol_Policy /= Direct; Error_Msg - (Project, In_Tree, + (Data.Flags, "<library reference symbol file { does not exist", - Lib_Ref_Symbol_File.Location); + Lib_Ref_Symbol_File.Location, Project); -- In addition in the non-controlled case, if symbol policy -- is Compliant, it is changed to Autonomous, because there @@ -5022,29 +4565,32 @@ package body Prj.Nmsc is if Name_Len > 0 then declare + -- We do not need to pass a Directory to + -- Normalize_Pathname, since the path_information + -- already contains absolute information. + Symb_Path : constant String := Normalize_Pathname (Get_Name_String (Project.Object_Directory.Name) & - Directory_Separator & Name_Buffer (1 .. Name_Len), - Directory => Current_Dir, + Directory => "/", Resolve_Links => Opt.Follow_Links_For_Files); Ref_Path : constant String := Normalize_Pathname (Get_Name_String (Project.Symbol_Data.Reference), - Directory => Current_Dir, + Directory => "/", Resolve_Links => Opt.Follow_Links_For_Files); begin if Symb_Path = Ref_Path then Error_Msg - (Project, In_Tree, + (Data.Flags, "library reference symbol file and library" & " symbol file cannot be the same file", - Lib_Ref_Symbol_File.Location); + Lib_Ref_Symbol_File.Location, Project); end if; end; end if; @@ -5062,7 +4608,8 @@ package body Prj.Nmsc is begin if Dir'Length > 1 and then (Dir (Dir'Last - 1) = Directory_Separator - or else Dir (Dir'Last - 1) = '/') + or else + Dir (Dir'Last - 1) = '/') then return Dir'Last - 1; else @@ -5070,209 +4617,55 @@ package body Prj.Nmsc is end if; end Compute_Directory_Last; - --------------- - -- Error_Msg -- - --------------- - - procedure Error_Msg - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Msg : String; - Flag_Location : Source_Ptr) - is - Real_Location : Source_Ptr := Flag_Location; - Error_Buffer : String (1 .. 5_000); - Error_Last : Natural := 0; - Name_Number : Natural := 0; - File_Number : Natural := 0; - First : Positive := Msg'First; - Index : Positive; - - procedure Add (C : Character); - -- Add a character to the buffer - - procedure Add (S : String); - -- Add a string to the buffer - - procedure Add_Name; - -- Add a name to the buffer - - procedure Add_File; - -- Add a file name to the buffer - - --------- - -- Add -- - --------- - - procedure Add (C : Character) is - begin - Error_Last := Error_Last + 1; - Error_Buffer (Error_Last) := C; - end Add; - - procedure Add (S : String) is - begin - Error_Buffer (Error_Last + 1 .. Error_Last + S'Length) := S; - Error_Last := Error_Last + S'Length; - end Add; - - -------------- - -- Add_File -- - -------------- - - procedure Add_File is - File : File_Name_Type; - - begin - Add ('"'); - File_Number := File_Number + 1; - - case File_Number is - when 1 => - File := Err_Vars.Error_Msg_File_1; - when 2 => - File := Err_Vars.Error_Msg_File_2; - when 3 => - File := Err_Vars.Error_Msg_File_3; - when others => - null; - end case; - - Get_Name_String (File); - Add (Name_Buffer (1 .. Name_Len)); - Add ('"'); - end Add_File; - - -------------- - -- Add_Name -- - -------------- - - procedure Add_Name is - Name : Name_Id; - - begin - Add ('"'); - Name_Number := Name_Number + 1; - - case Name_Number is - when 1 => - Name := Err_Vars.Error_Msg_Name_1; - when 2 => - Name := Err_Vars.Error_Msg_Name_2; - when 3 => - Name := Err_Vars.Error_Msg_Name_3; - when others => - null; - end case; - - Get_Name_String (Name); - Add (Name_Buffer (1 .. Name_Len)); - Add ('"'); - end Add_Name; - - -- Start of processing for Error_Msg - - begin - -- If location of error is unknown, use the location of the project - - if Real_Location = No_Location then - Real_Location := Project.Location; - end if; - - if Error_Report = null then - Prj.Err.Error_Msg (Msg, Real_Location); - return; - end if; - - -- Ignore continuation character - - if Msg (First) = '\' then - First := First + 1; - end if; - - -- Warning character is always the first one in this package - -- this is an undocumented kludge??? - - if Msg (First) = '?' then - First := First + 1; - Add ("Warning: "); - - elsif Msg (First) = '<' then - First := First + 1; - - if Err_Vars.Error_Msg_Warn then - Add ("Warning: "); - end if; - end if; - - Index := First; - while Index <= Msg'Last loop - if Msg (Index) = '{' then - Add_File; - - elsif Msg (Index) = '%' then - if Index < Msg'Last and then Msg (Index + 1) = '%' then - Index := Index + 1; - end if; - - Add_Name; - else - Add (Msg (Index)); - end if; - Index := Index + 1; - - end loop; - - Error_Report (Error_Buffer (1 .. Error_Last), Project, In_Tree); - end Error_Msg; - - -------------------------------- - -- Free_Ada_Naming_Exceptions -- - -------------------------------- - - procedure Free_Ada_Naming_Exceptions is - begin - Ada_Naming_Exception_Table.Set_Last (0); - Ada_Naming_Exceptions.Reset; - Reverse_Ada_Naming_Exceptions.Reset; - end Free_Ada_Naming_Exceptions; - --------------------- -- Get_Directories -- --------------------- procedure Get_Directories (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Current_Dir : String) + Data : in out Tree_Processing_Data) is + package Recursive_Dirs is new GNAT.Dynamic_HTables.Simple_HTable + (Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- Hash table stores recursive source directories, to avoid looking + -- several times, and to avoid cycles that may be introduced by symbolic + -- links. + + Visited : Recursive_Dirs.Instance; + Object_Dir : constant Variable_Value := Util.Value_Of - (Name_Object_Dir, Project.Decl.Attributes, In_Tree); + (Name_Object_Dir, Project.Decl.Attributes, Data.Tree); Exec_Dir : constant Variable_Value := Util.Value_Of - (Name_Exec_Dir, Project.Decl.Attributes, In_Tree); + (Name_Exec_Dir, Project.Decl.Attributes, Data.Tree); Source_Dirs : constant Variable_Value := Util.Value_Of - (Name_Source_Dirs, Project.Decl.Attributes, In_Tree); + (Name_Source_Dirs, Project.Decl.Attributes, Data.Tree); Excluded_Source_Dirs : constant Variable_Value := Util.Value_Of (Name_Excluded_Source_Dirs, Project.Decl.Attributes, - In_Tree); + Data.Tree); Source_Files : constant Variable_Value := Util.Value_Of - (Name_Source_Files, Project.Decl.Attributes, In_Tree); + (Name_Source_Files, + Project.Decl.Attributes, Data.Tree); Last_Source_Dir : String_List_Id := Nil_String; Languages : constant Variable_Value := Prj.Util.Value_Of - (Name_Languages, Project.Decl.Attributes, In_Tree); + (Name_Languages, Project.Decl.Attributes, Data.Tree); procedure Find_Source_Dirs (From : File_Name_Type; @@ -5316,7 +4709,8 @@ package body Prj.Nmsc is The_Path : constant String := Normalize_Pathname (Get_Name_String (Path), - Directory => Current_Dir, + Directory => + Get_Name_String (Project.Directory.Display_Name), Resolve_Links => Opt.Follow_Links_For_Dirs) & Directory_Separator; @@ -5337,10 +4731,10 @@ package body Prj.Nmsc is -- and continue recursive processing. if not Removed then - if Recursive_Dirs.Get (Canonical_Path) then + if Recursive_Dirs.Get (Visited, Canonical_Path) then return; else - Recursive_Dirs.Set (Canonical_Path, True); + Recursive_Dirs.Set (Visited, Canonical_Path, True); end if; end if; @@ -5349,7 +4743,7 @@ package body Prj.Nmsc is List := Project.Source_Dirs; Prev := Nil_String; while List /= Nil_String loop - Element := In_Tree.String_Elements.Table (List); + Element := Data.Tree.String_Elements.Table (List); if Element.Value /= No_Name then Found := Element.Value = Canonical_Path; @@ -5368,7 +4762,7 @@ package body Prj.Nmsc is Write_Line (The_Path (The_Path'First .. The_Path_Last)); end if; - String_Element_Table.Increment_Last (In_Tree.String_Elements); + String_Element_Table.Increment_Last (Data.Tree.String_Elements); Element := (Value => Canonical_Path, Display_Value => Non_Canonical_Path, @@ -5381,31 +4775,31 @@ package body Prj.Nmsc is if Last_Source_Dir = Nil_String then Project.Source_Dirs := - String_Element_Table.Last (In_Tree.String_Elements); + String_Element_Table.Last (Data.Tree.String_Elements); -- Here we already have source directories else -- Link the previous last to the new one - In_Tree.String_Elements.Table + Data.Tree.String_Elements.Table (Last_Source_Dir).Next := - String_Element_Table.Last (In_Tree.String_Elements); + String_Element_Table.Last (Data.Tree.String_Elements); end if; -- And register this source directory as the new last Last_Source_Dir := - String_Element_Table.Last (In_Tree.String_Elements); - In_Tree.String_Elements.Table (Last_Source_Dir) := Element; + String_Element_Table.Last (Data.Tree.String_Elements); + Data.Tree.String_Elements.Table (Last_Source_Dir) := Element; elsif Removed and Found then if Prev = Nil_String then Project.Source_Dirs := - In_Tree.String_Elements.Table (List).Next; + Data.Tree.String_Elements.Table (List).Next; else - In_Tree.String_Elements.Table (Prev).Next := - In_Tree.String_Elements.Table (List).Next; + Data.Tree.String_Elements.Table (Prev).Next := + Data.Tree.String_Elements.Table (List).Next; end if; end if; @@ -5440,6 +4834,7 @@ package body Prj.Nmsc is begin if Is_Directory (Path_Name) then + -- We have found a new subdirectory, call self Name_Len := Path_Name'Length; @@ -5516,14 +4911,14 @@ package body Prj.Nmsc is if Location = No_Location then Error_Msg - (Project, In_Tree, + (Data.Flags, "{ is not a valid directory.", - Project.Location); + Project.Location, Project); else Error_Msg - (Project, In_Tree, + (Data.Flags, "{ is not a valid directory.", - Location); + Location, Project); end if; else @@ -5556,10 +4951,10 @@ package body Prj.Nmsc is begin Locate_Directory (Project => Project, - In_Tree => In_Tree, Name => From, Path => Path_Name, Dir_Exists => Dir_Exists, + Data => Data, Must_Exist => False); if not Dir_Exists then @@ -5567,28 +4962,26 @@ package body Prj.Nmsc is if Location = No_Location then Error_Msg - (Project, In_Tree, + (Data.Flags, "{ is not a valid directory", - Project.Location); + Project.Location, Project); else Error_Msg - (Project, In_Tree, + (Data.Flags, "{ is not a valid directory", - Location); + Location, Project); end if; else declare Path : constant String := - Get_Name_String (Path_Name.Name) & - Directory_Separator; + Get_Name_String (Path_Name.Name); Last_Path : constant Natural := Compute_Directory_Last (Path); Path_Id : Name_Id; Display_Path : constant String := Get_Name_String - (Path_Name.Display_Name) & - Directory_Separator; + (Path_Name.Display_Name); Last_Display_Path : constant Natural := Compute_Directory_Last (Display_Path); @@ -5610,7 +5003,7 @@ package body Prj.Nmsc is -- list of directories. String_Element_Table.Increment_Last - (In_Tree.String_Elements); + (Data.Tree.String_Elements); Element := (Value => Path_Id, Index => 0, @@ -5624,23 +5017,23 @@ package body Prj.Nmsc is -- This is the first source directory Project.Source_Dirs := String_Element_Table.Last - (In_Tree.String_Elements); + (Data.Tree.String_Elements); else -- We already have source directories, link the -- previous last to the new one. - In_Tree.String_Elements.Table + Data.Tree.String_Elements.Table (Last_Source_Dir).Next := String_Element_Table.Last - (In_Tree.String_Elements); + (Data.Tree.String_Elements); end if; -- And register this source directory as the new last Last_Source_Dir := String_Element_Table.Last - (In_Tree.String_Elements); - In_Tree.String_Elements.Table + (Data.Tree.String_Elements); + Data.Tree.String_Elements.Table (Last_Source_Dir) := Element; else @@ -5652,7 +5045,7 @@ package body Prj.Nmsc is List := Project.Source_Dirs; while List /= Nil_String loop - Element := In_Tree.String_Elements.Table (List); + Element := Data.Tree.String_Elements.Table (List); exit when Element.Value = Path_Id; Prev := List; List := Element.Next; @@ -5663,11 +5056,11 @@ package body Prj.Nmsc is if Prev = Nil_String then Project.Source_Dirs := - In_Tree.String_Elements.Table (List).Next; + Data.Tree.String_Elements.Table (List).Next; else - In_Tree.String_Elements.Table (Prev).Next := - In_Tree.String_Elements.Table (List).Next; + Data.Tree.String_Elements.Table (Prev).Next := + Data.Tree.String_Elements.Table (List).Next; end if; end if; end if; @@ -5675,6 +5068,8 @@ package body Prj.Nmsc is end if; end; end if; + + Recursive_Dirs.Reset (Visited); end Find_Source_Dirs; -- Start of processing for Get_Directories @@ -5690,7 +5085,7 @@ package body Prj.Nmsc is -- is no sources in the project. if (((not Source_Files.Default) - and then Source_Files.Values = Nil_String) + and then Source_Files.Values = Nil_String) or else ((not Source_Dirs.Default) and then Source_Dirs.Values = Nil_String) or else @@ -5709,9 +5104,9 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, In_Tree, + (Data.Flags, "Object_Dir cannot be empty", - Object_Dir.Location); + Object_Dir.Location, Project); else -- We check that the specified object directory does exist. @@ -5722,11 +5117,11 @@ package body Prj.Nmsc is Locate_Directory (Project, - In_Tree, File_Name_Type (Object_Dir.Value), Path => Project.Object_Directory, Create => "object", Dir_Exists => Dir_Exists, + Data => Data, Location => Object_Dir.Location, Must_Exist => False, Externally_Built => Project.Externally_Built); @@ -5740,9 +5135,9 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Object_Dir.Value); Error_Msg - (Project, In_Tree, + (Data.Flags, "object directory { not found", - Project.Location); + Project.Location, Project); end if; end if; @@ -5753,11 +5148,11 @@ package body Prj.Nmsc is Name_Buffer (1) := '.'; Locate_Directory (Project, - In_Tree, Name_Find, Path => Project.Object_Directory, Create => "object", Dir_Exists => Dir_Exists, + Data => Data, Location => Object_Dir.Location, Externally_Built => Project.Externally_Built); end if; @@ -5783,19 +5178,19 @@ package body Prj.Nmsc is if Name_Len = 0 then Error_Msg - (Project, In_Tree, + (Data.Flags, "Exec_Dir cannot be empty", - Exec_Dir.Location); + Exec_Dir.Location, Project); else -- We check that the specified exec directory does exist Locate_Directory (Project, - In_Tree, File_Name_Type (Exec_Dir.Value), Path => Project.Exec_Directory, Dir_Exists => Dir_Exists, + Data => Data, Create => "exec", Location => Exec_Dir.Location, Externally_Built => Project.Externally_Built); @@ -5803,9 +5198,9 @@ package body Prj.Nmsc is if not Dir_Exists then Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); Error_Msg - (Project, In_Tree, + (Data.Flags, "exec directory { not found", - Project.Location); + Project.Location, Project); end if; end if; end if; @@ -5835,10 +5230,9 @@ package body Prj.Nmsc is if Project.Qualifier = Standard then Error_Msg - (Project, - In_Tree, + (Data.Flags, "a standard project cannot have no sources", - Source_Files.Location); + Source_Files.Location, Project); end if; elsif Source_Dirs.Default then @@ -5846,15 +5240,16 @@ package body Prj.Nmsc is -- No Source_Dirs specified: the single source directory is the one -- containing the project file. - String_Element_Table.Append (In_Tree.String_Elements, + String_Element_Table.Append (Data.Tree.String_Elements, (Value => Name_Id (Project.Directory.Name), Display_Value => Name_Id (Project.Directory.Display_Name), Location => No_Location, Flag => False, Next => Nil_String, Index => 0)); + Project.Source_Dirs := - String_Element_Table.Last (In_Tree.String_Elements); + String_Element_Table.Last (Data.Tree.String_Elements); if Current_Verbosity = High then Write_Attr @@ -5865,10 +5260,9 @@ package body Prj.Nmsc is elsif Source_Dirs.Values = Nil_String then if Project.Qualifier = Standard then Error_Msg - (Project, - In_Tree, + (Data.Flags, "a standard project cannot have no source directories", - Source_Dirs.Location); + Source_Dirs.Location, Project); end if; Project.Source_Dirs := Nil_String; @@ -5883,7 +5277,7 @@ package body Prj.Nmsc is Source_Dir := Source_Dirs.Values; while Source_Dir /= Nil_String loop - Element := In_Tree.String_Elements.Table (Source_Dir); + Element := Data.Tree.String_Elements.Table (Source_Dir); Find_Source_Dirs (File_Name_Type (Element.Value), Element.Location); Source_Dir := Element.Next; @@ -5903,7 +5297,7 @@ package body Prj.Nmsc is Source_Dir := Excluded_Source_Dirs.Values; while Source_Dir /= Nil_String loop - Element := In_Tree.String_Elements.Table (Source_Dir); + Element := Data.Tree.String_Elements.Table (Source_Dir); Find_Source_Dirs (File_Name_Type (Element.Value), Element.Location, @@ -5923,11 +5317,11 @@ package body Prj.Nmsc is begin while Current /= Nil_String loop - Element := In_Tree.String_Elements.Table (Current); + Element := Data.Tree.String_Elements.Table (Current); if Element.Value /= No_Name then Element.Value := Name_Id (Canonical_Case_File_Name (Name_Id (Element.Value))); - In_Tree.String_Elements.Table (Current) := Element; + Data.Tree.String_Elements.Table (Current) := Element; end if; Current := Element.Next; @@ -5941,10 +5335,11 @@ package body Prj.Nmsc is procedure Get_Mains (Project : Project_Id; - In_Tree : Project_Tree_Ref) + Data : in out Tree_Processing_Data) is Mains : constant Variable_Value := - Prj.Util.Value_Of (Name_Main, Project.Decl.Attributes, In_Tree); + Prj.Util.Value_Of + (Name_Main, Project.Decl.Attributes, Data.Tree); List : String_List_Id; Elem : String_Element; @@ -5963,20 +5358,20 @@ package body Prj.Nmsc is elsif Project.Library then Error_Msg - (Project, In_Tree, + (Data.Flags, "a library project file cannot have Main specified", - Mains.Location); + Mains.Location, Project); else List := Mains.Values; while List /= Nil_String loop - Elem := In_Tree.String_Elements.Table (List); + Elem := Data.Tree.String_Elements.Table (List); if Length_Of_Name (Elem.Value) = 0 then Error_Msg - (Project, In_Tree, + (Data.Flags, "?a main cannot have an empty name", - Elem.Location); + Elem.Location, Project); exit; end if; @@ -5992,8 +5387,8 @@ package body Prj.Nmsc is procedure Get_Sources_From_File (Path : String; Location : Source_Ptr; - Project : Project_Id; - In_Tree : Project_Tree_Ref) + Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) is File : Prj.Util.Text_File; Line : String (1 .. 250); @@ -6002,10 +5397,6 @@ package body Prj.Nmsc is Name_Loc : Name_Location; begin - if Get_Mode = Ada_Only then - Source_Names.Reset; - end if; - if Current_Verbosity = High then Write_Str ("Opening """); Write_Str (Path); @@ -6017,7 +5408,8 @@ package body Prj.Nmsc is Prj.Util.Open (File, Path); if not Prj.Util.Is_Valid (File) then - Error_Msg (Project, In_Tree, "file does not exist", Location); + Error_Msg + (Data.Flags, "file does not exist", Location, Project.Project); else -- Read the lines one by one @@ -6041,26 +5433,26 @@ package body Prj.Nmsc is if Line (J) = '/' or else Line (J) = Directory_Separator then Error_Msg_File_1 := Source_Name; Error_Msg - (Project, - In_Tree, + (Data.Flags, "file name cannot include directory information ({)", - Location); + Location, Project.Project); exit; end if; end loop; - Name_Loc := Source_Names.Get (Source_Name); + Name_Loc := Source_Names_Htable.Get + (Project.Source_Names, Source_Name); if Name_Loc = No_Name_Location then Name_Loc := (Name => Source_Name, Location => Location, Source => No_Source, - Except => False, Found => False); end if; - Source_Names.Set (Source_Name, Name_Loc); + Source_Names_Htable.Set + (Project.Source_Names, Source_Name, Name_Loc); end if; end loop; @@ -6078,21 +5470,14 @@ 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) is Filename : constant String := Get_Name_String (File_Name); Last : Integer := Filename'Last; - Sep_Len : constant Integer := - Integer (Length_Of_Name (Naming.Separate_Suffix)); - Body_Len : constant Integer := - Integer (Length_Of_Name (Naming.Body_Suffix)); - Spec_Len : constant Integer := - Integer (Length_Of_Name (Naming.Spec_Suffix)); - - Standard_GNAT : constant Boolean := - Naming.Spec_Suffix = Default_Ada_Spec_Suffix - and then - Naming.Body_Suffix = Default_Ada_Body_Suffix; + Sep_Len : Integer; + Body_Len : Integer; + Spec_Len : Integer; Unit_Except : Unit_Exception; Masked : Boolean := False; @@ -6101,6 +5486,13 @@ package body Prj.Nmsc is Unit := No_Name; Kind := Spec; + if Naming.Separate_Suffix = No_File + or else Naming.Body_Suffix = No_File + or else Naming.Spec_Suffix = No_File + then + return; + end if; + if Naming.Dot_Replacement = No_File then if Current_Verbosity = High then Write_Line (" No dot_replacement specified"); @@ -6109,6 +5501,10 @@ package body Prj.Nmsc is return; end if; + Sep_Len := Integer (Length_Of_Name (Naming.Separate_Suffix)); + Spec_Len := Integer (Length_Of_Name (Naming.Spec_Suffix)); + Body_Len := Integer (Length_Of_Name (Naming.Body_Suffix)); + -- Choose the longest suffix that matches. If there are several matches, -- give priority to specs, then bodies, then separates. @@ -6135,7 +5531,7 @@ package body Prj.Nmsc is if Last = Filename'Last then if Current_Verbosity = High then - Write_Line (" No matching suffix"); + Write_Line (" no matching suffix"); end if; return; @@ -6210,7 +5606,9 @@ package body Prj.Nmsc is -- In the standard GNAT naming scheme, check for special cases: children -- or separates of A, G, I or S, and run time sources. - if Standard_GNAT and then Name_Len >= 3 then + if Is_Standard_GNAT_Naming (Naming) + and then Name_Len >= 3 + then declare S1 : constant Character := Name_Buffer (1); S2 : constant Character := Name_Buffer (2); @@ -6239,10 +5637,9 @@ package body Prj.Nmsc is elsif S2 = '.' then - -- If it is potentially a run time source, disable filling - -- of the mapping file to avoid warnings. + -- If it is potentially a run time source - Set_Mapping_File_Initial_State_To_Empty (In_Tree); + null; end if; end if; end; @@ -6254,11 +5651,11 @@ package body Prj.Nmsc is Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit); -- If there is a naming exception for the same unit, the file is not - -- a source for the unit. Currently, this only applies in multi_lang - -- mode, since Unit_Exceptions is no set in ada_only mode. + -- a source for the unit. if Unit /= No_Name then - Unit_Except := Unit_Exceptions.Get (Unit); + Unit_Except := + Unit_Exceptions_Htable.Get (Project.Unit_Exceptions, Unit); if Kind = Spec then Masked := Unit_Except.Spec /= No_File @@ -6302,114 +5699,64 @@ package body Prj.Nmsc is end if; end Compute_Unit_Name; - -------------- - -- Get_Unit -- - -------------- + -------------------------- + -- Check_Illegal_Suffix -- + -------------------------- - procedure Get_Unit - (In_Tree : Project_Tree_Ref; - Canonical_File_Name : File_Name_Type; - Project : Project_Id; - Exception_Id : out Ada_Naming_Exception_Id; - Unit_Name : out Name_Id; - Unit_Kind : out Spec_Or_Body) + procedure Check_Illegal_Suffix + (Project : Project_Id; + Suffix : File_Name_Type; + Dot_Replacement : File_Name_Type; + Attribute_Name : String; + Location : Source_Ptr; + Data : in out Tree_Processing_Data) is - Info_Id : Ada_Naming_Exception_Id := - Ada_Naming_Exceptions.Get (Canonical_File_Name); - VMS_Name : File_Name_Type; - Kind : Source_Kind; - Lang : Language_Ptr; - - begin - if Info_Id = No_Ada_Naming_Exception - and then Hostparm.OpenVMS - then - VMS_Name := Canonical_File_Name; - Get_Name_String (VMS_Name); - - if Name_Buffer (Name_Len) = '.' then - Name_Len := Name_Len - 1; - VMS_Name := Name_Find; - end if; - - Info_Id := Ada_Naming_Exceptions.Get (VMS_Name); - end if; - - if Info_Id /= No_Ada_Naming_Exception then - Exception_Id := Info_Id; - Unit_Name := No_Name; - Unit_Kind := Spec; - - else - Exception_Id := No_Ada_Naming_Exception; - Lang := Get_Language_From_Name (Project, "ada"); - - if Lang = null then - Unit_Name := No_Name; - Unit_Kind := Spec; - else - Compute_Unit_Name - (File_Name => Canonical_File_Name, - Naming => Lang.Config.Naming_Data, - Kind => Kind, - Unit => Unit_Name, - In_Tree => In_Tree); - - case Kind is - when Spec => Unit_Kind := Spec; - when Impl | Sep => Unit_Kind := Impl; - end case; - end if; - end if; - end Get_Unit; - - ---------- - -- Hash -- - ---------- + Suffix_Str : constant String := Get_Name_String (Suffix); - function Hash (Unit : Unit_Info) return Header_Num is begin - return Header_Num (Unit.Unit mod 2048); - end Hash; + if Suffix_Str'Length = 0 then - ----------------------- - -- Is_Illegal_Suffix -- - ----------------------- + -- Always valid - function Is_Illegal_Suffix - (Suffix : File_Name_Type; - Dot_Replacement : File_Name_Type) return Boolean - is - Suffix_Str : constant String := Get_Name_String (Suffix); + return; - begin - if Suffix_Str'Length = 0 then - return False; elsif Index (Suffix_Str, ".") = 0 then - return True; + Err_Vars.Error_Msg_File_1 := Suffix; + Error_Msg + (Data.Flags, + "{ is illegal for " & Attribute_Name & ": must have a dot", + Location, Project); + return; end if; -- Case of dot replacement is a single dot, and first character of -- suffix is also a dot. - if Get_Name_String (Dot_Replacement) = "." + if Dot_Replacement /= No_File + and then Get_Name_String (Dot_Replacement) = "." and then Suffix_Str (Suffix_Str'First) = '.' then for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop - -- Case of following dot + -- If there are multiple dots in the name if Suffix_Str (Index) = '.' then -- It is illegal to have a letter following the initial dot - return Is_Letter (Suffix_Str (Suffix_Str'First + 1)); + if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then + Err_Vars.Error_Msg_File_1 := Suffix; + Error_Msg + (Data.Flags, + "{ is illegal for " & Attribute_Name + & ": ambiguous prefix when Dot_Replacement is a dot", + Location, Project); + end if; + return; end if; end loop; end if; - - return False; - end Is_Illegal_Suffix; + end Check_Illegal_Suffix; ---------------------- -- Locate_Directory -- @@ -6417,10 +5764,10 @@ package body Prj.Nmsc is procedure Locate_Directory (Project : Project_Id; - In_Tree : Project_Tree_Ref; Name : File_Name_Type; Path : out Path_Information; Dir_Exists : out Boolean; + Data : in out Tree_Processing_Data; Create : String := ""; Location : Source_Ptr := No_Location; Must_Exist : Boolean := True; @@ -6429,7 +5776,7 @@ package body Prj.Nmsc is Parent : constant Path_Name_Type := Project.Directory.Display_Name; The_Parent : constant String := - Get_Name_String (Parent) & Directory_Separator; + Get_Name_String (Parent); The_Parent_Last : constant Natural := Compute_Directory_Last (The_Parent); Full_Name : File_Name_Type; @@ -6522,10 +5869,10 @@ package body Prj.Nmsc is exception when Use_Error => Error_Msg - (Project, In_Tree, + (Data.Flags, "could not create " & Create & " directory " & Full_Path_Name.all, - Location); + Location, Project); end; end if; end if; @@ -6556,10 +5903,22 @@ package body Prj.Nmsc is begin Name_Len := Normed'Length; Name_Buffer (1 .. Name_Len) := Normed; + + -- Directories should always end with a directory separator + + if Name_Buffer (Name_Len) /= Directory_Separator then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + Path.Display_Name := Name_Find; Name_Len := Canonical_Path'Length; Name_Buffer (1 .. Name_Len) := Canonical_Path; + + if Name_Buffer (Name_Len) /= Directory_Separator then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + Path.Name := Name_Find; end; end if; @@ -6573,19 +5932,18 @@ package body Prj.Nmsc is --------------------------- procedure Find_Excluded_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref) + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) is Excluded_Source_List_File : constant Variable_Value := Util.Value_Of (Name_Excluded_Source_List_File, - Project.Decl.Attributes, - In_Tree); - + Project.Project.Decl.Attributes, + Data.Tree); Excluded_Sources : Variable_Value := Util.Value_Of (Name_Excluded_Source_Files, - Project.Decl.Attributes, - In_Tree); + Project.Project.Decl.Attributes, + Data.Tree); Current : String_List_Id; Element : String_Element; @@ -6603,33 +5961,32 @@ package body Prj.Nmsc is Locally_Removed := True; Excluded_Sources := Util.Value_Of - (Name_Locally_Removed_Files, Project.Decl.Attributes, In_Tree); + (Name_Locally_Removed_Files, + Project.Project.Decl.Attributes, Data.Tree); end if; - Excluded_Sources_Htable.Reset; - -- If there are excluded sources, put them in the table if not Excluded_Sources.Default then if not Excluded_Source_List_File.Default then if Locally_Removed then Error_Msg - (Project, In_Tree, + (Data.Flags, "?both attributes Locally_Removed_Files and " & "Excluded_Source_List_File are present", - Excluded_Source_List_File.Location); + Excluded_Source_List_File.Location, Project.Project); else Error_Msg - (Project, In_Tree, + (Data.Flags, "?both attributes Excluded_Source_Files and " & "Excluded_Source_List_File are present", - Excluded_Source_List_File.Location); + Excluded_Source_List_File.Location, Project.Project); end if; end if; Current := Excluded_Sources.Values; while Current /= Nil_String loop - Element := In_Tree.String_Elements.Table (Current); + Element := Data.Tree.String_Elements.Table (Current); Name := Canonical_Case_File_Name (Element.Value); -- If the element has no location, then use the location of @@ -6641,7 +5998,8 @@ package body Prj.Nmsc is Location := Element.Location; end if; - Excluded_Sources_Htable.Set (Name, (Name, False, Location)); + Excluded_Sources_Htable.Set + (Project.Excluded, Name, (Name, False, Location)); Current := Element.Next; end loop; @@ -6653,16 +6011,16 @@ package body Prj.Nmsc is Path_Name_Of (File_Name_Type (Excluded_Source_List_File.Value), - Project.Directory.Name); + Project.Project.Directory.Name); begin if Source_File_Path_Name'Length = 0 then Err_Vars.Error_Msg_File_1 := File_Name_Type (Excluded_Source_List_File.Value); Error_Msg - (Project, In_Tree, + (Data.Flags, "file with excluded sources { does not exist", - Excluded_Source_List_File.Location); + Excluded_Source_List_File.Location, Project.Project); else -- Open the file @@ -6671,7 +6029,8 @@ package body Prj.Nmsc is if not Prj.Util.Is_Valid (File) then Error_Msg - (Project, In_Tree, "file does not exist", Location); + (Data.Flags, "file does not exist", + Location, Project.Project); else -- Read the lines one by one @@ -6696,17 +6055,16 @@ package body Prj.Nmsc is then Error_Msg_File_1 := Name; Error_Msg - (Project, - In_Tree, + (Data.Flags, "file name cannot include " & "directory information ({)", - Location); + Location, Project.Project); exit; end if; end loop; Excluded_Sources_Htable.Set - (Name, (Name, False, Location)); + (Project.Excluded, Name, (Name, False, Location)); end if; end loop; @@ -6722,22 +6080,20 @@ package body Prj.Nmsc is ------------------ procedure Find_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Proc_Data : in out Processing_Data; - Allow_Duplicate_Basenames : Boolean) + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) is Sources : constant Variable_Value := Util.Value_Of (Name_Source_Files, - Project.Decl.Attributes, - In_Tree); + Project.Project.Decl.Attributes, + Data.Tree); Source_List_File : constant Variable_Value := Util.Value_Of (Name_Source_List_File, - Project.Decl.Attributes, - In_Tree); + Project.Project.Decl.Attributes, + Data.Tree); Name_Loc : Name_Location; Has_Explicit_Sources : Boolean; @@ -6748,15 +6104,17 @@ package body Prj.Nmsc is (Source_List_File.Kind = Single, "Source_List_File is not a single string"); + Project.Source_List_File_Location := Source_List_File.Location; + -- If the user has specified a Source_Files attribute if not Sources.Default then if not Source_List_File.Default then Error_Msg - (Project, In_Tree, + (Data.Flags, "?both attributes source_files and " & "source_list_file are present", - Source_List_File.Location); + Source_List_File.Location, Project.Project); end if; -- Sources is a list of file names @@ -6768,24 +6126,23 @@ package body Prj.Nmsc is Name : File_Name_Type; begin - if Get_Mode = Multi_Language then - if Current = Nil_String then - Project.Languages := No_Language_Index; + if Current = Nil_String then + Project.Project.Languages := No_Language_Index; - -- This project contains no source. For projects that don't - -- extend other projects, this also means that there is no - -- need for an object directory, if not specified. + -- This project contains no source. For projects that don't + -- extend other projects, this also means that there is no + -- need for an object directory, if not specified. - if Project.Extends = No_Project - and then Project.Object_Directory = Project.Directory - then - Project.Object_Directory := No_Path_Information; - end if; + if Project.Project.Extends = No_Project + and then Project.Project.Object_Directory = + Project.Project.Directory + then + Project.Project.Object_Directory := No_Path_Information; end if; end if; while Current /= Nil_String loop - Element := In_Tree.String_Elements.Table (Current); + Element := Data.Tree.String_Elements.Table (Current); Name := Canonical_Case_File_Name (Element.Value); Get_Name_String (Element.Value); @@ -6806,35 +6163,29 @@ package body Prj.Nmsc is then Error_Msg_File_1 := Name; Error_Msg - (Project, - In_Tree, + (Data.Flags, "file name cannot include directory " & "information ({)", - Location); + Location, Project.Project); exit; end if; end loop; - -- In Multi_Language mode, check whether the file is already - -- there: the same file name may be in the list. If the source - -- is missing, the error will be on the first mention of the - -- source file name. + -- Check whether the file is already there: the same file name + -- may be in the list. If the source is missing, the error will + -- be on the first mention of the source file name. - case Get_Mode is - when Ada_Only => - Name_Loc := No_Name_Location; - when Multi_Language => - Name_Loc := Source_Names.Get (Name); - end case; + Name_Loc := Source_Names_Htable.Get + (Project.Source_Names, Name); if Name_Loc = No_Name_Location then Name_Loc := (Name => Name, Location => Location, Source => No_Source, - Except => False, Found => False); - Source_Names.Set (Name, Name_Loc); + Source_Names_Htable.Set + (Project.Source_Names, Name, Name_Loc); end if; Current := Element.Next; @@ -6855,7 +6206,7 @@ package body Prj.Nmsc is Source_File_Path_Name : constant String := Path_Name_Of (File_Name_Type (Source_List_File.Value), - Project.Directory.Name); + Project.Project.Directory.Name); begin Has_Explicit_Sources := True; @@ -6864,14 +6215,14 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Source_List_File.Value); Error_Msg - (Project, In_Tree, + (Data.Flags, "file with sources { does not exist", - Source_List_File.Location); + Source_List_File.Location, Project.Project); else Get_Sources_From_File (Source_File_Path_Name, Source_List_File.Location, - Project, In_Tree); + Project, Data); end if; end; @@ -6883,30 +6234,19 @@ package body Prj.Nmsc is Has_Explicit_Sources := False; end if; - if Get_Mode = Ada_Only then - Find_Ada_Sources - (Project, In_Tree, - Explicit_Sources_Only => Has_Explicit_Sources, - Proc_Data => Proc_Data); + Search_Directories + (Project, + Data => Data, + For_All_Sources => Sources.Default and then Source_List_File.Default); - else - Search_Directories - (Project, In_Tree, - For_All_Sources => - Sources.Default and then Source_List_File.Default, - Allow_Duplicate_Basenames => Allow_Duplicate_Basenames); - end if; - - -- Check if all exceptions have been found. For Ada, it is an error if - -- an exception is not found. For other language, the source is simply - -- removed. + -- Check if all exceptions have been found. declare Source : Source_Id; Iter : Source_Iterator; begin - Iter := For_Each_Source (In_Tree, Project); + Iter := For_Each_Source (Data.Tree, Project.Project); loop Source := Prj.Element (Iter); exit when Source = No_Source; @@ -6916,9 +6256,11 @@ package body Prj.Nmsc is then if Source.Unit /= No_Unit_Index then - -- ??? Current limitation of gprbuild will display this - -- error message for multi-unit source files, because not - -- all instances of the file have had their path fully set. + -- For multi-unit source files, source_id gets duplicated + -- once for every unit. Only the first source_id got its + -- full path set. So if it isn't set for that first one, + -- the file wasn't found. Otherwise we need to update for + -- units after the first one. if Source.Index = 0 or else Source.Index = 1 @@ -6926,13 +6268,29 @@ package body Prj.Nmsc is Error_Msg_Name_1 := Name_Id (Source.Display_File); Error_Msg_Name_2 := Name_Id (Source.Unit.Name); Error_Msg - (Project, In_Tree, + (Data.Flags, "source file %% for unit %% not found", - No_Location); + No_Location, Project.Project); + + else + Source.Path := Files_Htable.Get + (Data.File_To_Source, Source.File).Path; + + if Current_Verbosity = High then + if Source.Path /= No_Path_Information then + Write_Line ("Setting full path for " + & Get_Name_String (Source.File) + & " at" & Source.Index'Img + & " to " + & Get_Name_String (Source.Path.Name)); + end if; + end if; end if; end if; - Remove_Source (Source, No_Source); + if Source.Path = No_Path_Information then + Remove_Source (Source, No_Source); + end if; end if; Next (Iter); @@ -6948,7 +6306,7 @@ package body Prj.Nmsc is First_Error : Boolean; begin - NL := Source_Names.Get_First; + NL := Source_Names_Htable.Get_First (Project.Source_Names); First_Error := True; while NL /= No_Name_Location loop if not NL.Found then @@ -6956,201 +6314,71 @@ package body Prj.Nmsc is if First_Error then Error_Msg - (Project, In_Tree, + (Data.Flags, "source file { not found", - NL.Location); + NL.Location, Project.Project); First_Error := False; else Error_Msg - (Project, In_Tree, + (Data.Flags, "\source file { not found", - NL.Location); + NL.Location, Project.Project); end if; end if; - NL := Source_Names.Get_Next; + NL := Source_Names_Htable.Get_Next (Project.Source_Names); end loop; end; end if; - - if Get_Mode = Ada_Only - and then Project.Extends = No_Project - then - -- We should have found at least one source, if not report an error - - if not Has_Ada_Sources (Project) then - Report_No_Sources - (Project, "Ada", In_Tree, Source_List_File.Location); - end if; - end if; end Find_Sources; ---------------- -- Initialize -- ---------------- - procedure Initialize (Proc_Data : in out Processing_Data) is + procedure Initialize + (Data : out Tree_Processing_Data; + Tree : Project_Tree_Ref; + Flags : Prj.Processing_Flags) + is begin - Files_Htable.Reset (Proc_Data.Units); + Files_Htable.Reset (Data.File_To_Source); + Data.Tree := Tree; + Data.Flags := Flags; end Initialize; ---------- -- Free -- ---------- - procedure Free (Proc_Data : in out Processing_Data) is + procedure Free (Data : in out Tree_Processing_Data) is begin - Files_Htable.Reset (Proc_Data.Units); + Files_Htable.Reset (Data.File_To_Source); end Free; - ---------------------- - -- Find_Ada_Sources -- - ---------------------- + ---------------- + -- Initialize -- + ---------------- - procedure Find_Ada_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Explicit_Sources_Only : Boolean; - Proc_Data : in out Processing_Data) + procedure Initialize + (Data : in out Project_Processing_Data; + Project : Project_Id) is - Source_Dir : String_List_Id; - Element : String_Element; - Dir : Dir_Type; - Dir_Has_Source : Boolean := False; - NL : Name_Location; - Ada_Language : Language_Ptr; - begin - if Current_Verbosity = High then - Write_Line ("Looking for Ada sources:"); - end if; - - Ada_Language := Project.Languages; - while Ada_Language /= No_Language_Index - and then Ada_Language.Name /= Name_Ada - loop - Ada_Language := Ada_Language.Next; - end loop; - - -- We look in all source directories for the file names in the hash - -- table Source_Names. - - Source_Dir := Project.Source_Dirs; - while Source_Dir /= Nil_String loop - Dir_Has_Source := False; - Element := In_Tree.String_Elements.Table (Source_Dir); - - declare - Dir_Path : constant String := - Get_Name_String (Element.Display_Value) & - Directory_Separator; - Dir_Last : constant Natural := Compute_Directory_Last (Dir_Path); - - begin - if Current_Verbosity = High then - Write_Line ("checking directory """ & Dir_Path & """"); - end if; - - -- Look for all files in the current source directory - - Open (Dir, Dir_Path (Dir_Path'First .. Dir_Last)); - - loop - Read (Dir, Name_Buffer, Name_Len); - exit when Name_Len = 0; - - if Current_Verbosity = High then - Write_Line (" Checking " & Name_Buffer (1 .. Name_Len)); - end if; - - declare - Name : constant File_Name_Type := Name_Find; - Canonical_Name : File_Name_Type; - - -- ??? We could probably optimize the following call: we - -- need to resolve links only once for the directory itself, - -- and then do a single call to readlink() for each file. - -- Unfortunately that would require Normalize_Pathname to - -- be changed so that it has the option of not resolving - -- links for its Directory parameter, only for Name. - - Path : constant String := - Normalize_Pathname - (Name => Name_Buffer (1 .. Name_Len), - Directory => Dir_Path (Dir_Path'First .. Dir_Last), - Resolve_Links => Opt.Follow_Links_For_Files, - Case_Sensitive => True); -- no case folding - - Path_Name : Path_Name_Type; - To_Record : Boolean := False; - Location : Source_Ptr; - - begin - -- If the file was listed in the explicit list of sources, - -- mark it as such (since we'll need to report an error when - -- an explicit source was not found) - - if Explicit_Sources_Only then - Canonical_Name := - Canonical_Case_File_Name (Name_Id (Name)); - NL := Source_Names.Get (Canonical_Name); - To_Record := NL /= No_Name_Location and then not NL.Found; - - if To_Record then - NL.Found := True; - Location := NL.Location; - Source_Names.Set (Canonical_Name, NL); - end if; - - else - To_Record := True; - Location := No_Location; - end if; - - if To_Record then - Name_Len := Path'Length; - Name_Buffer (1 .. Name_Len) := Path; - Path_Name := Name_Find; - - if Current_Verbosity = High then - Write_Line (" recording " & Get_Name_String (Name)); - end if; - - -- Register the source if it is an Ada compilation unit - - Record_Ada_Source - (File_Name => Name, - Path_Name => Path_Name, - Project => Project, - In_Tree => In_Tree, - Proc_Data => Proc_Data, - Ada_Language => Ada_Language, - Location => Location, - Source_Recorded => Dir_Has_Source); - end if; - end; - end loop; - - Close (Dir); - - exception - when others => - Close (Dir); - raise; - end; - - if Dir_Has_Source then - In_Tree.String_Elements.Table (Source_Dir).Flag := True; - end if; + Data.Project := Project; + end Initialize; - Source_Dir := Element.Next; - end loop; + ---------- + -- Free -- + ---------- - if Current_Verbosity = High then - Write_Line ("End looking for sources"); - end if; - end Find_Ada_Sources; + procedure Free (Data : in out Project_Processing_Data) is + begin + Source_Names_Htable.Reset (Data.Source_Names); + Unit_Exceptions_Htable.Reset (Data.Unit_Exceptions); + Excluded_Sources_Htable.Reset (Data.Excluded); + end Free; ------------------------------- -- Check_File_Naming_Schemes -- @@ -7158,7 +6386,7 @@ package body Prj.Nmsc is procedure Check_File_Naming_Schemes (In_Tree : Project_Tree_Ref; - Project : Project_Id; + Project : Project_Processing_Data; File_Name : File_Name_Type; Alternate_Languages : out Language_List; Language : out Language_Ptr; @@ -7235,7 +6463,7 @@ package body Prj.Nmsc is Lang_Kind := File_Based; Kind := Spec; - Tmp_Lang := Project.Languages; + Tmp_Lang := Project.Project.Languages; while Tmp_Lang /= No_Language_Index loop if Current_Verbosity = High then Write_Line @@ -7264,6 +6492,7 @@ package body Prj.Nmsc is Naming => Config.Naming_Data, Kind => Kind, Unit => Unit, + Project => Project, In_Tree => In_Tree); if Unit /= No_Name then @@ -7318,31 +6547,30 @@ package body Prj.Nmsc is ---------------- procedure Check_File - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Path : Path_Name_Type; - File_Name : File_Name_Type; - Display_File_Name : File_Name_Type; - For_All_Sources : Boolean; - Allow_Duplicate_Basenames : Boolean) + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data; + Path : Path_Name_Type; + File_Name : File_Name_Type; + Display_File_Name : File_Name_Type; + Locally_Removed : Boolean; + For_All_Sources : Boolean) is Canonical_Path : constant Path_Name_Type := Path_Name_Type (Canonical_Case_File_Name (Name_Id (Path))); - Name_Loc : Name_Location := Source_Names.Get (File_Name); + Name_Loc : Name_Location := + Source_Names_Htable.Get + (Project.Source_Names, File_Name); Check_Name : Boolean := False; Alternate_Languages : Language_List; Language : Language_Ptr; Source : Source_Id; - Add_Src : Boolean; Src_Ind : Source_File_Index; Unit : Name_Id; - Source_To_Replace : Source_Id := No_Source; Display_Language_Name : Name_Id; Lang_Kind : Language_Kind; Kind : Source_Kind := Spec; - Iter : Source_Iterator; begin if Name_Loc = No_Name_Location then @@ -7350,36 +6578,32 @@ package body Prj.Nmsc is else if Name_Loc.Found then + -- Check if it is OK to have the same file name in several -- source directories. - if not Project.Known_Order_Of_Source_Dirs then + if not Project.Project.Known_Order_Of_Source_Dirs then Error_Msg_File_1 := File_Name; Error_Msg - (Project, In_Tree, + (Data.Flags, "{ is found in several source directories", - Name_Loc.Location); + Name_Loc.Location, Project.Project); end if; else Name_Loc.Found := True; - Source_Names.Set (File_Name, Name_Loc); + Source_Names_Htable.Set + (Project.Source_Names, File_Name, Name_Loc); if Name_Loc.Source = No_Source then Check_Name := True; else - -- ??? Issue: there could be several entries for the same - -- source file in the list of sources, in case the file - -- contains multiple units. We should share the data as much - -- as possible, and more importantly set the path for all - -- instances. - Name_Loc.Source.Path := (Canonical_Path, Path); Source_Paths_Htable.Set - (In_Tree.Source_Paths_HT, + (Data.Tree.Source_Paths_HT, Canonical_Path, Name_Loc.Source); @@ -7395,13 +6619,16 @@ package body Prj.Nmsc is Override_Kind (Name_Loc.Source, Sep); end if; end if; + + Files_Htable.Set + (Data.File_To_Source, File_Name, Name_Loc.Source); end if; end if; end if; if Check_Name then Check_File_Naming_Schemes - (In_Tree => In_Tree, + (In_Tree => Data.Tree, Project => Project, File_Name => File_Name, Alternate_Languages => Alternate_Languages, @@ -7415,127 +6642,29 @@ package body Prj.Nmsc is -- A file name in a list must be a source of a language - if Name_Loc.Found then + if Data.Flags.Error_On_Unknown_Language + and then Name_Loc.Found + then Error_Msg_File_1 := File_Name; Error_Msg - (Project, - In_Tree, + (Data.Flags, "language unknown for {", - Name_Loc.Location); + Name_Loc.Location, Project.Project); end if; else - -- Check if the same file name or unit is used in the prj tree - - Iter := For_Each_Source (In_Tree); - Add_Src := True; - loop - Source := Prj.Element (Iter); - exit when Source = No_Source; - - if Unit /= No_Name - and then Source.Unit /= No_Unit_Index - and then Source.Unit.Name = Unit - and then - ((Source.Kind = Spec and then Kind = Impl) - or else - (Source.Kind = Impl and then Kind = Spec)) - then - -- We found the "other_part (source)" - - null; - - elsif (Unit /= No_Name - and then Source.Unit /= No_Unit_Index - and then Source.Unit.Name = Unit - and then - (Source.Kind = Kind - or else - (Source.Kind = Sep and then Kind = Impl) - or else - (Source.Kind = Impl and then Kind = Sep))) - or else - (Unit = No_Name and then Source.File = File_Name) - then - -- Duplication of file/unit in same project is only allowed - -- if order of source directories is known. - - if Project = Source.Project then - if Unit = No_Name then - if Allow_Duplicate_Basenames then - Add_Src := True; - elsif Project.Known_Order_Of_Source_Dirs then - Add_Src := False; - else - Error_Msg_File_1 := File_Name; - Error_Msg - (Project, In_Tree, "duplicate source file name {", - No_Location); - Add_Src := False; - end if; - - else - if Project.Known_Order_Of_Source_Dirs then - Add_Src := False; - else - Error_Msg_Name_1 := Unit; - Error_Msg - (Project, In_Tree, "duplicate unit %%", - No_Location); - Add_Src := False; - end if; - end if; - - -- Do not allow the same unit name in different projects, - -- except if one is extending the other. - - -- For a file based language, the same file name replaces - -- a file in a project being extended, but it is allowed - -- to have the same file name in unrelated projects. - - elsif Is_Extending (Project, Source.Project) then - Source_To_Replace := Source; - - elsif Unit /= No_Name - and then not Source.Locally_Removed - then - Error_Msg_Name_1 := Unit; - Error_Msg - (Project, In_Tree, - "unit %% cannot belong to several projects", - No_Location); - - Error_Msg_Name_1 := Project.Name; - Error_Msg_Name_2 := Name_Id (Path); - Error_Msg - (Project, In_Tree, "\ project %%, %%", No_Location); - - Error_Msg_Name_1 := Source.Project.Name; - Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name); - Error_Msg - (Project, In_Tree, "\ project %%, %%", No_Location); - - Add_Src := False; - end if; - end if; - - Next (Iter); - end loop; - - if Add_Src then - Add_Source - (Id => Source, - In_Tree => In_Tree, - Project => Project, - Lang_Id => Language, - Kind => Kind, - Alternate_Languages => Alternate_Languages, - File_Name => File_Name, - Display_File => Display_File_Name, - Unit => Unit, - Path => (Canonical_Path, Path), - Source_To_Replace => Source_To_Replace); - end if; + Add_Source + (Id => Source, + Project => Project.Project, + Lang_Id => Language, + Kind => Kind, + Data => Data, + Alternate_Languages => Alternate_Languages, + File_Name => File_Name, + Display_File => Display_File_Name, + Unit => Unit, + Locally_Removed => Locally_Removed, + Path => (Canonical_Path, Path)); end if; end if; end Check_File; @@ -7545,10 +6674,9 @@ package body Prj.Nmsc is ------------------------ procedure Search_Directories - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - For_All_Sources : Boolean; - Allow_Duplicate_Basenames : Boolean) + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data; + For_All_Sources : Boolean) is Source_Dir : String_List_Id; Element : String_Element; @@ -7565,10 +6693,10 @@ package body Prj.Nmsc is -- Loop through subdirectories - Source_Dir := Project.Source_Dirs; + Source_Dir := Project.Project.Source_Dirs; while Source_Dir /= Nil_String loop begin - Element := In_Tree.String_Elements.Table (Source_Dir); + Element := Data.Tree.String_Elements.Table (Source_Dir); if Element.Value /= No_Name then Get_Name_String (Element.Display_Value); @@ -7633,8 +6761,9 @@ package body Prj.Nmsc is -- Case_Sensitive set True (no folding) Path : Path_Name_Type; - FF : File_Found := - Excluded_Sources_Htable.Get (File_Name); + FF : File_Found := Excluded_Sources_Htable.Get + (Project.Excluded, File_Name); + To_Remove : Boolean := False; begin Name_Len := Path_Name'Length; @@ -7644,27 +6773,33 @@ package body Prj.Nmsc is if FF /= No_File_Found then if not FF.Found then FF.Found := True; - Excluded_Sources_Htable.Set (File_Name, FF); + Excluded_Sources_Htable.Set + (Project.Excluded, File_Name, FF); if Current_Verbosity = High then Write_Str (" excluded source """); Write_Str (Get_Name_String (File_Name)); Write_Line (""""); end if; - end if; - else - Check_File - (Project => Project, - In_Tree => In_Tree, - Path => Path, - File_Name => File_Name, - Display_File_Name => - Display_File_Name, - For_All_Sources => For_All_Sources, - Allow_Duplicate_Basenames => - Allow_Duplicate_Basenames); + -- Will mark the file as removed, but we + -- still need to add it to the list: if we + -- don't, the file will not appear in the + -- mapping file and will cause the compiler + -- to fail + + To_Remove := True; + end if; end if; + + Check_File + (Project => Project, + Data => Data, + Path => Path, + File_Name => File_Name, + Locally_Removed => To_Remove, + Display_File_Name => Display_File_Name, + For_All_Sources => For_All_Sources); end; end if; end loop; @@ -7691,28 +6826,28 @@ package body Prj.Nmsc is ---------------------------- procedure Load_Naming_Exceptions - (Project : Project_Id; - In_Tree : Project_Tree_Ref) + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) is Source : Source_Id; Iter : Source_Iterator; begin - Unit_Exceptions.Reset; - - Iter := For_Each_Source (In_Tree, Project); + Iter := For_Each_Source (Data.Tree, Project.Project); loop Source := Prj.Element (Iter); exit when Source = No_Source; -- An excluded file cannot also be an exception file name - if Excluded_Sources_Htable.Get (Source.File) /= No_File_Found then + if Excluded_Sources_Htable.Get (Project.Excluded, Source.File) /= + No_File_Found + then Error_Msg_File_1 := Source.File; Error_Msg - (Project, In_Tree, + (Data.Flags, "{ cannot be both excluded and an exception file name", - No_Location); + No_Location, Project.Project); end if; if Current_Verbosity = High then @@ -7721,21 +6856,22 @@ package body Prj.Nmsc is Write_Line (" in Source_Names"); end if; - Source_Names.Set - (K => Source.File, + Source_Names_Htable.Set + (Project.Source_Names, + K => Source.File, E => Name_Location' - (Name => Source.File, - Location => No_Location, - Source => Source, - Except => Source.Unit /= No_Unit_Index, - Found => False)); + (Name => Source.File, + Location => No_Location, + Source => Source, + Found => False)); -- If this is an Ada exception, record in table Unit_Exceptions if Source.Unit /= No_Unit_Index then declare Unit_Except : Unit_Exception := - Unit_Exceptions.Get (Source.Unit.Name); + Unit_Exceptions_Htable.Get + (Project.Unit_Exceptions, Source.Unit.Name); begin Unit_Except.Name := Source.Unit.Name; @@ -7746,7 +6882,8 @@ package body Prj.Nmsc is Unit_Except.Impl := Source.File; end if; - Unit_Exceptions.Set (Source.Unit.Name, Unit_Except); + Unit_Exceptions_Htable.Set + (Project.Unit_Exceptions, Source.Unit.Name, Unit_Except); end; end if; @@ -7759,49 +6896,82 @@ package body Prj.Nmsc is ---------------------- procedure Look_For_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Proc_Data : in out Processing_Data; - Allow_Duplicate_Basenames : Boolean) + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) is + Object_Files : Object_File_Names_Htable.Instance; Iter : Source_Iterator; + Src : Source_Id; + + procedure Check_Object (Src : Source_Id); + -- Check if object file name of Src is already used in the project tree, + -- and report an error if so. - procedure Process_Sources_In_Multi_Language_Mode; - -- Find all source files when in multi language mode + procedure Check_Object_Files; + -- Check that no two sources of this project have the same object file procedure Mark_Excluded_Sources; -- Mark as such the sources that are declared as excluded + ------------------ + -- Check_Object -- + ------------------ + + procedure Check_Object (Src : Source_Id) is + Source : Source_Id; + + begin + Source := Object_File_Names_Htable.Get (Object_Files, Src.Object); + + -- We cannot just check on "Source /= Src", since we might have + -- two different entries for the same file (and since that's + -- the same file it is expected that it has the same object) + + if Source /= No_Source + and then Source.Path /= Src.Path + then + Error_Msg_File_1 := Src.File; + Error_Msg_File_2 := Source.File; + Error_Msg + (Data.Flags, + "{ and { have the same object file name", + No_Location, Project.Project); + + else + Object_File_Names_Htable.Set (Object_Files, Src.Object, Src); + end if; + end Check_Object; + --------------------------- -- Mark_Excluded_Sources -- --------------------------- procedure Mark_Excluded_Sources is Source : Source_Id := No_Source; - OK : Boolean; Excluded : File_Found; + Proj : Project_Id; begin - Excluded := Excluded_Sources_Htable.Get_First; - while Excluded /= No_File_Found loop - OK := False; - - -- ??? Don't we have a hash table to map files to Source_Id? - -- ??? Why can't simply iterate over the sources of the current - -- project, as opposed to the whole tree ? - - Iter := For_Each_Source (In_Tree); - loop - Source := Prj.Element (Iter); - exit when Source = No_Source; - - if Source.File = Excluded.File then - if Source.Project = Project - or else Is_Extending (Project, Source.Project) - then - OK := True; + -- Minor optimization: if there are no excluded files, no need to + -- traverse the list of sources. We cannot however also check whether + -- the existing exceptions have ".Found" set to True (indicating we + -- found them before) because we need to do some final processing on + -- them in any case. + + if Excluded_Sources_Htable.Get_First (Project.Excluded) /= + No_File_Found + then + Proj := Project.Project; + while Proj /= No_Project loop + Iter := For_Each_Source (Data.Tree, Proj); + while Prj.Element (Iter) /= No_Source loop + Source := Prj.Element (Iter); + Excluded := Excluded_Sources_Htable.Get + (Project.Excluded, Source.File); + + if Excluded /= No_File_Found then Source.Locally_Removed := True; - Source.In_Interfaces := False; + Source.In_Interfaces := False; if Current_Verbosity = High then Write_Str ("Removing file "); @@ -7810,162 +6980,123 @@ package body Prj.Nmsc is & " " & Get_Name_String (Source.Project.Name)); end if; - else - Error_Msg - (Project, In_Tree, - "cannot remove a source from another project", - Excluded.Location); + Excluded_Sources_Htable.Remove + (Project.Excluded, Source.File); end if; - -- We used to exit here, but in fact when a source is - -- overridden in an extended project we have only marked the - -- original source file if we stop here, not the one from - -- the extended project. - -- ??? We could exit (and thus be faster) if the loop could - -- be done only on the current project, but this isn't - -- compatible with the way gprbuild works with excluded - -- sources apparently - - -- exit; - end if; + Next (Iter); + end loop; - Next (Iter); + Proj := Proj.Extends; end loop; + end if; - OK := OK or Excluded.Found; + -- If we have any excluded element left, that means we did not find + -- the source file + + Excluded := Excluded_Sources_Htable.Get_First (Project.Excluded); + while Excluded /= No_File_Found loop + if not Excluded.Found then + + -- Check if the file belongs to another imported project to + -- provide a better error message. + + Src := Find_Source + (In_Tree => Data.Tree, + Project => Project.Project, + In_Imported_Only => True, + Base_Name => Excluded.File); - if not OK then Err_Vars.Error_Msg_File_1 := Excluded.File; - Error_Msg - (Project, In_Tree, "unknown file {", Excluded.Location); + + if Src = No_Source then + Error_Msg + (Data.Flags, + "unknown file {", Excluded.Location, Project.Project); + else + Error_Msg + (Data.Flags, + "cannot remove a source from an imported project: {", + Excluded.Location, Project.Project); + end if; end if; - Excluded := Excluded_Sources_Htable.Get_Next; + Excluded := Excluded_Sources_Htable.Get_Next (Project.Excluded); end loop; end Mark_Excluded_Sources; - -------------------------------------------- - -- Process_Sources_In_Multi_Language_Mode -- - -------------------------------------------- + ------------------------ + -- Check_Object_Files -- + ------------------------ - procedure Process_Sources_In_Multi_Language_Mode is - Iter : Source_Iterator; + procedure Check_Object_Files is + Iter : Source_Iterator; + Src_Id : Source_Id; + Src_Ind : Source_File_Index; begin - -- Check that two sources of this project do not have the same object - -- file name. - - Check_Object_File_Names : declare - Src_Id : Source_Id; - Source_Name : File_Name_Type; - - procedure Check_Object (Src : Source_Id); - -- Check if object file name of the current source is already in - -- hash table Object_File_Names. If it is, report an error. If it - -- is not, put it there with the file name of the current source. - - ------------------ - -- Check_Object -- - ------------------ - - procedure Check_Object (Src : Source_Id) is - begin - Source_Name := Object_File_Names.Get (Src.Object); + Iter := For_Each_Source (Data.Tree); + loop + Src_Id := Prj.Element (Iter); + exit when Src_Id = No_Source; - if Source_Name /= No_File then - Error_Msg_File_1 := Src.File; - Error_Msg_File_2 := Source_Name; - Error_Msg - (Project, - In_Tree, - "{ and { have the same object file name", - No_Location); + if Is_Compilable (Src_Id) + and then Src_Id.Language.Config.Object_Generated + and then Is_Extending (Project.Project, Src_Id.Project) + then + if Src_Id.Unit = No_Unit_Index then + if Src_Id.Kind = Impl then + Check_Object (Src_Id); + end if; else - Object_File_Names.Set (Src.Object, Src.File); - end if; - end Check_Object; - - -- Start of processing for Check_Object_File_Names - - begin - Object_File_Names.Reset; - Iter := For_Each_Source (In_Tree); - loop - Src_Id := Prj.Element (Iter); - exit when Src_Id = No_Source; + case Src_Id.Kind is + when Spec => + if Other_Part (Src_Id) = No_Source then + Check_Object (Src_Id); + end if; - if Is_Compilable (Src_Id) - and then Src_Id.Language.Config.Object_Generated - and then Is_Extending (Project, Src_Id.Project) - then - if Src_Id.Unit = No_Unit_Index then - if Src_Id.Kind = Impl then - Check_Object (Src_Id); - end if; + when Sep => + null; - else - case Src_Id.Kind is - when Spec => - if Other_Part (Src_Id) = No_Source then - Check_Object (Src_Id); - end if; + when Impl => + if Other_Part (Src_Id) /= No_Source then + Check_Object (Src_Id); - when Sep => - null; + else + -- Check if it is a subunit - when Impl => - if Other_Part (Src_Id) /= No_Source then - Check_Object (Src_Id); + Src_Ind := + Sinput.P.Load_Project_File + (Get_Name_String (Src_Id.Path.Name)); + if Sinput.P.Source_File_Is_Subunit (Src_Ind) then + Override_Kind (Src_Id, Sep); else - -- Check if it is a subunit - - declare - Src_Ind : constant Source_File_Index := - Sinput.P.Load_Project_File - (Get_Name_String - (Src_Id.Path.Name)); - begin - if Sinput.P.Source_File_Is_Subunit - (Src_Ind) - then - Override_Kind (Src_Id, Sep); - else - Check_Object (Src_Id); - end if; - end; + Check_Object (Src_Id); end if; - end case; - end if; + end if; + end case; end if; + end if; - Next (Iter); - end loop; - end Check_Object_File_Names; - end Process_Sources_In_Multi_Language_Mode; + Next (Iter); + end loop; + end Check_Object_Files; -- Start of processing for Look_For_Sources begin - Source_Names.Reset; - Find_Excluded_Sources (Project, In_Tree); - - if (Get_Mode = Ada_Only and then Is_A_Language (Project, Name_Ada)) - or else (Get_Mode = Multi_Language - and then Project.Languages /= No_Language_Index) - then - if Get_Mode = Multi_Language then - Load_Naming_Exceptions (Project, In_Tree); - end if; + Find_Excluded_Sources (Project, Data); - Find_Sources (Project, In_Tree, Proc_Data, Allow_Duplicate_Basenames); + if Project.Project.Languages /= No_Language_Index then + Load_Naming_Exceptions (Project, Data); + Find_Sources (Project, Data); Mark_Excluded_Sources; - - if Get_Mode = Multi_Language then - Process_Sources_In_Multi_Language_Mode; - end if; + Check_Object_Files; end if; + + Object_File_Names_Htable.Reset (Object_Files); end Look_For_Sources; ------------------ @@ -7999,280 +7130,6 @@ package body Prj.Nmsc is end if; end Path_Name_Of; - ----------------------------------- - -- Prepare_Ada_Naming_Exceptions -- - ----------------------------------- - - procedure Prepare_Ada_Naming_Exceptions - (List : Array_Element_Id; - In_Tree : Project_Tree_Ref; - Kind : Spec_Or_Body) - is - Current : Array_Element_Id; - Element : Array_Element; - Unit : Unit_Info; - - begin - -- Traverse the list - - Current := List; - while Current /= No_Array_Element loop - Element := In_Tree.Array_Elements.Table (Current); - - if Element.Index /= No_Name then - Unit := - (Kind => Kind, - Unit => Element.Index, - Next => No_Ada_Naming_Exception); - Reverse_Ada_Naming_Exceptions.Set - (Unit, (Element.Value.Value, Element.Value.Index)); - Unit.Next := - Ada_Naming_Exceptions.Get (File_Name_Type (Element.Value.Value)); - Ada_Naming_Exception_Table.Increment_Last; - Ada_Naming_Exception_Table.Table - (Ada_Naming_Exception_Table.Last) := Unit; - Ada_Naming_Exceptions.Set - (File_Name_Type (Element.Value.Value), - Ada_Naming_Exception_Table.Last); - end if; - - Current := Element.Next; - end loop; - end Prepare_Ada_Naming_Exceptions; - - ----------------------- - -- Record_Ada_Source -- - ----------------------- - - procedure Record_Ada_Source - (File_Name : File_Name_Type; - Path_Name : Path_Name_Type; - Project : Project_Id; - In_Tree : Project_Tree_Ref; - Proc_Data : in out Processing_Data; - Ada_Language : Language_Ptr; - Location : Source_Ptr; - Source_Recorded : in out Boolean) - is - Canonical_File : File_Name_Type; - Canonical_Path : Path_Name_Type; - - File_Recorded : Boolean := False; - -- True when at least one file has been recorded - - procedure Record_Unit - (Unit_Name : Name_Id; - Unit_Ind : Int := 0; - Unit_Kind : Spec_Or_Body; - Needs_Pragma : Boolean); - -- Register of the units contained in the source file (there is in - -- general a single such unit except when exceptions to the naming - -- scheme indicate there are several such units) - - ----------------- - -- Record_Unit -- - ----------------- - - procedure Record_Unit - (Unit_Name : Name_Id; - Unit_Ind : Int := 0; - Unit_Kind : Spec_Or_Body; - Needs_Pragma : Boolean) - is - UData : constant Unit_Index := - Units_Htable.Get (In_Tree.Units_HT, Unit_Name); - -- ??? Add_Source will look it up again, can we do that only once ? - - Source : Source_Id; - To_Record : Boolean := False; - The_Location : Source_Ptr := Location; - Unit_Prj : Project_Id; - - begin - if Current_Verbosity = High then - Write_Str (" Putting "); - Write_Str (Get_Name_String (Unit_Name)); - Write_Line (" in the unit list."); - end if; - - -- The unit is already in the list, but may be it is only the other - -- unit kind (spec or body), or what is in the unit list is a unit of - -- a project we are extending. - - if UData /= No_Unit_Index then - if UData.File_Names (Unit_Kind) = null - or else - (UData.File_Names (Unit_Kind).File = Canonical_File - and then UData.File_Names (Unit_Kind).Locally_Removed) - or else Is_Extending - (Project.Extends, UData.File_Names (Unit_Kind).Project) - then - To_Record := True; - - -- If the same file is already in the list, do not add it again - - elsif UData.File_Names (Unit_Kind).Project = Project - and then - (Project.Known_Order_Of_Source_Dirs - or else - UData.File_Names (Unit_Kind).Path.Name = Canonical_Path) - then - To_Record := False; - - -- Else, same unit but not same file => It is an error to have two - -- units with the same name and the same kind (spec or body). - - else - if The_Location = No_Location then - The_Location := Project.Location; - end if; - - Err_Vars.Error_Msg_Name_1 := Unit_Name; - Error_Msg - (Project, In_Tree, "duplicate unit %%", The_Location); - - Err_Vars.Error_Msg_Name_1 := - UData.File_Names (Unit_Kind).Project.Name; - Err_Vars.Error_Msg_File_1 := - File_Name_Type (UData.File_Names (Unit_Kind).Path.Name); - Error_Msg - (Project, In_Tree, "\ project file %%, {", The_Location); - - Err_Vars.Error_Msg_Name_1 := Project.Name; - Err_Vars.Error_Msg_File_1 := File_Name_Type (Canonical_Path); - Error_Msg - (Project, In_Tree, "\ project file %%, {", The_Location); - - To_Record := False; - end if; - - -- It is a new unit, create a new record - - else - -- First, check if there is no other unit with this file name in - -- another project. If it is, report error but note we do that - -- only for the first unit in the source file. - - Unit_Prj := Files_Htable.Get (Proc_Data.Units, Canonical_File); - - if not File_Recorded - and then Unit_Prj /= No_Project - then - Error_Msg_File_1 := File_Name; - Error_Msg_Name_1 := Unit_Prj.Name; - Error_Msg - (Project, In_Tree, - "{ is already a source of project %%", - Location); - - else - To_Record := True; - end if; - end if; - - if To_Record then - Files_Htable.Set (Proc_Data.Units, Canonical_File, Project); - Add_Source - (Id => Source, - In_Tree => In_Tree, - Project => Project, - Lang_Id => Ada_Language, - File_Name => Canonical_File, - Display_File => File_Name, - Unit => Unit_Name, - Path => (Canonical_Path, Path_Name), - Naming_Exception => Needs_Pragma, - Kind => Unit_Kind, - Index => Unit_Ind); - Source_Recorded := True; - end if; - end Record_Unit; - - Exception_Id : Ada_Naming_Exception_Id; - Unit_Name : Name_Id; - Unit_Kind : Spec_Or_Body; - Unit_Ind : Int := 0; - Info : Unit_Info; - Name_Index : Name_And_Index; - Except_Name : Name_And_Index := No_Name_And_Index; - Needs_Pragma : Boolean; - - begin - Canonical_File := Canonical_Case_File_Name (Name_Id (File_Name)); - Canonical_Path := - Path_Name_Type (Canonical_Case_File_Name (Name_Id (Path_Name))); - - -- Check the naming scheme to get extra file properties - - Get_Unit - (In_Tree => In_Tree, - Canonical_File_Name => Canonical_File, - Project => Project, - Exception_Id => Exception_Id, - Unit_Name => Unit_Name, - Unit_Kind => Unit_Kind); - - Needs_Pragma := Exception_Id /= No_Ada_Naming_Exception; - - if Exception_Id = No_Ada_Naming_Exception - and then Unit_Name = No_Name - then - if Current_Verbosity = High then - Write_Str (" """); - Write_Str (Get_Name_String (Canonical_File)); - Write_Line (""" is not a valid source file name (ignored)."); - end if; - return; - end if; - - -- Check to see if the source has been hidden by an exception, - -- but only if it is not an exception. - - if not Needs_Pragma then - Except_Name := - Reverse_Ada_Naming_Exceptions.Get - ((Unit_Kind, Unit_Name, No_Ada_Naming_Exception)); - - if Except_Name /= No_Name_And_Index then - if Current_Verbosity = High then - Write_Str (" """); - Write_Str (Get_Name_String (Canonical_File)); - Write_Str (""" contains a unit that is found in """); - Write_Str (Get_Name_String (Except_Name.Name)); - Write_Line (""" (ignored)."); - end if; - - -- The file is not included in the source of the project since it - -- is hidden by the exception. So, nothing else to do. - - return; - end if; - end if; - - -- The following loop registers the unit in the appropriate table. It - -- will be executed multiple times when the file is a multi-unit file, - -- in which case Exception_Id initially points to the first file and - -- then to each other unit in the file. - - loop - if Exception_Id /= No_Ada_Naming_Exception then - Info := Ada_Naming_Exception_Table.Table (Exception_Id); - Exception_Id := Info.Next; - Info.Next := No_Ada_Naming_Exception; - Name_Index := Reverse_Ada_Naming_Exceptions.Get (Info); - - Unit_Name := Info.Unit; - Unit_Ind := Name_Index.Index; - Unit_Kind := Info.Kind; - end if; - - Record_Unit (Unit_Name, Unit_Ind, Unit_Kind, Needs_Pragma); - File_Recorded := True; - - exit when Exception_Id = No_Ada_Naming_Exception; - end loop; - end Record_Ada_Source; - ------------------- -- Remove_Source -- ------------------- @@ -8286,7 +7143,7 @@ package body Prj.Nmsc is begin if Current_Verbosity = High then Write_Str ("Removing source "); - Write_Line (Get_Name_String (Id.File)); + Write_Line (Get_Name_String (Id.File) & " at" & Id.Index'Img); end if; if Replaced_By /= No_Source then @@ -8325,12 +7182,12 @@ package body Prj.Nmsc is procedure Report_No_Sources (Project : Project_Id; Lang_Name : String; - In_Tree : Project_Tree_Ref; + Data : Tree_Processing_Data; Location : Source_Ptr; Continuation : Boolean := False) is begin - case When_No_Sources is + case Data.Flags.When_No_Sources is when Silent => null; @@ -8342,12 +7199,12 @@ package body Prj.Nmsc is " sources in this project"; begin - Error_Msg_Warn := When_No_Sources = Warning; + Error_Msg_Warn := Data.Flags.When_No_Sources = Warning; if Continuation then - Error_Msg (Project, In_Tree, "\" & Msg, Location); + Error_Msg (Data.Flags, "\" & Msg, Location, Project); else - Error_Msg (Project, In_Tree, Msg, Location); + Error_Msg (Data.Flags, Msg, Location, Project); end if; end; end case; @@ -8378,71 +7235,48 @@ package body Prj.Nmsc is Write_Line ("end Source_Dirs."); end Show_Source_Dirs; - ------------------------- - -- Warn_If_Not_Sources -- - ------------------------- - - -- comments needed in this body ??? + --------------------------- + -- Process_Naming_Scheme -- + --------------------------- - procedure Warn_If_Not_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Conventions : Array_Element_Id; - Specs : Boolean; - Extending : Boolean) + procedure Process_Naming_Scheme + (Tree : Project_Tree_Ref; + Root_Project : Project_Id; + Flags : Processing_Flags) is - Conv : Array_Element_Id; - Unit : Name_Id; - The_Unit_Data : Unit_Index; - Location : Source_Ptr; - - begin - Conv := Conventions; - while Conv /= No_Array_Element loop - Unit := In_Tree.Array_Elements.Table (Conv).Index; - Error_Msg_Name_1 := Unit; - Get_Name_String (Unit); - To_Lower (Name_Buffer (1 .. Name_Len)); - Unit := Name_Find; - The_Unit_Data := Units_Htable.Get (In_Tree.Units_HT, Unit); - Location := In_Tree.Array_Elements.Table (Conv).Value.Location; - - if The_Unit_Data = No_Unit_Index then - Error_Msg (Project, In_Tree, "?unknown unit %%", Location); + procedure Recursive_Check + (Project : Project_Id; + Data : in out Tree_Processing_Data); + -- Check_Naming_Scheme for the project + + --------------------- + -- Recursive_Check -- + --------------------- + + procedure Recursive_Check + (Project : Project_Id; + Data : in out Tree_Processing_Data) + is + begin + if Verbose_Mode then + Write_Str ("Processing_Naming_Scheme for project """); + Write_Str (Get_Name_String (Project.Name)); + Write_Line (""""); + end if; - else - Error_Msg_Name_2 := - In_Tree.Array_Elements.Table (Conv).Value.Value; + Prj.Nmsc.Check (Project, Data); + end Recursive_Check; - if Specs then - if not Check_Project - (The_Unit_Data.File_Names (Spec).Project, - Project, Extending) - then - Error_Msg - (Project, In_Tree, - "?source of spec of unit %% (%%)" & - " not found in this project", - Location); - end if; + procedure Check_All_Projects is new + For_Every_Project_Imported (Tree_Processing_Data, Recursive_Check); - else - if The_Unit_Data.File_Names (Impl) = null - or else not Check_Project - (The_Unit_Data.File_Names (Impl).Project, - Project, Extending) - then - Error_Msg - (Project, In_Tree, - "?source of body of unit %% (%%)" & - " not found in this project", - Location); - end if; - end if; - end if; + Data : Tree_Processing_Data; - Conv := In_Tree.Array_Elements.Table (Conv).Next; - end loop; - end Warn_If_Not_Sources; + -- Start of processing for Process_Naming_Scheme + begin + Initialize (Data, Tree => Tree, Flags => Flags); + Check_All_Projects (Root_Project, Data, Imported_First => True); + Free (Data); + end Process_Naming_Scheme; end Prj.Nmsc; diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads index f0f2ee5d4c2..eec6289e503 100644 --- a/gcc/ada/prj-nmsc.ads +++ b/gcc/ada/prj-nmsc.ads @@ -23,66 +23,21 @@ -- -- ------------------------------------------------------------------------------ --- Perform various checks on a project and find all its source files +-- Find source dirs and source files for a project private package Prj.Nmsc is - type Processing_Data is private; - -- Temporary data which is needed while parsing a project. It does not need - -- to be kept in memory once a project has been fully loaded, but is - -- necessary while performing consistency checks (duplicate sources,...) - -- This data must be initialized before processing any project, and the - -- same data is used for processing all projects in the tree. + procedure Process_Naming_Scheme + (Tree : Project_Tree_Ref; + Root_Project : Project_Id; + Flags : Processing_Flags); + -- Perform consistency and semantic checks on all the projects in the tree. + -- This procedure interprets the various case statements in the project + -- based on the current environment variables (the "scenario"). After + -- checking the validity of the naming scheme, it searches for all the + -- source files of the project. The result of this procedure is a filled-in + -- data structure for Project_Id which contains all the information about + -- the project. This information is only valid while the scenario variables + -- are preserved. - procedure Initialize (Proc_Data : in out Processing_Data); - -- Initialize Proc_Data - - procedure Free (Proc_Data : in out Processing_Data); - -- Free the memory occupied by Proc_Data - - procedure Check - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Report_Error : Put_Line_Access; - When_No_Sources : Error_Warning; - Current_Dir : String; - Proc_Data : in out Processing_Data; - Is_Config_File : Boolean; - Compiler_Driver_Mandatory : Boolean; - Allow_Duplicate_Basenames : Boolean); - -- Perform consistency and semantic checks on a project, starting from the - -- project tree parsed from the .gpr file. This procedure interprets the - -- various case statements in the project based on the current environment - -- variables (the "scenario"). After checking the validity of the naming - -- scheme, it searches for all the source files of the project. The result - -- of this procedure is a filled-in data structure for Project_Id which - -- contains all the information about the project. This information is only - -- valid while the scenario variables are preserved. If the current mode - -- is Ada_Only, this procedure will only search Ada sources, but in multi- - -- language mode it will look for sources for all supported languages. - -- - -- If Report_Error is null, use the standard error reporting mechanism - -- (Errout). Otherwise, report errors using Report_Error. - -- - -- Current_Dir is for optimization purposes only, avoiding system calls to - -- query it. - -- - -- When_No_Sources indicates what should be done when no sources of a - -- language are found in a project where this language is declared. - -- - -- Is_Config_File should be True if Project is config file (.cgpr) - -- - -- If Compiler_Driver_Mandatory is true, then a Compiler.Driver attribute - -- for each language must be defined, or we will not look for its source - -- files. - -- - -- If Allow_Duplicate_Basenames, then files with the same base names are - -- authorized within a project for source-based languages (never for unit - -- based languages) - -private - type Processing_Data is record - Units : Files_Htable.Instance; - -- Mapping from file base name to the project containing the file - end record; end Prj.Nmsc; diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb index 92010bf7cfa..bacbf8d7f87 100644 --- a/gcc/ada/prj-pars.adb +++ b/gcc/ada/prj-pars.adb @@ -27,9 +27,9 @@ with Ada.Exceptions; use Ada.Exceptions; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with Output; use Output; +with Prj.Conf; use Prj.Conf; with Prj.Err; use Prj.Err; with Prj.Part; -with Prj.Proc; with Prj.Tree; use Prj.Tree; with Sinput.P; @@ -44,17 +44,16 @@ package body Prj.Pars is Project : out Project_Id; Project_File_Name : String; Packages_To_Check : String_List_Access := All_Packages; - When_No_Sources : Error_Warning := Error; - Report_Error : Put_Line_Access := null; - Reset_Tree : Boolean := True; - Is_Config_File : Boolean := False) + Flags : Processing_Flags; + Reset_Tree : Boolean := True) is Project_Node : Project_Node_Id := Empty_Node; The_Project : Project_Id := No_Project; Success : Boolean := True; Current_Dir : constant String := Get_Current_Dir; Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; - + Automatically_Generated : Boolean; + Config_File_Path : String_Access; begin Project_Node_Tree := new Project_Node_Tree_Data; Prj.Tree.Initialize (Project_Node_Tree); @@ -69,22 +68,40 @@ package body Prj.Pars is Always_Errout_Finalize => False, Packages_To_Check => Packages_To_Check, Current_Directory => Current_Dir, - Is_Config_File => Is_Config_File); + Flags => Flags, + Is_Config_File => False); -- If there were no error, process the tree if Project_Node /= Empty_Node then - Prj.Proc.Process - (In_Tree => In_Tree, - Project => The_Project, - Success => Success, - From_Project_Node => Project_Node, - From_Project_Node_Tree => Project_Node_Tree, - Report_Error => Report_Error, - Reset_Tree => Reset_Tree, - When_No_Sources => When_No_Sources, - Current_Dir => Current_Dir, - Is_Config_File => Is_Config_File); + begin + -- No config file should be read from the disk for gnatmake. + -- However, we will simulate one that only contains the + -- default GNAT naming scheme. + + Process_Project_And_Apply_Config + (Main_Project => The_Project, + User_Project_Node => Project_Node, + Config_File_Name => "", + Autoconf_Specified => False, + Project_Tree => In_Tree, + Project_Node_Tree => Project_Node_Tree, + Packages_To_Check => null, + Allow_Automatic_Generation => False, + Automatically_Generated => Automatically_Generated, + Config_File_Path => Config_File_Path, + Flags => Flags, + Normalized_Hostname => "", + On_Load_Config => + Add_Default_GNAT_Naming_Scheme'Access, + Reset_Tree => Reset_Tree); + + Success := The_Project /= No_Project; + + exception + when Invalid_Config => + Success := False; + end; Prj.Err.Finalize; diff --git a/gcc/ada/prj-pars.ads b/gcc/ada/prj-pars.ads index 2c439ad115f..01caff93c19 100644 --- a/gcc/ada/prj-pars.ads +++ b/gcc/ada/prj-pars.ads @@ -35,10 +35,8 @@ package Prj.Pars is Project : out Project_Id; Project_File_Name : String; Packages_To_Check : String_List_Access := All_Packages; - When_No_Sources : Error_Warning := Error; - Report_Error : Prj.Put_Line_Access := null; - Reset_Tree : Boolean := True; - Is_Config_File : Boolean := False); + Flags : Processing_Flags; + Reset_Tree : Boolean := True); -- Parse and process a project files and all its imported project files, in -- the project tree In_Tree. -- All the project files are parsed (through Prj.Tree) to create a tree in @@ -57,13 +55,7 @@ package Prj.Pars is -- produces an error. For other packages, an unknown attribute produces a -- warning. -- - -- When_No_Sources indicates what should be done when no sources are found - -- in a project for a specified or implied language. - -- -- When Reset_Tree is True, all the project data are removed from the -- project table before processing. - -- - -- Is_Config_File should be set to True if the project represents a config - -- file (.cgpr) since some specific checks apply. end Prj.Pars; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 6582e6b8183..8a0f6a52c15 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -165,7 +165,8 @@ package body Prj.Part is Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; - Is_Config_File : Boolean); + Is_Config_File : Boolean; + Flags : Processing_Flags); -- Parse a project file. This is a recursive procedure: it calls itself for -- imported and extended projects. When From_Extended is not None, if the -- project has already been parsed and is an extended project A, return the @@ -179,7 +180,8 @@ package body Prj.Part is procedure Pre_Parse_Context_Clause (In_Tree : Project_Node_Tree_Ref; Context_Clause : out With_Id; - Is_Config_File : Boolean); + Is_Config_File : Boolean; + Flags : Processing_Flags); -- Parse the context clause of a project. Store the paths and locations of -- the imported projects in table Withs. Does nothing if there is no -- context clause (if the current token is not "with" or "limited" followed @@ -198,7 +200,8 @@ package body Prj.Part is Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; - Is_Config_File : Boolean); + Is_Config_File : Boolean; + Flags : Processing_Flags); -- Parse the imported projects that have been stored in table Withs, if -- any. From_Extended is used for the call to Parse_Single_Project below. -- When In_Limited is True, the importing path includes at least one @@ -214,12 +217,6 @@ package body Prj.Part is -- Returns the path name of a project file. Returns an empty string -- if project file cannot be found. - function Immediate_Directory_Of - (Path_Name : Path_Name_Type) return Path_Name_Type; - -- Get the directory of the file with the specified path name. - -- This includes the directory separator as the last character. - -- Returns "./" if Path_Name contains no directory separator. - function Project_Name_From (Path_Name : String; Is_Config_File : Boolean) return Name_Id; @@ -249,10 +246,6 @@ package body Prj.Part is -- Fake path name of the virtual extending project. The directory is -- the same directory as the extending all project. - Virtual_Dir_Id : constant Path_Name_Type := - Immediate_Directory_Of (Path_Name_Of (Main_Project, In_Tree)); - -- The directory of the extending all project - -- The source of the virtual extending project is something like: -- project V$<project name> extends <project path> is @@ -266,15 +259,11 @@ package body Prj.Part is -- Nodes that made up the virtual extending project - Virtual_Project : constant Project_Node_Id := - Default_Project_Node - (In_Tree, N_Project); + Virtual_Project : Project_Node_Id; With_Clause : constant Project_Node_Id := Default_Project_Node (In_Tree, N_With_Clause); - Project_Declaration : constant Project_Node_Id := - Default_Project_Node - (In_Tree, N_Project_Declaration); + Project_Declaration : Project_Node_Id; Source_Dirs_Declaration : constant Project_Node_Id := Default_Project_Node (In_Tree, N_Declarative_Item); @@ -292,12 +281,6 @@ package body Prj.Part is (In_Tree, N_Literal_String_List, List); begin - -- Get the virtual name id - - Name_Len := Virtual_Name'Length; - Name_Buffer (1 .. Name_Len) := Virtual_Name; - Virtual_Name_Id := Name_Find; - -- Get the virtual path name Get_Name_String (Path_Name_Of (Main_Project, In_Tree)); @@ -314,6 +297,20 @@ package body Prj.Part is Name_Len := Name_Len + Virtual_Name'Length; Virtual_Path_Id := Name_Find; + -- Get the virtual name id + + Name_Len := Virtual_Name'Length; + Name_Buffer (1 .. Name_Len) := Virtual_Name; + Virtual_Name_Id := Name_Find; + + Virtual_Project := Create_Project + (In_Tree => In_Tree, + Name => Virtual_Name_Id, + Full_Path => Virtual_Path_Id, + Is_Config_File => False); + + Project_Declaration := Project_Declaration_Of (Virtual_Project, In_Tree); + -- With clause Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id); @@ -325,13 +322,8 @@ package body Prj.Part is -- Virtual project node - Set_Name_Of (Virtual_Project, In_Tree, Virtual_Name_Id); - Set_Path_Name_Of (Virtual_Project, In_Tree, Virtual_Path_Id); Set_Location_Of (Virtual_Project, In_Tree, Location_Of (Main_Project, In_Tree)); - Set_Directory_Of (Virtual_Project, In_Tree, Virtual_Dir_Id); - Set_Project_Declaration_Of - (Virtual_Project, In_Tree, Project_Declaration); Set_Extended_Project_Path_Of (Virtual_Project, In_Tree, Path_Name_Of (For_Project, In_Tree)); @@ -361,54 +353,8 @@ package body Prj.Part is Set_Current_Term (Source_Dirs_Term, In_Tree, Source_Dirs_List); -- Source_Dirs empty list: nothing to do - - -- Put virtual project into Projects_Htable - - Prj.Tree.Tree_Private_Part.Projects_Htable.Set - (T => In_Tree.Projects_HT, - K => Virtual_Name_Id, - E => (Name => Virtual_Name_Id, - Node => Virtual_Project, - Canonical_Path => No_Path, - Extended => False, - Proj_Qualifier => Unspecified)); end Create_Virtual_Extending_Project; - ---------------------------- - -- Immediate_Directory_Of -- - ---------------------------- - - function Immediate_Directory_Of - (Path_Name : Path_Name_Type) return Path_Name_Type - is - begin - Get_Name_String (Path_Name); - - for Index in reverse 1 .. Name_Len loop - if Name_Buffer (Index) = '/' - or else Name_Buffer (Index) = Dir_Sep - then - -- Remove all chars after last directory separator from name - - if Index > 1 then - Name_Len := Index - 1; - - else - Name_Len := Index; - end if; - - return Name_Find; - end if; - end loop; - - -- There is no directory separator in name. Return "./" or ".\" - - Name_Len := 2; - Name_Buffer (1) := '.'; - Name_Buffer (2) := Dir_Sep; - return Name_Find; - end Immediate_Directory_Of; - ----------------------------------- -- Look_For_Virtual_Projects_For -- ----------------------------------- @@ -488,7 +434,8 @@ package body Prj.Part is Packages_To_Check : String_List_Access := All_Packages; Store_Comments : Boolean := False; Current_Directory : String := ""; - Is_Config_File : Boolean) + Is_Config_File : Boolean; + Flags : Processing_Flags) is Dummy : Boolean; pragma Warnings (Off, Dummy); @@ -547,7 +494,8 @@ package body Prj.Part is Packages_To_Check => Packages_To_Check, Depth => 0, Current_Dir => Current_Directory, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); -- If Project is an extending-all project, create the eventual -- virtual extending projects and check that there are no illegally @@ -657,7 +605,8 @@ package body Prj.Part is procedure Pre_Parse_Context_Clause (In_Tree : Project_Node_Tree_Ref; Context_Clause : out With_Id; - Is_Config_File : Boolean) + Is_Config_File : Boolean; + Flags : Processing_Flags) is Current_With_Clause : With_Id := No_With; Limited_With : Boolean := False; @@ -680,7 +629,8 @@ package body Prj.Part is if Is_Config_File then Error_Msg - ("configuration project cannot import " & + (Flags, + "configuration project cannot import " & "other configuration projects", Token_Ptr); end if; @@ -737,7 +687,7 @@ package body Prj.Part is Set_Is_Not_Last_In_List (Current_With_Node, In_Tree); else - Error_Msg ("expected comma or semi colon", Token_Ptr); + Error_Msg (Flags, "expected comma or semi colon", Token_Ptr); exit Comma_Loop; end if; @@ -763,7 +713,8 @@ package body Prj.Part is Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; - Is_Config_File : Boolean) + Is_Config_File : Boolean; + Flags : Processing_Flags) is Current_With_Clause : With_Id := Context_Clause; @@ -820,7 +771,7 @@ package body Prj.Part is Error_Msg_File_1 := File_Name_Type (Current_With.Path); Error_Msg - ("unknown project file: {", Current_With.Location); + (Flags, "unknown project file: {", Current_With.Location); -- If this is not imported by the main project file, display -- the import path. @@ -831,7 +782,7 @@ package body Prj.Part is File_Name_Type (Project_Stack.Table (Index).Path_Name); Error_Msg - ("\imported by {", Current_With.Location); + (Flags, "\imported by {", Current_With.Location); end loop; end if; @@ -903,7 +854,8 @@ package body Prj.Part is Packages_To_Check => Packages_To_Check, Depth => Depth, Current_Dir => Current_Dir, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); else Extends_All := Is_Extending_All (Withed_Project, In_Tree); @@ -965,7 +917,8 @@ package body Prj.Part is Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; - Is_Config_File : Boolean) + Is_Config_File : Boolean; + Flags : Processing_Flags) is Normed_Path_Name : Path_Name_Type; Canonical_Path_Name : Path_Name_Type; @@ -1028,9 +981,9 @@ package body Prj.Part is if Canonical_Path_Name = Project_Stack.Table (Index).Canonical_Path_Name then - Error_Msg ("circular dependency detected", Token_Ptr); + Error_Msg (Flags, "circular dependency detected", Token_Ptr); Error_Msg_Name_1 := Name_Id (Normed_Path_Name); - Error_Msg ("\ %% is imported by", Token_Ptr); + Error_Msg (Flags, "\ %% is imported by", Token_Ptr); for Current in reverse 1 .. Project_Stack.Last loop Error_Msg_Name_1 := @@ -1040,10 +993,10 @@ package body Prj.Part is Canonical_Path_Name then Error_Msg - ("\ %% which itself is imported by", Token_Ptr); + (Flags, "\ %% which itself is imported by", Token_Ptr); else - Error_Msg ("\ %%", Token_Ptr); + Error_Msg (Flags, "\ %%", Token_Ptr); exit; end if; end loop; @@ -1072,12 +1025,14 @@ package body Prj.Part is if A_Project_Name_And_Node.Extended then if A_Project_Name_And_Node.Proj_Qualifier /= Dry then Error_Msg - ("cannot extend the same project file several times", + (Flags, + "cannot extend the same project file several times", Token_Ptr); end if; else Error_Msg - ("cannot extend an already imported project file", + (Flags, + "cannot extend an already imported project file", Token_Ptr); end if; @@ -1117,7 +1072,8 @@ package body Prj.Part is end; else Error_Msg - ("cannot import an already extended project file", + (Flags, + "cannot import an already extended project file", Token_Ptr); end if; end if; @@ -1156,7 +1112,8 @@ package body Prj.Part is -- following Ada identifier's syntax). Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name); - Error_Msg ("?{ is not a valid path name for a project file", + Error_Msg (Flags, + "?{ is not a valid path name for a project file", Token_Ptr); end if; @@ -1167,14 +1124,16 @@ package body Prj.Part is Write_Eol; end if; - Project_Directory := Immediate_Directory_Of (Normed_Path_Name); + Project_Directory := + Path_Name_Type (Get_Directory (File_Name_Type (Normed_Path_Name))); -- Is there any imported project? Pre_Parse_Context_Clause (In_Tree => In_Tree, Is_Config_File => Is_Config_File, - Context_Clause => First_With); + Context_Clause => First_With, + Flags => Flags); Project := Default_Project_Node (Of_Kind => N_Project, In_Tree => In_Tree); @@ -1213,9 +1172,11 @@ package body Prj.Part is when Snames.Name_Configuration => if not Is_Config_File then - Error_Msg ("configuration projects cannot belong to a user" & - " project tree", - Token_Ptr); + Error_Msg + (Flags, + "configuration projects cannot belong to a user" & + " project tree", + Token_Ptr); end if; Proj_Qualifier := Configuration; @@ -1239,7 +1200,8 @@ package body Prj.Part is if Is_Config_File and then Proj_Qualifier /= Configuration then - Error_Msg ("a configuration project cannot be qualified except " & + Error_Msg (Flags, + "a configuration project cannot be qualified except " & "as configuration project", Qualifier_Location); end if; @@ -1298,7 +1260,8 @@ package body Prj.Part is if Is_Config_File then Error_Msg - ("extending configuration project not allowed", Token_Ptr); + (Flags, + "extending configuration project not allowed", Token_Ptr); end if; -- Make sure that gnatmake will use mapping files @@ -1362,9 +1325,11 @@ package body Prj.Part is Extension := new String'(Project_File_Extension); end if; - Error_Msg ("?file name does not match project name, " & - "should be `%%" & Extension.all & "`", - Token_Ptr); + Error_Msg + (Flags, + "?file name does not match project name, should be `%%" + & Extension.all & "`", + Token_Ptr); end if; end; @@ -1395,7 +1360,8 @@ package body Prj.Part is Packages_To_Check => Packages_To_Check, Depth => Depth + 1, Current_Dir => Current_Dir, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); end; @@ -1424,12 +1390,12 @@ package body Prj.Part is Duplicated := True; Error_Msg_Name_1 := Project_Name; Error_Msg - ("duplicate project name %%", + (Flags, "duplicate project name %%", Location_Of (Project, In_Tree)); Error_Msg_Name_1 := Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree)); Error_Msg - ("\already in %%", Location_Of (Project, In_Tree)); + (Flags, "\already in %%", Location_Of (Project, In_Tree)); end if; end; end if; @@ -1462,7 +1428,7 @@ package body Prj.Part is Error_Msg_Name_1 := Token_Name; - Error_Msg ("unknown project file: %%", Token_Ptr); + Error_Msg (Flags, "unknown project file: %%", Token_Ptr); -- If we are not in the main project file, display the -- import path. @@ -1471,13 +1437,13 @@ package body Prj.Part is Error_Msg_Name_1 := Name_Id (Project_Stack.Table (Project_Stack.Last).Path_Name); - Error_Msg ("\extended by %%", Token_Ptr); + Error_Msg (Flags, "\extended by %%", Token_Ptr); for Index in reverse 1 .. Project_Stack.Last - 1 loop Error_Msg_Name_1 := Name_Id (Project_Stack.Table (Index).Path_Name); - Error_Msg ("\imported by %%", Token_Ptr); + Error_Msg (Flags, "\imported by %%", Token_Ptr); end loop; end if; @@ -1501,7 +1467,8 @@ package body Prj.Part is Packages_To_Check => Packages_To_Check, Depth => Depth + 1, Current_Dir => Current_Dir, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); end; if Present (Extended_Project) then @@ -1522,7 +1489,7 @@ package body Prj.Part is Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry then Error_Msg - ("an abstract project can only extend " & + (Flags, "an abstract project can only extend " & "another abstract project", Qualifier_Location); end if; @@ -1550,7 +1517,7 @@ package body Prj.Part is if Is_Extending_All (With_Clause, In_Tree) then Error_Msg_Name_1 := Name_Of (Imported, In_Tree); - Error_Msg ("cannot import extending-all project %%", + Error_Msg (Flags, "cannot import extending-all project %%", Token_Ptr); exit With_Clause_Loop; end if; @@ -1615,7 +1582,8 @@ package body Prj.Part is Error_Msg_Name_1 := Name_Of_Project; Error_Msg_Name_2 := Parent_Name; - Error_Msg ("project %% does not import or extend project %%", + Error_Msg (Flags, + "project %% does not import or extend project %%", Location_Of (Project, In_Tree)); end if; end; @@ -1638,7 +1606,8 @@ package body Prj.Part is Current_Project => Project, Extends => Extended_Project, Packages_To_Check => Packages_To_Check, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration); if Present (Extended_Project) @@ -1697,7 +1666,7 @@ package body Prj.Part is then -- Invalid name: report an error - Error_Msg ("expected """ & + Error_Msg (Flags, "expected """ & Get_Name_String (Name_Of (Project, In_Tree)) & """", Token_Ptr); end if; @@ -1714,7 +1683,7 @@ package body Prj.Part is if Token /= Tok_EOF then Error_Msg - ("unexpected text following end of project", Token_Ptr); + (Flags, "unexpected text following end of project", Token_Ptr); end if; end if; @@ -1760,7 +1729,8 @@ package body Prj.Part is Packages_To_Check => Packages_To_Check, Depth => Depth + 1, Current_Dir => Current_Dir, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File, + Flags => Flags); Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); end; diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads index 3906ad7cb61..4e9acee9d9e 100644 --- a/gcc/ada/prj-part.ads +++ b/gcc/ada/prj-part.ads @@ -37,7 +37,8 @@ package Prj.Part is Packages_To_Check : String_List_Access := All_Packages; Store_Comments : Boolean := False; Current_Directory : String := ""; - Is_Config_File : Boolean); + Is_Config_File : Boolean; + Flags : Processing_Flags); -- Parse project file and all its imported project files and create a tree. -- Return the node for the project (or Empty_Node if parsing failed). If -- Always_Errout_Finalize is True, Errout.Finalize is called in all cases, diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 4c45642bf0d..7986a9b4774 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -39,8 +39,6 @@ with GNAT.HTable; package body Prj.Proc is - Error_Report : Put_Line_Access := null; - package Processed_Projects is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Project_Id, @@ -79,17 +77,12 @@ package body Prj.Proc is -- the package or project with declarations Decl. procedure Check - (In_Tree : Project_Tree_Ref; - Project : Project_Id; - Current_Dir : String; - When_No_Sources : Error_Warning; - Is_Config_File : Boolean; - Compiler_Driver_Mandatory : Boolean; - Allow_Duplicate_Basenames : Boolean); + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + Flags : Processing_Flags); -- Set all projects to not checked, then call Recursive_Check for the -- main project Project. Project is set to No_Project if errors occurred. -- Current_Dir is for optimization purposes, avoiding extra system calls. - -- Is_Config_File should be True if Project is a config file (.cgpr). -- If Allow_Duplicate_Basenames, then files with the same base names are -- authorized within a project for source-based languages (never for unit -- based languages) @@ -108,6 +101,7 @@ package body Prj.Proc is function Expression (Project : Project_Id; In_Tree : Project_Tree_Ref; + Flags : Processing_Flags; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Pkg : Package_Id; @@ -130,6 +124,7 @@ package body Prj.Proc is procedure Process_Declarative_Items (Project : Project_Id; In_Tree : Project_Tree_Ref; + Flags : Processing_Flags; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Pkg : Package_Id; @@ -141,6 +136,7 @@ package body Prj.Proc is procedure Recursive_Process (In_Tree : Project_Tree_Ref; Project : out Project_Id; + Flags : Processing_Flags; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Extended_By : Project_Id); @@ -151,22 +147,12 @@ package body Prj.Proc is -- extended project, if any. Then process the declarative items of the -- project. - type Recursive_Check_Data is record - In_Tree : Project_Tree_Ref; - Current_Dir : String_Access; - When_No_Sources : Error_Warning; - Proc_Data : Processing_Data; - Is_Config_File : Boolean; - Compiler_Driver_Mandatory : Boolean; - Allow_Duplicate_Basenames : Boolean; - end record; - -- Data passed to Recursive_Check - -- Current_Dir is for optimization purposes, avoiding extra system calls. - - procedure Recursive_Check - (Project : Project_Id; - Data : in out Recursive_Check_Data); - -- Check_Naming_Scheme for the project + function Get_Attribute_Index + (Tree : Project_Node_Tree_Ref; + Attr : Project_Node_Id; + Index : Name_Id) return Name_Id; + -- Copy the index of the attribute into Name_Buffer, converting to lower + -- case if the attribute is case-insensitive. --------- -- Add -- @@ -285,32 +271,12 @@ package body Prj.Proc is ----------- procedure Check - (In_Tree : Project_Tree_Ref; - Project : Project_Id; - Current_Dir : String; - When_No_Sources : Error_Warning; - Is_Config_File : Boolean; - Compiler_Driver_Mandatory : Boolean; - Allow_Duplicate_Basenames : Boolean) + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + Flags : Processing_Flags) is - Dir : aliased String := Current_Dir; - - procedure Check_All_Projects is new - For_Every_Project_Imported (Recursive_Check_Data, Recursive_Check); - - Data : Recursive_Check_Data; - begin - Data.In_Tree := In_Tree; - Data.Current_Dir := Dir'Unchecked_Access; - Data.When_No_Sources := When_No_Sources; - Data.Is_Config_File := Is_Config_File; - Data.Compiler_Driver_Mandatory := Compiler_Driver_Mandatory; - Data.Allow_Duplicate_Basenames := Allow_Duplicate_Basenames; - - Initialize (Data.Proc_Data); - - Check_All_Projects (Project, Data, Imported_First => True); + Process_Naming_Scheme (In_Tree, Project, Flags); -- Set the Other_Part field for the units @@ -334,7 +300,6 @@ package body Prj.Proc is if Source2 = No_Source then Unit_Htable.Set (K => Name, E => Source1); - else Unit_Htable.Remove (Name); end if; @@ -343,8 +308,6 @@ package body Prj.Proc is Next (Iter); end loop; end; - - Free (Data.Proc_Data); end Check; ------------------------------- @@ -398,7 +361,6 @@ package body Prj.Proc is if To.Attributes = No_Variable then To.Attributes := Variable_Element_Table.Last (In_Tree.Variable_Elements); - else In_Tree.Variable_Elements.Table (V2).Next := Variable_Element_Table.Last (In_Tree.Variable_Elements); @@ -431,7 +393,6 @@ package body Prj.Proc is if To.Arrays = No_Array then To.Arrays := Array_Table.Last (In_Tree.Arrays); - else In_Tree.Arrays.Table (A2).Next := Array_Table.Last (In_Tree.Arrays); @@ -482,6 +443,44 @@ package body Prj.Proc is end loop; end Copy_Package_Declarations; + ------------------------- + -- Get_Attribute_Index -- + ------------------------- + + function Get_Attribute_Index + (Tree : Project_Node_Tree_Ref; + Attr : Project_Node_Id; + Index : Name_Id) return Name_Id + is + Lower : Boolean; + + begin + Get_Name_String (Index); + Lower := Case_Insensitive (Attr, Tree); + + -- The index is always case insensitive if it does not include any dot. + -- ??? Why not use the properties from prj-attr, simply, maybe because + -- we don't know whether we have a file as an index? + + if not Lower then + Lower := True; + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Lower := False; + exit; + end if; + end loop; + end if; + + if Lower then + To_Lower (Name_Buffer (1 .. Name_Len)); + return Name_Find; + else + return Index; + end if; + end Get_Attribute_Index; + ---------------- -- Expression -- ---------------- @@ -489,13 +488,14 @@ package body Prj.Proc is function Expression (Project : Project_Id; In_Tree : Project_Tree_Ref; + Flags : Processing_Flags; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Pkg : Package_Id; First_Term : Project_Node_Id; Kind : Variable_Kind) return Variable_Value is - The_Term : Project_Node_Id := First_Term; + The_Term : Project_Node_Id; -- The term in the expression list The_Current_Term : Project_Node_Id := Empty_Node; @@ -513,6 +513,7 @@ package body Prj.Proc is -- Process each term of the expression, starting with First_Term + The_Term := First_Term; while Present (The_Term) loop The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree); @@ -592,6 +593,7 @@ package body Prj.Proc is Value := Expression (Project => Project, In_Tree => In_Tree, + Flags => Flags, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Pkg => Pkg, @@ -641,6 +643,7 @@ package body Prj.Proc is Expression (Project => Project, In_Tree => In_Tree, + Flags => Flags, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Pkg => Pkg, @@ -809,7 +812,6 @@ package body Prj.Proc is The_Array : Array_Id := No_Array; The_Element : Array_Element_Id := No_Array_Element; Array_Index : Name_Id := No_Name; - Lower : Boolean; begin if The_Package /= No_Package then @@ -831,33 +833,11 @@ package body Prj.Proc is if The_Array /= No_Array then The_Element := In_Tree.Arrays.Table (The_Array).Value; - - Get_Name_String (Index); - - Lower := - Case_Insensitive - (The_Current_Term, From_Project_Node_Tree); - - -- In multi-language mode (gprbuild), the index is - -- always case insensitive if it does not include - -- any dot. - - if Get_Mode = Multi_Language and then not Lower then - Lower := True; - - for J in 1 .. Name_Len loop - if Name_Buffer (J) = '.' then - Lower := False; - exit; - end if; - end loop; - end if; - - if Lower then - To_Lower (Name_Buffer (1 .. Name_Len)); - end if; - - Array_Index := Name_Find; + Array_Index := + Get_Attribute_Index + (From_Project_Node_Tree, + The_Current_Term, + Index); while The_Element /= No_Array_Element and then @@ -1048,6 +1028,7 @@ package body Prj.Proc is Def_Var := Expression (Project => Project, In_Tree => In_Tree, + Flags => Flags, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Pkg => Pkg, @@ -1065,17 +1046,11 @@ package body Prj.Proc is if Value = No_Name then if not Quiet_Output then - if Error_Report = null then - Error_Msg - ("?undefined external reference", - Location_Of - (The_Current_Term, From_Project_Node_Tree)); - else - Error_Report - ("warning: """ & Get_Name_String (Name) & - """ is an undefined external reference", - Project, In_Tree); - end if; + Error_Msg + (Flags, "?undefined external reference", + Location_Of + (The_Current_Term, From_Project_Node_Tree), + Project); end if; Value := Empty_String; @@ -1241,11 +1216,8 @@ package body Prj.Proc is Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; - Report_Error : Put_Line_Access; - When_No_Sources : Error_Warning := Error; - Reset_Tree : Boolean := True; - Current_Dir : String := ""; - Is_Config_File : Boolean) + Flags : Processing_Flags; + Reset_Tree : Boolean := True) is begin Process_Project_Tree_Phase_1 @@ -1254,22 +1226,19 @@ package body Prj.Proc is Success => Success, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, - Report_Error => Report_Error, + Flags => Flags, Reset_Tree => Reset_Tree); - if not Is_Config_File then + if Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree) /= + Configuration + then Process_Project_Tree_Phase_2 - (In_Tree => In_Tree, - Project => Project, - Success => Success, - From_Project_Node => From_Project_Node, - From_Project_Node_Tree => From_Project_Node_Tree, - Report_Error => Report_Error, - When_No_Sources => When_No_Sources, - Current_Dir => Current_Dir, - Compiler_Driver_Mandatory => True, - Allow_Duplicate_Basenames => False, - Is_Config_File => Is_Config_File); + (In_Tree => In_Tree, + Project => Project, + Success => Success, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Flags => Flags); end if; end Process; @@ -1280,6 +1249,7 @@ package body Prj.Proc is procedure Process_Declarative_Items (Project : Project_Id; In_Tree : Project_Tree_Ref; + Flags : Processing_Flags; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Pkg : Package_Id; @@ -1415,6 +1385,7 @@ package body Prj.Proc is Process_Declarative_Items (Project => Project, In_Tree => In_Tree, + Flags => Flags, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Pkg => New_Pkg, @@ -1603,16 +1574,11 @@ package body Prj.Proc is end loop; if Orig_Array = No_Array then - if Error_Report = null then - Error_Msg - ("associative array value not found", - Location_Of - (Current_Item, From_Project_Node_Tree)); - else - Error_Report - ("associative array value not found", - Project, In_Tree); - end if; + Error_Msg + (Flags, + "associative array value not found", + Location_Of (Current_Item, From_Project_Node_Tree), + Project); else Orig_Element := @@ -1715,6 +1681,7 @@ package body Prj.Proc is Expression (Project => Project, In_Tree => In_Tree, + Flags => Flags, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Pkg => Pkg, @@ -1751,18 +1718,12 @@ package body Prj.Proc is if New_Value.Value = Empty_String then Error_Msg_Name_1 := Name_Of (Current_Item, From_Project_Node_Tree); - - if Error_Report = null then - Error_Msg - ("no value defined for %%", - Location_Of - (Current_Item, From_Project_Node_Tree)); - else - Error_Report - ("no value defined for " & - Get_Name_String (Error_Msg_Name_1), - Project, In_Tree); - end if; + Error_Msg + (Flags, + "no value defined for %%", + Location_Of + (Current_Item, From_Project_Node_Tree), + Project); else declare @@ -1796,24 +1757,12 @@ package body Prj.Proc is Error_Msg_Name_2 := Name_Of (Current_Item, From_Project_Node_Tree); - - if Error_Report = null then - Error_Msg - ("value %% is illegal " & - "for typed string %%", - Location_Of - (Current_Item, - From_Project_Node_Tree)); - - else - Error_Report - ("value """ & - Get_Name_String (Error_Msg_Name_1) & - """ is illegal for typed string """ & - Get_Name_String (Error_Msg_Name_2) & - """", - Project, In_Tree); - end if; + Error_Msg + (Flags, + "value %% is illegal for typed string %%", + Location_Of + (Current_Item, From_Project_Node_Tree), + Project); end if; end; end if; @@ -1879,7 +1828,8 @@ package body Prj.Proc is pragma Assert (Kind_Of (Current_Item, From_Project_Node_Tree) /= N_Attribute_Declaration, - "illegal attribute declaration"); + "illegal attribute declaration for " + & Get_Name_String (Current_Item_Name)); Variable_Element_Table.Increment_Last (In_Tree.Variable_Elements); @@ -1921,47 +1871,17 @@ package body Prj.Proc is Index_Name : Name_Id := Associative_Array_Index_Of (Current_Item, From_Project_Node_Tree); - Lower : Boolean; The_Array : Array_Id; - The_Array_Element : Array_Element_Id := No_Array_Element; begin if Index_Name /= All_Other_Names then - -- Get the string index - - Get_Name_String - (Associative_Array_Index_Of + Index_Name := Get_Attribute_Index + (From_Project_Node_Tree, + Current_Item, + Associative_Array_Index_Of (Current_Item, From_Project_Node_Tree)); - - -- Put in lower case, if necessary - - Lower := - Case_Insensitive - (Current_Item, From_Project_Node_Tree); - - -- In multi-language mode (gprbuild), the index - -- is always case insensitive if it does not - -- include any dot. - - if Get_Mode = Multi_Language - and then not Lower - then - for J in 1 .. Name_Len loop - if Name_Buffer (J) = '.' then - Lower := False; - exit; - end if; - end loop; - end if; - - if Lower then - GNAT.Case_Util.To_Lower - (Name_Buffer (1 .. Name_Len)); - end if; - - Index_Name := Name_Find; end if; -- Look for the array in the appropriate list @@ -2249,6 +2169,7 @@ package body Prj.Proc is Process_Declarative_Items (Project => Project, In_Tree => In_Tree, + Flags => Flags, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Pkg => Pkg, @@ -2279,12 +2200,10 @@ package body Prj.Proc is Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; - Report_Error : Put_Line_Access; + Flags : Processing_Flags; Reset_Tree : Boolean := True) is begin - Error_Report := Report_Error; - if Reset_Tree then -- Make sure there are no projects in the data structure @@ -2300,6 +2219,7 @@ package body Prj.Proc is Recursive_Process (Project => Project, In_Tree => In_Tree, + Flags => Flags, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Extended_By => No_Project); @@ -2315,17 +2235,12 @@ package body Prj.Proc is ---------------------------------- procedure Process_Project_Tree_Phase_2 - (In_Tree : Project_Tree_Ref; - Project : Project_Id; - Success : out Boolean; - From_Project_Node : Project_Node_Id; - From_Project_Node_Tree : Project_Node_Tree_Ref; - Report_Error : Put_Line_Access; - When_No_Sources : Error_Warning := Error; - Current_Dir : String; - Is_Config_File : Boolean; - Compiler_Driver_Mandatory : Boolean; - Allow_Duplicate_Basenames : Boolean) + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + Success : out Boolean; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Flags : Processing_Flags) is Obj_Dir : Path_Name_Type; Extending : Project_Id; @@ -2335,15 +2250,10 @@ package body Prj.Proc is -- Start of processing for Process_Project_Tree_Phase_2 begin - Error_Report := Report_Error; - Success := True; if Project /= No_Project then - Check (In_Tree, Project, Current_Dir, When_No_Sources, - Is_Config_File => Is_Config_File, - Compiler_Driver_Mandatory => Compiler_Driver_Mandatory, - Allow_Duplicate_Basenames => Allow_Duplicate_Basenames); + Check (In_Tree, Project, Flags); end if; -- If main project is an extending all project, set the object @@ -2392,44 +2302,23 @@ package body Prj.Proc is then if Extending2.Virtual then Error_Msg_Name_1 := Prj.Project.Display_Name; - - if Error_Report = null then - Error_Msg - ("project %% cannot be extended by a virtual" & - " project with the same object directory", - Prj.Project.Location); - else - Error_Report - ("project """ & - Get_Name_String (Error_Msg_Name_1) & - """ cannot be extended by a virtual " & - "project with the same object directory", - Project, In_Tree); - end if; + Error_Msg + (Flags, + "project %% cannot be extended by a virtual" & + " project with the same object directory", + Prj.Project.Location, Project); else Error_Msg_Name_1 := Extending2.Display_Name; Error_Msg_Name_2 := Prj.Project.Display_Name; - - if Error_Report = null then - Error_Msg - ("project %% cannot extend project %%", - Extending2.Location); - Error_Msg - ("\they share the same object directory", - Extending2.Location); - - else - Error_Report - ("project """ & - Get_Name_String (Error_Msg_Name_1) & - """ cannot extend project """ & - Get_Name_String (Error_Msg_Name_2) & """", - Project, In_Tree); - Error_Report - ("they share the same object directory", - Project, In_Tree); - end if; + Error_Msg + (Flags, + "project %% cannot extend project %%", + Extending2.Location, Project); + Error_Msg + (Flags, + "\they share the same object directory", + Extending2.Location, Project); end if; end if; @@ -2449,29 +2338,6 @@ package body Prj.Proc is (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); end Process_Project_Tree_Phase_2; - --------------------- - -- Recursive_Check -- - --------------------- - - procedure Recursive_Check - (Project : Project_Id; - Data : in out Recursive_Check_Data) - is - begin - if Verbose_Mode then - Write_Str ("Checking project file """); - Write_Str (Get_Name_String (Project.Name)); - Write_Line (""""); - end if; - - Prj.Nmsc.Check - (Project, Data.In_Tree, Error_Report, Data.When_No_Sources, - Data.Current_Dir.all, Data.Proc_Data, - Compiler_Driver_Mandatory => Data.Compiler_Driver_Mandatory, - Is_Config_File => Data.Is_Config_File, - Allow_Duplicate_Basenames => Data.Allow_Duplicate_Basenames); - end Recursive_Check; - ----------------------- -- Recursive_Process -- ----------------------- @@ -2479,6 +2345,7 @@ package body Prj.Proc is procedure Recursive_Process (In_Tree : Project_Tree_Ref; Project : out Project_Id; + Flags : Processing_Flags; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Extended_By : Project_Id) @@ -2519,6 +2386,7 @@ package body Prj.Proc is Recursive_Process (In_Tree => In_Tree, Project => New_Project, + Flags => Flags, From_Project_Node => Project_Node_Of (With_Clause, From_Project_Node_Tree), @@ -2660,6 +2528,7 @@ package body Prj.Proc is Recursive_Process (In_Tree => In_Tree, Project => Project.Extends, + Flags => Flags, From_Project_Node => Extended_Project_Of (Declaration_Node, From_Project_Node_Tree), @@ -2669,6 +2538,7 @@ package body Prj.Proc is Process_Declarative_Items (Project => Project, In_Tree => In_Tree, + Flags => Flags, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Pkg => No_Package, diff --git a/gcc/ada/prj-proc.ads b/gcc/ada/prj-proc.ads index ae69d968ff6..40b5bf35d19 100644 --- a/gcc/ada/prj-proc.ads +++ b/gcc/ada/prj-proc.ads @@ -37,7 +37,7 @@ package Prj.Proc is Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; - Report_Error : Put_Line_Access; + Flags : Prj.Processing_Flags; Reset_Tree : Boolean := True); -- Process a project tree (ie the direct resulting of parsing a .gpr file) -- based on the current scenario variables. @@ -48,41 +48,22 @@ package Prj.Proc is -- needed to automatically generate a configuration file. This first phase -- of the processing does not require a configuration file. -- - -- If Report_Error is null, use the error reporting mechanism. Otherwise, - -- report errors using Report_Error. - -- - -- When_No_Sources indicates what should be done when no sources are found - -- in a project for a specified or implied language. - -- -- When Reset_Tree is True, all the project data are removed from the -- project table before processing. procedure Process_Project_Tree_Phase_2 - (In_Tree : Project_Tree_Ref; - Project : Project_Id; - Success : out Boolean; - From_Project_Node : Project_Node_Id; - From_Project_Node_Tree : Project_Node_Tree_Ref; - Report_Error : Put_Line_Access; - When_No_Sources : Error_Warning := Error; - Current_Dir : String; - Is_Config_File : Boolean; - Compiler_Driver_Mandatory : Boolean; - Allow_Duplicate_Basenames : Boolean); + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + Success : out Boolean; + From_Project_Node : Project_Node_Id; + From_Project_Node_Tree : Project_Node_Tree_Ref; + Flags : Processing_Flags); -- Perform the second phase of the processing, filling the rest of the -- project with the information extracted from the project tree. This phase -- requires that the configuration file has already been parsed (in fact -- we currently assume that the contents of the configuration file has -- been included in Project through Confgpr.Apply_Config_File). The -- parameters are the same as for phase_1, with the addition of: - -- - -- Current_Dir is for optimization purposes, avoiding extra system calls. - -- - -- Is_Config_File should be true if Project is a config file (.cgpr) - -- - -- If Allow_Duplicate_Basenames, then files with the same base names are - -- authorized within a project for source-based languages (never for unit - -- based languages) procedure Process (In_Tree : Project_Tree_Ref; @@ -90,11 +71,8 @@ package Prj.Proc is Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; - Report_Error : Put_Line_Access; - When_No_Sources : Error_Warning := Error; - Reset_Tree : Boolean := True; - Current_Dir : String := ""; - Is_Config_File : Boolean); + Flags : Processing_Flags; + Reset_Tree : Boolean := True); -- Performs the two phases of the processing end Prj.Proc; diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb index 862b6ff6302..0dd2e5eeabd 100644 --- a/gcc/ada/prj-strt.adb +++ b/gcc/ada/prj-strt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -108,7 +108,8 @@ package body Prj.Strt is (In_Tree : Project_Node_Tree_Ref; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; - External_Value : out Project_Node_Id); + External_Value : out Project_Node_Id; + Flags : Processing_Flags); -- Parse an external reference. Current token is "external" procedure Attribute_Reference @@ -116,7 +117,8 @@ package body Prj.Strt is Reference : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id); + Current_Package : Project_Node_Id; + Flags : Processing_Flags); -- Parse an attribute reference. Current token is an apostrophe procedure Terms @@ -125,7 +127,8 @@ package body Prj.Strt is Expr_Kind : in out Variable_Kind; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; - Optional_Index : Boolean); + Optional_Index : Boolean; + Flags : Processing_Flags); -- Recursive procedure to parse one term or several terms concatenated -- using "&". @@ -160,7 +163,8 @@ package body Prj.Strt is Reference : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id) + Current_Package : Project_Node_Id; + Flags : Processing_Flags) is Current_Attribute : Attribute_Node_Id := First_Attribute; @@ -195,7 +199,7 @@ package body Prj.Strt is if Current_Attribute = Empty_Attribute then Error_Msg_Name_1 := Token_Name; - Error_Msg ("unknown attribute %%", Token_Ptr); + Error_Msg (Flags, "unknown attribute %%", Token_Ptr); Reference := Empty_Node; -- Scan past the attribute name @@ -273,7 +277,8 @@ package body Prj.Strt is procedure End_Case_Construction (Check_All_Labels : Boolean; - Case_Location : Source_Ptr) + Case_Location : Source_Ptr; + Flags : Processing_Flags) is Non_Used : Natural := 0; First_Non_Used : Choice_Node_Id := First_Choice_Node_Id; @@ -296,19 +301,19 @@ package body Prj.Strt is if Non_Used = 1 then Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String; - Error_Msg ("?value %% is not used as label", Case_Location); + Error_Msg (Flags, "?value %% is not used as label", Case_Location); -- If several are not used, report a warning for each one of them elsif Non_Used > 1 then Error_Msg - ("?the following values are not used as labels:", + (Flags, "?the following values are not used as labels:", Case_Location); for Choice in First_Non_Used .. Choices.Last loop if not Choices.Table (Choice).Already_Used then Error_Msg_Name_1 := Choices.Table (Choice).The_String; - Error_Msg ("\?%%", Case_Location); + Error_Msg (Flags, "\?%%", Case_Location); end if; end loop; end if; @@ -347,7 +352,8 @@ package body Prj.Strt is (In_Tree : Project_Node_Tree_Ref; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; - External_Value : out Project_Node_Id) + External_Value : out Project_Node_Id; + Flags : Processing_Flags) is Field_Id : Project_Node_Id := Empty_Node; @@ -406,12 +412,14 @@ package body Prj.Strt is Parse_Expression (In_Tree => In_Tree, Expression => Field_Id, + Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => False); if Expression_Kind_Of (Field_Id, In_Tree) = List then - Error_Msg ("expression must be a single string", Loc); + Error_Msg + (Flags, "expression must be a single string", Loc); else Set_External_Default_Of (External_Value, In_Tree, To => Field_Id); @@ -425,7 +433,7 @@ package body Prj.Strt is end if; when others => - Error_Msg ("`,` or `)` expected", Token_Ptr); + Error_Msg (Flags, "`,` or `)` expected", Token_Ptr); end case; end if; end External_Reference; @@ -436,7 +444,8 @@ package body Prj.Strt is procedure Parse_Choice_List (In_Tree : Project_Node_Tree_Ref; - First_Choice : out Project_Node_Id) + First_Choice : out Project_Node_Id; + Flags : Processing_Flags) is Current_Choice : Project_Node_Id := Empty_Node; Next_Choice : Project_Node_Id := Empty_Node; @@ -483,7 +492,7 @@ package body Prj.Strt is -- case construction so report an error. Error_Msg_Name_1 := Choice_String; - Error_Msg ("duplicate case label %%", Token_Ptr); + Error_Msg (Flags, "duplicate case label %%", Token_Ptr); else Choices.Table (Choice).Already_Used := True; @@ -497,7 +506,7 @@ package body Prj.Strt is if not Found then Error_Msg_Name_1 := Choice_String; - Error_Msg ("illegal case label %%", Token_Ptr); + Error_Msg (Flags, "illegal case label %%", Token_Ptr); end if; -- Scan past the label @@ -535,7 +544,8 @@ package body Prj.Strt is Expression : out Project_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; - Optional_Index : Boolean) + Optional_Index : Boolean; + Flags : Processing_Flags) is First_Term : Project_Node_Id := Empty_Node; Expression_Kind : Variable_Kind := Undefined; @@ -552,6 +562,7 @@ package body Prj.Strt is Terms (In_Tree => In_Tree, Term => First_Term, Expr_Kind => Expression_Kind, + Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => Optional_Index); @@ -568,7 +579,8 @@ package body Prj.Strt is procedure Parse_String_Type_List (In_Tree : Project_Node_Tree_Ref; - First_String : out Project_Node_Id) + First_String : out Project_Node_Id; + Flags : Processing_Flags) is Last_String : Project_Node_Id := Empty_Node; Next_String : Project_Node_Id := Empty_Node; @@ -609,7 +621,7 @@ package body Prj.Strt is -- This is a repetition, report an error Error_Msg_Name_1 := String_Value; - Error_Msg ("duplicate value %% in type", Token_Ptr); + Error_Msg (Flags, "duplicate value %% in type", Token_Ptr); exit; end if; @@ -650,7 +662,8 @@ package body Prj.Strt is (In_Tree : Project_Node_Tree_Ref; Variable : out Project_Node_Id; Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id) + Current_Package : Project_Node_Id; + Flags : Processing_Flags) is Current_Variable : Project_Node_Id := Empty_Node; @@ -723,7 +736,7 @@ package body Prj.Strt is if First_Attribute = Empty_Attribute then Error_Msg_Name_1 := Names.Table (1).Name; - Error_Msg ("unknown project %", + Error_Msg (Flags, "unknown project %", Names.Table (1).Location); First_Attribute := Attribute_First; @@ -747,7 +760,7 @@ package body Prj.Strt is if No (The_Package) then Error_Msg_Name_1 := Names.Table (1).Name; - Error_Msg ("package % not yet defined", + Error_Msg (Flags, "package % not yet defined", Names.Table (1).Location); end if; end if; @@ -844,7 +857,7 @@ package body Prj.Strt is if No (The_Project) then Error_Msg_Name_1 := Long_Project; Error_Msg_Name_2 := Short_Project; - Error_Msg ("unknown projects % or %", + Error_Msg (Flags, "unknown projects % or %", Names.Table (1).Location); The_Package := Empty_Node; First_Attribute := Attribute_First; @@ -869,7 +882,8 @@ package body Prj.Strt is Error_Msg_Name_1 := Names.Table (Names.Last).Name; Error_Msg_Name_2 := Short_Project; - Error_Msg ("package % not declared in project %", + Error_Msg (Flags, + "package % not declared in project %", Names.Table (Names.Last).Location); First_Attribute := Attribute_First; @@ -889,6 +903,7 @@ package body Prj.Strt is Attribute_Reference (In_Tree, Variable, + Flags => Flags, Current_Project => The_Project, Current_Package => The_Package, First_Attribute => First_Attribute); @@ -944,7 +959,7 @@ package body Prj.Strt is elsif No (The_Package) then Error_Msg_Name_1 := Names.Table (1).Name; - Error_Msg ("unknown package or project %", + Error_Msg (Flags, "unknown package or project %", Names.Table (1).Location); Look_For_Variable := False; @@ -1023,7 +1038,7 @@ package body Prj.Strt is Error_Msg_Name_1 := Long_Project; Error_Msg_Name_2 := Short_Project; Error_Msg - ("unknown projects % or %", + (Flags, "unknown projects % or %", Names.Table (1).Location); Look_For_Variable := False; @@ -1047,7 +1062,7 @@ package body Prj.Strt is -- The package does not exist, report an error Error_Msg_Name_1 := Names.Table (2).Name; - Error_Msg ("unknown package %", + Error_Msg (Flags, "unknown package %", Names.Table (Names.Last - 1).Location); Look_For_Variable := False; @@ -1143,7 +1158,7 @@ package body Prj.Strt is if No (Current_Variable) then Error_Msg_Name_1 := Variable_Name; Error_Msg - ("unknown variable %", Names.Table (Names.Last).Location); + (Flags, "unknown variable %", Names.Table (Names.Last).Location); end if; end if; @@ -1165,7 +1180,8 @@ package body Prj.Strt is -- but attempt to scan the index. if Token = Tok_Left_Paren then - Error_Msg ("\variables cannot be associative arrays", Token_Ptr); + Error_Msg + (Flags, "\variables cannot be associative arrays", Token_Ptr); Scan (In_Tree); Expect (Tok_String_Literal, "literal string"); @@ -1227,7 +1243,8 @@ package body Prj.Strt is Expr_Kind : in out Variable_Kind; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; - Optional_Index : Boolean) + Optional_Index : Boolean; + Flags : Processing_Flags) is Next_Term : Project_Node_Id := Empty_Node; Term_Id : Project_Node_Id := Empty_Node; @@ -1263,7 +1280,7 @@ package body Prj.Strt is Expr_Kind := List; Error_Msg - ("literal string list cannot appear in a string", + (Flags, "literal string list cannot appear in a string", Token_Ptr); end case; @@ -1294,6 +1311,7 @@ package body Prj.Strt is Parse_Expression (In_Tree => In_Tree, Expression => Next_Expression, + Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => Optional_Index); @@ -1301,7 +1319,7 @@ package body Prj.Strt is -- The expression kind is String list, report an error if Expression_Kind_Of (Next_Expression, In_Tree) = List then - Error_Msg ("single expression expected", + Error_Msg (Flags, "single expression expected", Current_Location); end if; @@ -1358,7 +1376,7 @@ package body Prj.Strt is if Token = Tok_At then if not Optional_Index then - Error_Msg ("index not allowed here", Token_Ptr); + Error_Msg (Flags, "index not allowed here", Token_Ptr); Scan (In_Tree); if Token = Tok_Integer_Literal then @@ -1376,7 +1394,8 @@ package body Prj.Strt is Index : constant Int := UI_To_Int (Int_Literal_Value); begin if Index = 0 then - Error_Msg ("index cannot be zero", Token_Ptr); + Error_Msg + (Flags, "index cannot be zero", Token_Ptr); else Set_Source_Index_Of (Term_Id, In_Tree, To => Index); @@ -1396,6 +1415,7 @@ package body Prj.Strt is Parse_Variable_Reference (In_Tree => In_Tree, Variable => Reference, + Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package); Set_Current_Term (Term, In_Tree, To => Reference); @@ -1417,7 +1437,8 @@ package body Prj.Strt is Expr_Kind := List; Error_Msg - ("list variable cannot appear in single string expression", + (Flags, + "list variable cannot appear in single string expression", Current_Location); end if; end if; @@ -1435,6 +1456,7 @@ package body Prj.Strt is Attribute_Reference (In_Tree => In_Tree, Reference => Reference, + Flags => Flags, First_Attribute => Prj.Attr.Attribute_First, Current_Project => Current_Project, Current_Package => Empty_Node); @@ -1451,7 +1473,7 @@ package body Prj.Strt is and then Expression_Kind_Of (Reference, In_Tree) = List then Error_Msg - ("lists cannot appear in single string expression", + (Flags, "lists cannot appear in single string expression", Current_Location); end if; end if; @@ -1466,13 +1488,14 @@ package body Prj.Strt is External_Reference (In_Tree => In_Tree, + Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, External_Value => Reference); Set_Current_Term (Term, In_Tree, To => Reference); when others => - Error_Msg ("cannot be part of an expression", Token_Ptr); + Error_Msg (Flags, "cannot be part of an expression", Token_Ptr); Term := Empty_Node; return; end case; @@ -1486,6 +1509,7 @@ package body Prj.Strt is (In_Tree => In_Tree, Term => Next_Term, Expr_Kind => Expr_Kind, + Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => Optional_Index); diff --git a/gcc/ada/prj-strt.ads b/gcc/ada/prj-strt.ads index d0b4b593941..7dbe5302781 100644 --- a/gcc/ada/prj-strt.ads +++ b/gcc/ada/prj-strt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,15 +31,16 @@ private package Prj.Strt is procedure Parse_String_Type_List (In_Tree : Project_Node_Tree_Ref; - First_String : out Project_Node_Id); + First_String : out Project_Node_Id; + Flags : Processing_Flags); -- Get the list of literal strings that are allowed for a typed string. -- On entry, the current token is the first literal string following -- a left parenthesis in a string type declaration such as: -- type Toto is ("string_1", "string_2", "string_3"); - -- On exit, the current token is the right parenthesis. - -- The parameter First_String is a node that contained the first - -- literal string of the string type, linked with the following - -- literal strings. + -- + -- On exit, the current token is the right parenthesis. The parameter + -- First_String is a node that contained the first literal string of the + -- string type, linked with the following literal strings. -- -- Report an error if -- - a literal string is not found at the beginning of the list @@ -49,27 +50,27 @@ private package Prj.Strt is procedure Start_New_Case_Construction (In_Tree : Project_Node_Tree_Ref; String_Type : Project_Node_Id); - -- This procedure is called at the beginning of a case construction - -- The parameter String_Type is the node for the string type - -- of the case label variable. - -- The different literal strings of the string type are stored - -- into a table to be checked against the case labels of the - -- case construction. + -- This procedure is called at the beginning of a case construction The + -- parameter String_Type is the node for the string type of the case label + -- variable. The different literal strings of the string type are stored + -- into a table to be checked against the case labels of the case + -- construction. procedure End_Case_Construction (Check_All_Labels : Boolean; - Case_Location : Source_Ptr); - -- This procedure is called at the end of a case construction - -- to remove the case labels and to restore the previous state. - -- In particular, in the case of nested case constructions, - -- the case labels of the enclosing case construction are restored. - -- When When_Others is False and we are not in quiet output, a warning - -- is emitted for each value of the case variable string type that has - -- not been specified. + Case_Location : Source_Ptr; + Flags : Processing_Flags); + -- This procedure is called at the end of a case construction to remove the + -- case labels and to restore the previous state. In particular, in the + -- case of nested case constructions, the case labels of the enclosing case + -- construction are restored. When When_Others is False and we are not in + -- quiet output, a warning is emitted for each value of the case variable + -- string type that has not been specified. procedure Parse_Choice_List (In_Tree : Project_Node_Tree_Ref; - First_Choice : out Project_Node_Id); + First_Choice : out Project_Node_Id; + Flags : Processing_Flags); -- Get the label for a choice list. -- Report an error if -- - a case label is not a literal string @@ -81,26 +82,28 @@ private package Prj.Strt is Expression : out Project_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; - Optional_Index : Boolean); - -- Parse a simple string expression or a string list expression. - -- Current_Project is the node of the project file being parsed. - -- Current_Package is the node of the package being parsed, - -- or Empty_Node when we are at the project level (not in a package). - -- On exit, Expression is the node of the expression that has - -- been parsed. + Optional_Index : Boolean; + Flags : Processing_Flags); + -- Parse a simple string expression or a string list expression + -- + -- Current_Project is the node of the project file being parsed + -- + -- Current_Package is the node of the package being parsed, or Empty_Node + -- when we are at the project level (not in a package). On exit, Expression + -- is the node of the expression that has been parsed. procedure Parse_Variable_Reference (In_Tree : Project_Node_Tree_Ref; Variable : out Project_Node_Id; Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id); - -- Parse a variable or attribute reference. - -- Used internally (in expressions) and for case variables (in Prj.Dect). - -- Current_Package is the node of the package being parsed, - -- or Empty_Node when we are at the project level (not in a package). - -- On exit, Variable is the node of the variable or attribute reference. - -- A variable reference is made of one to three simple names. - -- An attribute reference is made of one or two simple names, + Current_Package : Project_Node_Id; + Flags : Processing_Flags); + -- Parse variable or attribute reference. Used internally (in expressions) + -- and for case variables (in Prj.Dect). Current_Package is the node of the + -- package being parsed, or Empty_Node when we are at the project level + -- (not in a package). On exit, Variable is the node of the variable or + -- attribute reference. A variable reference is made of one to three simple + -- names. An attribute reference is made of one or two simple names, -- followed by an apostrophe, followed by the attribute simple name. end Prj.Strt; diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index e9bc4a38853..1f15c80b27b 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; +with Osint; use Osint; with Prj.Err; package body Prj.Tree is @@ -96,8 +97,7 @@ package body Prj.Tree is begin pragma Assert (Present (To) - and then - In_Tree.Project_Nodes.Table (To).Kind /= N_Comment); + and then In_Tree.Project_Nodes.Table (To).Kind /= N_Comment); Zone := In_Tree.Project_Nodes.Table (To).Comments; @@ -108,25 +108,25 @@ package body Prj.Tree is Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (Project_Node_Table.Last (In_Tree.Project_Nodes)) := - (Kind => N_Comment_Zones, - Qualifier => Unspecified, - Expr_Kind => Undefined, - Location => No_Location, - Directory => No_Path, - Variables => Empty_Node, - Packages => Empty_Node, - Pkg_Id => Empty_Package, - Name => No_Name, - Src_Index => 0, - Path_Name => No_Path, - Value => No_Name, - Field1 => Empty_Node, - Field2 => Empty_Node, - Field3 => Empty_Node, - Field4 => Empty_Node, - Flag1 => False, - Flag2 => False, - Comments => Empty_Node); + (Kind => N_Comment_Zones, + Qualifier => Unspecified, + Expr_Kind => Undefined, + Location => No_Location, + Directory => No_Path, + Variables => Empty_Node, + Packages => Empty_Node, + Pkg_Id => Empty_Package, + Name => No_Name, + Src_Index => 0, + Path_Name => No_Path, + Value => No_Name, + Field1 => Empty_Node, + Field2 => Empty_Node, + Field3 => Empty_Node, + Field4 => Empty_Node, + Flag1 => False, + Flag2 => False, + Comments => Empty_Node); Zone := Project_Node_Table.Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (To).Comments := Zone; @@ -2820,4 +2820,252 @@ package body Prj.Tree is return Unkept_Comments; end There_Are_Unkept_Comments; + -------------------- + -- Create_Project -- + -------------------- + + function Create_Project + (In_Tree : Project_Node_Tree_Ref; + Name : Name_Id; + Full_Path : Path_Name_Type; + Is_Config_File : Boolean := False) return Project_Node_Id + is + Project : Project_Node_Id; + Qualifier : Project_Qualifier := Unspecified; + begin + Project := Default_Project_Node (In_Tree, N_Project); + Set_Name_Of (Project, In_Tree, Name); + Set_Directory_Of + (Project, In_Tree, + Path_Name_Type (Get_Directory (File_Name_Type (Full_Path)))); + Set_Path_Name_Of (Project, In_Tree, Full_Path); + + Set_Project_Declaration_Of + (Project, In_Tree, + Default_Project_Node (In_Tree, N_Project_Declaration)); + + if Is_Config_File then + Qualifier := Configuration; + end if; + + if not Is_Config_File then + Prj.Tree.Tree_Private_Part.Projects_Htable.Set + (In_Tree.Projects_HT, + Name, + Prj.Tree.Tree_Private_Part.Project_Name_And_Node' + (Name => Name, + Canonical_Path => No_Path, + Node => Project, + Extended => False, + Proj_Qualifier => Qualifier)); + end if; + + return Project; + end Create_Project; + + ---------------- + -- Add_At_End -- + ---------------- + + procedure Add_At_End + (Tree : Project_Node_Tree_Ref; + Parent : Project_Node_Id; + Expr : Project_Node_Id; + Add_Before_First_Pkg : Boolean := False; + Add_Before_First_Case : Boolean := False) + is + Real_Parent : Project_Node_Id; + New_Decl, Decl, Next : Project_Node_Id; + Last, L : Project_Node_Id; + + begin + if Kind_Of (Expr, Tree) /= N_Declarative_Item then + New_Decl := Default_Project_Node (Tree, N_Declarative_Item); + Set_Current_Item_Node (New_Decl, Tree, Expr); + else + New_Decl := Expr; + end if; + + if Kind_Of (Parent, Tree) = N_Project then + Real_Parent := Project_Declaration_Of (Parent, Tree); + else + Real_Parent := Parent; + end if; + + Decl := First_Declarative_Item_Of (Real_Parent, Tree); + + if Decl = Empty_Node then + Set_First_Declarative_Item_Of (Real_Parent, Tree, New_Decl); + else + loop + Next := Next_Declarative_Item (Decl, Tree); + exit when Next = Empty_Node + or else + (Add_Before_First_Pkg + and then Kind_Of (Current_Item_Node (Next, Tree), Tree) = + N_Package_Declaration) + or else + (Add_Before_First_Case + and then Kind_Of (Current_Item_Node (Next, Tree), Tree) = + N_Case_Construction); + Decl := Next; + end loop; + + -- In case Expr is in fact a range of declarative items + + Last := New_Decl; + loop + L := Next_Declarative_Item (Last, Tree); + exit when L = Empty_Node; + Last := L; + end loop; + + -- In case Expr is in fact a range of declarative items + + Last := New_Decl; + loop + L := Next_Declarative_Item (Last, Tree); + exit when L = Empty_Node; + Last := L; + end loop; + + Set_Next_Declarative_Item (Last, Tree, Next); + Set_Next_Declarative_Item (Decl, Tree, New_Decl); + end if; + end Add_At_End; + + --------------------------- + -- Create_Literal_String -- + --------------------------- + + function Create_Literal_String + (Str : Namet.Name_Id; + Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + Node : Project_Node_Id; + begin + Node := Default_Project_Node (Tree, N_Literal_String, Prj.Single); + Set_Next_Literal_String (Node, Tree, Empty_Node); + Set_String_Value_Of (Node, Tree, Str); + return Node; + end Create_Literal_String; + + --------------------------- + -- Enclose_In_Expression -- + --------------------------- + + function Enclose_In_Expression + (Node : Project_Node_Id; + Tree : Project_Node_Tree_Ref) return Project_Node_Id + is + Expr : constant Project_Node_Id := + Default_Project_Node (Tree, N_Expression, Single); + begin + Set_First_Term (Expr, Tree, Default_Project_Node (Tree, N_Term, Single)); + Set_Current_Term (First_Term (Expr, Tree), Tree, Node); + return Expr; + end Enclose_In_Expression; + + -------------------- + -- Create_Package -- + -------------------- + + function Create_Package + (Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Pkg : String) return Project_Node_Id + is + Pack : Project_Node_Id; + N : Name_Id; + + begin + Name_Len := Pkg'Length; + Name_Buffer (1 .. Name_Len) := Pkg; + N := Name_Find; + + -- Check if the package already exists + + Pack := First_Package_Of (Project, Tree); + while Pack /= Empty_Node loop + if Prj.Tree.Name_Of (Pack, Tree) = N then + return Pack; + end if; + + Pack := Next_Package_In_Project (Pack, Tree); + end loop; + + -- Create the package and add it to the declarative item + + Pack := Default_Project_Node (Tree, N_Package_Declaration); + Set_Name_Of (Pack, Tree, N); + + -- Find the correct package id to use + + Set_Package_Id_Of (Pack, Tree, Package_Node_Id_Of (N)); + + -- Add it to the list of packages + + Set_Next_Package_In_Project + (Pack, Tree, First_Package_Of (Project, Tree)); + Set_First_Package_Of (Project, Tree, Pack); + + Add_At_End (Tree, Project_Declaration_Of (Project, Tree), Pack); + + return Pack; + end Create_Package; + + ------------------- + -- Create_Attribute -- + ---------------------- + + function Create_Attribute + (Tree : Project_Node_Tree_Ref; + Prj_Or_Pkg : Project_Node_Id; + Name : Name_Id; + Index_Name : Name_Id := No_Name; + Kind : Variable_Kind := List; + At_Index : Integer := 0) return Project_Node_Id + is + Node : constant Project_Node_Id := + Default_Project_Node (Tree, N_Attribute_Declaration, Kind); + + Case_Insensitive : Boolean; + + Pkg : Package_Node_Id; + Start_At : Attribute_Node_Id; + + begin + Set_Name_Of (Node, Tree, Name); + + if At_Index /= 0 then + Set_Source_Index_Of (Node, Tree, To => Int (At_Index)); + end if; + + if Index_Name /= No_Name then + Set_Associative_Array_Index_Of (Node, Tree, Index_Name); + end if; + + if Prj_Or_Pkg /= Empty_Node then + Add_At_End (Tree, Prj_Or_Pkg, Node); + end if; + + -- Find out the case sensitivity of the attribute + + if Prj_Or_Pkg /= Empty_Node + and then Kind_Of (Prj_Or_Pkg, Tree) = N_Package_Declaration + then + Pkg := Prj.Attr.Package_Node_Id_Of (Name_Of (Prj_Or_Pkg, Tree)); + Start_At := First_Attribute_Of (Pkg); + else + Start_At := Attribute_First; + end if; + + Start_At := Attribute_Node_Id_Of (Name, Start_At); + Case_Insensitive := + Attribute_Kind_Of (Start_At) = Case_Insensitive_Associative_Array; + Tree.Project_Nodes.Table (Node).Flag1 := Case_Insensitive; + + return Node; + end Create_Attribute; + end Prj.Tree; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index 57fe531dc3d..46cfcf14a21 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -92,11 +92,11 @@ package Prj.Tree is function Present (Node : Project_Node_Id) return Boolean; pragma Inline (Present); - -- Return True iff Node /= Empty_Node + -- Return True if Node /= Empty_Node function No (Node : Project_Node_Id) return Boolean; pragma Inline (No); - -- Return True iff Node = Empty_Node + -- Return True if Node = Empty_Node procedure Initialize (Tree : Project_Node_Tree_Ref); -- Initialize the Project File tree: empty the Project_Nodes table @@ -108,6 +108,7 @@ package Prj.Tree is And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id; -- Returns a Project_Node_Record with the specified Kind and Expr_Kind. All -- the other components have default nil values. + -- To create a node for a project itself, see Create_Project below instead function Hash (N : Project_Node_Id) return Header_Num; -- Used for hash tables where the key is a Project_Node_Id @@ -285,7 +286,8 @@ package Prj.Tree is (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Path_Name_Type; pragma Inline (Directory_Of); - -- Only valid for N_Project nodes + -- Returns the directory that contains the project file. This always ends + -- with a directory separator. Only valid for N_Project nodes. function Expression_Kind_Of (Node : Project_Node_Id; @@ -430,8 +432,7 @@ package Prj.Tree is (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Project_Of_Renamed_Package_Of); - -- Only valid for N_Package_Declaration nodes. - -- May return Empty_Node. + -- Only valid for N_Package_Declaration nodes. May return Empty_Node. function Next_Package_In_Project (Node : Project_Node_Id; @@ -586,15 +587,80 @@ package Prj.Tree is In_Tree : Project_Node_Tree_Ref) return Boolean; -- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes + ----------------------- + -- Create procedures -- + ----------------------- + -- The following procedures are used to edit a project file tree. They are + -- slightly higher-level than the Set_* procedures below + + function Create_Project + (In_Tree : Project_Node_Tree_Ref; + Name : Name_Id; + Full_Path : Path_Name_Type; + Is_Config_File : Boolean := False) return Project_Node_Id; + -- Create a new node for a project and register it in the tree so that it + -- can be retrieved later on. + + function Create_Package + (Tree : Project_Node_Tree_Ref; + Project : Project_Node_Id; + Pkg : String) return Project_Node_Id; + -- Create a new package in Project. If the package already exists, it is + -- returned. The name of the package *must* be lower-cases, or none of its + -- attributes will be recognized. + + function Create_Attribute + (Tree : Project_Node_Tree_Ref; + Prj_Or_Pkg : Project_Node_Id; + Name : Name_Id; + Index_Name : Name_Id := No_Name; + Kind : Variable_Kind := List; + At_Index : Integer := 0) return Project_Node_Id; + -- Create a new attribute. The new declaration is added at the end of the + -- declarative item list for Prj_Or_Pkg (a project or a package), but + -- before any package declaration). No addition is done if Prj_Or_Pkg is + -- Empty_Node. If Index_Name is not "", then if creates an attribute value + -- for a specific index. At_Index is used for the " at <idx>" in the naming + -- exceptions. Use Set_Expression_Of to set the value of the attribute (in + -- which case Enclose_In_Expression might be useful) + + function Create_Literal_String + (Str : Namet.Name_Id; + Tree : Project_Node_Tree_Ref) return Project_Node_Id; + -- Create a literal string whose value is Str + + procedure Add_At_End + (Tree : Project_Node_Tree_Ref; + Parent : Project_Node_Id; + Expr : Project_Node_Id; + Add_Before_First_Pkg : Boolean := False; + Add_Before_First_Case : Boolean := False); + -- Add a new declarative item in the list in Parent. This new declarative + -- item will contain Expr (unless Expr is already a declarative item, in + -- which case it is added directly to the list). The new item is inserted + -- at the end of the list, unless Add_Before_First_Pkg is True. In the + -- latter case, it is added just before the first case construction is + -- seen, or before the first package (this assumes that all packages are + -- found at the end of the project, which isn't true in the general case + -- unless you have normalized the project to match this description). + + function Enclose_In_Expression + (Node : Project_Node_Id; + Tree : Project_Node_Tree_Ref) return Project_Node_Id; + -- Enclose the Node inside a N_Expression node, and return this expression + -------------------- -- Set Procedures -- -------------------- - -- The following procedures are part of the abstract interface of - -- the Project File tree. + -- The following procedures are part of the abstract interface of the + -- Project File tree. -- Each Set_* procedure is valid only for the same Project_Node_Kind -- nodes as the corresponding query function above. + -- These are very low-level, and manipulate the tree itself directly. You + -- should look at the Create_* procedure instead if you want to use higher + -- level constructs procedure Set_Name_Of (Node : Project_Node_Id; @@ -960,6 +1026,7 @@ package Prj.Tree is Pkg_Id : Package_Node_Id := Empty_Package; -- Only used for N_Package_Declaration + -- -- The component Pkg_Id is an entry into the table Package_Attributes -- (in Prj.Attr). It is used to indicate all the attributes of the -- package with their characteristics. @@ -995,38 +1062,45 @@ package Prj.Tree is Flag1 : Boolean := False; -- This flag is significant only for: + -- -- N_Attribute_Declaration and N_Attribute_Reference - -- It indicates for an associative array attribute, that the + -- Indicates for an associative array attribute, that the -- index is case insensitive. - -- N_Comment - it indicates that the comment is preceded by an - -- empty line. - -- N_Project - it indicates that there are comments in the project - -- source that cannot be kept in the tree. + -- + -- N_Comment + -- Indicates that the comment is preceded by an empty line. + -- + -- N_Project + -- Indicates that there are comments in the project source that + -- cannot be kept in the tree. + -- -- N_Project_Declaration - -- - it indicates that there are unkept comments in the - -- project. + -- Indicates that there are unkept comments in the project. + -- -- N_With_Clause - -- - it indicates that this is not the last with in a - -- with clause. It is set for "A", but not for "B" in - -- with "B"; - -- and - -- with "A", "B"; + -- Indicates that this is not the last with in a with clause. + -- Set for "A", but not for "B" in with "B"; and with "A", "B"; Flag2 : Boolean := False; -- This flag is significant only for: - -- N_Project - it indicates that the project "extends all" another - -- project. - -- N_Comment - it indicates that the comment is followed by an - -- empty line. + -- + -- N_Project + -- Indicates that the project "extends all" another project. + -- + -- N_Comment + -- Indicates that the comment is followed by an empty line. + -- -- N_With_Clause - -- - it indicates that the originally imported project - -- is an extending all project. + -- Indicates that the originally imported project is an extending + -- all project. Comments : Project_Node_Id := Empty_Node; -- For nodes other that N_Comment_Zones or N_Comment, designates the -- comment zones associated with the node. - -- for N_Comment_Zones, designates the comment after the "end" of + -- + -- For N_Comment_Zones, designates the comment after the "end" of -- the construct. + -- -- For N_Comment, designates the next comment, if any. end record; @@ -1245,15 +1319,14 @@ package Prj.Tree is -- -- Flag2: comment is followed by an empty line -- -- Comments: next comment - package Project_Node_Table is - new GNAT.Dynamic_Tables + package Project_Node_Table is new + GNAT.Dynamic_Tables (Table_Component_Type => Project_Node_Record, Table_Index_Type => Project_Node_Id, Table_Low_Bound => First_Node_Id, Table_Initial => Project_Nodes_Initial, Table_Increment => Project_Nodes_Increment); - -- This table contains the syntactic tree of project data - -- from project files. + -- Table contains the syntactic tree of project data from project files type Project_Name_And_Node is record Name : Name_Id; @@ -1309,13 +1382,9 @@ private type Comment_State is record End_Of_Line_Node : Project_Node_Id := Empty_Node; - Previous_Line_Node : Project_Node_Id := Empty_Node; - Previous_End_Node : Project_Node_Id := Empty_Node; - Unkept_Comments : Boolean := False; - Comments : Comments_Ptr := null; end record; diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index 5e36fcd71e6..897e7f01dbe 100644 --- a/gcc/ada/prj-util.adb +++ b/gcc/ada/prj-util.adb @@ -130,8 +130,6 @@ package body Prj.Util is In_Package => Builder_Package, In_Tree => In_Tree); - Executable_Suffix : Variable_Value := Nil_Variable_Value; - Executable_Suffix_Name : Name_Id := No_Name; Lang : Language_Ptr; @@ -183,22 +181,7 @@ package body Prj.Util is end if; if Builder_Package /= No_Package then - if Get_Mode = Multi_Language then - Executable_Suffix_Name := Project.Config.Executable_Suffix; - - else - Executable_Suffix := Prj.Util.Value_Of - (Variable_Name => Name_Executable_Suffix, - In_Variables => In_Tree.Packages.Table - (Builder_Package).Decl.Attributes, - In_Tree => In_Tree); - - if Executable_Suffix /= Nil_Variable_Value - and then not Executable_Suffix.Default - then - Executable_Suffix_Name := Executable_Suffix.Value; - end if; - end if; + Executable_Suffix_Name := Project.Config.Executable_Suffix; if Executable = Nil_Variable_Value and Ada_Main then Get_Name_String (Main); @@ -251,7 +234,8 @@ package body Prj.Util is -- possibly suffixed by the executable suffix. if Executable /= Nil_Variable_Value - and then Executable.Value /= Empty_Name + and then Executable.Value /= No_Name + and then Length_Of_Name (Executable.Value) /= 0 then -- Get the executable name. If Executable_Suffix is defined, -- make sure that it will be the extension of the executable. @@ -303,40 +287,24 @@ package body Prj.Util is Get_Name_String (Strip_Suffix (Main)); end if; - if Executable_Suffix /= Nil_Variable_Value - and then not Executable_Suffix.Default - then - -- If attribute Executable_Suffix is specified, add this suffix + -- Get the executable name. If Executable_Suffix is defined in the + -- configuration, make sure that it will be the extension of the + -- executable. - declare - Suffix : constant String := - Get_Name_String (Executable_Suffix.Value); - begin - Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; - Name_Len := Name_Len + Suffix'Length; - return Name_Find; - end; + declare + Saved_EEOT : constant Name_Id := Executable_Extension_On_Target; + Result : File_Name_Type; - else - -- Get the executable name. If Executable_Suffix is defined in the - -- configuration, make sure that it will be the extension of the - -- executable. - - declare - Saved_EEOT : constant Name_Id := Executable_Extension_On_Target; - Result : File_Name_Type; - - begin - if Project.Config.Executable_Suffix /= No_Name then - Executable_Extension_On_Target := - Project.Config.Executable_Suffix; - end if; + begin + if Project.Config.Executable_Suffix /= No_Name then + Executable_Extension_On_Target := + Project.Config.Executable_Suffix; + end if; - Result := Executable_Name (Name_Find); - Executable_Extension_On_Target := Saved_EEOT; - return Result; - end; - end if; + Result := Executable_Name (Name_Find); + Executable_Extension_On_Target := Saved_EEOT; + return Result; + end; end Executable_Of; -------------- diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index ec7eeaa0903..e0c2f1bde20 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -28,10 +28,10 @@ with Ada.Unchecked_Deallocation; with Debug; with Osint; use Osint; +with Output; use Output; with Prj.Attr; with Prj.Err; use Prj.Err; with Snames; use Snames; -with Table; with Uintp; use Uintp; with GNAT.Directory_Operations; use GNAT.Directory_Operations; @@ -47,22 +47,20 @@ package body Prj is Initial_Buffer_Size : constant := 100; -- Initial size for extensible buffer used in Add_To_Buffer - Current_Mode : Mode := Ada_Only; - - The_Empty_String : Name_Id; - - Default_Ada_Spec_Suffix_Id : File_Name_Type; - Default_Ada_Body_Suffix_Id : File_Name_Type; - -- Initialized in Prj.Initialize, then never modified + The_Empty_String : Name_Id := No_Name; subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; - The_Casing_Images : constant array (Known_Casing) of String_Access := - (All_Lower_Case => new String'("lowercase"), - All_Upper_Case => new String'("UPPERCASE"), - Mixed_Case => new String'("MixedCase")); + type Cst_String_Access is access constant String; - Initialized : Boolean := False; + All_Lower_Case_Image : aliased constant String := "lowercase"; + All_Upper_Case_Image : aliased constant String := "UPPERCASE"; + Mixed_Case_Image : aliased constant String := "MixedCase"; + + The_Casing_Images : constant array (Known_Casing) of Cst_String_Access := + (All_Lower_Case => All_Lower_Case_Image'Access, + All_Upper_Case => All_Upper_Case_Image'Access, + Mixed_Case => Mixed_Case_Image'Access); Project_Empty : constant Project_Data := (Qualifier => Unspecified, @@ -114,16 +112,6 @@ package body Prj is Depth => 0, Unkept_Comments => False); - package Temp_Files is new Table.Table - (Table_Component_Type => Path_Name_Type, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 20, - Table_Increment => 100, - Table_Name => "Makegpr.Temp_Files"); - -- Table to store the path name of all the created temporary files, so that - -- they can be deleted at the end, or when the program is interrupted. - procedure Free (Project : in out Project_Id); -- Free memory allocated for Project @@ -175,37 +163,77 @@ package body Prj is Last := Last + S'Length; end Add_To_Buffer; - ----------------------------- - -- Default_Ada_Body_Suffix -- - ----------------------------- + --------------------------- + -- Delete_Temporary_File -- + --------------------------- + + procedure Delete_Temporary_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type) + is + Dont_Care : Boolean; + pragma Warnings (Off, Dont_Care); - function Default_Ada_Body_Suffix return File_Name_Type is begin - return Default_Ada_Body_Suffix_Id; - end Default_Ada_Body_Suffix; + if not Debug.Debug_Flag_N then + if Current_Verbosity = High then + Write_Line ("Removing temp file: " & Get_Name_String (Path)); + end if; - ----------------------------- - -- Default_Ada_Spec_Suffix -- - ----------------------------- + Delete_File (Get_Name_String (Path), Dont_Care); - function Default_Ada_Spec_Suffix return File_Name_Type is - begin - return Default_Ada_Spec_Suffix_Id; - end Default_Ada_Spec_Suffix; + for Index in + 1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files) + loop + if Tree.Private_Part.Temp_Files.Table (Index) = Path then + Tree.Private_Part.Temp_Files.Table (Index) := No_Path; + end if; + end loop; + end if; + end Delete_Temporary_File; --------------------------- -- Delete_All_Temp_Files -- --------------------------- - procedure Delete_All_Temp_Files is + procedure Delete_All_Temp_Files (Tree : Project_Tree_Ref) is Dont_Care : Boolean; pragma Warnings (Off, Dont_Care); + + Path : Path_Name_Type; + begin if not Debug.Debug_Flag_N then - for Index in 1 .. Temp_Files.Last loop - Delete_File - (Get_Name_String (Temp_Files.Table (Index)), Dont_Care); + for Index in + 1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files) + loop + Path := Tree.Private_Part.Temp_Files.Table (Index); + + if Path /= No_Path then + if Current_Verbosity = High then + Write_Line ("Removing temp file: " + & Get_Name_String (Path)); + end if; + + Delete_File (Get_Name_String (Path), Dont_Care); + end if; end loop; + + Temp_Files_Table.Free (Tree.Private_Part.Temp_Files); + Temp_Files_Table.Init (Tree.Private_Part.Temp_Files); + end if; + + -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or + -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to + -- the empty string. On VMS, this has the effect of deassigning + -- the logical names. + + if Tree.Private_Part.Current_Source_Path_File /= No_Path then + Setenv (Project_Include_Path_File, ""); + end if; + + if Tree.Private_Part.Current_Object_Path_File /= No_Path then + Setenv (Project_Objects_Path_File, ""); end if; end Delete_All_Temp_Files; @@ -271,7 +299,8 @@ package body Prj is procedure Expect (The_Token : Token_Type; Token_Image : String) is begin if Token /= The_Token then - Error_Msg (Token_Image & " expected", Token_Ptr); + -- ??? Should pass user flags here instead + Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr); end if; end Expect; @@ -469,14 +498,72 @@ package body Prj is Reset (Seen); end For_Every_Project_Imported; - -------------- - -- Get_Mode -- - -------------- + ----------------- + -- Find_Source -- + ----------------- + + function Find_Source + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + In_Imported_Only : Boolean := False; + In_Extended_Only : Boolean := False; + Base_Name : File_Name_Type) return Source_Id + is + Result : Source_Id := No_Source; + + procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id); + -- Look for Base_Name in the sources of Proj + + ---------------------- + -- Look_For_Sources -- + ---------------------- + + procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id) is + Iterator : Source_Iterator; + + begin + Iterator := For_Each_Source (In_Tree => In_Tree, Project => Proj); + while Element (Iterator) /= No_Source loop + if Element (Iterator).File = Base_Name then + Src := Element (Iterator); + return; + end if; + + Next (Iterator); + end loop; + end Look_For_Sources; + + procedure For_Imported_Projects is new For_Every_Project_Imported + (State => Source_Id, Action => Look_For_Sources); + + Proj : Project_Id; + + -- Start of processing for Find_Source - function Get_Mode return Mode is begin - return Current_Mode; - end Get_Mode; + if In_Extended_Only then + Proj := Project; + while Proj /= No_Project loop + Look_For_Sources (Proj, Result); + exit when Result /= No_Source; + + Proj := Proj.Extends; + end loop; + + elsif In_Imported_Only then + Look_For_Sources (Project, Result); + + if Result = No_Source then + For_Imported_Projects + (By => Project, + With_State => Result); + end if; + else + Look_For_Sources (No_Project, Result); + end if; + + return Result; + end Find_Source; ---------- -- Hash -- @@ -518,25 +605,29 @@ package body Prj is return The_Casing_Images (Casing).all; end Image; + ----------------------------- + -- Is_Standard_GNAT_Naming -- + ----------------------------- + + function Is_Standard_GNAT_Naming + (Naming : Lang_Naming_Data) return Boolean + is + begin + return Get_Name_String (Naming.Spec_Suffix) = ".ads" + and then Get_Name_String (Naming.Body_Suffix) = ".adb" + and then Get_Name_String (Naming.Dot_Replacement) = "-"; + end Is_Standard_GNAT_Naming; + ---------------- -- Initialize -- ---------------- procedure Initialize (Tree : Project_Tree_Ref) is begin - if not Initialized then - Initialized := True; + if The_Empty_String = No_Name then Uintp.Initialize; Name_Len := 0; The_Empty_String := Name_Find; - Empty_Name := The_Empty_String; - Empty_File_Name := File_Name_Type (The_Empty_String); - Name_Len := 4; - Name_Buffer (1 .. 4) := ".ads"; - Default_Ada_Spec_Suffix_Id := Name_Find; - Name_Len := 4; - Name_Buffer (1 .. 4) := ".adb"; - Default_Ada_Body_Suffix_Id := Name_Find; Prj.Attr.Initialize; Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project)); @@ -549,18 +640,6 @@ package body Prj is end if; end Initialize; - ------------------- - -- Is_A_Language -- - ------------------- - - function Is_A_Language - (Project : Project_Id; - Language_Name : Name_Id) return Boolean is - begin - return Get_Language_From_Name - (Project, Get_Name_String (Language_Name)) /= null; - end Is_A_Language; - ------------------ -- Is_Extending -- ------------------ @@ -606,10 +685,12 @@ package body Prj is -- Record_Temp_File -- ---------------------- - procedure Record_Temp_File (Path : Path_Name_Type) is + procedure Record_Temp_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type) + is begin - Temp_Files.Increment_Last; - Temp_Files.Table (Temp_Files.Last) := Path; + Temp_Files_Table.Append (Tree.Private_Part.Temp_Files, Path); end Record_Temp_File; ---------- @@ -766,22 +847,13 @@ package body Prj is Array_Table.Free (Tree.Arrays); Package_Table.Free (Tree.Packages); Source_Paths_Htable.Reset (Tree.Source_Paths_HT); - Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT); Free_List (Tree.Projects, Free_Project => True); Free_Units (Tree.Units_HT); -- Private part - Path_File_Table.Free (Tree.Private_Part.Path_Files); - Source_Path_Table.Free (Tree.Private_Part.Source_Paths); - Object_Path_Table.Free (Tree.Private_Part.Object_Paths); - - Free (Tree.Private_Part.Ada_Path_Buffer); - - -- Naming data (nothing to free ???) - - null; + Temp_Files_Table.Free (Tree.Private_Part.Temp_Files); Unchecked_Free (Tree); end if; @@ -802,44 +874,17 @@ package body Prj is Array_Table.Init (Tree.Arrays); Package_Table.Init (Tree.Packages); Source_Paths_Htable.Reset (Tree.Source_Paths_HT); - Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT); Free_List (Tree.Projects, Free_Project => True); Free_Units (Tree.Units_HT); -- Private part table - Path_File_Table.Init (Tree.Private_Part.Path_Files); - Source_Path_Table.Init (Tree.Private_Part.Source_Paths); - Object_Path_Table.Init (Tree.Private_Part.Object_Paths); - - if Current_Mode = Ada_Only then - Tree.Private_Part.Current_Source_Path_File := No_Path; - Tree.Private_Part.Current_Object_Path_File := No_Path; - Tree.Private_Part.Ada_Path_Length := 0; - Tree.Private_Part.Ada_Prj_Include_File_Set := False; - Tree.Private_Part.Ada_Prj_Objects_File_Set := False; - Tree.Private_Part.Fill_Mapping_File := True; - end if; - end Reset; - - -------------- - -- Set_Mode -- - -------------- + Temp_Files_Table.Init (Tree.Private_Part.Temp_Files); - procedure Set_Mode (New_Mode : Mode) is - begin - Current_Mode := New_Mode; - - case New_Mode is - when Ada_Only => - Default_Language_Is_Ada := True; - Must_Check_Configuration := False; - when Multi_Language => - Default_Language_Is_Ada := False; - Must_Check_Configuration := True; - end case; - end Set_Mode; + Tree.Private_Part.Current_Source_Path_File := No_Path; + Tree.Private_Part.Current_Object_Path_File := No_Path; + end Reset; ------------------- -- Switches_Name -- @@ -886,29 +931,6 @@ package body Prj is return False; end Has_Ada_Sources; - ------------------------- - -- Has_Foreign_Sources -- - ------------------------- - - function Has_Foreign_Sources (Data : Project_Id) return Boolean is - Lang : Language_Ptr; - - begin - Lang := Data.Languages; - while Lang /= No_Language_Index loop - if Lang.Name /= Name_Ada - and then - (Current_Mode = Ada_Only or else Lang.First_Source /= No_Source) - then - return True; - end if; - - Lang := Lang.Next; - end loop; - - return False; - end Has_Foreign_Sources; - ------------------------ -- Contains_ALI_Files -- ------------------------ @@ -1086,7 +1108,8 @@ package body Prj is function Is_Compilable (Source : Source_Id) return Boolean is begin - return Source.Language.Config.Compiler_Driver /= Empty_File_Name + return Source.Language.Config.Compiler_Driver /= No_File + and then Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0 and then not Source.Locally_Removed; end Is_Compilable; @@ -1152,6 +1175,28 @@ package body Prj is end if; end Other_Part; + ------------------ + -- Create_Flags -- + ------------------ + + function Create_Flags + (Report_Error : Error_Handler; + When_No_Sources : Error_Warning; + Require_Sources_Other_Lang : Boolean := True; + Allow_Duplicate_Basenames : Boolean := True; + Compiler_Driver_Mandatory : Boolean := False; + Error_On_Unknown_Language : Boolean := True) return Processing_Flags + is + begin + return Processing_Flags' + (Report_Error => Report_Error, + When_No_Sources => When_No_Sources, + Require_Sources_Other_Lang => Require_Sources_Other_Lang, + Allow_Duplicate_Basenames => Allow_Duplicate_Basenames, + Error_On_Unknown_Language => Error_On_Unknown_Language, + Compiler_Driver_Mandatory => Compiler_Driver_Mandatory); + end Create_Flags; + 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 3889e66e5ea..ff2e01f0e49 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -59,10 +59,6 @@ package Prj is type Yes_No_Unknown is (Yes, No, Unknown); -- Tri-state to decide if -lgnarl is needed when linking - type Mode is (Multi_Language, Ada_Only); - -- Ada_Only: mode for gnatmake, gnatclean, gnatname, the GNAT driver - -- Multi_Language: mode for gprbuild, gprclean - type Project_Qualifier is (Unspecified, Standard, @@ -80,23 +76,6 @@ package Prj is -- Aggregate_Library: aggregate library project is ... -- Configuration: configuration project is ... - function Get_Mode return Mode; - pragma Inline (Get_Mode); - - procedure Set_Mode (New_Mode : Mode); - pragma Inline (Set_Mode); - - Default_Language_Is_Ada : Boolean := True; - -- If no language was defined in the project or the configuration file, it - -- is an error, unless this variable is True, in which case it defaults to - -- Ada. Calling Set_Mode will reset this variable, default is for Ada_Only. - - Must_Check_Configuration : Boolean := False; - -- True when the contents of the configuration file must be checked. This - -- is in general only needed by gprbuild itself, since other applications - -- can ignore such errors when they don't need to build directly. Calling - -- Set_Mode will reset this variable, default is for Ada_Only. - 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. @@ -111,32 +90,12 @@ package Prj is procedure Free (Tree : in out Project_Tree_Ref); -- Free memory associated with the tree - function Default_Ada_Spec_Suffix return File_Name_Type; - pragma Inline (Default_Ada_Spec_Suffix); - -- The name for the standard GNAT suffix for Ada spec source file name - -- ".ads". Initialized by Prj.Initialize. - - function Default_Ada_Body_Suffix return File_Name_Type; - pragma Inline (Default_Ada_Body_Suffix); - -- The name for the standard GNAT suffix for Ada body source file name - -- ".adb". Initialized by Prj.Initialize. - Config_Project_File_Extension : String := ".cgpr"; Project_File_Extension : String := ".gpr"; -- The standard config and user project file name extensions. They are not -- constants, because Canonical_Case_File_Name is called on these variables -- in the body of Prj. - type Error_Warning is (Silent, Warning, Error); - -- Severity of some situations, such as: no Ada sources in a project where - -- Ada is one of the language. - -- - -- When the situation occurs, the behaviour depends on the setting: - -- - -- - Silent: no action - -- - Warning: issue a warning, does not cause the tool to fail - -- - Error: issue an error, causes the tool to fail - function Empty_File return File_Name_Type; function Empty_String return Name_Id; -- Return the id for an empty string "" @@ -145,6 +104,7 @@ package Prj is Name : Path_Name_Type := No_Path; Display_Name : Path_Name_Type := No_Path; end record; + -- Directory names always end with a directory separator No_Path_Information : constant Path_Information := (No_Path, No_Path); @@ -391,6 +351,11 @@ package Prj is Spec_Suffix => No_File, Body_Suffix => No_File); + function Is_Standard_GNAT_Naming (Naming : Lang_Naming_Data) return Boolean; + -- True if the naming scheme is GNAT's default naming scheme. This + -- is to take into account shortened names like "Ada." (a-), "System." (s-) + -- and so on. + type Source_Data; type Source_Id is access all Source_Data; @@ -669,7 +634,7 @@ package Prj is Unit : Unit_Index := No_Unit_Index; -- Name of the unit, if language is unit based. This is only set for - -- those finles that are part of the compilation set (for instance a + -- those files that are part of the compilation set (for instance a -- file in an extended project that is overridden will not have this -- field set). @@ -1236,25 +1201,16 @@ package Prj is end record; function Empty_Project return Project_Data; - -- Return the representation of an empty project. + -- Return the representation of an empty project function Is_Extending (Extending : Project_Id; Extended : Project_Id) return Boolean; -- Return True if Extending is extending the Extended project - function Is_A_Language - (Project : Project_Id; - Language_Name : Name_Id) return Boolean; - -- Return True when Language_Name (which must be lower case) is one of the - -- languages used for the project. - function Has_Ada_Sources (Data : Project_Id) return Boolean; -- Return True if the project has Ada sources - function Has_Foreign_Sources (Data : Project_Id) return Boolean; - -- Return True if the project has foreign sources - Project_Error : exception; -- Raised by some subprograms in Prj.Attr @@ -1267,15 +1223,6 @@ package Prj is Equal => "="); -- Mapping of unit names to indexes in the Units table - package Files_Htable is new Simple_HTable - (Header_Num => Header_Num, - Element => Project_Id, - No_Element => No_Project, - Key => File_Name_Type, - Hash => Hash, - Equal => "="); - -- Mapping of file names to indexes in the Units table - --------------------- -- Source_Iterator -- --------------------- @@ -1295,6 +1242,17 @@ package Prj is procedure Next (Iter : in out Source_Iterator); -- Move on to the next source + function Find_Source + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + In_Imported_Only : Boolean := False; + In_Extended_Only : Boolean := False; + Base_Name : File_Name_Type) return Source_Id; + -- Find the first source file with the given name either in the whole tree + -- (if In_Imported_Only is False) or in the projects imported or extended + -- by Project otherwise. In_Extended_Only implies In_Imported_Only, and + -- will only look in Project and the projects it extends + ----------------------- -- Project_Tree_Data -- ----------------------- @@ -1311,22 +1269,17 @@ package Prj is Arrays : Array_Table.Instance; Packages : Package_Table.Instance; Projects : Project_List; + Units_HT : Units_Htable.Instance; - Source_Paths_HT : Source_Paths_Htable.Instance; - Unit_Sources_HT : Unit_Sources_Htable.Instance; + -- Unit name to Unit_Index (and from there so Source_Id) - -- Private part + Source_Paths_HT : Source_Paths_Htable.Instance; + -- Full path to Source_Id - Private_Part : Private_Project_Tree_Data; + Private_Part : Private_Project_Tree_Data; end record; -- Data for a project tree - type Put_Line_Access is access procedure - (Line : String; - Project : Project_Id; - In_Tree : Project_Tree_Ref); - -- Use to customize error reporting in Prj.Proc and Prj.Nmsc - procedure Expect (The_Token : Token_Type; Token_Image : String); -- Check that the current token is The_Token. If it is not, then output -- an error message. @@ -1389,16 +1342,91 @@ package Prj is (Source_File_Name : File_Name_Type) return File_Name_Type; -- Returns the switches file name corresponding to a source file name + ----------- + -- Flags -- + ----------- + + type Processing_Flags is private; + -- Flags used while parsing and processing a project tree to configure the + -- behavior of the parser, and indicate how to report error messages. This + -- structure does not allocate memory and never needs to be freed + + type Error_Warning is (Silent, Warning, Error); + -- Severity of some situations, such as: no Ada sources in a project where + -- Ada is one of the language. + -- + -- When the situation occurs, the behaviour depends on the setting: + -- + -- - Silent: no action + -- - Warning: issue a warning, does not cause the tool to fail + -- - Error: issue an error, causes the tool to fail + + type Error_Handler is access procedure + (Project : Project_Id; + Is_Warning : Boolean); + -- This warngs when an error was found when parsing a project. The error + -- itself is handled through Prj.Err (and Prj.Err.Finalize should be called + -- to actually print the error). This ensures that duplicate error messages + -- are always correctly removed, that errors msgs are sorted, and that all + -- tools will report the same error to the user. + + function Create_Flags + (Report_Error : Error_Handler; + When_No_Sources : Error_Warning; + Require_Sources_Other_Lang : Boolean := True; + Allow_Duplicate_Basenames : Boolean := True; + Compiler_Driver_Mandatory : Boolean := False; + Error_On_Unknown_Language : Boolean := True) return Processing_Flags; + -- Function used to create Processing_Flags structure + -- + -- If Allow_Duplicate_Basenames, then files with the same base names are + -- authorized within a project for source-based languages (never for unit + -- based languages). + -- + -- If Compiler_Driver_Mandatory is true, then a Compiler.Driver attribute + -- for each language must be defined, or we will not look for its source + -- files. + -- + -- When_No_Sources indicates what should be done when no sources of a + -- language are found in a project where this language is declared. + -- If Require_Sources_Other_Lang is true, then all languages must have at + -- least one source file, or an error is reported via When_No_Sources. If + -- it is false, this is only required for Ada (and only if it is a language + -- of the project). When this parameter is set to False, we do not check + -- that a proper naming scheme is defined for languages other than Ada. + -- + -- If Report_Error is null, use the standard error reporting mechanism + -- (Errout). Otherwise, report errors using Report_Error. + -- + -- If Error_On_Unknown_Language is true, an error is displayed if some of + -- the source files listed in the project do not match any naming scheme + + Gprbuild_Flags : constant Processing_Flags; + Gnatmake_Flags : constant Processing_Flags; + -- Flags used by the various tools. They all display the error messages + -- through Prj.Err. + ---------------- -- Temp Files -- ---------------- - procedure Record_Temp_File (Path : Path_Name_Type); + procedure Record_Temp_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type); -- Record the path of a newly created temporary file, so that it can be -- deleted later. - procedure Delete_All_Temp_Files; - -- Delete all recorded temporary files + procedure Delete_All_Temp_Files (Tree : Project_Tree_Ref); + -- Delete all recorded temporary files. + -- Does nothing if Debug.Debug_Flag_N is set + + procedure Delete_Temporary_File + (Tree : Project_Tree_Ref; + Path : Path_Name_Type); + -- Delete a temporary file from the disk. The file is also removed from the + -- list of temporary files to delete at the end of the program, in case + -- another program running on the same machine has recreated it. + -- Does nothing if Debug.Debug_Flag_N is set private @@ -1418,14 +1446,6 @@ private -- The prefix for virtual extending projects. Because of the '$', which is -- normally forbidden for project names, there cannot be any name clash. - Empty_Name : Name_Id; - -- Name_Id for an empty name (no characters). Initialized in procedure - -- Initialize. - - Empty_File_Name : File_Name_Type; - -- Empty File_Name_Type (no characters). Initialized in procedure - -- Initialize. - type Source_Iterator is record In_Tree : Project_Tree_Ref; @@ -1448,39 +1468,26 @@ private Last : in out Natural); -- Append a String to the Buffer - package Path_File_Table is new GNAT.Dynamic_Tables - (Table_Component_Type => Path_Name_Type, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 50, - Table_Increment => 100); - -- Table storing all the temp path file names. - -- Used by Delete_All_Path_Files. - - package Source_Path_Table is new GNAT.Dynamic_Tables - (Table_Component_Type => Name_Id, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 50, - Table_Increment => 100); - -- A table to store the source dirs before creating the source path file - - package Object_Path_Table is new GNAT.Dynamic_Tables + package Temp_Files_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Path_Name_Type, - Table_Index_Type => Natural, + Table_Index_Type => Integer, Table_Low_Bound => 1, - Table_Initial => 50, - Table_Increment => 100); - -- A table to store the object dirs, before creating the object path file + Table_Initial => 10, + Table_Increment => 10); + -- Table to store the path name of all the created temporary files, so that + -- they can be deleted at the end, or when the program is interrupted. type Private_Project_Tree_Data is record - Path_Files : Path_File_Table.Instance; - Source_Paths : Source_Path_Table.Instance; - Object_Paths : Object_Path_Table.Instance; + Temp_Files : Temp_Files_Table.Instance; + -- Temporary files created as part of running tools (pragma files, + -- mapping files,...) Current_Source_Path_File : Path_Name_Type := No_Path; -- Current value of project source path file env var. Used to avoid - -- setting the env var to the same value. + -- setting the env var to the same value. When different from No_Path, + -- this indicates that logical names (VMS) or environment variables were + -- created and should be deassigned to avoid polluting the environment + -- on VMS. -- gnatmake only Current_Object_Path_File : Path_Name_Type := No_Path; @@ -1488,30 +1495,33 @@ private -- setting the env var to the same value. -- gnatmake only - Ada_Path_Buffer : String_Access := new String (1 .. 1024); - -- A buffer where values for ADA_INCLUDE_PATH and ADA_OBJECTS_PATH are - -- stored. - -- gnatmake only - - Ada_Path_Length : Natural := 0; - -- Index of the last valid character in Ada_Path_Buffer - -- gnatmake only - - Ada_Prj_Include_File_Set : Boolean := False; - Ada_Prj_Objects_File_Set : Boolean := False; - -- These flags are set to True when the corresponding environment - -- variables are set and are used to give these environment variables an - -- empty string value at the end of the program. This has no practical - -- effect on most platforms, except on VMS where the logical names are - -- deassigned, thus avoiding the pollution of the environment of the - -- caller. - -- gnatmake only - - Fill_Mapping_File : Boolean := True; - -- gnatmake only - end record; -- Type to represent the part of a project tree which is private to the -- Project Manager. + type Processing_Flags is record + Require_Sources_Other_Lang : Boolean; + Report_Error : Error_Handler; + When_No_Sources : Error_Warning; + Allow_Duplicate_Basenames : Boolean; + Compiler_Driver_Mandatory : Boolean; + Error_On_Unknown_Language : Boolean; + end record; + + Gprbuild_Flags : constant Processing_Flags := + (Report_Error => null, + When_No_Sources => Warning, + Require_Sources_Other_Lang => True, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => True, + Error_On_Unknown_Language => True); + + Gnatmake_Flags : constant Processing_Flags := + (Report_Error => null, + When_No_Sources => Error, + Require_Sources_Other_Lang => False, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => False, + Error_On_Unknown_Language => False); + end Prj; diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index ca20709ddc8..1d9efb93b7f 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -96,11 +96,7 @@ __gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *); #ifdef IN_RTS /* For eh personality routine */ -#if (__GNUC__ * 10 + __GNUC_MINOR__ > 44) -#include "elf/dwarf2.h" -#else #include "dwarf2.h" -#endif #include "unwind-dw2-fde.h" #include "unwind-pe.h" diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 41dae0f59c9..32323fc593e 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -158,8 +158,8 @@ package body Rtsfind is -- "had semantic errors" -- -- The "not found" case is treated specially in that it is considered - -- a normal situation in configurable run-time mode (and the message in - -- this case is suppressed unless we are operating in All_Errors_Mode). + -- a normal situation in configurable run-time mode, and generates + -- a warning, but is otherwise ignored. procedure Load_RTU (U_Id : RTU_Id; @@ -537,30 +537,25 @@ package body Rtsfind is -- Output file name and reason string - if S /= "not found" - or else not Configurable_Run_Time_Mode - or else All_Errors_Mode - then - M (1 .. 6) := "\file "; - P := 6; + M (1 .. 6) := "\file "; + P := 6; - Get_Name_String - (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False)); - M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); - P := P + Name_Len; + Get_Name_String + (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False)); + M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); + P := P + Name_Len; - M (P + 1) := ' '; - P := P + 1; + M (P + 1) := ' '; + P := P + 1; - M (P + 1 .. P + S'Length) := S; - P := P + S'Length; + M (P + 1 .. P + S'Length) := S; + P := P + S'Length; - RTE_Error_Msg (M (1 .. P)); + RTE_Error_Msg (M (1 .. P)); - -- Output entity name + -- Output entity name - Output_Entity_Name (Id, "not available"); - end if; + Output_Entity_Name (Id, "not available"); -- In configurable run time mode, we raise RE_Not_Available, and the -- caller is expected to deal gracefully with this. In the case of a @@ -804,12 +799,12 @@ package body Rtsfind is procedure Maybe_Add_With (U : in out RT_Unit_Table_Record) is begin -- We do not need to generate a with_clause for a call issued from - -- RTE_Component_Available. However, for Inspector, we need these + -- RTE_Component_Available. However, for CodePeer, we need these -- additional with's, because for a sequence like "if RTE_Available (X) -- then ... RTE (X)" the RTE call fails to create some necessary -- with's. - if RTE_Available_Call and then not Inspector_Mode then + if RTE_Available_Call and then not Generate_SCIL then return; end if; @@ -869,7 +864,7 @@ package body Rtsfind is RE_Image : constant String := RE_Id'Image (Id); begin - if Id = RE_Null or else not All_Errors_Mode then + if Id = RE_Null then return; end if; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 59c9835088c..2276e80d7ab 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1193,7 +1193,6 @@ package Rtsfind is RE_Get_Reference, -- System.Partition_Interface RE_Asynchronous_P_To_Sync_Scope, -- System.Partition_Interface RE_Buffer_Stream_Type, -- System.Partition_Interface - RE_Allocate_Buffer, -- System.Partition_Interface RE_Release_Buffer, -- System.Partition_Interface RE_BS_To_Any, -- System.Partition_Interface RE_Any_To_BS, -- System.Partition_Interface @@ -2350,7 +2349,6 @@ package Rtsfind is RE_Get_Reference => System_Partition_Interface, RE_Asynchronous_P_To_Sync_Scope => System_Partition_Interface, RE_Buffer_Stream_Type => System_Partition_Interface, - RE_Allocate_Buffer => System_Partition_Interface, RE_Release_Buffer => System_Partition_Interface, RE_BS_To_Any => System_Partition_Interface, RE_Any_To_BS => System_Partition_Interface, diff --git a/gcc/ada/s-arit64.adb b/gcc/ada/s-arit64.adb index 2d18b8833bd..b6f253585c1 100644 --- a/gcc/ada/s-arit64.adb +++ b/gcc/ada/s-arit64.adb @@ -211,11 +211,7 @@ package body System.Arith_64 is end if; else - if Zhi /= 0 then - T2 := Ylo * Zhi; - else - T2 := 0; - end if; + T2 := (if Zhi /= 0 then Ylo * Zhi else 0); end if; T1 := Ylo * Zlo; @@ -254,23 +250,13 @@ package body System.Arith_64 is if X >= 0 then R := To_Int (Ru); - - if Den_Pos then - Q := To_Int (Qu); - else - Q := -To_Int (Qu); - end if; + Q := (if Den_Pos then To_Int (Qu) else -To_Int (Qu)); -- Case of dividend (X) sign negative else R := -To_Int (Ru); - - if Den_Pos then - Q := -To_Int (Qu); - else - Q := To_Int (Qu); - end if; + Q := (if Den_Pos then -To_Int (Qu) else To_Int (Qu)); end if; end Double_Divide; @@ -548,11 +534,9 @@ package body System.Arith_64 is -- which ensured the first bit of the divisor is set, this gives -- an estimate of the quotient that is at most two too high. - if D (J + 1) = Zhi then - Qd (J + 1) := 2 ** 32 - 1; - else - Qd (J + 1) := Lo ((D (J + 1) & D (J + 2)) / Zhi); - end if; + Qd (J + 1) := (if D (J + 1) = Zhi + then 2 ** 32 - 1 + else Lo ((D (J + 1) & D (J + 2)) / Zhi)); -- Compute amount to subtract @@ -598,27 +582,15 @@ package body System.Arith_64 is -- Case of dividend (X * Y) sign positive - if (X >= 0 and then Y >= 0) - or else (X < 0 and then Y < 0) - then + if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then R := To_Pos_Int (Ru); - - if Z > 0 then - Q := To_Pos_Int (Qu); - else - Q := To_Neg_Int (Qu); - end if; + Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); -- Case of dividend (X * Y) sign negative else R := To_Neg_Int (Ru); - - if Z > 0 then - Q := To_Neg_Int (Qu); - else - Q := To_Pos_Int (Qu); - end if; + Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); end if; end Scaled_Divide; diff --git a/gcc/ada/s-direio.adb b/gcc/ada/s-direio.adb index 11d2ca6a078..dee00cd3609 100644 --- a/gcc/ada/s-direio.adb +++ b/gcc/ada/s-direio.adb @@ -223,11 +223,7 @@ package body System.Direct_IO is -- last operation as other, to force the file position to be reset -- on the next read. - if File.Bytes = Size then - File.Last_Op := Op_Read; - else - File.Last_Op := Op_Other; - end if; + File.Last_Op := (if File.Bytes = Size then Op_Read else Op_Other); end Read; -- The following is the required overriding for Stream.Read, which is @@ -376,11 +372,7 @@ package body System.Direct_IO is -- last operation as other, to force the file position to be reset -- on the next write. - if File.Bytes = Size then - File.Last_Op := Op_Write; - else - File.Last_Op := Op_Other; - end if; + File.Last_Op := (if File.Bytes = Size then Op_Write else Op_Other); end Write; -- The following is the required overriding for Stream.Write, which is diff --git a/gcc/ada/s-imgdec.adb b/gcc/ada/s-imgdec.adb index efead0be17e..6ddf5e0f920 100644 --- a/gcc/ada/s-imgdec.adb +++ b/gcc/ada/s-imgdec.adb @@ -273,12 +273,7 @@ package body System.Img_Dec is -- exception is for the value zero, which by convention has an -- exponent of +0. - if Zero then - Expon := 0; - else - Expon := Digits_Before_Point - 1; - end if; - + Expon := (if Zero then 0 else Digits_Before_Point - 1); Set ('E'); ND := 0; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 694fcf1b622..b5dd2a86a7b 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -76,7 +76,6 @@ pragma Style_Checks ("M32766"); ** $ DEFINE/USER SYS$OUTPUT s-oscons-tmplt.s ** $ RUN s-oscons-tmplt ** $ RUN xoscons - ** **/ #include <stdlib.h> @@ -89,6 +88,16 @@ pragma Style_Checks ("M32766"); # define HAVE_TERMIOS #endif +#if defined (__vxworks) + +/** + ** For VxWorks, always include vxWorks.h (gsocket.h provides it only for + ** the case of runtime libraries that support sockets). + **/ + +# include <vxWorks.h> +#endif + #include "gsocket.h" #ifdef DUMMY diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/s-regpat.adb index 68d915f8ad0..8d83b93e1a3 100755 --- a/gcc/ada/s-regpat.adb +++ b/gcc/ada/s-regpat.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1999-2008, AdaCore -- +-- Copyright (C) 1999-2009, 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- -- @@ -988,29 +988,23 @@ package body System.Regpat is case (C) is when '^' => - if (Flags and Multiple_Lines) /= 0 then - IP := Emit_Node (MBOL); - elsif (Flags and Single_Line) /= 0 then - IP := Emit_Node (SBOL); - else - IP := Emit_Node (BOL); - end if; + IP := + Emit_Node + (if (Flags and Multiple_Lines) /= 0 then MBOL + elsif (Flags and Single_Line) /= 0 then SBOL + else BOL); when '$' => - if (Flags and Multiple_Lines) /= 0 then - IP := Emit_Node (MEOL); - elsif (Flags and Single_Line) /= 0 then - IP := Emit_Node (SEOL); - else - IP := Emit_Node (EOL); - end if; + IP := + Emit_Node + (if (Flags and Multiple_Lines) /= 0 then MEOL + elsif (Flags and Single_Line) /= 0 then SEOL + else EOL); when '.' => - if (Flags and Single_Line) /= 0 then - IP := Emit_Node (SANY); - else - IP := Emit_Node (ANY); - end if; + IP := + Emit_Node + (if (Flags and Single_Line) /= 0 then SANY else ANY); Expr_Flags.Has_Width := True; Expr_Flags.Simple := True; @@ -1146,15 +1140,9 @@ package body System.Regpat is begin Flags := Worst_Expression; -- Tentatively - - if First then - IP := Emit_Ptr; - else - IP := Emit_Node (BRANCH); - end if; + IP := (if First then Emit_Ptr else Emit_Node (BRANCH)); Chain := 0; - while Parse_Pos <= Parse_End and then E (Parse_Pos) /= ')' and then E (Parse_Pos) /= ASCII.LF @@ -1566,11 +1554,9 @@ package body System.Regpat is begin Parse_Pos := Parse_Pos - 1; -- Look at current character - if (Flags and Case_Insensitive) /= 0 then - IP := Emit_Node (EXACTF); - else - IP := Emit_Node (EXACT); - end if; + IP := + Emit_Node + (if (Flags and Case_Insensitive) /= 0 then EXACTF else EXACT); Length_Ptr := Emit_Ptr; Emit_Ptr := String_Operand (IP); @@ -1707,11 +1693,10 @@ package body System.Regpat is Op := Expression (Parse_Pos); - if Op /= '+' then - Expr_Flags := (SP_Start => True, others => False); - else - Expr_Flags := (Has_Width => True, others => False); - end if; + Expr_Flags := + (if Op /= '+' + then (SP_Start => True, others => False) + else (Has_Width => True, others => False)); -- Detect non greedy operators in the easy cases @@ -1840,36 +1825,23 @@ package body System.Regpat is if E (Parse_Pos .. Parse_Pos + Alnum'Length - 1) = Alnum then - if Invert then - Class := ANYOF_NALNUMC; - else - Class := ANYOF_ALNUMC; - end if; - + Class := + (if Invert then ANYOF_NALNUMC else ANYOF_ALNUMC); Parse_Pos := Parse_Pos + Alnum'Length; elsif E (Parse_Pos .. Parse_Pos + Alpha'Length - 1) = Alpha then - if Invert then - Class := ANYOF_NALPHA; - else - Class := ANYOF_ALPHA; - end if; - + Class := + (if Invert then ANYOF_NALPHA else ANYOF_ALPHA); Parse_Pos := Parse_Pos + Alpha'Length; elsif E (Parse_Pos .. Parse_Pos + Ascii_C'Length - 1) = Ascii_C then - if Invert then - Class := ANYOF_NASCII; - else - Class := ANYOF_ASCII; - end if; - + Class := + (if Invert then ANYOF_NASCII else ANYOF_ASCII); Parse_Pos := Parse_Pos + Ascii_C'Length; - else Fail ("Invalid character class: " & E); end if; @@ -1883,14 +1855,8 @@ package body System.Regpat is and then E (Parse_Pos .. Parse_Pos + Cntrl'Length - 1) = Cntrl then - if Invert then - Class := ANYOF_NCNTRL; - else - Class := ANYOF_CNTRL; - end if; - + Class := (if Invert then ANYOF_NCNTRL else ANYOF_CNTRL); Parse_Pos := Parse_Pos + Cntrl'Length; - else Fail ("Invalid character class: " & E); end if; @@ -1900,12 +1866,7 @@ package body System.Regpat is and then E (Parse_Pos .. Parse_Pos + Digit'Length - 1) = Digit then - if Invert then - Class := ANYOF_NDIGIT; - else - Class := ANYOF_DIGIT; - end if; - + Class := (if Invert then ANYOF_NDIGIT else ANYOF_DIGIT); Parse_Pos := Parse_Pos + Digit'Length; end if; @@ -1914,14 +1875,8 @@ package body System.Regpat is and then E (Parse_Pos .. Parse_Pos + Graph'Length - 1) = Graph then - if Invert then - Class := ANYOF_NGRAPH; - else - Class := ANYOF_GRAPH; - end if; - + Class := (if Invert then ANYOF_NGRAPH else ANYOF_GRAPH); Parse_Pos := Parse_Pos + Graph'Length; - else Fail ("Invalid character class: " & E); end if; @@ -1931,14 +1886,8 @@ package body System.Regpat is and then E (Parse_Pos .. Parse_Pos + Lower'Length - 1) = Lower then - if Invert then - Class := ANYOF_NLOWER; - else - Class := ANYOF_LOWER; - end if; - + Class := (if Invert then ANYOF_NLOWER else ANYOF_LOWER); Parse_Pos := Parse_Pos + Lower'Length; - else Fail ("Invalid character class: " & E); end if; @@ -1951,23 +1900,15 @@ package body System.Regpat is if E (Parse_Pos .. Parse_Pos + Print'Length - 1) = Print then - if Invert then - Class := ANYOF_NPRINT; - else - Class := ANYOF_PRINT; - end if; - + Class := + (if Invert then ANYOF_NPRINT else ANYOF_PRINT); Parse_Pos := Parse_Pos + Print'Length; elsif E (Parse_Pos .. Parse_Pos + Punct'Length - 1) = Punct then - if Invert then - Class := ANYOF_NPUNCT; - else - Class := ANYOF_PUNCT; - end if; - + Class := + (if Invert then ANYOF_NPUNCT else ANYOF_PUNCT); Parse_Pos := Parse_Pos + Punct'Length; else @@ -1983,14 +1924,8 @@ package body System.Regpat is and then E (Parse_Pos .. Parse_Pos + Space'Length - 1) = Space then - if Invert then - Class := ANYOF_NSPACE; - else - Class := ANYOF_SPACE; - end if; - + Class := (if Invert then ANYOF_NSPACE else ANYOF_SPACE); Parse_Pos := Parse_Pos + Space'Length; - else Fail ("Invalid character class: " & E); end if; @@ -2000,14 +1935,8 @@ package body System.Regpat is and then E (Parse_Pos .. Parse_Pos + Upper'Length - 1) = Upper then - if Invert then - Class := ANYOF_NUPPER; - else - Class := ANYOF_UPPER; - end if; - + Class := (if Invert then ANYOF_NUPPER else ANYOF_UPPER); Parse_Pos := Parse_Pos + Upper'Length; - else Fail ("Invalid character class: " & E); end if; @@ -2017,14 +1946,8 @@ package body System.Regpat is and then E (Parse_Pos .. Parse_Pos + Word'Length - 1) = Word then - if Invert then - Class := ANYOF_NALNUM; - else - Class := ANYOF_ALNUM; - end if; - + Class := (if Invert then ANYOF_NALNUM else ANYOF_ALNUM); Parse_Pos := Parse_Pos + Word'Length; - else Fail ("Invalid character class: " & E); end if; @@ -2034,12 +1957,7 @@ package body System.Regpat is and then E (Parse_Pos .. Parse_Pos + Xdigit'Length - 1) = Xdigit then - if Invert then - Class := ANYOF_NXDIGIT; - else - Class := ANYOF_XDIGIT; - end if; - + Class := (if Invert then ANYOF_NXDIGIT else ANYOF_XDIGIT); Parse_Pos := Parse_Pos + Xdigit'Length; else @@ -2633,11 +2551,10 @@ package body System.Regpat is N := Is_Alnum (Data (Input_Pos - 1)); end if; - if Input_Pos > Last_In_Data then - Ln := False; - else - Ln := Is_Alnum (Data (Input_Pos)); - end if; + Ln := + (if Input_Pos > Last_In_Data + then False + else Is_Alnum (Data (Input_Pos))); if Op = BOUND then if N = Ln then diff --git a/gcc/ada/s-scaval.adb b/gcc/ada/s-scaval.adb index 415763c3e6b..f1742a72a38 100644 --- a/gcc/ada/s-scaval.adb +++ b/gcc/ada/s-scaval.adb @@ -270,17 +270,14 @@ package body System.Scalar_Values is else -- Convert the two hex digits (we know they are valid here) - if C1 in '0' .. '9' then - B := Character'Pos (C1) - Character'Pos ('0'); - else - B := Character'Pos (C1) - (Character'Pos ('A') - 10); - end if; - - if C2 in '0' .. '9' then - B := B * 16 + Character'Pos (C2) - Character'Pos ('0'); - else - B := B * 16 + Character'Pos (C2) - (Character'Pos ('A') - 10); - end if; + B := 16 * (Character'Pos (C1) + - (if C1 in '0' .. '9' + then Character'Pos ('0') + else Character'Pos ('A') - 10)) + + (Character'Pos (C2) + - (if C2 in '0' .. '9' + then Character'Pos ('0') + else Character'Pos ('A') - 10)); -- Initialize data values from the hex value diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index 35fcbdf92a1..e3d30fc0cbf 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -187,11 +187,10 @@ package body System.Tasking is -- Initialize Environment Task - if Main_Priority = Unspecified_Priority then - Base_Priority := Default_Priority; - else - Base_Priority := Priority (Main_Priority); - end if; + Base_Priority := + (if Main_Priority = Unspecified_Priority + then Default_Priority + else Priority (Main_Priority)); T := STPO.New_ATCB (0); Initialize_ATCB diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 7cdde56054d..35e0dd37d63 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -405,11 +405,10 @@ package body System.Tasking.Rendezvous is -- If this is a call made inside of an abort deferred region, -- the call should be never abortable. - if Self_Id.Deferral_Level > 1 then - Entry_Call.State := Never_Abortable; - else - Entry_Call.State := Now_Abortable; - end if; + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); Entry_Call.E := Entry_Index (E); Entry_Call.Prio := Get_Priority (Self_Id); @@ -1706,11 +1705,10 @@ package body System.Tasking.Rendezvous is -- If this is a call made inside of an abort deferred region, -- the call should be never abortable. - if Self_Id.Deferral_Level > 1 then - Entry_Call.State := Never_Abortable; - else - Entry_Call.State := Now_Abortable; - end if; + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); Entry_Call.E := Entry_Index (E); Entry_Call.Prio := Get_Priority (Self_Id); diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 76e3740277d..e26a09de8ec 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -282,11 +282,10 @@ package body System.Tasking.Stages is Write_Lock (P); Write_Lock (C); - if C.Common.Base_Priority < Get_Priority (Self_ID) then - Activate_Prio := Get_Priority (Self_ID); - else - Activate_Prio := C.Common.Base_Priority; - end if; + Activate_Prio := + (if C.Common.Base_Priority < Get_Priority (Self_ID) + then Get_Priority (Self_ID) + else C.Common.Base_Priority); System.Task_Primitives.Operations.Create_Task (C, Task_Wrapper'Address, @@ -517,11 +516,10 @@ package body System.Tasking.Stages is pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C')); - if Priority = Unspecified_Priority then - Base_Priority := Self_ID.Common.Base_Priority; - else - Base_Priority := System.Any_Priority (Priority); - end if; + Base_Priority := + (if Priority = Unspecified_Priority + then Self_ID.Common.Base_Priority + else System.Any_Priority (Priority)); -- Find parent P of new Task, via master level number @@ -589,6 +587,7 @@ package body System.Tasking.Stages is -- confused when waiting for these tasks to terminate. T.Master_of_Task := Library_Task_Level; + else T.Master_of_Task := Master; end if; @@ -1075,11 +1074,10 @@ package body System.Tasking.Stages is -- Assume a size of the stack taken at this stage - if Size < Small_Stack_Limit then - Overflow_Guard := Small_Overflow_Guard; - else - Overflow_Guard := Big_Overflow_Guard; - end if; + Overflow_Guard := + (if Size < Small_Stack_Limit + then Small_Overflow_Guard + else Big_Overflow_Guard); if not Parameters.Sec_Stack_Dynamic then Self_ID.Common.Compiler_Data.Sec_Stack_Addr := diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 06102daf62e..13688e6c669 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -582,11 +582,9 @@ package body System.Tasking.Protected_Objects.Operations is Entry_Call.Mode := Mode; Entry_Call.Cancellation_Attempted := False; - if Self_ID.Deferral_Level > 1 then - Entry_Call.State := Never_Abortable; - else - Entry_Call.State := Now_Abortable; - end if; + Entry_Call.State := + (if Self_ID.Deferral_Level > 1 + then Never_Abortable else Now_Abortable); Entry_Call.E := Entry_Index (E); Entry_Call.Prio := STPO.Get_Priority (Self_ID); @@ -972,17 +970,15 @@ package body System.Tasking.Protected_Objects.Operations is pragma Debug (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " & ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); - Entry_Call := - Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; + Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; Entry_Call.Next := null; Entry_Call.Mode := Timed_Call; Entry_Call.Cancellation_Attempted := False; - if Self_Id.Deferral_Level > 1 then - Entry_Call.State := Never_Abortable; - else - Entry_Call.State := Now_Abortable; - end if; + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); Entry_Call.E := Entry_Index (E); Entry_Call.Prio := STPO.Get_Priority (Self_Id); diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb index a429903d64b..10cfca21016 100644 --- a/gcc/ada/s-tposen.adb +++ b/gcc/ada/s-tposen.adb @@ -231,12 +231,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is STPO.Timed_Sleep (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded); - if Timedout then - Entry_Call.State := Cancelled; - else - Entry_Call.State := Done; - end if; - + Entry_Call.State := (if Timedout then Cancelled else Done); Self_Id.Common.State := Runnable; end Wait_For_Completion_With_Timeout; diff --git a/gcc/ada/s-trafor-default.adb b/gcc/ada/s-trafor-default.adb index 85a66177d8d..93f0e24c5b3 100644 --- a/gcc/ada/s-trafor-default.adb +++ b/gcc/ada/s-trafor-default.adb @@ -40,8 +40,8 @@ package body System.Traces.Format is ------------------ function Format_Trace (Source : String) return String_Trace is - Length : Integer := Source'Length; - Result : String_Trace := (others => ' '); + Length : constant Integer := Source'Length; + Result : String_Trace := (others => ' '); begin -- If run-time tracing active, then fill the string @@ -52,7 +52,8 @@ package body System.Traces.Format is Result (Length + 1 .. Max_Size) := (others => ' '); Result (Length + 1) := ASCII.NUL; else - Result (1 .. Max_Size - 1) := Source (1 .. Max_Size - 1); + Result (1 .. Max_Size - 1) := + Source (Source'First .. Source'First - 1 + Max_Size - 1); Result (Max_Size) := ASCII.NUL; end if; end if; @@ -68,8 +69,8 @@ package body System.Traces.Format is (Source : String_Trace; Annex : String) return String_Trace is - Result : String_Trace := (others => ' '); - Annex_Length : Integer := Annex'Length; + Result : String_Trace := (others => ' '); + Annex_Length : constant Integer := Annex'Length; Source_Length : Integer; begin diff --git a/gcc/ada/s-valwch.adb b/gcc/ada/s-valwch.adb index fd573f88acc..b2db5005adc 100644 --- a/gcc/ada/s-valwch.adb +++ b/gcc/ada/s-valwch.adb @@ -119,7 +119,6 @@ package body System.Val_WChar is if S (F + 1) = '[' then W := Wide_Wide_Character'Val (UTF_32 ('[', WCEM_Brackets)); - else W := Wide_Wide_Character'Val (UTF_32 (S (F + 1), EM)); end if; diff --git a/gcc/ada/s-vmexta.adb b/gcc/ada/s-vmexta.adb index 51c94d6ca1b..b19e27436ea 100644 --- a/gcc/ada/s-vmexta.adb +++ b/gcc/ada/s-vmexta.adb @@ -29,7 +29,7 @@ -- -- ------------------------------------------------------------------------------ --- This is an Alpha/VMS package. +-- This is an Alpha/VMS package with System.HTable; pragma Elaborate_All (System.HTable); diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index dad352b03d4..f5beda4b2d3 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1788,7 +1788,7 @@ package body Sem is end; end loop; - -- Now traverse compilation units in order. + -- Now traverse compilation units in order Cur := First_Elmt (Comp_Unit_List); while Present (Cur) loop diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 2c40c92ad17..9bff18efb9f 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2183,11 +2183,6 @@ package body Sem_Aggr is if Etype (Imm_Type) = Base_Type (A_Type) then return True; - elsif Is_CPP_Constructor_Call (A) - and then Etype (Imm_Type) = Base_Type (Etype (A_Type)) - then - return True; - -- The base type of the parent type may appear as a private -- extension if it is declared as such in a parent unit of -- the current one. For consistency of the subsequent analysis @@ -2303,7 +2298,6 @@ package body Sem_Aggr is if Is_Class_Wide_Type (Etype (A)) and then Nkind (Original_Node (A)) = N_Function_Call - and then not Is_CPP_Constructor_Call (Original_Node (A)) then -- If the ancestor part is a dispatching call, it appears -- statically to be a legal ancestor, but it yields any @@ -2379,7 +2373,7 @@ package body Sem_Aggr is -- Builds a new N_Component_Association node which associates -- Component to expression Expr and adds it to the association -- list being built, either New_Assoc_List, or the association - -- being build for an inner aggregate. + -- being built for an inner aggregate. function Discr_Present (Discr : Entity_Id) return Boolean; -- If aggregate N is a regular aggregate this routine will return True. @@ -2795,9 +2789,7 @@ package body Sem_Aggr is -- Check wrong use of class-wide types - if Is_Class_Wide_Type (Etype (Expr)) - and then not Is_CPP_Constructor_Call (Expr) - then + if Is_Class_Wide_Type (Etype (Expr)) then Error_Msg_N ("dynamically tagged expression not allowed", Expr); end if; @@ -3100,21 +3092,7 @@ package body Sem_Aggr is -- ancestors, starting with the root. if Nkind (N) = N_Extension_Aggregate then - - -- Handle case where ancestor part is a C++ constructor. In - -- this case it must be a function returning a class-wide type. - -- If the ancestor part is a C++ constructor, then it must be a - -- function returning a class-wide type, so handle that here. - - if Is_CPP_Constructor_Call (Ancestor_Part (N)) then - pragma Assert - (Is_Class_Wide_Type (Etype (Ancestor_Part (N)))); - Root_Typ := Root_Type (Etype (Ancestor_Part (N))); - - -- Normal case, not a C++ constructor - else - Root_Typ := Base_Type (Etype (Ancestor_Part (N))); - end if; + Root_Typ := Base_Type (Etype (Ancestor_Part (N))); else Root_Typ := Root_Type (Typ); @@ -3390,7 +3368,7 @@ package body Sem_Aggr is Assoc_List : List_Id; Comp : Entity_Id); -- Nested components may themselves be discriminated - -- types constrained by outer discriminants. Their + -- types constrained by outer discriminants, whose -- values must be captured before the aggregate is -- expanded into assignments. @@ -3527,7 +3505,7 @@ package body Sem_Aggr is -- have been collected in the aggregate earlier, and -- they may appear as constraints of subcomponents. -- Similarly if this component has discriminants, they - -- might it turn be propagated to their components. + -- might in turn be propagated to their components. if Has_Discriminants (Typ) then Add_Discriminant_Values (Expr, New_Assoc_List); @@ -3546,7 +3524,7 @@ package body Sem_Aggr is begin -- If the type has additional components, create - -- an others box association for them. + -- an OTHERS box association for them. Comp := First_Component (Ctyp); while Present (Comp) loop diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 41c6a723b7f..970d3679224 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -742,7 +742,7 @@ package body Sem_Ch10 is -- in its scope. Finally we create a Units table entry for -- the subprogram declaration, to maintain a one-to-one -- correspondence with compilation unit nodes. This is - -- critical for the tree traversals performed by Codepeer. + -- critical for the tree traversals performed by CodePeer. declare Loc : constant Source_Ptr := Sloc (N); @@ -5721,7 +5721,7 @@ package body Sem_Ch10 is end if; end if; - -- Preserve structure of homonym chain. + -- Preserve structure of homonym chain Set_Homonym (E, Homonym (Lim_Typ)); end if; diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 8aedaf5be31..d54c6f8a04f 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -555,6 +555,46 @@ package body Sem_Ch11 is -- field if one is present. procedure Analyze_Raise_xxx_Error (N : Node_Id) is + + function Same_Expression (C1, C2 : Node_Id) return Boolean; + -- It often occurs that two identical raise statements are generated in + -- succession (for example when dynamic elaboration checks take place on + -- separate expressions in a call). If the two statements are identical + -- according to the simple criterion that follows, the raise is + -- converted into a null statement. + + --------------------- + -- Same_Expression -- + --------------------- + + function Same_Expression (C1, C2 : Node_Id) return Boolean is + begin + if No (C1) and then No (C2) then + return True; + + elsif Is_Entity_Name (C1) and then Is_Entity_Name (C2) then + return Entity (C1) = Entity (C2); + + elsif Nkind (C1) /= Nkind (C2) then + return False; + + elsif Nkind (C1) in N_Unary_Op then + return Same_Expression (Right_Opnd (C1), Right_Opnd (C2)); + + elsif Nkind (C1) in N_Binary_Op then + return Same_Expression (Left_Opnd (C1), Left_Opnd (C2)) + and then Same_Expression (Right_Opnd (C1), Right_Opnd (C2)); + + elsif Nkind (C1) = N_Null then + return True; + + else + return False; + end if; + end Same_Expression; + + -- Start of processing for Analyze_Raise_xxx_Error + begin if No (Etype (N)) then Set_Etype (N, Standard_Void_Type); @@ -574,6 +614,20 @@ package body Sem_Ch11 is Rewrite (N, Make_Null_Statement (Sloc (N))); end if; end if; + + -- Remove duplicate raise statements. Note that the previous one may + -- already have been removed as well. + + if not Comes_From_Source (N) + and then Nkind (N) /= N_Null_Statement + and then Is_List_Member (N) + and then Present (Prev (N)) + and then Nkind (N) = Nkind (Original_Node (Prev (N))) + and then Same_Expression + (Condition (N), Condition (Original_Node (Prev (N)))) + then + Rewrite (N, Make_Null_Statement (Sloc (N))); + end if; end Analyze_Raise_xxx_Error; ----------------------------- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 9afdb0a5a48..75b24952200 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -4374,7 +4374,7 @@ package body Sem_Ch12 is -- The new compilation unit is linked to its body, but both share the -- same file, so we do not set Body_Required on the new unit so as not -- to create a spurious dependency on a non-existent body in the ali. - -- This simplifies Codepeer unit traversal. + -- This simplifies CodePeer unit traversal. -- We use the original instantiation compilation unit as the resulting -- compilation unit of the instance, since this is the main unit. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index c61421dbcc6..2ec5334c573 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -87,9 +87,6 @@ package body Sem_Ch13 is -- Attributes that do not specify a representation characteristic are -- operational attributes. - function Address_Aliased_Entity (N : Node_Id) return Entity_Id; - -- If expression N is of the form E'Address, return E - procedure New_Stream_Subprogram (N : Node_Id; Ent : Entity_Id; @@ -164,6 +161,9 @@ package body Sem_Ch13 is Y : Entity_Id; -- The entity of the object being overlaid + + Off : Boolean; + -- Whether the address is offseted within Y end record; package Address_Clause_Checks is new Table.Table ( @@ -174,33 +174,6 @@ package body Sem_Ch13 is Table_Increment => 200, Table_Name => "Address_Clause_Checks"); - ---------------------------- - -- Address_Aliased_Entity -- - ---------------------------- - - function Address_Aliased_Entity (N : Node_Id) return Entity_Id is - begin - if Nkind (N) = N_Attribute_Reference - and then Attribute_Name (N) = Name_Address - then - declare - P : Node_Id; - - begin - P := Prefix (N); - while Nkind_In (P, N_Selected_Component, N_Indexed_Component) loop - P := Prefix (P); - end loop; - - if Is_Entity_Name (P) then - return Entity (P); - end if; - end; - end if; - - return Empty; - end Address_Aliased_Entity; - ----------------------------------------- -- Adjust_Record_For_Reverse_Bit_Order -- ----------------------------------------- @@ -906,11 +879,12 @@ package body Sem_Ch13 is Ekind (U_Ent) = E_Constant then declare - Expr : constant Node_Id := Expression (N); - Aent : constant Entity_Id := Address_Aliased_Entity (Expr); - Ent_Y : constant Entity_Id := Find_Overlaid_Object (N); + Expr : constant Node_Id := Expression (N); + O_Ent : Entity_Id; + Off : Boolean; begin + -- Exported variables cannot have an address clause, -- because this cancels the effect of the pragma Export @@ -918,12 +892,15 @@ package body Sem_Ch13 is Error_Msg_N ("cannot export object with address clause", Nam); return; + end if; + + Find_Overlaid_Entity (N, O_Ent, Off); -- Overlaying controlled objects is erroneous - elsif Present (Aent) - and then (Has_Controlled_Component (Etype (Aent)) - or else Is_Controlled (Etype (Aent))) + if Present (O_Ent) + and then (Has_Controlled_Component (Etype (O_Ent)) + or else Is_Controlled (Etype (O_Ent))) then Error_Msg_N ("?cannot overlay with controlled object", Expr); @@ -934,9 +911,9 @@ package body Sem_Ch13 is Reason => PE_Overlaid_Controlled_Object)); return; - elsif Present (Aent) + elsif Present (O_Ent) and then Ekind (U_Ent) = E_Constant - and then not Is_Constant_Object (Aent) + and then not Is_Constant_Object (O_Ent) then Error_Msg_N ("constant overlays a variable?", Expr); @@ -964,10 +941,15 @@ package body Sem_Ch13 is -- Here we are checking for explicit overlap of one variable -- by another, and if we find this then mark the overlapped -- variable as also being volatile to prevent unwanted - -- optimizations. + -- optimizations. This is a significant pessimization so + -- avoid it when there is an offset, i.e. when the object + -- is composite; they cannot be optimized easily anyway. - if Present (Ent_Y) then - Set_Treat_As_Volatile (Ent_Y); + if Present (O_Ent) + and then Is_Object (O_Ent) + and then not Off + then + Set_Treat_As_Volatile (O_Ent); end if; -- Legality checks on the address clause for initialized @@ -1015,53 +997,42 @@ package body Sem_Ch13 is -- the variable, it is somewhere else. Kill_Size_Check_Code (U_Ent); - end; - -- If the address clause is of the form: + -- If the address clause is of the form: - -- for Y'Address use X'Address + -- for Y'Address use X'Address - -- or + -- or - -- Const : constant Address := X'Address; - -- ... - -- for Y'Address use Const; + -- Const : constant Address := X'Address; + -- ... + -- for Y'Address use Const; - -- then we make an entry in the table for checking the size and - -- alignment of the overlaying variable. We defer this check - -- till after code generation to take full advantage of the - -- annotation done by the back end. This entry is only made if - -- we have not already posted a warning about size/alignment - -- (some warnings of this type are posted in Checks), and if - -- the address clause comes from source. - - if Address_Clause_Overlay_Warnings - and then Comes_From_Source (N) - then - declare - Ent_X : Entity_Id := Empty; - Ent_Y : Entity_Id := Empty; + -- then we make an entry in the table for checking the size + -- and alignment of the overlaying variable. We defer this + -- check till after code generation to take full advantage + -- of the annotation done by the back end. This entry is + -- only made if the address clause comes from source. - begin - Ent_Y := Find_Overlaid_Object (N); - - if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then - Ent_X := Entity (Name (N)); - Address_Clause_Checks.Append ((N, Ent_X, Ent_Y)); + if Address_Clause_Overlay_Warnings + and then Comes_From_Source (N) + and then Present (O_Ent) + and then Is_Object (O_Ent) + then + Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off)); - -- If variable overlays a constant view, and we are - -- warning on overlays, then mark the variable as - -- overlaying a constant (we will give warnings later - -- if this variable is assigned). + -- If variable overlays a constant view, and we are + -- warning on overlays, then mark the variable as + -- overlaying a constant (we will give warnings later + -- if this variable is assigned). - if Is_Constant_Object (Ent_Y) - and then Ekind (Ent_X) = E_Variable - then - Set_Overlays_Constant (Ent_X); - end if; + if Is_Constant_Object (O_Ent) + and then Ekind (U_Ent) = E_Variable + then + Set_Overlays_Constant (U_Ent); end if; - end; - end if; + end if; + end; -- Not a valid entity for an address clause @@ -1244,7 +1215,7 @@ package body Sem_Ch13 is if VM_Target = No_VM then Set_Has_External_Tag_Rep_Clause (U_Ent); - elsif not Inspector_Mode then + else Error_Msg_Name_1 := Attr; Error_Msg_N ("% attribute unsupported in this configuration", Nam); @@ -3225,7 +3196,7 @@ package body Sem_Ch13 is when N_Null => return; - when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test => + when N_Binary_Op | N_Short_Circuit | N_Membership_Test => Check_Expr_Constants (Left_Opnd (Nod)); Check_Expr_Constants (Right_Opnd (Nod)); @@ -4255,6 +4226,8 @@ package body Sem_Ch13 is ACCR : Address_Clause_Check_Record renames Address_Clause_Checks.Table (J); + Expr : Node_Id; + X_Alignment : Uint; Y_Alignment : Uint; @@ -4266,35 +4239,17 @@ package body Sem_Ch13 is if not Address_Warning_Posted (ACCR.N) then - -- Get alignments. Really we should always have the alignment - -- of the objects properly back annotated, but right now the - -- back end fails to back annotate for address clauses??? + Expr := Original_Node (Expression (ACCR.N)); - if Known_Alignment (ACCR.X) then - X_Alignment := Alignment (ACCR.X); - else - X_Alignment := Alignment (Etype (ACCR.X)); - end if; + -- Get alignments - if Known_Alignment (ACCR.Y) then - Y_Alignment := Alignment (ACCR.Y); - else - Y_Alignment := Alignment (Etype (ACCR.Y)); - end if; + X_Alignment := Alignment (ACCR.X); + Y_Alignment := Alignment (ACCR.Y); -- Similarly obtain sizes - if Known_Esize (ACCR.X) then - X_Size := Esize (ACCR.X); - else - X_Size := Esize (Etype (ACCR.X)); - end if; - - if Known_Esize (ACCR.Y) then - Y_Size := Esize (ACCR.Y); - else - Y_Size := Esize (Etype (ACCR.Y)); - end if; + X_Size := Esize (ACCR.X); + Y_Size := Esize (ACCR.Y); -- Check for large object overlaying smaller one @@ -4302,8 +4257,10 @@ package body Sem_Ch13 is and then X_Size > Uint_0 and then X_Size > Y_Size then + Error_Msg_NE + ("?& overlays smaller object", ACCR.N, ACCR.X); Error_Msg_N - ("?size for overlaid object is too small", ACCR.N); + ("\?program execution may be erroneous", ACCR.N); Error_Msg_Uint_1 := X_Size; Error_Msg_NE ("\?size of & is ^", ACCR.N, ACCR.X); @@ -4311,16 +4268,23 @@ package body Sem_Ch13 is Error_Msg_NE ("\?size of & is ^", ACCR.N, ACCR.Y); - -- Check for inadequate alignment. Again the defensive check - -- on Y_Alignment should not be needed, but because of the - -- failure in back end annotation, we can have an alignment - -- of 0 here??? + -- Check for inadequate alignment, both of the base object + -- and of the offset, if any. - -- Note: we do not check alignments if we gave a size - -- warning, since it would likely be redundant. + -- Note: we do not check the alignment if we gave a size + -- warning, since it would likely be redundant. elsif Y_Alignment /= Uint_0 - and then Y_Alignment < X_Alignment + and then (Y_Alignment < X_Alignment + or else (ACCR.Off + and then + Nkind (Expr) = N_Attribute_Reference + and then + Attribute_Name (Expr) = Name_Address + and then + Has_Compatible_Alignment + (ACCR.X, Prefix (Expr)) + /= Known_Compatible)) then Error_Msg_NE ("?specified address for& may be inconsistent " @@ -4337,6 +4301,11 @@ package body Sem_Ch13 is Error_Msg_NE ("\?alignment of & is ^", ACCR.N, ACCR.Y); + if Y_Alignment >= X_Alignment then + Error_Msg_N + ("\?but offset is not multiple of alignment", + ACCR.N); + end if; end if; end if; end; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 488b300ab69..00c40e7677b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -590,8 +590,8 @@ package body Sem_Ch3 is function Is_Progenitor (Iface : Entity_Id; - Typ : Entity_Id) return Boolean; - -- Determine whether type Typ implements interface Iface. This requires + Typ : Entity_Id) return Boolean; + -- Determine whether the interface Iface is implemented by Typ. It requires -- traversing the list of abstract interfaces of the type, as well as that -- of the ancestor types. The predicate is used to determine when a formal -- in the signature of an inherited operation must carry the derived type. @@ -2631,7 +2631,6 @@ package body Sem_Ch3 is if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E)) and then Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) - and then not Is_CPP_Constructor_Call (E) then Error_Msg_N ("dynamically tagged expression not allowed!", E); end if; @@ -2726,6 +2725,13 @@ package body Sem_Ch3 is then Act_T := Etype (E); + -- In case of class-wide interface object declarations we delay + -- the generation of the equivalent record type declarations until + -- its expansion because there are cases in they are not required. + + elsif Is_Interface (T) then + null; + else Expand_Subtype_From_Expr (N, T, Object_Definition (N), E); Act_T := Find_Type_Of_Object (Object_Definition (N), N); @@ -6987,13 +6993,13 @@ package body Sem_Ch3 is -- Fields inherited from the Parent_Type Set_Discard_Names - (Derived_Type, Einfo.Discard_Names (Parent_Type)); + (Derived_Type, Einfo.Discard_Names (Parent_Type)); Set_Has_Specified_Layout - (Derived_Type, Has_Specified_Layout (Parent_Type)); + (Derived_Type, Has_Specified_Layout (Parent_Type)); Set_Is_Limited_Composite - (Derived_Type, Is_Limited_Composite (Parent_Type)); + (Derived_Type, Is_Limited_Composite (Parent_Type)); Set_Is_Private_Composite - (Derived_Type, Is_Private_Composite (Parent_Type)); + (Derived_Type, Is_Private_Composite (Parent_Type)); -- Fields inherited from the Parent_Base @@ -7014,10 +7020,22 @@ package body Sem_Ch3 is -- Fields inherited from the Parent_Base for record types if Is_Record_Type (Derived_Type) then - Set_OK_To_Reorder_Components - (Derived_Type, OK_To_Reorder_Components (Parent_Base)); - Set_Reverse_Bit_Order - (Derived_Type, Reverse_Bit_Order (Parent_Base)); + + -- Ekind (Parent_Base) is not necessarily E_Record_Type since + -- Parent_Base can be a private type or private extension. + + if Present (Full_View (Parent_Base)) then + Set_OK_To_Reorder_Components + (Derived_Type, + OK_To_Reorder_Components (Full_View (Parent_Base))); + Set_Reverse_Bit_Order + (Derived_Type, Reverse_Bit_Order (Full_View (Parent_Base))); + else + Set_OK_To_Reorder_Components + (Derived_Type, OK_To_Reorder_Components (Parent_Base)); + Set_Reverse_Bit_Order + (Derived_Type, Reverse_Bit_Order (Parent_Base)); + end if; end if; -- Direct controlled types do not inherit Finalize_Storage_Only flag @@ -7049,7 +7067,6 @@ package body Sem_Ch3 is else Set_Component_Alignment (Derived_Type, Component_Alignment (Parent_Base)); - Set_C_Pass_By_Copy (Derived_Type, C_Pass_By_Copy (Parent_Base)); end if; @@ -7895,7 +7912,7 @@ package body Sem_Ch3 is -- declaration, all clauses are inherited. if No (First_Rep_Item (Def_Id)) then - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); end if; if Is_Tagged_Type (T) then @@ -16433,6 +16450,22 @@ package body Sem_Ch3 is Set_Is_CPP_Class (Full_T); Set_Convention (Full_T, Convention_CPP); end if; + + -- If the private view has user specified stream attributes, then so has + -- the full view. + + if Has_Specified_Stream_Read (Priv_T) then + Set_Has_Specified_Stream_Read (Full_T); + end if; + if Has_Specified_Stream_Write (Priv_T) then + Set_Has_Specified_Stream_Write (Full_T); + end if; + if Has_Specified_Stream_Input (Priv_T) then + Set_Has_Specified_Stream_Input (Full_T); + end if; + if Has_Specified_Stream_Output (Priv_T) then + Set_Has_Specified_Stream_Output (Full_T); + end if; end Process_Full_View; ----------------------------------- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 98cbde31d43..774d7aeac33 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2047,14 +2047,108 @@ package body Sem_Ch4 is Set_Etype (L, T_F); end if; - end Try_One_Interp; + procedure Analyze_Set_Membership; + -- If a set of alternatives is present, analyze each and find the + -- common type to which they must all resolve. + + ---------------------------- + -- Analyze_Set_Membership -- + ---------------------------- + + procedure Analyze_Set_Membership is + Alt : Node_Id; + Index : Interp_Index; + It : Interp; + Candidate_Interps : Node_Id; + Common_Type : Entity_Id := Empty; + + begin + Analyze (L); + Candidate_Interps := L; + + if not Is_Overloaded (L) then + Common_Type := Etype (L); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + Analyze (Alt); + + if not Has_Compatible_Type (Alt, Common_Type) then + Wrong_Type (Alt, Common_Type); + end if; + + Next (Alt); + end loop; + + else + Alt := First (Alternatives (N)); + while Present (Alt) loop + Analyze (Alt); + if not Is_Overloaded (Alt) then + Common_Type := Etype (Alt); + + else + Get_First_Interp (Alt, Index, It); + while Present (It.Typ) loop + if not + Has_Compatible_Type (Candidate_Interps, It.Typ) + then + Remove_Interp (Index); + end if; + + Get_Next_Interp (Index, It); + end loop; + + Get_First_Interp (Alt, Index, It); + + if No (It.Typ) then + Error_Msg_N ("alternative has no legal type", Alt); + return; + end if; + + -- If alternative is not overloaded, we have a unique type + -- for all of them. + + Set_Etype (Alt, It.Typ); + Get_Next_Interp (Index, It); + + if No (It.Typ) then + Set_Is_Overloaded (Alt, False); + Common_Type := Etype (Alt); + end if; + + Candidate_Interps := Alt; + end if; + + Next (Alt); + end loop; + end if; + + Set_Etype (N, Standard_Boolean); + + if Present (Common_Type) then + Set_Etype (L, Common_Type); + Set_Is_Overloaded (L, False); + + else + Error_Msg_N ("cannot resolve membership operation", N); + end if; + end Analyze_Set_Membership; + -- Start of processing for Analyze_Membership_Op begin Analyze_Expression (L); + if No (R) + and then Extensions_Allowed + then + Analyze_Set_Membership; + return; + end if; + if Nkind (R) = N_Range or else (Nkind (R) = N_Attribute_Reference and then Attribute_Name (R) = Name_Range) @@ -2090,6 +2184,7 @@ package body Sem_Ch4 is Set_Etype (N, Standard_Boolean); if Comes_From_Source (N) + and then Present (Right_Opnd (N)) and then Is_CPP_Class (Etype (Etype (Right_Opnd (N)))) then Error_Msg_N ("membership test not applicable to cpp-class types", N); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 4c047b49c53..fe7ffbc49c3 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -549,7 +549,6 @@ package body Sem_Ch5 is or else (Is_Dynamically_Tagged (Rhs) and then not Is_Access_Type (T1))) and then not Is_Class_Wide_Type (T1) - and then not Is_CPP_Constructor_Call (Rhs) then Error_Msg_N ("dynamically tagged expression not allowed!", Rhs); @@ -1833,6 +1832,11 @@ package body Sem_Ch5 is Set_Ekind (Id, E_Loop_Parameter); Set_Etype (Id, Etype (DS)); + + -- Treat a range as an implicit reference to the type, to + -- inhibit spurious warnings. + + Generate_Reference (Base_Type (Etype (DS)), N, ' '); Set_Is_Known_Valid (Id, True); -- The loop is not a declarative part, so the only entity diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 2fa6cf81918..009af960a24 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2637,7 +2637,7 @@ package body Sem_Ch6 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Make_Null_Statement (Loc)))); - -- Create new entities for body and formals. + -- Create new entities for body and formals Set_Defining_Unit_Name (Specification (Null_Body), Make_Defining_Identifier (Loc, Chars (Defining_Entity (N)))); @@ -5496,16 +5496,8 @@ package body Sem_Ch6 is (No (P_Formal) or else Present (Extra_Accessibility (P_Formal))) then - -- Temporary kludge: for now we avoid creating the extra formal - -- for access parameters of protected operations because of - -- problem with the case of internal protected calls. ??? - - if Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Definition - and then Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Body - then - Set_Extra_Accessibility - (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "F")); - end if; + Set_Extra_Accessibility + (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "F")); end if; -- This label is required when skipping extra formal generation for @@ -6083,7 +6075,7 @@ package body Sem_Ch6 is and then FCE (Left_Opnd (E1), Left_Opnd (E2)) and then FCE (Right_Opnd (E1), Right_Opnd (E2)); - when N_And_Then | N_Or_Else | N_Membership_Test => + when N_Short_Circuit | N_Membership_Test => return FCE (Left_Opnd (E1), Left_Opnd (E2)) and then @@ -7183,6 +7175,7 @@ package body Sem_Ch6 is or else not Is_Overloadable (Subp) or else not Is_Primitive (Subp) or else not Is_Dispatching_Operation (Subp) + or else not Present (Find_Dispatching_Type (Subp)) or else not Is_Interface (Find_Dispatching_Type (Subp)) then null; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 00ca88b1fe9..9a242d5eedd 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1518,7 +1518,7 @@ package body Sem_Ch9 is Generate_Reference (Entry_Id, Entry_Name); if Present (First_Formal (Entry_Id)) then - if VM_Target = JVM_Target and then not Inspector_Mode then + if VM_Target = JVM_Target then Error_Msg_N ("arguments unsupported in requeue statement", First_Formal (Entry_Id)); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 239742aa783..705f428716a 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -105,15 +105,13 @@ package body Sem_Disp is begin Formal := First_Formal (Subp); - while Present (Formal) loop Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); if Present (Ctrl_Type) then - -- When the controlling type is concurrent and declared within a - -- generic or inside an instance, use its corresponding record - -- type. + -- When controlling type is concurrent and declared within a + -- generic or inside an instance use corresponding record type. if Is_Concurrent_Type (Ctrl_Type) and then Present (Corresponding_Record_Type (Ctrl_Type)) @@ -124,7 +122,7 @@ package body Sem_Disp is if Ctrl_Type = Typ then Set_Is_Controlling_Formal (Formal); - -- Ada 2005 (AI-231): Anonymous access types used in + -- Ada 2005 (AI-231): Anonymous access types that are used in -- controlling parameters exclude null because it is necessary -- to read the tag to dispatch, and null has no tag. @@ -178,7 +176,10 @@ package body Sem_Disp is Next_Formal (Formal); end loop; - if Present (Etype (Subp)) then + if Ekind (Subp) = E_Function + or else + Ekind (Subp) = E_Generic_Function + then Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); if Present (Ctrl_Type) then @@ -426,14 +427,12 @@ package body Sem_Disp is else Par := Parent (N); - while Present (Par) loop - - if (Nkind (Par) = N_Function_Call or else - Nkind (Par) = N_Procedure_Call_Statement or else - Nkind (Par) = N_Assignment_Statement or else - Nkind (Par) = N_Op_Eq or else - Nkind (Par) = N_Op_Ne) + if Nkind_In (Par, N_Function_Call, + N_Procedure_Call_Statement, + N_Assignment_Statement, + N_Op_Eq, + N_Op_Ne) and then Is_Tagged_Type (Etype (Subp)) then return; @@ -471,11 +470,10 @@ package body Sem_Disp is -- Find a controlling argument, if any if Present (Parameter_Associations (N)) then - Actual := First_Actual (N); - Subp_Entity := Entity (Name (N)); - Formal := First_Formal (Subp_Entity); + Actual := First_Actual (N); + Formal := First_Formal (Subp_Entity); while Present (Actual) loop Control := Find_Controlling_Arg (Actual); exit when Present (Control); @@ -544,7 +542,6 @@ package body Sem_Disp is end if; Actual := First_Actual (N); - while Present (Actual) loop if Actual /= Control then @@ -758,7 +755,7 @@ package body Sem_Disp is E := First_Entity (Subp); while Present (E) loop - -- For an access parameter, check designated type. + -- For an access parameter, check designated type if Ekind (Etype (E)) = E_Anonymous_Access_Type then Typ := Designated_Type (Etype (E)); @@ -866,7 +863,7 @@ package body Sem_Disp is -- If the type is already frozen, the overriding is not allowed -- except when Old_Subp is not a dispatching operation (which can -- occur when Old_Subp was inherited by an untagged type). However, - -- a body with no previous spec freezes the type "after" its + -- a body with no previous spec freezes the type *after* its -- declaration, and therefore is a legal overriding (unless the type -- has already been frozen). Only the first such body is legal. @@ -880,7 +877,7 @@ package body Sem_Disp is then declare Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); - Decl_Item : Node_Id := Next (Parent (Tagged_Type)); + Decl_Item : Node_Id; begin -- ??? The checks here for whether the type has been @@ -899,6 +896,7 @@ package body Sem_Disp is -- then the type has been frozen already so the overriding -- primitive is illegal. + Decl_Item := Next (Parent (Tagged_Type)); while Present (Decl_Item) and then (Decl_Item /= Subp_Body) loop @@ -1166,8 +1164,10 @@ package body Sem_Disp is elsif Has_Controlled_Component (Tagged_Type) and then (Chars (Subp) = Name_Initialize - or else Chars (Subp) = Name_Adjust - or else Chars (Subp) = Name_Finalize) + or else + Chars (Subp) = Name_Adjust + or else + Chars (Subp) = Name_Finalize) then declare F_Node : constant Node_Id := Freeze_Node (Tagged_Type); @@ -1187,13 +1187,13 @@ package body Sem_Disp is TSS_Deep_Finalize); begin - -- Remove previous controlled function, which was constructed - -- and analyzed when the type was frozen. This requires - -- removing the body of the redefined primitive, as well as - -- its specification if needed (there is no spec created for - -- Deep_Initialize, see exp_ch3.adb). We must also dismantle - -- the exception information that may have been generated for - -- it when front end zero-cost tables are enabled. + -- Remove previous controlled function which was constructed and + -- analyzed when the type was frozen. This requires removing the + -- body of the redefined primitive, as well as its specification + -- if needed (there is no spec created for Deep_Initialize, see + -- exp_ch3.adb). We must also dismantle the exception information + -- that may have been generated for it when front end zero-cost + -- tables are enabled. for J in D_Names'Range loop Old_P := TSS (Tagged_Type, D_Names (J)); @@ -1217,9 +1217,9 @@ package body Sem_Disp is Build_Late_Proc (Tagged_Type, Chars (Subp)); - -- The new operation is added to the actions of the freeze - -- node for the type, but this node has already been analyzed, - -- so we must retrieve and analyze explicitly the new body. + -- The new operation is added to the actions of the freeze node + -- for the type, but this node has already been analyzed, so we + -- must retrieve and analyze explicitly the new body. if Present (F_Node) and then Present (Actions (F_Node)) @@ -1264,14 +1264,10 @@ package body Sem_Disp is F1 := First_Formal (Proc); F2 := First_Formal (Subp); - while Present (F1) and then Present (F2) loop - if Ekind (Etype (F1)) = E_Anonymous_Access_Type then - if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then return False; - elsif Designated_Type (Etype (F1)) = Parent_Typ and then Designated_Type (Etype (F2)) /= Full then @@ -1304,11 +1300,8 @@ package body Sem_Disp is Op1 := First_Elmt (Old_Prim); Op2 := First_Elmt (New_Prim); - while Present (Op1) and then Present (Op2) loop - if Derives_From (Node (Op1)) then - if No (Prev) then -- Avoid adding it to the list of primitives if already there! @@ -1346,7 +1339,7 @@ package body Sem_Disp is Set_Scope (Subp, Current_Scope); Tagged_Type := Find_Dispatching_Type (Subp); - -- Add Old_Subp to primitive operations if not already present. + -- Add Old_Subp to primitive operations if not already present if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type)); @@ -1371,6 +1364,7 @@ package body Sem_Disp is then declare Formal : Entity_Id; + begin Formal := First_Formal (Old_Subp); while Present (Formal) loop @@ -1397,8 +1391,8 @@ package body Sem_Disp is -- Otherwise, update its alias and other attributes. if Present (Alias (Old_Subp)) - and then Nkind (Unit_Declaration_Node (Old_Subp)) - /= N_Subprogram_Renaming_Declaration + and then Nkind (Unit_Declaration_Node (Old_Subp)) /= + N_Subprogram_Renaming_Declaration then Set_Alias (Old_Subp, Alias (Subp)); @@ -1461,24 +1455,22 @@ package body Sem_Disp is Typ := Etype (N); if Is_Access_Type (Typ) then - -- In the case of an Access attribute, use the type of - -- the prefix, since in the case of an actual for an - -- access parameter, the attribute's type may be of a - -- specific designated type, even though the prefix - -- type is class-wide. + + -- In the case of an Access attribute, use the type of the prefix, + -- since in the case of an actual for an access parameter, the + -- attribute's type may be of a specific designated type, even + -- though the prefix type is class-wide. if Nkind (N) = N_Attribute_Reference then Typ := Etype (Prefix (N)); - -- An allocator is dispatching if the type of qualified - -- expression is class_wide, in which case this is the - -- controlling type. + -- An allocator is dispatching if the type of qualified expression + -- is class_wide, in which case this is the controlling type. elsif Nkind (Orig_Node) = N_Allocator and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression then Typ := Etype (Expression (Orig_Node)); - else Typ := Designated_Type (Typ); end if; @@ -1560,6 +1552,7 @@ package body Sem_Disp is end if; end if; + pragma Assert (not Is_Dispatching_Operation (Subp)); return Empty; end Find_Dispatching_Type; @@ -1775,10 +1768,12 @@ package body Sem_Disp is -- even if non-dispatching, and a call from inside calls the -- overriding operation because it hides the implicit one. To -- indicate that the body of Prev_Op is never called, set its - -- dispatch table entity to Empty. + -- dispatch table entity to Empty. If the overridden operation + -- has a dispatching result, so does the overriding one. Set_Alias (Prev_Op, New_Op); Set_DTC_Entity (Prev_Op, Empty); + Set_Has_Controlling_Result (New_Op, Has_Controlling_Result (Prev_Op)); return; end if; end Override_Dispatching_Operation; @@ -1798,9 +1793,9 @@ package body Sem_Disp is elsif Nkind (Actual) = N_Identifier and then Nkind (Original_Node (Actual)) = N_Function_Call then - -- Call rewritten as object declaration when stack-checking - -- is enabled. Propagate tag to expression in declaration, which - -- is original call. + -- Call rewritten as object declaration when stack-checking is + -- enabled. Propagate tag to expression in declaration, which is + -- original call. Call_Node := Expression (Parent (Entity (Actual))); @@ -1821,8 +1816,8 @@ package body Sem_Disp is Call_Node := Expression (Actual); end if; - -- Do not set the Controlling_Argument if already set. This happens - -- in the special case of _Input (see Exp_Attr, case Input). + -- Do not set the Controlling_Argument if already set. This happens in + -- the special case of _Input (see Exp_Attr, case Input). if No (Controlling_Argument (Call_Node)) then Set_Controlling_Argument (Call_Node, Control); @@ -1839,8 +1834,8 @@ package body Sem_Disp is end loop; -- Expansion of dispatching calls is suppressed when VM_Target, because - -- the VM back-ends directly handle the generation of dispatching - -- calls and would have to undo any expansion to an indirect call. + -- the VM back-ends directly handle the generation of dispatching calls + -- and would have to undo any expansion to an indirect call. if Tagged_Type_Expansion then Expand_Dispatching_Call (Call_Node); diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 1e948f09566..d06d1d081fc 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -2905,7 +2905,8 @@ package body Sem_Eval is Left_Int := Expr_Value (Left); if (Kind = N_And_Then and then Is_False (Left_Int)) - or else (Kind = N_Or_Else and Is_True (Left_Int)) + or else + (Kind = N_Or_Else and then Is_True (Left_Int)) then Fold_Uint (N, Left_Int, Rstat); return; @@ -4955,7 +4956,7 @@ package body Sem_Eval is "(RM 4.9(5))!", N, E); end if; - when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test => + when N_Binary_Op | N_Short_Circuit | N_Membership_Test => if Nkind (N) in N_Op_Shift then Error_Msg_N ("shift functions are never static (RM 4.9(6,18))!", N); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 885d1b885db..45dc5f90d23 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -35,6 +35,7 @@ with Checks; use Checks; with Csets; use Csets; with Debug; use Debug; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; with Exp_Dist; use Exp_Dist; with Lib; use Lib; @@ -3553,73 +3554,67 @@ package body Sem_Prag is elsif Is_Record_Type (Def_Id) and then C = Convention_CPP then - if not Is_Tagged_Type (Def_Id) then - Error_Msg_Sloc := Sloc (Def_Id); - Error_Pragma_Arg ("imported 'C'P'P type must be tagged", Arg2); - - else - -- Types treated as CPP classes are treated as limited, but we - -- don't require them to be declared this way. A warning is - -- issued to encourage the user to declare them as limited. - -- This is not an error, for compatibility reasons, because - -- these types have been supported this way for some time. + -- Types treated as CPP classes are treated as limited, but we + -- don't require them to be declared this way. A warning is + -- issued to encourage the user to declare them as limited. + -- This is not an error, for compatibility reasons, because + -- these types have been supported this way for some time. - if not Is_Limited_Type (Def_Id) then - Error_Msg_N - ("imported 'C'P'P type should be " & - "explicitly declared limited?", - Get_Pragma_Arg (Arg2)); - Error_Msg_N - ("\type will be considered limited", - Get_Pragma_Arg (Arg2)); - end if; + if not Is_Limited_Type (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type should be " & + "explicitly declared limited?", + Get_Pragma_Arg (Arg2)); + Error_Msg_N + ("\type will be considered limited", + Get_Pragma_Arg (Arg2)); + end if; - Set_Is_CPP_Class (Def_Id); - Set_Is_Limited_Record (Def_Id); + Set_Is_CPP_Class (Def_Id); + Set_Is_Limited_Record (Def_Id); - -- Imported CPP types must not have discriminants (because C++ - -- classes do not have discriminants). + -- Imported CPP types must not have discriminants (because C++ + -- classes do not have discriminants). - if Has_Discriminants (Def_Id) then - Error_Msg_N - ("imported 'C'P'P type cannot have discriminants", - First (Discriminant_Specifications - (Declaration_Node (Def_Id)))); - end if; + if Has_Discriminants (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type cannot have discriminants", + First (Discriminant_Specifications + (Declaration_Node (Def_Id)))); + end if; - -- Components of imported CPP types must not have default - -- expressions because the constructor (if any) is in the - -- C++ side. + -- Components of imported CPP types must not have default + -- expressions because the constructor (if any) is on the + -- C++ side. - declare - Tdef : constant Node_Id := - Type_Definition (Declaration_Node (Def_Id)); - Clist : Node_Id; - Comp : Node_Id; + declare + Tdef : constant Node_Id := + Type_Definition (Declaration_Node (Def_Id)); + Clist : Node_Id; + Comp : Node_Id; - begin - if Nkind (Tdef) = N_Record_Definition then - Clist := Component_List (Tdef); + begin + if Nkind (Tdef) = N_Record_Definition then + Clist := Component_List (Tdef); - else - pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); - Clist := Component_List (Record_Extension_Part (Tdef)); - end if; + else + pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); + Clist := Component_List (Record_Extension_Part (Tdef)); + end if; - if Present (Clist) then - Comp := First (Component_Items (Clist)); - while Present (Comp) loop - if Present (Expression (Comp)) then - Error_Msg_N - ("component of imported 'C'P'P type cannot have" & - " default expression", Expression (Comp)); - end if; + if Present (Clist) then + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + if Present (Expression (Comp)) then + Error_Msg_N + ("component of imported 'C'P'P type cannot have" & + " default expression", Expression (Comp)); + end if; - Next (Comp); - end loop; - end if; - end; - end if; + Next (Comp); + end loop; + end if; + end; else Error_Pragma_Arg @@ -6272,8 +6267,10 @@ package body Sem_Prag is -- [, [Link_Name =>] static_string_EXPRESSION ]); when Pragma_CPP_Constructor => CPP_Constructor : declare - Id : Entity_Id; - Def_Id : Entity_Id; + Elmt : Elmt_Id; + Id : Entity_Id; + Def_Id : Entity_Id; + Tag_Typ : Entity_Id; begin GNAT_Pragma; @@ -6294,8 +6291,10 @@ package body Sem_Prag is Def_Id := Entity (Id); if Ekind (Def_Id) = E_Function - and then Is_Class_Wide_Type (Etype (Def_Id)) - and then Is_CPP_Class (Etype (Etype (Def_Id))) + and then (Is_CPP_Class (Etype (Def_Id)) + or else (Is_Class_Wide_Type (Etype (Def_Id)) + and then + Is_CPP_Class (Root_Type (Etype (Def_Id))))) then if Arg_Count >= 2 then Set_Imported (Def_Id); @@ -6306,6 +6305,36 @@ package body Sem_Prag is Set_Has_Completion (Def_Id); Set_Is_Constructor (Def_Id); + -- Imported C++ constructors are not dispatching primitives + -- because in C++ they don't have a dispatch table slot. + -- However, in Ada the constructor has the profile of a + -- function that returns a tagged type and therefore it has + -- been treated as a primitive operation during semantic + -- analysis. We now remove it from the list of primitive + -- operations of the type. + + if Is_Tagged_Type (Etype (Def_Id)) + and then not Is_Class_Wide_Type (Etype (Def_Id)) + then + pragma Assert (Is_Dispatching_Operation (Def_Id)); + Tag_Typ := Etype (Def_Id); + + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) and then Node (Elmt) /= Def_Id loop + Next_Elmt (Elmt); + end loop; + + Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); + Set_Is_Dispatching_Operation (Def_Id, False); + end if; + + -- For backward compatibility, if the constructor returns a + -- class wide type, and we internally change the return type to + -- the corresponding root type. + + if Is_Class_Wide_Type (Etype (Def_Id)) then + Set_Etype (Def_Id, Root_Type (Etype (Def_Id))); + end if; else Error_Pragma_Arg ("pragma% requires function returning a 'C'P'P_Class type", @@ -11248,9 +11277,11 @@ package body Sem_Prag is Arg := Expression (Arg1); -- The expression is used in the call to Create_Task, and must be - -- expanded there, not in the context of the current spec. + -- expanded there, not in the context of the current spec. It must + -- however be analyzed to capture global references, in case it + -- appears in a generic context. - Preanalyze_And_Resolve (New_Copy_Tree (Arg), Standard_String); + Preanalyze_And_Resolve (Arg, Standard_String); if Nkind (P) /= N_Task_Definition then Pragma_Misplaced; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3af4785a026..48fed245fc5 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -675,6 +675,7 @@ package body Sem_Res is elsif Ada_Version >= Ada_05 and then Is_Entity_Name (Pref) + and then Is_Access_Type (Etype (Pref)) and then Ekind (Directly_Designated_Type (Etype (Pref))) = E_Incomplete_Type and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref))) @@ -2492,7 +2493,7 @@ package body Sem_Res is when N_Allocator => Resolve_Allocator (N, Ctx_Type); - when N_And_Then | N_Or_Else + when N_Short_Circuit => Resolve_Short_Circuit (N, Ctx_Type); when N_Attribute_Reference @@ -3982,17 +3983,9 @@ package body Sem_Res is Check_Unset_Reference (Expression (E)); -- A qualified expression requires an exact match of the type, - -- class-wide matching is not allowed. We skip this test in a call - -- to a CPP constructor because in such case, although the function - -- profile indicates that it returns a class-wide type, the object - -- returned by the C++ constructor has a concrete type. + -- class-wide matching is not allowed. - if Is_Class_Wide_Type (Etype (Expression (E))) - and then Is_CPP_Constructor_Call (Expression (E)) - then - null; - - elsif (Is_Class_Wide_Type (Etype (Expression (E))) + if (Is_Class_Wide_Type (Etype (Expression (E))) or else Is_Class_Wide_Type (Etype (E))) and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) then @@ -6741,16 +6734,52 @@ package body Sem_Res is procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is pragma Warnings (Off, Typ); - L : constant Node_Id := Left_Opnd (N); + L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); T : Entity_Id; + procedure Resolve_Set_Membership; + -- Analysis has determined a unique type for the left operand. + -- Use it to resolve the disjuncts. + + ---------------------------- + -- Resolve_Set_Membership -- + ---------------------------- + + procedure Resolve_Set_Membership is + Alt : Node_Id; + + begin + Resolve (L, Etype (L)); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + + -- Alternative is an expression, a range + -- or a subtype mark. + + if not Is_Entity_Name (Alt) + or else not Is_Type (Entity (Alt)) + then + Resolve (Alt, Etype (L)); + end if; + + Next (Alt); + end loop; + end Resolve_Set_Membership; + + -- Start of processing for Resolve_Membership_Op + begin if L = Error or else R = Error then return; end if; - if not Is_Overloaded (R) + if Present (Alternatives (N)) then + Resolve_Set_Membership; + return; + + elsif not Is_Overloaded (R) and then (Etype (R) = Universal_Integer or else Etype (R) = Universal_Real) @@ -7607,7 +7636,7 @@ package body Sem_Res is -- Generate cross-reference. We needed to wait until full overloading -- resolution was complete to do this, since otherwise we can't tell if - -- we are an Lvalue of not. + -- we are an lvalue or not. if May_Be_Lvalue (N) then Generate_Reference (Entity (S), S, 'm'); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 5883e3fe867..fad78d49d9b 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -1204,9 +1204,9 @@ package body Sem_Type is -- for special handling of expressions with universal operands, see -- comments to Has_Abstract_Interpretation below. - ------------------------ - -- In_Generic_Actual -- - ------------------------ + ----------------------- + -- In_Generic_Actual -- + ----------------------- function In_Generic_Actual (Exp : Node_Id) return Boolean is Par : constant Node_Id := Parent (Exp); @@ -2147,9 +2147,8 @@ package body Sem_Type is ------------------------- function Has_Compatible_Type - (N : Node_Id; - Typ : Entity_Id) - return Boolean + (N : Node_Id; + Typ : Entity_Id) return Boolean is I : Interp_Index; It : Interp; @@ -2597,9 +2596,8 @@ package body Sem_Type is --------------------------- function Is_Invisible_Operator - (N : Node_Id; - T : Entity_Id) - return Boolean + (N : Node_Id; + T : Entity_Id) return Boolean is Orig_Node : constant Node_Id := Original_Node (N); @@ -2809,9 +2807,8 @@ package body Sem_Type is and then Base_Type (T1) = Base_Type (T) and then Is_Numeric_Type (T); - -- for division and multiplication, a user-defined function does - -- not match the predefined universal_fixed operation, except in - -- Ada83 mode. + -- For division and multiplication, a user-defined function does not + -- match the predefined universal_fixed operation, except in Ada 83. elsif Op_Name = Name_Op_Divide then return (Base_Type (T1) = Base_Type (T2) @@ -2892,7 +2889,7 @@ package body Sem_Type is II : Interp_Index; begin - -- Find end of Interp list and copy downward to erase the discarded one + -- Find end of interp list and copy downward to erase the discarded one II := I + 1; while Present (All_Interp.Table (II).Typ) loop @@ -2903,7 +2900,7 @@ package body Sem_Type is All_Interp.Table (J - 1) := All_Interp.Table (J); end loop; - -- Back up interp. index to insure that iterator will pick up next + -- Back up interp index to insure that iterator will pick up next -- available interpretation. I := I - 1; diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index 879432435fd..cfbc579bf08 100644 --- a/gcc/ada/sem_type.ads +++ b/gcc/ada/sem_type.ads @@ -103,10 +103,7 @@ package Sem_Type is -- in N. If the name is an expanded name, the homonyms are only those that -- belong to the same scope. - function Is_Invisible_Operator - (N : Node_Id; - T : Entity_Id) - return Boolean; + function Is_Invisible_Operator (N : Node_Id; T : Entity_Id) return Boolean; -- Check whether a predefined operation with universal operands appears in -- a context in which the operators of the expected type are not visible. @@ -172,8 +169,7 @@ package Sem_Type is function Disambiguate (N : Node_Id; I1, I2 : Interp_Index; - Typ : Entity_Id) - return Interp; + Typ : Entity_Id) return Interp; -- If more than one interpretation of a name in a call is legal, apply -- preference rules (universal types first) and operator visibility in -- order to remove ambiguity. I1 and I2 are the first two interpretations @@ -191,10 +187,7 @@ package Sem_Type is -- right operand, which has one interpretation compatible with that of L. -- Return the type intersection of the two. - function Has_Compatible_Type - (N : Node_Id; - Typ : Entity_Id) - return Boolean; + function Has_Compatible_Type (N : Node_Id; Typ : Entity_Id) return Boolean; -- Verify that some interpretation of the node N has a type compatible with -- Typ. If N is not overloaded, then its unique type must be compatible -- with Typ. Otherwise iterate through the interpretations of N looking for @@ -220,11 +213,11 @@ package Sem_Type is function Is_Ancestor (T1, T2 : Entity_Id) return Boolean; -- T1 is a tagged type (not class-wide). Verify that it is one of the - -- ancestors of type T2 (which may or not be class-wide) + -- ancestors of type T2 (which may or not be class-wide). function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean; -- Checks whether T1 is any subtype of T2 directly or indirectly. Applies - -- only to scalar subtypes ??? + -- only to scalar subtypes??? function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean; -- Used to resolve subprograms renaming operators, and calls to user diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c2706007a70..7a0108511fb 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2892,11 +2892,15 @@ package body Sem_Util is end Find_Corresponding_Discriminant; -------------------------- - -- Find_Overlaid_Object -- + -- Find_Overlaid_Entity -- -------------------------- - function Find_Overlaid_Object (N : Node_Id) return Entity_Id is - Expr : Node_Id; + procedure Find_Overlaid_Entity + (N : Node_Id; + Ent : out Entity_Id; + Off : out Boolean) + is + Expr : Node_Id; begin -- We are looking for one of the two following forms: @@ -2912,24 +2916,25 @@ package body Sem_Util is -- In the second case, the expr is either Y'Address, or recursively a -- constant that eventually references Y'Address. + Ent := Empty; + Off := False; + if Nkind (N) = N_Attribute_Definition_Clause and then Chars (N) = Name_Address then - -- This loop checks the form of the expression for Y'Address where Y - -- is an object entity name. The first loop checks the original - -- expression in the attribute definition clause. Subsequent loops - -- check referenced constants. - Expr := Expression (N); + + -- This loop checks the form of the expression for Y'Address, + -- using recursion to deal with intermediate constants. + loop - -- Check for Y'Address where Y is an object entity + -- Check for Y'Address if Nkind (Expr) = N_Attribute_Reference and then Attribute_Name (Expr) = Name_Address - and then Is_Entity_Name (Prefix (Expr)) - and then Is_Object (Entity (Prefix (Expr))) then - return Entity (Prefix (Expr)); + Expr := Prefix (Expr); + exit; -- Check for Const where Const is a constant entity @@ -2941,13 +2946,36 @@ package body Sem_Util is -- Anything else does not need checking else - exit; + return; end if; end loop; - end if; - return Empty; - end Find_Overlaid_Object; + -- This loop checks the form of the prefix for an entity, + -- using recursion to deal with intermediate components. + + loop + -- Check for Y where Y is an entity + + if Is_Entity_Name (Expr) then + Ent := Entity (Expr); + return; + + -- Check for components + + elsif + Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) then + + Expr := Prefix (Expr); + Off := True; + + -- Anything else does not need checking + + else + return; + end if; + end loop; + end if; + end Find_Overlaid_Entity; ------------------------- -- Find_Parameter_Type -- @@ -3829,16 +3857,16 @@ package body Sem_Util is Default : Alignment_Result) return Alignment_Result is Result : Alignment_Result := Known_Compatible; - -- Set to result if Problem_Prefix or Problem_Offset returns True. - -- Note that once a value of Known_Incompatible is set, it is sticky - -- and does not get changed to Unknown (the value in Result only gets - -- worse as we go along, never better). + -- Holds the current status of the result. Note that once a value of + -- Known_Incompatible is set, it is sticky and does not get changed + -- to Unknown (the value in Result only gets worse as we go along, + -- never better). - procedure Check_Offset (Offs : Uint); - -- Called when Expr is a selected or indexed component with Offs set - -- to resp Component_First_Bit or Component_Size. Checks that if the - -- offset is specified it is compatible with the object alignment - -- requirements. The value in Result is modified accordingly. + Offs : Uint := No_Uint; + -- Set to a factor of the offset from the base object when Expr is a + -- selected or indexed component, based on Component_Bit_Offset and + -- Component_Size respectively. A negative value is used to represent + -- a value which is not known at compile time. procedure Check_Prefix; -- Checks the prefix recursively in the case where the expression @@ -3849,33 +3877,6 @@ package body Sem_Util is -- compatible, or known incompatible), then set Result to R. ------------------ - -- Check_Offset -- - ------------------ - - procedure Check_Offset (Offs : Uint) is - begin - -- Unspecified or zero offset is always OK - - if Offs = No_Uint or else Offs = Uint_0 then - null; - - -- If we do not know required alignment, any non-zero offset is - -- a potential problem (but certainly may be OK, so result is - -- unknown). - - elsif Unknown_Alignment (Obj) then - Set_Result (Unknown); - - -- If we know the required alignment, see if offset is compatible - - else - if Offs mod (System_Storage_Unit * Alignment (Obj)) /= 0 then - Set_Result (Known_Incompatible); - end if; - end if; - end Check_Offset; - - ------------------ -- Check_Prefix -- ------------------ @@ -3940,37 +3941,60 @@ package body Sem_Util is Set_Result (Unknown); end if; - -- Check possible bad component offset and check prefix + -- Check prefix and component offset - Check_Offset - (Component_Bit_Offset (Entity (Selector_Name (Expr)))); Check_Prefix; + Offs := Component_Bit_Offset (Entity (Selector_Name (Expr))); -- If Expr is an indexed component, we must make sure there is no -- potentially troublesome Component_Size clause and that the array -- is not bit-packed. elsif Nkind (Expr) = N_Indexed_Component then + declare + Typ : constant Entity_Id := Etype (Prefix (Expr)); + Ind : constant Node_Id := First_Index (Typ); - -- Bit packed array always generates unknown alignment + begin + -- Bit packed array always generates unknown alignment - if Is_Bit_Packed_Array (Etype (Prefix (Expr))) then - Set_Result (Unknown); - end if; + if Is_Bit_Packed_Array (Typ) then + Set_Result (Unknown); + end if; - -- Check possible bad component size and check prefix + -- Check prefix and component offset - Check_Offset (Component_Size (Etype (Prefix (Expr)))); - Check_Prefix; + Check_Prefix; + Offs := Component_Size (Typ); + + -- Small optimization: compute the full offset when possible + + if Offs /= No_Uint + and then Offs > Uint_0 + and then Present (Ind) + and then Nkind (Ind) = N_Range + and then Compile_Time_Known_Value (Low_Bound (Ind)) + and then Compile_Time_Known_Value (First (Expressions (Expr))) + then + Offs := Offs * (Expr_Value (First (Expressions (Expr))) + - Expr_Value (Low_Bound ((Ind)))); + end if; + end; end if; + -- If we have a null offset, the result is entirely determined by + -- the base object and has already been computed recursively. + + if Offs = Uint_0 then + null; + -- Case where we know the alignment of the object - if Known_Alignment (Obj) then + elsif Known_Alignment (Obj) then declare ObjA : constant Uint := Alignment (Obj); - ExpA : Uint := No_Uint; - SizA : Uint := No_Uint; + ExpA : Uint := No_Uint; + SizA : Uint := No_Uint; begin -- If alignment of Obj is 1, then we are always OK @@ -3981,9 +4005,16 @@ package body Sem_Util is -- Alignment of Obj is greater than 1, so we need to check else - -- See if Expr is an object with known alignment + -- If we have an offset, see if it is compatible + + if Offs /= No_Uint and Offs > Uint_0 then + if Offs mod (System_Storage_Unit * ObjA) /= 0 then + Set_Result (Known_Incompatible); + end if; + + -- See if Expr is an object with known alignment - if Is_Entity_Name (Expr) + elsif Is_Entity_Name (Expr) and then Known_Alignment (Entity (Expr)) then ExpA := Alignment (Entity (Expr)); @@ -3995,26 +4026,29 @@ package body Sem_Util is elsif Known_Alignment (Etype (Expr)) then ExpA := Alignment (Etype (Expr)); + + -- Otherwise the alignment is unknown + + else + Set_Result (Default); end if; -- If we got an alignment, see if it is acceptable - if ExpA /= No_Uint then - if ExpA < ObjA then - Set_Result (Known_Incompatible); - end if; + if ExpA /= No_Uint and then ExpA < ObjA then + Set_Result (Known_Incompatible); + end if; - -- Case of Expr alignment unknown + -- If Expr is not a piece of a larger object, see if size + -- is given. If so, check that it is not too small for the + -- required alignment. - else - Set_Result (Default); - end if; + if Offs /= No_Uint then + null; - -- See if size is given. If so, check that it is not too - -- small for the required alignment. - -- See if Expr is an object with known alignment + -- See if Expr is an object with known size - if Is_Entity_Name (Expr) + elsif Is_Entity_Name (Expr) and then Known_Static_Esize (Entity (Expr)) then SizA := Esize (Entity (Expr)); @@ -4038,6 +4072,12 @@ package body Sem_Util is end if; end; + -- If we do not know required alignment, any non-zero offset is a + -- potential problem (but certainly may be OK, so result is unknown). + + elsif Offs /= No_Uint then + Set_Result (Unknown); + -- If we can't find the result by direct comparison of alignment -- values, then there is still one case that we can determine known -- result, and that is when we can determine that the types are the @@ -4059,8 +4099,8 @@ package body Sem_Util is if Known_Alignment (Entity (Expr)) and then - UI_To_Int (Alignment (Entity (Expr))) - < Ttypes.Maximum_Alignment + UI_To_Int (Alignment (Entity (Expr))) < + Ttypes.Maximum_Alignment then Set_Result (Unknown); @@ -4073,7 +4113,7 @@ package body Sem_Util is and then (UI_To_Int (Esize (Entity (Expr))) mod (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) - /= 0 + /= 0 then Set_Result (Unknown); @@ -4090,7 +4130,7 @@ package body Sem_Util is -- Unknown, since that result will be set in any case. elsif Default /= Unknown - and then (Has_Size_Clause (Etype (Expr)) + and then (Has_Size_Clause (Etype (Expr)) or else Has_Alignment_Clause (Etype (Expr))) then @@ -4129,17 +4169,16 @@ package body Sem_Util is ---------------------- function Has_Declarations (N : Node_Id) return Boolean is - K : constant Node_Kind := Nkind (N); - begin - return K = N_Accept_Statement - or else K = N_Block_Statement - or else K = N_Compilation_Unit_Aux - or else K = N_Entry_Body - or else K = N_Package_Body - or else K = N_Protected_Body - or else K = N_Subprogram_Body - or else K = N_Task_Body - or else K = N_Package_Specification; + begin + return Nkind_In (Nkind (N), N_Accept_Statement, + N_Block_Statement, + N_Compilation_Unit_Aux, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body, + N_Package_Specification); end Has_Declarations; ------------------------------------------- @@ -4897,26 +4936,22 @@ package body Sem_Util is is Ifaces_List : Elist_Id; Elmt : Elmt_Id; - Iface : Entity_Id; - Typ : Entity_Id; + Iface : Entity_Id := Base_Type (Iface_Ent); + Typ : Entity_Id := Base_Type (Typ_Ent); begin - if Is_Class_Wide_Type (Typ_Ent) then - Typ := Etype (Typ_Ent); - else - Typ := Typ_Ent; - end if; - - if Is_Class_Wide_Type (Iface_Ent) then - Iface := Etype (Iface_Ent); - else - Iface := Iface_Ent; + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); end if; if not Has_Interfaces (Typ) then return False; end if; + if Is_Class_Wide_Type (Iface) then + Iface := Root_Type (Iface); + end if; + Collect_Interfaces (Typ, Ifaces_List); Elmt := First_Elmt (Ifaces_List); @@ -5530,7 +5565,6 @@ package body Sem_Util is function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is begin return Nkind (N) = N_Function_Call - and then Is_Class_Wide_Type (Etype (N)) and then Is_CPP_Class (Etype (Etype (N))) and then Is_Constructor (Entity (Name (N))) and then Is_Imported (Entity (Name (N))); @@ -7288,11 +7322,11 @@ package body Sem_Util is return False; end if; - -- For a selected component A.B, A is certainly an Lvalue if A.B is - -- an Lvalue. B is a little interesting, if we have A.B:=3, there is - -- some discussion as to whether B is an Lvalue or not, we choose to - -- say it is. Note however that A is not an Lvalue if it is of an - -- access type since this is an implicit dereference. + -- For a selected component A.B, A is certainly an lvalue if A.B is. + -- B is a little interesting, if we have A.B := 3, there is some + -- discussion as to whether B is an lvalue or not, we choose to say + -- it is. Note however that A is not an lvalue if it is of an access + -- type since this is an implicit dereference. when N_Selected_Component => if N = Prefix (P) @@ -7305,8 +7339,8 @@ package body Sem_Util is end if; -- For an indexed component or slice, the index or slice bounds is - -- never an Lvalue. The prefix is an lvalue if the indexed component - -- or slice is an Lvalue, except if it is an access type, where we + -- never an lvalue. The prefix is an lvalue if the indexed component + -- or slice is an lvalue, except if it is an access type, where we -- have an implicit dereference. when N_Indexed_Component => @@ -7318,17 +7352,17 @@ package body Sem_Util is return May_Be_Lvalue (P); end if; - -- Prefix of a reference is an Lvalue if the reference is an Lvalue + -- Prefix of a reference is an lvalue if the reference is an lvalue when N_Reference => return May_Be_Lvalue (P); - -- Prefix of explicit dereference is never an Lvalue + -- Prefix of explicit dereference is never an lvalue when N_Explicit_Dereference => return False; - -- Function call arguments are never Lvalues + -- Function call arguments are never lvalues when N_Function_Call => return False; @@ -7425,7 +7459,7 @@ package body Sem_Util is when N_Object_Renaming_Declaration => return True; - -- All other references are definitely not Lvalues + -- All other references are definitely not lvalues when others => return False; @@ -9820,10 +9854,12 @@ package body Sem_Util is P := Parent (N); while Present (P) loop - if Nkind (P) = N_If_Statement + if Nkind (P) = N_If_Statement or else Nkind (P) = N_Case_Statement - or else (Nkind (P) = N_And_Then and then Desc = Right_Opnd (P)) - or else (Nkind (P) = N_Or_Else and then Desc = Right_Opnd (P)) + or else (Nkind (P) in N_Short_Circuit + and then Desc = Right_Opnd (P)) + or else (Nkind (P) = N_Conditional_Expression + and then Desc /= First (Expressions (P))) or else Nkind (P) = N_Exception_Handler or else Nkind (P) = N_Selective_Accept or else Nkind (P) = N_Conditional_Entry_Call diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b4adabf26a9..44d6c3ef5be 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -320,12 +320,16 @@ package Sem_Util is -- denotes when analyzed. Subsequent uses of this id on a different -- type denote the discriminant at the same position in this new type. - function Find_Overlaid_Object (N : Node_Id) return Entity_Id; - -- The node N should be an address representation clause. This function - -- checks if the target expression is the address of some stand alone - -- object (variable or constant), and if so, returns its entity. If N is - -- not an address representation clause, or if it is not possible to - -- determine that the address is of this form, then Empty is returned. + procedure Find_Overlaid_Entity + (N : Node_Id; + Ent : out Entity_Id; + Off : out Boolean); + -- The node N should be an address representation clause. Determines if the + -- target expression is the address of an entity with an optional offset. + -- If so, Ent is set to the entity and, if there is an offset, Off is set + -- to True, otherwise to False. If N is not an address representation + -- clause, or if it is not possible to determine that the address is of + -- this form, then Ent is set to Empty, and Off is set to False. function Find_Parameter_Type (Param : Node_Id) return Entity_Id; -- Return the type of formal parameter Param as determined by its diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index b6163375031..e483d051504 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -475,7 +475,7 @@ package body Sem_Warn is and then Present (Entity (N)) and then Entity (N) = Var then - -- If this is an Lvalue, then definitely abandon, since + -- If this is an lvalue, then definitely abandon, since -- this could be a direct modification of the variable. if May_Be_Lvalue (N) then @@ -2997,6 +2997,12 @@ package body Sem_Warn is Warn_On_Unrepped_Components := True; Warn_On_Warnings_Off := True; + when 'm' => + Warn_On_Suspicious_Modulus_Value := True; + + when 'M' => + Warn_On_Suspicious_Modulus_Value := False; + when 'o' => Warn_On_All_Unread_Out_Parameters := True; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 866dd5f72cd..2ed3ad3ff85 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -229,7 +229,9 @@ package body Sinfo is (N : Node_Id) return List_Id is begin pragma Assert (False - or else NT (N).Nkind = N_Case_Statement); + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_In + or else NT (N).Nkind = N_Not_In); return List4 (N); end Alternatives; @@ -3034,7 +3036,9 @@ package body Sinfo is (N : Node_Id; Val : List_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_Case_Statement); + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_In + or else NT (N).Nkind = N_Not_In); Set_List4_With_Parent (N, Val); end Set_Alternatives; @@ -5818,6 +5822,31 @@ package body Sinfo is T = V8; end Nkind_In; + + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind; + V9 : Node_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6 or else + T = V7 or else + T = V8 or else + T = V9; + end Nkind_In; + ----------------- -- Pragma_Name -- ----------------- diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index ad96467e61b..5f741077ce5 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -671,7 +671,6 @@ package Sinfo is -- Comes_From_Extended_Return_Statement (Flag18-Sem) -- Present in N_Simple_Return_Statement nodes. True if this node was -- constructed as part of the N_Extended_Return_Statement expansion. - -- . -- Compile_Time_Known_Aggregate (Flag18-Sem) -- Present in N_Aggregate nodes. Set for aggregates which can be fully @@ -3472,23 +3471,38 @@ package Sinfo is -- SIMPLE_EXPRESSION [not] in RANGE -- | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK - -- Note: although the grammar above allows only a range or a - -- subtype mark, the parser in fact will accept any simple - -- expression in place of a subtype mark. This means that the - -- semantic analyzer must be prepared to deal with, and diagnose - -- a simple expression other than a name for the right operand. - -- This simplifies error recovery in the parser. + -- Note: although the grammar above allows only a range or a subtype + -- mark, the parser in fact will accept any simple expression in place + -- of a subtype mark. This means that the semantic analyzer must be able + -- to deal with, and diagnose a simple expression other than a name for + -- the right operand. This simplifies error recovery in the parser. + + -- If extensions are enabled, the grammar is as follows: + + -- RELATION ::= + -- SIMPLE_EXPRESSION [not] in SET_ALTERNATIVE {| SET_ALTERNATIVE} + + -- SET_ALTERNATIVE ::= RANGE | SUBTYPE_MARK + + -- The Alternatives field below is present only if there is more than + -- one Set_Alternative present, in which case Right_Opnd is set to + -- Empty, and Alternatives contains the list of alternatives. In the + -- tree passed to the back end, Alternatives is always No_List, and + -- Right_Opnd is set (i.e. the expansion circuitry expands out the + -- complex set membership case using simple membership operations). -- N_In -- Sloc points to IN -- Left_Opnd (Node2) -- Right_Opnd (Node3) + -- Alternatives (List4) (set to No_List if only one set alternative) -- plus fields for expression -- N_Not_In -- Sloc points to NOT of NOT IN -- Left_Opnd (Node2) -- Right_Opnd (Node3) + -- Alternatives (List4) (set to No_List if only one set alternative) -- plus fields for expression -------------------- @@ -7044,16 +7058,19 @@ package Sinfo is N_In, N_Not_In, - -- N_Subexpr, N_Has_Etype + -- N_Subexpr, N_Has_Etype, N_Short_Circuit N_And_Then, + N_Or_Else, + + -- N_Subexpr, N_Has_Etype + N_Conditional_Expression, N_Explicit_Dereference, N_Function_Call, N_Indexed_Component, N_Integer_Literal, N_Null, - N_Or_Else, N_Procedure_Call_Statement, N_Qualified_Expression, @@ -7438,6 +7455,10 @@ package Sinfo is N_At_Clause .. N_Attribute_Definition_Clause; + subtype N_Short_Circuit is Node_Kind range + N_And_Then .. + N_Or_Else; + subtype N_Statement_Other_Than_Procedure_Call is Node_Kind range N_Abort_Statement .. N_If_Statement; @@ -9349,6 +9370,18 @@ package Sinfo is V7 : Node_Kind; V8 : Node_Kind) return Boolean; + function Nkind_In + (T : Node_Kind; + V1 : Node_Kind; + V2 : Node_Kind; + V3 : Node_Kind; + V4 : Node_Kind; + V5 : Node_Kind; + V6 : Node_Kind; + V7 : Node_Kind; + V8 : Node_Kind; + V9 : Node_Kind) return Boolean; + pragma Inline (Nkind_In); -- Inline all above functions @@ -9750,14 +9783,14 @@ package Sinfo is (1 => False, -- unused 2 => True, -- Left_Opnd (Node2) 3 => True, -- Right_Opnd (Node3) - 4 => False, -- unused + 4 => True, -- Alternatives (List4) 5 => False), -- Etype (Node5-Sem) N_Not_In => (1 => False, -- unused 2 => True, -- Left_Opnd (Node2) 3 => True, -- Right_Opnd (Node3) - 4 => False, -- unused + 4 => True, -- Alternatives (List4) 5 => False), -- Etype (Node5-Sem) N_Op_And => diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 3ae79182c8c..86d95f3371b 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1885,7 +1885,12 @@ package body Sprint is when N_In => Sprint_Left_Opnd (Node); Write_Str_Sloc (" in "); - Sprint_Right_Opnd (Node); + + if Present (Right_Opnd (Node)) then + Sprint_Right_Opnd (Node); + else + Sprint_Bar_List (Alternatives (Node)); + end if; when N_Incomplete_Type_Declaration => Write_Indent_Str_Sloc ("type "); @@ -1984,7 +1989,12 @@ package body Sprint is when N_Not_In => Sprint_Left_Opnd (Node); Write_Str_Sloc (" not in "); - Sprint_Right_Opnd (Node); + + if Present (Right_Opnd (Node)) then + Sprint_Right_Opnd (Node); + else + Sprint_Bar_List (Alternatives (Node)); + end if; when N_Null => Write_Str_With_Col_Check_Sloc ("null"); diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index c860af4e410..f0acc45c766 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -228,6 +228,12 @@ package body Switch.C is Ptr := Ptr + 1; Operating_Mode := Check_Semantics; + -- Processing for C switch + + when 'C' => + Ptr := Ptr + 1; + CodePeer_Mode := True; + -- Processing for d switch when 'd' => @@ -358,6 +364,14 @@ package body Switch.C is return; + -- -gnateC switch (CodePeer SCIL generation) + -- Not enabled for now, keep it for later??? + -- use -gnatd.I only for now + + -- when 'C' => + -- Ptr := Ptr + 1; + -- Generate_SCIL := True; + -- -gnateD switch (preprocessing symbol definition) when 'D' => diff --git a/gcc/ada/symbols-processing-vms-ia64.adb b/gcc/ada/symbols-processing-vms-ia64.adb index 0eb1af7e4d6..beb099e40b0 100644 --- a/gcc/ada/symbols-processing-vms-ia64.adb +++ b/gcc/ada/symbols-processing-vms-ia64.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -85,9 +85,14 @@ package body Processing is Stname : Integer; Stinfo : Character; + Stother : Character; Sttype : Integer; Stbind : Integer; Stshndx : Integer; + Stvis : Integer; + + STV_Internal : constant := 1; + STV_Hidden : constant := 2; Section_Headers : Section_Header_Ptr; @@ -340,7 +345,7 @@ package body Processing is while Offset < End_Symtab loop Get_Word (Stname); Get_Byte (Stinfo); - Get_Byte (B); + Get_Byte (Stother); Get_Half (Stshndx); for J in 1 .. 4 loop Get_Word (W); @@ -348,10 +353,13 @@ package body Processing is Sttype := Integer'(Character'Pos (Stinfo)) mod 16; Stbind := Integer'(Character'Pos (Stinfo)) / 16; + Stvis := Integer'(Character'Pos (Stother)) mod 4; if (Sttype = 1 or else Sttype = 2) and then Stbind /= 0 and then Stshndx /= 0 + and then Stvis /= STV_Internal + and then Stvis /= STV_Hidden then -- Check if this is a symbol from a generic body diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 395a7137659..be882055af4 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -436,6 +436,18 @@ package body Tbuild is Strval => End_String); end Make_String_Literal; + function Make_Temporary + (Loc : Source_Ptr; + Id : Name_Id; + Related_Node : Node_Id := Empty) return Node_Id + is + Temp : Node_Id; + begin + Temp := Make_Defining_Identifier (Loc, Id); + Set_Related_Expression (Temp, Related_Node); + return Temp; + end Make_Temporary; + --------------------------- -- Make_Unsuppress_Block -- --------------------------- diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index efa8960516f..f12b616c93a 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -175,6 +175,14 @@ package Tbuild is -- A convenient form of Make_String_Literal, where the string value -- is given as a normal string instead of a String_Id value. + function Make_Temporary + (Loc : Source_Ptr; + Id : Name_Id; + Related_Node : Node_Id := Empty) return Node_Id; + -- Create a defining identifier to capture the value of an expression + -- or aggregate, and link it to the expression that it replaces, in + -- order to provide better CodePeer reports. + function Make_Unsuppress_Block (Loc : Source_Ptr; Check : Name_Id; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 5fb53ae339e..c2f0770f29e 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -949,8 +949,7 @@ package body Treepr is -- Deal with Left_Opnd and Right_Opnd fields if Nkind (N) in N_Op - or else Nkind (N) = N_And_Then - or else Nkind (N) = N_Or_Else + or else Nkind (N) in N_Short_Circuit or else Nkind (N) in N_Membership_Test then -- Print Left_Opnd if present diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index 61191ef9644..68851c39617 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -148,6 +148,8 @@ gcc -c ^ GNAT COMPILE -gnatwL ^ /WARNINGS=NOELABORATION -gnatwm ^ /WARNINGS=MODIFIED_UNREF -gnatwM ^ /WARNINGS=NOMODIFIED_UNREF +-gnatw.m ^ /WARNINGS=SUSPICIOUS_MODULUES +-gnatw.M ^ /WARNINGS=NOSUSPICIOUS_MODULUES -gnatwn ^ /WARNINGS=NORMAL -gnatwo ^ /WARNINGS=OVERLAYS -gnatwO ^ /WARNINGS=NOOVERLAYS diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 76d9a25b4a4..47e78997559 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -150,6 +150,11 @@ begin Write_Switch_Char ("c"); Write_Line ("Check syntax and semantics only (no code generation)"); + -- Line for -gnatC switch + + Write_Switch_Char ("C"); + Write_Line ("Generate CodePeer information (no code generation)"); + -- Line for -gnatd switch Write_Switch_Char ("d?"); @@ -428,6 +433,8 @@ begin "but not read"); Write_Line (" M* turn off warnings for variable assigned " & "but not read"); + Write_Line (" .m* turn on warnings for suspicious modulus value"); + Write_Line (" .M turn off warnings for suspicious modulus value"); Write_Line (" n* normal warning mode (cancels -gnatws/-gnatwe)"); Write_Line (" o* turn on warnings for address clause overlay"); Write_Line (" O turn off warnings for address clause overlay"); diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index a8565c3d2e2..b4ee226c673 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -2914,6 +2914,10 @@ package VMS_Data is "-gnatwm " & "NOMODIFIED_UNREF " & "-gnatwM " & + "SUSPICIOUS_MODULUS " & + "-gnatw.m " & + "NOSUSPICIOUS_MODULUS " & + "-gnatw.M " & "NORMAL " & "-gnatwn " & "OVERLAYS " & diff --git a/gcc/ada/vxaddr2line.adb b/gcc/ada/vxaddr2line.adb index 1fd85ec506f..f1bb48a7428 100644 --- a/gcc/ada/vxaddr2line.adb +++ b/gcc/ada/vxaddr2line.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2008, AdaCore -- +-- Copyright (C) 2002-2009, 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- -- @@ -75,7 +75,7 @@ with GNAT.Regpat; use GNAT.Regpat; procedure VxAddr2Line is package Unsigned_32_IO is new Modular_IO (Unsigned_32); - -- Instantiate Modular_IO to have Put. + -- Instantiate Modular_IO to have Put Ref_Symbol : constant String := "adainit"; -- This is the name of the reference symbol which runtime address shall diff --git a/gcc/alias.c b/gcc/alias.c index 248600179f8..e9cc2d85f96 100644 --- a/gcc/alias.c +++ b/gcc/alias.c @@ -46,6 +46,9 @@ along with GCC; see the file COPYING3. If not see #include "tree-pass.h" #include "ipa-type-escape.h" #include "df.h" +#include "tree-ssa-alias.h" +#include "pointer-set.h" +#include "tree-flow.h" /* The aliasing API provided here solves related but different problems: @@ -249,6 +252,98 @@ DEF_VEC_ALLOC_P(alias_set_entry,gc); /* The splay-tree used to store the various alias set entries. */ static GTY (()) VEC(alias_set_entry,gc) *alias_sets; +/* Build a decomposed reference object for querying the alias-oracle + from the MEM rtx and store it in *REF. + Returns false if MEM is not suitable for the alias-oracle. */ + +static bool +ao_ref_from_mem (ao_ref *ref, const_rtx mem) +{ + tree expr = MEM_EXPR (mem); + tree base; + + if (!expr) + return false; + + ao_ref_init (ref, expr); + + /* Get the base of the reference and see if we have to reject or + adjust it. */ + base = ao_ref_base (ref); + if (base == NULL_TREE) + return false; + + /* If this is a pointer dereference of a non-SSA_NAME punt. + ??? We could replace it with a pointer to anything. */ + if (INDIRECT_REF_P (base) + && TREE_CODE (TREE_OPERAND (base, 0)) != SSA_NAME) + return false; + + /* If this is a reference based on a partitioned decl replace the + base with an INDIRECT_REF of the pointer representative we + created during stack slot partitioning. */ + if (TREE_CODE (base) == VAR_DECL + && ! TREE_STATIC (base) + && cfun->gimple_df->decls_to_pointers != NULL) + { + void *namep; + namep = pointer_map_contains (cfun->gimple_df->decls_to_pointers, base); + if (namep) + { + ref->base_alias_set = get_alias_set (base); + ref->base = build1 (INDIRECT_REF, TREE_TYPE (base), *(tree *)namep); + } + } + + ref->ref_alias_set = MEM_ALIAS_SET (mem); + + /* For NULL MEM_OFFSET the MEM_EXPR may have been stripped arbitrarily + without recording offset or extent adjustments properly. */ + if (MEM_OFFSET (mem) == NULL_RTX) + { + ref->offset = 0; + ref->max_size = -1; + } + else + { + ref->offset += INTVAL (MEM_OFFSET (mem)) * BITS_PER_UNIT; + } + + /* NULL MEM_SIZE should not really happen with a non-NULL MEM_EXPR, + but just play safe here. The size may have been adjusted together + with the offset, so we need to take it if it is set and not rely + on MEM_EXPR here (which has the size determining parts potentially + stripped anyway). We lose precision for max_size which is only + available from the remaining MEM_EXPR. */ + if (MEM_SIZE (mem) == NULL_RTX) + { + ref->size = -1; + ref->max_size = -1; + } + else + { + ref->size = INTVAL (MEM_SIZE (mem)) * BITS_PER_UNIT; + } + + return true; +} + +/* Query the alias-oracle on whether the two memory rtx X and MEM may + alias. If TBAA_P is set also apply TBAA. Returns true if the + two rtxen may alias, false otherwise. */ + +static bool +rtx_refs_may_alias_p (const_rtx x, const_rtx mem, bool tbaa_p) +{ + ao_ref ref1, ref2; + + if (!ao_ref_from_mem (&ref1, x) + || !ao_ref_from_mem (&ref2, mem)) + return true; + + return refs_may_alias_p_1 (&ref1, &ref2, tbaa_p); +} + /* Returns a pointer to the alias set entry for ALIAS_SET, if there is such an entry, or NULL otherwise. */ @@ -2191,8 +2286,10 @@ true_dependence (const_rtx mem, enum machine_mode mem_mode, const_rtx x, if (mem_mode == BLKmode || GET_MODE (x) == BLKmode) return 1; - return ! fixed_scalar_and_varying_struct_p (mem, x, mem_addr, x_addr, - varies); + if (fixed_scalar_and_varying_struct_p (mem, x, mem_addr, x_addr, varies)) + return 0; + + return rtx_refs_may_alias_p (x, mem, true); } /* Canonical true dependence: X is read after store in MEM takes place. @@ -2255,8 +2352,10 @@ canon_true_dependence (const_rtx mem, enum machine_mode mem_mode, rtx mem_addr, if (mem_mode == BLKmode || GET_MODE (x) == BLKmode) return 1; - return ! fixed_scalar_and_varying_struct_p (mem, x, mem_addr, x_addr, - varies); + if (fixed_scalar_and_varying_struct_p (mem, x, mem_addr, x_addr, varies)) + return 0; + + return rtx_refs_may_alias_p (x, mem, true); } /* Returns nonzero if a write to X might alias a previous read from @@ -2316,8 +2415,11 @@ write_dependence_p (const_rtx mem, const_rtx x, int writep) = fixed_scalar_and_varying_struct_p (mem, x, mem_addr, x_addr, rtx_addr_varies_p); - return (!(fixed_scalar == mem && !aliases_everything_p (x)) - && !(fixed_scalar == x && !aliases_everything_p (mem))); + if ((fixed_scalar == mem && !aliases_everything_p (x)) + || (fixed_scalar == x && !aliases_everything_p (mem))) + return 0; + + return rtx_refs_may_alias_p (x, mem, false); } /* Anti dependence: X is written after read in MEM takes place. */ diff --git a/gcc/builtins.c b/gcc/builtins.c index de1984e5ab5..a5f41fc91f8 100644 --- a/gcc/builtins.c +++ b/gcc/builtins.c @@ -344,6 +344,16 @@ get_object_alignment (tree exp, unsigned int align, unsigned int max_align) return MIN (align, max_align); } +/* Returns true iff we can trust that alignment information has been + calculated properly. */ + +bool +can_trust_pointer_alignment (void) +{ + /* We rely on TER to compute accurate alignment information. */ + return (optimize && flag_tree_ter); +} + /* Return the alignment in bits of EXP, a pointer valued expression. But don't return more than MAX_ALIGN no matter what. The alignment returned is, by default, the alignment of the thing that @@ -357,8 +367,7 @@ get_pointer_alignment (tree exp, unsigned int max_align) { unsigned int align, inner; - /* We rely on TER to compute accurate alignment information. */ - if (!(optimize && flag_tree_ter)) + if (!can_trust_pointer_alignment ()) return 0; if (!POINTER_TYPE_P (TREE_TYPE (exp))) diff --git a/gcc/c-common.c b/gcc/c-common.c index 1c883d15308..20dac6b2ef4 100644 --- a/gcc/c-common.c +++ b/gcc/c-common.c @@ -8266,11 +8266,13 @@ c_warn_unused_result (gimple_seq seq) location_t loc = gimple_location (g); if (fdecl) - warning_at (loc, 0, "ignoring return value of %qD, " + warning_at (loc, OPT_Wunused_result, + "ignoring return value of %qD, " "declared with attribute warn_unused_result", fdecl); else - warning_at (loc, 0, "ignoring return value of function " + warning_at (loc, OPT_Wunused_result, + "ignoring return value of function " "declared with attribute warn_unused_result"); } break; diff --git a/gcc/c.opt b/gcc/c.opt index e8a9a31a382..5ee9a1348d4 100644 --- a/gcc/c.opt +++ b/gcc/c.opt @@ -488,6 +488,10 @@ Wunused-macros C ObjC C++ ObjC++ Warning Warn about macros defined in the main file that are not used +Wunused-result +C ObjC C++ ObjC++ Var(warn_unused_result) Init(1) Warning +Warn if a caller of a function, marked with attribute warn_unused_result, does not use its return value + Wvariadic-macros C ObjC C++ ObjC++ Warning Do not warn about using variadic macros when -pedantic diff --git a/gcc/cfgexpand.c b/gcc/cfgexpand.c index 62b5c4515d1..359433922d5 100644 --- a/gcc/cfgexpand.c +++ b/gcc/cfgexpand.c @@ -784,6 +784,133 @@ stack_var_size_cmp (const void *a, const void *b) return 0; } + +/* If the points-to solution *PI points to variables that are in a partition + together with other variables add all partition members to the pointed-to + variables bitmap. */ + +static void +add_partitioned_vars_to_ptset (struct pt_solution *pt, + struct pointer_map_t *decls_to_partitions, + struct pointer_set_t *visited, bitmap temp) +{ + bitmap_iterator bi; + unsigned i; + bitmap *part; + + if (pt->anything + || pt->vars == NULL + /* The pointed-to vars bitmap is shared, it is enough to + visit it once. */ + || pointer_set_insert(visited, pt->vars)) + return; + + bitmap_clear (temp); + + /* By using a temporary bitmap to store all members of the partitions + we have to add we make sure to visit each of the partitions only + once. */ + EXECUTE_IF_SET_IN_BITMAP (pt->vars, 0, i, bi) + if ((!temp + || !bitmap_bit_p (temp, i)) + && (part = (bitmap *) pointer_map_contains (decls_to_partitions, + (void *)(size_t) i))) + bitmap_ior_into (temp, *part); + if (!bitmap_empty_p (temp)) + bitmap_ior_into (pt->vars, temp); +} + +/* Update points-to sets based on partition info, so we can use them on RTL. + The bitmaps representing stack partitions will be saved until expand, + where partitioned decls used as bases in memory expressions will be + rewritten. */ + +static void +update_alias_info_with_stack_vars (void) +{ + struct pointer_map_t *decls_to_partitions = NULL; + size_t i, j; + tree var = NULL_TREE; + + for (i = 0; i < stack_vars_num; i++) + { + bitmap part = NULL; + tree name; + struct ptr_info_def *pi; + + /* Not interested in partitions with single variable. */ + if (stack_vars[i].representative != i + || stack_vars[i].next == EOC) + continue; + + if (!decls_to_partitions) + { + decls_to_partitions = pointer_map_create (); + cfun->gimple_df->decls_to_pointers = pointer_map_create (); + } + + /* Create an SSA_NAME that points to the partition for use + as base during alias-oracle queries on RTL for bases that + have been partitioned. */ + if (var == NULL_TREE) + var = create_tmp_var (ptr_type_node, NULL); + name = make_ssa_name (var, NULL); + + /* Create bitmaps representing partitions. They will be used for + points-to sets later, so use GGC alloc. */ + part = BITMAP_GGC_ALLOC (); + for (j = i; j != EOC; j = stack_vars[j].next) + { + tree decl = stack_vars[j].decl; + unsigned int uid = DECL_UID (decl); + /* We should never end up partitioning SSA names (though they + may end up on the stack). Neither should we allocate stack + space to something that is unused and thus unreferenced. */ + gcc_assert (DECL_P (decl) + && referenced_var_lookup (uid)); + bitmap_set_bit (part, uid); + *((bitmap *) pointer_map_insert (decls_to_partitions, + (void *)(size_t) uid)) = part; + *((tree *) pointer_map_insert (cfun->gimple_df->decls_to_pointers, + decl)) = name; + } + + /* Make the SSA name point to all partition members. */ + pi = get_ptr_info (name); + pt_solution_set (&pi->pt, part); + } + + /* Make all points-to sets that contain one member of a partition + contain all members of the partition. */ + if (decls_to_partitions) + { + unsigned i; + struct pointer_set_t *visited = pointer_set_create (); + bitmap temp = BITMAP_ALLOC (NULL); + + for (i = 1; i < num_ssa_names; i++) + { + tree name = ssa_name (i); + struct ptr_info_def *pi; + + if (name + && POINTER_TYPE_P (TREE_TYPE (name)) + && ((pi = SSA_NAME_PTR_INFO (name)) != NULL)) + add_partitioned_vars_to_ptset (&pi->pt, decls_to_partitions, + visited, temp); + } + + add_partitioned_vars_to_ptset (&cfun->gimple_df->escaped, + decls_to_partitions, visited, temp); + add_partitioned_vars_to_ptset (&cfun->gimple_df->callused, + decls_to_partitions, visited, temp); + + pointer_set_destroy (visited); + pointer_map_destroy (decls_to_partitions); + BITMAP_FREE (temp); + } +} + /* A subroutine of partition_stack_vars. The UNION portion of a UNION/FIND partitioning algorithm. Partitions A and B are known to be non-conflicting. Merge them into a single partition A. @@ -903,6 +1030,9 @@ partition_stack_vars (void) break; } } + + if (optimize) + update_alias_info_with_stack_vars (); } /* A debugging aid for expand_used_vars. Dump the generated partitions. */ @@ -1164,9 +1294,11 @@ expand_one_var (tree var, bool toplevel, bool really_expand) variables, which won't be on stack, we collect alignment of type and ignore user specified alignment. */ if (TREE_STATIC (var) || DECL_EXTERNAL (var)) - align = TYPE_ALIGN (TREE_TYPE (var)); + align = MINIMUM_ALIGNMENT (TREE_TYPE (var), + TYPE_MODE (TREE_TYPE (var)), + TYPE_ALIGN (TREE_TYPE (var))); else - align = DECL_ALIGN (var); + align = MINIMUM_ALIGNMENT (var, DECL_MODE (var), DECL_ALIGN (var)); if (crtl->stack_alignment_estimated < align) { diff --git a/gcc/common.opt b/gcc/common.opt index 5928839421c..1175767fc1a 100644 --- a/gcc/common.opt +++ b/gcc/common.opt @@ -1122,6 +1122,34 @@ fsched-stalled-insns-dep= Common RejectNegative Joined UInteger -fsched-stalled-insns-dep=<number> Set dependence distance checking in premature scheduling of queued insns +fsched-group-heuristic +Common Report Var(flag_sched_group_heuristic) Init(1) Optimization +Enable the group heuristic in the scheduler + +fsched-critical-path-heuristic +Common Report Var(flag_sched_critical_path_heuristic) Init(1) Optimization +Enable the critical path heuristic in the scheduler + +fsched-spec-insn-heuristic +Common Report Var(flag_sched_spec_insn_heuristic) Init(1) Optimization +Enable the speculative instruction heuristic in the scheduler + +fsched-reg-pressure-heuristic +Common Report Var(flag_sched_reg_pressure_heuristic) Init(1) Optimization +Enable the register pressure heuristic in the scheduler + +fsched-rank-heuristic +Common Report Var(flag_sched_rank_heuristic) Init(1) Optimization +Enable the rank heuristic in the scheduler + +fsched-last-insn-heuristic +Common Report Var(flag_sched_last_insn_heuristic) Init(1) Optimization +Enable the last instruction heuristic in the scheduler + +fsched-dep-count-heuristic +Common Report Var(flag_sched_dep_count_heuristic) Init(1) Optimization +Enable the dependent count heuristic in the scheduler + fsection-anchors Common Report Var(flag_section_anchors) Optimization Access data in the same section from shared anchor points diff --git a/gcc/config.gcc b/gcc/config.gcc index fe345c13953..98d7771b322 100644 --- a/gcc/config.gcc +++ b/gcc/config.gcc @@ -2902,7 +2902,7 @@ case "${target}" in ;; mips*-*-*) - supported_defaults="abi arch arch_32 arch_64 float tune tune_32 tune_64 divide llsc mips-plt" + supported_defaults="abi arch arch_32 arch_64 float tune tune_32 tune_64 divide llsc mips-plt synci" case ${with_float} in "" | soft | hard) @@ -2964,6 +2964,20 @@ case "${target}" in exit 1 ;; esac + + case ${with_synci} in + yes) + with_synci=synci + ;; + "" | no) + # No is the default. + with_synci=no-synci + ;; + *) + echo "Unknown synci type used in --with-synci" 1>&2 + exit 1 + ;; + esac ;; powerpc*-*-* | rs6000-*-*) @@ -3230,7 +3244,7 @@ case ${target} in esac t= -all_defaults="abi cpu cpu_32 cpu_64 arch arch_32 arch_64 tune tune_32 tune_64 schedule float mode fpu divide llsc mips-plt" +all_defaults="abi cpu cpu_32 cpu_64 arch arch_32 arch_64 tune tune_32 tune_64 schedule float mode fpu divide llsc mips-plt synci" for option in $all_defaults do eval "val=\$with_"`echo $option | sed s/-/_/g` diff --git a/gcc/config/arm/thumb2.md b/gcc/config/arm/thumb2.md index 0c5c2dbd9ce..884d58c7677 100644 --- a/gcc/config/arm/thumb2.md +++ b/gcc/config/arm/thumb2.md @@ -1325,7 +1325,7 @@ (clobber (reg:CC CC_REGNUM))] "TARGET_THUMB2" "* - if (get_attr_length (insn) == 2 && which_alternative == 0) + if (get_attr_length (insn) == 2) return \"cbz\\t%0, %l1\"; else return \"cmp\\t%0, #0\;beq\\t%l1\"; @@ -1333,7 +1333,8 @@ [(set (attr "length") (if_then_else (and (ge (minus (match_dup 1) (pc)) (const_int 2)) - (le (minus (match_dup 1) (pc)) (const_int 128))) + (le (minus (match_dup 1) (pc)) (const_int 128)) + (eq (symbol_ref ("which_alternative")) (const_int 0))) (const_int 2) (const_int 8)))] ) @@ -1347,7 +1348,7 @@ (clobber (reg:CC CC_REGNUM))] "TARGET_THUMB2" "* - if (get_attr_length (insn) == 2 && which_alternative == 0) + if (get_attr_length (insn) == 2) return \"cbnz\\t%0, %l1\"; else return \"cmp\\t%0, #0\;bne\\t%l1\"; @@ -1355,7 +1356,8 @@ [(set (attr "length") (if_then_else (and (ge (minus (match_dup 1) (pc)) (const_int 2)) - (le (minus (match_dup 1) (pc)) (const_int 128))) + (le (minus (match_dup 1) (pc)) (const_int 128)) + (eq (symbol_ref ("which_alternative")) (const_int 0))) (const_int 2) (const_int 8)))] ) diff --git a/gcc/config/avr/avr-protos.h b/gcc/config/avr/avr-protos.h index c2d199d0dc7..719829d431f 100644 --- a/gcc/config/avr/avr-protos.h +++ b/gcc/config/avr/avr-protos.h @@ -24,6 +24,7 @@ extern int function_arg_regno_p (int r); extern void avr_init_once (void); extern void avr_override_options (void); +extern void avr_cpu_cpp_builtins (struct cpp_reader * pfile); extern void avr_optimization_options (int level, int size); extern char *avr_change_section (char *sect_name); extern int avr_ret_register (void); diff --git a/gcc/config/avr/avr.c b/gcc/config/avr/avr.c index 7dd2a6f8bfd..e715e39fe38 100644 --- a/gcc/config/avr/avr.c +++ b/gcc/config/avr/avr.c @@ -107,7 +107,7 @@ static const char *const avr_regnames[] = REGISTER_NAMES; static int last_insn_address = 0; /* Preprocessor macros to define depending on MCU type. */ -const char *avr_extra_arch_macro; +static const char *avr_extra_arch_macro; /* Current architecture. */ const struct base_arch_s *avr_current_arch; @@ -222,6 +222,53 @@ avr_override_options (void) init_machine_status = avr_init_machine_status; } +/* Worker function for TARGET_CPU_CPP_BUILTINS. */ + +void +avr_cpu_cpp_builtins (struct cpp_reader *pfile) +{ + builtin_define_std ("AVR"); + + if (avr_current_arch->macro) + cpp_define (pfile, avr_current_arch->macro); + if (avr_extra_arch_macro) + cpp_define (pfile, avr_extra_arch_macro); + if (avr_current_arch->have_elpm) + cpp_define (pfile, "__AVR_HAVE_RAMPZ__"); + if (avr_current_arch->have_elpm) + cpp_define (pfile, "__AVR_HAVE_ELPM__"); + if (avr_current_arch->have_elpmx) + cpp_define (pfile, "__AVR_HAVE_ELPMX__"); + if (avr_current_arch->have_movw_lpmx) + { + cpp_define (pfile, "__AVR_HAVE_MOVW__"); + cpp_define (pfile, "__AVR_HAVE_LPMX__"); + } + if (avr_current_arch->asm_only) + cpp_define (pfile, "__AVR_ASM_ONLY__"); + if (avr_current_arch->have_mul) + { + cpp_define (pfile, "__AVR_ENHANCED__"); + cpp_define (pfile, "__AVR_HAVE_MUL__"); + } + if (avr_current_arch->have_jmp_call) + { + cpp_define (pfile, "__AVR_MEGA__"); + cpp_define (pfile, "__AVR_HAVE_JMP_CALL__"); + } + if (avr_current_arch->have_eijmp_eicall) + { + cpp_define (pfile, "__AVR_HAVE_EIJMP_EICALL__"); + cpp_define (pfile, "__AVR_3_BYTE_PC__"); + } + else + { + cpp_define (pfile, "__AVR_2_BYTE_PC__"); + } + if (TARGET_NO_INTERRUPTS) + cpp_define (pfile, "__NO_INTERRUPTS__"); +} + /* return register class from register number. */ static const enum reg_class reg_class_tab[]={ diff --git a/gcc/config/avr/avr.h b/gcc/config/avr/avr.h index 97e3e2a2f68..73752467e08 100644 --- a/gcc/config/avr/avr.h +++ b/gcc/config/avr/avr.h @@ -102,52 +102,7 @@ extern const struct mcu_type_s *avr_current_device; extern const struct mcu_type_s avr_mcu_types[]; extern const struct base_arch_s avr_arch_types[]; -#define TARGET_CPU_CPP_BUILTINS() \ - do \ - { \ - builtin_define_std ("AVR"); \ - if (avr_current_arch->macro) \ - builtin_define (avr_current_arch->macro); \ - if (avr_extra_arch_macro) \ - builtin_define (avr_extra_arch_macro); \ - if (avr_current_arch->have_elpm) \ - builtin_define ("__AVR_HAVE_RAMPZ__"); \ - if (avr_current_arch->have_elpm) \ - builtin_define ("__AVR_HAVE_ELPM__"); \ - if (avr_current_arch->have_elpmx) \ - builtin_define ("__AVR_HAVE_ELPMX__"); \ - if (avr_current_arch->have_movw_lpmx) \ - { \ - builtin_define ("__AVR_HAVE_MOVW__"); \ - builtin_define ("__AVR_HAVE_LPMX__"); \ - } \ - if (avr_current_arch->asm_only) \ - builtin_define ("__AVR_ASM_ONLY__"); \ - if (avr_current_arch->have_mul) \ - { \ - builtin_define ("__AVR_ENHANCED__"); \ - builtin_define ("__AVR_HAVE_MUL__"); \ - } \ - if (avr_current_arch->have_jmp_call) \ - { \ - builtin_define ("__AVR_MEGA__"); \ - builtin_define ("__AVR_HAVE_JMP_CALL__"); \ - } \ - if (avr_current_arch->have_eijmp_eicall) \ - { \ - builtin_define ("__AVR_HAVE_EIJMP_EICALL__"); \ - builtin_define ("__AVR_3_BYTE_PC__"); \ - } \ - else \ - { \ - builtin_define ("__AVR_2_BYTE_PC__"); \ - } \ - if (TARGET_NO_INTERRUPTS) \ - builtin_define ("__NO_INTERRUPTS__"); \ - } \ - while (0) - -extern const char *avr_extra_arch_macro; +#define TARGET_CPU_CPP_BUILTINS() avr_cpu_cpp_builtins (pfile) #if !defined(IN_LIBGCC2) && !defined(IN_TARGET_LIBS) extern GTY(()) section *progmem_section; diff --git a/gcc/config/i386/cygming.h b/gcc/config/i386/cygming.h index 431e926818a..bc81554a3dd 100644 --- a/gcc/config/i386/cygming.h +++ b/gcc/config/i386/cygming.h @@ -73,7 +73,8 @@ along with GCC; see the file COPYING3. If not see #define TARGET_OS_CPP_BUILTINS() \ do \ { \ - builtin_define ("_X86_=1"); \ + if (!TARGET_64BIT) \ + builtin_define ("_X86_=1"); \ builtin_assert ("system=winnt"); \ builtin_define ("__stdcall=__attribute__((__stdcall__))"); \ builtin_define ("__fastcall=__attribute__((__fastcall__))"); \ diff --git a/gcc/config/i386/i386-protos.h b/gcc/config/i386/i386-protos.h index d1d601a6a67..324062ec7df 100644 --- a/gcc/config/i386/i386-protos.h +++ b/gcc/config/i386/i386-protos.h @@ -89,6 +89,7 @@ extern bool ix86_agi_dependent (rtx set_insn, rtx use_insn); extern void ix86_expand_unary_operator (enum rtx_code, enum machine_mode, rtx[]); extern rtx ix86_build_const_vector (enum machine_mode, bool, rtx); +extern rtx ix86_build_signbit_mask (enum machine_mode, bool, bool); extern void ix86_split_convert_uns_si_sse (rtx[]); extern void ix86_expand_convert_uns_didf_sse (rtx, rtx); extern void ix86_expand_convert_uns_sixf_sse (rtx, rtx); @@ -199,6 +200,8 @@ extern int ix86_return_pops_args (tree, tree, int); extern int ix86_data_alignment (tree, int); extern unsigned int ix86_local_alignment (tree, enum machine_mode, unsigned int); +extern unsigned int ix86_minimum_alignment (tree, enum machine_mode, + unsigned int); extern int ix86_constant_alignment (tree, int); extern tree ix86_handle_shared_attribute (tree *, tree, tree, int, bool *); extern tree ix86_handle_selectany_attribute (tree *, tree, tree, int, bool *); diff --git a/gcc/config/i386/i386.c b/gcc/config/i386/i386.c index 15a73d86551..99963be27ca 100644 --- a/gcc/config/i386/i386.c +++ b/gcc/config/i386/i386.c @@ -48,7 +48,7 @@ along with GCC; see the file COPYING3. If not see #include "langhooks.h" #include "cgraph.h" #include "gimple.h" -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "df.h" #include "tm-constrs.h" #include "params.h" @@ -14017,7 +14017,7 @@ ix86_build_const_vector (enum machine_mode mode, bool vect, rtx value) all elements of the vector register. If INVERT is true, then create a mask excluding the sign bit. */ -static rtx +rtx ix86_build_signbit_mask (enum machine_mode mode, bool vect, bool invert) { enum machine_mode vec_mode, imode; @@ -14181,15 +14181,9 @@ ix86_expand_copysign (rtx operands[]) op0 = CONST0_RTX (vmode); else { - rtvec v; - - if (mode == SFmode) - v = gen_rtvec (4, op0, CONST0_RTX (SFmode), - CONST0_RTX (SFmode), CONST0_RTX (SFmode)); - else - v = gen_rtvec (2, op0, CONST0_RTX (DFmode)); + rtx v = ix86_build_const_vector (mode, false, op0); - op0 = force_reg (vmode, gen_rtx_CONST_VECTOR (vmode, v)); + op0 = force_reg (vmode, v); } } else if (op0 != CONST0_RTX (mode)) @@ -20087,6 +20081,41 @@ ix86_local_alignment (tree exp, enum machine_mode mode, } return align; } + +/* Compute the minimum required alignment for dynamic stack realignment + purposes for a local variable, parameter or a stack slot. EXP is + the data type or decl itself, MODE is its mode and ALIGN is the + alignment that the object would ordinarily have. */ + +unsigned int +ix86_minimum_alignment (tree exp, enum machine_mode mode, + unsigned int align) +{ + tree type, decl; + + if (TARGET_64BIT || align != 64 || ix86_preferred_stack_boundary >= 64) + return align; + + if (exp && DECL_P (exp)) + { + type = TREE_TYPE (exp); + decl = exp; + } + else + { + type = exp; + decl = NULL; + } + + /* Don't do dynamic stack realignment for long long objects with + -mpreferred-stack-boundary=2. */ + if ((mode == DImode || (type && TYPE_MODE (type) == DImode)) + && (!type || !TYPE_USER_ALIGN (type)) + && (!decl || !DECL_USER_ALIGN (decl))) + return 32; + + return align; +} /* Emit RTL insns to initialize the variable parts of a trampoline. FNADDR is an RTX for the address of the function's pure code. @@ -20875,6 +20904,10 @@ enum ix86_builtins IX86_BUILTIN_FABSQ, IX86_BUILTIN_COPYSIGNQ, + /* Vectorizer support builtins. */ + IX86_BUILTIN_CPYSGNPS, + IX86_BUILTIN_CPYSGNPD, + /* SSE5 instructions */ IX86_BUILTIN_FMADDSS, IX86_BUILTIN_FMADDSD, @@ -21711,6 +21744,8 @@ static const struct builtin_description bdesc_args[] = { OPTION_MASK_ISA_SSE, CODE_FOR_iorv4sf3, "__builtin_ia32_orps", IX86_BUILTIN_ORPS, UNKNOWN, (int) V4SF_FTYPE_V4SF_V4SF }, { OPTION_MASK_ISA_SSE, CODE_FOR_xorv4sf3, "__builtin_ia32_xorps", IX86_BUILTIN_XORPS, UNKNOWN, (int) V4SF_FTYPE_V4SF_V4SF }, + { OPTION_MASK_ISA_SSE, CODE_FOR_copysignv4sf3, "__builtin_ia32_copysignps", IX86_BUILTIN_CPYSGNPS, UNKNOWN, (int) V4SF_FTYPE_V4SF_V4SF }, + { OPTION_MASK_ISA_SSE, CODE_FOR_sse_movss, "__builtin_ia32_movss", IX86_BUILTIN_MOVSS, UNKNOWN, (int) V4SF_FTYPE_V4SF_V4SF }, { OPTION_MASK_ISA_SSE, CODE_FOR_sse_movhlps_exp, "__builtin_ia32_movhlps", IX86_BUILTIN_MOVHLPS, UNKNOWN, (int) V4SF_FTYPE_V4SF_V4SF }, { OPTION_MASK_ISA_SSE, CODE_FOR_sse_movlhps_exp, "__builtin_ia32_movlhps", IX86_BUILTIN_MOVLHPS, UNKNOWN, (int) V4SF_FTYPE_V4SF_V4SF }, @@ -21808,6 +21843,8 @@ static const struct builtin_description bdesc_args[] = { OPTION_MASK_ISA_SSE2, CODE_FOR_iorv2df3, "__builtin_ia32_orpd", IX86_BUILTIN_ORPD, UNKNOWN, (int) V2DF_FTYPE_V2DF_V2DF }, { OPTION_MASK_ISA_SSE2, CODE_FOR_xorv2df3, "__builtin_ia32_xorpd", IX86_BUILTIN_XORPD, UNKNOWN, (int) V2DF_FTYPE_V2DF_V2DF }, + { OPTION_MASK_ISA_SSE2, CODE_FOR_copysignv2df3, "__builtin_ia32_copysignpd", IX86_BUILTIN_CPYSGNPD, UNKNOWN, (int) V2DF_FTYPE_V2DF_V2DF }, + { OPTION_MASK_ISA_SSE2, CODE_FOR_sse2_movsd, "__builtin_ia32_movsd", IX86_BUILTIN_MOVSD, UNKNOWN, (int) V2DF_FTYPE_V2DF_V2DF }, { OPTION_MASK_ISA_SSE2, CODE_FOR_sse2_unpckhpd_exp, "__builtin_ia32_unpckhpd", IX86_BUILTIN_UNPCKHPD, UNKNOWN, (int) V2DF_FTYPE_V2DF_V2DF }, { OPTION_MASK_ISA_SSE2, CODE_FOR_sse2_unpcklpd_exp, "__builtin_ia32_unpcklpd", IX86_BUILTIN_UNPCKLPD, UNKNOWN, (int) V2DF_FTYPE_V2DF_V2DF }, @@ -25694,6 +25731,18 @@ ix86_builtin_vectorized_function (unsigned int fn, tree type_out, return ix86_builtins[IX86_BUILTIN_CVTPS2DQ]; break; + case BUILT_IN_COPYSIGN: + if (out_mode == DFmode && out_n == 2 + && in_mode == DFmode && in_n == 2) + return ix86_builtins[IX86_BUILTIN_CPYSGNPD]; + break; + + case BUILT_IN_COPYSIGNF: + if (out_mode == SFmode && out_n == 4 + && in_mode == SFmode && in_n == 4) + return ix86_builtins[IX86_BUILTIN_CPYSGNPS]; + break; + default: ; } @@ -30589,8 +30638,8 @@ ix86_enum_va_list (int idx, const char **pname, tree *ptree) #undef TARGET_OPTION_PRINT #define TARGET_OPTION_PRINT ix86_function_specific_print -#undef TARGET_OPTION_CAN_INLINE_P -#define TARGET_OPTION_CAN_INLINE_P ix86_can_inline_p +#undef TARGET_CAN_INLINE_P +#define TARGET_CAN_INLINE_P ix86_can_inline_p #undef TARGET_EXPAND_TO_RTL_HOOK #define TARGET_EXPAND_TO_RTL_HOOK ix86_maybe_switch_abi diff --git a/gcc/config/i386/i386.h b/gcc/config/i386/i386.h index 97483b7cf36..f9b9dd17803 100644 --- a/gcc/config/i386/i386.h +++ b/gcc/config/i386/i386.h @@ -831,6 +831,15 @@ enum target_cpu_default #define LOCAL_DECL_ALIGNMENT(DECL) \ ix86_local_alignment ((DECL), VOIDmode, DECL_ALIGN (DECL)) +/* If defined, a C expression to compute the minimum required alignment + for dynamic stack realignment purposes for EXP (a TYPE or DECL), + MODE, assuming normal alignment ALIGN. + + If this macro is not defined, then (ALIGN) will be used. */ + +#define MINIMUM_ALIGNMENT(EXP, MODE, ALIGN) \ + ix86_minimum_alignment (EXP, MODE, ALIGN) + /* If defined, a C expression that gives the alignment boundary, in bits, of an argument with the specified mode and type. If it is diff --git a/gcc/config/i386/mingw-tls.c b/gcc/config/i386/mingw-tls.c deleted file mode 100644 index 8495a96e3b9..00000000000 --- a/gcc/config/i386/mingw-tls.c +++ /dev/null @@ -1,206 +0,0 @@ -/* Catch and clean up data allocated in TLS. - Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, - 2009 Free Software Foundation, Inc. - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -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/>. */ - -/* This part is based on the implementation of Mumit Khan <khan@nanotech.wisc.edu> - * provided to mingw under public domain and ported for libgcc by Kai Tietz. - */ - -#define WIN32_LEAN_AND_MEAN -#include <windows.h> -#undef WIN32_LEAN_AND_MEAN -#include <stdlib.h> - -/* The list of threads active with key/dtor pairs. */ -typedef struct __mingwthr_key { - DWORD key; - void (*dtor) (void *); - struct __mingwthr_key *next; -} __mingwthr_key_t; - -#if defined(_WIN32) && !defined(__CYGWIN__) - -/* Static functions for libgcc. */ -#ifdef SHARED -__declspec(dllexport) -int _CRT_MT = 1; - -/* Shared functions for libgcc. */ - -/* Prototypes. */ -__declspec(dllexport) int __mingwthr_key_dtor (DWORD key, void (*) (void *)); -__declspec(dllexport) int __mingwthr_remove_key_dtor (DWORD); -BOOL APIENTRY DllMain (HANDLE, DWORD, LPVOID); - - -/* To protect the thread/key association data structure modifications. */ -static CRITICAL_SECTION __mingwthr_cs; -static __mingwthr_key_t *key_dtor_list; - -/* - * __mingwthr_key_add: - * - * Add key/dtor association for this thread. If the thread entry does not - * exist, create a new one and add to the head of the threads list; add - * the new assoc at the head of the keys list. - * - */ - -static int -___mingwthr_add_key_dtor (DWORD key, void (*dtor) (void *)) -{ - __mingwthr_key_t *new_key; - - new_key = (__mingwthr_key_t *) calloc (1, sizeof (__mingwthr_key_t)); - if (new_key == NULL) - return -1; - - new_key->key = key; - new_key->dtor = dtor; - - EnterCriticalSection (&__mingwthr_cs); - - new_key->next = key_dtor_list; - key_dtor_list = new_key; - - LeaveCriticalSection (&__mingwthr_cs); - - return 0; -} - -static int -___mingwthr_remove_key_dtor (DWORD key) -{ - __mingwthr_key_t *prev_key; - __mingwthr_key_t *cur_key; - - EnterCriticalSection (&__mingwthr_cs); - - prev_key = NULL; - cur_key = key_dtor_list; - - while (cur_key != NULL) - { - if( cur_key->key == key ) - { - /* take key/dtor out of list */ - if (prev_key == NULL) - key_dtor_list = cur_key->next; - else - prev_key->next = cur_key->next; - - free (cur_key); - break; - } - - prev_key = cur_key; - cur_key = cur_key->next; - } - - LeaveCriticalSection (&__mingwthr_cs); - - return 0; -} - -/* - * __mingwthr_run_key_dtors (void): - * - * Callback from DllMain when thread detaches to clean up the key - * storage. - * - * Note that this does not delete the key itself, but just runs - * the dtor if the current value are both non-NULL. Note that the - * keys with NULL dtors are not added by __mingwthr_key_dtor, the - * only public interface, so we don't need to check. - * - */ - -static void -__mingwthr_run_key_dtors (void) -{ - __mingwthr_key_t *keyp; - - EnterCriticalSection (&__mingwthr_cs); - - for (keyp = key_dtor_list; keyp; ) - { - LPVOID value = TlsGetValue (keyp->key); - if (GetLastError () == ERROR_SUCCESS) - { - if (value) - (*keyp->dtor) (value); - } - keyp = keyp->next; - } - - LeaveCriticalSection (&__mingwthr_cs); -} - -/* - * __mingwthr_register_key_dtor (DWORD key, void (*dtor) (void *)) - * - * Public interface called by C++ exception handling mechanism in - * libgcc (cf: __gthread_key_create). - * - */ - -__declspec(dllexport) -int -__mingwthr_key_dtor (DWORD key, void (*dtor) (void *)) -{ - if (dtor) - return ___mingwthr_add_key_dtor (key, dtor); - - return 0; -} - -__declspec(dllexport) -int -__mingwthr_remove_key_dtor (DWORD key) -{ - return ___mingwthr_remove_key_dtor (key); -} - -BOOL APIENTRY -DllMain (HANDLE hDllHandle __attribute__ ((__unused__)), - DWORD reason /* Reason this function is being called. */, - LPVOID reserved __attribute__ ((__unused__))) -{ - switch (reason) - { - case DLL_PROCESS_ATTACH: - InitializeCriticalSection (&__mingwthr_cs); - break; - - case DLL_PROCESS_DETACH: - __mingwthr_run_key_dtors (); - DeleteCriticalSection (&__mingwthr_cs); - break; - - case DLL_THREAD_ATTACH: - break; - - case DLL_THREAD_DETACH: - __mingwthr_run_key_dtors (); - break; - } - return TRUE; -} -#endif -#endif diff --git a/gcc/config/i386/sse.md b/gcc/config/i386/sse.md index 1e938ca3c94..8980bf21ac2 100644 --- a/gcc/config/i386/sse.md +++ b/gcc/config/i386/sse.md @@ -1594,6 +1594,26 @@ [(set_attr "type" "sselog") (set_attr "mode" "<MODE>")]) +(define_expand "copysign<mode>3" + [(set (match_dup 5) + (and:SSEMODEF2P (match_operand:SSEMODEF2P 1 "register_operand" "") + (match_dup 3))) + (set (match_dup 6) + (and:SSEMODEF2P (match_operand:SSEMODEF2P 2 "register_operand" "") + (match_dup 4))) + (set (match_operand:SSEMODEF2P 0 "register_operand" "") + (ior:SSEMODEF2P (match_dup 5) (match_dup 6)))] + "SSE_VEC_FLOAT_MODE_P (<MODE>mode)" +{ + int i; + + for (i = 3; i < 7; i++) + operands[i] = gen_reg_rtx (<MODE>mode); + + operands[3] = ix86_build_signbit_mask (<ssescalarmode>mode, 1, 1); + operands[4] = ix86_build_signbit_mask (<ssescalarmode>mode, 1, 0); +}) + ;; Also define scalar versions. These are used for abs, neg, and ;; conditional move. Using subregs into vector modes causes register ;; allocation lossage. These patterns do not allow memory operands diff --git a/gcc/config/i386/t-gthr-win32 b/gcc/config/i386/t-gthr-win32 index e3977ce6336..f67fa1e25a8 100644 --- a/gcc/config/i386/t-gthr-win32 +++ b/gcc/config/i386/t-gthr-win32 @@ -1,3 +1,2 @@ # We hide calls to w32api needed for w32 thread support here: -LIB2FUNCS_EXTRA = $(srcdir)/config/i386/gthr-win32.c \ - $(srcdir)/config/i386/mingw-tls.c +LIB2FUNCS_EXTRA = $(srcdir)/config/i386/gthr-win32.c diff --git a/gcc/config/i386/winnt.c b/gcc/config/i386/winnt.c index fe5081d37a5..7069c40846f 100644 --- a/gcc/config/i386/winnt.c +++ b/gcc/config/i386/winnt.c @@ -107,6 +107,10 @@ i386_pe_determine_dllexport_p (tree decl) if (TREE_CODE (decl) != VAR_DECL && TREE_CODE (decl) != FUNCTION_DECL) return false; + /* Don't export local clones of dllexports. */ + if (!TREE_PUBLIC (decl)) + return false; + if (lookup_attribute ("dllexport", DECL_ATTRIBUTES (decl))) return true; @@ -601,6 +605,8 @@ i386_pe_maybe_record_exported_symbol (tree decl, const char *name, int is_data) if (!SYMBOL_REF_DLLEXPORT_P (symbol)) return; + gcc_assert (TREE_PUBLIC (decl)); + p = (struct export_list *) ggc_alloc (sizeof *p); p->next = export_head; p->name = name; diff --git a/gcc/config/mep/mep-protos.h b/gcc/config/mep/mep-protos.h index eb37702ddf4..a4de754bbd9 100644 --- a/gcc/config/mep/mep-protos.h +++ b/gcc/config/mep/mep-protos.h @@ -33,6 +33,7 @@ extern bool mep_allow_clip (rtx, rtx, int); extern bool mep_bit_position_p (rtx, bool); extern bool mep_split_mov (rtx *, int); extern bool mep_vliw_mode_match (rtx); +extern bool mep_vliw_jmp_match (rtx); extern bool mep_multi_slot (rtx); extern bool mep_legitimate_address (enum machine_mode, rtx, int); extern int mep_legitimize_address (rtx *, rtx, enum machine_mode); diff --git a/gcc/config/mep/mep.c b/gcc/config/mep/mep.c index 9b489f9c14a..80d20184055 100644 --- a/gcc/config/mep/mep.c +++ b/gcc/config/mep/mep.c @@ -170,7 +170,7 @@ static tree mep_validate_interrupt (tree *, tree, tree, int, bool *); static tree mep_validate_io_cb (tree *, tree, tree, int, bool *); static tree mep_validate_vliw (tree *, tree, tree, int, bool *); static bool mep_function_attribute_inlinable_p (const_tree); -static bool mep_option_can_inline_p (tree, tree); +static bool mep_can_inline_p (tree, tree); static bool mep_lookup_pragma_disinterrupt (const char *); static int mep_multiple_address_regions (tree, bool); static int mep_attrlist_to_encoding (tree, tree); @@ -236,8 +236,8 @@ static tree mep_gimplify_va_arg_expr (tree, tree, tree *, tree *); #define TARGET_INSERT_ATTRIBUTES mep_insert_attributes #undef TARGET_FUNCTION_ATTRIBUTE_INLINABLE_P #define TARGET_FUNCTION_ATTRIBUTE_INLINABLE_P mep_function_attribute_inlinable_p -#undef TARGET_OPTION_CAN_INLINE_P -#define TARGET_OPTION_CAN_INLINE_P mep_option_can_inline_p +#undef TARGET_CAN_INLINE_P +#define TARGET_CAN_INLINE_P mep_can_inline_p #undef TARGET_SECTION_TYPE_FLAGS #define TARGET_SECTION_TYPE_FLAGS mep_section_type_flags #undef TARGET_ASM_NAMED_SECTION @@ -1182,6 +1182,20 @@ mep_vliw_mode_match (rtx tgt) return src_vliw == tgt_vliw; } +/* Like the above, but also test for near/far mismatches. */ + +bool +mep_vliw_jmp_match (rtx tgt) +{ + bool src_vliw = mep_vliw_function_p (cfun->decl); + bool tgt_vliw = INTVAL (tgt); + + if (mep_section_tag (DECL_RTL (cfun->decl)) == 'f') + return false; + + return src_vliw == tgt_vliw; +} + bool mep_multi_slot (rtx x) { @@ -2894,7 +2908,12 @@ mep_expand_prologue (void) } if (frame_pointer_needed) - add_constant (FP_REGNO, SP_REGNO, sp_offset - frame_size, 1); + { + /* We've already adjusted down by sp_offset. Total $sp change + is reg_save_size + frame_size. We want a net change here of + just reg_save_size. */ + add_constant (FP_REGNO, SP_REGNO, sp_offset - reg_save_size, 1); + } add_constant (SP_REGNO, SP_REGNO, sp_offset-(reg_save_size+frame_size), 1); @@ -4110,20 +4129,17 @@ mep_function_attribute_inlinable_p (const_tree callee) } static bool -mep_option_can_inline_p (tree caller, tree callee) +mep_can_inline_p (tree caller, tree callee) { if (TREE_CODE (callee) == ADDR_EXPR) callee = TREE_OPERAND (callee, 0); - if (TREE_CODE (callee) == FUNCTION_DECL - && DECL_DECLARED_INLINE_P (callee) - && !mep_vliw_function_p (caller) + if (!mep_vliw_function_p (caller) && mep_vliw_function_p (callee)) { - error ("cannot call inline VLIW functions from core functions"); - return true; + return false; } - return false; + return true; } #define FUNC_CALL 1 diff --git a/gcc/config/mep/mep.h b/gcc/config/mep/mep.h index 7c69a5d4fba..353823cef01 100644 --- a/gcc/config/mep/mep.h +++ b/gcc/config/mep/mep.h @@ -43,8 +43,8 @@ along with GCC; see the file COPYING3. If not see #undef CC1_SPEC #define CC1_SPEC "%{!mlibrary:%(config_cc_spec)} \ -%{!.cc:%{O2:%{!funroll*:--param max-completely-peeled-insns=10 \ - --param max-unrolled-insns=10 -funroll-loops}}}" +%{!.cc:%{O2:%{!funroll*:--param max-completely-peeled-insns=6 \ + --param max-unrolled-insns=6 -funroll-loops}}}" #undef CC1PLUS_SPEC #define CC1PLUS_SPEC "%{!mlibrary:%(config_cc_spec)}" @@ -534,7 +534,9 @@ typedef struct #define FUNCTION_ARG_ADVANCE(CUM, MODE, TYPE, NAMED) \ mep_arg_advance (& (CUM), MODE, TYPE, NAMED) -#define FUNCTION_ARG_REGNO_P(REGNO) ((REGNO) >= 1 && (REGNO) <= 4) +#define FUNCTION_ARG_REGNO_P(REGNO) \ + (((REGNO) >= 1 && (REGNO) <= 4) \ + || ((REGNO) >= FIRST_CR_REGNO + 1 && (REGNO) <= FIRST_CR_REGNO + 4)) #define RETURN_VALUE_REGNUM 0 diff --git a/gcc/config/mep/mep.md b/gcc/config/mep/mep.md index 2b6aa808526..5b5fba87215 100644 --- a/gcc/config/mep/mep.md +++ b/gcc/config/mep/mep.md @@ -1923,8 +1923,12 @@ ] "SIBLING_CALL_P (insn)" { - if (mep_vliw_mode_match (operands[2])) + if (mep_vliw_jmp_match (operands[2])) return "jmp\t%0"; + else if (mep_vliw_mode_match (operands[2])) + return + "movu $3, %0\n\ + jmp $3"; else return "ldc $12, $lp\n\ @@ -1994,8 +1998,12 @@ ] "SIBLING_CALL_P (insn)" { - if (mep_vliw_mode_match (operands[3])) + if (mep_vliw_jmp_match (operands[3])) return "jmp\t%1"; + else if (mep_vliw_mode_match (operands[3])) + return + "movu $3, %1\n\ + jmp $3"; else return "ldc $12, $lp\n\ diff --git a/gcc/config/mips/mips.c b/gcc/config/mips/mips.c index 361589282ec..4a10fb47244 100644 --- a/gcc/config/mips/mips.c +++ b/gcc/config/mips/mips.c @@ -14524,6 +14524,13 @@ mips_override_options (void) : !TARGET_BRANCHLIKELY)) sorry ("%qs requires branch-likely instructions", "-mfix-r10000"); + if (TARGET_SYNCI && !ISA_HAS_SYNCI) + { + warning (0, "the %qs architecture does not support the synci " + "instruction", mips_arch_info->name); + target_flags &= ~MASK_SYNCI; + } + /* Save base state of options. */ mips_base_target_flags = target_flags; mips_base_schedule_insns = flag_schedule_insns; diff --git a/gcc/config/mips/mips.h b/gcc/config/mips/mips.h index c8ea60590d1..a3ab2f8bb8f 100644 --- a/gcc/config/mips/mips.h +++ b/gcc/config/mips/mips.h @@ -787,7 +787,8 @@ enum mips_code_readable_setting { {"float", "%{!msoft-float:%{!mhard-float:-m%(VALUE)-float}}" }, \ {"divide", "%{!mdivide-traps:%{!mdivide-breaks:-mdivide-%(VALUE)}}" }, \ {"llsc", "%{!mllsc:%{!mno-llsc:-m%(VALUE)}}" }, \ - {"mips-plt", "%{!mplt:%{!mno-plt:-m%(VALUE)}}" } + {"mips-plt", "%{!mplt:%{!mno-plt:-m%(VALUE)}}" }, \ + {"synci", "%{!msynci:%{!mno-synci:-m%(VALUE)}}" } /* A spec that infers the -mdsp setting from an -march argument. */ diff --git a/gcc/config/mips/mips.md b/gcc/config/mips/mips.md index 46e7afa9be5..3c42b465693 100644 --- a/gcc/config/mips/mips.md +++ b/gcc/config/mips/mips.md @@ -4728,7 +4728,7 @@ "" " { - if (ISA_HAS_SYNCI) + if (TARGET_SYNCI) { mips_expand_synci_loop (operands[0], operands[1]); emit_insn (gen_sync ()); @@ -4753,7 +4753,7 @@ (define_insn "synci" [(unspec_volatile [(match_operand 0 "pmode_register_operand" "d")] UNSPEC_SYNCI)] - "ISA_HAS_SYNCI" + "TARGET_SYNCI" "synci\t0(%0)") (define_insn "rdhwr_synci_step_<mode>" diff --git a/gcc/config/mips/mips.opt b/gcc/config/mips/mips.opt index 90167542790..9038125fae4 100644 --- a/gcc/config/mips/mips.opt +++ b/gcc/config/mips/mips.opt @@ -268,6 +268,10 @@ msym32 Target Report Var(TARGET_SYM32) Assume all symbols have 32-bit values +msynci +Target Report Mask(SYNCI) +Use synci instruction to invalidate i-cache + mtune= Target RejectNegative Joined Var(mips_tune_string) -mtune=PROCESSOR Optimize the output for PROCESSOR diff --git a/gcc/config/mmix/mmix.c b/gcc/config/mmix/mmix.c index f81512401f6..67b1b2323b5 100644 --- a/gcc/config/mmix/mmix.c +++ b/gcc/config/mmix/mmix.c @@ -36,7 +36,7 @@ along with GCC; see the file COPYING3. If not see #include "toplev.h" #include "recog.h" #include "ggc.h" -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "debug.h" #include "tm_p.h" #include "integrate.h" diff --git a/gcc/config/rs6000/darwin-fallback.c b/gcc/config/rs6000/darwin-fallback.c index e4d5afe50ac..4591071ea74 100644 --- a/gcc/config/rs6000/darwin-fallback.c +++ b/gcc/config/rs6000/darwin-fallback.c @@ -28,7 +28,7 @@ #include "tsystem.h" #include "coretypes.h" #include "tm.h" -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "unwind.h" #include "unwind-dw2.h" #include <stdint.h> diff --git a/gcc/config/rs6000/predicates.md b/gcc/config/rs6000/predicates.md index dbf78734b17..13bb76a12ad 100644 --- a/gcc/config/rs6000/predicates.md +++ b/gcc/config/rs6000/predicates.md @@ -367,9 +367,7 @@ ;; Return 1 if the operand is an offsettable memory operand. (define_predicate "offsettable_mem_operand" (and (match_operand 0 "memory_operand") - (match_test "GET_CODE (XEXP (op, 0)) != PRE_INC - && GET_CODE (XEXP (op, 0)) != PRE_DEC - && GET_CODE (XEXP (op, 0)) != PRE_MODIFY"))) + (match_test "GET_RTX_CLASS (GET_CODE (XEXP (op, 0))) != RTX_AUTOINC"))) ;; Return 1 if the operand is a memory operand with an address divisible by 4 (define_predicate "word_offset_memref_operand" diff --git a/gcc/config/sh/sh.c b/gcc/config/sh/sh.c index 18123c34cde..b4c190029df 100644 --- a/gcc/config/sh/sh.c +++ b/gcc/config/sh/sh.c @@ -38,7 +38,7 @@ along with GCC; see the file COPYING3. If not see #include "toplev.h" #include "recog.h" #include "integrate.h" -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "tm_p.h" #include "target.h" #include "target-def.h" diff --git a/gcc/config/xtensa/unwind-dw2-xtensa.c b/gcc/config/xtensa/unwind-dw2-xtensa.c index 235b8a12563..e7ca86a10fb 100644 --- a/gcc/config/xtensa/unwind-dw2-xtensa.c +++ b/gcc/config/xtensa/unwind-dw2-xtensa.c @@ -28,7 +28,7 @@ #include "tsystem.h" #include "coretypes.h" #include "tm.h" -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "unwind.h" #ifdef __USING_SJLJ_EXCEPTIONS__ # define NO_SIZE_OF_ENCODED_VALUE diff --git a/gcc/configure b/gcc/configure index f48c9cf9bb3..3e7165c382f 100755 --- a/gcc/configure +++ b/gcc/configure @@ -29309,7 +29309,7 @@ touch Make-hooks target_list="all.cross start.encap rest.encap tags \ install-common install-man install-info install-pdf dvi pdf \ html uninstall info man srcextra srcman srcinfo \ - mostlyclean clean distclean maintainer-clean" + mostlyclean clean distclean maintainer-clean install-plugin" for t in $target_list do diff --git a/gcc/configure.ac b/gcc/configure.ac index dad3b405441..f3c36ef1811 100644 --- a/gcc/configure.ac +++ b/gcc/configure.ac @@ -4139,7 +4139,7 @@ touch Make-hooks target_list="all.cross start.encap rest.encap tags \ install-common install-man install-info install-pdf dvi pdf \ html uninstall info man srcextra srcman srcinfo \ - mostlyclean clean distclean maintainer-clean" + mostlyclean clean distclean maintainer-clean install-plugin" for t in $target_list do diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index 8e3b90704c6..4265fa9f9cf 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,70 @@ +2009-07-14 Taras Glek <tglek@mozilla.com> + Rafael Espindola <espindola@google.com> + + * Make-lang.in: Added CP_PLUGIN_HEADERS and + c.install-target to export cp-tree.h cxx-pretty-print.h + name-lookup.h headers for plugins. + +2009-07-14 Jason Merrill <jason@redhat.com> + + PR c++/37276 + * decl.c (decls_match): A non-extern-C declaration doesn't match + a builtin extern-C declaration. + + PR c++/40746 + * name-lookup.c (qualified_lookup_using_namespace): Don't stop + looking in used namespaces just because we found something on + another branch. + + PR c++/40740 + * semantics.c (perform_koenig_lookup): Handle empty template args. + + * call.c (build_over_call): Use can_trust_pointer_alignment. + +2009-07-14 Dodji Seketeli <dodji@redhat.com> + + PR debug/40705 + PR c++/403057 + * decl2.c (grokfield): Don't call set_underlying_type on typedef + decls that are type names. + +2009-07-13 Andrew Pinski <andrew_pinski@playstation.sony.com> + + PR C++/22154 + * parser.c (cp_parser_elaborated_type_specifier): Accept typename in + front of qualified names. + +2009-07-12 Jason Merrill <jason@redhat.com> + + PR c++/36628 + * tree.c (rvalue): Use lvalue_or_rvalue_with_address_p. + + PR c++/37206 + * cp-tree.h (enum cp_lvalue_kind_flags): Add clk_rvalueref. + * tree.c (lvalue_p_1): Return it. Remove + treat_class_rvalues_as_lvalues parm. + (real_lvalue_p): Disallow pseudo-lvalues here. + (lvalue_or_rvalue_with_address_p): New fn. + * call.c (initialize_reference): Use it instead of real_lvalue_p. + + PR c++/40689 + * init.c (build_new_1): Handle initializer list as array initializer. + (build_vec_init): Likewise. + * typeck.c (cp_build_modify_expr): Likewise. + * typeck2.c (process_init_constructor_array): Error rather than abort + if too many initializers. + +2009-07-10 Jakub Jelinek <jakub@redhat.com> + + PR c++/40502 + * error.c (cp_print_error_function): Check for NULL block. + +2008-07-09 Simon Martin <simartin@users.sourceforge.net> + Jason Merrill <jason@redhat.com> + + * pt.c (perform_typedefs_access_check, get_types_needing_access_check, + append_type_to_template_for_access_check_1): Use CLASS_TYPE_P. + 2009-07-09 Dodji Seketeli <dodji@redhat.com> PR c++/40684 diff --git a/gcc/cp/Make-lang.in b/gcc/cp/Make-lang.in index 2c562f873f6..6bff698f00b 100644 --- a/gcc/cp/Make-lang.in +++ b/gcc/cp/Make-lang.in @@ -41,6 +41,7 @@ CXX_INSTALL_NAME := $(shell echo c++|sed '$(program_transform_name)') GXX_INSTALL_NAME := $(shell echo g++|sed '$(program_transform_name)') CXX_TARGET_INSTALL_NAME := $(target_noncanonical)-$(shell echo c++|sed '$(program_transform_name)') GXX_TARGET_INSTALL_NAME := $(target_noncanonical)-$(shell echo g++|sed '$(program_transform_name)') +CP_PLUGIN_HEADERS := cp-tree.h cxx-pretty-print.h name-lookup.h # # Define the names for selecting c++ in LANGUAGES. @@ -189,6 +190,19 @@ $(DESTDIR)$(man1dir)/$(GXX_INSTALL_NAME)$(man1ext): doc/g++.1 installdirs -$(INSTALL_DATA) $< $@ -chmod a-x $@ +c++.install-plugin: installdirs +# We keep the directory structure for files in config and .def files. All +# other files are flattened to a single directory. + headers="$(CP_PLUGIN_HEADERS)"; \ + for file in $$headers; do \ + path=$(srcdir)/cp/$$file; \ + dest=$(plugin_includedir)/cp/$$file; \ + echo $(INSTALL_DATA) $$path $(DESTDIR)$$dest; \ + dir=`dirname $$dest`; \ + $(mkinstalldirs) $(DESTDIR)$$dir; \ + $(INSTALL_DATA) $$path $(DESTDIR)$$dest; \ + done + c++.uninstall: -rm -rf $(DESTDIR)$(bindir)/$(CXX_INSTALL_NAME)$(exeext) -rm -rf $(DESTDIR)$(bindir)/$(GXX_INSTALL_NAME)$(exeext) diff --git a/gcc/cp/call.c b/gcc/cp/call.c index f0d624ed590..588c997a34b 100644 --- a/gcc/cp/call.c +++ b/gcc/cp/call.c @@ -5669,11 +5669,11 @@ build_over_call (struct z_candidate *cand, int flags, tsubst_flags_t complain) arg1 = arg; arg0 = cp_build_unary_op (ADDR_EXPR, to, 0, complain); - if (!(optimize && flag_tree_ter)) + if (!can_trust_pointer_alignment ()) { - /* When TER is off get_pointer_alignment returns 0, so a call + /* If we can't be sure about pointer alignment, a call to __builtin_memcpy is expanded as a call to memcpy, which - is invalid with identical args. When TER is on it is + is invalid with identical args. Otherwise it is expanded as a block move, which should be safe. */ arg0 = save_expr (arg0); arg1 = save_expr (arg1); @@ -7622,7 +7622,7 @@ initialize_reference (tree type, tree expr, tree decl, tree *cleanup) expr = error_mark_node; else { - if (!real_lvalue_p (expr)) + if (!lvalue_or_rvalue_with_address_p (expr)) { tree init; var = set_up_extended_ref_temp (decl, expr, cleanup, &init); diff --git a/gcc/cp/cp-tree.h b/gcc/cp/cp-tree.h index 24351b4dad6..933da1992d2 100644 --- a/gcc/cp/cp-tree.h +++ b/gcc/cp/cp-tree.h @@ -3509,9 +3509,10 @@ enum tag_types { enum cp_lvalue_kind_flags { clk_none = 0, /* Things that are not an lvalue. */ clk_ordinary = 1, /* An ordinary lvalue. */ - clk_class = 2, /* An rvalue of class-type. */ - clk_bitfield = 4, /* An lvalue for a bit-field. */ - clk_packed = 8 /* An lvalue for a packed field. */ + clk_rvalueref = 2,/* An rvalue formed using an rvalue reference */ + clk_class = 4, /* An rvalue of class-type. */ + clk_bitfield = 8, /* An lvalue for a bit-field. */ + clk_packed = 16 /* An lvalue for a packed field. */ }; /* This type is used for parameters and variables which hold @@ -4884,6 +4885,7 @@ extern tree copy_binfo (tree, tree, tree, tree *, int); extern int member_p (const_tree); extern cp_lvalue_kind real_lvalue_p (tree); +extern bool lvalue_or_rvalue_with_address_p (const_tree); extern bool builtin_valid_in_constant_expr_p (const_tree); extern tree build_min (enum tree_code, tree, ...); extern tree build_min_nt (enum tree_code, ...); diff --git a/gcc/cp/decl.c b/gcc/cp/decl.c index d7a0e0d9693..e1b6678ea2d 100644 --- a/gcc/cp/decl.c +++ b/gcc/cp/decl.c @@ -932,6 +932,14 @@ decls_match (tree newdecl, tree olddecl) && DECL_EXTERN_C_P (olddecl))) return 0; +#ifdef NO_IMPLICIT_EXTERN_C + /* A new declaration doesn't match a built-in one unless it + is also extern "C". */ + if (DECL_BUILT_IN (olddecl) + && DECL_EXTERN_C_P (olddecl) && !DECL_EXTERN_C_P (newdecl)) + return 0; +#endif + if (TREE_CODE (f1) != TREE_CODE (f2)) return 0; diff --git a/gcc/cp/decl2.c b/gcc/cp/decl2.c index b3b567e0f6c..3a5d2fa929b 100644 --- a/gcc/cp/decl2.c +++ b/gcc/cp/decl2.c @@ -821,7 +821,9 @@ grokfield (const cp_declarator *declarator, cplus_decl_attributes (&value, attrlist, attrflags); } - if (declspecs->specs[(int)ds_typedef]) + if (declspecs->specs[(int)ds_typedef] + && TREE_TYPE (value) != error_mark_node + && TYPE_NAME (TYPE_MAIN_VARIANT (TREE_TYPE (value))) != value) set_underlying_type (value); return value; diff --git a/gcc/cp/error.c b/gcc/cp/error.c index 850f4069a17..a0ba51a6ceb 100644 --- a/gcc/cp/error.c +++ b/gcc/cp/error.c @@ -2603,7 +2603,7 @@ cp_print_error_function (diagnostic_context *context, while (block && TREE_CODE (block) == BLOCK) block = BLOCK_SUPERCONTEXT (block); - if (TREE_CODE (block) == FUNCTION_DECL) + if (block && TREE_CODE (block) == FUNCTION_DECL) fndecl = block; abstract_origin = NULL; } diff --git a/gcc/cp/init.c b/gcc/cp/init.c index 68ffe3a3dd0..19b24895e55 100644 --- a/gcc/cp/init.c +++ b/gcc/cp/init.c @@ -1773,6 +1773,7 @@ build_new_1 (VEC(tree,gc) **placement, tree type, tree nelts, /* The type of the new-expression. (This type is always a pointer type.) */ tree pointer_type; + tree non_const_pointer_type; tree outer_nelts = NULL_TREE; tree alloc_call, alloc_expr; /* The address returned by the call to "operator new". This node is @@ -2076,9 +2077,15 @@ build_new_1 (VEC(tree,gc) **placement, tree type, tree nelts, } /* Now use a pointer to the type we've actually allocated. */ - data_addr = fold_convert (pointer_type, data_addr); + + /* But we want to operate on a non-const version to start with, + since we'll be modifying the elements. */ + non_const_pointer_type = build_pointer_type + (cp_build_qualified_type (type, TYPE_QUALS (type) & ~TYPE_QUAL_CONST)); + + data_addr = fold_convert (non_const_pointer_type, data_addr); /* Any further uses of alloc_node will want this type, too. */ - alloc_node = fold_convert (pointer_type, alloc_node); + alloc_node = fold_convert (non_const_pointer_type, alloc_node); /* Now initialize the allocated object. Note that we preevaluate the initialization expression, apart from the actual constructor call or @@ -2098,12 +2105,32 @@ build_new_1 (VEC(tree,gc) **placement, tree type, tree nelts, if (array_p) { - if (*init) + tree vecinit = NULL_TREE; + if (*init && VEC_length (tree, *init) == 1 + && BRACE_ENCLOSED_INITIALIZER_P (VEC_index (tree, *init, 0)) + && CONSTRUCTOR_IS_DIRECT_INIT (VEC_index (tree, *init, 0))) + { + tree arraytype, domain; + vecinit = VEC_index (tree, *init, 0); + if (TREE_CONSTANT (nelts)) + domain = compute_array_index_type (NULL_TREE, nelts); + else + { + domain = NULL_TREE; + if (CONSTRUCTOR_NELTS (vecinit) > 0) + warning (0, "non-constant array size in new, unable to " + "verify length of initializer-list"); + } + arraytype = build_cplus_array_type (type, domain); + vecinit = digest_init (arraytype, vecinit); + } + else if (*init) { if (complain & tf_error) permerror (input_location, "ISO C++ forbids initialization in array new"); else return error_mark_node; + vecinit = build_tree_list_vec (*init); } init_expr = build_vec_init (data_addr, @@ -2111,7 +2138,7 @@ build_new_1 (VEC(tree,gc) **placement, tree type, tree nelts, MINUS_EXPR, outer_nelts, integer_one_node, complain), - build_tree_list_vec (*init), + vecinit, explicit_value_init_p, /*from_array=*/0, complain); @@ -2270,7 +2297,7 @@ build_new_1 (VEC(tree,gc) **placement, tree type, tree nelts, /* A new-expression is never an lvalue. */ gcc_assert (!lvalue_p (rval)); - return rval; + return convert (pointer_type, rval); } /* Generate a representation for a C++ "new" expression. *PLACEMENT @@ -2664,6 +2691,7 @@ build_vec_init (tree base, tree maxindex, tree init, inner_elt_type = strip_array_types (type); if (init + && TREE_CODE (atype) == ARRAY_TYPE && (from_array == 2 ? (!CLASS_TYPE_P (inner_elt_type) || !TYPE_HAS_COMPLEX_ASSIGN_REF (inner_elt_type)) @@ -2679,7 +2707,6 @@ build_vec_init (tree base, tree maxindex, tree init, brace-enclosed initializers. In this case, digest_init and store_constructor will handle the semantics for us. */ - gcc_assert (TREE_CODE (atype) == ARRAY_TYPE); stmt_expr = build2 (INIT_EXPR, atype, base, init); return stmt_expr; } diff --git a/gcc/cp/name-lookup.c b/gcc/cp/name-lookup.c index c1032e3f80c..7a8016ffa0b 100644 --- a/gcc/cp/name-lookup.c +++ b/gcc/cp/name-lookup.c @@ -3929,6 +3929,7 @@ qualified_lookup_using_namespace (tree name, tree scope, /* ... and a list of namespace yet to see. */ tree todo = NULL_TREE; tree todo_maybe = NULL_TREE; + tree *todo_weak = &todo_maybe; tree usings; timevar_push (TV_NAME_LOOKUP); /* Look through namespace aliases. */ @@ -3942,9 +3943,7 @@ qualified_lookup_using_namespace (tree name, tree scope, ambiguous_decl (result, binding, flags); /* Consider strong using directives always, and non-strong ones - if we haven't found a binding yet. ??? Shouldn't we consider - non-strong ones if the initial RESULT is non-NULL, but the - binding in the given namespace is? */ + if we haven't found a binding yet. */ for (usings = DECL_NAMESPACE_USING (scope); usings; usings = TREE_CHAIN (usings)) /* If this was a real directive, and we have not seen it. */ @@ -3959,12 +3958,12 @@ qualified_lookup_using_namespace (tree name, tree scope, && !purpose_member (TREE_PURPOSE (usings), seen) && !purpose_member (TREE_PURPOSE (usings), todo)) todo = tree_cons (TREE_PURPOSE (usings), NULL_TREE, todo); - else if ((!result->value && !result->type) + else if (!binding && !purpose_member (TREE_PURPOSE (usings), seen) && !purpose_member (TREE_PURPOSE (usings), todo) && !purpose_member (TREE_PURPOSE (usings), todo_maybe)) - todo_maybe = tree_cons (TREE_PURPOSE (usings), NULL_TREE, - todo_maybe); + *todo_weak = tree_cons (TREE_PURPOSE (usings), NULL_TREE, + *todo_weak); } if (todo) { @@ -3977,6 +3976,7 @@ qualified_lookup_using_namespace (tree name, tree scope, scope = TREE_PURPOSE (todo_maybe); todo = TREE_CHAIN (todo_maybe); todo_maybe = NULL_TREE; + todo_weak = &todo; } else scope = NULL_TREE; /* If there never was a todo list. */ diff --git a/gcc/cp/parser.c b/gcc/cp/parser.c index d6d4d5bbd27..94fba02aa34 100644 --- a/gcc/cp/parser.c +++ b/gcc/cp/parser.c @@ -11591,6 +11591,7 @@ cp_parser_elaborated_type_specifier (cp_parser* parser, tree identifier; tree type = NULL_TREE; tree attributes = NULL_TREE; + tree globalscope; cp_token *token = NULL; /* See if we're looking at the `enum' keyword. */ @@ -11622,9 +11623,6 @@ cp_parser_elaborated_type_specifier (cp_parser* parser, cp_lexer_consume_token (parser->lexer); /* Remember that it's a `typename' type. */ tag_type = typename_type; - /* The `typename' keyword is only allowed in templates. */ - if (!processing_template_decl) - permerror (input_location, "using %<typename%> outside of template"); } /* Otherwise it must be a class-key. */ else @@ -11637,10 +11635,10 @@ cp_parser_elaborated_type_specifier (cp_parser* parser, } /* Look for the `::' operator. */ - cp_parser_global_scope_opt (parser, - /*current_scope_valid_p=*/false); + globalscope = cp_parser_global_scope_opt (parser, + /*current_scope_valid_p=*/false); /* Look for the nested-name-specifier. */ - if (tag_type == typename_type) + if (tag_type == typename_type && !globalscope) { if (!cp_parser_nested_name_specifier (parser, /*typename_keyword_p=*/true, diff --git a/gcc/cp/pt.c b/gcc/cp/pt.c index d042f98f9a3..68250c2aff2 100644 --- a/gcc/cp/pt.c +++ b/gcc/cp/pt.c @@ -7143,7 +7143,7 @@ perform_typedefs_access_check (tree tmpl, tree targs) tree t; if (!tmpl - || (!RECORD_OR_UNION_CODE_P (TREE_CODE (tmpl)) + || (!CLASS_TYPE_P (tmpl) && TREE_CODE (tmpl) != FUNCTION_DECL)) return; @@ -17513,7 +17513,7 @@ get_types_needing_access_check (tree t) if (!(ti = get_template_info (t))) return NULL_TREE; - if (RECORD_OR_UNION_CODE_P (TREE_CODE (t)) + if (CLASS_TYPE_P (t) || TREE_CODE (t) == FUNCTION_DECL) { if (!TI_TEMPLATE (ti)) @@ -17546,7 +17546,7 @@ append_type_to_template_for_access_check_1 (tree t, return; gcc_assert ((TREE_CODE (t) == FUNCTION_DECL - || RECORD_OR_UNION_CODE_P (TREE_CODE (t))) + || CLASS_TYPE_P (t)) && type_decl && TREE_CODE (type_decl) == TYPE_DECL && scope); diff --git a/gcc/cp/semantics.c b/gcc/cp/semantics.c index aa52a362fb7..61dff51ba75 100644 --- a/gcc/cp/semantics.c +++ b/gcc/cp/semantics.c @@ -1827,9 +1827,12 @@ perform_koenig_lookup (tree fn, VEC(tree,gc) *args) tree identifier = NULL_TREE; tree functions = NULL_TREE; tree tmpl_args = NULL_TREE; + bool template_id = false; if (TREE_CODE (fn) == TEMPLATE_ID_EXPR) { + /* Use a separate flag to handle null args. */ + template_id = true; tmpl_args = TREE_OPERAND (fn, 1); fn = TREE_OPERAND (fn, 0); } @@ -1861,8 +1864,8 @@ perform_koenig_lookup (tree fn, VEC(tree,gc) *args) fn = unqualified_fn_lookup_error (identifier); } - if (fn && tmpl_args) - fn = build_nt (TEMPLATE_ID_EXPR, fn, tmpl_args); + if (fn && template_id) + fn = build2 (TEMPLATE_ID_EXPR, unknown_type_node, fn, tmpl_args); return fn; } diff --git a/gcc/cp/tree.c b/gcc/cp/tree.c index 644e53cef9f..a003b44e9de 100644 --- a/gcc/cp/tree.c +++ b/gcc/cp/tree.c @@ -44,7 +44,7 @@ static tree build_cplus_array_type_1 (tree, tree); static int list_hash_eq (const void *, const void *); static hashval_t list_hash_pieces (tree, tree, tree); static hashval_t list_hash (const void *); -static cp_lvalue_kind lvalue_p_1 (const_tree, int); +static cp_lvalue_kind lvalue_p_1 (const_tree); static tree build_target_expr (tree, tree); static tree count_trees_r (tree *, int *, void *); static tree verify_stmt_tree_r (tree *, int *, void *); @@ -55,12 +55,10 @@ static tree handle_com_interface_attribute (tree *, tree, tree, int, bool *); static tree handle_init_priority_attribute (tree *, tree, tree, int, bool *); /* If REF is an lvalue, returns the kind of lvalue that REF is. - Otherwise, returns clk_none. If TREAT_CLASS_RVALUES_AS_LVALUES is - nonzero, rvalues of class type are considered lvalues. */ + Otherwise, returns clk_none. */ static cp_lvalue_kind -lvalue_p_1 (const_tree ref, - int treat_class_rvalues_as_lvalues) +lvalue_p_1 (const_tree ref) { cp_lvalue_kind op1_lvalue_kind = clk_none; cp_lvalue_kind op2_lvalue_kind = clk_none; @@ -72,8 +70,7 @@ lvalue_p_1 (const_tree ref, if (TREE_CODE (ref) == INDIRECT_REF && TREE_CODE (TREE_TYPE (TREE_OPERAND (ref, 0))) == REFERENCE_TYPE) - return lvalue_p_1 (TREE_OPERAND (ref, 0), - treat_class_rvalues_as_lvalues); + return lvalue_p_1 (TREE_OPERAND (ref, 0)); if (TREE_CODE (TREE_TYPE (ref)) == REFERENCE_TYPE) { @@ -82,12 +79,7 @@ lvalue_p_1 (const_tree ref, && TREE_CODE (ref) != PARM_DECL && TREE_CODE (ref) != VAR_DECL && TREE_CODE (ref) != COMPONENT_REF) - { - if (CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (ref)))) - return treat_class_rvalues_as_lvalues ? clk_class : clk_none; - else - return clk_none; - } + return clk_rvalueref; /* lvalue references and named rvalue references are lvalues. */ return clk_ordinary; @@ -108,12 +100,10 @@ lvalue_p_1 (const_tree ref, case WITH_CLEANUP_EXPR: case REALPART_EXPR: case IMAGPART_EXPR: - return lvalue_p_1 (TREE_OPERAND (ref, 0), - treat_class_rvalues_as_lvalues); + return lvalue_p_1 (TREE_OPERAND (ref, 0)); case COMPONENT_REF: - op1_lvalue_kind = lvalue_p_1 (TREE_OPERAND (ref, 0), - treat_class_rvalues_as_lvalues); + op1_lvalue_kind = lvalue_p_1 (TREE_OPERAND (ref, 0)); /* Look at the member designator. */ if (!op1_lvalue_kind) ; @@ -164,35 +154,28 @@ lvalue_p_1 (const_tree ref, if (TREE_SIDE_EFFECTS (TREE_OPERAND (ref, 0)) || TREE_SIDE_EFFECTS (TREE_OPERAND (ref, 1))) return clk_none; - op1_lvalue_kind = lvalue_p_1 (TREE_OPERAND (ref, 0), - treat_class_rvalues_as_lvalues); - op2_lvalue_kind = lvalue_p_1 (TREE_OPERAND (ref, 1), - treat_class_rvalues_as_lvalues); + op1_lvalue_kind = lvalue_p_1 (TREE_OPERAND (ref, 0)); + op2_lvalue_kind = lvalue_p_1 (TREE_OPERAND (ref, 1)); break; case COND_EXPR: op1_lvalue_kind = lvalue_p_1 (TREE_OPERAND (ref, 1) ? TREE_OPERAND (ref, 1) - : TREE_OPERAND (ref, 0), - treat_class_rvalues_as_lvalues); - op2_lvalue_kind = lvalue_p_1 (TREE_OPERAND (ref, 2), - treat_class_rvalues_as_lvalues); + : TREE_OPERAND (ref, 0)); + op2_lvalue_kind = lvalue_p_1 (TREE_OPERAND (ref, 2)); break; case MODIFY_EXPR: return clk_ordinary; case COMPOUND_EXPR: - return lvalue_p_1 (TREE_OPERAND (ref, 1), - treat_class_rvalues_as_lvalues); + return lvalue_p_1 (TREE_OPERAND (ref, 1)); case TARGET_EXPR: - return treat_class_rvalues_as_lvalues ? clk_class : clk_none; + return clk_class; case VA_ARG_EXPR: - return (treat_class_rvalues_as_lvalues - && CLASS_TYPE_P (TREE_TYPE (ref)) - ? clk_class : clk_none); + return (CLASS_TYPE_P (TREE_TYPE (ref)) ? clk_class : clk_none); case CALL_EXPR: /* Any class-valued call would be wrapped in a TARGET_EXPR. */ @@ -209,8 +192,7 @@ lvalue_p_1 (const_tree ref, with a BASELINK. */ /* This CONST_CAST is okay because BASELINK_FUNCTIONS returns its argument unmodified and we assign it to a const_tree. */ - return lvalue_p_1 (BASELINK_FUNCTIONS (CONST_CAST_TREE (ref)), - treat_class_rvalues_as_lvalues); + return lvalue_p_1 (BASELINK_FUNCTIONS (CONST_CAST_TREE (ref))); case NON_DEPENDENT_EXPR: /* We must consider NON_DEPENDENT_EXPRs to be lvalues so that @@ -246,18 +228,33 @@ lvalue_p_1 (const_tree ref, cp_lvalue_kind real_lvalue_p (tree ref) { - return lvalue_p_1 (ref, - /*treat_class_rvalues_as_lvalues=*/0); + cp_lvalue_kind kind = lvalue_p_1 (ref); + if (kind & (clk_rvalueref|clk_class)) + return clk_none; + else + return kind; } -/* This differs from real_lvalue_p in that class rvalues are - considered lvalues. */ +/* This differs from real_lvalue_p in that class rvalues are considered + lvalues. */ bool lvalue_p (const_tree ref) { - return - (lvalue_p_1 (ref, /*class rvalue ok*/ 1) != clk_none); + return (lvalue_p_1 (ref) != clk_none); +} + +/* This differs from real_lvalue_p in that rvalues formed by dereferencing + rvalue references are considered rvalues. */ + +bool +lvalue_or_rvalue_with_address_p (const_tree ref) +{ + cp_lvalue_kind kind = lvalue_p_1 (ref); + if (kind & clk_class) + return false; + else + return (kind != clk_none); } /* Test whether DECL is a builtin that may appear in a @@ -535,7 +532,9 @@ rvalue (tree expr) if (!CLASS_TYPE_P (type) && cp_type_quals (type)) type = TYPE_MAIN_VARIANT (type); - if (!processing_template_decl && real_lvalue_p (expr)) + /* We need to do this for rvalue refs as well to get the right answer + from decltype; see c++/36628. */ + if (!processing_template_decl && lvalue_or_rvalue_with_address_p (expr)) expr = build1 (NON_LVALUE_EXPR, type, expr); else if (type != TREE_TYPE (expr)) expr = build_nop (type, expr); diff --git a/gcc/cp/typeck.c b/gcc/cp/typeck.c index 871c1d36319..6a4802e3375 100644 --- a/gcc/cp/typeck.c +++ b/gcc/cp/typeck.c @@ -6202,8 +6202,11 @@ cp_build_modify_expr (tree lhs, enum tree_code modifycode, tree rhs, { int from_array; - if (!same_or_base_type_p (TYPE_MAIN_VARIANT (lhstype), - TYPE_MAIN_VARIANT (TREE_TYPE (rhs)))) + if (BRACE_ENCLOSED_INITIALIZER_P (rhs)) + rhs = digest_init (lhstype, rhs); + + else if (!same_or_base_type_p (TYPE_MAIN_VARIANT (lhstype), + TYPE_MAIN_VARIANT (TREE_TYPE (rhs)))) { if (complain & tf_error) error ("incompatible types in assignment of %qT to %qT", @@ -6212,7 +6215,8 @@ cp_build_modify_expr (tree lhs, enum tree_code modifycode, tree rhs, } /* Allow array assignment in compiler-generated code. */ - if (!current_function_decl || !DECL_ARTIFICIAL (current_function_decl)) + else if (!current_function_decl + || !DECL_ARTIFICIAL (current_function_decl)) { /* This routine is used for both initialization and assignment. Make sure the diagnostic message differentiates the context. */ diff --git a/gcc/cp/typeck2.c b/gcc/cp/typeck2.c index c43fd763dc0..d68383e380a 100644 --- a/gcc/cp/typeck2.c +++ b/gcc/cp/typeck2.c @@ -913,10 +913,9 @@ process_init_constructor_array (tree type, tree init) /* Vectors are like simple fixed-size arrays. */ len = TYPE_VECTOR_SUBPARTS (type); - /* There cannot be more initializers than needed as otherwise - reshape_init would have already rejected the initializer. */ - if (!unbounded) - gcc_assert (VEC_length (constructor_elt, v) <= len); + /* There must not be more initializers than needed. */ + if (!unbounded && VEC_length (constructor_elt, v) > len) + error ("too many initializers for %qT", type); for (i = 0; VEC_iterate (constructor_elt, v, i, ce); ++i) { diff --git a/gcc/defaults.h b/gcc/defaults.h index 11873a8c8a5..b6cec4b249b 100644 --- a/gcc/defaults.h +++ b/gcc/defaults.h @@ -1138,6 +1138,10 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see LOCAL_ALIGNMENT (TREE_TYPE (DECL), DECL_ALIGN (DECL)) #endif +#ifndef MINIMUM_ALIGNMENT +#define MINIMUM_ALIGNMENT(EXP,MODE,ALIGN) (ALIGN) +#endif + /* Alignment value for attribute ((aligned)). */ #ifndef ATTRIBUTE_ALIGNED_VALUE #define ATTRIBUTE_ALIGNED_VALUE BIGGEST_ALIGNMENT diff --git a/gcc/doc/install.texi b/gcc/doc/install.texi index 06794590491..a480dc5e066 100644 --- a/gcc/doc/install.texi +++ b/gcc/doc/install.texi @@ -1170,6 +1170,14 @@ not provide them. On MIPS targets, make @option{-mno-llsc} the default when no @option{-mllsc} option is passed. +@item --with-synci +On MIPS targets, make @option{-msynci} the default when no +@option{-mno-synci} option is passed. + +@item --without-synci +On MIPS targets, make @option{-mno-synci} the default when no +@option{-msynci} option is passed. This is the default. + @item --with-mips-plt On MIPS targets, make use of copy relocations and PLTs. These features are extensions to the traditional diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index e780d976415..b1f0d99497a 100644 --- a/gcc/doc/invoke.texi +++ b/gcc/doc/invoke.texi @@ -260,7 +260,7 @@ Objective-C and Objective-C++ Dialects}. -Wsystem-headers -Wtrigraphs -Wtype-limits -Wundef -Wuninitialized @gol -Wunknown-pragmas -Wno-pragmas -Wunreachable-code @gol -Wunsuffixed-float-constants -Wunused -Wunused-function @gol --Wunused-label -Wunused-parameter -Wunused-value -Wunused-variable @gol +-Wunused-label -Wunused-parameter -Wno-unused-result -Wunused-value -Wunused-variable @gol -Wvariadic-macros -Wvla @gol -Wvolatile-register-var -Wwrite-strings} @@ -364,6 +364,10 @@ Objective-C and Objective-C++ Dialects}. -frounding-math -fsched2-use-superblocks @gol -fsched2-use-traces -fsched-spec-load -fsched-spec-load-dangerous @gol -fsched-stalled-insns-dep[=@var{n}] -fsched-stalled-insns[=@var{n}] @gol +-fsched-group-heuristic -fsched-critical-path-heuristic @gol +-fsched-spec-insn-heuristic -fsched-reg-pressure-heuristic @gol +-fsched-rank-heuristic -fsched-last-insn-heuristic @gol +-fsched-dep-count-heuristic @gol -fschedule-insns -fschedule-insns2 -fsection-anchors @gol -fselective-scheduling -fselective-scheduling2 @gol -fsel-sched-pipelining -fsel-sched-pipelining-outer-loops @gol @@ -696,7 +700,7 @@ Objective-C and Objective-C++ Dialects}. -mflush-func=@var{func} -mno-flush-func @gol -mbranch-cost=@var{num} -mbranch-likely -mno-branch-likely @gol -mfp-exceptions -mno-fp-exceptions @gol --mvr4130-align -mno-vr4130-align} +-mvr4130-align -mno-vr4130-align -msynci -mno-synci} @emph{MMIX Options} @gccoptlist{-mlibfuncs -mno-libfuncs -mepsilon -mno-epsilon -mabi=gnu @gol @@ -3264,6 +3268,13 @@ Warn whenever a function parameter is unused aside from its declaration. To suppress this warning use the @samp{unused} attribute (@pxref{Variable Attributes}). +@item -Wno-unused-result +@opindex Wunused-result +@opindex Wno-unused-result +Do not warn if a caller of a function marked with attribute +@code{warn_unused_result} (@pxref{Variable Attributes}) does not use +its return value. The default is @option{-Wunused-result}. + @item -Wunused-variable @opindex Wunused-variable @opindex Wno-unused-variable @@ -6227,6 +6238,59 @@ results from the algorithm. This only makes sense when scheduling after register allocation, i.e.@: with @option{-fschedule-insns2} or at @option{-O2} or higher. +@item -fsched-group-heuristic +@opindex fsched-group-heuristic +Enable the group heuristic in the scheduler. This heuristic favors +the instruction that belongs to a schedule group. This is enabled +by default when scheduling is enabled, i.e.@: with @option{-fschedule-insns} +or @option{-fschedule-insns2} or at @option{-O2} or higher. + +@item -fsched-critical-path-heuristic +@opindex fsched-critical-path-heuristic +Enable the critical-path heuristic in the scheduler. This heuristic favors +instructions on the critical path. This is enabled by default when +scheduling is enabled, i.e.@: with @option{-fschedule-insns} +or @option{-fschedule-insns2} or at @option{-O2} or higher. + +@item -fsched-spec-insn-heuristic +@opindex fsched-spec-insn-heuristic +Enable the speculative instruction heuristic in the scheduler. This +heuristic favors speculative instructions with greater dependency weakness. +This is enabled by default when scheduling is enabled, i.e.@: +with @option{-fschedule-insns} or @option{-fschedule-insns2} +or at @option{-O2} or higher. + +@item -fsched-reg-pressure-heuristic +@opindex fsched-reg-pressure-heuristic +Enable the register pressure heuristic in the scheduler. This heuristic +favors the instruction with smaller contribution to register pressure. +This only makes sense when scheduling before register allocation, i.e.@: +with @option{-fschedule-insns} or at @option{-O2} or higher. + +@item -fsched-rank-heuristic +@opindex fsched-rank-heuristic +Enable the rank heuristic in the scheduler. This heuristic favors +the instruction belonging to a basic block with greater size or frequency. +This is enabled by default when scheduling is enabled, i.e.@: +with @option{-fschedule-insns} or @option{-fschedule-insns2} or +at @option{-O2} or higher. + +@item -fsched-last-insn-heuristic +@opindex fsched-last-insn-heuristic +Enable the last-instruction heuristic in the scheduler. This heuristic +favors the instruction that is less dependent on the last instruction +scheduled. This is enabled by default when scheduling is enabled, +i.e.@: with @option{-fschedule-insns} or @option{-fschedule-insns2} or +at @option{-O2} or higher. + +@item -fsched-dep-count-heuristic +@opindex fsched-dep-count-heuristic +Enable the dependent-count heuristic in the scheduler. This heuristic +favors the instruction that has more instructions depending on it. +This is enabled by default when scheduling is enabled, i.e.@: +with @option{-fschedule-insns} or @option{-fschedule-insns2} or +at @option{-O2} or higher. + @item -fsched2-use-traces @opindex fsched2-use-traces Use @option{-fsched2-use-superblocks} algorithm when scheduling after register @@ -13710,6 +13774,22 @@ thinks should execute in parallel. This option only has an effect when optimizing for the VR4130. It normally makes code faster, but at the expense of making it bigger. It is enabled by default at optimization level @option{-O3}. + +@item -msynci +@itemx -mno-synci +@opindex msynci +Enable (disable) generation of @code{synci} instructions on +architectures that support it. The @code{synci} instructions (if +enabled) will be generated when @code{__builtin___clear_cache()} is +compiled. + +This option defaults to @code{-mno-synci}, but the default can be +overridden by configuring with @code{--with-synci}. + +When compiling code for single processor systems, it is generally safe +to use @code{synci}. However, on many multi-core (SMP) systems, it +will not invalidate the instruction caches on all cores and may lead +to undefined behavior. @end table @node MMIX Options diff --git a/gcc/doc/sourcebuild.texi b/gcc/doc/sourcebuild.texi index e4378489773..22b27e76ec9 100644 --- a/gcc/doc/sourcebuild.texi +++ b/gcc/doc/sourcebuild.texi @@ -615,6 +615,8 @@ that should be installed. @item install-man Install man pages for the front end. This target should ignore errors. +@item install-plugin +Install headers needed for plugins. @item srcextra Copies its dependencies into the source directory. This generally should be used for generated files such as Bison output files which are not diff --git a/gcc/doc/tm.texi b/gcc/doc/tm.texi index e328210385c..41ed0317521 100644 --- a/gcc/doc/tm.texi +++ b/gcc/doc/tm.texi @@ -1227,6 +1227,14 @@ One use of this macro is to increase alignment of medium-size data to make it all fit in fewer cache lines. @end defmac +@defmac MINIMUM_ALIGNMENT (@var{exp}, @var{mode}, @var{align}) +If defined, a C expression to compute the minimum required alignment +for dynamic stack realignment purposes for @var{exp} (a type or decl), +@var{mode}, assuming normal alignment @var{align}. + +If this macro is not defined, then @var{align} will be used. +@end defmac + @defmac EMPTY_FIELD_BOUNDARY Alignment in bits to be given to a structure bit-field that follows an empty field such as @code{int : 0;}. diff --git a/gcc/dwarf2asm.c b/gcc/dwarf2asm.c index 4e2c9980feb..c12f809d7ed 100644 --- a/gcc/dwarf2asm.c +++ b/gcc/dwarf2asm.c @@ -1,5 +1,5 @@ /* Dwarf2 assembler output helper routines. - Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2008 + Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009 Free Software Foundation, Inc. This file is part of GCC. @@ -29,7 +29,7 @@ along with GCC; see the file COPYING3. If not see #include "output.h" #include "target.h" #include "dwarf2asm.h" -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "splay-tree.h" #include "ggc.h" #include "tm_p.h" diff --git a/gcc/dwarf2out.c b/gcc/dwarf2out.c index 2e30a0c6702..2c5d0562562 100644 --- a/gcc/dwarf2out.c +++ b/gcc/dwarf2out.c @@ -74,7 +74,7 @@ along with GCC; see the file COPYING3. If not see #include "expr.h" #include "libfuncs.h" #include "except.h" -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "dwarf2out.h" #include "dwarf2asm.h" #include "toplev.h" @@ -283,6 +283,11 @@ typedef struct GTY(()) dw_fde_struct { unsigned stack_realign : 1; /* Whether dynamic realign argument pointer register has been saved. */ unsigned drap_reg_saved: 1; + /* True iff dw_fde_begin label is in text_section or cold_text_section. */ + unsigned in_std_section : 1; + /* True iff dw_fde_unlikely_section_label is in text_section or + cold_text_section. */ + unsigned cold_in_std_section : 1; } dw_fde_node; @@ -3587,6 +3592,7 @@ dwarf2out_begin_prologue (unsigned int line ATTRIBUTE_UNUSED, char label[MAX_ARTIFICIAL_LABEL_BYTES]; char * dup_label; dw_fde_ref fde; + section *fnsec; current_function_func_begin_label = NULL; @@ -3602,7 +3608,8 @@ dwarf2out_begin_prologue (unsigned int line ATTRIBUTE_UNUSED, return; #endif - switch_to_section (function_section (current_function_decl)); + fnsec = function_section (current_function_decl); + switch_to_section (fnsec); ASM_GENERATE_INTERNAL_LABEL (label, FUNC_BEGIN_LABEL, current_function_funcdef_no); ASM_OUTPUT_DEBUG_LABEL (asm_out_file, FUNC_BEGIN_LABEL, @@ -3646,6 +3653,27 @@ dwarf2out_begin_prologue (unsigned int line ATTRIBUTE_UNUSED, fde->all_throwers_are_sibcalls = crtl->all_throwers_are_sibcalls; fde->drap_reg = INVALID_REGNUM; fde->vdrap_reg = INVALID_REGNUM; + if (flag_reorder_blocks_and_partition) + { + section *unlikelysec; + if (first_function_block_is_cold) + fde->in_std_section = 1; + else + fde->in_std_section + = (fnsec == text_section + || (cold_text_section && fnsec == cold_text_section)); + unlikelysec = unlikely_text_section (); + fde->cold_in_std_section + = (unlikelysec == text_section + || (cold_text_section && unlikelysec == cold_text_section)); + } + else + { + fde->in_std_section + = (fnsec == text_section + || (cold_text_section && fnsec == cold_text_section)); + fde->cold_in_std_section = 0; + } args_size = old_args_size = 0; @@ -15107,6 +15135,8 @@ gen_type_die_with_usage (tree type, dw_die_ref context_die, if (type == NULL_TREE || type == error_mark_node) return; + /* If TYPE is a typedef type variant, let's generate debug info + for the parent typedef which TYPE is a type of. */ if (TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL && DECL_ORIGINAL_TYPE (TYPE_NAME (type))) { @@ -17128,12 +17158,14 @@ dwarf2out_finish (const char *filename) if (fde->dw_fde_switched_sections) { - add_ranges_by_labels (fde->dw_fde_hot_section_label, - fde->dw_fde_hot_section_end_label); - add_ranges_by_labels (fde->dw_fde_unlikely_section_label, - fde->dw_fde_unlikely_section_end_label); + if (!fde->in_std_section) + add_ranges_by_labels (fde->dw_fde_hot_section_label, + fde->dw_fde_hot_section_end_label); + if (!fde->cold_in_std_section) + add_ranges_by_labels (fde->dw_fde_unlikely_section_label, + fde->dw_fde_unlikely_section_end_label); } - else + else if (!fde->in_std_section) add_ranges_by_labels (fde->dw_fde_begin, fde->dw_fde_end); } diff --git a/gcc/emit-rtl.c b/gcc/emit-rtl.c index df2b4b749b3..5b42f4a8778 100644 --- a/gcc/emit-rtl.c +++ b/gcc/emit-rtl.c @@ -197,7 +197,6 @@ static mem_attrs *get_mem_attrs (alias_set_type, tree, rtx, rtx, unsigned int, static hashval_t reg_attrs_htab_hash (const void *); static int reg_attrs_htab_eq (const void *, const void *); static reg_attrs *get_reg_attrs (tree, int); -static tree component_ref_for_mem_expr (tree); static rtx gen_const_vector (enum machine_mode, int); static void copy_rtx_if_shared_1 (rtx *orig); @@ -869,7 +868,11 @@ gen_reg_rtx (enum machine_mode mode) if (SUPPORTS_STACK_ALIGNMENT && crtl->stack_alignment_estimated < align && !crtl->stack_realign_processed) - crtl->stack_alignment_estimated = align; + { + unsigned int min_align = MINIMUM_ALIGNMENT (NULL, mode, align); + if (crtl->stack_alignment_estimated < min_align) + crtl->stack_alignment_estimated = min_align; + } if (generating_concat_p && (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT @@ -1425,40 +1428,6 @@ operand_subword_force (rtx op, unsigned int offset, enum machine_mode mode) return result; } -/* Within a MEM_EXPR, we care about either (1) a component ref of a decl, - or (2) a component ref of something variable. Represent the later with - a NULL expression. */ - -static tree -component_ref_for_mem_expr (tree ref) -{ - tree inner = TREE_OPERAND (ref, 0); - - if (TREE_CODE (inner) == COMPONENT_REF) - inner = component_ref_for_mem_expr (inner); - else - { - /* Now remove any conversions: they don't change what the underlying - object is. Likewise for SAVE_EXPR. */ - while (CONVERT_EXPR_P (inner) - || TREE_CODE (inner) == VIEW_CONVERT_EXPR - || TREE_CODE (inner) == SAVE_EXPR) - inner = TREE_OPERAND (inner, 0); - - if (! DECL_P (inner)) - inner = NULL_TREE; - } - - if (inner == TREE_OPERAND (ref, 0) - /* Don't leak SSA-names in the third operand. */ - && (!TREE_OPERAND (ref, 2) - || TREE_CODE (TREE_OPERAND (ref, 2)) != SSA_NAME)) - return ref; - else - return build3 (COMPONENT_REF, TREE_TYPE (ref), inner, - TREE_OPERAND (ref, 1), NULL_TREE); -} - /* Returns 1 if both MEM_EXPR can be considered equal and 0 otherwise. */ @@ -1474,23 +1443,7 @@ mem_expr_equal_p (const_tree expr1, const_tree expr2) if (TREE_CODE (expr1) != TREE_CODE (expr2)) return 0; - if (TREE_CODE (expr1) == COMPONENT_REF) - return - mem_expr_equal_p (TREE_OPERAND (expr1, 0), - TREE_OPERAND (expr2, 0)) - && mem_expr_equal_p (TREE_OPERAND (expr1, 1), /* field decl */ - TREE_OPERAND (expr2, 1)); - - if (INDIRECT_REF_P (expr1)) - return mem_expr_equal_p (TREE_OPERAND (expr1, 0), - TREE_OPERAND (expr2, 0)); - - /* ARRAY_REFs, ARRAY_RANGE_REFs and BIT_FIELD_REFs should already - have been resolved here. */ - gcc_assert (DECL_P (expr1)); - - /* Decls with different pointers can't be equal. */ - return 0; + return operand_equal_p (expr1, expr2, 0); } /* Return OFFSET if XEXP (MEM, 0) - OFFSET is known to be ALIGN @@ -1728,7 +1681,7 @@ set_mem_attributes_minus_bitpos (rtx ref, tree t, int objectp, else if (TREE_CODE (t) == COMPONENT_REF && ! DECL_BIT_FIELD (TREE_OPERAND (t, 1))) { - expr = component_ref_for_mem_expr (t); + expr = t; offset = const0_rtx; apply_bitpos = bitpos; /* ??? Any reason the field size would be different than @@ -1785,7 +1738,8 @@ set_mem_attributes_minus_bitpos (rtx ref, tree t, int objectp, } else if (TREE_CODE (t2) == COMPONENT_REF) { - expr = component_ref_for_mem_expr (t2); + expr = t2; + offset = NULL; if (host_integerp (off_tree, 1)) { offset = GEN_INT (tree_low_cst (off_tree, 1)); diff --git a/gcc/except.c b/gcc/except.c index 4a02fe305b4..06e5529dddc 100644 --- a/gcc/except.c +++ b/gcc/except.c @@ -65,7 +65,7 @@ along with GCC; see the file COPYING3. If not see #include "output.h" #include "dwarf2asm.h" #include "dwarf2out.h" -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "toplev.h" #include "hashtab.h" #include "intl.h" @@ -440,12 +440,16 @@ void expand_resx_expr (tree exp) { int region_nr = TREE_INT_CST_LOW (TREE_OPERAND (exp, 0)); + rtx insn; struct eh_region_d *reg = VEC_index (eh_region, cfun->eh->region_array, region_nr); - gcc_assert (!reg->resume); do_pending_stack_adjust (); - reg->resume = emit_jump_insn (gen_rtx_RESX (VOIDmode, region_nr)); + insn = emit_jump_insn (gen_rtx_RESX (VOIDmode, region_nr)); + if (reg->resume) + reg->resume = gen_rtx_INSN_LIST (VOIDmode, insn, reg->resume); + else + reg->resume = insn; emit_barrier (); } @@ -565,7 +569,7 @@ can_be_reached_by_runtime (sbitmap contains_stmt, struct eh_region_d *r) if (i->type != ERT_MUST_NOT_THROW) { bool found = TEST_BIT (contains_stmt, i->region_number); - if (!found) + if (!found && i->aka) EXECUTE_IF_SET_IN_BITMAP (i->aka, 0, n, bi) if (TEST_BIT (contains_stmt, n)) { @@ -2012,6 +2016,7 @@ build_post_landing_pads (void) /* We delay the generation of the _Unwind_Resume until we generate landing pads. We emit a marker here so as to get good control flow data in the meantime. */ + gcc_assert (!region->resume); region->resume = emit_jump_insn (gen_rtx_RESX (VOIDmode, region->region_number)); emit_barrier (); @@ -2040,6 +2045,7 @@ build_post_landing_pads (void) /* We delay the generation of the _Unwind_Resume until we generate landing pads. We emit a marker here so as to get good control flow data in the meantime. */ + gcc_assert (!region->resume); region->resume = emit_jump_insn (gen_rtx_RESX (VOIDmode, region->region_number)); emit_barrier (); @@ -2080,6 +2086,7 @@ connect_post_landing_pads (void) struct eh_region_d *outer; rtx seq; rtx barrier; + rtx resume_list; region = VEC_index (eh_region, cfun->eh->region_array, i); /* Mind we don't process a region more than once. */ @@ -2088,7 +2095,7 @@ connect_post_landing_pads (void) /* If there is no RESX, or it has been deleted by flow, there's nothing to fix up. */ - if (! region->resume || INSN_DELETED_P (region->resume)) + if (! region->resume) continue; /* Search for another landing pad in this function. */ @@ -2096,46 +2103,55 @@ connect_post_landing_pads (void) if (outer->post_landing_pad) break; - start_sequence (); - - if (outer) + for (resume_list = region->resume; resume_list; + resume_list = (GET_CODE (resume_list) == INSN_LIST + ? XEXP (resume_list, 1) : NULL_RTX)) { - edge e; - basic_block src, dest; - - emit_jump (outer->post_landing_pad); - src = BLOCK_FOR_INSN (region->resume); - dest = BLOCK_FOR_INSN (outer->post_landing_pad); - while (EDGE_COUNT (src->succs) > 0) - remove_edge (EDGE_SUCC (src, 0)); - e = make_edge (src, dest, 0); - e->probability = REG_BR_PROB_BASE; - e->count = src->count; - } - else - { - emit_library_call (unwind_resume_libfunc, LCT_THROW, - VOIDmode, 1, crtl->eh.exc_ptr, ptr_mode); - - /* What we just emitted was a throwing libcall, so it got a - barrier automatically added after it. If the last insn in - the libcall sequence isn't the barrier, it's because the - target emits multiple insns for a call, and there are insns - after the actual call insn (which are redundant and would be - optimized away). The barrier is inserted exactly after the - call insn, so let's go get that and delete the insns after - it, because below we need the barrier to be the last insn in - the sequence. */ - delete_insns_since (NEXT_INSN (last_call_insn ())); - } + rtx resume = (GET_CODE (resume_list) == INSN_LIST + ? XEXP (resume_list, 0) : resume_list); + if (INSN_DELETED_P (resume)) + continue; + start_sequence (); - seq = get_insns (); - end_sequence (); - barrier = emit_insn_before (seq, region->resume); - /* Avoid duplicate barrier. */ - gcc_assert (BARRIER_P (barrier)); - delete_insn (barrier); - delete_insn (region->resume); + if (outer) + { + edge e; + basic_block src, dest; + + emit_jump (outer->post_landing_pad); + src = BLOCK_FOR_INSN (resume); + dest = BLOCK_FOR_INSN (outer->post_landing_pad); + while (EDGE_COUNT (src->succs) > 0) + remove_edge (EDGE_SUCC (src, 0)); + e = make_edge (src, dest, 0); + e->probability = REG_BR_PROB_BASE; + e->count = src->count; + } + else + { + emit_library_call (unwind_resume_libfunc, LCT_THROW, + VOIDmode, 1, crtl->eh.exc_ptr, ptr_mode); + + /* What we just emitted was a throwing libcall, so it got a + barrier automatically added after it. If the last insn in + the libcall sequence isn't the barrier, it's because the + target emits multiple insns for a call, and there are insns + after the actual call insn (which are redundant and would be + optimized away). The barrier is inserted exactly after the + call insn, so let's go get that and delete the insns after + it, because below we need the barrier to be the last insn in + the sequence. */ + delete_insns_since (NEXT_INSN (last_call_insn ())); + } + + seq = get_insns (); + end_sequence (); + barrier = emit_insn_before (seq, resume); + /* Avoid duplicate barrier. */ + gcc_assert (BARRIER_P (barrier)); + delete_insn (barrier); + delete_insn (resume); + } /* ??? From tree-ssa we can wind up with catch regions whose label is not instantiated, but whose resx is present. Now @@ -4419,6 +4435,15 @@ dump_eh_tree (FILE * out, struct function *fun) } if (i->resume) { + rtx resume_list = i->resume; + fprintf (out, " resume:"); + while (GET_CODE (resume_list) == INSN_LIST) + { + fprintf (out, "%i,", INSN_UID (XEXP (resume_list, 0))); + if (NOTE_P (XEXP (resume_list, 0))) + fprintf (out, " (deleted)"); + resume_list = XEXP (resume_list, 1); + } fprintf (out, " resume:%i", INSN_UID (i->resume)); if (NOTE_P (i->resume)) fprintf (out, " (deleted)"); diff --git a/gcc/expmed.c b/gcc/expmed.c index aa8d02d0e83..c73bf21f671 100644 --- a/gcc/expmed.c +++ b/gcc/expmed.c @@ -5343,7 +5343,7 @@ emit_store_flag_1 (rtx target, enum rtx_code code, rtx op0, rtx op1, target = gen_reg_rtx (target_mode); convert_move (target, tem, - 0 == (STORE_FLAG_VALUE + 0 == ((normalizep ? normalizep : STORE_FLAG_VALUE) & ((HOST_WIDE_INT) 1 << (GET_MODE_BITSIZE (word_mode) -1)))); return target; diff --git a/gcc/final.c b/gcc/final.c index 25084431555..e84c2cabdb3 100644 --- a/gcc/final.c +++ b/gcc/final.c @@ -72,6 +72,7 @@ along with GCC; see the file COPYING3. If not see #include "expr.h" #include "cfglayout.h" #include "tree-pass.h" +#include "tree-flow.h" #include "timevar.h" #include "cgraph.h" #include "coverage.h" @@ -4422,6 +4423,8 @@ rest_of_clean_state (void) free_bb_for_insn (); + delete_tree_ssa (); + if (targetm.binds_local_p (current_function_decl)) { unsigned int pref = crtl->preferred_stack_boundary; diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5b1ed772829..aaf2c882dc1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,48 @@ +2009-07-14 Taras Glek <tglek@mozilla.com> + Rafael Espindola <espindola@google.com> + + * Make-lang.in (fortran.install-plugin): New target for + installing plugin headers. + +2009-07-13 H.J. Lu <hongjiu.lu@intel.com> + + * module.c (mio_symbol): Remove the unused variable, formal. + +2009-07-13 Janus Weil <janus@gcc.gnu.org> + + PR fortran/40646 + * module.c (mio_symbol): If the symbol has formal arguments, + the formal namespace will be present. + * resolve.c (resolve_actual_arglist): Correctly handle 'called' + procedure pointer components as actual arguments. + (resolve_fl_derived,resolve_symbol): Make sure the formal namespace + is present. + * trans-expr.c (gfc_conv_procedure_call): Correctly handle the formal + arguments of procedure pointer components. + +2009-07-12 Tobias Burnus <burnus@net-b.de> + Philippe Marguinaud <philippe.marguinaud@meteo.fr> + + PR fortran/40588 + * primary.c (match_charkind_name): Fix condition for $ matching. + + PR libfortran/22423 + * libgfortran.h: Typedef the GFC_DTYPE_* enum. + +2009-07-11 Tobias Burnus <burnus@net-b.de> + + PR fortran/33197 + * check.c (gfc_check_fn_rc2008): New function. + * intrinsic.h (gfc_check_fn_rc2008): New prototype. + * intrinsic.c (add_functions): Add complex tan, cosh, sinh, + and tanh. + +2009-07-10 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/39334 + * primary.c (match_kind_param): Return MATCH_NO if the symbol + has no value. + 2008-07-09 Paul Thomas <pault@gcc.gnu.org> PR fortran/40629 diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index 0ac9bb2262b..38041f09535 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -234,6 +234,8 @@ fortran.install-common: install-finclude-dir installdirs fi ; \ fi +fortran.install-plugin: + fortran.install-info: $(DESTDIR)$(infodir)/gfortran.info fortran.install-man: $(DESTDIR)$(man1dir)/$(GFORTRAN_INSTALL_NAME)$(man1ext) diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 103c9417790..8f949d2c093 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1212,6 +1212,23 @@ gfc_check_fn_rc (gfc_expr *a) gfc_try +gfc_check_fn_rc2008 (gfc_expr *a) +{ + if (real_or_complex_check (a, 0) == FAILURE) + return FAILURE; + + if (a->ts.type == BT_COMPLEX + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' " + "argument of '%s' intrinsic at %L", + gfc_current_intrinsic_arg[0], gfc_current_intrinsic, + &a->where) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try gfc_check_fnum (gfc_expr *unit) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 9402234b034..a918ddf7d23 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1440,7 +1440,7 @@ add_functions (void) make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77); add_sym_1 ("cosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_cosh, gfc_resolve_cosh, + gfc_check_fn_rc2008, gfc_simplify_cosh, gfc_resolve_cosh, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dcosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, @@ -2405,7 +2405,7 @@ add_functions (void) make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77); add_sym_1 ("sinh", GFC_ISYM_SINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_sinh, gfc_resolve_sinh, + gfc_check_fn_rc2008, gfc_simplify_sinh, gfc_resolve_sinh, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dsinh", GFC_ISYM_SINH,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, @@ -2488,7 +2488,7 @@ add_functions (void) make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU); add_sym_1 ("tan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_tan, gfc_resolve_tan, + gfc_check_fn_rc2008, gfc_simplify_tan, gfc_resolve_tan, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dtan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, @@ -2498,7 +2498,7 @@ add_functions (void) make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77); add_sym_1 ("tanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_tanh, gfc_resolve_tanh, + gfc_check_fn_rc2008, gfc_simplify_tanh, gfc_resolve_tanh, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dtanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index d1bf846c264..1e2fbd7a027 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -64,6 +64,7 @@ gfc_try gfc_check_fn_c (gfc_expr *); gfc_try gfc_check_fn_d (gfc_expr *); gfc_try gfc_check_fn_r (gfc_expr *); gfc_try gfc_check_fn_rc (gfc_expr *); +gfc_try gfc_check_fn_rc2008 (gfc_expr *); gfc_try gfc_check_fnum (gfc_expr *); gfc_try gfc_check_hostnm (gfc_expr *); gfc_try gfc_check_huge (gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index eb0956adb22..34783b4a5e0 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -2676,7 +2676,7 @@ Inverse function: @ref{ACOS} @code{COSH(X)} computes the hyperbolic cosine of @var{X}. @item @emph{Standard}: -Fortran 77 and later +Fortran 77 and later, for a complex argument Fortran 2008 or later @item @emph{Class}: Elemental function @@ -2686,14 +2686,14 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL}. +@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL} and it is positive -(@math{ \cosh (x) \geq 0 }). For a @code{REAL} argument @var{X}, -@math{ \cosh (x) \geq 1 }. -The return value is of the same kind as @var{X}. +The return value has same type and kind as @var{X}. If @var{X} is +complex, the imaginary part of the result is in radians. If @var{X} +is @code{REAL}, the return value has a lower bound of one, +@math{\cosh (x) \geq 1}. @item @emph{Example}: @smallexample @@ -9820,7 +9820,7 @@ end program test_sin @code{SINH(X)} computes the hyperbolic sine of @var{X}. @item @emph{Standard}: -Fortran 95 and later +Fortran 95 and later, for a complex argument Fortran 2008 or later @item @emph{Class}: Elemental function @@ -9830,11 +9830,11 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL}. +@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL}. +The return value has same type and kind as @var{X}. @item @emph{Example}: @smallexample @@ -10508,7 +10508,7 @@ END PROGRAM @code{TAN(X)} computes the tangent of @var{X}. @item @emph{Standard}: -Fortran 77 and later +Fortran 77 and later, for a complex argument Fortran 2008 or later @item @emph{Class}: Elemental function @@ -10518,12 +10518,11 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL}. +@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL}. The kind type parameter is -the same as @var{X}. +The return value has same type and kind as @var{X}. @item @emph{Example}: @smallexample @@ -10558,7 +10557,7 @@ end program test_tan @code{TANH(X)} computes the hyperbolic tangent of @var{X}. @item @emph{Standard}: -Fortran 77 and later +Fortran 77 and later, for a complex argument Fortran 2008 or later @item @emph{Class}: Elemental function @@ -10568,11 +10567,13 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL}. +@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}. @end multitable @item @emph{Return value}: -The return value is of type @code{REAL} and lies in the range +The return value has same type and kind as @var{X}. If @var{X} is +complex, the imaginary part of the result is in radians. If @var{X} +is @code{REAL}, the return value lies in the range @math{ - 1 \leq tanh(x) \leq 1 }. @item @emph{Example}: diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index a18fdce2e88..d66020717a4 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -110,7 +110,7 @@ libgfortran_error_codes; #define GFC_DTYPE_TYPE_MASK 0x38 #define GFC_DTYPE_SIZE_SHIFT 6 -enum +typedef enum { GFC_DTYPE_UNKNOWN = 0, GFC_DTYPE_INTEGER, @@ -120,5 +120,6 @@ enum GFC_DTYPE_COMPLEX, GFC_DTYPE_DERIVED, GFC_DTYPE_CHARACTER -}; +} +dtype; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 7e6e8ff93c4..f16f8d3f72e 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -3432,26 +3432,13 @@ mio_symbol (gfc_symbol *sym) { int intmod = INTMOD_NONE; - gfc_formal_arglist *formal; - mio_lparen (); mio_symbol_attribute (&sym->attr); mio_typespec (&sym->ts); - /* Contained procedures don't have formal namespaces. Instead we output the - procedure namespace. The will contain the formal arguments. */ if (iomode == IO_OUTPUT) - { - formal = sym->formal; - while (formal && !formal->sym) - formal = formal->next; - - if (formal) - mio_namespace_ref (&formal->sym->ns); - else - mio_namespace_ref (&sym->formal_ns); - } + mio_namespace_ref (&sym->formal_ns); else { mio_namespace_ref (&sym->formal_ns); diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 4a84aedbc30..0d52c6c0940 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -57,6 +57,9 @@ match_kind_param (int *kind) if (sym->attr.flavor != FL_PARAMETER) return MATCH_NO; + if (sym->value == NULL) + return MATCH_NO; + p = gfc_extract_int (sym->value, kind); if (p != NULL) return MATCH_NO; @@ -829,7 +832,7 @@ match_charkind_name (char *name) if (!ISALNUM (c) && c != '_' - && (gfc_option.flag_dollar_ok && c != '$')) + && (c != '$' || !gfc_option.flag_dollar_ok)) break; *name++ = c; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9b091ad0162..880dfd0e886 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1239,7 +1239,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (gfc_is_proc_ptr_comp (e, &comp)) { e->ts = comp->ts; - e->expr_type = EXPR_VARIABLE; + if (e->value.compcall.actual == NULL) + e->expr_type = EXPR_VARIABLE; + else + { + if (comp->as != NULL) + e->rank = comp->as->rank; + e->expr_type = EXPR_FUNCTION; + } goto argument_list; } @@ -8993,6 +9000,9 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) } +static void resolve_symbol (gfc_symbol *sym); + + /* Resolve the components of a derived type. */ static gfc_try @@ -9031,6 +9041,9 @@ resolve_fl_derived (gfc_symbol *sym) { gfc_symbol *ifc = c->ts.interface; + if (ifc->formal && !ifc->formal_ns) + resolve_symbol (ifc); + if (ifc->attr.intrinsic) resolve_intrinsic (ifc, &ifc->declared_at); @@ -9832,6 +9845,20 @@ resolve_symbol (gfc_symbol *sym) if (sym->formal_ns && sym->formal_ns != gfc_current_ns) gfc_resolve (sym->formal_ns); + /* Make sure the formal namespace is present. */ + if (sym->formal && !sym->formal_ns) + { + gfc_formal_arglist *formal = sym->formal; + while (formal && !formal->sym) + formal = formal->next; + + if (formal) + { + sym->formal_ns = formal->sym->ns; + sym->formal_ns->refs++; + } + } + /* Check threadprivate restrictions. */ if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all && (!sym->attr.in_common diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b6a825a8125..787251d7627 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2560,7 +2560,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, != EXPR_CONSTANT) || (comp && comp->attr.dimension) || (!comp && sym->attr.dimension)); - formal = sym->formal; + if (comp) + formal = comp->formal; + else + formal = sym->formal; /* Evaluate the arguments. */ for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) { diff --git a/gcc/function.c b/gcc/function.c index 93244dba76b..e31c12ada35 100644 --- a/gcc/function.c +++ b/gcc/function.c @@ -2976,9 +2976,17 @@ assign_parm_setup_stack (struct assign_parm_data_all *all, tree parm, TYPE_UNSIGNED (TREE_TYPE (parm))); if (data->stack_parm) - /* ??? This may need a big-endian conversion on sparc64. */ - data->stack_parm - = adjust_address (data->stack_parm, data->nominal_mode, 0); + { + int offset = subreg_lowpart_offset (data->nominal_mode, + GET_MODE (data->stack_parm)); + /* ??? This may need a big-endian conversion on sparc64. */ + data->stack_parm + = adjust_address (data->stack_parm, data->nominal_mode, 0); + if (offset && MEM_OFFSET (data->stack_parm)) + set_mem_offset (data->stack_parm, + plus_constant (MEM_OFFSET (data->stack_parm), + offset)); + } } if (data->entry_parm != data->stack_parm) @@ -3138,8 +3146,12 @@ assign_parms (tree fndecl) { unsigned int align = FUNCTION_ARG_BOUNDARY (data.promoted_mode, data.passed_type); + align = MINIMUM_ALIGNMENT (data.passed_type, data.promoted_mode, + align); if (TYPE_ALIGN (data.nominal_type) > align) - align = TYPE_ALIGN (data.passed_type); + align = MINIMUM_ALIGNMENT (data.nominal_type, + TYPE_MODE (data.nominal_type), + TYPE_ALIGN (data.nominal_type)); if (crtl->stack_alignment_estimated < align) { gcc_assert (!crtl->stack_realign_processed); diff --git a/gcc/haifa-sched.c b/gcc/haifa-sched.c index 66be7e5d94b..95cbfc1b1a8 100644 --- a/gcc/haifa-sched.c +++ b/gcc/haifa-sched.c @@ -890,7 +890,8 @@ rank_for_schedule (const void *x, const void *y) int val, priority_val, weight_val, info_val; /* The insn in a schedule group should be issued the first. */ - if (SCHED_GROUP_P (tmp) != SCHED_GROUP_P (tmp2)) + if (flag_sched_group_heuristic && + SCHED_GROUP_P (tmp) != SCHED_GROUP_P (tmp2)) return SCHED_GROUP_P (tmp2) ? 1 : -1; /* Make sure that priority of TMP and TMP2 are initialized. */ @@ -899,11 +900,11 @@ rank_for_schedule (const void *x, const void *y) /* Prefer insn with higher priority. */ priority_val = INSN_PRIORITY (tmp2) - INSN_PRIORITY (tmp); - if (priority_val) + if (flag_sched_critical_path_heuristic && priority_val) return priority_val; /* Prefer speculative insn with greater dependencies weakness. */ - if (spec_info) + if (flag_sched_spec_insn_heuristic && spec_info) { ds_t ds1, ds2; dw_t dw1, dw2; @@ -927,16 +928,16 @@ rank_for_schedule (const void *x, const void *y) } /* Prefer an insn with smaller contribution to registers-pressure. */ - if (!reload_completed && + if (flag_sched_reg_pressure_heuristic && !reload_completed && (weight_val = INSN_REG_WEIGHT (tmp) - INSN_REG_WEIGHT (tmp2))) return weight_val; info_val = (*current_sched_info->rank) (tmp, tmp2); - if (info_val) + if(flag_sched_rank_heuristic && info_val) return info_val; /* Compare insns based on their relation to the last-scheduled-insn. */ - if (INSN_P (last_scheduled_insn)) + if (flag_sched_last_insn_heuristic && INSN_P (last_scheduled_insn)) { dep_t dep1; dep_t dep2; @@ -977,7 +978,7 @@ rank_for_schedule (const void *x, const void *y) val = (sd_lists_size (tmp2, SD_LIST_FORW) - sd_lists_size (tmp, SD_LIST_FORW)); - if (val != 0) + if (flag_sched_dep_count_heuristic && val != 0) return val; /* If insns are equally good, sort by INSN_LUID (original insn order), diff --git a/gcc/java/ChangeLog b/gcc/java/ChangeLog index 9f90f53b4d6..9e7e5f517eb 100644 --- a/gcc/java/ChangeLog +++ b/gcc/java/ChangeLog @@ -1,3 +1,9 @@ +2009-07-14 Taras Glek <tglek@mozilla.com> + Rafael Espindola <espindola@google.com> + + * Make-lang.in (java.install-plugin): New target for + installing plugin headers. + 2009-07-07 Manuel López-Ibáñez <manu@gcc.gnu.org> * class.c: Replace %J by an explicit location. Update all calls. diff --git a/gcc/java/Make-lang.in b/gcc/java/Make-lang.in index 263ddc39b04..094e5e1bcfb 100644 --- a/gcc/java/Make-lang.in +++ b/gcc/java/Make-lang.in @@ -180,6 +180,7 @@ java.install-common: installdirs fi ; \ done +java.install-plugin: java.install-man: java.uninstall: diff --git a/gcc/objc/ChangeLog b/gcc/objc/ChangeLog index 00475c1ac1e..13d537e4316 100644 --- a/gcc/objc/ChangeLog +++ b/gcc/objc/ChangeLog @@ -1,3 +1,9 @@ +2009-07-14 Taras Glek <tglek@mozilla.com> + Rafael Espindola <espindola@google.com> + + * Make-lang.in (objc.install-plugin): New target for + installing plugin headers. + 2009-07-07 Manuel López-Ibáñez <manu@gcc.gnu.org> * objc-act.c (next_sjlj_build_catch_list): Replace EXPR_LOCUS by diff --git a/gcc/objc/Make-lang.in b/gcc/objc/Make-lang.in index bfe8a849091..fad506b7640 100644 --- a/gcc/objc/Make-lang.in +++ b/gcc/objc/Make-lang.in @@ -98,6 +98,7 @@ objc.html: objc.man: objc.srcinfo: objc.srcman: +objc.install-plugin: objc.tags: force cd $(srcdir)/objc; etags -o TAGS.sub *.c *.h; \ diff --git a/gcc/objcp/ChangeLog b/gcc/objcp/ChangeLog index 526830f588b..a19627ca4a3 100644 --- a/gcc/objcp/ChangeLog +++ b/gcc/objcp/ChangeLog @@ -1,3 +1,9 @@ +2009-07-14 Taras Glek <tglek@mozilla.com> + Rafael Espindola <espindola@google.com> + + * Make-lang.in (obj-c.install-plugin): New target for + installing plugin headers. + 2009-06-19 Ian Lance Taylor <iant@google.com> * objcp-decl.h (start_struct): Remove in_struct and struct_types diff --git a/gcc/objcp/Make-lang.in b/gcc/objcp/Make-lang.in index 2b1b8098429..0f549d07a41 100644 --- a/gcc/objcp/Make-lang.in +++ b/gcc/objcp/Make-lang.in @@ -107,6 +107,7 @@ obj-c++.html: obj-c++.srcinfo: obj-c++.srcextra: obj-c++.man: +obj-c++.install-plugin: obj-c++.tags: force cd $(srcdir)/objcp; etags -o TAGS.sub *.y *.c *.h; \ diff --git a/gcc/print-rtl.c b/gcc/print-rtl.c index 7f8a6c9b501..fa02699707e 100644 --- a/gcc/print-rtl.c +++ b/gcc/print-rtl.c @@ -40,6 +40,7 @@ along with GCC; see the file COPYING3. If not see #include "flags.h" #include "hard-reg-set.h" #include "basic-block.h" +#include "diagnostic.h" #endif static FILE *outfile; @@ -72,60 +73,11 @@ int flag_simple = 0; int dump_for_graph; #ifndef GENERATOR_FILE -static void -print_decl_name (FILE *outfile, const_tree node) -{ - if (DECL_NAME (node)) - fputs (IDENTIFIER_POINTER (DECL_NAME (node)), outfile); - else - { - if (TREE_CODE (node) == LABEL_DECL && LABEL_DECL_UID (node) != -1) - fprintf (outfile, "L.%d", (int) LABEL_DECL_UID (node)); - else - { - char c = TREE_CODE (node) == CONST_DECL ? 'C' : 'D'; - fprintf (outfile, "%c.%u", c, DECL_UID (node)); - } - } -} - void print_mem_expr (FILE *outfile, const_tree expr) { - if (TREE_CODE (expr) == COMPONENT_REF) - { - if (TREE_OPERAND (expr, 0)) - print_mem_expr (outfile, TREE_OPERAND (expr, 0)); - else - fputs (" <variable>", outfile); - fputc ('.', outfile); - print_decl_name (outfile, TREE_OPERAND (expr, 1)); - } - else if (TREE_CODE (expr) == INDIRECT_REF) - { - fputs (" (*", outfile); - print_mem_expr (outfile, TREE_OPERAND (expr, 0)); - fputs (")", outfile); - } - else if (TREE_CODE (expr) == ALIGN_INDIRECT_REF) - { - fputs (" (A*", outfile); - print_mem_expr (outfile, TREE_OPERAND (expr, 0)); - fputs (")", outfile); - } - else if (TREE_CODE (expr) == MISALIGNED_INDIRECT_REF) - { - fputs (" (M*", outfile); - print_mem_expr (outfile, TREE_OPERAND (expr, 0)); - fputs (")", outfile); - } - else if (TREE_CODE (expr) == RESULT_DECL) - fputs (" <result>", outfile); - else - { - fputc (' ', outfile); - print_decl_name (outfile, expr); - } + fputc (' ', outfile); + print_generic_expr (outfile, CONST_CAST_TREE (expr), 0); } #endif diff --git a/gcc/target-def.h b/gcc/target-def.h index ddf3e0adc4f..54060f5395c 100644 --- a/gcc/target-def.h +++ b/gcc/target-def.h @@ -827,8 +827,8 @@ #define TARGET_OPTION_PRAGMA_PARSE default_target_option_pragma_parse #endif -#ifndef TARGET_OPTION_CAN_INLINE_P -#define TARGET_OPTION_CAN_INLINE_P default_target_option_can_inline_p +#ifndef TARGET_CAN_INLINE_P +#define TARGET_CAN_INLINE_P default_target_can_inline_p #endif #define TARGET_OPTION_HOOKS \ @@ -838,7 +838,7 @@ TARGET_OPTION_RESTORE, \ TARGET_OPTION_PRINT, \ TARGET_OPTION_PRAGMA_PARSE, \ - TARGET_OPTION_CAN_INLINE_P, \ + TARGET_CAN_INLINE_P, \ } /* The whole shebang. */ diff --git a/gcc/targhooks.c b/gcc/targhooks.c index 50a82f47faf..7d5a09233c7 100644 --- a/gcc/targhooks.c +++ b/gcc/targhooks.c @@ -771,7 +771,7 @@ default_target_option_pragma_parse (tree ARG_UNUSED (args), } bool -default_target_option_can_inline_p (tree caller, tree callee) +default_target_can_inline_p (tree caller, tree callee) { bool ret = false; tree callee_opts = DECL_FUNCTION_SPECIFIC_TARGET (callee); diff --git a/gcc/targhooks.h b/gcc/targhooks.h index 5d77ce5854b..839f1c32360 100644 --- a/gcc/targhooks.h +++ b/gcc/targhooks.h @@ -107,5 +107,5 @@ extern tree default_emutls_var_init (tree, tree, tree); extern bool default_hard_regno_scratch_ok (unsigned int); extern bool default_target_option_valid_attribute_p (tree, tree, tree, int); extern bool default_target_option_pragma_parse (tree, tree); -extern bool default_target_option_can_inline_p (tree, tree); +extern bool default_target_can_inline_p (tree, tree); extern unsigned int default_case_values_threshold (void); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 674429c44f8..140bb9e863e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,201 @@ +2009-07-14 Taras Glek <tglek@mozilla.com> + Rafael Espindola <espindola@google.com> + + * g++.dg/plugin/header-plugin-test.C: New. + * g++.dg/plugin/header_plugin.c: New. + * g++.dg/plugin/plugin.exp: Update. + +2009-07-14 Uros Bizjak <ubizjak@gmail.com> + + * gcc.target/i386/sse-recip-vec.c: Move arrays out of test + function to enable vectorization. + * gcc.target/i386/sse2-lrint-vec.c: Ditto. + * gcc.target/i386/sse2-lrintf-vec.c: Ditto. + +2009-07-14 Uros Bizjak <ubizjak@gmail.com> + + * gcc.target/i386/sse-copysignf-vec.c: New test. + * gcc.target/i386/sse2-copysign-vec.c: Ditto. + +2009-07-14 Jason Merrill <jason@redhat.com> + + PR c++/37276 + * g++.dg/lookup/builtin5.C: New. + * g++.dg/other/error22.C: Add missing extern "C". + * g++.dg/warn/Warray-bounds.C: Likewise. + * gcc.dg/compat/compat-common.h: Likewise. + + PR c++/40746 + * g++.dg/lookup/using20.C: New. + + PR c++/40740 + * g++.dg/template/koenig8.C: New. + +2009-07-14 Jack Howarth <howarth@bromo.med.uc.edu> + + * testsuite/gcc.c-torture/compile/20000804-1.c: skip for ilp32 on + both i?86-*-darwin* and x86_64-*-darwin*. + +2009-07-14 Joseph Myers <joseph@codesourcery.com> + + * gcc.target/i386/pr37843-1.c, gcc.target/i386/pr37843-2.c, + gcc.target/i386/pr37843-3.c: Allow leading underscore on function + name. + +2009-07-14 Dodji Seketeli <dodji@redhat.com> + + PR debug/40705 + * g++.dg/debug/dwarf2/typedef1.C: New test. + + PR c++/403057 + * g++.dg/other/typedef3.C: New test. + +2009-07-14 Maxim Kuvyrkov <maxim@codesourcery.com> + + * gcc.dg/20090709-1.c: Move to a proper place ... + * gcc.target/m68k/20090709-1.c: ... here. + +2009-07-13 Andrew Pinski <andrew_pinski@playstation.sony.com> + + PR C++/22154 + * g++.old-deja/g++.pt/typename10.C: Update for DR 382, typename in + front of qualified names are allowed. + * g++.dg/parse/crash10.C: Likewise. + * g++.dg/parse/error15.C: Likewise. + * g++.dg/parse/typename9.C: Likewise. + * g++.dg/parse/error8.C: Likewise. + +2009-07-13 Janus Weil <janus@gcc.gnu.org> + + PR fortran/40646 + * gfortran.dg/proc_ptr_22.f90: Extended. + * gfortran.dg/proc_ptr_comp_12.f90: Extended. + +2009-07-13 Ira Rosen <irar@il.ibm.com> + + * gfortran.dg/vect/vect-6.f: New test. + +2009-07-12 Jason Merrill <jason@redhat.com> + + PR c++/36628 + * g++.dg/cpp0x/decltype17.C: New. + + PR c++/37206 + * g++.dg/cpp0x/rv10.C: New. + +2009-07-12 Jason Merrill <jason@redhat.com> + + PR c++/40689 + * g++.dg/cpp0x/initlist20.C: New. + * g++.dg/cpp0x/initlist21.C: New. + +2009-07-12 Ira Rosen <irar@il.ibm.com> + + * gcc.dg/vect/no-scevccp-outer-2.c: Expect to vectorize. + * gcc.dg/vect/vect-double-reduc-1.c, gcc.dg/vect/vect-double-reduc-2.c, + gcc.dg/vect/vect-double-reduc-3.c, gcc.dg/vect/vect-double-reduc-4.c, + gcc.dg/vect/vect-double-reduc-5.c, gcc.dg/vect/vect-double-reduc-6.c, + gcc.dg/vect/vect-double-reduc-7.c: New tests. + +2009-07-12 Hans-Peter Nilsson <hp@axis.com> + + * gfortran.dg/f2003_io_4.f03, gfortran.dg/read_size_noadvance.f90, + gfortran.dg/namelist_39.f90, gfortran.dg/read_repeat.f90, + gfortran.dg/fmt_exhaust.f90, gfortran.dg/fseek.f90, + gfortran.dg/fmt_t_7.f, gfortran.dg/read_x_past.f, + gfortran.dg/read_bad_advance.f90, gfortran.dg/backslash_3.f, + gfortran.dg/namelist_56.f90, gfortran.dg/list_read_5.f90, + gfortran.dg/fmt_cache_1.f, gfortran.dg/fmt_t_4.f90: Gate test on + effective_target fd_truncate. + +2009-07-11 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/specs/addr1.ads: New test. + +2009-07-11 Jan Hubicka <jh@suse.cz> + + PR middle-end/48388 + * g++.dg/torture/pr40388.C: New testcase. + +2009-07-11 Jakub Jelinek <jakub@redhat.com> + + PR target/40668 + * gcc.c-torture/execute/pr40668.c: New test. + +2009-07-11 Paolo Bonzini <bonzini@gnu.org> + + * gcc.c-torture/execute/20090711-1.c: New test. + +2009-07-11 Richard Sandiford <rdsandiford@googlemail.com> + + PR testsuite/40699 + PR testsuite/40707 + PR testsuite/40709 + * lib/gcc-defs.exp, lib/target-libpath.exp, lib/objc.exp, + lib/gfortran.exp, lib/g++.exp, lib/obj-c++.exp, lib/c-torture.exp, + lib/gcc-dg.exp, lib/gnat.exp, g++.dg/compat/compat.exp, + g++.dg/compat/struct-layout-1.exp: Revert 2009-06-30 commit. + +2009-07-11 Tobias Burnus <burnus@net-b.de> + + PR fortran/33197 + * gfortran.dg/complex_intrinsic_3.f90: New test. + * gfortran.dg/complex_intrinsic_4.f90: New test. + +2009-07-10 David Daney <ddaney@caviumnetworks.com> + + PR target/39079 + * testsuite/gcc.target/mips/mips.exp: Make -msynci a known option. + * gcc.target/mips/clear-cache-1.c (dg-options): Add -msynci. + +2009-07-10 Jakub Jelinek <jakub@redhat.com> + + PR c++/40502 + * g++.dg/ext/strncpy-chk1.C: New test. + +2009-07-10 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/40496 + * g++.dg/opt/pr40496.C: New testcase. + +2009-07-10 Manuel López-Ibáñez <manu@gcc.gnu.org> + + PR 25509 + PR 40614 + * g++.dg/warn/unused-result1-Werror.c: New. + +2009-07-10 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/39334 + * gfortran.dg/recursive_parameter_1.f90: New test. + +2009-07-09 Steven G. Kargl <kargl@gcc.gnu.org> + + * gfortran.dg/c_kind_tests_2.f03: clean-up leftover module(s). + * gfortran.dg/module_equivalence_6.f90: Ditto. + * gfortran.dg/alloc_comp_auto_array_2.f90: Ditto. + * gfortran.dg/nan_2.f90: Ditto. + * gfortran.dg/inquire_11.f90: Ditto. + * gfortran.dg/abstract_type_3.f03: Ditto. + * gfortran.dg/abstract_type_1.f90: Ditto. + * gfortran.dg/private_type_9.f90: Ditto. + * gfortran.dg/abstract_type_5.f03: Ditto. + * gfortran.dg/elemental_subroutine_6.f90: Ditto. + * gfortran.dg/derived_comp_array_ref_3.f90: Ditto. + * gfortran.dg/derived_sub.f90: Ditto. + * gfortran.dg/missing_optional_dummy_5.f90: Ditto. + * gfortran.dg/bounds_check_fail_2.f90: Ditto. + * gfortran.dg/maxloc_bounds_6.f90: Ditto. + * gfortran.dg/mvbits_6.f90: Ditto. + * gfortran.dg/abstract_type_2.f03: Ditto. + * gfortran.dg/abstract_type_4.f03: Ditto. + * gfortran.dg/bounds_check_9.f90: Ditto. + * gfortran.dg/optional_dim_3.f90: Ditto. + * gfortran.dg/pr32921.f: Ditto. + * gfortran.dg/entry_16.f90: Ditto. + * gfortran.dg/generic_16.f90: Ditto. + + 2009-07-09 Maxim Kuvyrkov <maxim@codesourcery.com> * gcc.target/m68k/20090709-1.c: New. diff --git a/gcc/testsuite/g++.dg/compat/compat.exp b/gcc/testsuite/g++.dg/compat/compat.exp index 0ca91bfb059..7fb16fed959 100644 --- a/gcc/testsuite/g++.dg/compat/compat.exp +++ b/gcc/testsuite/g++.dg/compat/compat.exp @@ -103,14 +103,14 @@ set sid "cp_compat" # are different. set use_alt 0 set same_alt 0 -set alt_ld_library_path "" +set alt_ld_library_path "." if [info exists ALT_CXX_UNDER_TEST] then { set use_alt 1 if [string match "same" $ALT_CXX_UNDER_TEST] then { set same_alt 1 } else { if [info exists ALT_LD_LIBRARY_PATH] then { - set alt_ld_library_path $ALT_LD_LIBRARY_PATH + append alt_ld_library_path ":${ALT_LD_LIBRARY_PATH}" } } } diff --git a/gcc/testsuite/g++.dg/compat/struct-layout-1.exp b/gcc/testsuite/g++.dg/compat/struct-layout-1.exp index f8c26512710..7fa89470e16 100644 --- a/gcc/testsuite/g++.dg/compat/struct-layout-1.exp +++ b/gcc/testsuite/g++.dg/compat/struct-layout-1.exp @@ -109,14 +109,14 @@ set sid "cp_compat" # are different. set use_alt 0 set same_alt 0 -set alt_ld_library_path "" +set alt_ld_library_path "." if [info exists ALT_CXX_UNDER_TEST] then { set use_alt 1 if [string match "same" $ALT_CXX_UNDER_TEST] then { set same_alt 1 } else { if [info exists ALT_LD_LIBRARY_PATH] then { - set alt_ld_library_path $ALT_LD_LIBRARY_PATH + append alt_ld_library_path ":${ALT_LD_LIBRARY_PATH}" } } } diff --git a/gcc/testsuite/g++.dg/cpp0x/decltype17.C b/gcc/testsuite/g++.dg/cpp0x/decltype17.C new file mode 100644 index 00000000000..3c98105fced --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/decltype17.C @@ -0,0 +1,29 @@ +// PR c++/36628 +// { dg-options "-std=c++0x" } +// { dg-do run } + +#include <typeinfo> +#include <string.h> + +int rvalue(); +int& lvalueref(); +int&& rvalueref(); + +decltype(true ? rvalue() : rvalue()) f() +{} + +decltype(true ? lvalueref() : lvalueref()) g() +{} + +decltype(true ? rvalueref() : rvalueref()) h() +{} + +int main() +{ + if (strcmp (typeid(f).name(), "FivE") != 0) + return 1; + if (strcmp (typeid(g).name(), "FRivE") != 0) + return 2; + if (strcmp (typeid(h).name(), "FivE") != 0) + return 3; +} diff --git a/gcc/testsuite/g++.dg/cpp0x/initlist20.C b/gcc/testsuite/g++.dg/cpp0x/initlist20.C new file mode 100644 index 00000000000..fcdb73f190c --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/initlist20.C @@ -0,0 +1,17 @@ +// PR c++/40689 +// { dg-options "-std=c++0x" } + +class X +{ + public: + X(): data {1,2,3,4,5} {} + private: + const short data[5]; +}; + +int main() +{ + const float * pData = new const float[4] { 1.5, 2.5, 3.5, 4.5 }; + + return 0; +} diff --git a/gcc/testsuite/g++.dg/cpp0x/initlist21.C b/gcc/testsuite/g++.dg/cpp0x/initlist21.C new file mode 100644 index 00000000000..9412a085170 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/initlist21.C @@ -0,0 +1,18 @@ +// PR c++/40689 +// { dg-options "-std=c++0x" } + +class X +{ + public: + X(): data {1,2} {} // { dg-error "too many initializers" } + private: + const short data[1]; +}; + +int f(int n) +{ + const float * pData = new const float[1] { 1.5, 2.5 }; // { dg-error "too many initializers" } + pData = new const float[n] { 1.5, 2.5 }; // { dg-warning "array size" } + + return 0; +} diff --git a/gcc/testsuite/g++.dg/cpp0x/rv10.C b/gcc/testsuite/g++.dg/cpp0x/rv10.C new file mode 100644 index 00000000000..5e78b1dbb69 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/rv10.C @@ -0,0 +1,15 @@ +// { dg-options "-std=gnu++0x" } + +struct A +{ + A() = default; + A(const A&) = delete; +}; + +A&& f(); +void h(A&&); +void g() +{ + A&& arr = f(); + h(f()); +} diff --git a/gcc/testsuite/g++.dg/debug/dwarf2/typedef1.C b/gcc/testsuite/g++.dg/debug/dwarf2/typedef1.C new file mode 100644 index 00000000000..f325ac54ad2 --- /dev/null +++ b/gcc/testsuite/g++.dg/debug/dwarf2/typedef1.C @@ -0,0 +1,33 @@ +// Contributed by Dodji Seketeli <dodji@redhat.com> +// Origin: PR c++/40705 +// { dg-options "-g -dA" } +// { dg-do compile } +// { dg-final { scan-assembler-times "DW_TAG_structure_type" 2 } } +// { dg-final { scan-assembler-times "DW_AT_name: \"foo<1u>\"" 1 } } +// { dg-final { scan-assembler-times "DW_TAG_enumeration_type" 2 } } +// { dg-final { scan-assembler-times "DW_AT_name: \"typedef foo<1u>::type type\"" 1 } } +// { dg-final { scan-assembler-times "DIE (.*) DW_TAG_enumeration_type" 2 } } +// { dg-final { scan-assembler-times "\"e0..\".*DW_AT_name" 1 } } +// { dg-final { scan-assembler-times "\"e1..\".*DW_AT_name" 1 } } + +template <unsigned int n> +struct foo +{ +public: + typedef + unsigned char type; +}; + +template<> +struct foo<1> +{ + typedef enum { e0, e1 } type; +}; + +int +main() +{ + foo<1> f; + foo<1>::type t = foo<1>::e1; + return t; +} diff --git a/gcc/testsuite/g++.dg/ext/strncpy-chk1.C b/gcc/testsuite/g++.dg/ext/strncpy-chk1.C new file mode 100644 index 00000000000..7770ba93127 --- /dev/null +++ b/gcc/testsuite/g++.dg/ext/strncpy-chk1.C @@ -0,0 +1,31 @@ +// PR c++/40502 +// { dg-do compile } +// { dg-options "-O2" } + +struct A { char x[12], y[35]; }; +struct B { char z[50]; }; + +inline void +foo (char *dest, const char *__restrict src, __SIZE_TYPE__ n) +{ + __builtin___strncpy_chk (dest, src, n, __builtin_object_size (dest, 0)); // { dg-warning "will always overflow" } +} + +void bar (const char *, int); + +inline void +baz (int i) +{ + char s[128], t[32]; + bar (s, 0); + bar (t, i); + A a; + B b; + foo (a.y, b.z, 36); +} + +void +test () +{ + baz (0); +} diff --git a/gcc/testsuite/g++.dg/lookup/builtin5.C b/gcc/testsuite/g++.dg/lookup/builtin5.C new file mode 100644 index 00000000000..1bd67dce5ac --- /dev/null +++ b/gcc/testsuite/g++.dg/lookup/builtin5.C @@ -0,0 +1,16 @@ +// PR c++/37276 + +// { dg-final { scan-assembler "_ZSt5atanhd" } } + +namespace std +{ + inline double + atanh(double __x) + { return __builtin_atanh(__x); } +} + +int main() +{ + std::atanh(.3); + return 0; +} diff --git a/gcc/testsuite/g++.dg/lookup/using20.C b/gcc/testsuite/g++.dg/lookup/using20.C new file mode 100644 index 00000000000..dc1d293a2ee --- /dev/null +++ b/gcc/testsuite/g++.dg/lookup/using20.C @@ -0,0 +1,18 @@ +// PR c++/40476 + +namespace A +{ + int i; // { dg-error "i" } +} +using namespace A; +namespace B +{ + namespace B2 + { + int i; // { dg-error "i" } + } + using namespace B2; +} +using namespace B; + +int j = ::i; // { dg-error "ambiguous" } diff --git a/gcc/testsuite/g++.dg/opt/pr40496.C b/gcc/testsuite/g++.dg/opt/pr40496.C new file mode 100644 index 00000000000..b0eaebf702f --- /dev/null +++ b/gcc/testsuite/g++.dg/opt/pr40496.C @@ -0,0 +1,18 @@ +// { dg-do compile } +// { dg-options "-O2 -fprefetch-loop-arrays -msse2" { target i?86-*-* x86_64-*-* } } + +struct DOMStringHandle +{ + unsigned int fLength; + int fRefCount; +}; +static void *freeListPtr; +void foo(DOMStringHandle *dsg) +{ + int i; + for (i = 1; i < 1023; i++) + { + *(void **) &dsg[i] = freeListPtr; + freeListPtr = &dsg[i]; + } +} diff --git a/gcc/testsuite/g++.dg/other/error22.C b/gcc/testsuite/g++.dg/other/error22.C index 8b7a9e93714..225dcae8214 100644 --- a/gcc/testsuite/g++.dg/other/error22.C +++ b/gcc/testsuite/g++.dg/other/error22.C @@ -1,7 +1,7 @@ // PR c++/34394 // { dg-do compile } -extern double fabs (double); +extern "C" double fabs (double); void foo (double x) { diff --git a/gcc/testsuite/g++.dg/other/typedef3.C b/gcc/testsuite/g++.dg/other/typedef3.C new file mode 100644 index 00000000000..8ead5b84520 --- /dev/null +++ b/gcc/testsuite/g++.dg/other/typedef3.C @@ -0,0 +1,12 @@ +// Contributed by Dodji Seketeli <dodji@redhat.com> +// Origin: PR c++/40357 +// { dg-do compile } + +struct XalanCProcessor +{ + typedef enum {eInvalid, eXalanSourceTree, eXercesDOM} ParseOptionType; + ParseOptionType getParseOption(void); +}; +typedef XalanCProcessor::ParseOptionType ParseOptionType; +ParseOptionType XalanCProcessor::getParseOption(void) {} + diff --git a/gcc/testsuite/g++.dg/parse/crash10.C b/gcc/testsuite/g++.dg/parse/crash10.C index 8212fcb5b29..712e8767487 100644 --- a/gcc/testsuite/g++.dg/parse/crash10.C +++ b/gcc/testsuite/g++.dg/parse/crash10.C @@ -9,5 +9,5 @@ class { - typename:: // { dg-error "" "" } + typename:: ; // { dg-error "" "" } diff --git a/gcc/testsuite/g++.dg/parse/error15.C b/gcc/testsuite/g++.dg/parse/error15.C index c5d3d3d7d67..2352193bcd6 100644 --- a/gcc/testsuite/g++.dg/parse/error15.C +++ b/gcc/testsuite/g++.dg/parse/error15.C @@ -14,7 +14,7 @@ N::A f2; // { dg-error "1:invalid use of template-name 'N::A' witho N::INVALID f3; // { dg-error "1:'INVALID' in namespace 'N' does not name a type" } N::C::INVALID f4; // { dg-error "1:'INVALID' in class 'N::C' does not name a type" } N::K f6; // { dg-error "1:'K' in namespace 'N' does not name a type" } -typename N::A f7; // { dg-error "1:using 'typename' outside of template" "1" } +typename N::A f7; // { dg-error "13:invalid use of template-name 'N::A' without an argument list" "13" { target *-*-* } 17 } // { dg-error "17:invalid type in declaration before ';' token" "17" { target *-*-* } 17 } @@ -24,7 +24,7 @@ struct B N::INVALID f3; // { dg-error "3:'INVALID' in namespace 'N' does not name a type" } N::C::INVALID f4; // { dg-error "3:'INVALID' in class 'N::C' does not name a type" } N::K f6; // { dg-error "3:'K' in namespace 'N' does not name a type" } - typename N::A f7; // { dg-error "3:using 'typename' outside of template" } + typename N::A f7; // { dg-error "15:invalid use of template-name 'N::A' without an argument list" "15" { target *-*-* } 27 } }; diff --git a/gcc/testsuite/g++.dg/parse/error8.C b/gcc/testsuite/g++.dg/parse/error8.C index ba572b0db7d..6d3bf5a856a 100644 --- a/gcc/testsuite/g++.dg/parse/error8.C +++ b/gcc/testsuite/g++.dg/parse/error8.C @@ -4,7 +4,6 @@ struct A { friend typename struct B; }; -// { dg-error "19:using 'typename' outside of template" "" { target *-*-* } 4 } // { dg-error "28:expected nested-name-specifier before 'struct'" "" { target *-*-* } 4 } // { dg-error "35:multiple types in one declaration" "" { target *-*-* } 4 } // { dg-error "12:friend declaration does not name a class or function" "" { target *-*-* } 4 } diff --git a/gcc/testsuite/g++.dg/parse/typename9.C b/gcc/testsuite/g++.dg/parse/typename9.C index aa72cd6c584..8d77072197b 100644 --- a/gcc/testsuite/g++.dg/parse/typename9.C +++ b/gcc/testsuite/g++.dg/parse/typename9.C @@ -1,3 +1,6 @@ +// check that using a qualified name with a typename does +// not report an error. + struct A { typedef int X; }; -int i = typename A::X(); // { dg-error "typename" } +int i = typename A::X(); diff --git a/gcc/testsuite/g++.dg/plugin/header-plugin-test.C b/gcc/testsuite/g++.dg/plugin/header-plugin-test.C new file mode 100644 index 00000000000..bd6aff11f3c --- /dev/null +++ b/gcc/testsuite/g++.dg/plugin/header-plugin-test.C @@ -0,0 +1,3 @@ +// Test case for the dumb plugin. +// { dg-do compile } + diff --git a/gcc/testsuite/g++.dg/plugin/header_plugin.c b/gcc/testsuite/g++.dg/plugin/header_plugin.c new file mode 100644 index 00000000000..a9340307e8c --- /dev/null +++ b/gcc/testsuite/g++.dg/plugin/header_plugin.c @@ -0,0 +1,32 @@ +#include "gcc-plugin.h" +#include <stdlib.h> +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "tree-pass.h" +#include "intl.h" + +/* reqs */ +#include "tm.h" + +/* gcc/ headers. */ +#include "diagnostic.h" +#include "c-common.h" +#include "c-pretty-print.h" +#include "tree-iterator.h" +#include "plugin.h" +#include "tree-flow.h" +#include "langhooks.h" +#include "cp/cp-tree.h" +#include "cp/cxx-pretty-print.h" +#include "cp/name-lookup.h" + +int plugin_is_GPL_compatible; + +int +plugin_init (struct plugin_name_args *plugin_info, + struct plugin_gcc_version *version) +{ + return 0; +} diff --git a/gcc/testsuite/g++.dg/plugin/plugin.exp b/gcc/testsuite/g++.dg/plugin/plugin.exp index eb019986ffe..4ba73e53dac 100644 --- a/gcc/testsuite/g++.dg/plugin/plugin.exp +++ b/gcc/testsuite/g++.dg/plugin/plugin.exp @@ -49,7 +49,8 @@ load_lib plugin-support.exp set plugin_test_list [list \ { attribute_plugin.c attribute_plugin-test-1.C } \ { selfassign.c self-assign-test-1.C self-assign-test-2.C self-assign-test-3.C } \ - { dumb_plugin.c dumb-plugin-test-1.C } ] + { dumb_plugin.c dumb-plugin-test-1.C } \ + { header_plugin.c header-plugin-test.C } ] foreach plugin_test $plugin_test_list { # Replace each source file with its full-path name diff --git a/gcc/testsuite/g++.dg/template/koenig8.C b/gcc/testsuite/g++.dg/template/koenig8.C new file mode 100644 index 00000000000..5a49a7066da --- /dev/null +++ b/gcc/testsuite/g++.dg/template/koenig8.C @@ -0,0 +1,20 @@ +// PR c++/40740 + +template<class T> +T addsome(T v) { + return v+1; +} + +int addsome(int v) { + return v+2; +} + +int main() { + int i = 0; + if (addsome(i) != 2) + return 1; + if (addsome<>(i) != 1) + return 2; + return 0; +} + diff --git a/gcc/testsuite/g++.dg/torture/pr40388.C b/gcc/testsuite/g++.dg/torture/pr40388.C new file mode 100644 index 00000000000..63fbbfba5a2 --- /dev/null +++ b/gcc/testsuite/g++.dg/torture/pr40388.C @@ -0,0 +1,21 @@ +void foo(); + +struct A +{ + ~A() + { + try + { + foo(); + foo(); + } + catch (...) + { + } + } +}; + +void bar() +{ + A a1, a2; +} diff --git a/gcc/testsuite/g++.dg/warn/Warray-bounds.C b/gcc/testsuite/g++.dg/warn/Warray-bounds.C index d53af521486..61c7c5d8e32 100644 --- a/gcc/testsuite/g++.dg/warn/Warray-bounds.C +++ b/gcc/testsuite/g++.dg/warn/Warray-bounds.C @@ -3,8 +3,9 @@ int a[10]; +extern "C" __SIZE_TYPE__ strlen(const char *s); + static inline int n(void) { - __SIZE_TYPE__ strlen(const char *s); return strlen("12345"); } diff --git a/gcc/testsuite/g++.dg/warn/unused-result1-Werror.c b/gcc/testsuite/g++.dg/warn/unused-result1-Werror.c new file mode 100644 index 00000000000..033d707778c --- /dev/null +++ b/gcc/testsuite/g++.dg/warn/unused-result1-Werror.c @@ -0,0 +1,10 @@ +// PR 40614 +// { dg-options "-Werror=unused-result" } +class QByteArray { +public: + QByteArray(const QByteArray &); +}; +class QString { + QByteArray toLocal8Bit() const __attribute__ ((warn_unused_result)); + void fooWarnHere() const { toLocal8Bit(); } // { dg-error "ignoring" } +}; diff --git a/gcc/testsuite/g++.old-deja/g++.pt/typename10.C b/gcc/testsuite/g++.old-deja/g++.pt/typename10.C index f778c42f098..cdd9850ac0d 100644 --- a/gcc/testsuite/g++.old-deja/g++.pt/typename10.C +++ b/gcc/testsuite/g++.old-deja/g++.pt/typename10.C @@ -4,4 +4,4 @@ struct S { typedef int I; }; -void f(typename S::I); // { dg-error "" } using typename outside of template +void f(typename S::I); diff --git a/gcc/testsuite/gcc.c-torture/compile/20000804-1.c b/gcc/testsuite/gcc.c-torture/compile/20000804-1.c index 68db6d36aed..d1b351584d4 100644 --- a/gcc/testsuite/gcc.c-torture/compile/20000804-1.c +++ b/gcc/testsuite/gcc.c-torture/compile/20000804-1.c @@ -2,7 +2,7 @@ statement to force a 'long long' (64-bits) to go in a register. */ /* { dg-do assemble } */ /* { dg-skip-if "" { { i?86-*-* x86_64-*-* } && ilp32 } { "-fpic" "-fPIC" } { "" } } */ -/* { dg-skip-if "PIC default" { i?86-*-darwin* } { "*" } { "" } } */ +/* { dg-skip-if "PIC default" { { i?86-*-darwin* x86_64-*-darwin* } && ilp32 } { "*" } { "" } } */ /* { dg-skip-if "No 64-bit registers" { m32c-*-* } { "*" } { "" } } */ /* { dg-xfail-if "" { m6811-*-* m6812-*-* h8300-*-* } { "*" } { "" } } */ diff --git a/gcc/testsuite/gcc.c-torture/execute/20090711-1.c b/gcc/testsuite/gcc.c-torture/execute/20090711-1.c new file mode 100644 index 00000000000..5c3d93a37ed --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/20090711-1.c @@ -0,0 +1,21 @@ +/* Used to be miscompiled at -O0 due to incorrect choice of sign extension + vs. zero extension. __attribute__ ((noinline)) added to try to make it + fail at higher optimization levels too. */ + +extern void abort (void); + +long long __attribute__ ((noinline)) +div (long long val) +{ + return val / 32768; +} + +int main (void) +{ + long long d1 = -990000000; + long long d2 = div(d1); + if (d2 != -30212) + abort (); + return 0; +} + diff --git a/gcc/testsuite/gcc.c-torture/execute/pr40668.c b/gcc/testsuite/gcc.c-torture/execute/pr40668.c new file mode 100644 index 00000000000..70fe63f8916 --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/pr40668.c @@ -0,0 +1,35 @@ +static void +foo (unsigned int x, void *p) +{ + __builtin_memcpy (p, &x, sizeof x); +} + +void +bar (int type, void *number) +{ + switch (type) + { + case 1: + foo (0x12345678, number); + break; + case 7: + foo (0, number); + break; + case 8: + foo (0, number); + break; + case 9: + foo (0, number); + break; + } +} + +int +main (void) +{ + unsigned int x; + bar (1, &x); + if (x != 0x12345678) + __builtin_abort (); + return 0; +} diff --git a/gcc/testsuite/gcc.dg/compat/compat-common.h b/gcc/testsuite/gcc.dg/compat/compat-common.h index 40d4e08f9f1..8a92ea3e606 100644 --- a/gcc/testsuite/gcc.dg/compat/compat-common.h +++ b/gcc/testsuite/gcc.dg/compat/compat-common.h @@ -47,5 +47,9 @@ #endif #endif +#ifdef __cplusplus +extern "C" void abort (void); +#else extern void abort (void); +#endif extern int fails; diff --git a/gcc/testsuite/gcc.dg/vect/no-scevccp-outer-2.c b/gcc/testsuite/gcc.dg/vect/no-scevccp-outer-2.c index a9ac09c4a2b..13b37883c2e 100644 --- a/gcc/testsuite/gcc.dg/vect/no-scevccp-outer-2.c +++ b/gcc/testsuite/gcc.dg/vect/no-scevccp-outer-2.c @@ -1,4 +1,6 @@ /* { dg-do compile } */ +/* { dg-require-effective-target vect_int } */ + #define N 40 int @@ -14,5 +16,5 @@ foo (){ return diff; } -/* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" { xfail *-*-* } } } */ +/* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" } } */ /* { dg-final { cleanup-tree-dump "vect" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/vect-double-reduc-1.c b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-1.c new file mode 100644 index 00000000000..e3358428a48 --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-1.c @@ -0,0 +1,56 @@ +/* { dg-require-effective-target vect_int_mult } */ + +#include <stdarg.h> +#include <stdio.h> +#include "tree-vect.h" + +#define K 32 + +int in[2*K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +int coeff[K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +int out[K]; +int check_result[K] = {642816,660736,678656,696576,714496,732416,750336,768256,786176,804096,822016,839936,857856,875776,893696,911616,929536,947456,965376,983296,1001216,1019136,1037056,1054976,1072896,1090816,1108736,1126656,1144576,1162496,1180416,1198336}; + +__attribute__ ((noinline)) void +foo () +{ + int sum = 0, i, j, k; + + for (k = 0; k < K; k++) + { + sum = 0; + for (j = 0; j < K; j++) + for (i = 0; i < K; i++) + sum += in[i+k][j] * coeff[i][j]; + + out[k] = sum; + } +} + +int main () +{ + int i, j, k; + + check_vect (); + + for (j = 0; j < K; j++) + { + for (i = 0; i < 2*K; i++) + in[i][j] = i+j; + + for (i = 0; i < K; i++) + coeff[i][j] = i+2; + } + + foo(); + + for (k = 0; k < K; k++) + if (out[k] != check_result[k]) + abort (); + + return 0; +} + +/* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" } } */ +/* { dg-final { cleanup-tree-dump "vect" } } */ + diff --git a/gcc/testsuite/gcc.dg/vect/vect-double-reduc-2.c b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-2.c new file mode 100644 index 00000000000..be469be02de --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-2.c @@ -0,0 +1,56 @@ +/* { dg-require-effective-target vect_int_mult } */ + +#include <stdarg.h> +#include <stdio.h> +#include "tree-vect.h" + +#define K 32 + +int in[2*K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +int coeff[K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +int out[K]; +int check_result[K] = {357184,339264,321344,303424,285504,267584,249664,231744,213824,195904,177984,160064,142144,124224,106304,88384,70464,52544,34624,16704,-1216,-19136,-37056,-54976,-72896,-90816,-108736,-126656,-144576,-162496,-180416,-198336}; + +__attribute__ ((noinline)) void +foo () +{ + int res = 0, i, j, k; + + for (k = 0; k < K; k++) + { + res = 1000000; + for (j = 0; j < K; j++) + for (i = 0; i < K; i++) + res -= in[i+k][j] * coeff[i][j]; + + out[k] = res; + } +} + +int main () +{ + int i, j, k; + + check_vect (); + + for (j = 0; j < K; j++) + { + for (i = 0; i < 2*K; i++) + in[i][j] = i+j; + + for (i = 0; i < K; i++) + coeff[i][j] = i+2; + } + + foo(); + + for (k = 0; k < K; k++) + if (out[k] != check_result[k]) + abort (); + + return 0; +} + +/* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" } } */ +/* { dg-final { cleanup-tree-dump "vect" } } */ + diff --git a/gcc/testsuite/gcc.dg/vect/vect-double-reduc-3.c b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-3.c new file mode 100644 index 00000000000..87b5a04099e --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-3.c @@ -0,0 +1,67 @@ +/* { dg-require-effective-target vect_int } */ + +#include <stdarg.h> +#include <stdio.h> +#include "tree-vect.h" + +#define K 32 + +int in[2*K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +int coeff[K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +int out_max[K], out_min[K]; +int check_max[K] = {62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93}; +int check_min[K] = {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31}; + +__attribute__ ((noinline)) void +foo (int x, int y) +{ + int max, min, i, j, k; + + for (k = 0; k < K; k++) + { + max = x; + min = y; + for (j = 0; j < K; j++) + for (i = 0; i < K; i++) + { + max = max < in[i+k][j] ? in[i+k][j] : max; + min = min > in[i+k][j] ? in[i+k][j] : min; + } + out_max[k] = max; + out_min[k] = min; + } +} + +int main () +{ + int i, j, k; + + check_vect (); + + for (j = 0; j < K; j++) + { + for (i = 0; i < 2*K; i++) + in[i][j] = i+j; + + for (i = 0; i < K; i++) + coeff[i][j] = i+2; + } + + foo(0, 0); + + for (k = 0; k < K; k++) + if (out_max[k] != check_max[k] || out_min[k] != 0) + abort (); + + foo(100, 45); + + for (k = 0; k < K; k++) + if (out_min[k] != check_min[k] || out_max[k] != 100) + abort (); + + return 0; +} + +/* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" { xfail vect_no_int_max } } } */ +/* { dg-final { cleanup-tree-dump "vect" } } */ + diff --git a/gcc/testsuite/gcc.dg/vect/vect-double-reduc-4.c b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-4.c new file mode 100644 index 00000000000..90e0da70a20 --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-4.c @@ -0,0 +1,56 @@ +/* { dg-require-effective-target vect_int_mult } */ + +#include <stdarg.h> +#include <stdio.h> +#include "tree-vect.h" + +#define K 32 + +int in[2*K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +int coeff[K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +int out[K]; +int check_result[K] = {652816,670736,688656,706576,724496,742416,760336,778256,796176,814096,832016,849936,867856,885776,903696,921616,939536,957456,975376,993296,1011216,1029136,1047056,1064976,1082896,1100816,1118736,1136656,1154576,1172496,1190416,1208336}; + +__attribute__ ((noinline)) void +foo () +{ + int sum = 0, i, j, k; + + for (k = 0; k < K; k++) + { + sum = 10000; + for (j = 0; j < K; j++) + for (i = 0; i < K; i++) + sum += in[i+k][j] * coeff[i][j]; + + out[k] = sum; + } +} + +int main () +{ + int i, j, k; + + check_vect (); + + for (j = 0; j < K; j++) + { + for (i = 0; i < 2*K; i++) + in[i][j] = i+j; + + for (i = 0; i < K; i++) + coeff[i][j] = i+2; + } + + foo(); + + for (k = 0; k < K; k++) + if (out[k] != check_result[k]) + abort (); + + return 0; +} + +/* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" } } */ +/* { dg-final { cleanup-tree-dump "vect" } } */ + diff --git a/gcc/testsuite/gcc.dg/vect/vect-double-reduc-5.c b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-5.c new file mode 100644 index 00000000000..f624d86502f --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-5.c @@ -0,0 +1,58 @@ +/* { dg-require-effective-target vect_int_mult } */ + +#include <stdarg.h> +#include <stdio.h> +#include "tree-vect.h" + +#define K 32 + +signed short in[2*K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +signed short coeff[K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +int out[K]; +int check_result[K] = {642816,660736,678656,696576,714496,732416,750336,768256,786176,804096,822016,839936,857856,875776,893696,911616,929536,947456,965376,983296,1001216,1019136,1037056,1054976,1072896,1090816,1108736,1126656,1144576,1162496,1180416,1198336}; + +__attribute__ ((noinline)) void +foo () +{ + int sum = 0, i, j, k; + + for (k = 0; k < K; k++) + { + sum = 0; + for (j = 0; j < K; j++) + for (i = 0; i < K; i++) + sum += in[i+k][j] * coeff[i][j]; + + out[k] = sum; + } +} + +int main () +{ + int i, j, k; + + check_vect (); + + for (j = 0; j < K; j++) + { + for (i = 0; i < 2*K; i++) + in[i][j] = i+j; + + for (i = 0; i < K; i++) + coeff[i][j] = i+2; + } + + foo(); + + for (k = 0; k < K; k++) + if (out[k] != check_result[k]) + abort (); + + return 0; +} + +/* Vectorization of loops with multiple types and double reduction is not + supported yet. */ +/* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" { xfail *-*-* } } } */ +/* { dg-final { cleanup-tree-dump "vect" } } */ + diff --git a/gcc/testsuite/gcc.dg/vect/vect-double-reduc-6.c b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-6.c new file mode 100644 index 00000000000..f52b32bfad9 --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-6.c @@ -0,0 +1,50 @@ +/* { dg-require-effective-target vect_int_mult } */ + +#include <stdarg.h> +#include <stdio.h> +#include "tree-vect.h" + +#define K 4 + +int in[2*K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +int out[K]; +int check_result[K] = {0,16,256,4096}; + +__attribute__ ((noinline)) void +foo () +{ + int sum; + int i, j, k; + + for (k = 0; k < K; k++) + { + sum = 1; + for (j = 0; j < K; j++) + for (i = 0; i < K; i++) + sum *= in[i+k][j]; + out[k] = sum; + } +} + +int main () +{ + int i, j, k; + + check_vect (); + + for (i = 0; i < 2*K; i++) + for (j = 0; j < K; j++) + in[i][j] = (i+2)/3; + + foo(); + + for (k = 0; k < K; k++) + if (out[k] != check_result[k]) + abort (); + + return 0; +} + +/* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 1 "vect" } } */ +/* { dg-final { cleanup-tree-dump "vect" } } */ + diff --git a/gcc/testsuite/gcc.dg/vect/vect-double-reduc-7.c b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-7.c new file mode 100644 index 00000000000..9e7ced7f927 --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/vect-double-reduc-7.c @@ -0,0 +1,65 @@ +/* { dg-require-effective-target vect_int } */ + +#include <stdarg.h> +#include <stdio.h> +#include "tree-vect.h" + +#define K 32 + +int in[2*K][K] __attribute__ ((__aligned__(__BIGGEST_ALIGNMENT__))); +int out[K]; +int check_result[K] = {63,63,191,191,127,127,191,191,127,127,191,191,127,127,191,191,127,127,191,191,127,127,191,191,127,127,191,191,127,127,191,191}; + +__attribute__ ((noinline)) void +foo () +{ + int res_or, res_and, res_xor, i, j, k; + + for (k = 0; k < K; k++) + { + res_or = 0; + for (j = 0; j < K; j++) + for (i = 0; i < K; i++) + res_or = res_or | in[i+k][j]; + + res_and = 1; + for (j = 0; j < K; j++) + for (i = 0; i < K; i++) + res_and = res_and & in[i+k][j]; + + res_xor = 0; + for (j = 0; j < K; j++) + for (i = 0; i < K; i++) + res_xor = res_xor ^ in[i+k][j]; + + out[k] = res_or + res_and + res_xor; + } +} + +int main () +{ + int i, j, k; + + check_vect (); + + for (j = 0; j < K; j++) + { + for (i = 0; i < 2*K; i++) + in[i][j] = i+j; + + for (i = 0; i < K; i++) + out[i] = i+j; + } + + foo(); + + for (k = 0; k < K; k++) + if (out[k] != check_result[k]) + abort (); + + return 0; +} + +/* { dg-final { scan-tree-dump-times "OUTER LOOP VECTORIZED" 3 "vect" } } */ +/* { dg-final { cleanup-tree-dump "vect" } } */ + diff --git a/gcc/testsuite/gcc.target/i386/pr37843-1.c b/gcc/testsuite/gcc.target/i386/pr37843-1.c index e37ea9df289..981988223e0 100644 --- a/gcc/testsuite/gcc.target/i386/pr37843-1.c +++ b/gcc/testsuite/gcc.target/i386/pr37843-1.c @@ -2,8 +2,8 @@ /* { dg-do compile { target nonpic } } */ /* { dg-options "-O2 -mpreferred-stack-boundary=6 -mincoming-stack-boundary=5" } */ /* { dg-final { scan-assembler "and\[lq\]?\[\\t \]*\\$-64,\[\\t \]*%\[re\]?sp" } } */ -/* { dg-final { scan-assembler "call\[\\t \]*foo" } } */ -/* { dg-final { scan-assembler-not "jmp\[\\t \]*foo" } } */ +/* { dg-final { scan-assembler "call\[\\t \]*_?foo" } } */ +/* { dg-final { scan-assembler-not "jmp\[\\t \]*_?foo" } } */ extern int foo (void); diff --git a/gcc/testsuite/gcc.target/i386/pr37843-2.c b/gcc/testsuite/gcc.target/i386/pr37843-2.c index e36cb0d95e7..fa177714ab0 100644 --- a/gcc/testsuite/gcc.target/i386/pr37843-2.c +++ b/gcc/testsuite/gcc.target/i386/pr37843-2.c @@ -2,8 +2,8 @@ /* { dg-do compile { target nonpic } } */ /* { dg-options "-O2 -mpreferred-stack-boundary=6 -mincoming-stack-boundary=6" } */ /* { dg-final { scan-assembler-not "and\[lq\]?\[\\t \]*\\$-64,\[\\t \]*%\[re\]?sp" } } */ -/* { dg-final { scan-assembler-not "call\[\\t \]*foo" } } */ -/* { dg-final { scan-assembler "jmp\[\\t \]*foo" } } */ +/* { dg-final { scan-assembler-not "call\[\\t \]*_?foo" } } */ +/* { dg-final { scan-assembler "jmp\[\\t \]*_?foo" } } */ extern int foo (void); diff --git a/gcc/testsuite/gcc.target/i386/pr37843-3.c b/gcc/testsuite/gcc.target/i386/pr37843-3.c index a475e4143ff..15d05c1b4c3 100644 --- a/gcc/testsuite/gcc.target/i386/pr37843-3.c +++ b/gcc/testsuite/gcc.target/i386/pr37843-3.c @@ -2,8 +2,8 @@ /* { dg-do compile { target { ilp32 && nonpic } } } */ /* { dg-options "-O2 -msse2 -mpreferred-stack-boundary=4 -mstackrealign" } */ /* { dg-final { scan-assembler-not "andl\[\\t \]*\\$-16,\[\\t \]*%\[re\]?sp" } } */ -/* { dg-final { scan-assembler-not "call\[\\t \]*foo" } } */ -/* { dg-final { scan-assembler "jmp\[\\t \]*foo" } } */ +/* { dg-final { scan-assembler-not "call\[\\t \]*_?foo" } } */ +/* { dg-final { scan-assembler "jmp\[\\t \]*_?foo" } } */ #include <emmintrin.h> diff --git a/gcc/testsuite/gcc.target/i386/sse-copysignf-vec.c b/gcc/testsuite/gcc.target/i386/sse-copysignf-vec.c new file mode 100644 index 00000000000..9342e2c7187 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/sse-copysignf-vec.c @@ -0,0 +1,27 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -ftree-vectorize -msse" } */ + +#include "sse-check.h" + +extern float copysignf (float, float); + +#define N 16 + +float a[N] = {-0.1f,-3.2f,-6.3f,-9.4f,-12.5f,-15.6f,-18.7f,-21.8f,24.9f,27.1f,30.2f,33.3f,36.4f,39.5f,42.6f,45.7f}; +float b[N] = {-1.2f,3.4f,-5.6f,7.8f,-9.0f,1.0f,-2.0f,3.0f,-4.0f,-5.0f,6.0f,7.0f,-8.0f,-9.0f,10.0f,11.0f}; +float r[N]; + +static void +sse_test (void) +{ + int i; + + for (i = 0; i < N; i++) + r[i] = copysignf (a[i], b[i]); + + /* check results: */ + for (i = 0; i < N; i++) + if (r[i] != copysignf (a[i], b[i])) + abort (); +} + diff --git a/gcc/testsuite/gcc.target/i386/sse-recip-vec.c b/gcc/testsuite/gcc.target/i386/sse-recip-vec.c index 24ee1ac821e..2f90ec8aeca 100644 --- a/gcc/testsuite/gcc.target/i386/sse-recip-vec.c +++ b/gcc/testsuite/gcc.target/i386/sse-recip-vec.c @@ -7,15 +7,15 @@ extern float sqrtf (float); #define N 8 +float a[N] = { 0.f, 18.f, 108.f, 324.f, 720.f, 1944.f, 3087.f, 5832.f }; +float b[N] = { 1.f, 2.f, 3.f, 4.f, 5.f, 6.f, 7.f, 8.f }; +float r[N]; + +float rc[N] = { 0.f, 3.f, 6.f, 9.f, 12.f, 18.f, 21.f, 27.f }; + static void sse_test (void) { - float a[N] = { 0.f, 18.f, 108.f, 324.f, 720.f, 1944.f, 3087.f, 5832.f }; - float b[N] = { 1.f, 2.f, 3.f, 4.f, 5.f, 6.f, 7.f, 8.f }; - float r[N]; - - float rc[N] = { 0.f, 3.f, 6.f, 9.f, 12.f, 18.f, 21.f, 27.f }; - int i; for (i = 0; i < N; i++) diff --git a/gcc/testsuite/gcc.target/i386/sse2-copysign-vec.c b/gcc/testsuite/gcc.target/i386/sse2-copysign-vec.c new file mode 100644 index 00000000000..710aa640fd0 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/sse2-copysign-vec.c @@ -0,0 +1,27 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -ftree-vectorize -msse2" } */ + +#include "sse2-check.h" + +extern double copysign (double, double); + +#define N 16 + +double a[N] = {-0.1,-3.2,-6.3,-9.4,-12.5,-15.6,-18.7,-21.8,24.9,27.1,30.2,33.3,36.4,39.5,42.6,45.7}; +double b[N] = {-1.2,3.4,-5.6,7.8,-9.0,1.0,-2.0,3.0,-4.0,-5.0,6.0,7.0,-8.0,-9.0,10.0,11.0}; +double r[N]; + +static void +sse2_test (void) +{ + int i; + + for (i = 0; i < N; i++) + r[i] = copysign (a[i], b[i]); + + /* check results: */ + for (i = 0; i < N; i++) + if (r[i] != copysign (a[i], b[i])) + abort (); +} + diff --git a/gcc/testsuite/gcc.target/i386/sse2-lrint-vec.c b/gcc/testsuite/gcc.target/i386/sse2-lrint-vec.c index a6db5c4b56b..5276c7edd39 100644 --- a/gcc/testsuite/gcc.target/i386/sse2-lrint-vec.c +++ b/gcc/testsuite/gcc.target/i386/sse2-lrint-vec.c @@ -7,12 +7,12 @@ extern long lrint (double); #define N 32 +double a[N] = {0.4,3.5,6.6,9.4,12.5,15.6,18.4,21.5,24.6,27.4,30.5,33.6,36.4,39.5,42.6,45.4,0.5,3.6,6.4,9.5,12.6,15.4,18.5,21.6,24.4,27.5,30.6,33.4,36.5,39.6,42.4,45.5}; +long r[N]; + static void sse2_test (void) { - double a[N] = {0.4,3.5,6.6,9.4,12.5,15.6,18.4,21.5,24.6,27.4,30.5,33.6,36.4,39.5,42.6,45.4,0.5,3.6,6.4,9.5,12.6,15.4,18.5,21.6,24.4,27.5,30.6,33.4,36.5,39.6,42.4,45.5}; - long r[N]; - int i; for (i = 0; i < N; i++) diff --git a/gcc/testsuite/gcc.target/i386/sse2-lrintf-vec.c b/gcc/testsuite/gcc.target/i386/sse2-lrintf-vec.c index eb74f831d01..43037a57726 100644 --- a/gcc/testsuite/gcc.target/i386/sse2-lrintf-vec.c +++ b/gcc/testsuite/gcc.target/i386/sse2-lrintf-vec.c @@ -7,12 +7,12 @@ extern long lrintf (float); #define N 32 +float a[N] = {0.4,3.5,6.6,9.4,12.5,15.6,18.4,21.5,24.6,27.4,30.5,33.6,36.4,39.5,42.6,45.4,0.5,3.6,6.4,9.5,12.6,15.4,18.5,21.6,24.4,27.5,30.6,33.4,36.5,39.6,42.4,45.5}; +long r[N]; + static void sse2_test (void) { - float a[N] = {0.4,3.5,6.6,9.4,12.5,15.6,18.4,21.5,24.6,27.4,30.5,33.6,36.4,39.5,42.6,45.4,0.5,3.6,6.4,9.5,12.6,15.4,18.5,21.6,24.4,27.5,30.6,33.4,36.5,39.6,42.4,45.5}; - long r[N]; - int i; for (i = 0; i < N; i++) diff --git a/gcc/testsuite/gcc.dg/20090709-1.c b/gcc/testsuite/gcc.target/m68k/20090709-1.c index fda05b7566d..fda05b7566d 100644 --- a/gcc/testsuite/gcc.dg/20090709-1.c +++ b/gcc/testsuite/gcc.target/m68k/20090709-1.c diff --git a/gcc/testsuite/gcc.target/mips/clear-cache-1.c b/gcc/testsuite/gcc.target/mips/clear-cache-1.c index 60bbf9dfc40..0ccc007fbc7 100644 --- a/gcc/testsuite/gcc.target/mips/clear-cache-1.c +++ b/gcc/testsuite/gcc.target/mips/clear-cache-1.c @@ -1,5 +1,5 @@ /* { dg-do compile } */ -/* { dg-options "-O2 isa_rev>=2" } */ +/* { dg-options "-O2 -msynci isa_rev>=2" } */ /* { dg-final { scan-assembler "synci" } } */ /* { dg-final { scan-assembler "jr.hb" } } */ /* { dg-final { scan-assembler-not "_flush_cache" } } */ diff --git a/gcc/testsuite/gcc.target/mips/mips.exp b/gcc/testsuite/gcc.target/mips/mips.exp index a0b8fc39623..5ec21422242 100644 --- a/gcc/testsuite/gcc.target/mips/mips.exp +++ b/gcc/testsuite/gcc.target/mips/mips.exp @@ -234,6 +234,7 @@ foreach option { shared smartmips sym32 + synci } { lappend mips_option_groups $option "-m(no-|)$option" } diff --git a/gcc/testsuite/gfortran.dg/abstract_type_1.f90 b/gcc/testsuite/gfortran.dg/abstract_type_1.f90 index b6baa3abab8..7a91e11a89c 100644 --- a/gcc/testsuite/gfortran.dg/abstract_type_1.f90 +++ b/gcc/testsuite/gfortran.dg/abstract_type_1.f90 @@ -11,3 +11,4 @@ MODULE m END TYPE t ! { dg-error "END MODULE" } END MODULE m +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/abstract_type_2.f03 b/gcc/testsuite/gfortran.dg/abstract_type_2.f03 index 6dcfe1492ff..9b4ddebe40a 100644 --- a/gcc/testsuite/gfortran.dg/abstract_type_2.f03 +++ b/gcc/testsuite/gfortran.dg/abstract_type_2.f03 @@ -11,3 +11,4 @@ MODULE m END TYPE error_t ! { dg-error "END MODULE" } END MODULE m +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/abstract_type_3.f03 b/gcc/testsuite/gfortran.dg/abstract_type_3.f03 index abeeec9dc6a..a6f06235d24 100644 --- a/gcc/testsuite/gfortran.dg/abstract_type_3.f03 +++ b/gcc/testsuite/gfortran.dg/abstract_type_3.f03 @@ -49,3 +49,4 @@ CONTAINS END SUBROUTINE impl END MODULE m +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/abstract_type_4.f03 b/gcc/testsuite/gfortran.dg/abstract_type_4.f03 index 89fd3b03272..bc34d4e541f 100644 --- a/gcc/testsuite/gfortran.dg/abstract_type_4.f03 +++ b/gcc/testsuite/gfortran.dg/abstract_type_4.f03 @@ -26,3 +26,4 @@ PROGRAM main ! See if constructing the extending type works. conc = concrete_t (1, 2) END PROGRAM main +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/abstract_type_5.f03 b/gcc/testsuite/gfortran.dg/abstract_type_5.f03 index a0060f81795..7da38e8fed7 100644 --- a/gcc/testsuite/gfortran.dg/abstract_type_5.f03 +++ b/gcc/testsuite/gfortran.dg/abstract_type_5.f03 @@ -43,3 +43,4 @@ CONTAINS END SUBROUTINE test END MODULE m +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_2.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_2.f90 index c4c4ae21e01..c8945cfc375 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_2.f90 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_2.f90 @@ -38,3 +38,4 @@ end module grid_io call read_grid_header end ! { dg-final { cleanup-tree-dump "grid_io" } } +! { dg-final { cleanup-modules "grid_io" } } diff --git a/gcc/testsuite/gfortran.dg/backslash_3.f b/gcc/testsuite/gfortran.dg/backslash_3.f index 905d2b4c302..8625b3724e4 100644 --- a/gcc/testsuite/gfortran.dg/backslash_3.f +++ b/gcc/testsuite/gfortran.dg/backslash_3.f @@ -1,4 +1,4 @@ -C { dg-do run } +C { dg-do run { target fd_truncate } } C { dg-options "-fbackslash" } C PR fortran/30278 program a diff --git a/gcc/testsuite/gfortran.dg/bounds_check_9.f90 b/gcc/testsuite/gfortran.dg/bounds_check_9.f90 index c0abd2896ec..3b487efa146 100644 --- a/gcc/testsuite/gfortran.dg/bounds_check_9.f90 +++ b/gcc/testsuite/gfortran.dg/bounds_check_9.f90 @@ -34,3 +34,4 @@ program main call sub() call sub((/4,5/)) end program main +! { dg-final { cleanup-modules "sub_mod" } } diff --git a/gcc/testsuite/gfortran.dg/bounds_check_fail_2.f90 b/gcc/testsuite/gfortran.dg/bounds_check_fail_2.f90 index bb2c247bf31..d79272b3876 100644 --- a/gcc/testsuite/gfortran.dg/bounds_check_fail_2.f90 +++ b/gcc/testsuite/gfortran.dg/bounds_check_fail_2.f90 @@ -37,3 +37,4 @@ program main call sub((/4/)) end program main ! { dg-output "Fortran runtime error: Array bound mismatch" } +! { dg-final { cleanup-modules "sub_mod" } } diff --git a/gcc/testsuite/gfortran.dg/c_kind_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_kind_tests_2.f03 index aaaee978adc..a8cdbdff50c 100644 --- a/gcc/testsuite/gfortran.dg/c_kind_tests_2.f03 +++ b/gcc/testsuite/gfortran.dg/c_kind_tests_2.f03 @@ -12,3 +12,4 @@ module c_kind_tests_2 real(myI), bind(c) :: myCFloat2 ! { dg-warning "is for type INTEGER" } real(4), bind(c) :: myFloat ! { dg-warning "may not be a C interoperable" } end module c_kind_tests_2 +! { dg-final { cleanup-modules "c_kind_tests_2" } } diff --git a/gcc/testsuite/gfortran.dg/complex_intrinsic_3.f90 b/gcc/testsuite/gfortran.dg/complex_intrinsic_3.f90 new file mode 100644 index 00000000000..f0d12d6ef14 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/complex_intrinsic_3.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR fortran/33197 +! +! Fortran 2008 complex trigonometric functions: tan, cosh, sinh, tanh +! +implicit none +real(4), parameter :: pi = 2*acos(0.0_4) +real(8), parameter :: pi8 = 2*acos(0.0_8) +real(4), parameter :: eps = 10*epsilon(0.0_4) +real(8), parameter :: eps8 = 10*epsilon(0.0_8) +complex(4), volatile :: z0_0 = cmplx(0.0_4, 0.0_4, kind=4) +complex(4), volatile :: z1_1 = cmplx(1.0_4, 1.0_4, kind=4) +complex(4), volatile :: zp_p = cmplx(pi, pi, kind=4) +complex(8), volatile :: z80_0 = cmplx(0.0_8, 0.0_8, kind=8) +complex(8), volatile :: z81_1 = cmplx(1.0_8, 1.0_8, kind=8) +complex(8), volatile :: z8p_p = cmplx(pi8, pi8, kind=8) + +if (abs(tan(z0_0) - cmplx(0.0,0.0,4)) > eps) call abort() +if (abs(tan(z1_1) - cmplx(0.27175257,1.0839232,4)) > eps) call abort() +if (abs(tan(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call abort() +if (abs(tan(z81_1) - cmplx(0.27175258531951174_8,1.0839233273386946_8,8)) > eps8) call abort() + +if (abs(cosh(z0_0) - cmplx(1.0,0.0,4)) > eps) call abort() +if (abs(cosh(z1_1) - cmplx(0.83372992,0.98889768,4)) > eps) call abort() +if (abs(cosh(z80_0) - cmplx(1.0_8,0.0_8,8)) > eps8) call abort() +if (abs(cosh(z81_1) - cmplx(0.83373002513114913_8,0.98889770576286506_8,8)) > eps8) call abort() + +if (abs(sinh(z0_0) - cmplx(0.0,0.0,4)) > eps) call abort() +if (abs(sinh(z1_1) - cmplx(0.63496387,1.2984575,4)) > eps) call abort() +if (abs(sinh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call abort() +if (abs(sinh(z81_1) - cmplx(0.63496391478473613_8,1.2984575814159773_8,8)) > eps8) call abort() + +if (abs(tanh(z0_0) - cmplx(0.0,0.0,4)) > eps) call abort() +if (abs(tanh(z1_1) - cmplx(1.0839232,0.27175257,4)) > eps) call abort() +if (abs(tanh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call abort() +if (abs(tanh(z81_1) - cmplx(1.0839233273386946_8,0.27175258531951174_8,8)) > eps8) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/complex_intrinsic_4.f90 b/gcc/testsuite/gfortran.dg/complex_intrinsic_4.f90 new file mode 100644 index 00000000000..faef28f2398 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/complex_intrinsic_4.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/33197 +! +! Fortran 2008 complex trigonometric functions: tan, cosh, sinh, tanh +! +real :: r +complex :: z +r = -45.5 +r = sin(r) +r = cos(r) +r = tan(r) +r = cosh(r) +r = sinh(r) +r = tanh(r) +z = 4.0 +z = cos(z) +z = sin(z) +z = tan(z) ! { dg-error "Fortran 2008: COMPLEX argument" } +z = cosh(z)! { dg-error "Fortran 2008: COMPLEX argument" } +z = sinh(z)! { dg-error "Fortran 2008: COMPLEX argument" } +z = tanh(z)! { dg-error "Fortran 2008: COMPLEX argument" } +end diff --git a/gcc/testsuite/gfortran.dg/derived_comp_array_ref_3.f90 b/gcc/testsuite/gfortran.dg/derived_comp_array_ref_3.f90 index 53d73e78802..7a0b77ea802 100644 --- a/gcc/testsuite/gfortran.dg/derived_comp_array_ref_3.f90 +++ b/gcc/testsuite/gfortran.dg/derived_comp_array_ref_3.f90 @@ -26,4 +26,4 @@ END MODULE cdf_nc_chisq_mod use cdf_nc_chisq_mod call local_cum_nc_chisq end -! { dg-final { cleanup-modules "cdf_aux_mod cdf_beta_mod" } } +! { dg-final { cleanup-modules "cdf_nc_chisq_mod" } } diff --git a/gcc/testsuite/gfortran.dg/derived_sub.f90 b/gcc/testsuite/gfortran.dg/derived_sub.f90 index 1750ada124a..9b6624579c2 100644 --- a/gcc/testsuite/gfortran.dg/derived_sub.f90 +++ b/gcc/testsuite/gfortran.dg/derived_sub.f90 @@ -31,3 +31,4 @@ contains end subroutine end module +! { dg-final { cleanup-modules "modone modtwo" } } diff --git a/gcc/testsuite/gfortran.dg/elemental_subroutine_6.f90 b/gcc/testsuite/gfortran.dg/elemental_subroutine_6.f90 index aab33f39dae..44577c888b7 100644 --- a/gcc/testsuite/gfortran.dg/elemental_subroutine_6.f90 +++ b/gcc/testsuite/gfortran.dg/elemental_subroutine_6.f90 @@ -21,4 +21,5 @@ CONTAINS ALLOCATE( out(1:42, 1:42) ) out(1, 1:42) = in(1, 1:42) END SUBROUTINE -END MODULE foo
\ No newline at end of file +END MODULE foo +! { dg-final { cleanup-modules "foo" } } diff --git a/gcc/testsuite/gfortran.dg/entry_16.f90 b/gcc/testsuite/gfortran.dg/entry_16.f90 index ba8eff86b8d..384d99fd72c 100644 --- a/gcc/testsuite/gfortran.dg/entry_16.f90 +++ b/gcc/testsuite/gfortran.dg/entry_16.f90 @@ -41,3 +41,4 @@ END MODULE complex if (.not.((a + b) .eq. (b + a))) call abort () if (.not.((a + b) .eq. cx (4, 2))) call abort () end +! { dg-final { cleanup-modules "complex" } } diff --git a/gcc/testsuite/gfortran.dg/f2003_io_4.f03 b/gcc/testsuite/gfortran.dg/f2003_io_4.f03 index d253a81bb64..92c708c2921 100644 --- a/gcc/testsuite/gfortran.dg/f2003_io_4.f03 +++ b/gcc/testsuite/gfortran.dg/f2003_io_4.f03 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } ! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org> ! Test of decimal= feature diff --git a/gcc/testsuite/gfortran.dg/fmt_cache_1.f b/gcc/testsuite/gfortran.dg/fmt_cache_1.f index 3390b723e66..825b44c11a7 100644 --- a/gcc/testsuite/gfortran.dg/fmt_cache_1.f +++ b/gcc/testsuite/gfortran.dg/fmt_cache_1.f @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } ! pr40662 segfaults when specific format is invoked twice. ! pr40330 incorrect io. ! test case derived from pr40662, <jvdelisle@gcc.gnu.org> diff --git a/gcc/testsuite/gfortran.dg/fmt_exhaust.f90 b/gcc/testsuite/gfortran.dg/fmt_exhaust.f90 index 5db34051485..bea3f800532 100644 --- a/gcc/testsuite/gfortran.dg/fmt_exhaust.f90 +++ b/gcc/testsuite/gfortran.dg/fmt_exhaust.f90 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } ! PR27304 Test running out of data descriptors with data remaining. ! Derived from case in PR. Submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org>. program test diff --git a/gcc/testsuite/gfortran.dg/fmt_t_4.f90 b/gcc/testsuite/gfortran.dg/fmt_t_4.f90 index e40a4fc46b7..62b8d49c046 100644 --- a/gcc/testsuite/gfortran.dg/fmt_t_4.f90 +++ b/gcc/testsuite/gfortran.dg/fmt_t_4.f90 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } ! PR31199, test case from PR report. program write_write character(len=20) :: a,b,c diff --git a/gcc/testsuite/gfortran.dg/fseek.f90 b/gcc/testsuite/gfortran.dg/fseek.f90 index 0189c408c6a..2649063ac59 100644 --- a/gcc/testsuite/gfortran.dg/fseek.f90 +++ b/gcc/testsuite/gfortran.dg/fseek.f90 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } PROGRAM test_fseek INTEGER, PARAMETER :: SEEK_SET = 0, SEEK_CUR = 1, SEEK_END = 2, fd=10 diff --git a/gcc/testsuite/gfortran.dg/generic_16.f90 b/gcc/testsuite/gfortran.dg/generic_16.f90 index cb6e34df554..501e146bcc1 100644 --- a/gcc/testsuite/gfortran.dg/generic_16.f90 +++ b/gcc/testsuite/gfortran.dg/generic_16.f90 @@ -32,3 +32,4 @@ PROGRAM main REAL(kind=dp) :: rawData(2), data, work(3) data = median(rawData, work) ! { dg-error "no specific function" } END PROGRAM main +! { dg-final { cleanup-modules "auxiliary" } } diff --git a/gcc/testsuite/gfortran.dg/inquire_11.f90 b/gcc/testsuite/gfortran.dg/inquire_11.f90 index f4107661d79..cc5e26d0908 100644 --- a/gcc/testsuite/gfortran.dg/inquire_11.f90 +++ b/gcc/testsuite/gfortran.dg/inquire_11.f90 @@ -8,3 +8,4 @@ CONTAINS INQUIRE (UNIT=1, EXIST=qexist) END SUBROUTINE i END MODULE print_it +! { dg-final { cleanup-modules "print_it" } } diff --git a/gcc/testsuite/gfortran.dg/list_read_5.f90 b/gcc/testsuite/gfortran.dg/list_read_5.f90 index f69d1f3ccff..658c5249722 100644 --- a/gcc/testsuite/gfortran.dg/list_read_5.f90 +++ b/gcc/testsuite/gfortran.dg/list_read_5.f90 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } ! PR25307 Check handling of end-of-file conditions for list directed reads. ! Prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org> program pr25307 diff --git a/gcc/testsuite/gfortran.dg/maxloc_bounds_6.f90 b/gcc/testsuite/gfortran.dg/maxloc_bounds_6.f90 index 74a78ff4727..3a63418aef3 100644 --- a/gcc/testsuite/gfortran.dg/maxloc_bounds_6.f90 +++ b/gcc/testsuite/gfortran.dg/maxloc_bounds_6.f90 @@ -13,4 +13,3 @@ program main write(line,fmt='(80I1)') res end program main ! { dg-output "Fortran runtime error: Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2" } -! { dg-final { cleanup-modules "tst" } } diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_5.f90 b/gcc/testsuite/gfortran.dg/missing_optional_dummy_5.f90 index 9b3631351e9..4ad399e8a98 100644 --- a/gcc/testsuite/gfortran.dg/missing_optional_dummy_5.f90 +++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_5.f90 @@ -25,5 +25,5 @@ end module krmod ! { dg-final { scan-tree-dump " tm_doit \\(&parm.\(6|7\), 0B, 0\\);" "original" } } ! { dg-final { cleanup-tree-dump "original" } } -! { dg-final { cleanup-modules "pr22146" } } +! { dg-final { cleanup-modules "krmod" } } diff --git a/gcc/testsuite/gfortran.dg/module_equivalence_6.f90 b/gcc/testsuite/gfortran.dg/module_equivalence_6.f90 index 8c8049e46be..c33a2caa3d1 100644 --- a/gcc/testsuite/gfortran.dg/module_equivalence_6.f90 +++ b/gcc/testsuite/gfortran.dg/module_equivalence_6.f90 @@ -19,4 +19,4 @@ PROGRAM fortranlibtest INTEGER :: ii ii = H5P_DEFAULT_F END PROGRAM fortranlibtest -! { dg-final { cleanup-modules "H5GLOBAL HD5" } } +! { dg-final { cleanup-modules "H5GLOBAL HDF5" } } diff --git a/gcc/testsuite/gfortran.dg/mvbits_6.f90 b/gcc/testsuite/gfortran.dg/mvbits_6.f90 index c8986df21ca..56ceacc5ec8 100644 --- a/gcc/testsuite/gfortran.dg/mvbits_6.f90 +++ b/gcc/testsuite/gfortran.dg/mvbits_6.f90 @@ -31,3 +31,4 @@ call yg0009(tda2l,4,3,1,-1,-4,-3) end +! { dg-final { cleanup-modules "yg0009_stuff" } } diff --git a/gcc/testsuite/gfortran.dg/namelist_39.f90 b/gcc/testsuite/gfortran.dg/namelist_39.f90 index 36721409fa5..82e631e0dd0 100644 --- a/gcc/testsuite/gfortran.dg/namelist_39.f90 +++ b/gcc/testsuite/gfortran.dg/namelist_39.f90 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } ! PR33421 and PR33253 Weird quotation of namelist output of character arrays ! Test case from Toon Moone, adapted by Jerry DeLisle <jvdelisle@gcc.gnu.org> diff --git a/gcc/testsuite/gfortran.dg/namelist_56.f90 b/gcc/testsuite/gfortran.dg/namelist_56.f90 index 03fda759f5c..8d879fc910b 100644 --- a/gcc/testsuite/gfortran.dg/namelist_56.f90 +++ b/gcc/testsuite/gfortran.dg/namelist_56.f90 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } ! PR37707 Namelist read of array of derived type incorrect ! Test case from Tobias Burnus IMPLICIT NONE diff --git a/gcc/testsuite/gfortran.dg/nan_2.f90 b/gcc/testsuite/gfortran.dg/nan_2.f90 index c26eebcb627..5882fa0888e 100644 --- a/gcc/testsuite/gfortran.dg/nan_2.f90 +++ b/gcc/testsuite/gfortran.dg/nan_2.f90 @@ -105,3 +105,4 @@ program test if (isinf(max(-large, -inf, nan))) call abort end program test +! { dg-final { cleanup-modules "aux2" } } diff --git a/gcc/testsuite/gfortran.dg/optional_dim_3.f90 b/gcc/testsuite/gfortran.dg/optional_dim_3.f90 index fc66ba5b843..45099a30735 100644 --- a/gcc/testsuite/gfortran.dg/optional_dim_3.f90 +++ b/gcc/testsuite/gfortran.dg/optional_dim_3.f90 @@ -50,3 +50,4 @@ program main call sub(bound=.false., dimmy=1_8) call sub() end program main +! { dg-final { cleanup-modules "tst_foo" } } diff --git a/gcc/testsuite/gfortran.dg/pr32921.f b/gcc/testsuite/gfortran.dg/pr32921.f index c166dd76360..42bb986ada0 100644 --- a/gcc/testsuite/gfortran.dg/pr32921.f +++ b/gcc/testsuite/gfortran.dg/pr32921.f @@ -47,3 +47,4 @@ END ! { dg-final { scan-tree-dump-times "stride" 4 "lim" } } ! { dg-final { cleanup-tree-dump "lim" } } +! { dg-final { cleanup-modules "LES3D_DATA" } } diff --git a/gcc/testsuite/gfortran.dg/private_type_9.f90 b/gcc/testsuite/gfortran.dg/private_type_9.f90 index 078041ae0be..3ca2fd5fb0f 100644 --- a/gcc/testsuite/gfortran.dg/private_type_9.f90 +++ b/gcc/testsuite/gfortran.dg/private_type_9.f90 @@ -39,3 +39,4 @@ module m4 end module m4 end +! { dg-final { cleanup-modules "m1 m2 m3 m4" } } diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_22.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_22.f90 index 6dfa1f23899..3b1f5c64e8b 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_22.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_22.f90 @@ -7,6 +7,7 @@ module bugTestMod implicit none + procedure(returnMat), pointer :: pp2 contains function returnMat( a, b ) result( mat ) integer:: a, b @@ -21,6 +22,8 @@ program bugTest procedure(returnMat), pointer :: pp pp => returnMat if (sum(pp(2,2))/=4) call abort() + pp2 => returnMat + if (sum(pp2(3,2))/=6) call abort() end program bugTest ! { dg-final { cleanup-modules "bugTestMod" } } diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_12.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_12.f90 index 314bcf8253b..5f26a782ed9 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_12.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_12.f90 @@ -27,6 +27,8 @@ program bugTest testCatch = testObj%test(2,2) print *,testCatch if (sum(testCatch)/=4) call abort() + print *,testObj%test(3,3) + if (sum(testObj%test(3,3))/=9) call abort() end program bugTest ! { dg-final { cleanup-modules "bugTestMod" } } diff --git a/gcc/testsuite/gfortran.dg/read_bad_advance.f90 b/gcc/testsuite/gfortran.dg/read_bad_advance.f90 index 5b43cfecc7f..3ca4493c451 100644 --- a/gcc/testsuite/gfortran.dg/read_bad_advance.f90 +++ b/gcc/testsuite/gfortran.dg/read_bad_advance.f90 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } ! PR27138 Failure to advance line on bad list directed read. ! Submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org> program test diff --git a/gcc/testsuite/gfortran.dg/read_repeat.f90 b/gcc/testsuite/gfortran.dg/read_repeat.f90 index 192ebe81ffb..ab7a6a4c7d5 100644 --- a/gcc/testsuite/gfortran.dg/read_repeat.f90 +++ b/gcc/testsuite/gfortran.dg/read_repeat.f90 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } ! PR39528 repeated entries not read when using list-directed input. ! Test case derived from reporters example. program rread diff --git a/gcc/testsuite/gfortran.dg/read_size_noadvance.f90 b/gcc/testsuite/gfortran.dg/read_size_noadvance.f90 index 819a28dcccb..37ecff90d65 100644 --- a/gcc/testsuite/gfortran.dg/read_size_noadvance.f90 +++ b/gcc/testsuite/gfortran.dg/read_size_noadvance.f90 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } ! PR26890 Test for use of SIZE variable in IO list. ! Test case from Paul Thomas. ! Submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org> diff --git a/gcc/testsuite/gfortran.dg/read_x_past.f b/gcc/testsuite/gfortran.dg/read_x_past.f index 4a6d05369d3..16f66234548 100644 --- a/gcc/testsuite/gfortran.dg/read_x_past.f +++ b/gcc/testsuite/gfortran.dg/read_x_past.f @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do run { target fd_truncate } } ! { dg-options -w } ! PR 26661 : Test reading X's past file end with no LF or CR. ! PR 26880 : Tests that rewind clears the gfc_unit read_bad flag. diff --git a/gcc/testsuite/gfortran.dg/recursive_parameter_1.f90 b/gcc/testsuite/gfortran.dg/recursive_parameter_1.f90 new file mode 100644 index 00000000000..8a13d254f49 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/recursive_parameter_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests the fix for PR39334 in which the recursive parameter declaration +! caused a sgfault. +! +! Reported by James van Buskirk on comp.lang.fortran +! +program recursive_parameter + implicit none + integer, parameter :: dp = kind(1.0_dp) ! { dg-error "Missing kind-parameter" } + write(*,*) dp ! { dg-error "has no IMPLICIT type" } +end program recursive_parameter diff --git a/gcc/testsuite/gfortran.dg/vect/vect-6.f b/gcc/testsuite/gfortran.dg/vect/vect-6.f new file mode 100644 index 00000000000..f232dcb82d8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/vect/vect-6.f @@ -0,0 +1,25 @@ +! { dg-do compile } + + SUBROUTINE PROPAGATE(ICI1,ICI2,I,J,J1,ELEM,NHSO,HSO + * ,MULST,IROOTS) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + COMPLEX*16 HSO,ELEM + DIMENSION HSO(NHSO,NHSO),MULST(*),IROOTS(*) + ISHIFT=MULST(ICI1)*(I-1)+1 + JSHIFT=MULST(ICI2)*(J-1)+1 + DO 200 ICI=1,ICI1-1 + ISHIFT=ISHIFT+MULST(ICI)*IROOTS(ICI) + 200 CONTINUE + DO 220 ICI=1,ICI2-1 + JSHIFT=JSHIFT+MULST(ICI)*IROOTS(ICI) + 220 CONTINUE + DO 150 MSS=MS,-MS,-2 + IND1=ISHIFT+K + IND2=JSHIFT+K + HSO(IND1,IND2)=ELEM + HSO(IND2,IND1)=DCONJG(ELEM) + 150 CONTINUE + END + +! { dg-final { cleanup-tree-dump "vect" } } + diff --git a/gcc/testsuite/gnat.dg/specs/addr1.ads b/gcc/testsuite/gnat.dg/specs/addr1.ads new file mode 100644 index 00000000000..83d432cff58 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/addr1.ads @@ -0,0 +1,35 @@ +-- { dg-do compile } + +with Interfaces; use Interfaces; + +package Addr1 is + + type Arr is array (Integer range <>) of Unsigned_16; + + type Rec1 is record + I1, I2: Integer; + end record; + + type Rec2 is record + I1, I2: Integer; + end record; + for Rec2'Size use 64; + + A: Arr (1 .. 12); + + Obj1: Rec1; + for Obj1'Address use A'Address; -- { dg-bogus "alignment" } + + Obj2: Rec2; + for Obj2'Address use A'Address; -- { dg-bogus "alignment" } + + Obj3: Rec1; + for Obj3'Address use A(1)'Address; -- { dg-bogus "alignment" } + + Obj4: Rec1; + for Obj4'Address use A(2)'Address; -- { dg-warning "(alignment|erroneous)" } + + Obj5: Rec1; + for Obj5'Address use A(3)'Address; -- { dg-bogus "alignment" } + +end Addr1; diff --git a/gcc/testsuite/lib/c-torture.exp b/gcc/testsuite/lib/c-torture.exp index bc14845b2fe..769ec97d3ec 100644 --- a/gcc/testsuite/lib/c-torture.exp +++ b/gcc/testsuite/lib/c-torture.exp @@ -54,6 +54,15 @@ if ![info exists GCC_UNDER_TEST] { set GCC_UNDER_TEST "[find_gcc]" } +global orig_environment_saved + +# This file may be sourced, so don't override environment settings +# that have been previously setup. +if { $orig_environment_saved == 0 } { + append ld_library_path [gcc-set-multilib-library-path $GCC_UNDER_TEST] + set_ld_library_path_env_vars +} + # # c-torture-compile -- runs the Tege C-torture test # @@ -99,13 +108,6 @@ proc c-torture-compile { src option } { # proc c-torture-execute { sources args } { global tmpdir tool srcdir output compiler_conditional_xfail_data - global ld_library_path ld_library_path_multilib GCC_UNDER_TEST - - if { "$ld_library_path_multilib" - != "[board_info target multilib_flags]" } { - set ld_library_path [find_libgcc_s $GCC_UNDER_TEST] - set_ld_library_path_env_vars - } # Use the first source filename given as the filename under test. set src [lindex $sources 0] diff --git a/gcc/testsuite/lib/g++.exp b/gcc/testsuite/lib/g++.exp index f31bbec588a..a5f26800c1c 100644 --- a/gcc/testsuite/lib/g++.exp +++ b/gcc/testsuite/lib/g++.exp @@ -106,51 +106,52 @@ proc g++_link_flags { paths } { set gccpath ${paths} set libio_dir "" set flags "" - set ld_library_path "" + set ld_library_path "." set shlib_ext [get_shlib_extension] verbose "shared lib extension: $shlib_ext" if { $gccpath != "" } { if [file exists "${gccpath}/lib/libstdc++.a"] { - add_path ld_library_path "${gccpath}/lib" + append ld_library_path ":${gccpath}/lib" } if [file exists "${gccpath}/libg++/libg++.a"] { append flags "-L${gccpath}/libg++ " - add_path ld_library_path "${gccpath}/libg++" + append ld_library_path ":${gccpath}/libg++" } if [file exists "${gccpath}/libstdc++/libstdc++.a"] { append flags "-L${gccpath}/libstdc++ " - add_path ld_library_path "${gccpath}/libstdc++" + append ld_library_path ":${gccpath}/libstdc++" } if [file exists "${gccpath}/libstdc++-v3/src/.libs/libstdc++.a"] { append flags " -L${gccpath}/libstdc++-v3/src/.libs " - add_path ld_library_path "${gccpath}/libstdc++-v3/src/.libs" + append ld_library_path ":${gccpath}/libstdc++-v3/src/.libs" } # Look for libstdc++.${shlib_ext}. if [file exists "${gccpath}/libstdc++-v3/src/.libs/libstdc++.${shlib_ext}"] { append flags " -L${gccpath}/libstdc++-v3/src/.libs " - add_path ld_library_path "${gccpath}/libstdc++-v3/src/.libs" + append ld_library_path ":${gccpath}/libstdc++-v3/src/.libs" } + if [file exists "${gccpath}/libiberty/libiberty.a"] { append flags "-L${gccpath}/libiberty " } if [file exists "${gccpath}/librx/librx.a"] { append flags "-L${gccpath}/librx " } - add_path ld_library_path [find_libgcc_s $GXX_UNDER_TEST] + append ld_library_path [gcc-set-multilib-library-path $GXX_UNDER_TEST] } else { global tool_root_dir set libgpp [lookfor_file ${tool_root_dir} libg++] if { $libgpp != "" } { append flags "-L${libgpp} " - add_path ld_library_path ${libgpp} + append ld_library_path ":${libgpp}" } set libstdcpp [lookfor_file ${tool_root_dir} libstdc++] if { $libstdcpp != "" } { append flags "-L${libstdcpp} " - add_path ld_library_path ${libstdcpp} + append ld_library_path ":${libstdcpp}" } set libiberty [lookfor_file ${tool_root_dir} libiberty] if { $libiberty != "" } { diff --git a/gcc/testsuite/lib/gcc-defs.exp b/gcc/testsuite/lib/gcc-defs.exp index 0a5d6a38d0d..53926a69a23 100644 --- a/gcc/testsuite/lib/gcc-defs.exp +++ b/gcc/testsuite/lib/gcc-defs.exp @@ -233,3 +233,35 @@ proc dg-additional-files-options { options source } { return $options } + +# Return a colon-separate list of directories to search for libraries +# for COMPILER, including multilib directories. + +proc gcc-set-multilib-library-path { compiler } { + global rootme + + # ??? rootme will not be set when testing an installed compiler. + # In that case, we should perhaps use some other method to find + # libraries. + if {![info exists rootme]} { + return "" + } + + set libpath ":${rootme}" + set compiler [lindex $compiler 0] + if { [is_remote host] == 0 && [which $compiler] != 0 } { + foreach i "[exec $compiler --print-multi-lib]" { + set mldir "" + regexp -- "\[a-z0-9=_/\.-\]*;" $i mldir + set mldir [string trimright $mldir "\;@"] + if { "$mldir" == "." } { + continue + } + if { [llength [glob -nocomplain ${rootme}/${mldir}/libgcc_s*.so.*]] >= 1 } { + append libpath ":${rootme}/${mldir}" + } + } + } + + return $libpath +} diff --git a/gcc/testsuite/lib/gcc-dg.exp b/gcc/testsuite/lib/gcc-dg.exp index 09b0cf4b49a..7e684171be9 100644 --- a/gcc/testsuite/lib/gcc-dg.exp +++ b/gcc/testsuite/lib/gcc-dg.exp @@ -65,6 +65,15 @@ if ![info exists GCC_UNDER_TEST] { set GCC_UNDER_TEST "[find_gcc]" } +global orig_environment_saved + +# This file may be sourced, so don't override environment settings +# that have been previously setup. +if { $orig_environment_saved == 0 } { + append ld_library_path [gcc-set-multilib-library-path $GCC_UNDER_TEST] + set_ld_library_path_env_vars +} + # Define gcc callbacks for dg.exp. proc gcc-dg-test-1 { target_compile prog do_what extra_tool_flags } { @@ -108,14 +117,6 @@ proc gcc-dg-test-1 { target_compile prog do_what extra_tool_flags } { set output_file "[file rootname [file tail $prog]].o" } "run" { - global ld_library_path ld_library_path_multilib GCC_UNDER_TEST - - if { "$ld_library_path_multilib" - != "[board_info target multilib_flags]" } { - set ld_library_path [find_libgcc_s $GCC_UNDER_TEST] - set_ld_library_path_env_vars - } - set compile_type "executable" # FIXME: "./" is to cope with "." not being in $PATH. # Should this be handled elsewhere? diff --git a/gcc/testsuite/lib/gfortran.exp b/gcc/testsuite/lib/gfortran.exp index 5c35e031d2b..a4d6e2b5d38 100644 --- a/gcc/testsuite/lib/gfortran.exp +++ b/gcc/testsuite/lib/gfortran.exp @@ -84,7 +84,7 @@ proc gfortran_link_flags { paths } { set gccpath ${paths} set libio_dir "" set flags "" - set ld_library_path "" + set ld_library_path "." set shlib_ext [get_shlib_extension] verbose "shared lib extension: $shlib_ext" @@ -94,11 +94,11 @@ proc gfortran_link_flags { paths } { # for uninstalled testing. append flags "-B${gccpath}/libgfortran/.libs " append flags "-L${gccpath}/libgfortran/.libs " - add_path ld_library_path "${gccpath}/libgfortran/.libs" + append ld_library_path ":${gccpath}/libgfortran/.libs" } if [file exists "${gccpath}/libgfortran/.libs/libgfortran.${shlib_ext}"] { append flags "-L${gccpath}/libgfortran/.libs " - add_path ld_library_path "${gccpath}/libgfortran/.libs" + append ld_library_path ":${gccpath}/libgfortran/.libs" } if [file exists "${gccpath}/libgfortran/libgforbegin.a"] { append flags "-L${gccpath}/libgfortran " @@ -106,7 +106,8 @@ proc gfortran_link_flags { paths } { if [file exists "${gccpath}/libiberty/libiberty.a"] { append flags "-L${gccpath}/libiberty " } - add_path ld_library_path [find_libgcc_s $GFORTRAN_UNDER_TEST] + append ld_library_path \ + [gcc-set-multilib-library-path $GFORTRAN_UNDER_TEST] } set_ld_library_path_env_vars diff --git a/gcc/testsuite/lib/gnat.exp b/gcc/testsuite/lib/gnat.exp index bb95487e8bd..35e18da93d2 100644 --- a/gcc/testsuite/lib/gnat.exp +++ b/gcc/testsuite/lib/gnat.exp @@ -147,7 +147,7 @@ proc gnat_target_compile { source dest type options } { set GNAT_UNDER_TEST "$GNAT_UNDER_TEST_ORIG $gnat_rts_opt" } - set ld_library_path ${gnat_libgcc_s_path} + set ld_library_path ".:${gnat_libgcc_s_path}" lappend options "compiler=$GNAT_UNDER_TEST -q -f" lappend options "timeout=[timeout_value]" diff --git a/gcc/testsuite/lib/obj-c++.exp b/gcc/testsuite/lib/obj-c++.exp index 4feb8c178c8..b61dc556437 100644 --- a/gcc/testsuite/lib/obj-c++.exp +++ b/gcc/testsuite/lib/obj-c++.exp @@ -106,30 +106,30 @@ proc obj-c++_link_flags { paths } { set gccpath ${paths} set libio_dir "" set flags "" - set ld_library_path "" + set ld_library_path "." set shlib_ext [get_shlib_extension] verbose "shared lib extension: $shlib_ext" if { $gccpath != "" } { if [file exists "${gccpath}/lib/libstdc++.a"] { - add_path ld_library_path "${gccpath}/lib" + append ld_library_path ":${gccpath}/lib" } if [file exists "${gccpath}/libg++/libg++.a"] { append flags "-L${gccpath}/libg++ " - add_path ld_library_path "${gccpath}/libg++" + append ld_library_path ":${gccpath}/libg++" } if [file exists "${gccpath}/libstdc++/libstdc++.a"] { append flags "-L${gccpath}/libstdc++ " - add_path ld_library_path "${gccpath}/libstdc++" + append ld_library_path ":${gccpath}/libstdc++" } if [file exists "${gccpath}/libstdc++-v3/src/.libs/libstdc++.a"] { append flags " -L${gccpath}/libstdc++-v3/src/.libs " - add_path ld_library_path "${gccpath}/libstdc++-v3/src/.libs" + append ld_library_path ":${gccpath}/libstdc++-v3/src/.libs" } # Look for libstdc++.${shlib_ext}. if [file exists "${gccpath}/libstdc++-v3/src/.libs/libstdc++.${shlib_ext}"] { append flags " -L${gccpath}/libstdc++-v3/src/.libs " - add_path ld_library_path "${gccpath}/libstdc++-v3/src/.libs" + append ld_library_path ":${gccpath}/libstdc++-v3/src/.libs" } if [file exists "${gccpath}/libiberty/libiberty.a"] { append flags "-L${gccpath}/libiberty " @@ -158,21 +158,23 @@ proc obj-c++_link_flags { paths } { if { $libobjc_dir != "" } { set libobjc_dir [file dirname ${libobjc_dir}] append flags "-L${libobjc_dir}" - add_path ld_library_path ${libobjc_dir} + append ld_library_path ":${libobjc_dir}" } - add_path ld_library_path [find_libgcc_s $OBJCXX_UNDER_TEST] + append ld_library_path \ + [gcc-set-multilib-library-path $OBJCXX_UNDER_TEST] + } else { global tool_root_dir; set libgpp [lookfor_file ${tool_root_dir} libg++]; if { $libgpp != "" } { append flags "-L${libgpp} "; - add_path ld_library_path ${libgpp} + append ld_library_path ":${libgpp}" } set libstdcpp [lookfor_file ${tool_root_dir} libstdc++]; if { $libstdcpp != "" } { append flags "-L${libstdcpp} "; - add_path ld_library_path ${libstdcpp} + append ld_library_path ":${libstdcpp}" } set libiberty [lookfor_file ${tool_root_dir} libiberty]; if { $libiberty != "" } { diff --git a/gcc/testsuite/lib/objc.exp b/gcc/testsuite/lib/objc.exp index c0eeb02bd93..934f31dabdc 100644 --- a/gcc/testsuite/lib/objc.exp +++ b/gcc/testsuite/lib/objc.exp @@ -121,7 +121,7 @@ proc objc_init { args } { objc_maybe_build_wrapper "${tmpdir}/objc-testglue.o" - set objc_libgcc_s_path [find_libgcc_s $OBJC_UNDER_TEST] + set objc_libgcc_s_path [gcc-set-multilib-library-path $OBJC_UNDER_TEST] } proc objc_target_compile { source dest type options } { @@ -135,7 +135,7 @@ proc objc_target_compile { source dest type options } { global objc_libgcc_s_path global shlib_ext - set ld_library_path ${objc_libgcc_s_path} + set ld_library_path ".:${objc_libgcc_s_path}" lappend options "libs=-lobjc" set shlib_ext [get_shlib_extension] verbose "shared lib extension: $shlib_ext" @@ -191,7 +191,7 @@ proc objc_target_compile { source dest type options } { set libobjc_dir [file dirname ${libobjc_dir}] set objc_link_flags "-L${libobjc_dir}" lappend options "additional_flags=${objc_link_flags}" - add_path ld_library_path ${libobjc_dir} + append ld_library_path ":${libobjc_dir}" } if { $type == "precompiled_header" } { # If we generating a precompiled header, we have say this is an diff --git a/gcc/testsuite/lib/target-libpath.exp b/gcc/testsuite/lib/target-libpath.exp index 49accd09687..6a01d9498e7 100644 --- a/gcc/testsuite/lib/target-libpath.exp +++ b/gcc/testsuite/lib/target-libpath.exp @@ -16,106 +16,175 @@ # This file was contributed by John David Anglin (dave.anglin@nrc-cnrc.gc.ca) -# A list of ld library path environment variables that might need to be -# defined. -# -# Some variables represent ABI-specific paths, and if these variables -# aren't defined, the dynamic loader might fall back on a more general -# variable. We must do the same when trying to read the current setting -# of such a path. Each element of this list is therefore itself a list: -# the first element of each sublist specifies the name of the variable, -# and the other elements specify fallback alternatives. We use FOO as a -# shorthand for { FOO }. -set ld_library_path_vars { - LD_LIBRARY_PATH - LD_RUN_PATH - SHLIB_PATH - { LD_LIBRARYN32_PATH LD_LIBRARY_PATH } - { LD_LIBRARY64_PATH LD_LIBRARY_PATH } - { LD_LIBRARY_PATH_32 LD_LIBRARY_PATH } - { LD_LIBRARY_PATH_64 LD_LIBRARY_PATH } - DYLD_LIBRARY_PATH -} - -# Set up the global orig_FOO_saved variables. We define this as a function -# to avoid polluting the global namespace with local variables. -proc init_ld_library_path_env_vars { } { - global ld_library_path_vars - - foreach spec $ld_library_path_vars { - set var orig_[string tolower [lindex $spec 0]]_saved - global $var - set $var 0 - } -} -init_ld_library_path_env_vars set orig_environment_saved 0 +set orig_ld_library_path_saved 0 +set orig_ld_run_path_saved 0 +set orig_shlib_path_saved 0 +set orig_ld_libraryn32_path_saved 0 +set orig_ld_library64_path_saved 0 +set orig_ld_library_path_32_saved 0 +set orig_ld_library_path_64_saved 0 +set orig_dyld_library_path_saved 0 set orig_gcc_exec_prefix_saved 0 set orig_gcc_exec_prefix_checked 0 -set ld_library_path_multilib unset + ####################################### # proc set_ld_library_path_env_vars { } ####################################### proc set_ld_library_path_env_vars { } { - global ld_library_path - global orig_environment_saved - global ld_library_path_vars - global orig_gcc_exec_prefix_saved - global orig_gcc_exec_prefix_checked - global orig_gcc_exec_prefix - global TEST_GCC_EXEC_PREFIX - global ld_library_path_multilib - global env - - # Save the original GCC_EXEC_PREFIX. - if { $orig_gcc_exec_prefix_checked == 0 } { - if [info exists env(GCC_EXEC_PREFIX)] { - set orig_gcc_exec_prefix "$env(GCC_EXEC_PREFIX)" - set orig_gcc_exec_prefix_saved 1 - } - set orig_gcc_exec_prefix_checked 1 - } + global ld_library_path + global orig_environment_saved + global orig_ld_library_path_saved + global orig_ld_run_path_saved + global orig_shlib_path_saved + global orig_ld_libraryn32_path_saved + global orig_ld_library64_path_saved + global orig_ld_library_path_32_saved + global orig_ld_library_path_64_saved + global orig_dyld_library_path_saved + global orig_gcc_exec_prefix_saved + global orig_gcc_exec_prefix_checked + global orig_ld_library_path + global orig_ld_run_path + global orig_shlib_path + global orig_ld_libraryn32_path + global orig_ld_library64_path + global orig_ld_library_path_32 + global orig_ld_library_path_64 + global orig_dyld_library_path + global orig_gcc_exec_prefix + global TEST_GCC_EXEC_PREFIX + global env - # Set GCC_EXEC_PREFIX for the compiler under test to pick up files not in - # the build tree from a specified location (normally the install tree). - if [info exists TEST_GCC_EXEC_PREFIX] { - setenv GCC_EXEC_PREFIX "$TEST_GCC_EXEC_PREFIX" + # Save the original GCC_EXEC_PREFIX. + if { $orig_gcc_exec_prefix_checked == 0 } { + if [info exists env(GCC_EXEC_PREFIX)] { + set orig_gcc_exec_prefix "$env(GCC_EXEC_PREFIX)" + set orig_gcc_exec_prefix_saved 1 } + set orig_gcc_exec_prefix_checked 1 + } - # Setting the ld library path causes trouble when testing cross-compilers. - if { [is_remote target] } { - return - } + # Set GCC_EXEC_PREFIX for the compiler under test to pick up files not in + # the build tree from a specified location (normally the install tree). + if [info exists TEST_GCC_EXEC_PREFIX] { + setenv GCC_EXEC_PREFIX "$TEST_GCC_EXEC_PREFIX" + } - set ld_library_path_multilib [board_info target multilib_flags] - - foreach spec $ld_library_path_vars { - set var [lindex $spec 0] - set lvar [string tolower $var] - - global orig_$lvar - global orig_${lvar}_saved - - if { $orig_environment_saved == 0 } { - if [info exists env($var)] { - set orig_$lvar [set env($var)] - set orig_${lvar}_saved 1 - } - } - set value $ld_library_path - foreach extra $spec { - set lextra [string tolower $extra] - if [set orig_${lextra}_saved] { - add_path value [set orig_$lextra] - break - } - } - setenv $var $value - } + # Setting the ld library path causes trouble when testing cross-compilers. + if { [is_remote target] } { + return + } + + if { $orig_environment_saved == 0 } { set orig_environment_saved 1 - verbose -log "set_ld_library_path_env_vars: ld_library_path=$ld_library_path" + + # Save the original environment. + if [info exists env(LD_LIBRARY_PATH)] { + set orig_ld_library_path "$env(LD_LIBRARY_PATH)" + set orig_ld_library_path_saved 1 + } + if [info exists env(LD_RUN_PATH)] { + set orig_ld_run_path "$env(LD_RUN_PATH)" + set orig_ld_run_path_saved 1 + } + if [info exists env(SHLIB_PATH)] { + set orig_shlib_path "$env(SHLIB_PATH)" + set orig_shlib_path_saved 1 + } + if [info exists env(LD_LIBRARYN32_PATH)] { + set orig_ld_libraryn32_path "$env(LD_LIBRARYN32_PATH)" + set orig_ld_libraryn32_path_saved 1 + } + if [info exists env(LD_LIBRARY64_PATH)] { + set orig_ld_library64_path "$env(LD_LIBRARY64_PATH)" + set orig_ld_library64_path_saved 1 + } + if [info exists env(LD_LIBRARY_PATH_32)] { + set orig_ld_library_path_32 "$env(LD_LIBRARY_PATH_32)" + set orig_ld_library_path_32_saved 1 + } + if [info exists env(LD_LIBRARY_PATH_64)] { + set orig_ld_library_path_64 "$env(LD_LIBRARY_PATH_64)" + set orig_ld_library_path_64_saved 1 + } + if [info exists env(DYLD_LIBRARY_PATH)] { + set orig_dyld_library_path "$env(DYLD_LIBRARY_PATH)" + set orig_dyld_library_path_saved 1 + } + } + + # We need to set ld library path in the environment. Currently, + # unix.exp doesn't set the environment correctly for all systems. + # It only sets SHLIB_PATH and LD_LIBRARY_PATH when it executes a + # program. We also need the environment set for compilations, etc. + # + # On IRIX 6, we have to set variables akin to LD_LIBRARY_PATH, but + # called LD_LIBRARYN32_PATH (for the N32 ABI) and LD_LIBRARY64_PATH + # (for the 64-bit ABI). The same applies to Darwin (DYLD_LIBRARY_PATH), + # Solaris 32 bit (LD_LIBRARY_PATH_32), Solaris 64 bit (LD_LIBRARY_PATH_64), + # and HP-UX (SHLIB_PATH). In some cases, the variables are independent + # of LD_LIBRARY_PATH, and in other cases LD_LIBRARY_PATH is used if the + # variable is not defined. + # + # Doing this is somewhat of a hack as ld_library_path gets repeated in + # SHLIB_PATH and LD_LIBRARY_PATH when unix_load sets these variables. + if { $orig_ld_library_path_saved } { + setenv LD_LIBRARY_PATH "$ld_library_path:$orig_ld_library_path" + } else { + setenv LD_LIBRARY_PATH "$ld_library_path" + } + if { $orig_ld_run_path_saved } { + setenv LD_RUN_PATH "$ld_library_path:$orig_ld_run_path" + } else { + setenv LD_RUN_PATH "$ld_library_path" + } + # The default shared library dynamic path search for 64-bit + # HP-UX executables searches LD_LIBRARY_PATH before SHLIB_PATH. + # LD_LIBRARY_PATH isn't used for 32-bit executables. Thus, we + # set LD_LIBRARY_PATH and SHLIB_PATH as if they were independent. + if { $orig_shlib_path_saved } { + setenv SHLIB_PATH "$ld_library_path:$orig_shlib_path" + } else { + setenv SHLIB_PATH "$ld_library_path" + } + if { $orig_ld_libraryn32_path_saved } { + setenv LD_LIBRARYN32_PATH "$ld_library_path:$orig_ld_libraryn32_path" + } elseif { $orig_ld_library_path_saved } { + setenv LD_LIBRARYN32_PATH "$ld_library_path:$orig_ld_library_path" + } else { + setenv LD_LIBRARYN32_PATH "$ld_library_path" + } + if { $orig_ld_library64_path_saved } { + setenv LD_LIBRARY64_PATH "$ld_library_path:$orig_ld_library64_path" + } elseif { $orig_ld_library_path_saved } { + setenv LD_LIBRARY64_PATH "$ld_library_path:$orig_ld_library_path" + } else { + setenv LD_LIBRARY64_PATH "$ld_library_path" + } + if { $orig_ld_library_path_32_saved } { + setenv LD_LIBRARY_PATH_32 "$ld_library_path:$orig_ld_library_path_32" + } elseif { $orig_ld_library_path_saved } { + setenv LD_LIBRARY_PATH_32 "$ld_library_path:$orig_ld_library_path" + } else { + setenv LD_LIBRARY_PATH_32 "$ld_library_path" + } + if { $orig_ld_library_path_64_saved } { + setenv LD_LIBRARY_PATH_64 "$ld_library_path:$orig_ld_library_path_64" + } elseif { $orig_ld_library_path_saved } { + setenv LD_LIBRARY_PATH_64 "$ld_library_path:$orig_ld_library_path" + } else { + setenv LD_LIBRARY_PATH_64 "$ld_library_path" + } + if { $orig_dyld_library_path_saved } { + setenv DYLD_LIBRARY_PATH "$ld_library_path:$orig_dyld_library_path" + } else { + setenv DYLD_LIBRARY_PATH "$ld_library_path" + } + + verbose -log "set_ld_library_path_env_vars: ld_library_path=$ld_library_path" } ####################################### @@ -123,35 +192,77 @@ proc set_ld_library_path_env_vars { } { ####################################### proc restore_ld_library_path_env_vars { } { - global orig_environment_saved - global ld_library_path_vars - global orig_gcc_exec_prefix_saved - global orig_gcc_exec_prefix - global env - - if { $orig_gcc_exec_prefix_saved } { - setenv GCC_EXEC_PREFIX "$orig_gcc_exec_prefix" - } elseif [info exists env(GCC_EXEC_PREFIX)] { - unsetenv GCC_EXEC_PREFIX - } + global orig_environment_saved + global orig_ld_library_path_saved + global orig_ld_run_path_saved + global orig_shlib_path_saved + global orig_ld_libraryn32_path_saved + global orig_ld_library64_path_saved + global orig_ld_library_path_32_saved + global orig_ld_library_path_64_saved + global orig_dyld_library_path_saved + global orig_gcc_exec_prefix_saved + global orig_ld_library_path + global orig_ld_run_path + global orig_shlib_path + global orig_ld_libraryn32_path + global orig_ld_library64_path + global orig_ld_library_path_32 + global orig_ld_library_path_64 + global orig_dyld_library_path + global orig_gcc_exec_prefix + global env - if { $orig_environment_saved == 0 } { - return - } - - foreach spec $ld_library_path_vars { - set var [lindex $spec 0] - set lvar [string tolower $var] + if { $orig_gcc_exec_prefix_saved } { + setenv GCC_EXEC_PREFIX "$orig_gcc_exec_prefix" + } elseif [info exists env(GCC_EXEC_PREFIX)] { + unsetenv GCC_EXEC_PREFIX + } - global orig_$lvar - global orig_${lvar}_saved + if { $orig_environment_saved == 0 } { + return + } - if [set orig_${lvar}_saved] { - setenv $var [set orig_$lvar] - } elseif [info exists env($var)] { - unsetenv $var - } - } + if { $orig_ld_library_path_saved } { + setenv LD_LIBRARY_PATH "$orig_ld_library_path" + } elseif [info exists env(LD_LIBRARY_PATH)] { + unsetenv LD_LIBRARY_PATH + } + if { $orig_ld_run_path_saved } { + setenv LD_RUN_PATH "$orig_ld_run_path" + } elseif [info exists env(LD_RUN_PATH)] { + unsetenv LD_RUN_PATH + } + if { $orig_shlib_path_saved } { + setenv SHLIB_PATH "$orig_shlib_path" + } elseif [info exists env(SHLIB_PATH)] { + unsetenv SHLIB_PATH + } + if { $orig_ld_libraryn32_path_saved } { + setenv LD_LIBRARYN32_PATH "$orig_ld_libraryn32_path" + } elseif [info exists env(LD_LIBRARYN32_PATH)] { + unsetenv LD_LIBRARYN32_PATH + } + if { $orig_ld_library64_path_saved } { + setenv LD_LIBRARY64_PATH "$orig_ld_library64_path" + } elseif [info exists env(LD_LIBRARY64_PATH)] { + unsetenv LD_LIBRARY64_PATH + } + if { $orig_ld_library_path_32_saved } { + setenv LD_LIBRARY_PATH_32 "$orig_ld_library_path_32" + } elseif [info exists env(LD_LIBRARY_PATH_32)] { + unsetenv LD_LIBRARY_PATH_32 + } + if { $orig_ld_library_path_64_saved } { + setenv LD_LIBRARY_PATH_64 "$orig_ld_library_path_64" + } elseif [info exists env(LD_LIBRARY_PATH_64)] { + unsetenv LD_LIBRARY_PATH_64 + } + if { $orig_dyld_library_path_saved } { + setenv DYLD_LIBRARY_PATH "$orig_dyld_library_path" + } elseif [info exists env(DYLD_LIBRARY_PATH)] { + unsetenv DYLD_LIBRARY_PATH + } } ####################################### @@ -173,46 +284,3 @@ proc get_shlib_extension { } { return $shlib_ext } -# If DIR is not an empty string, add it to the end of variable UPPATH, -# which represents a colon-separated path. -proc add_path { uppath dir } { - upvar $uppath path - - if { $dir != "" } { - if { [info exists path] && $path != "" } { - append path ":" - } - append path $dir - } -} - -# Return the directory that contains the shared libgcc for this multilib, -# or "" if we don't know. -proc find_libgcc_s { compiler } { - # Remote host testing requires an installed compiler (get_multilibs - # imposes the same restriction). It is up to the board file or - # tester to make sure that the installed compiler's libraries - # can be found in the library path. - if { [is_remote host] } { - return "" - } - # The same goes if we can't find the compiler. - set compiler_path [which [lindex $compiler 0]] - if { $compiler_path == "" } { - return "" - } - # Run the compiler with the current multilib flags to get the - # relative multilib directory. - set subdir [eval exec $compiler [board_info target multilib_flags] \ - --print-multi-directory] - # We are only interested in cases where libgcc_s is in the same - # directory as the compiler itself. - set dir [file dirname $compiler_path] - if { $subdir != "." } { - set dir [file join $dir $subdir] - } - if { ![file exists $dir] } { - return "" - } - return $dir -} diff --git a/gcc/tree-dfa.c b/gcc/tree-dfa.c index 64c5e266cd8..1067a439b44 100644 --- a/gcc/tree-dfa.c +++ b/gcc/tree-dfa.c @@ -729,7 +729,7 @@ get_ref_base_and_extent (tree exp, HOST_WIDE_INT *poffset, size_tree = DECL_SIZE (TREE_OPERAND (exp, 1)); else if (TREE_CODE (exp) == BIT_FIELD_REF) size_tree = TREE_OPERAND (exp, 1); - else + else if (!VOID_TYPE_P (TREE_TYPE (exp))) { enum machine_mode mode = TYPE_MODE (TREE_TYPE (exp)); if (mode == BLKmode) diff --git a/gcc/tree-flow.h b/gcc/tree-flow.h index c7733104dd0..cec5ed7a13a 100644 --- a/gcc/tree-flow.h +++ b/gcc/tree-flow.h @@ -63,6 +63,10 @@ struct GTY(()) gimple_df { /* The PTA solution for the CALLUSED artificial variable. */ struct pt_solution callused; + /* A map of decls to artificial ssa-names that point to the partition + of the decl. */ + struct pointer_map_t * GTY((skip(""))) decls_to_pointers; + /* Free list of SSA_NAMEs. */ tree free_ssanames; diff --git a/gcc/tree-optimize.c b/gcc/tree-optimize.c index 765e021e908..7a9d2bd7c46 100644 --- a/gcc/tree-optimize.c +++ b/gcc/tree-optimize.c @@ -226,10 +226,6 @@ execute_free_datastructures (void) free_dominance_info (CDI_DOMINATORS); free_dominance_info (CDI_POST_DOMINATORS); - /* Remove the ssa structures. */ - if (cfun->gimple_df) - delete_tree_ssa (); - /* And get rid of annotations we no longer need. */ delete_tree_cfg_annotations (); diff --git a/gcc/tree-parloops.c b/gcc/tree-parloops.c index 5f11fc77a1b..28c96a26f59 100644 --- a/gcc/tree-parloops.c +++ b/gcc/tree-parloops.c @@ -284,13 +284,15 @@ loop_parallel_p (struct loop *loop, htab_t reduction_list, { gimple phi = gsi_stmt (gsi); gimple reduc_stmt = NULL; + bool dummy; /* ??? TODO: Change this into a generic function that recognizes reductions. */ if (!is_gimple_reg (PHI_RESULT (phi))) continue; if (simple_loop_info) - reduc_stmt = vect_is_simple_reduction (simple_loop_info, phi, true); + reduc_stmt = vect_is_simple_reduction (simple_loop_info, phi, true, + &dummy); /* Create a reduction_info struct, initialize it and insert it to the reduction list. */ diff --git a/gcc/tree-ssa-alias.c b/gcc/tree-ssa-alias.c index 4d721877d02..92297fc6cf2 100644 --- a/gcc/tree-ssa-alias.c +++ b/gcc/tree-ssa-alias.c @@ -724,7 +724,7 @@ indirect_refs_may_alias_p (tree ref1, tree ptr1, /* Return true, if the two memory references REF1 and REF2 may alias. */ -static bool +bool refs_may_alias_p_1 (ao_ref *ref1, ao_ref *ref2, bool tbaa_p) { tree base1, base2; diff --git a/gcc/tree-ssa-alias.h b/gcc/tree-ssa-alias.h index 2be903f31c5..3a087505199 100644 --- a/gcc/tree-ssa-alias.h +++ b/gcc/tree-ssa-alias.h @@ -92,6 +92,7 @@ extern tree ao_ref_base (ao_ref *); extern alias_set_type ao_ref_alias_set (ao_ref *); extern bool ptr_deref_may_alias_global_p (tree); extern bool refs_may_alias_p (tree, tree); +extern bool refs_may_alias_p_1 (ao_ref *, ao_ref *, bool); extern bool refs_anti_dependent_p (tree, tree); extern bool refs_output_dependent_p (tree, tree); extern bool ref_maybe_used_by_stmt_p (gimple, tree); @@ -121,6 +122,7 @@ extern bool pt_solutions_intersect (struct pt_solution *, struct pt_solution *); extern bool pt_solutions_same_restrict_base (struct pt_solution *, struct pt_solution *); extern void pt_solution_reset (struct pt_solution *); +extern void pt_solution_set (struct pt_solution *, bitmap); extern void dump_pta_stats (FILE *); diff --git a/gcc/tree-ssa-loop-manip.c b/gcc/tree-ssa-loop-manip.c index c1514bf25f8..b891ea64957 100644 --- a/gcc/tree-ssa-loop-manip.c +++ b/gcc/tree-ssa-loop-manip.c @@ -990,10 +990,19 @@ tree_transform_and_unroll_loop (struct loop *loop, unsigned factor, /* Prefer using original variable as a base for the new ssa name. This is necessary for virtual ops, and useful in order to avoid losing debug info for real ops. */ - if (TREE_CODE (next) == SSA_NAME) + if (TREE_CODE (next) == SSA_NAME + && useless_type_conversion_p (TREE_TYPE (next), + TREE_TYPE (init))) var = SSA_NAME_VAR (next); - else if (TREE_CODE (init) == SSA_NAME) + else if (TREE_CODE (init) == SSA_NAME + && useless_type_conversion_p (TREE_TYPE (init), + TREE_TYPE (next))) var = SSA_NAME_VAR (init); + else if (useless_type_conversion_p (TREE_TYPE (next), TREE_TYPE (init))) + { + var = create_tmp_var (TREE_TYPE (next), "unrinittmp"); + add_referenced_var (var); + } else { var = create_tmp_var (TREE_TYPE (init), "unrinittmp"); diff --git a/gcc/tree-ssa-structalias.c b/gcc/tree-ssa-structalias.c index 303bd1f6e42..7e7e8e424c0 100644 --- a/gcc/tree-ssa-structalias.c +++ b/gcc/tree-ssa-structalias.c @@ -4886,6 +4886,28 @@ pt_solution_reset (struct pt_solution *pt) pt->anything = true; } +/* Set the points-to solution *PT to point only to the variables + in VARS. */ + +void +pt_solution_set (struct pt_solution *pt, bitmap vars) +{ + bitmap_iterator bi; + unsigned i; + + memset (pt, 0, sizeof (struct pt_solution)); + pt->vars = vars; + EXECUTE_IF_SET_IN_BITMAP (vars, 0, i, bi) + { + tree var = referenced_var_lookup (i); + if (is_global_var (var)) + { + pt->vars_contains_global = true; + break; + } + } +} + /* Return true if the points-to solution *PT is empty. */ static bool diff --git a/gcc/tree-ssa.c b/gcc/tree-ssa.c index c8a48a3b227..7ec04f70fad 100644 --- a/gcc/tree-ssa.c +++ b/gcc/tree-ssa.c @@ -802,52 +802,9 @@ init_tree_ssa (struct function *fn) void delete_tree_ssa (void) { - size_t i; - basic_block bb; - gimple_stmt_iterator gsi; referenced_var_iterator rvi; tree var; - /* Release any ssa_names still in use. */ - for (i = 0; i < num_ssa_names; i++) - { - tree var = ssa_name (i); - if (var && TREE_CODE (var) == SSA_NAME) - { - SSA_NAME_IMM_USE_NODE (var).prev = &(SSA_NAME_IMM_USE_NODE (var)); - SSA_NAME_IMM_USE_NODE (var).next = &(SSA_NAME_IMM_USE_NODE (var)); - } - release_ssa_name (var); - } - - /* FIXME. This may not be necessary. We will release all this - memory en masse in free_ssa_operands. This clearing used to be - necessary to avoid problems with the inliner, but it may not be - needed anymore. */ - FOR_EACH_BB (bb) - { - for (gsi = gsi_start_bb (bb); !gsi_end_p (gsi); gsi_next (&gsi)) - { - gimple stmt = gsi_stmt (gsi); - - if (gimple_has_ops (stmt)) - { - gimple_set_def_ops (stmt, NULL); - gimple_set_use_ops (stmt, NULL); - } - - if (gimple_has_mem_ops (stmt)) - { - gimple_set_vdef (stmt, NULL_TREE); - gimple_set_vuse (stmt, NULL_TREE); - } - - gimple_set_modified (stmt, true); - } - if (!(bb->flags & BB_RTL)) - set_phi_nodes (bb, NULL); - } - /* Remove annotations from every referenced local variable. */ FOR_EACH_REFERENCED_VAR (var, rvi) { @@ -873,6 +830,9 @@ delete_tree_ssa (void) cfun->gimple_df->default_defs = NULL; pt_solution_reset (&cfun->gimple_df->escaped); pt_solution_reset (&cfun->gimple_df->callused); + if (cfun->gimple_df->decls_to_pointers != NULL) + pointer_map_destroy (cfun->gimple_df->decls_to_pointers); + cfun->gimple_df->decls_to_pointers = NULL; cfun->gimple_df->modified_noreturn_calls = NULL; cfun->gimple_df = NULL; diff --git a/gcc/tree-vect-loop.c b/gcc/tree-vect-loop.c index a37e3c00f72..1db80e43efd 100644 --- a/gcc/tree-vect-loop.c +++ b/gcc/tree-vect-loop.c @@ -291,8 +291,7 @@ vect_determine_vectorization_factor (loop_vec_info loop_vinfo) } else { - - gcc_assert (! STMT_VINFO_DATA_REF (stmt_info) + gcc_assert (!STMT_VINFO_DATA_REF (stmt_info) && !is_pattern_stmt_p (stmt_info)); scalar_type = vect_get_smallest_scalar_type (stmt, &dummy, @@ -410,6 +409,7 @@ vect_analyze_scalar_cycles_1 (loop_vec_info loop_vinfo, struct loop *loop) tree dumy; VEC(gimple,heap) *worklist = VEC_alloc (gimple, heap, 64); gimple_stmt_iterator gsi; + bool double_reduc; if (vect_print_dump_info (REPORT_DETAILS)) fprintf (vect_dump, "=== vect_analyze_scalar_cycles ==="); @@ -477,26 +477,39 @@ vect_analyze_scalar_cycles_1 (loop_vec_info loop_vinfo, struct loop *loop) gcc_assert (STMT_VINFO_DEF_TYPE (stmt_vinfo) == vect_unknown_def_type); nested_cycle = (loop != LOOP_VINFO_LOOP (loop_vinfo)); - reduc_stmt = vect_is_simple_reduction (loop_vinfo, phi, !nested_cycle); + reduc_stmt = vect_is_simple_reduction (loop_vinfo, phi, !nested_cycle, + &double_reduc); if (reduc_stmt) { - if (nested_cycle) + if (double_reduc) { if (vect_print_dump_info (REPORT_DETAILS)) - fprintf (vect_dump, "Detected vectorizable nested cycle."); + fprintf (vect_dump, "Detected double reduction."); - STMT_VINFO_DEF_TYPE (stmt_vinfo) = vect_nested_cycle; + STMT_VINFO_DEF_TYPE (stmt_vinfo) = vect_double_reduction_def; STMT_VINFO_DEF_TYPE (vinfo_for_stmt (reduc_stmt)) = - vect_nested_cycle; + vect_double_reduction_def; } - else + else { - if (vect_print_dump_info (REPORT_DETAILS)) - fprintf (vect_dump, "Detected reduction."); + if (nested_cycle) + { + if (vect_print_dump_info (REPORT_DETAILS)) + fprintf (vect_dump, "Detected vectorizable nested cycle."); - STMT_VINFO_DEF_TYPE (stmt_vinfo) = vect_reduction_def; - STMT_VINFO_DEF_TYPE (vinfo_for_stmt (reduc_stmt)) = - vect_reduction_def; + STMT_VINFO_DEF_TYPE (stmt_vinfo) = vect_nested_cycle; + STMT_VINFO_DEF_TYPE (vinfo_for_stmt (reduc_stmt)) = + vect_nested_cycle; + } + else + { + if (vect_print_dump_info (REPORT_DETAILS)) + fprintf (vect_dump, "Detected reduction."); + + STMT_VINFO_DEF_TYPE (stmt_vinfo) = vect_reduction_def; + STMT_VINFO_DEF_TYPE (vinfo_for_stmt (reduc_stmt)) = + vect_reduction_def; + } } } else @@ -1111,10 +1124,13 @@ vect_analyze_loop_operations (loop_vec_info loop_vinfo) /* inner-loop loop-closed exit phi in outer-loop vectorization (i.e. a phi in the tail of the outer-loop). FORNOW: we currently don't support the case that these phis - are not used in the outerloop, cause this case requires - to actually do something here. */ - if (!STMT_VINFO_RELEVANT_P (stmt_info) - || STMT_VINFO_LIVE_P (stmt_info)) + are not used in the outerloop (unless it is double reduction, + i.e., this phi is vect_reduction_def), cause this case + requires to actually do something here. */ + if ((!STMT_VINFO_RELEVANT_P (stmt_info) + || STMT_VINFO_LIVE_P (stmt_info)) + && STMT_VINFO_DEF_TYPE (stmt_info) + != vect_double_reduction_def) { if (vect_print_dump_info (REPORT_DETAILS)) fprintf (vect_dump, @@ -1466,31 +1482,40 @@ vect_analyze_loop (struct loop *loop) Output: REDUC_CODE - the corresponding tree-code to be used to reduce the vector of partial results into a single scalar result (which - will also reside in a vector). + will also reside in a vector) or ERROR_MARK if the operation is + a supported reduction operation, but does not have such tree-code. - Return TRUE if a corresponding REDUC_CODE was found, FALSE otherwise. */ + Return FALSE if CODE currently cannot be vectorized as reduction. */ static bool reduction_code_for_scalar_code (enum tree_code code, enum tree_code *reduc_code) { switch (code) - { - case MAX_EXPR: - *reduc_code = REDUC_MAX_EXPR; - return true; - - case MIN_EXPR: - *reduc_code = REDUC_MIN_EXPR; - return true; - - case PLUS_EXPR: - *reduc_code = REDUC_PLUS_EXPR; - return true; - - default: - return false; - } + { + case MAX_EXPR: + *reduc_code = REDUC_MAX_EXPR; + return true; + + case MIN_EXPR: + *reduc_code = REDUC_MIN_EXPR; + return true; + + case PLUS_EXPR: + *reduc_code = REDUC_PLUS_EXPR; + return true; + + case MULT_EXPR: + case MINUS_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + case BIT_AND_EXPR: + *reduc_code = ERROR_MARK; + return true; + + default: + return false; + } } @@ -1507,7 +1532,7 @@ report_vect_op (gimple stmt, const char *msg) /* Function vect_is_simple_reduction - Detect a cross-iteration def-use cycle that represents a simple + (1) Detect a cross-iteration def-use cycle that represents a simple reduction computation. We look for the following pattern: loop_header: @@ -1524,12 +1549,20 @@ report_vect_op (gimple stmt, const char *msg) Condition 1 is tested here. Conditions 2,3 are tested in vect_mark_stmts_to_be_vectorized. - Also detect a cross-iteration def-use cycle in nested loops, i.e., nested - cycles, if CHECK_REDUCTION is false. */ + (2) Detect a cross-iteration def-use cycle in nested loops, i.e., + nested cycles, if CHECK_REDUCTION is false. + + (3) Detect cycles of phi nodes in outer-loop vectorization, i.e., double + reductions: + + a1 = phi < a0, a2 > + inner loop (def of a3) + a2 = phi < a3 > +*/ gimple vect_is_simple_reduction (loop_vec_info loop_info, gimple phi, - bool check_reduction) + bool check_reduction, bool *double_reduc) { struct loop *loop = (gimple_bb (phi))->loop_father; struct loop *vect_loop = LOOP_VINFO_LOOP (loop_info); @@ -1543,6 +1576,9 @@ vect_is_simple_reduction (loop_vec_info loop_info, gimple phi, tree name; imm_use_iterator imm_iter; use_operand_p use_p; + bool phi_def; + + *double_reduc = false; /* If CHECK_REDUCTION is true, we assume inner-most loop vectorization, otherwise, we assume outer loop vectorization. */ @@ -1584,14 +1620,24 @@ vect_is_simple_reduction (loop_vec_info loop_info, gimple phi, return NULL; } - if (!is_gimple_assign (def_stmt)) + if (!is_gimple_assign (def_stmt) && gimple_code (def_stmt) != GIMPLE_PHI) { if (vect_print_dump_info (REPORT_DETAILS)) print_gimple_stmt (vect_dump, def_stmt, 0, TDF_SLIM); return NULL; } - name = gimple_assign_lhs (def_stmt); + if (is_gimple_assign (def_stmt)) + { + name = gimple_assign_lhs (def_stmt); + phi_def = false; + } + else + { + name = PHI_RESULT (def_stmt); + phi_def = true; + } + nloop_uses = 0; FOR_EACH_IMM_USE_FAST (use_p, imm_iter, name) { @@ -1608,6 +1654,37 @@ vect_is_simple_reduction (loop_vec_info loop_info, gimple phi, } } + /* If DEF_STMT is a phi node itself, we expect it to have a single argument + defined in the inner loop. */ + if (phi_def) + { + op1 = PHI_ARG_DEF (def_stmt, 0); + + if (gimple_phi_num_args (def_stmt) != 1 + || TREE_CODE (op1) != SSA_NAME) + { + if (vect_print_dump_info (REPORT_DETAILS)) + fprintf (vect_dump, "unsupported phi node definition."); + + return NULL; + } + + def1 = SSA_NAME_DEF_STMT (op1); + if (flow_bb_inside_loop_p (loop, gimple_bb (def_stmt)) + && loop->inner + && flow_bb_inside_loop_p (loop->inner, gimple_bb (def1)) + && is_gimple_assign (def1)) + { + if (vect_print_dump_info (REPORT_DETAILS)) + report_vect_op (def_stmt, "detected double reduction: "); + + *double_reduc = true; + return def_stmt; + } + + return NULL; + } + code = gimple_assign_rhs_code (def_stmt); if (check_reduction @@ -1697,7 +1774,6 @@ vect_is_simple_reduction (loop_vec_info loop_info, gimple phi, return NULL; } - /* Check that one def is the reduction def, defined by PHI, the other def is either defined in the loop ("vect_internal_def"), or it's an induction (defined by a loop-header phi-node). */ @@ -2296,7 +2372,7 @@ get_initial_def_for_induction (gimple iv_phi) access_fn = analyze_scalar_evolution (iv_loop, PHI_RESULT (iv_phi)); gcc_assert (access_fn); ok = vect_is_simple_iv_evolution (iv_loop->num, access_fn, - &init_expr, &step_expr); + &init_expr, &step_expr); gcc_assert (ok); pe = loop_preheader_edge (iv_loop); @@ -2306,7 +2382,8 @@ get_initial_def_for_induction (gimple iv_phi) /* iv_loop is nested in the loop to be vectorized. init_expr had already been created during vectorization of previous stmts; We obtain it from the STMT_VINFO_VEC_STMT of the defining stmt. */ - tree iv_def = PHI_ARG_DEF_FROM_EDGE (iv_phi, loop_preheader_edge (iv_loop)); + tree iv_def = PHI_ARG_DEF_FROM_EDGE (iv_phi, + loop_preheader_edge (iv_loop)); vec_init = vect_get_vec_def_for_operand (iv_def, iv_phi, NULL); } else @@ -2507,18 +2584,16 @@ get_initial_def_for_induction (gimple iv_phi) vector of partial results. Option1 (adjust in epilog): Initialize the vector as follows: - add: [0,0,...,0,0] - mult: [1,1,...,1,1] - min/max: [init_val,init_val,..,init_val,init_val] - bit and/or: [init_val,init_val,..,init_val,init_val] + add/bit or/xor: [0,0,...,0,0] + mult/bit and: [1,1,...,1,1] + min/max: [init_val,init_val,..,init_val,init_val] and when necessary (e.g. add/mult case) let the caller know that it needs to adjust the result by init_val. Option2: Initialize the vector as follows: - add: [0,0,...,0,init_val] - mult: [1,1,...,1,init_val] - min/max: [init_val,init_val,...,init_val] - bit and/or: [init_val,init_val,...,init_val] + add/bit or/xor: [init_val,0,0,...,0] + mult/bit and: [init_val,1,1,...,1] + min/max: [init_val,init_val,...,init_val] and no adjustments are needed. For example, for the following code: @@ -2533,11 +2608,14 @@ get_initial_def_for_induction (gimple iv_phi) the result at the end by 'init_val'. FORNOW, we are using the 'adjust in epilog' scheme, because this way the - initialization vector is simpler (same element in all entries). + initialization vector is simpler (same element in all entries), if + ADJUSTMENT_DEF is not NULL, and Option2 otherwise. + A cost model should help decide between these two schemes. */ tree -get_initial_def_for_reduction (gimple stmt, tree init_val, tree *adjustment_def) +get_initial_def_for_reduction (gimple stmt, tree init_val, + tree *adjustment_def) { stmt_vec_info stmt_vinfo = vinfo_for_stmt (stmt); loop_vec_info loop_vinfo = STMT_VINFO_LOOP_VINFO (stmt_vinfo); @@ -2551,47 +2629,123 @@ get_initial_def_for_reduction (gimple stmt, tree init_val, tree *adjustment_def) tree t = NULL_TREE; int i; bool nested_in_vect_loop = false; + tree init_value; + REAL_VALUE_TYPE real_init_val = dconst0; + int int_init_val = 0; + gimple def_stmt = NULL; gcc_assert (vectype); nunits = TYPE_VECTOR_SUBPARTS (vectype); gcc_assert (POINTER_TYPE_P (scalar_type) || INTEGRAL_TYPE_P (scalar_type) || SCALAR_FLOAT_TYPE_P (scalar_type)); + if (nested_in_vect_loop_p (loop, stmt)) nested_in_vect_loop = true; else gcc_assert (loop == (gimple_bb (stmt))->loop_father); - switch (code) - { - case WIDEN_SUM_EXPR: - case DOT_PROD_EXPR: - case PLUS_EXPR: - case MINUS_EXPR: - if (nested_in_vect_loop) - *adjustment_def = vect_get_vec_def_for_operand (init_val, stmt, NULL); - else - *adjustment_def = init_val; - /* Create a vector of zeros for init_def. */ - if (SCALAR_FLOAT_TYPE_P (scalar_type)) - def_for_init = build_real (scalar_type, dconst0); - else - def_for_init = build_int_cst (scalar_type, 0); - - for (i = nunits - 1; i >= 0; --i) - t = tree_cons (NULL_TREE, def_for_init, t); - init_def = build_vector (vectype, t); - break; + /* In case of double reduction we only create a vector variable to be put + in the reduction phi node. The actual statement creation is done in + vect_create_epilog_for_reduction. */ + if (adjustment_def && nested_in_vect_loop + && TREE_CODE (init_val) == SSA_NAME + && (def_stmt = SSA_NAME_DEF_STMT (init_val)) + && gimple_code (def_stmt) == GIMPLE_PHI + && flow_bb_inside_loop_p (loop, gimple_bb (def_stmt)) + && vinfo_for_stmt (def_stmt) + && STMT_VINFO_DEF_TYPE (vinfo_for_stmt (def_stmt)) + == vect_double_reduction_def) + { + *adjustment_def = NULL; + return vect_create_destination_var (init_val, vectype); + } - case MIN_EXPR: - case MAX_EXPR: - *adjustment_def = NULL_TREE; - init_def = vect_get_vec_def_for_operand (init_val, stmt, NULL); - break; + if (TREE_CONSTANT (init_val)) + { + if (SCALAR_FLOAT_TYPE_P (scalar_type)) + init_value = build_real (scalar_type, TREE_REAL_CST (init_val)); + else + init_value = build_int_cst (scalar_type, TREE_INT_CST_LOW (init_val)); + } + else + init_value = init_val; - default: - gcc_unreachable (); - } + switch (code) + { + case WIDEN_SUM_EXPR: + case DOT_PROD_EXPR: + case PLUS_EXPR: + case MINUS_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + case MULT_EXPR: + case BIT_AND_EXPR: + /* ADJUSMENT_DEF is NULL when called from + vect_create_epilog_for_reduction to vectorize double reduction. */ + if (adjustment_def) + { + if (nested_in_vect_loop) + *adjustment_def = vect_get_vec_def_for_operand (init_val, stmt, + NULL); + else + *adjustment_def = init_val; + } + + if (code == MULT_EXPR || code == BIT_AND_EXPR) + { + real_init_val = dconst1; + int_init_val = 1; + } + + if (SCALAR_FLOAT_TYPE_P (scalar_type)) + def_for_init = build_real (scalar_type, real_init_val); + else + def_for_init = build_int_cst (scalar_type, int_init_val); + + /* Create a vector of '0' or '1' except the first element. */ + for (i = nunits - 2; i >= 0; --i) + t = tree_cons (NULL_TREE, def_for_init, t); + + /* Option1: the first element is '0' or '1' as well. */ + if (adjustment_def) + { + t = tree_cons (NULL_TREE, def_for_init, t); + init_def = build_vector (vectype, t); + break; + } + + /* Option2: the first element is INIT_VAL. */ + t = tree_cons (NULL_TREE, init_value, t); + if (TREE_CONSTANT (init_val)) + init_def = build_vector (vectype, t); + else + init_def = build_constructor_from_list (vectype, t); + + break; + + case MIN_EXPR: + case MAX_EXPR: + if (adjustment_def) + { + *adjustment_def = NULL_TREE; + init_def = vect_get_vec_def_for_operand (init_val, stmt, NULL); + break; + } + + for (i = nunits - 1; i >= 0; --i) + t = tree_cons (NULL_TREE, init_value, t); + + if (TREE_CONSTANT (init_val)) + init_def = build_vector (vectype, t); + else + init_def = build_constructor_from_list (vectype, t); + + break; + + default: + gcc_unreachable (); + } return init_def; } @@ -2613,6 +2767,7 @@ get_initial_def_for_reduction (gimple stmt, tree init_val, tree *adjustment_def) REDUCTION_PHI is the phi-node that carries the reduction computation. REDUC_INDEX is the index of the operand in the right hand side of the statement that is defined by REDUCTION_PHI. + DOUBLE_REDUC is TRUE if double reduction phi nodes should be handled. This function: 1. Creates the reduction def-use cycle: sets the arguments for @@ -2657,14 +2812,15 @@ vect_create_epilog_for_reduction (tree vect_def, gimple stmt, int ncopies, enum tree_code reduc_code, gimple reduction_phi, - int reduc_index) + int reduc_index, + bool double_reduc) { stmt_vec_info stmt_info = vinfo_for_stmt (stmt); stmt_vec_info prev_phi_info; tree vectype; enum machine_mode mode; loop_vec_info loop_vinfo = STMT_VINFO_LOOP_VINFO (stmt_info); - struct loop *loop = LOOP_VINFO_LOOP (loop_vinfo); + struct loop *loop = LOOP_VINFO_LOOP (loop_vinfo), *outer_loop = NULL; basic_block exit_bb; tree scalar_dest; tree scalar_type; @@ -2694,6 +2850,7 @@ vect_create_epilog_for_reduction (tree vect_def, gimple stmt, if (nested_in_vect_loop_p (loop, stmt)) { + outer_loop = loop; loop = loop->inner; nested_in_vect_loop = true; } @@ -2726,7 +2883,7 @@ vect_create_epilog_for_reduction (tree vect_def, gimple stmt, the scalar def before the loop, that defines the initial value of the reduction variable. */ vec_initial_def = vect_get_vec_def_for_operand (reduction_op, stmt, - &adjustment_def); + &adjustment_def); phi = reduction_phi; def = vect_def; @@ -2744,8 +2901,8 @@ vect_create_epilog_for_reduction (tree vect_def, gimple stmt, { fprintf (vect_dump, "transform reduction: created def-use cycle: "); print_gimple_stmt (vect_dump, phi, 0, TDF_SLIM); - fprintf (vect_dump, "\n"); - print_gimple_stmt (vect_dump, SSA_NAME_DEF_STMT (def), 0, TDF_SLIM); + fprintf (vect_dump, "\n"); + print_gimple_stmt (vect_dump, SSA_NAME_DEF_STMT (def), 0, TDF_SLIM); } phi = STMT_VINFO_RELATED_STMT (vinfo_for_stmt (phi)); @@ -2831,15 +2988,25 @@ vect_create_epilog_for_reduction (tree vect_def, gimple stmt, bitsize = TYPE_SIZE (scalar_type); bytesize = TYPE_SIZE_UNIT (scalar_type); + /* For MINUS_EXPR the initial vector is [init_val,0,...,0], therefore, + partial results are added and not subtracted. */ + if (code == MINUS_EXPR) + code = PLUS_EXPR; /* In case this is a reduction in an inner-loop while vectorizing an outer loop - we don't need to extract a single scalar result at the end of the - inner-loop. The final vector of partial results will be used in the - vectorized outer-loop, or reduced to a scalar result at the end of the - outer-loop. */ - if (nested_in_vect_loop) + inner-loop (unless it is double reduction, i.e., the use of reduction is + outside the outer-loop). The final vector of partial results will be used + in the vectorized outer-loop, or reduced to a scalar result at the end of + the outer-loop. */ + if (nested_in_vect_loop && !double_reduc) goto vect_finalize_reduction; + /* The epilogue is created for the outer-loop, i.e., for the loop being + vectorized. */ + if (double_reduc) + loop = outer_loop; + /* FORNOW */ gcc_assert (ncopies == 1); @@ -2914,6 +3081,7 @@ vect_create_epilog_for_reduction (tree vect_def, gimple stmt, bit_offset /= 2) { tree bitpos = size_int (bit_offset); + epilog_stmt = gimple_build_assign_with_ops (shift_code, vec_dest, new_temp, bitpos); new_name = make_ssa_name (vec_dest, epilog_stmt); @@ -2987,7 +3155,7 @@ vect_create_epilog_for_reduction (tree vect_def, gimple stmt, { tree rhs; - gcc_assert (!nested_in_vect_loop); + gcc_assert (!nested_in_vect_loop || double_reduc); if (vect_print_dump_info (REPORT_DETAILS)) fprintf (vect_dump, "extract scalar result"); @@ -3007,6 +3175,9 @@ vect_create_epilog_for_reduction (tree vect_def, gimple stmt, vect_finalize_reduction: + if (double_reduc) + loop = loop->inner; + /* 2.5 Adjust the final result by the initial value of the reduction variable. (When such adjustment is not needed, then 'adjustment_def' is zero). For example, if code is PLUS we create: @@ -3016,11 +3187,6 @@ vect_finalize_reduction: { if (nested_in_vect_loop) { - /* For MINUS_EXPR we create new_temp = loop_exit_def + adjustment_def - since the initial value is [0,0,...,0]. */ - if (code == MINUS_EXPR) - code = PLUS_EXPR; - gcc_assert (TREE_CODE (TREE_TYPE (adjustment_def)) == VECTOR_TYPE); expr = build2 (code, vectype, PHI_RESULT (new_phi), adjustment_def); new_dest = vect_create_destination_var (scalar_dest, vectype); @@ -3055,6 +3221,7 @@ vect_finalize_reduction: VEC_quick_push (gimple, phis, exit_phi); } } + /* We expect to have found an exit_phi because of loop-closed-ssa form. */ gcc_assert (!VEC_empty (gimple, phis)); @@ -3063,12 +3230,13 @@ vect_finalize_reduction: if (nested_in_vect_loop) { stmt_vec_info stmt_vinfo = vinfo_for_stmt (exit_phi); + gimple vect_phi; /* FORNOW. Currently not supporting the case that an inner-loop reduction is not used in the outer-loop (but only outside the - outer-loop). */ - gcc_assert (STMT_VINFO_RELEVANT_P (stmt_vinfo) - && !STMT_VINFO_LIVE_P (stmt_vinfo)); + outer-loop), unless it is double reduction. */ + gcc_assert ((STMT_VINFO_RELEVANT_P (stmt_vinfo) + && !STMT_VINFO_LIVE_P (stmt_vinfo)) || double_reduc); epilog_stmt = adjustment_def ? epilog_stmt : new_phi; STMT_VINFO_VEC_STMT (stmt_vinfo) = epilog_stmt; @@ -3078,7 +3246,88 @@ vect_finalize_reduction: if (adjustment_def) STMT_VINFO_RELATED_STMT (vinfo_for_stmt (epilog_stmt)) = STMT_VINFO_RELATED_STMT (vinfo_for_stmt (new_phi)); - continue; + + if (!double_reduc + || STMT_VINFO_DEF_TYPE (stmt_vinfo) != vect_double_reduction_def) + continue; + + /* Handle double reduction: + + stmt1: s1 = phi <s0, s2> - double reduction phi (outer loop) + stmt2: s3 = phi <s1, s4> - (regular) reduction phi (inner loop) + stmt3: s4 = use (s3) - (regular) reduction stmt (inner loop) + stmt4: s2 = phi <s4> - double reduction stmt (outer loop) + + At that point the regular reduction (stmt2 and stmt3) is already + vectorized, as well as the exit phi node, stmt4. + Here we vectorize the phi node of double reduction, stmt1, and + update all relevant statements. */ + + /* Go through all the uses of s2 to find double reduction phi node, + i.e., stmt1 above. */ + orig_name = PHI_RESULT (exit_phi); + FOR_EACH_IMM_USE_STMT (use_stmt, imm_iter, orig_name) + { + stmt_vec_info use_stmt_vinfo = vinfo_for_stmt (use_stmt); + stmt_vec_info new_phi_vinfo; + tree vect_phi_init, preheader_arg, vect_phi_res, init_def; + basic_block bb = gimple_bb (use_stmt); + gimple use; + + /* Check that USE_STMT is really double reduction phi node. */ + if (gimple_code (use_stmt) != GIMPLE_PHI + || gimple_phi_num_args (use_stmt) != 2 + || !use_stmt_vinfo + || STMT_VINFO_DEF_TYPE (use_stmt_vinfo) + != vect_double_reduction_def + || bb->loop_father != outer_loop) + continue; + + /* Create vector phi node for double reduction: + vs1 = phi <vs0, vs2> + vs1 was created previously in this function by a call to + vect_get_vec_def_for_operand and is stored in vec_initial_def; + vs2 is defined by EPILOG_STMT, the vectorized EXIT_PHI; + vs0 is created here. */ + + /* Create vector phi node. */ + vect_phi = create_phi_node (vec_initial_def, bb); + new_phi_vinfo = new_stmt_vec_info (vect_phi, + loop_vec_info_for_loop (outer_loop), NULL); + set_vinfo_for_stmt (vect_phi, new_phi_vinfo); + + /* Create vs0 - initial def of the double reduction phi. */ + preheader_arg = PHI_ARG_DEF_FROM_EDGE (use_stmt, + loop_preheader_edge (outer_loop)); + init_def = get_initial_def_for_reduction (stmt, preheader_arg, + NULL); + vect_phi_init = vect_init_vector (use_stmt, init_def, vectype, + NULL); + + /* Update phi node arguments with vs0 and vs2. */ + add_phi_arg (vect_phi, vect_phi_init, + loop_preheader_edge (outer_loop)); + add_phi_arg (vect_phi, PHI_RESULT (epilog_stmt), + loop_latch_edge (outer_loop)); + if (vect_print_dump_info (REPORT_DETAILS)) + { + fprintf (vect_dump, "created double reduction phi node: "); + print_gimple_stmt (vect_dump, vect_phi, 0, TDF_SLIM); + } + + vect_phi_res = PHI_RESULT (vect_phi); + + /* Replace the use, i.e., set the correct vs1 in the regular + reduction phi node. FORNOW, NCOPIES is always 1, so the loop + is redundant. */ + use = reduction_phi; + for (j = 0; j < ncopies; j++) + { + edge pr_edge = loop_preheader_edge (loop); + SET_PHI_ARG_DEF (use, pr_edge->dest_idx, vect_phi_res); + use = STMT_VINFO_RELATED_STMT (vinfo_for_stmt (use)); + } + } } /* Replace the uses: */ @@ -3087,6 +3336,7 @@ vect_finalize_reduction: FOR_EACH_IMM_USE_ON_STMT (use_p, imm_iter) SET_USE (use_p, new_temp); } + VEC_free (gimple, heap, phis); } @@ -3171,9 +3421,15 @@ vectorizable_reduction (gimple stmt, gimple_stmt_iterator *gsi, gimple reduc_def_stmt = NULL; /* The default is that the reduction variable is the last in statement. */ int reduc_index = 2; + bool double_reduc = false, dummy; + basic_block def_bb; + struct loop * def_stmt_loop, *outer_loop = NULL; + tree def_arg; + gimple def_arg_stmt; if (nested_in_vect_loop_p (loop, stmt)) { + outer_loop = loop; loop = loop->inner; nested_cycle = true; } @@ -3185,7 +3441,6 @@ vectorizable_reduction (gimple stmt, gimple_stmt_iterator *gsi, return false; /* 1. Is vectorizable reduction? */ - /* Not supportable if the reduction variable is used in the loop. */ if (STMT_VINFO_RELEVANT (stmt_info) > vect_used_in_outer) return false; @@ -3300,10 +3555,11 @@ vectorizable_reduction (gimple stmt, gimple_stmt_iterator *gsi, if (orig_stmt) gcc_assert (orig_stmt == vect_is_simple_reduction (loop_vinfo, reduc_def_stmt, - !nested_cycle)); + !nested_cycle, + &dummy)); else gcc_assert (stmt == vect_is_simple_reduction (loop_vinfo, reduc_def_stmt, - !nested_cycle)); + !nested_cycle, &dummy)); if (STMT_VINFO_LIVE_P (vinfo_for_stmt (reduc_def_stmt))) return false; @@ -3400,25 +3656,49 @@ vectorizable_reduction (gimple stmt, gimple_stmt_iterator *gsi, orig_code = code; } - if (nested_cycle) - epilog_reduc_code = orig_code; - else - if (!reduction_code_for_scalar_code (orig_code, &epilog_reduc_code)) - return false; + if (!reduction_code_for_scalar_code (orig_code, &epilog_reduc_code)) + return false; - reduc_optab = optab_for_tree_code (epilog_reduc_code, vectype, optab_default); + reduc_optab = optab_for_tree_code (epilog_reduc_code, vectype, + optab_default); if (!reduc_optab) { if (vect_print_dump_info (REPORT_DETAILS)) fprintf (vect_dump, "no optab for reduction."); epilog_reduc_code = ERROR_MARK; } - if (optab_handler (reduc_optab, vec_mode)->insn_code == CODE_FOR_nothing) + + if (reduc_optab + && optab_handler (reduc_optab, vec_mode)->insn_code == CODE_FOR_nothing) { if (vect_print_dump_info (REPORT_DETAILS)) fprintf (vect_dump, "reduc op not supported by target."); epilog_reduc_code = ERROR_MARK; } + + if (nested_cycle) + { + def_bb = gimple_bb (reduc_def_stmt); + def_stmt_loop = def_bb->loop_father; + def_arg = PHI_ARG_DEF_FROM_EDGE (reduc_def_stmt, + loop_preheader_edge (def_stmt_loop)); + if (TREE_CODE (def_arg) == SSA_NAME + && (def_arg_stmt = SSA_NAME_DEF_STMT (def_arg)) + && gimple_code (def_arg_stmt) == GIMPLE_PHI + && flow_bb_inside_loop_p (outer_loop, gimple_bb (def_arg_stmt)) + && vinfo_for_stmt (def_arg_stmt) + && STMT_VINFO_DEF_TYPE (vinfo_for_stmt (def_arg_stmt)) + == vect_double_reduction_def) + double_reduc = true; + } + + if (double_reduc && ncopies > 1) + { + if (vect_print_dump_info (REPORT_DETAILS)) + fprintf (vect_dump, "multiple types in double reduction"); + + return false; + } if (!vec_stmt) /* transformation not required. */ { @@ -3560,8 +3840,10 @@ vectorizable_reduction (gimple stmt, gimple_stmt_iterator *gsi, epilog reduction code. */ if (!single_defuse_cycle) new_temp = gimple_assign_lhs (*vec_stmt); + vect_create_epilog_for_reduction (new_temp, stmt, epilog_copies, - epilog_reduc_code, first_phi, reduc_index); + epilog_reduc_code, first_phi, reduc_index, + double_reduc); return true; } diff --git a/gcc/tree-vect-stmts.c b/gcc/tree-vect-stmts.c index 1c9415b7031..891ee1860f0 100644 --- a/gcc/tree-vect-stmts.c +++ b/gcc/tree-vect-stmts.c @@ -331,7 +331,7 @@ process_use (gimple stmt, tree use, loop_vec_info loop_vinfo, bool live_p, ... inner-loop: d = def_stmt - outer-loop-tail-bb: + outer-loop-tail-bb (or outer-loop-exit-bb in double reduction): stmt # use (d) */ else if (flow_loop_nested_p (bb->loop_father, def_bb->loop_father)) { @@ -341,7 +341,8 @@ process_use (gimple stmt, tree use, loop_vec_info loop_vinfo, bool live_p, switch (relevant) { case vect_unused_in_scope: - relevant = (STMT_VINFO_DEF_TYPE (stmt_vinfo) == vect_reduction_def) ? + relevant = (STMT_VINFO_DEF_TYPE (stmt_vinfo) == vect_reduction_def + || STMT_VINFO_DEF_TYPE (stmt_vinfo) == vect_double_reduction_def) ? vect_used_in_outer_by_reduction : vect_unused_in_scope; break; @@ -393,7 +394,8 @@ vect_mark_stmts_to_be_vectorized (loop_vec_info loop_vinfo) basic_block bb; gimple phi; bool live_p; - enum vect_relevant relevant; + enum vect_relevant relevant, tmp_relevant; + enum vect_def_type def_type; if (vect_print_dump_info (REPORT_DETAILS)) fprintf (vect_dump, "=== vect_mark_stmts_to_be_vectorized ==="); @@ -465,49 +467,64 @@ vect_mark_stmts_to_be_vectorized (loop_vec_info loop_vinfo) identify stmts that are used solely by a reduction, and therefore the order of the results that they produce does not have to be kept. */ - if (STMT_VINFO_DEF_TYPE (stmt_vinfo) == vect_reduction_def) + def_type = STMT_VINFO_DEF_TYPE (stmt_vinfo); + tmp_relevant = relevant; + switch (def_type) { - enum vect_relevant tmp_relevant = relevant; - switch (tmp_relevant) - { - case vect_unused_in_scope: - gcc_assert (gimple_code (stmt) != GIMPLE_PHI); - relevant = vect_used_by_reduction; - break; + case vect_reduction_def: + switch (tmp_relevant) + { + case vect_unused_in_scope: + relevant = vect_used_by_reduction; + break; - case vect_used_by_reduction: - if (gimple_code (stmt) == GIMPLE_PHI) - break; - /* fall through */ + case vect_used_by_reduction: + if (gimple_code (stmt) == GIMPLE_PHI) + break; + /* fall through */ - default: - if (vect_print_dump_info (REPORT_DETAILS)) - fprintf (vect_dump, "unsupported use of reduction."); - VEC_free (gimple, heap, worklist); - return false; - } + default: + if (vect_print_dump_info (REPORT_DETAILS)) + fprintf (vect_dump, "unsupported use of reduction."); - live_p = false; - } - else if (STMT_VINFO_DEF_TYPE (stmt_vinfo) == vect_nested_cycle) - { - enum vect_relevant tmp_relevant = relevant; - switch (tmp_relevant) - { - case vect_unused_in_scope: - case vect_used_in_outer_by_reduction: - case vect_used_in_outer: - break; + VEC_free (gimple, heap, worklist); + return false; + } - default: + live_p = false; + break; + + case vect_nested_cycle: + if (tmp_relevant != vect_unused_in_scope + && tmp_relevant != vect_used_in_outer_by_reduction + && tmp_relevant != vect_used_in_outer) + { if (vect_print_dump_info (REPORT_DETAILS)) fprintf (vect_dump, "unsupported use of nested cycle."); VEC_free (gimple, heap, worklist); return false; - } + } + + live_p = false; + break; + + case vect_double_reduction_def: + if (tmp_relevant != vect_unused_in_scope + && tmp_relevant != vect_used_by_reduction) + { + if (vect_print_dump_info (REPORT_DETAILS)) + fprintf (vect_dump, "unsupported use of double reduction."); + + VEC_free (gimple, heap, worklist); + return false; + } + + live_p = false; + break; - live_p = false; + default: + break; } FOR_EACH_PHI_OR_STMT_USE (use_p, stmt, iter, SSA_OP_USE) @@ -974,6 +991,7 @@ vect_get_vec_def_for_operand (tree op, gimple stmt, tree *scalar_def) /* Case 4: operand is defined by a loop header phi - reduction */ case vect_reduction_def: + case vect_double_reduction_def: case vect_nested_cycle: { struct loop *loop; diff --git a/gcc/tree-vectorizer.h b/gcc/tree-vectorizer.h index 05f5e4783f7..c7dab10c13f 100644 --- a/gcc/tree-vectorizer.h +++ b/gcc/tree-vectorizer.h @@ -61,6 +61,7 @@ enum vect_def_type { vect_internal_def, vect_induction_def, vect_reduction_def, + vect_double_reduction_def, vect_nested_cycle, vect_unknown_def_type }; @@ -822,7 +823,7 @@ extern tree vect_create_addr_base_for_vector_ref (gimple, gimple_seq *, /* In tree-vect-loop.c. */ /* FORNOW: Used in tree-parloops.c. */ extern void destroy_loop_vec_info (loop_vec_info, bool); -extern gimple vect_is_simple_reduction (loop_vec_info, gimple, bool); +extern gimple vect_is_simple_reduction (loop_vec_info, gimple, bool, bool *); /* Drive for loop analysis stage. */ extern loop_vec_info vect_analyze_loop (struct loop *); /* Drive for loop transformation stage. */ diff --git a/gcc/tree-vrp.c b/gcc/tree-vrp.c index 117b1992816..5379b7555ac 100644 --- a/gcc/tree-vrp.c +++ b/gcc/tree-vrp.c @@ -5749,8 +5749,10 @@ vrp_evaluate_conditional (enum tree_code code, tree op0, tree op1, gimple stmt) warning_at (location, OPT_Wtype_limits, integer_zerop (ret) - ? "comparison always false due to limited range of data type" - : "comparison always true due to limited range of data type"); + ? G_("comparison always false " + "due to limited range of data type") + : G_("comparison always true " + "due to limited range of data type")); } } diff --git a/gcc/tree.h b/gcc/tree.h index 2f2a65aedee..809c6e68ab8 100644 --- a/gcc/tree.h +++ b/gcc/tree.h @@ -4797,6 +4797,7 @@ extern tree build_va_arg_indirect_ref (tree); extern tree build_string_literal (int, const char *); extern bool validate_arglist (const_tree, ...); extern rtx builtin_memset_read_str (void *, HOST_WIDE_INT, enum machine_mode); +extern bool can_trust_pointer_alignment (void); extern int get_pointer_alignment (tree, unsigned int); extern bool is_builtin_name (const char*); extern int get_object_alignment (tree, unsigned int, unsigned int); diff --git a/gcc/unwind-dw2-fde-darwin.c b/gcc/unwind-dw2-fde-darwin.c index c033bbe0cb5..cd00ea22f4c 100644 --- a/gcc/unwind-dw2-fde-darwin.c +++ b/gcc/unwind-dw2-fde-darwin.c @@ -27,7 +27,7 @@ #include "tsystem.h" #include <string.h> #include <stdlib.h> -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "unwind.h" #define NO_BASE_OF_ENCODED_VALUE #define DWARF2_OBJECT_END_PTR_EXTENSION diff --git a/gcc/unwind-dw2-fde-glibc.c b/gcc/unwind-dw2-fde-glibc.c index 8f6473dbaab..418f0300108 100644 --- a/gcc/unwind-dw2-fde-glibc.c +++ b/gcc/unwind-dw2-fde-glibc.c @@ -37,7 +37,7 @@ #endif #include "coretypes.h" #include "tm.h" -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "unwind.h" #define NO_BASE_OF_ENCODED_VALUE #include "unwind-pe.h" diff --git a/gcc/unwind-dw2-fde.c b/gcc/unwind-dw2-fde.c index 6780700e6af..4aa9d82af8d 100644 --- a/gcc/unwind-dw2-fde.c +++ b/gcc/unwind-dw2-fde.c @@ -29,7 +29,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include "tsystem.h" #include "coretypes.h" #include "tm.h" -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "unwind.h" #define NO_BASE_OF_ENCODED_VALUE #include "unwind-pe.h" diff --git a/gcc/unwind-dw2.c b/gcc/unwind-dw2.c index 0ceda12a44b..68a1a282b34 100644 --- a/gcc/unwind-dw2.c +++ b/gcc/unwind-dw2.c @@ -27,7 +27,7 @@ #include "tsystem.h" #include "coretypes.h" #include "tm.h" -#include "elf/dwarf2.h" +#include "dwarf2.h" #include "unwind.h" #ifdef __USING_SJLJ_EXCEPTIONS__ # define NO_SIZE_OF_ENCODED_VALUE diff --git a/include/ChangeLog b/include/ChangeLog index 148e404957a..ef802e57fda 100644 --- a/include/ChangeLog +++ b/include/ChangeLog @@ -1,3 +1,13 @@ +2009-07-09 Jakub Jelinek <jakub@redhat.com> + + * dwarf2.h (enum dwarf_location_atom): Add DW_OP_implicit_value + and DW_OP_stack_value. + +2009-07-09 Tom Tromey <tromey@redhat.com> + + * elf/dwarf2.h: Remove, renaming to... + * dwarf2.h: ... this. + 2009-06-29 Tom Tromey <tromey@redhat.com> * elf/dwarf2.h: New file. Merged with gdb. diff --git a/include/elf/dwarf2.h b/include/dwarf2.h index f0dbfd28f72..702110406fd 100644 --- a/include/elf/dwarf2.h +++ b/include/dwarf2.h @@ -548,6 +548,10 @@ enum dwarf_location_atom DW_OP_call_frame_cfa = 0x9c, DW_OP_bit_piece = 0x9d, + /* DWARF 4 extensions. */ + DW_OP_implicit_value = 0x9e, + DW_OP_stack_value = 0x9f, + DW_OP_lo_user = 0xe0, /* Implementation-defined range start. */ DW_OP_hi_user = 0xff, /* Implementation-defined range end. */ diff --git a/libada/ChangeLog b/libada/ChangeLog index b23aa8e7b85..fc48aa148dd 100644 --- a/libada/ChangeLog +++ b/libada/ChangeLog @@ -1,3 +1,8 @@ +2009-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * configure.ac: Include multi.m4 and do not call AC_CANONICAL_SYSTEM. + * configure: Regenerate. + 2009-04-09 Jakub Jelinek <jakub@redhat.com> * Makefile.in: Change copyright header to refer to version diff --git a/libada/configure b/libada/configure index 56a4b481136..bd42f9ab622 100755 --- a/libada/configure +++ b/libada/configure @@ -1388,6 +1388,7 @@ test -n "$target_alias" && test "$program_prefix$program_suffix$program_transform_name" = \ NONENONEs,x,x, && program_prefix=${target_alias}- +target_alias=${target_alias-$host_alias} # Determine the noncanonical target name, for directory use. case ${build_alias} in @@ -1457,9 +1458,6 @@ else MAINT='#' fi; - -target_alias=${target_alias-$host_alias} - # Default to --enable-multilib # Check whether --enable-multilib or --disable-multilib was given. if test "${enable_multilib+set}" = set; then @@ -1490,6 +1488,13 @@ else fi +# Even if the default multilib is not a cross compilation, +# it may be that some of the other multilibs are. +if test $cross_compiling = no && test $multilib = yes \ + && test "x${with_multisubdir}" != x ; then + cross_compiling=maybe +fi + ac_config_commands="$ac_config_commands default-1" # Calculate toolexeclibdir @@ -3823,6 +3828,9 @@ ac_configure_args="${multilib_arg} ${ac_configure_args}" multi_basedir="$multi_basedir" CONFIG_SHELL=${CONFIG_SHELL-/bin/sh} CC="$CC" +CXX="$CXX" +GFORTRAN="$GFORTRAN" +GCJ="$GCJ" _ACEOF diff --git a/libada/configure.ac b/libada/configure.ac index 9cee1a0e7b8..12de5479e00 100644 --- a/libada/configure.ac +++ b/libada/configure.ac @@ -16,6 +16,7 @@ # <http://www.gnu.org/licenses/>. sinclude(../config/acx.m4) +sinclude(../config/multi.m4) sinclude(../config/override.m4) AC_INIT @@ -27,6 +28,7 @@ AC_CONFIG_SRCDIR([Makefile.in]) AC_CANONICAL_BUILD AC_CANONICAL_HOST AC_CANONICAL_TARGET +target_alias=${target_alias-$host_alias} # Determine the noncanonical target name, for directory use. ACX_NONCANONICAL_TARGET @@ -49,9 +51,6 @@ AC_ARG_ENABLE([maintainer-mode], [MAINT='#']) AC_SUBST([MAINT])dnl -AC_CANONICAL_SYSTEM -target_alias=${target_alias-$host_alias} - AM_ENABLE_MULTILIB(, ..) # Calculate toolexeclibdir # Also toolexecdir, though it's only used in toolexeclibdir diff --git a/libffi/ChangeLog b/libffi/ChangeLog index db0e5e67095..7ba04c24e54 100644 --- a/libffi/ChangeLog +++ b/libffi/ChangeLog @@ -1,3 +1,11 @@ +2009-07-11 Richard Sandiford <rdsandiford@googlemail.com> + + PR testsuite/40699 + PR testsuite/40707 + PR testsuite/40709 + * testsuite/lib/libffi-dg.exp: Revert 2009-07-02, 2009-07-01 and + 2009-06-30 commits. + 2009-07-01 Richard Sandiford <r.sandiford@uk.ibm.com> * testsuite/lib/libffi-dg.exp (libffi-init): Set ld_library_path diff --git a/libffi/testsuite/lib/libffi-dg.exp b/libffi/testsuite/lib/libffi-dg.exp index a5e23e28953..8db38c286a8 100644 --- a/libffi/testsuite/lib/libffi-dg.exp +++ b/libffi/testsuite/lib/libffi-dg.exp @@ -107,16 +107,33 @@ proc libffi-init { args } { set blddircxx [lookfor_file [get_multilibs] libstdc++-v3] verbose "libstdc++ $blddircxx" - set ld_library_path "" set gccdir [lookfor_file $tool_root_dir gcc/libgcc.a] if {$gccdir != ""} { set gccdir [file dirname $gccdir] - add_path ld_library_path [find_libgcc_s "$gccdir/xgcc"] + } + verbose "gccdir $gccdir" + + set ld_library_path "." + append ld_library_path ":${gccdir}" + + set compiler "${gccdir}/xgcc" + if { [is_remote host] == 0 && [which $compiler] != 0 } { + foreach i "[exec $compiler --print-multi-lib]" { + set mldir "" + regexp -- "\[a-z0-9=_/\.-\]*;" $i mldir + set mldir [string trimright $mldir "\;@"] + if { "$mldir" == "." } { + continue + } + if { [llength [glob -nocomplain ${gccdir}/${mldir}/libgcc_s*.so.*]] >= 1 } { + append ld_library_path ":${gccdir}/${mldir}" + } + } } # add the library path for libffi. - add_path ld_library_path "${blddirffi}/.libs" + append ld_library_path ":${blddirffi}/.libs" # add the library path for libstdc++ as well. - add_path ld_library_path "${blddircxx}/src/.libs" + append ld_library_path ":${blddircxx}/src/.libs" verbose "ld_library_path: $ld_library_path" diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 7ea4129aed2..932c85efd7c 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,15 @@ +2009-07-12 Tobias Burnus <burnus@net-b.de> + + PR libfortran/22423 + * io/io.h (namelist_type): Use the proper enum for GFC_DTYPE_*. + * intrinsics/iso_c_binding.c (c_f_pointer_u0): Make sure + variable is initialized to silence warning. + +2009-07-10 Steven G. Kargl <kargl@gcc.gnu.org> + + * c99_functions.c (ccoshf, ccosh, ccoshl, ctanhf, ctanh, ctanl): + Fix errant minus. + 2009-07-08 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR libfortran/40330 diff --git a/libgfortran/intrinsics/c99_functions.c b/libgfortran/intrinsics/c99_functions.c index d4ed17fc1b0..63af2a51f3a 100644 --- a/libgfortran/intrinsics/c99_functions.c +++ b/libgfortran/intrinsics/c99_functions.c @@ -1165,7 +1165,7 @@ csinhl (long double complex a) #endif -/* cosh(a + i b) = cosh(a) cos(b) - i sinh(a) sin(b) */ +/* cosh(a + i b) = cosh(a) cos(b) + i sinh(a) sin(b) */ #if !defined(HAVE_CCOSHF) #define HAVE_CCOSHF 1 float complex @@ -1176,7 +1176,7 @@ ccoshf (float complex a) r = REALPART (a); i = IMAGPART (a); - COMPLEX_ASSIGN (v, coshf (r) * cosf (i), - (sinhf (r) * sinf (i))); + COMPLEX_ASSIGN (v, coshf (r) * cosf (i), sinhf (r) * sinf (i)); return v; } #endif @@ -1191,7 +1191,7 @@ ccosh (double complex a) r = REALPART (a); i = IMAGPART (a); - COMPLEX_ASSIGN (v, cosh (r) * cos (i), - (sinh (r) * sin (i))); + COMPLEX_ASSIGN (v, cosh (r) * cos (i), sinh (r) * sin (i)); return v; } #endif @@ -1206,13 +1206,13 @@ ccoshl (long double complex a) r = REALPART (a); i = IMAGPART (a); - COMPLEX_ASSIGN (v, coshl (r) * cosl (i), - (sinhl (r) * sinl (i))); + COMPLEX_ASSIGN (v, coshl (r) * cosl (i), sinhl (r) * sinl (i)); return v; } #endif -/* tanh(a + i b) = (tanh(a) + i tan(b)) / (1 - i tanh(a) tan(b)) */ +/* tanh(a + i b) = (tanh(a) + i tan(b)) / (1 + i tanh(a) tan(b)) */ #if !defined(HAVE_CTANHF) #define HAVE_CTANHF 1 float complex @@ -1224,7 +1224,7 @@ ctanhf (float complex a) rt = tanhf (REALPART (a)); it = tanf (IMAGPART (a)); COMPLEX_ASSIGN (n, rt, it); - COMPLEX_ASSIGN (d, 1, - (rt * it)); + COMPLEX_ASSIGN (d, 1, rt * it); return n / d; } @@ -1241,7 +1241,7 @@ ctanh (double complex a) rt = tanh (REALPART (a)); it = tan (IMAGPART (a)); COMPLEX_ASSIGN (n, rt, it); - COMPLEX_ASSIGN (d, 1, - (rt * it)); + COMPLEX_ASSIGN (d, 1, rt * it); return n / d; } @@ -1258,7 +1258,7 @@ ctanhl (long double complex a) rt = tanhl (REALPART (a)); it = tanl (IMAGPART (a)); COMPLEX_ASSIGN (n, rt, it); - COMPLEX_ASSIGN (d, 1, - (rt * it)); + COMPLEX_ASSIGN (d, 1, rt * it); return n / d; } diff --git a/libgfortran/intrinsics/iso_c_binding.c b/libgfortran/intrinsics/iso_c_binding.c index bb25e3e2d4f..0dd7449df6d 100644 --- a/libgfortran/intrinsics/iso_c_binding.c +++ b/libgfortran/intrinsics/iso_c_binding.c @@ -113,26 +113,36 @@ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in, /* Have to allow for the SHAPE array to be any valid kind for an INTEGER type. */ + switch (size) + { #ifdef HAVE_GFC_INTEGER_1 - if (size == 1) - ub = *((GFC_INTEGER_1 *) p); + case 1: + ub = *((GFC_INTEGER_1 *) p); + break; #endif #ifdef HAVE_GFC_INTEGER_2 - if (size == 2) - ub = *((GFC_INTEGER_2 *) p); + case 2: + ub = *((GFC_INTEGER_2 *) p); + break; #endif #ifdef HAVE_GFC_INTEGER_4 - if (size == 4) - ub = *((GFC_INTEGER_4 *) p); + case 4: + ub = *((GFC_INTEGER_4 *) p); + break; #endif #ifdef HAVE_GFC_INTEGER_8 - if (size == 8) - ub = *((GFC_INTEGER_8 *) p); + case 8: + ub = *((GFC_INTEGER_8 *) p); + break; #endif #ifdef HAVE_GFC_INTEGER_16 - if (size == 16) - ub = *((GFC_INTEGER_16 *) p); + case 16: + ub = *((GFC_INTEGER_16 *) p); + break; #endif + default: + internal_error (NULL, "c_f_pointer_u0: Invalid size"); + } p += source_stride; if (i == 0) diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 088969a0fca..2a077629a6d 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -163,7 +163,7 @@ format_hash_entry; typedef struct namelist_type { /* Object type, stored as GFC_DTYPE_xxxx. */ - bt type; + dtype type; /* Object name. */ char * var_name; diff --git a/libgomp/ChangeLog b/libgomp/ChangeLog index 6d36e309ebb..89157021e97 100644 --- a/libgomp/ChangeLog +++ b/libgomp/ChangeLog @@ -1,3 +1,12 @@ +2009-07-11 Richard Sandiford <rdsandiford@googlemail.com> + + PR testsuite/40699 + PR testsuite/40707 + PR testsuite/40709 + * testsuite/lib/libgomp.exp: Revert 2009-07-02 and 2009-06-30 commits. + * testsuite/libgomp.c/c.exp, testsuite/libgomp.c++/c++.exp, + testsuite/libgomp.fortran/fortran.exp: Revert 2009-06-30 commits. + 2009-07-02 Richard Sandiford <r.sandiford@uk.ibm.com> * testsuite/lib/libgomp.exp (libgomp_init): Use the ALWAYS_CFLAGS diff --git a/libgomp/testsuite/lib/libgomp.exp b/libgomp/testsuite/lib/libgomp.exp index 4712de23e32..972d4a1fdd3 100644 --- a/libgomp/testsuite/lib/libgomp.exp +++ b/libgomp/testsuite/lib/libgomp.exp @@ -86,6 +86,40 @@ proc libgomp_init { args } { set CFLAGS "" } + # Locate libgcc.a so we don't need to account for different values of + # SHLIB_EXT on different platforms + set gccdir [lookfor_file $tool_root_dir gcc/libgcc.a] + if {$gccdir != ""} { + set gccdir [file dirname $gccdir] + } + + # Compute what needs to be put into LD_LIBRARY_PATH + set always_ld_library_path ".:${blddir}/.libs" + + # Compute what needs to be added to the existing LD_LIBRARY_PATH. + if {$gccdir != ""} { + # Add AIX pthread directory first. + if { [llength [glob -nocomplain ${gccdir}/pthread/libgcc_s*.a]] >= 1 } { + append always_ld_library_path ":${gccdir}/pthread" + } + append always_ld_library_path ":${gccdir}" + set compiler [lindex $GCC_UNDER_TEST 0] + + if { [is_remote host] == 0 && [which $compiler] != 0 } { + foreach i "[exec $compiler --print-multi-lib]" { + set mldir "" + regexp -- "\[a-z0-9=_/\.-\]*;" $i mldir + set mldir [string trimright $mldir "\;@"] + if { "$mldir" == "." } { + continue + } + if { [llength [glob -nocomplain ${gccdir}/${mldir}/libgcc_s*.so.*]] >= 1 } { + append always_ld_library_path ":${gccdir}/${mldir}" + } + } + } + } + set ALWAYS_CFLAGS "" if { $blddir != "" } { lappend ALWAYS_CFLAGS "additional_flags=-B${blddir}/" @@ -119,16 +153,6 @@ proc libgomp_init { args } { # And, gee, turn on OpenMP. lappend ALWAYS_CFLAGS "additional_flags=-fopenmp" - - set compiler $GCC_UNDER_TEST - foreach flag $ALWAYS_CFLAGS { - if { [regexp {^(additional_flags|ldflags)=(.*)} $flag d1 d2 option] } { - lappend compiler $option - } - } - - set always_ld_library_path "${blddir}/.libs" - add_path always_ld_library_path [find_libgcc_s $compiler] } # diff --git a/libgomp/testsuite/libgomp.c++/c++.exp b/libgomp/testsuite/libgomp.c++/c++.exp index 92b8146e505..decda3d1a12 100644 --- a/libgomp/testsuite/libgomp.c++/c++.exp +++ b/libgomp/testsuite/libgomp.c++/c++.exp @@ -37,10 +37,12 @@ if { $lang_test_file_found } { # Gather a list of all tests. set tests [lsort [glob -nocomplain $srcdir/$subdir/*.C]] - set ld_library_path $always_ld_library_path if { $blddir != "" } { - add_path ld_library_path "${blddir}/${lang_library_path}" + set ld_library_path "$always_ld_library_path:${blddir}/${lang_library_path}" + } else { + set ld_library_path "$always_ld_library_path" } + append ld_library_path [gcc-set-multilib-library-path $GCC_UNDER_TEST] set_ld_library_path_env_vars set flags_file "${blddir}/../libstdc++-v3/scripts/testsuite_flags" diff --git a/libgomp/testsuite/libgomp.c/c.exp b/libgomp/testsuite/libgomp.c/c.exp index e304f560a5a..980bb526f3f 100644 --- a/libgomp/testsuite/libgomp.c/c.exp +++ b/libgomp/testsuite/libgomp.c/c.exp @@ -20,6 +20,7 @@ dg-init set tests [lsort [find $srcdir/$subdir *.c]] set ld_library_path $always_ld_library_path +append ld_library_path [gcc-set-multilib-library-path $GCC_UNDER_TEST] set_ld_library_path_env_vars # Main loop. diff --git a/libgomp/testsuite/libgomp.fortran/fortran.exp b/libgomp/testsuite/libgomp.fortran/fortran.exp index a1042d1f351..3d6615ffee7 100644 --- a/libgomp/testsuite/libgomp.fortran/fortran.exp +++ b/libgomp/testsuite/libgomp.fortran/fortran.exp @@ -26,10 +26,12 @@ if { $lang_test_file_found } { # Gather a list of all tests. set tests [lsort [find $srcdir/$subdir *.\[fF\]{,90,95,03,08}]] - set ld_library_path $always_ld_library_path if { $blddir != "" } { - add_path ld_library_path "${blddir}/${lang_library_path}" + set ld_library_path "$always_ld_library_path:${blddir}/${lang_library_path}" + } else { + set ld_library_path "$always_ld_library_path" } + append ld_library_path [gcc-set-multilib-library-path $GCC_UNDER_TEST] set_ld_library_path_env_vars # Main loop. diff --git a/libjava/ChangeLog b/libjava/ChangeLog index 3934d4e6983..cad3e377fe7 100644 --- a/libjava/ChangeLog +++ b/libjava/ChangeLog @@ -1,3 +1,10 @@ +2009-07-11 Richard Sandiford <rdsandiford@googlemail.com> + + PR testsuite/40699 + PR testsuite/40707 + PR testsuite/40709 + * testsuite/lib/libjava.exp: Revert 2009-06-30 commit. + 2009-06-30 Richard Sandiford <r.sandiford@uk.ibm.com> * testsuite/lib/libjava.exp (libjava_init): Just add diff --git a/libjava/testsuite/lib/libjava.exp b/libjava/testsuite/lib/libjava.exp index 95a3138ce3d..510e4ac80d8 100644 --- a/libjava/testsuite/lib/libjava.exp +++ b/libjava/testsuite/lib/libjava.exp @@ -197,8 +197,36 @@ proc libjava_init { args } { } # Finally, add the gcc build directory so that we can find the - # shared libgcc. - set libjava_libgcc_s_path [find_libgcc_s $GCJ_UNDER_TEST] + # shared libgcc. This, like much of dejagnu, is hideous. + set libjava_libgcc_s_path {} + + if { [istarget "*-*-darwin*"] } { + set so_extension "dylib" + } elseif { [istarget "*-*-cygwin*"] || [istarget "*-*-mingw*"] } { + set so_extension "dll" + } else { + set so_extension "so" + } + set gccdir [lookfor_file $tool_root_dir gcc/libgcc_s.${so_extension}] + if {$gccdir != ""} { + set gccdir [file dirname $gccdir] + lappend libjava_libgcc_s_path $gccdir + verbose "libjava_libgcc_s_path = $libjava_libgcc_s_path" + set compiler ${gccdir}/xgcc + if { [is_remote host] == 0 && [which $compiler] != 0 } { + foreach i "[exec $compiler --print-multi-lib]" { + set mldir "" + regexp -- "\[a-z0-9=_/\.-\]*;" $i mldir + set mldir [string trimright $mldir "\;@"] + if { "$mldir" == "." } { + continue + } + if { [llength [glob -nocomplain ${gccdir}/${mldir}/libgcc_s*.${so_extension}.*]] >= 1 } { + lappend libjava_libgcc_s_path "${gccdir}/${mldir}" + } + } + } + } set libjava_initialized 1 } @@ -309,8 +337,6 @@ proc libjava_arguments {{mode compile}} { # Basically we want to build up a colon separated path list from # the value of $libjava. - # Add "." to the list so that we pick up shared libraries created - # by the testsuite itself. set lpath "." foreach dir [list $libjava] { foreach item [split $dir " "] { @@ -444,8 +470,8 @@ proc gcj_invoke {program expectFile ld_library_additions} { global ld_library_path set ld_library_path "$libjava_ld_library_path" - foreach path $ld_library_additions { - add_path ld_library_path $path + if {[llength $ld_library_additions] > 0} { + append ld_library_path :[join $ld_library_additions :] } set_ld_library_path_env_vars @@ -486,8 +512,8 @@ proc exec_gij {jarfile expectFile {ld_library_additions {}} {addl_flags {}}} { global ld_library_path set ld_library_path "$libjava_ld_library_path" - foreach path $ld_library_additions { - add_path ld_library_path $path + if {[llength $ld_library_additions] > 0} { + append ld_library_path :[join $ld_library_additions :] } set_ld_library_path_env_vars @@ -536,8 +562,8 @@ proc libjava_invoke {errname testName optName executable inpfile resultfile global ld_library_path set ld_library_path "$libjava_ld_library_path" - foreach path $ld_library_additions { - add_path ld_library_path $path + if {[llength $ld_library_additions] > 0} { + append ld_library_path :[join $ld_library_additions :] } set_ld_library_path_env_vars diff --git a/libmudflap/ChangeLog b/libmudflap/ChangeLog index 75031657d06..78507bc017b 100644 --- a/libmudflap/ChangeLog +++ b/libmudflap/ChangeLog @@ -1,3 +1,10 @@ +2009-07-11 Richard Sandiford <rdsandiford@googlemail.com> + + PR testsuite/40699 + PR testsuite/40707 + PR testsuite/40709 + * testsuite/lib/libmudflap.exp: Revert 2009-06-30 commit. + 2009-07-01 Richard Guenther <rguenther@suse.de> PR tree-optimization/19831 diff --git a/libmudflap/testsuite/lib/libmudflap.exp b/libmudflap/testsuite/lib/libmudflap.exp index da91643a7b2..c69e84ade29 100644 --- a/libmudflap/testsuite/lib/libmudflap.exp +++ b/libmudflap/testsuite/lib/libmudflap.exp @@ -60,9 +60,28 @@ proc libmudflap-init { language } { # set LD_LIBRARY_PATH so that libgcc_s, libstdc++ binaries can be found. # locate libgcc.a so we don't need to account for different values of # SHLIB_EXT on different platforms - set ld_library_path [find_libgcc_s $cxx] - add_path ld_library_path "${cxxblddir}/src/.libs" - add_path ld_library_path "${blddir}/.libs" + set gccdir [lookfor_file $tool_root_dir gcc/libgcc.a] + if {$gccdir != ""} { + set gccdir [file dirname $gccdir] + } + + set ld_library_path "." + append ld_library_path ":${gccdir}" + append ld_library_path ":${cxxblddir}/src/.libs" + if {[is_remote host] == 0} { + foreach i "[exec ${gccdir}/xgcc --print-multi-lib]" { + set mldir "" + regexp -- "\[a-z0-9=_/\.-\]*;" $i mldir + set mldir [string trimright $mldir "\;@"] + if { "$mldir" == "." } { + continue + } + if { [llength [glob -nocomplain ${gccdir}/${mldir}/libgcc_s*.so.*]] >= 1 } { + append ld_library_path ":${gccdir}/${mldir}" + } + } + } + append ld_library_path ":${blddir}/.libs" set libs "-L${blddir}/.libs" set cxxflags "-ggdb3 -DDEBUG_ASSERT" diff --git a/libstdc++-v3/ChangeLog b/libstdc++-v3/ChangeLog index 35a856414f1..97a165d7127 100644 --- a/libstdc++-v3/ChangeLog +++ b/libstdc++-v3/ChangeLog @@ -1,3 +1,15 @@ +2009-07-12 Paolo Carlini <paolo.carlini@oracle.com> + + * include/std/type_traits (common_type): Remove workaround for + PR36628, now fixed. + +2009-07-11 Richard Sandiford <rdsandiford@googlemail.com> + + PR testsuite/40699 + PR testsuite/40707 + PR testsuite/40709 + * testsuite/lib/libstdc++.exp: Revert 2009-06-30 commit. + 2009-07-08 Janis Johnson <janis187@us.ibm.com> PR libstdc++/40691 diff --git a/libstdc++-v3/include/std/type_traits b/libstdc++-v3/include/std/type_traits index ce9ee1b06f8..94c40df97b8 100644 --- a/libstdc++-v3/include/std/type_traits +++ b/libstdc++-v3/include/std/type_traits @@ -580,13 +580,8 @@ namespace std static _Tp&& __t(); static _Up&& __u(); - // HACK: Prevents optimization of ?: in the decltype - // expression when the condition is the literal, "true". - // See, PR36628. - static bool __true_or_false(); - public: - typedef decltype(__true_or_false() ? __t() : __u()) type; + typedef decltype(true ? __t() : __u()) type; }; template<typename _Tp, typename _Up, typename... _Vp> diff --git a/libstdc++-v3/testsuite/lib/libstdc++.exp b/libstdc++-v3/testsuite/lib/libstdc++.exp index 99adce94fa3..45e92d756ec 100644 --- a/libstdc++-v3/testsuite/lib/libstdc++.exp +++ b/libstdc++-v3/testsuite/lib/libstdc++.exp @@ -132,6 +132,7 @@ proc libstdc++_init { testfile } { set gccdir [lookfor_file $tool_root_dir gcc/libgcc.a] if {$gccdir != ""} { set gccdir [file dirname $gccdir] + append ld_library_path_tmp ":${gccdir}" } v3track gccdir 3 @@ -141,7 +142,7 @@ proc libstdc++_init { testfile } { if {$libgompdir != ""} { set v3-libgomp 1 set libgompdir [file dirname $libgompdir] - add_path ld_library_path_tmp ${libgompdir} + append ld_library_path_tmp ":${libgompdir}" verbose -log "libgomp support detected" } v3track libgompdir 3 @@ -161,8 +162,22 @@ proc libstdc++_init { testfile } { if {$gccdir != ""} { set compiler ${gccdir}/g++ set ld_library_path ${ld_library_path_tmp} - add_path ld_library_path "${blddir}/src/.libs" - add_path ld_library_path [find_libgcc_s $compiler] + append ld_library_path ":${blddir}/src/.libs" + + if { [is_remote host] == 0 && [which $compiler] != 0 } { + foreach i "[exec $compiler --print-multi-lib]" { + set mldir "" + regexp -- "\[a-z0-9=_/\.-\]*;" $i mldir + set mldir [string trimright $mldir "\;@"] + if { "$mldir" == "." } { + continue + } + if { [llength [glob -nocomplain ${gccdir}/${mldir}/libgcc_s*.so.*]] >= 1 } { + append ld_library_path ":${gccdir}/${mldir}" + } + } + } + set_ld_library_path_env_vars if [info exists env(LD_LIBRARY_PATH)] { verbose -log "LD_LIBRARY_PATH = $env(LD_LIBRARY_PATH)" |